SuperHack/SuperHack CD.bin/CODING/MISC/MAG09.ZIP/MODE13H.PAS

Pascal/Delphi Source File | 2010-12-05 | 7.3 KB | 336 lines

Unit Mode13h;

{ Version 1.2 }

Interface

Const VGA=$A000;
      Npages=1;

Type RgbItem=Record
                   R,G,B:Byte;
             End;
     RgbList=Array[0..255] of RgbItem;
     Table=Array[0..1799] Of Real;
     PTable=^Table;

Var Sines:Ptable;
    Cosines:Ptable;
    Virt:Array[1..Npages] Of Pointer;
    VP:Array[1..Npages] Of Word;
    PCXPal:RgbList;

Procedure Initgraph;
Procedure Closegraph;
Procedure PutPixel(X,Y:word;Col:Byte;Where:Word);
Function GetPixel(X,Y:word;Where:Word):Byte;
Procedure Cls(Col:Byte;Where:Word);
Procedure WaitVBL;
Procedure GetColor(Col:Byte;Var R,G,B:Byte);
Procedure SetColor(Col,R,G,B:Byte);
Procedure GetPalette(Var Pal:RgbList);
Procedure SetPalette(Pal:RgbList);
Procedure RotatePal(Var Pal:RgbList;First,Last:Byte);
Procedure Fade(Target:RgbList);
Procedure Circle(X,Y,R:Integer;Col:Byte;Where:Word);
Function Sgn(A:Real):Integer;
Procedure Line(X1,Y1,X2,Y2,Col:Integer;Where:Word);
Procedure InitTables;
Procedure ClearTables;
Procedure InitVirt;
Procedure CloseVirt;
Procedure CopyPage(From,Too:Word);
Procedure LoadPCX(Filename:String;Where:Word);
Procedure LoadPal(Filename:String;Var Pal:RgbList);

Implementation

Procedure Initgraph; Assembler;
Asm
   mov ah,0
   mov al,13h
   int 10h
End;

Procedure Closegraph; Assembler;
Asm
   mov ah,0
   mov al,03h
   int 10h
End;

Procedure PutPixel(X,Y:word;Col:Byte;Where:Word);
Begin
     Mem[Where:(y*320)+x]:=Col;
End;

Function GetPixel(X,Y:word;Where:Word):Byte;
Begin
     GetPixel:=Mem[Where:(y*320)+x];
End;


Procedure Cls(Col:Byte;Where:Word);
Begin
     Fillchar(Mem[Where:0000],64000,Col);
End;

Procedure WaitVBL; Assembler;
Label A1,A2;
Asm
   Mov DX,3DAh
   A1:
      In AL,DX
      And AL,08h
      Jnz A1
   A2:
      In AL,DX
      And AL,08h
      Jz A2
End;

Procedure GetColor(Col:Byte;Var R,G,B:Byte);
Begin
     Port[$3C7]:=Col;
     R:=Port[$3C9];
     G:=Port[$3C9];
     B:=Port[$3C9];
End;

Procedure SetColor(Col,R,G,B:Byte);
Begin
     Port[$3C8]:=Col;
     Port[$3C9]:=R;
     Port[$3C9]:=G;
     Port[$3C9]:=B;
End;

Procedure GetPalette(Var Pal:RgbList);
Var A:Byte;
Begin
     For A:=0 To 255 do GetColor(A,Pal[A].R,Pal[A].G,Pal[A].B);
End;

Procedure SetPalette(Pal:RgbList);
Var A:Byte;
Begin
     WaitVBL;
     For A:=0 To 255 do SetColor(A,Pal[A].R,Pal[A].G,Pal[A].B);
End;

Procedure RotatePal(Var Pal:RgbList;First,Last:Byte);
Var Temp:RgbItem;
    A:Byte;
Begin
     Temp:=Pal[Last];
     For A:=Last-1 DownTo First Do Pal[A+1]:=Pal[A];
     Pal[First]:=Temp;
End;

Procedure Fade(Target:RgbList);
Var Tmp:RgbList;
    Flag:Boolean;
    Loop:Integer;
Begin
     Repeat
           Flag:=True;
           GetPalette(Tmp);
           For Loop:=0 To 255 Do
           Begin
                If Tmp[Loop].R>Target[Loop].R Then
                Begin
                     Dec(Tmp[Loop].R);
                     Flag:=False;
                End;
                If Tmp[Loop].G>Target[Loop].G Then
                Begin
                     Dec(Tmp[Loop].G);
                     Flag:=False;
                End;
                If Tmp[Loop].B>Target[Loop].B Then
                Begin
                     Dec(Tmp[Loop].B);
                     Flag:=False;
                End;
                If Tmp[Loop].R<Target[Loop].R Then
                Begin
                     Inc(Tmp[Loop].R);
                     Flag:=False;
                End;
                If Tmp[Loop].G<Target[Loop].G Then
                Begin
                     Inc(Tmp[Loop].G);
                     Flag:=False;
                End;
                If Tmp[Loop].B<Target[Loop].B Then
                Begin
                     Inc(Tmp[Loop].B);
                     Flag:=False;
                End;
           End;
           SetPalette(Tmp);
     Until Flag;
End;

Procedure Circle(X,Y,R:Integer;Col:Byte;Where:Word);
Var Px,Py:Integer;
    Deg:Word;
Begin
     For Deg:=0 to 1799 Do
     Begin
          Px:=Trunc(R*Sines^[Deg]+X);
          Py:=Trunc(R*Cosines^[Deg]+Y);
          PutPixel(Px,Py,Col,Where);
     End;
End;

Function Sgn(A:Real):Integer;
Begin
     If A<0 then Sgn:=-1;
     If A=0 then Sgn:=0;
     If A>0 then Sgn:=+1;
End;

Procedure Line(X1,Y1,X2,Y2,Col:Integer;Where:Word);
Var Deltax,S,Deltay,Dx1,Dy1,Dx2,Dy2,S1,S2:Real;
    I:Integer;
Begin
     Deltax:=X2-X1;
     Deltay:=Y2-Y1;
     Dx1:=Sgn(Deltax);
     Dy1:=Sgn(Deltay);
     Dx2:=Sgn(Deltax);
     Dy2:= 0;
     S1:=Abs(Deltax);
     S2:=Abs(Deltay);
     If Not (S1>S2) Then
     Begin
          Dx2:=0;
          Dy2:=Sgn(Deltay);
          S1:=Abs(Deltay);
          S2:=Abs(Deltax);
     End;
     S:=Int(S1/2);
     For I:=0 To Round(S1) Do
     Begin
          PutPixel(X1,Y1,Col,Where);
          S:=S+S2;
          If Not (S<S1) Then
          Begin
               S:=S-S1;
               X1:=X1+Round(Dx1);
               Y1:=Y1+Round(Dy1);
          End
          Else
          Begin
               X1:=X1+Round(dx2);
               Y1:=Y1+Round(Dy2);
          End;
     End;
End;

Procedure InitTables;
Var A:Word;
    B:Real;
Begin
     Getmem(Sines,Sizeof(Sines^));
     Getmem(Cosines,Sizeof(Cosines^));
     B:=0;
     For A:=0 To 1799 Do
     Begin
          Sines^[A]:=Sin(B);
          Cosines^[A]:=Cos(B);
          B:=B+0.005;
     End;
End;

Procedure ClearTables;
Begin
     Freemem(Sines,Sizeof(Sines^));
     Freemem(Cosines,Sizeof(Cosines^));
End;

Procedure InitVirt;
Var A:Byte;
Begin
     For A:=1 To Npages Do
     Begin
          GetMem(Virt[A],64000);
          VP[A]:=Seg(Virt[A]^);
     End;
End;

Procedure CloseVirt;
Var A:Byte;
Begin
     For A:=1 To Npages Do
     Begin
          Freemem(Virt[A],64000);
          VP[A]:=$A000;
     End;
End;

Procedure CopyPage(From,Too:Word);
Begin
     WaitVbl;
     Move(Mem[From:0],Mem[Too:0],64000);
End;

Procedure LoadPCX(Filename:String;Where:Word);
Var Fil:File;
    Dx,Dy:Word;
    J,M:Byte;
    Ph:Word;
    Buff:Array[0..127] of byte;
Begin
     Assign(Fil,Filename);
     Reset(Fil,1);
     Blockread(Fil,Buff,128);
     Dy:=0;
     Repeat
           Dx:=0;
           Repeat
                 BlockRead(Fil,J,1);
                 If J>192 Then
                 Begin
                      BlockRead(Fil,M,1);
                      Dec(J,192);
                      For Ph:=1 To J Do
                      Begin
                           PutPixel(Dx,Dy,M,Where);
                           Inc(Dx);
                      End;
                 End
                 Else
                 Begin
                      PutPixel(Dx,Dy,J,Where);
                      Inc(Dx);
                 End;
           Until Dx>=320;
           Inc(Dy);
     Until Dy=200;
     BlockRead(Fil,M,1);
     If M=12 Then
     Begin
          BlockRead(Fil,PCXPal,768);
          For M:=0 To 255 Do
          Begin
               PCXPal[M].R:=PCXPal[M].R Div 4;
               PCXPal[M].G:=PCXPal[M].G Div 4;
               PCXPal[M].B:=PCXPal[M].B Div 4;
          End;
     End;
     Close(Fil);
End;

Procedure LoadPal(Filename:String;Var Pal:RgbList);
Var F:File;
Begin
     Assign(F,Filename);
     Reset(F,1);
     Blockread(F,Pal,768);
     Close(F);
End;

Begin
End.