{ Отзывы присылайте на склад нитроманита nitromanit@mail.ru

  Данная утилита позваляет в режиме VGA 320x200 256 цветов
  выводить шрифты, масштабировать картинки, менять цвета
  один на другой

  Примером служит исходник моего графического редактора
  VG-NOW его можно выкачать там же где и эту утилиту  
}

{$G+}
Unit geffect;

interface

function FontResult:word;
function FontResMsg(a:word):string;
function get_fontfilesize(x,y:byte):word;
function FontInfo(fname:string;var sizeX,sizeY:byte;var long:word):word;
function GetWighthX(fnt:word):word;
function GetWighthY(fnt:word):word;
function loadfont(fname:string;var buf):word;
procedure clearimagebuf(count:word;color:byte;var buf);
procedure hsimbol(x,y:word;color,wighthX,wighthY,achar:byte;var buf);
procedure print(fontnum,x,y:word;color:byte;str:string);
procedure window_color_excheng(x1,y1,x2,y2:word;newc,oldc:byte);
procedure resize_blk(x1,y1,x2,y2:word;var buf);

implementation

type
       Tfont=array [0..2048] of byte;
       TFontIndex=record
                  sizeX,sizeY:byte;
                  fontbuf:^Tfont;
                  end;

var   fonttab:array [1..10] of TFontIndex;
      fres,d:word;
      f:file;

const longftab:word=0; {0-fonttable empty}

function FontResult:word;
begin
FontResult:=fres;
end;

function FontResMsg(a:word):string;
var s:string;
begin
  case a of
    0:s:='Ok';
    2:s:='Font not found';
    3:s:='Path not found';
    4:s:='Files open too much';
    5:s:='Access denied';
   12:s:='Incorrect access code to file';
   50:s:='Font table is full';
  else s:='Error';
  end;
FontResMsg:=s;
end;

function get_fontfilesize(x,y:byte):word;
var intx,inty:byte;
begin
intx:=1;inty:=8;
if (X<=8) and (Y<=8) then begin intx:=1;inty:=8;end
   else begin intx:=2;inty:=16;end;
get_fontfilesize:=intX*intY*256+2;
end;

function FontInfo(fname:string;var sizeX,sizeY:byte;var long:word):word;
var intx,inty:byte;
begin
   assign(f,Fname);{$i-}
   reset(f,1);     {$i+}
   fres:=ioresult;
   if fres<>0 then begin FontInfo:=0;exit;end;
   blockread(f,sizeX,1,d);
   blockread(f,sizeY,1,d);
   close(f);
   if sizeX<=8 then intx:=1
      else if sizeX<=16 then intx:=2;
   if sizeY<=8 then inty:=8
      else if sizeY<=16 then inty:=16;
   long:=get_fontfilesize(sizeX,sizeY); {intX*intY*256+2;}
end;

function GetWighthX(fnt:word):word;
begin
GetWighthX:=fonttab[fnt].sizeX;
end;

function GetWighthY(fnt:word):word;
begin
GetWighthY:=fonttab[fnt].sizeY;
end;

function loadfont1(fname:string;var buf):word; {0-error,if not error number font of FontTable}
begin
if longftab=10 then begin
   fres:=50;loadfont1:=0;exit;end;
   assign(f,Fname);{$i-}
   reset(f,1);     {$i+}
   fres:=ioresult;
   if fres<>0 then begin loadfont1:=0;exit;end;
   inc(longftab);
   blockread(f,fonttab[longftab].sizeX,1,d);
   blockread(f,fonttab[longftab].sizeY,1,d);
   blockread(f,buf,get_fontfilesize(fonttab[longftab].sizeX,
   fonttab[longftab].sizeY),d); {2048}
   close(f);
   fonttab[longftab].fontbuf:=@buf;
   loadfont1:=longftab;
end;

function loadfont(fname:string;var buf):word; {0-error,if not error number font of FontTable}
var i,num:word;
begin
num:=0;
if longftab=10 then begin
   fres:=50;loadfont:=0;exit;end;
   assign(f,Fname);{$i-}
   reset(f,1);     {$i+}
   fres:=ioresult;
   if fres<>0 then begin loadfont:=0;exit;end;
   for i:=1 to 10 do
     if fonttab[i].fontbuf=@buf then num:=i;
   if num=0 then begin inc(longftab);num:=longftab;end;
   blockread(f,fonttab[num].sizeX,1,d);
   blockread(f,fonttab[num].sizeY,1,d);
   blockread(f,buf,get_fontfilesize(fonttab[num].sizeX,
   fonttab[num].sizeY),d); {2048}
   close(f);
   fonttab[num].fontbuf:=@buf;
   loadfont:=num;
end;

procedure clearimagebuf(count:word;color:byte;var buf);assembler;
asm
        push es
        push cx
        les si,buf
        add si,4
        {mov ax,320
        cld
        stosw
        mov ax,200
        stosw}
        {xor ax,ax}
        mov al,color
        mov cx,count
    rep stosb
        pop cx
        pop es
end;

procedure hsimbol1(x,y:word;color,wighth,achar:byte;var buf);assembler;
var interval_y,interval_x:word;
    a:byte;
asm
           les si,buf
           mov interval_y,8
           xor ax,ax
           mov al,achar
	   shl ax,1
           shl ax,1
           shl ax,1
           add si,ax
	   mov ah,0
     @utar:push x
           xor cx,cx
           mov cl,8   {;8}
           mov al,es:[si]
           mov a,al
           inc si
           dec interval_y
    @rowdg:shl ax,1
	   cmp ah,0
           je @ometa
           push ax
           push es
           push di
           mov ax,y
           shl ax,1
           shl ax,1
           mov di,ax
           shl ax,1
           shl ax,1
           add ax,di	
           add ax,0A000h
           mov es,ax
           mov di,x
           mov al,color
           mov es:[di],al
           pop di
           pop es
           pop ax
    @ometa:mov ah,0
           inc x
	   loop @rowdg
           inc y
           pop x
           cmp interval_y,0
           jne @utar
end;

procedure hsimbol(x,y:word;color,wighthX,wighthY,achar:byte;var buf);
var interval_y,interval_x:word;
    a:byte;
begin
if (wighthX<=8) and (wighthY<=8) then
 asm
           les si,buf
           xor ax,ax
           mov al,wighthY
           mov interval_y,ax
           xor ax,ax
           mov al,achar
	   shl ax,3
           add si,ax
	   mov ah,0
     @utar:push x
           xor cx,cx
           mov cl,8
           mov al,es:[si]
           inc si
           dec interval_y
    @rowdg:shl al,1
	   {cmp ah,0
           je @ometa}
           jnc @ometa
           push ax
           push es
           push di
           mov ax,y
           shl ax,2
           mov di,ax
           shl ax,2
           add ax,di
           add ax,0A000h
           mov es,ax
           mov di,x
           mov al,color
           mov es:[di],al
           pop di
           pop es
           pop ax
    @ometa:mov ah,0
           inc x
	   loop @rowdg
           inc y
           pop x
           cmp interval_y,0
           jne @utar
 end
 else
 asm
           les si,buf
           xor ax,ax
           mov al,wighthY
           mov interval_y,ax {8}
           xor ax,ax
           mov al,achar
	   shl ax,5
           add si,ax
	   mov ah,0
     @utar:push x
           xor cx,cx
           mov cx,16   {;8}
           mov ax,es:[si]
           inc si
           inc si
           dec interval_y
    @rowdg:shl ax,1
           jnc @ometa
           push ax
           push es
           push di
           mov ax,y
           shl ax,2
           mov di,ax
           shl ax,2
           add ax,di
           add ax,0A000h
           mov es,ax
           mov di,x
           mov al,color
           mov es:[di],al
           pop di
           pop es
           pop ax
    @ometa:inc x
	   loop @rowdg
           inc y
           pop x
           cmp interval_y,0
           jne @utar
 end;
end;

procedure print(fontnum,x,y:word;color:byte;str:string);
var  n:word;
     bstr:record
          long:byte;
          achar:array[1..100] of byte
          end
          absolute str;
begin
     for n:=1 to bstr.long do
         begin
         hsimbol(x,y,color,fonttab[fontnum].sizeX,fonttab[fontnum].sizeY,
                 bstr.achar[n],fonttab[fontnum].fontbuf^);
         x:=x+fonttab[fontnum].sizeX;
         end;
end;

procedure line_color_excheng(x1,y1,x2:word;newc,oldc:byte);assembler;
asm
           push ax
           push bx
           push cx
           push di
           push es
           mov ax,0a000h
           mov es,ax
           mov ax,y1
           mov bx,320
           mul bx
           add ax,x1
           mov di,ax
           mov cx,x2
           sub cx,x1
    @c_ex1:mov al,oldc
     repne scasb
           jne @c_ex2
           dec di
           mov al,newc
           stosb
           jmp @c_ex1
    @c_ex2:pop es
           pop di
           pop cx
           pop bx
           pop ax
end;

procedure window_color_excheng(x1,y1,x2,y2:word;newc,oldc:byte);
var i:word;
begin
for i:=0 to y2-y1-1 do line_color_excheng(x1,y1+i,x2,newc,oldc);
end;

procedure resize_blk(x1,y1,x2,y2:word;var buf);assembler;
var dds,addx,interval_x,interval_y,wighthX,wighthY,
    put_kx,put_ky,total_x,total_y:word;
asm
           push ds
           lds si,buf
           mov ax,ds
           pop ds
           mov dds,ax
           push ds
           mov ds,ax
           lodsw
           pop ds
           mov wighthX,ax
           mov ax,dds
           push ds
           mov ds,ax
           lodsw
           pop ds
           mov wighthY,ax
           mov ax,x2
           sub ax,x1
           mov bx,ax
           cmp ax,0
           jz  @rnd
           mov ax,320
           sub ax,bx
           mov addx,ax
           mov interval_x,bx
           mov cl,7
           mov ax,wighthX
           shl ax,cl
           xor dx,dx
           div bx
           mov put_kx,ax
           mov ax,y2
           sub ax,y1
           cmp ax,0
           jz  @rnd
           mov interval_y,ax
           mov bx,ax
           mov ax,wighthY
           xchg ah,al
           xor dx,dx
           div bx
           mov put_ky,ax
           mov ax,y1
           mov bx,20
           mul bx
           add ax,0a000h
           mov es,ax
           mov di,x1
           mov total_y,0
           mov cx,interval_y
     @rblk:push si
           mov ax,total_y
           add ax,put_ky
           mov total_y,ax
           xchg ah,al
           xor ah,ah
           mov bx,wighthX
           mul bx
           add si,ax
    @rline:push cx
           mov cx,interval_x
           mov total_x,0
   @rline1:push si
           mov ax,total_x
           add ax,put_kx
           mov total_x,ax
           push cx
           mov cl,7
           shr ax,cl
           pop cx
           add si,ax
           push ds
           mov ax,dds
           mov ds,ax
           movsb
           pop ds
           pop si
           loop @rline1
           pop cx
           add di,addx
           pop si
           loop @rblk
      @rnd:
end;

begin
for d:=1 to 10 do fonttab[d].fontbuf:=nil;
end.