Unit GraphV2;
interface
Uses
  CRT,DOS;
Const
  NormEffect = 0;
  FadeEffect = 1;
  noViewEfct = 2;
  GetMaxX    = 319;
  GetMaxY    = 199;
  CentreX    = 160;
  CentreY    = 100;
  VGA        = $13;
  On         = True;
  Off        = False;
  Screen     : Pointer = Ptr($0000,$0000);
Type
  RGB       = Array[0..$300] of byte;
var
  PageW    : Pointer;
  PageWS   : Word;
  PageWO   : Word;
  WriteS   : Word;

Procedure WaitVBL;

Procedure GetRGB(Pal : Pointer);

Procedure SetRGB(Pal : pointer);

{ Assembler : }
Procedure InitGraph( Mode : Byte );

Procedure CloseGraph;

Procedure PutPixel ( X,Y : Integer;
                     C   : Byte);

Function GetPixel ( X,Y : Integer) : Byte;

Function GPixel ( X,Y : Integer) : Byte;

Procedure ClearDevice(CColor : Byte);

Procedure ViewPage;

Procedure PaletteOff;

{ Assembler }
Procedure FadeOut(First,Last : Word; Speed : Byte);

Procedure FadeIn(first,Last : word; Pal: pointer; speed : Byte);

Procedure FadeFromWhite(first,Last : word; Pal: pointer; Speed : Byte);

Procedure FadeWhite(First,Last : Word; speed : Byte);

Implementation
var
  DirectV : Boolean;


Procedure WaitVBL; Assembler;
Asm
    { Wait VBL }
    push  dx
    push  ax
    Mov   DX,$3DA
@W: in    AL,DX
    Test  AL,$08
    Jne   @W

@X: in    AL,DX
    test  AL,$08
    Je    @X
    pop   ax
    pop   dx
end;

Procedure GetRGB( Pal : pointer); Assembler;
Asm
  Les    DI,[Pal]
  cld
  Xor    CX,CX
@Beg:
  Mov    DX,$3C8
  Mov    AL,CL
  Out    DX,AL
  Inc    DX
  In     AL,DX
  StosB
  In     AL,DX
  StosB
  In     AL,DX
  StosB
  inc    CX
  cmp    CX,$100
  jbe    @beg

End;

Procedure SetRGB(Pal : pointer); Assembler;
Asm
  Push   DS

  Lds    SI,[Pal]
  cld
  Xor    CX,CX
  Mov    DX,$3C8
@Beg:
  Mov    AL,CL
  Out    DX,AL
  Inc    DX
  LodsB
  Out    DX,AL
  Lodsb
  Out    DX,AL
  Lodsb
  Out    DX,AL
  inc    CX
  Dec    DX
  cmp    CH,$00
  je     @beg

  Pop    DS
End;

Procedure InitGraph( Mode : Byte );
Begin
  asm
    Mov  AH,$00
    Mov  AL,&Mode
    int  $10
  End;
  DirectV := False;
  Getmem(pageW,$FFFF);
  PageWS := Seg(PageW^);
  WriteS := PageWS;
  Screen := Ptr($A000,0000);
  FillChar(PageW^,64000,0);
End;

Procedure CloseGraph;
Begin
  Asm
    Mov AH,$00
    Mov AL,$03
    int $10
  End;
  TextMode(CO80);
  ClrScr;
End;

Procedure PutPixel( X,Y : Integer;
                    C   : Byte); Assembler;
asm
  dec   x
  dec   y
  cmp   X,319    { ; X > 320 Or x <0 }
  ja    @exit
  cmp   Y,199    { ; Y > 200 or Y < 0}
  ja    @exit

  mov   ax,&WriteS
  mov   Es,ax
  Imul  ax,Y,$140     { Y*320         }
  mov   di,X
  add   di,ax           { Bx := Bx+Ax   }
  mov   al,c
  stosb

@exit:
End;

Function GPixel( X,Y : Integer) : Byte;
Begin
  GPixel := Mem[WriteS:(Y-1)*320+(X-1)];
End;

Function GetPixel ( X,Y : Integer) : Byte;
Begin
  GetPixel := Mem[WriteS:(Y-1)*320+(X-1)]
End;

Procedure ClearDevice(CColor : Byte); Assembler;
Asm
    Mov  CX,32000
    Mov  AX,[WriteS]
    Mov  ES,AX
    Xor  DI,DI
    Mov  AH,[CColor]
    Mov  AL,AH
    Rep  StosW
End;

Procedure ViewPage; Assembler;
Asm
  Cmp   &DirectV,0
  jne   @exit

  Push  DS

  Mov   AX,$A000
  Mov   ES,AX
  Mov   AX,&WriteS
  Mov   DS,AX
  Mov   CX,07D00h
  Xor   Si,Si
  xor   Di,Di
  Rep   MovsW

  Pop   DS
@exit:
End;

Procedure PaletteOff;
Var
  INPal : RGB;
Begin
  fillChar(InPal,sizeOf(RGB),0);
  SetRGB(@InPal);
End;

Procedure FadeOut(First,Last : Word; Speed : Byte);
Var
  R,G,B : Byte;
Begin
  Asm
     PushA
     mov    bh,speed
     cmp    bh,0
     jne    @ok
     mov    bh,1
@ok: mov    si,$40
@Gb:
     Mov    cx,[First]
     mov    bl,bh

@@wt:call   waitvbl
     dec    bl
     jnz    @@wt

@Rer:
     { Get R,G,B }
     Mov    dx,$3C7
     Mov    al,cl
     Out    dx,al
     mov    dx,$3C9

     In     al,dx
     mov    [r],Al

     In     al,dx
     mov    [g],Al

     In     al,dx
     mov    [b],Al

     { Decremente R,G,B }
     cmp    [r],0
     je     @G1
     dec    [R]

@G1: cmp    [g],0
     je     @b1
     dec    [g]

@B1: cmp    [B],0
     je     @n1
     dec    [B]

     { Write to DAC VGA }
@N1: Mov    DX,$3C8
     mov    al,cl
     out    dx,al
     inc    dx

     mov    al,[r]
     out    dx,al

     mov    al,[g]
     out    dx,al

     mov    al,[b]
     out    dx,al

     inc    cx
     cmp    cx,[Last]
     jbe    @rer

     dec    Si
     cmp    si,-1
     jne    @GB
     PopA
  End;
End;

Procedure FadeIn(first,Last : word; Pal : pointer; Speed : Byte);
Var
  R,G,B    : Byte;
Begin
  Asm
     PushA
     Push   DS
     mov    bh,speed
     cmp    bh,0
     jne    @ok
     mov    bh,1
@ok: mov    di,$40
@Gb:
     Mov    cx,[first]

     mov    bl,bh
@bcl:call   WaitVbl
     dec    bl
     jnz    @bcl
@Rer:
     { Get R,G,B }
     Lds    sI,[Pal]
     mov    dx,3
     mov    ax,cx
     mul    dx
     add    si,ax
     Mov    dx,$3C7
     Mov    al,cl
     Out    dx,al
     mov    dx,$3C9

     In     al,dx
     mov    [r],Al

     In     al,dx
     mov    [g],Al

     In     al,dx
     mov    [b],Al

     lodsb
     { Decremente R,G,B }
     cmp    [r],al
     je     @G1
     inc    [R]

@G1: lodsb
     cmp    [g],al
     je     @b1
     inc    [g]

@B1: lodsb
     cmp    [B],al
     je     @n1
     inc    [B]

     { Write to DAC VGA }
@N1: Mov    DX,$3C8
     mov    al,cl
     out    dx,al
     inc    dx

     mov    al,[r]
     out    dx,al

     mov    al,[g]
     out    dx,al

     mov    al,[b]
     out    dx,al

     inc    cx
     cmp    cx,[last]
     jbe    @rer

     dec    di
     cmp    di,-1
     jne    @GB
     Pop    dS
     PopA
  End;
End;

Procedure FadeFromWhite(first,Last : word; Pal:pointer; Speed : Byte);
Var
  R,G,B    : Byte;
Begin
  Asm
     PushA
     Push   DS
     mov    bl,speed
     mov    di,$40
@Gb:
     Mov    cx,[first]
     call   WaitVbl
@Rer:
     { Get R,G,B }
     LDs    sI,Pal
     mov    dx,3
     mov    ax,cx
     mul    dx
     add    si,ax
     Mov    dx,$3C7
     Mov    al,cl
     Out    dx,al
     mov    dx,$3C9

     In     al,dx
     mov    [r],Al

     In     al,dx
     mov    [g],Al

     In     al,dx
     mov    [b],Al

     lodsb
     { Decremente R,G,B }
     cmp    [r],al
     je     @G1
     sub    [R],bl

@G1: lodsb
     cmp    [g],al
     je     @b1
     sub    [g],bl

@B1: lodsb
     cmp    [B],al
     je     @n1
     sub    [B],bl

     { Write to DAC VGA }
@N1: Mov    DX,$3C8
     mov    al,cl
     out    dx,al
     inc    dx

     mov    al,[r]
     out    dx,al

     mov    al,[g]
     out    dx,al

     mov    al,[b]
     out    dx,al

     inc    cx
     cmp    cx,[last]
     jbe    @rer

     dec    di
     cmp    di,$FFFF
     jne    @GB
     Pop    DS
     PopA
  End;
End;

Procedure FadeWhite(First,Last : Word; Speed : Byte);
Var
  R,G,B : Byte;
Begin
  Asm
     mov    bl,speed
     mov    BH,040h
     sub    bh,bl
     mov    si,40h
@Gb:
     Mov    cx,[First]
     call   WaitVbl
@Rer:
     { Get R,G,B }
     Mov    dx,$3C7
     Mov    al,cl
     Out    dx,al
     mov    dx,$3C9

     In     al,dx
     mov    [r],Al

     In     al,dx
     mov    [g],Al

     In     al,dx
     mov    [b],Al

     { Incremente R,G,B }
     cmp    r,bh
     jnb    @G1
     add    R,bl

@G1: cmp    G,bh
     jnb    @b1
     add    G,bl

@B1: cmp    B,bh
     jnb     @n1
     add    B,bl

     { Write to DAC VGA }
@N1: Mov    DX,$3C8
     mov    al,cl
     out    dx,al
     inc    dx

     mov    al,[r]
     out    dx,al

     mov    al,[g]
     out    dx,al

     mov    al,[b]
     out    dx,al

     inc    cx
     cmp    cx,[Last]
     jbe    @rer

     dec    si
     cmp    si,-1
     jne    @GB
  End;
End;

End.