UNIT Grapher;

INTERFACE

 Uses
  Crt, Graph;

 Var
  CurrentColor: Byte;
  FillColor: Byte;
  GetX, GetY: Integer;

 Procedure Init256Mode;
 Procedure Done256Mode;
 Procedure ShowScreen;
 Procedure SetRGBPalette(n, r, g, b: Byte);
 Procedure SetColor(c: Byte);
 Procedure SetFillStyle(a,c: Byte);
 Procedure PutPixel(x, y: Word; c: Byte);
 Procedure GetImage(x1,y1,x2,y2:word;var A);
 Procedure PutImage(x,y:word;var A);
 Procedure Line(x1, y1, x2, y2: Real);
 Procedure MoveTo(x0,y0: Integer);
 Procedure LineTo(x, y: Integer);
 Procedure Rectangle(x1, y1, x2, y2: Integer);
 Procedure Ellipse(x, y, rx, ry: Integer);
 Procedure Bar(x1, y1, x2, y2: Integer);
 Procedure Fill(x, y: Integer; c: Byte);
 Procedure Clear(c: Byte);
 Function GetPixel(x, y: Word): Byte;

IMPLEMENTATION

 Var
  screen: Pointer;

 Procedure ShowScreen;
  var
   i, j: Word;
  procedure PutPixel(x, y: Word; c: Byte);assembler;
    asm
     mov ax,[y]
     mov bx,ax
     shl bx,6
     add bh,al
     add bx,[x]
     mov es,[SEGA000]
     mov al,[c]
     mov es:[bx],al
    end;
  begin
   for i:=0 to 199
   do for j:=0 to 319
      do PutPixel(j, i, Mem[(Seg(screen^)):(i*320+j)]);
  end; {ShowScreen}

 Procedure Bar(x1, y1, x2, y2: Integer);
  var
   i, j: Integer;
  begin
   for i:=y1 to y2
   do for j:=x1 to x2
      do PutPixel(j, i, FillColor)
  end; {Bar}

 Procedure Fill(x, y: Integer; c: Byte);
  const
   a: Array [1..8,1..2] of ShortInt
			= ((-1,-1),
			   ( 0,-1),
			   ( 1,-1),
			   ( 1, 0),
			   ( 1, 1),
			   ( 0, 1),
			   (-1, 1),
			   (-1, 0)
			  );
  var
   c0: Byte;
  procedure fil(x, y: Integer; c: Byte);
   var
    i: Byte;
   begin
     PutPixel(x,y,c);
      readkey;
    for i:=1 to 8
    do if GetPixel(x+a[i,1],y+a[i,2]) = c0
       then fil(x+a[i,1],y+a[i,2],c)
   end; {fil}
  begin
   if GetPixel(x,y) <> c
   then begin
	 c0:=GetPixel(x,y);
	 fil(x, y, c)
	end
  end; {Fill}

 Procedure Clear(c: Byte);
  begin
   SetFillStyle(1,c);
   Bar(0,0,319,199)
  end; {Clear}

 Procedure Init256Mode;
  var
   gd, gm: Integer;
  begin
   gd:=InstallUserDriver('svga256',nil);
   gm:=0;
   InitGraph(gd, gm, '');
   ClearDevice;
   GetMem(screen, 64000);
   Clear(0)
  end; {InitGraph}

 Procedure Done256Mode;
  begin
   CloseGraph;
   FreeMem(screen, 64000)
  end; {Done256Mode}

 Procedure SetRGBPalette(n, r, g, b: Byte);assembler;
  asm
   mov ax,1010h
   mov bl,n
   xor bh,bh
   mov dh,r
   mov ch,g
   mov cl,b
   int 10h
  end; {SetColor}

 Procedure SetColor(c: Byte);
  begin
   CurrentColor:=c
  end; {SetColor}

 Procedure SetFillStyle(a,c: Byte);
  begin
   FillColor:=c
  end; {SetFillColor}

 Procedure PutPixel(x, y: Word; c: Byte);
  begin
   if (x >= 0)and(x <= 319)and(y >= 0)and(y <= 199)
   then Mem[Seg(screen^):(y*320+x)]:=c
  end;

 Procedure GetImage(x1,y1,x2,y2:word;var A);assembler;
  asm
   push ds
   mov ax,320
   mul y1
   mov si,x1
   add si,ax
   mov ax,0A000h
   mov ds,ax
   les di,A
   cld
   mov cx,x2
   sub cx,x1
   inc cx
   mov ax,cx
   stosw
   mov dx,y2
   sub dx,y1
   inc dx
   mov ax,dx
   stosw
   mov bx,320
   sub bx,cx
   mov ax,cx
   @Go:
   rep movsb
   mov cx,ax
   add si,bx
   dec dx
   jnz @Go
   pop ds
  end;

 Procedure PutImage(x,y:word;var A);assembler;
  asm
   push ds
   mov ax,320
   mul y
   mov di,x
   add di,ax
   mov ax,0A000h
   mov es,ax
   lds si,A
   cld
   lodsw
   mov cx,ax
   lodsw
   mov dx,ax
   mov bx,320
   sub bx,cx
   mov ax,cx
   @Go:
   rep movsb
   mov cx,ax
   add di,bx
   dec dx
   jnz @Go
   pop ds
  end;

 Procedure Line(x1, y1, x2, y2: Real);
  var
   x, y, n, kx, ky: Real;
   i: Integer;
  begin
   n:=sqrt(sqr(x2-x1) + sqr(y2-y1));
    if n <> 0
    then begin
	  kx:=(x2-x1)/n;
	  ky:=(y2-y1)/n
	 end
    else begin
	  kx:=0;
	  ky:=0
	 end;
   x:=x1;
   y:=y1;
    for i:=0 to Round(n)
    do begin
	Putpixel(Round(x), Round(y), CurrentColor);
	x:=x + kx;
	y:=y + ky
       end
  end; {Line}

 Procedure MoveTo(x0,y0: Integer);
  begin
   GetX:=x0;
   GetY:=y0
  end;

 Procedure LineTo(x, y: Integer);
  begin
   Line(GetX, GetY, x, y)
  end; {LineTo}

 Procedure Rectangle(x1, y1, x2, y2: Integer);
  begin
   Line(x1,y1,x2,y1);
   Line(x2,y1,x2,y2);
   Line(x2,y2,x1,y2);
   Line(x1,y2,x1,y1)
  end; {Rectangle}

 Procedure Ellipse(x, y, rx, ry: Integer);
  var
   xx, yy, i, r: Integer;
  begin
    r:=rx+ry;
   for i:=1 to Round(2*PI*r)
   do begin
       xx:=x + Round(rx*cos(i/r));
       yy:=y + Round(ry*sin(i/r));
       PutPixel(xx, yy, CurrentColor)
      end
  end; {Ellipse}

 Function GetPixel(x, y: Word): Byte{;assembler};
  begin
   GetPixel:=Mem[Seg(screen^):(y*320+x)]
{  asm
   push ds
   mov ax,$a000
   mov ds,ax
   mov si,y
   mov ax,y
   shl si,8
   shl ax,6
   add si,ax
   add si,x
   sub si,321
   lodsb
   pop ds}
  end; {GetPixel}

BEGIN
 CurrentColor:=15;
 FillColor:=15
END.