Unit GraphVGA;
interface
Uses
  CRT,DOS;
Const
  NormEffect = 0;
  FadeEffect = 1;
  noViewEfct = 2;
  GetMaxX    = 319;
  GetMaxY    = 199;
  CentreX    = 160;
  CentreY    = 100;
  VGA        = $13;
  CGALo      = $04;
  CGAHi      = $06;
  On         = True;
  Off        = False;
  Screen     : Pointer = Ptr($0000,$0000);
  MagicLong  : Longint = $11111111;
Type
  Infor     = Record
                X1,Y1,X2,Y2 : Integer;
              End;
  PointType = Record
                X,Y : Integer;
              End;
  ColorRGB  = Record
                Rouge : Byte;
                Vert  : Byte;
                Bleu  : Byte;
              End;
  RGB       = Array[0..$FF] of ColorRGB;
  ImageInfo = Record
                SizeX    : Word;
                SizeY    : Word;
                Palette  : RGB;
                Picture  : Pointer;
                Size     : Word;
              End;
Var
  PageW    : Pointer;
  PageWS   : Word;
  PageWO   : Word;
  WriteS   : Word;
  Reg      : Registers;
  RGBPal   : RGB;
  DirectV  : Boolean;
  VgaMode  : Boolean;
  Doub     : Boolean;
  DefSpd   : Byte;
  _CColor  : Byte;

Procedure pause(Speed : Word);

Procedure SimpleBuffer;

Procedure DoubleBuffer;

Procedure SetDColor( c: Byte);

Function Rad(A : Real) : real;

Function Deg(A : Real) : Real;

Procedure WaitVBL;

Procedure SetRGB(Var Pal : RGB);

Procedure GetRGB(Var Pal : RGB);

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

Procedure CloseGraph;

Procedure SetSpeed(Speed : Byte);
{ Assembler : }
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 DirectVideo(Direct : Boolean);

Function GetVideo : Boolean;

Procedure SetColor ( Color, Red, Green, Blue : Byte );

Procedure SetRGBColor( Color,R,G,B : Byte; Var Pal : RGB);

{ Assembler }
Procedure Line(X1,Y1,X2,Y2 : Integer; Color : byte);

Procedure PaletteOff;

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

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

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

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

Function expo(A,E : integer) : LongInt;

Procedure PutImage( Var Im  : ImageInfo;
                    Mo  : Byte);

Procedure AllocImage( SX,SY : Word;
                      Var I : imageInfo);

Procedure FreeImage( Var I : ImageInfo);

Procedure LoadRIX(N : String; Var Ima : Imageinfo);

Procedure Comprs(Var Pic : Pointer; Var Taille : Word);

Procedure UnComprs(Pic : Pointer; ToP : Pointer);

Implementation
{
Var
  PageW    : Pointer;
  PageWS   : Word;
  PageWO   : Word;
  WriteS   : Word;
  Reg      : Registers;
  DirectV  : Boolean;
  VgaMode  : Boolean;
  DefSpd   : Byte;
  _CColor  : Byte;
}

Procedure Pause(Speed : Word);
Var
  I : Word;
Begin
  I := 0;
  Repeat
    Inc(I);
  Until I>Speed;
End;

Procedure SetDColor( c: Byte);
Begin
  _CColor := C;
End;

Function Rad(A : Real) : real;
Begin
  Rad := (A*Pi)/180;
End;

Function Deg(A : Real) : Real;
Begin
  Deg := (A*180) /pi;
End;

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

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

Procedure SetColor ( Color, Red, Green, Blue : Byte ); Assembler;
Asm
  PushA
  Mov    DX,$3C8
  Mov    AL,[Color]
  Out    DX,AL
  Inc    DX
  Mov    AL,[Red]
  Out    DX,AL
  Mov    AL,[Green]
  Out    DX,AL
  Mov    AL,[Blue]
  Out    DX,AL
  PopA
End;

Procedure SetRGB(Var Pal : RGB); Assembler;
Asm
  Push   DS
  Push   SI
  Push   DX
  Push   CX
  Push   AX

  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

  mov    DI,offset [RGBPal]
  mov    ax,seg [rgbPal]
  mov    es,ax
  Lds    SI,[Pal]
  mov    CX,3*$FF
  rep    movsb
  Pop    AX
  Pop    CX
  Pop    DX
  Pop    SI
  Pop    DS
End;

Procedure GetRGB(Var Pal : RGB); Assembler;
Asm
  Push   DS
  Push   SI
  Push   DX
  Push   CX
  Push   AX

  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    CH,$00
  jz     @beg

  Pop    AX
  Pop    CX
  Pop    DX
  Pop    SI
  Pop    DS
End;

Procedure SetSpeed(Speed : Byte);
Begin
  DefSpd := Speed;
End;

Procedure SimpleBuffer;
Begin
  If not Doub Then Exit;
  Freemem(PageW,$FFFF);
  PageWS := $A000;
  WriteS := $A000;
  Doub   := false;
End;

Procedure DoubleBuffer;
Begin
  If Doub Then Exit;
  Getmem(pageW,$FFFF);
  PageWS := Seg(PageW^);
  WriteS := PageWS;
  Doub   := True;
End;

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

Procedure CloseGraph;
Begin
  If Not VGAMode Then
    Exit;
  If doub then
    FreeMem(Pagew,$FFFF);
  Asm
    Mov AH,$00
    Mov AL,$03
    int $10
  End;
  TextMode(CO80);
End;

Procedure PutPixel( X,Y : Integer;
                    C   : Byte); Assembler;
asm
  Mov   Ax,[X]
  cmp   [X],1
  jl    @exit
  cmp   [X],320
  jg    @exit
  cmp   [Y],1
  jl   @exit
  cmp   [Y],200
  jg    @exit

  mov   ax,&WriteS
  mov   Es,ax
  dec   [x]             { X-1           }
  dec   [y]             { Y-1           }
  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,$7D00
  Xor   Si,Si
  xor   Di,Di
  Rep   MovsW

  Pop   DS
@exit:
End;

Procedure DirectVideo(Direct : Boolean);
Begin
  Case Direct Of
    True  : WriteS := $A000;
    False : WriteS := PageWS;
  End;
  directV := Direct;
End;

Function GetVideo : Boolean;
Begin
  GetVideo := DirectV;
End;

Procedure SetRGBColor( Color,R,G,B : Byte; Var Pal : RGB);
Begin
  With Pal[Color] Do
    Begin
      Rouge := R;
      Vert  := G;
      Bleu  := B;
    End;
End;

Procedure Line(X1,Y1,X2,Y2 : Integer; Color : Byte); Assembler;
Asm
         mov ax,WriteS
         mov es,ax
         mov si,x2
         sub si,x1
         mov ax,si
         jns @1
         neg ax
@1:      mov di,y2
         sub di,y1
         mov bx,di
         jns @2
         neg bx
@2:      cmp ax,bx
         jge @3
         jmp @4
@3:      cmp ax,0
         je @fin
         std
         cmp si,0
         jge @5
         cld
@5:      mov cx,si
@bcl1:   mov ax,si
         imul di
         idiv cx
         add ax,y1
         mov bx,ax
         mov ax,320
         mul bx
         add ax,x1
         add ax,si
         mov bx,ax
         mov al,color
         mov byte ptr es:[bx],al
         lodsb
         cmp si,0
         jnz @bcl1
         jmp @fin
@4:      xchg si,di
         std
         cmp si,0
         jge @6
         cld
@6:      mov cx,si
@bcl2:   mov bx,y1
         add bx,si
         mov ax,320
         mul bx
         mov bx,ax
         mov ax,di
         imul si
         idiv cx
         add ax,x1
         add bx,ax
         mov al,color
         mov byte ptr es:[bx],al
         lodsb
         cmp si,0
         jnz @bcl2
@fin:
end;

Procedure GetIntRGB ( Var Pal : RGB); Assembler;
asm
  Mov  AH,10h
  mov  AL,17h
  Xor  BX,BX
  mov  CX,256*3
  les  dx,Pal
  int  10h
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    bl,speed
     mov    si,$40
@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

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

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

@B1: cmp    [B],0
     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    Si
     cmp    si,-1
     jne    @GB
     PopA
  End;
End;

Procedure FadeIn(first,Last : word; Var Pal : RGB; Speed : Byte);
Var
  R,G,B    : Byte;
Begin
  Asm
     PushA
     Push   ES
     mov    bl,speed
     mov    di,$40
@Gb:
     Mov    cx,[first]
     call   WaitVbl
@Rer:
     { Get R,G,B }
     Les    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
     add    [R],bl

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

@B1: lodsb
     cmp    [B],al
     je     @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    di
     cmp    di,-1
     jne    @GB
     Pop    ES
     PopA
  End;
End;

Procedure FadeFromWhite(first,Last : word; Var Pal : RGB; 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;
  GetRGB(RGBPal);
End;

Function expo(A,E : integer) : LongInt;
Var
  E1 : Byte;
  T : LongInt;
Begin
  T := A;
  For E1:= 1 to e-1 do
    T := A * T;
  Expo := T;
End;

Procedure PutImage( Var Im  : ImageInfo;
                    Mo  : Byte);
Var
  X1,Y1 : Word;
  Y2    : Word;
  B     : Boolean;
Begin
  B := GetVideo;
  If Mo <> 2 Then PaletteOff;
  DirectVideo(On);
  With Im do
    Begin
      For Y1:=1 to SizeY do
        Begin
          Y2 := (Y1-1)*320;
          X1 := (Y1-1)*SizeX;
          move( Mem[Seg(Picture^): Ofs(Picture^)+X1],
                Mem[WriteS:(Y2)],SizeX);
        End;
        DirectVideo(B);
        Case Mo Of
          0 : SetRGB(Palette);
          1 : FadeIn(0,$ff,Palette,1);
          2 : SETRGB(Palette);
          3 : ;
        End;
    End;
End;

Procedure AllocImage( SX,SY : Word;
                      Var I : imageInfo);
Var
  Si : Longint;
Begin
  Si := Longint(SX)*Longint(SY);
  With I do
    Begin
      If SI > 64000 Then
        SI := 64000;
      GetMem(Picture,Si);
      Size := Si;
      SizeX := Sx;
      SizeY := Sy;
    End;
End;

Procedure FreeImage( Var I : ImageInfo);
Begin
  With I do
    Begin
      FreeMem(Picture,Size);
      Size := 0;
      SizeX := 0;
      SizeY := 0;
    End;
End;

Procedure LoadRIX(N : String; Var Ima : Imageinfo);
Var
  Header  : LongInt;
  F       : file;
  X,Y     : Word;
  CC      : Byte;
  Xs,YS   : Word;
  Info    : Word;
Begin
  Assign(F,N);
  reset(F,1);
  BlockRead(F,Header,4);
  BlockRead(F,Xs,2);
  BlockRead(F,YS,2);
  BlockRead(F,Info,2);
  AllocImage(Xs,Ys,Ima);
  For Xs:=0 to $Ff do
    With Ima do
      BlockRead(F,Palette[Xs],3);
  BlockRead(f,Ima.Picture^,ima.Size);
  Close(F);
End;

Procedure Comprs(Var Pic : Pointer; Var Taille : Word);
Function scan( X : Word;
               C : Byte) : Byte;
Var
  I  : Word;
  Ct : Byte;
Begin
  I := X;
  Ct := 0;
  While (Mem[WriteS:I] = C) AND (I<64000) AND (Ct<$FF) DO
    Begin
      Inc(Ct);
      Inc(I);
    End;
  Scan := Ct-1;
End;

Var
  I : Word;
  R : Word;
  P : Byte;
  Sc : Byte;
  Ts : Pointer;
Begin
  getMem(Ts,64000);
  I := 0;
  R := 0;
  Repeat
    P := Scan(I,Mem[WriteS:I]);
    If P > 1 Then
      Begin
        MemL[seg(Ts^):Ofs(Ts^)+R ] := MagicLong;
        Mem[seg(Ts^):Ofs(Ts^)+R+4] := P;             { Nombre de repetitions }
        Mem[seg(Ts^):Ofs(Ts^)+R+5] := Mem[WriteS:I]; { Byte a r‚p‚ter        }
        Inc(R,6);
        Inc(I,P+1);
        For Sc := I to I+p+1 do
          Mem[WriteS:I] := 0;
      End
    Else
      Begin
        Mem[Seg(Ts^):Ofs(Ts^)+R] := Mem[WriteS:I];
        inc(R);
        Inc(I);
      End;
  Until I>64000;
  Taille := R;
  GetMem(Pic,Taille);
  Move(Ts^,Pic^,Taille);
  FreeMem(Ts,64000);
End;

Procedure UnComprs(Pic : Pointer; ToP : Pointer);
Var
  I,R : Word;
  C   : Byte;
Begin
  I := 0;
  R := Ofs(Pic^);
  Repeat
    If MemL[seg(Pic^):R  ] = MagicLong Then
      Begin
        For C:= 0 to Mem[seg(Pic^):R+4] do
          Begin
            Mem[Seg(Top^):I] := Mem[seg(Pic^):R+5];
            Inc(i);
          End;
       Inc(R,6);
      End
    Else
      Begin
        Mem[Seg(Top^):I] := Mem[Seg(Pic^):R];
        inc(R);
        Inc(I);
      End;
  Until I>64000;
End;

End.