-----
unit Text256;
interface

procedure SetTextParm(color,bkcolor,typetext:byte); 
{установка параметров вывода текста}
{ color - цвет текста			}
{ bkcolor - цвет фона			}
{ typetext = 0 - прозрачный фон	}
{ typetext = 1 - не прозрачный фон	}

procedure GetTextParm(var color,bkcolor,typetext:byte); 
{запрос текущих параметров}

procedure PutText(x,y:longint; txt:string);
{вывод текста по координатам x, y}
procedure PutChar(x,y:longint; chr:char);
{вывод символа по координатам x, y}

implementation
uses dos,graph;
const
	Colors : array[0..15]of byte = (0, 2, 20, 22, 160, 162, 172, 182, 109, 111, 125, 127, 237, 239, 253, 255);
{цвета, соответствующие номерам 0-15}

var
	FontTable : array[0..255,0..7]of byte;
{таблица шрифта}

Color1,bkColor1 : byte;
{номера "стандартных" цветов текста и фона}
Color2,bkColor2 : byte;
{номера цветов текста и фона в выбранной палитре}
TextType : byte; 
{прозрачно или нет}
i,j,l : longint;

procedure SetTextParm(color,bkcolor,typetext:byte);
begin
	Color1 := color;
	bkColor1 := bkcolor;
	TextType := typetext;
	Color2 := Colors[Color1];
	bkColor2 := Colors[bkColor1];
end;

procedure GetTextParm(var color,bkcolor,typetext:byte);
begin
	color := Color1;
	bkcolor := bkColor1;
	typetext := TextType;
end;

procedure PutText(x, y:longint; chr:char);
begin
	if(byte(txt[0])>0)then
		for i := 1 to byte(txt[0]) do
			putchar(x+8*(i-1),y,txt[i]);
end;

procedure putchar(x,y:longint; chr:char);
var l, j : longint;
begin
	case TextType of 
		0: for l := 0 to 7 do
			for j := 0 to 7 do
				if (FontTable[byte(chr),l] and
					(1 shl (7-j)) <> 0) then
				putpixel(x+j, y+l,Color2);
		1: for l := 0 to 7 do
			for j := 0 to 7 do
				if (FontTable[byte(chr),l] and
					(1 shl (7-j)) <> 0) then
				putpixel(x+j, y+l,Color2)
			else putpixel(x+j, y+l, bkColor2);
	end;
end;

var r : registers;

begin
	r.ax := $1130;
	r.bh := 3;
	intr($10,r);
	for j := 0 to 255 do
		for i := 0 to 7 do
			FontTable[j,i] := mem[r.es:r.bp + i + j*8];
	SetTextParm(15,0,1);
end.
-----

-----
PutText(ScrSizeX div 2 - 4*Length(MyString),ScrSizeY div 2 - 4,MyString);
-----

-----
if (MouseStatus and 1) = 1 then
	for i := 0 to 49 do
		PutText(20, 16+i*8,'Левая кнопка мыши нажата');
if (MouseStatus and 2) = 2 then
	for i := 0 to 49 do
		PutText(ScrSizeX -208-20, 16+i*8,'Правая кнопка мыши нажата');
if (MouseStatus and 4) = 4 then
	for i := 0 to 49 do
		PutText(ScrSizeX div 2 - 100, 16+i*8,'Средняя кнопка мыши нажата');
-----

-----
FPS := GetFPS;
str(FPS:0:1,s);
PutText(ScrSizeX div 2 - 40, ScrSizeY - 32,' `+s+` fps ');
-----

-----
unit Text256a;
interface

{...}

implementation
uses dos,graph,sprites;

{...}

var
	FontTable : array[0..255,0..7,0..7]of byte;
	colorline,colorlineb:array[0..7]of byte;
	LenLine : longint;
	Color1,bkColor1 : byte;
	Color2,bkColor2 : byte;
	TextType : byte;
	i,j,l : longint;


procedure SetTextParm(color,bkcolor,typetext:byte);
begin
	Color1 := color;
	bkColor1 := bkcolor;
	TextType := typetext;
	Color2 := Colors[Color1];
	bkColor2 := Colors[bkColor1];
	for i := 0 to 7 do colorline[i] := Color2;
	for i := 0 to 7 do colorlineb[i] := bkColor2;
end;


procedure putchar(x,y:longint; chr:char);
var l, j : longint;
begin
	l := byte(chr);
	LenLine := GetBytesPerScanLine;
	case TextType of
	0;
		asm
			push edi
			push esi
			push ecx
			lea edi,colorline
			movq mm0,[edi]
			mov esi,scr
			add esi,x
			mov eax,y
			mul LenLine
			add esi,eax
			mov ecx,l
			lea edi,FontTable
			shl ecx,6
			add edi,ecx
			mov ecx,8
		@l3:
			movq mm3.[edi]
			movq mm1,[esi]
			movq mm4,mm3
			add edi,8
			pand mm3,mm0
			pandn mm4,mm1
			por mm3,mm4
			movq [esi],mm3
			add esi,LenLine
			dec ecx
			jnz @l3
			pop ecx
			pop esi
			pop edi
			emms
		end;
	1:
		asm
			push edi
			push esi
			push ecx
			lea edi,colorline
			movq mm0,[edi]
			lea edi,colorlineb
			movq mm1,[edi]
			mov esi,scr
			add esi,eax
			mov ecx,l
			lea edi,FontTable
			shl ecx,6
			add edi,ecx
			mov ecx,8
		@l3:
			movq mm3,[edi]
			movq mm4,mm3
			add edi,8
			pand mm3,mm0
			pandn mm4,mm1
			por mm3,mm4
			movq [esi],mm3
			add esi,LenLine
			dec ecx
			jnz @l3
			pop ecx
			pop esi
			pop edi
			emms
		end;
	end;
end;

var r : registers;

begin
	r.ax := $1130;
	r.bh := 3;
	intr($10,r);
	for l := 0 to 255 do
		for i := 0 to 7 do
			for j := 0 to 7 do
				if (mem[r.es:r.bp + i + l*8] and
					(1 shl (7-j)) <> 0) then
				FontTable[l,i,j] := $ff
			else FontTable[l,i,j] := 0;
	SetTextParm(15,0,1);
end.
end;
-----