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

Pascal/Delphi Source File | 1996-09-08 | 12.3 KB | 507 lines

Unit Mode13h;

{ Version 1.3 }

Interface

Const VGA=$A000;
      Npages=2;
      TableElements=360;

Type RgbItem=Record
                   R,G,B:Byte;
             End;
     RgbList=Array[0..255] of RgbItem;
     Table=Array[0..TableElements] 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);
Procedure PutClippedPixel(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 LineC(X1,Y1,X2,Y2,Col:Integer;Where:Word);
Procedure Poly(X1,Y1,X2,Y2,X3,Y3,X4,Y4:Word;Color:Byte;Where:Word);
Procedure FPoly(X1,Y1,X2,Y2,X3,Y3,X4,Y4:Word;Color:Byte;Where:Word);
Procedure Ellipse(X,Y,RH,RV:Integer;Col:Byte;Where:Word);
Procedure Arc(X,Y,RH,RV:Integer;SAngle,EAngle:Integer;Col:Byte;Where:Word);
Procedure FEllipse(X,Y,RH,RV:Integer;Col:Byte;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;

Procedure PutClippedPixel(X,Y:word;Col:Byte;Where:Word);
Begin
     If (X<0) Or (X>319) Then Exit;
     If (Y<0) Or (Y>199) Then Exit;
     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 TableElements 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 LineC(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
          If (X1>=0) And (Y1>=0) And (X1<=319) And (Y1<=199) Then
            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 Poly(X1,Y1,X2,Y2,X3,Y3,X4,Y4:Word;Color:Byte;Where:Word);
Begin
     Line(X1,Y1,X2,Y2,Color,Where);
     Line(X2,Y2,X3,Y3,Color,Where);
     Line(X3,Y3,X4,Y4,Color,Where);
     Line(X4,Y4,X1,Y1,Color,Where);
End;

Procedure FPoly(X1,Y1,X2,Y2,X3,Y3,X4,Y4:Word;Color:Byte;Where:Word);
Var MnY,MxY:Word;
    DeltaX1,DeltaX2,DeltaX3,DeltaX4:Integer;
    DeltaY1,DeltaY2,DeltaY3,DeltaY4:Integer;
    Y:Word;
    MnX,MxX:Integer;
    X:Integer;
Begin
     MnY:=Y1;
     MxY:=Y1;
     If MnY>Y2 Then MnY:=Y2;
     If MnY>Y3 Then MnY:=Y3;
     If MnY>Y4 Then MnY:=Y4;
     If MxY<Y2 Then MxY:=Y2;
     If MxY<Y3 Then MxY:=Y3;
     If MxY<Y4 Then MxY:=Y4;
     If MnY<0 Then MnY:=0;
     If MxY>199 Then MxY:=199;
     If MnY>199 Then Exit;
     If MxY<0 Then Exit;
     DeltaX1:=(X1-X4); DeltaY1:=(Y1-Y4);
     DeltaX2:=(X2-X1); DeltaY2:=(Y2-Y1);
     DeltaX3:=(X3-X2); DeltaY3:=(Y3-Y2);
     DeltaX4:=(X4-X3); DeltaY4:=(Y4-Y3);
     For Y:=MnY To MnX Do
     Begin
          MnX:=319;
          MxX:=-1;
          If (Y>=Y1) Or (Y>=Y2) Then
            If (Y<=Y1) Or (Y<=Y2) Then
              If Not(Y1=Y2) Then
              Begin
                   X:=(Y-Y1)*DeltaX2 Div DeltaY2 + X1;
                   If X<MnX Then MnX:=X;
                   If X>MxX Then MxX:=X;
              End;
          If (Y>=Y2) Or (Y>=Y3) Then
            If (Y<=Y2) Or (Y<=Y3) Then
              If Not(Y2=Y3) Then
              Begin
                   X:=(Y-Y2)*DeltaX3 Div DeltaY3 + X2;
                   If X<MnX Then MnX:=X;
                   If X>MxX Then MxX:=X;
              End;
          If (Y>=Y3) Or (Y>=Y4) Then
            If (Y<=Y3) Or (Y<=Y4) Then
              If Not(Y3=Y4) Then
              Begin
                   X:=(Y-Y3)*DeltaX4 Div DeltaY4 + X3;
                   If X<MnX Then MnX:=X;
                   If X>MxX Then MxX:=X;
              End;
          If (Y>=Y4) Or (Y>=Y1) Then
            If (Y<=Y4) Or (Y<=Y1) Then
              If Not(Y4=Y1) Then
              Begin
                   X:=(Y-Y4)*DeltaX1 Div DeltaY1 + X4;
                   If X<MnX Then MnX:=X;
                   If X>MxX Then MxX:=X;
              End;
          If MnX<0 Then MnX:=0;
          If MxX>319 Then MxX:=319;
          If MnX<MxX Then Line(MnX,Y,MxX,Y,Color,Where);
     End;
End;

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

Procedure Arc(X,Y,RH,RV:Integer;SAngle,EAngle:Integer;Col:Byte;Where:Word);
Var Px,Py:Integer;
    Deg:Word;
Begin
     SAngle:=Trunc(TableElements/360 * SAngle);
     EAngle:=Trunc(TableElements/360 * EAngle);
     For Deg:=SAngle to EAngle Do
     Begin
          Px:=Trunc(RH*Sines^[Deg]+X);
          Py:=Trunc(RV*Cosines^[Deg]+Y);
          PutPixel(Px,Py,Col,Where);
     End;
End;

Procedure FEllipse(X,Y,RH,RV:Integer;Col:Byte;Where:Word);
Var Px1,Px2,Py:Integer;
    Delta:Integer;
    Deg:Word;
Begin
     For Deg:=0 to (TableElements Div 2) Do
     Begin
          Delta:=Trunc(RH*Sines^[Deg]);
          Px1:=Delta+X;
          Px2:=X-Delta;
          Py:=Trunc(RV*Cosines^[Deg]+Y);
          Line(Px1,Py,Px2,Py,Col,Where);
     End;
End;

Procedure InitTables;
Var A:Word;
    B:Real;
    Increment:Real;
Begin
     Getmem(Sines,Sizeof(Sines^));
     Getmem(Cosines,Sizeof(Cosines^));
     B:=0;
     Increment:=2*PI/TableElements;
     For A:=0 To TableElements Do
     Begin
          Sines^[A]:=Sin(B);
          Cosines^[A]:=Cos(B);
          B:=B+Increment;
     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);
          Virt[A]:=NIL;
          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.