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

  Данная утилита оптимизирована, но не до предела - дерзайте,
  особого внимания заслуживает мой алгоритм Paint - насладитесь 

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

  Формат буфера для функций Get_Window, Put_Window:
  
  смещение  длина  описание
     0        2    ширина по горизонтали
     2        2    высота по вертикали
     4      ???    сама картинка

  Этот же формат используется в процедуре Resize_blk из моей
  утилиты GEFFECT.TPU 
}

{$G+}
Unit vga256;

interface

procedure initgraphscreen;
procedure exitgraphscreen;
procedure Get_palette(var buf);
procedure Set_palette(var buf);
procedure ClrScreen;
procedure Pset(x,y:integer;color:byte);
procedure asmPset;  {di-x,ax-y,bl-color для вызова из asm-процедур}
function Areset(x,y:word):byte;
procedure pcls(x1,y1,x2,y2:word;color:byte);
procedure Line(x1,y1,x2,y2:integer;color:byte);
procedure box(x1,y1,x2,y2:integer;color:byte);
procedure bar(x1,y1,x2,y2:integer;acolor,bcolor:byte);
procedure Circle(xc,yc,r:integer;color:byte);
procedure Arc(xc,yc,rx,ry:integer;color:byte);
procedure paint(x,y:integer;acolor,bcolor:byte);
procedure Get_Window(xl,yl,xr,yr:word;var buf);
procedure Put_Window(x,y:word;var buf);

type
         winbufp=record
                 wighthX,wighthY:word;
                 image:array [0..64160] of byte;
                 end;
         palette=record
                 red,green,blue:byte;
                 end;
         paletbufp=array [0..255] of palette;

var
         MinX,MaxX,MinY,MaxY:word;
         tabsin:array [0..2700] of real;
         screenbuf:^winbufp;

const
         black=0;
         white=15;
         blue=1;
         gray=7;
         segA000=ptr($0a000,0);
         offcos=540;
         mulsin=6;

implementation

var  
     i:word;

procedure initgraphscreen;assembler;
asm
    mov ax,13h
    int 10h
end;

procedure exitgraphscreen;assembler;
asm
    mov ax,3
    int 10h
end;

procedure Get_palette(var buf);assembler;
asm
    push es
    mov ax,1017h
    mov bx,0
    mov cx,256
    les dx,buf
    int 10h
    pop es
end;

procedure Set_palette(var buf);assembler;
asm
    push es
    mov ax,1012h
    mov bx,0
    mov cx,256
    les dx,buf
    int 10h
    pop es
end;

procedure ClrScreen;assembler;
asm
    mov ax,0a000h
    mov es,ax
    xor di,di
    mov cx,32000
    xor ax,ax
rep stosw
end;

procedure Pset(x,y:integer;color:byte);assembler;
asm
    mov ax,x
    cmp ax,MaxX
    ja  @pn
    cmp ax,MinX
    jb  @pn
    mov ax,y
    cmp ax,MaxY
    ja  @pn
    cmp ax,MinY
    jb  @pn
    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
@pn:
end;

procedure asmPset;assembler;{di-x,ax-y,bl-color для вызова из asm-процедур}
asm
           push ax
           push es
           push di
           shl ax,1
           shl ax,1
           mov di,ax
           shl ax,1
           shl ax,1
           add ax,di	
           add ax,0A000h
           mov es,ax
           pop di
           mov al,bl
           mov es:[di],al
           pop es
           pop ax
end;

function Areset(x,y:word):byte;assembler;
asm
           mov ax,0A000h
           mov es,ax
           mov ax,y
           shl ax,6
           mov di,ax
           shl ax,1
           shl ax,1
           add di,ax
           add di,x
           mov al,es:[di]
end;

procedure pcls(x1,y1,x2,y2:word;color:byte);assembler;
var intX,intY:word;
asm
           push es
           push di
           mov ax,x2
           cmp ax,x1
           ja  @a2
           mov bx,x1
           mov x1,ax
           mov ax,bx
       @a2:sub ax,x1
           inc ax
           mov intX,ax
           mov ax,y2
           cmp ax,y1
           ja  @a3
           mov bx,y1
           mov y1,ax
           mov ax,bx
       @a3:sub ax,y1
           inc ax
           mov intY,ax
           mov ax,0a000h
           mov es,ax
           mov cx,intY
       @a1:push cx
           mov ax,y1
           mov bx,320
           mul bx
           add ax,x1
           mov di,ax
           mov cx,intX
           mov al,color
       rep stosb
           pop cx
           inc y1
           loop @a1
           pop di
           pop es
end;

procedure Line(x1,y1,x2,y2:integer;color:byte);assembler;
VAR X,Y,INTX,INTY,ADDX,INTX2,INTY2:integer;
asm
           mov ax,0a000h
           mov es,ax
     @lal2:MOV    AX,Y1
           CMP    AX,Y2
           JNG    @L013F
           MOV    BX,Y2
           MOV    Y2,AX
           MOV    Y1,BX
           MOV    AX,X1
           MOV    BX,X2
           MOV    X2,AX
           MOV    X1,BX
    @L013F:MOV    AX,X2
           SUB    AX,X1
           MOV    INTX,AX
           MOV    AX,Y2
           SUB    AX,Y1
           MOV    INTY,AX
           MOV    ADDX,1
           CMP    INTX,0
           JG     @L015A
           SUB    ADDX,2
           NEG    INTX
    @L015A:MOV    AX,INTX
           CMP    AX,INTY
           JNG    @L0188
           MOV    CX,INTX
           MOV    AX,INTY
           ADD    AX,AX
           MOV    INTY2,AX
           MOV    BX,AX
           SUB    BX,INTX
           MOV    AX,INTX
           ADD    AX,AX
           MOV    INTX2,AX
           MOV    AX,X1
           MOV    X,AX
           MOV    AX,Y1
           MOV    Y,AX
           cmp ax,MaxY
           ja @lend1
           cmp ax,MinY
           jb @lend1
           mov ax,X
           cmp ax,MaxX
           ja @lend1
           cmp ax,MinX
           jb @lend1
           mov ax,Y
           mov di,X
           shl ax,6
           add di,ax
           shl ax,2
           add di,ax
           mov al,color
           mov es:[di],al
    @lend1:CMP    CX,0
           JZ     @L0184
    @L0170:CMP    BX,0
           JL     @L017B
           INC    Y
           SUB    BX,INTX2
    @L017B:ADD    BX,INTY2
           MOV    AX,X
           ADD    AX,ADDX
           MOV    X,AX
           cmp ax,MaxX
           ja @lend2
           cmp ax,MinX
           jb @lend2
           mov ax,y
           cmp ax,MaxY
           ja @lend2
           cmp ax,MinY
           jb @lend2
           mov ax,Y
           mov di,X
           shl ax,6
           add di,ax
           shl ax,2
           add di,ax
           mov al,color
           mov es:[di],al
    @lend2:dec cx
           jnz @L0170
    @L0184:JMP    @L01AE
    @L0188:MOV    CX,INTY
           MOV    AX,INTX
           ADD    AX,AX
           MOV    INTX2,AX
           MOV    BX,AX
           SUB    BX,INTY
           MOV    AX,INTY
           ADD    AX,AX
           MOV    INTY2,AX
           MOV    AX,X1
           MOV    X,AX
           MOV    AX,Y1
           MOV    Y,AX
           cmp ax,MaxY
           ja @lend3
           cmp ax,MinY
           jb @lend3
           mov ax,X
           cmp ax,MaxX
           ja @lend3
           cmp ax,MinX
           jb @lend3
           mov ax,Y
           mov di,X
           shl ax,6
           add di,ax
           shl ax,2
           add di,ax
           mov al,color
           mov es:[di],al
    @lend3:CMP    CX,0
           JZ     @L01AE
    @L019A:CMP    BX,0
           JL     @L01A3
           MOV    AX,X
           ADD    AX,ADDX
           MOV    X,AX
           SUB    BX,INTY2
    @L01A3:ADD    BX,INTX2
           INC    Y
           mov ax,Y
           cmp ax,MaxY
           ja @lend4
           cmp ax,MinY
           jb @lend4
           mov ax,X
           cmp ax,MaxX
           ja @lend4
           cmp ax,MinX
           jb @lend4
           mov ax,Y
           mov di,X
           shl ax,6
           add di,ax
           shl ax,2
           add di,ax
           mov al,color
           mov es:[di],al
    @lend4:dec cx
           jnz @L019A
    @L01AE:
end;

procedure box(x1,y1,x2,y2:integer;color:byte);
begin
line(x1,y1,x2,y1,color); {verhnya line}
line(x1,y1,x1,y2,color); {left line}
line(x2,y1,x2,y2,color); {right line}
line(x1,y2,x2,y2,color); {nignyay line}
end;

procedure bar(x1,y1,x2,y2:integer;acolor,bcolor:byte);{acolor - цвет границы}
begin                                  {bcolor - цвет наполнителя}
box(x1,y1,x2,y2,acolor);
if (x1>x2) and (y1>y2) then begin pcls(x2+1,y2+1,x1-1,y1-1,bcolor);exit;end;
if (y1>y2) then begin pcls(x1+1,y2+1,x2-1,y1-1,bcolor);exit;end;
if (x1>x2) then begin pcls(x2+1,y1+1,x1-1,y2-1,bcolor);exit;end;
if (x2-x1=0) or (y2-y1=0) then exit;
pcls(x1+1,y1+1,x2-1,y2-1,bcolor);
end;

procedure Get_Window(xl,yl,xr,yr:word;var buf);assembler;
var interval_x,interval_y:word;
asm
           push es
           les di,buf
           mov ax,xr
           sub ax,xl
           inc ax
           stosw
           mov interval_x,ax
           mov ax,yr
           sub ax,yl
           inc ax
           stosw
           mov interval_y,ax
       @g1:mov ax,yl
           mov bx,320
           mul bx
           add ax,xl
           mov si,ax
           cld
           mov cx,interval_x
	   push ds
	   mov ax,0a000h
	   mov ds,ax
       rep movsb
	   pop ds
           cmp interval_y,1
           je @g2
           dec interval_y
           inc yl
           jmp @g1
       @g2:pop es
end;

procedure Put_Window(x,y:word;var buf);assembler;
var interval_x,interval_y,dds:word;
asm
           push es
           push ds
           lds si,buf
           mov ax,ds
           pop ds
           mov dds,ax
           push ds
           mov ax,dds
           mov ds,ax
           lodsw
           pop ds
           mov interval_x,ax
           push ds
           mov ax,dds
           mov ds,ax
           lodsw
           pop ds
           mov interval_y,ax
           mov ax,0a000h
           mov es,ax
       @p1:mov ax,y
           mov bx,320
           mul bx
           add ax,x
           mov di,ax
           cld
           mov cx,interval_x
           push ds
           mov ax,dds
           mov ds,ax
       rep movsb
           pop ds
           cmp interval_y,1
           je  @p2
           dec interval_y
           inc y
           jmp @p1
       @p2:pop es
end;

procedure Circle(xc,yc,r:integer;color:byte);
var x,y,count,point:integer;
    a,step:real;
begin
a:=0;step:=45/r;
count:=2*r+1;
repeat
point:=trunc(mulsin*a);
x:=trunc(r*tabsin[point]);
y:=trunc(r*tabsin[offcos+point]);
pset(xc+x,yc+y,color);
pset(xc-x,yc+y,color);
pset(xc+x,yc-y,color);
pset(xc-x,yc-y,color);
a:=a+step;
dec(count);
until count=0;
end;

procedure Arc(xc,yc,rx,ry:integer;color:byte);
var x,y,count,point:integer;
    a,step:real;
begin
if rx>ry then begin
   a:=0;step:=45/rx;
   count:=2*rx+1;
   repeat
   point:=trunc(mulsin*a);
   x:=trunc(rx*tabsin[point]);
   y:=trunc(ry*tabsin[offcos+point]);
   pset(xc+x,yc+y,color);
   pset(xc-x,yc+y,color);
   pset(xc+x,yc-y,color);
   pset(xc-x,yc-y,color);
   a:=a+step;
   dec(count);
   until count=0;
   end
else begin
   a:=0;step:=45/ry;
   count:=2*ry+1;
   repeat
   point:=trunc(mulsin*a);
   x:=trunc(rx*tabsin[point]);
   y:=trunc(ry*tabsin[offcos+point]);
   pset(xc+x,yc+y,color);
   pset(xc-x,yc+y,color);
   pset(xc+x,yc-y,color);
   pset(xc-x,yc-y,color);
   a:=a+step;
   dec(count);
   until count=0;
   end;
end;

procedure paint(x,y:integer;acolor,bcolor:byte); {acolor - цвет границы}
                                             {bcolor - цвет наполнителя}
type
     pw=^word;
     aword=array [1..160] of word;
     revrec=record
            xa,ya:word;
     end;
     bword=array [1..100] of revrec;

var
     fline1,fline2:aword;
     preadyzon,pfoundzon,phelperzon:pw;
     preadyline,pfoundline,phelperline:^aword;
     rline1,rline2:bword;
     rlineready,rlinefound,rlinehelp:^bword;
     rzonready,rzonfound,rzonhelp:pw;
     deltaY:integer;
     c,d,e,f:word;

     procedure Filline(x,y:word);

     procedure Zoneline(x:integer;y:word);
     var i,j:boolean;
         b,bclr,cclr:byte;
         yd:word;
     begin {Zoneline}
       {if areset(x,y)=acolor then exit;}
       bclr:=bcolor;
       b:=areset(x-1,y);
       while (b<>acolor) and (x-1>=MinX+1) do begin
             dec(x);
         asm
           mov ax,0A000h
           mov es,ax
           mov ax,y
           shl ax,6
           mov di,ax
           shl ax,1
           shl ax,1
           add di,ax
           add di,x
           dec di
           mov al,es:[di]
           mov b,al
         end;
       end;
       i:=true;j:=true;
       repeat
          {pset(x,y,bcolor);}
         asm
           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,bclr
           mov es:[di],al
         end;
         yd:=y+deltaY;
         asm
           mov ax,0A000h
           mov es,ax
           mov ax,yd
           shl ax,6
           mov di,ax
           shl ax,1
           shl ax,1
           add di,ax
           add di,x
           mov al,es:[di]
           mov b,al
         end;
         if (b<>acolor) and ((yd>=MinY) and (yd<=MaxY)) then begin
            if i=true then begin
               pfoundzon^:=pfoundzon^+1;
               pfoundline^[pfoundzon^]:=x;
               i:=false;
            end;
         end
         else i:=true;
         {b:=areset(x,y-deltaY);}
         yd:=y-deltaY;
         asm
           mov ax,0A000h
           mov es,ax
           mov ax,yd
           shl ax,6
           mov di,ax
           shl ax,1
           shl ax,1
           add di,ax
           add di,x
           mov al,es:[di]
           mov b,al
         end;
         if ((b<>acolor) and (b<>bcolor)) and ((yd>=MinY) and (yd<=MaxY)) then
         begin
           if j=true then begin
              rzonfound^:=rzonfound^+1;
              rlinefound^[rzonfound^].xa:=x;
              rlinefound^[rzonfound^].ya:=y-deltaY;
              j:=false;
           end;
         end
         else j:=true;
         inc(x);
         {b:=areset(x,y);}
         asm
           mov ax,0A000h
           mov es,ax
           mov ax,y
           shl ax,6
           mov di,ax
           shl ax,1
           shl ax,1
           add di,ax
           add di,x
           mov al,es:[di]
           mov b,al
         end;
       until (b=acolor) or (b=bcolor) or (x>=MaxX+1);
       i:=true;j:=true;
     end;  {Zoneline}
     begin {Filline}
       pfoundzon^:=0;preadyzon^:=0;
       Zoneline(x,y);y:=y+deltaY;
       repeat
         phelperline:=pfoundline;pfoundline:=preadyline;
         preadyline:=phelperline;
         phelperzon:=pfoundzon;pfoundzon:=preadyzon;
         preadyzon:=phelperzon;
         while preadyzon^<>0 do begin
         Zoneline(preadyline^[preadyzon^],y);
         preadyzon^:=preadyzon^-1;
         end;
         y:=y+deltaY;
       until pfoundzon^=0;
       y:=y-deltaY;
     end;  {Filline}

begin {paint}
  if areset(x,y)=acolor then exit;
  preadyzon:=@c;pfoundzon:=@d;
  rzonready:=@e;rzonfound:=@f;
  rlineready:=@rline1;rlinefound:=@rline2;
  preadyline:=@fline1;pfoundline:=@fline2;
  rzonready^:=0;rzonfound^:=0;
  deltaY:=-1;
  Filline(x,y);
  repeat
    rzonhelp:=rzonfound;rzonfound:=rzonready;
    rzonready:=rzonhelp;
    rlinehelp:=rlinefound;rlinefound:=rlineready;
    rlineready:=rlinehelp;
    deltaY:=-deltaY;
    while rzonready^<>0 do begin
    Filline(rlineready^[rzonready^].xa,rlineready^[rzonready^].ya);
    rzonready^:=rzonready^-1;
    end;
  until rzonfound^=0;
end;  {paint}

begin
screenbuf:=segA000;
MinX:=0;
MaxX:=319;
MinY:=0;
MaxY:=199;
for i:=0 to 2700 do tabsin[i]:=sin(0.1666666*pi*i/180);
end.