pascal цвета

Ответ от Bogdan Kasatkin[мастер]
Непугатся :)) Предупреждаю это писал не я: )
interface
{ установка параметров вывода текста }
procedure SetTextParm(color,bkcolor,typetext:byte);
{ color - цвет текста }
{ bkcolor - цвет фона }
{ typetext = 0 - прозрачный фон }
{ typetext = 1 - непрозрачный фон }
{ запрос текущих параметров }
procedure GetTextParm(var color,bkcolor,typetext:byte);
{вывод текста по координатам x,y (верхний левый угол) }
procedure PutText(x,y:word;text:string);
{вывод символа по координатам x,y (верхний левый угол) }
procedure PutChar(x,y:word;chr:char);
implementation
uses dos;
type
FTType = array[0..255,0..7]of byte; {для шрифта}
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 : ^FTType; {таблица шрифта}
Color1,bkColor1 : byte;
{номера <стандартных> цветов текста и фона}
Color2,bkColor2 : byte;
{номера цветов текста и фона в выбранной палитре}
TextType : byte; {способ вывода (прозрачно или нет) }
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:word;text:string);
var
i:word;
begin
if(byte(text[0])>0)then
for i := 1 to byte(text[0]) do
putchar(x+8*(i-1),y,text)
end;
procedure PutPixel(x,y:word;c:byte); {вывод точки}
begin
mem[SegA000:x+y*320] := c;
end;
function getpixel(x,y:word):byte; {запрос цвета точки}
begin
getpixel := mem[SegA000:x+y*320];
end;
procedure putchar(x,y:word;chr:char);
var
i,j,k,l : word;
cc,bb : byte;
begin
l := byte(chr);
case TextType of
0: for i := 0 to 7 do { прозрачный фон }
for j := 0 to 7 do
if (FontTable^[l,i] and
(1 shl (7-j)) <> 0) then
putpixel(x+j,y+i,Color2);
1: for i := 0 to 7 do { непрозрачный фон }
for j := 0 to 7 do
if (FontTable^[l,i] and
(1 shl (7-j)) <> 0) then
putpixel(x+j,y+i,Color2)
else putpixel(x+j,y+i,bkColor2);
end;
end;
var r : registers;
begin {инициализация - получаем адрес таблицы шрифтов}
r.ax := $1130;
r.bh := 3;
intr($10,r);
FontTable := ptr(r.es,r.bp);
Color1 := 15; {заносим величины по умолчанию}
bkColor1 := 0;
TextType := 1;
Color2 := Colors[Color1];
bkColor2 := Colors[bkColor1];
end.

Ответ от 3 ответа[гуру]

Ответ от 3 ответа[гуру]