View \MODE13H.PAS

SpellView V1.2

Submitted By: Unknown
Rating: (Not rated) (Rate It)

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.