{----------------------------------- XtaC -----------------------------------}
{ File - MEMGRFX.PAS }
{ Created - 20/08/1996, 0:15:00 AM }
{ Programmer - Milton Moura aka XtaC aka U2RDEAD aka Xboy¨ }
{ Comments - This is, like, my 1st demo... Cewl, Hum? }
{----------------------------------- XtaC -----------------------------------}
Unit MemGrfx;
{ -------------------------------------------------------------------------- }
InterFace
{ -------------------------------------------------------------------------- }
Uses Crt,Dos;
Const
VGA: Word = $a000;
wColor: Array[0..15] of Byte =
( 16, 17, 18, 19, 20 ,21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31);
Type
ColType = Record
R, G, B: Byte;
End;
PalType = Array[0..255] of ColType;
{ -------------------------------------------------------------------------- }
Procedure SetMCGA;
Procedure SetText;
Procedure Cls (Col: Byte; Where: Word);
Procedure WaitRetrace;
Procedure Fadecurs;
Procedure FadeOut;
Procedure WriteFile(Strg: String);
Procedure ReadFile(Str: String;Where: Word);
Procedure Pal(ColorNo : Byte; R,G,B : Byte);
Procedure LoadPal (FileName : string);
Procedure PutPixel (X,Y : Integer; Col : Byte; Where: Word);
Procedure SetPal(Var Palet : PalType);
Procedure GetPal(Col : Byte; Var R, G, B : Byte);
Function GetPixel(X, Y: Word;Where: Word): Byte;
procedure setpalt(c,r,g,b:byte);
Function EscPressed: Boolean;
{ -------------------------------------------------------------------------- }
ImpleMentation
{ -------------------------------------------------------------------------- }
Function EscPressed: Boolean;
Var Esc: Char;
Begin
Esc:= '#';
EscPressed:=False;
If Keypressed then Esc:=Readkey;
If Esc in [#113,#81] Then Begin
SetText; Writeln('XtaC Demo'); Writeln('Milton Moura, 1996'); Halt;
End;
If Esc in [#27,#13,' '] then EscPressed:=True;
End;
{ -------------------------------------------------------------------------- }
Function GetPixel(X, Y: Word; Where: Word): Byte;
Begin
GetPixel := Mem [Where:X+(Y*320)];
End;
{ -------------------------------------------------------------------------- }
procedure setpalt(c,r,g,b:byte); assembler; asm
mov dx,3c8h; mov al,[c]; out dx,al; inc dx; mov al,[r]
out dx,al; mov al,[g]; out dx,al; mov al,[b]; out dx,al; end;
{ -------------------------------------------------------------------------- }
Procedure SetMCGA; Assembler;
Asm
MOV AX, 0013h
INT 10h
End;
{ -------------------------------------------------------------------------- }
Procedure SetText; Assembler;
Asm
MOV AX, 0003h
INT 10h
End;
{ -------------------------------------------------------------------------- }
Procedure Cls (Col: Byte; Where: Word);
Begin Fillchar( Mem [Where:0], 64000, Col); End;
{ -------------------------------------------------------------------------- }
Procedure WaitRetrace; assembler;
Label l1, l2;
Asm
MOV DX, 3DAh
l1:
IN AL, DX
AND AL, 08h
JNZ l1
l2:
IN AL, DX
AND AL, 08h
JZ l2
End;
{ -------------------------------------------------------------------------- }
Procedure PutPixel (X,Y : Integer; Col : Byte; Where: Word); Assembler;
Asm
push ds
push es
mov ax,[where]
mov es,ax
mov bx,[X]
mov dx,[Y]
push bx {; and this again for later}
mov bx, dx {; bx = dx}
mov dh, dl {; dx = dx * 256}
xor dl, dl
shl bx, 1
shl bx, 1
shl bx, 1
shl bx, 1
shl bx, 1
shl bx, 1 {; bx = bx * 64}
add dx, bx {; dx = dx + bx (ie y*320)}
pop bx {; get back our x}
add bx, dx {; finalise location}
mov di, bx
{; es:di = where to go}
xor al,al
mov ah, [Col]
mov es:[di],ah
pop es
pop ds
End;
{ -------------------------------------------------------------------------- }
Procedure WriteFile(Strg: String);
var data: text;
x, y: integer;
Pixel: Byte;
begin
Assign(data, Strg);
Rewrite(data);
append(data);
for x:=0 to 319 do begin
for y:=0 to 199 do begin
Pixel := GetPixel(x,y,Vga);
write(data,chr(Pixel));
End;
End;
close(data);
end;
{ -------------------------------------------------------------------------- }
procedure ReadFile(Str: String;Where: Word);
var data: text;
x, y, color,code: integer;
Pixel: Char;
begin
Assign(data, Str);
Reset(data);
while not Eof(data) do begin
for x:=0 to 319 do begin
for y:=0 to 199 do begin
read(data,Pixel);
Color:=Ord(Pixel);
putpixel(x, y, color, Where);
end;
end;
end;
close(data);
end;
{ -------------------------------------------------------------------------- }
Procedure Pal(ColorNo : Byte; R,G,B : Byte);
Begin
Port[$3c8] := ColorNo;
Port[$3c9] := R;
Port[$3c9] := G;
Port[$3c9] := B;
End;
{ -------------------------------------------------------------------------- }
procedure LoadPal (FileName : string);
{ This loads the Pallette file and puts it on screen }
type DACType = array [0..255] of record
R, G, B : byte;
end;
var DAC : DACType;
Fil : file of DACType;
I : integer;
BEGIN
assign (Fil, FileName);
reset (Fil);
read (Fil, DAC);
close (Fil);
for I := 0 to 255 do Pal(I,Dac[I].R,Dac[I].G,Dac[I].B);
end;
{ -------------------------------------------------------------------------- }
Procedure SetPal(Var Palet : PalType); Assembler;
Asm
call WaitRetrace
push ds
lds si, Palet
mov dx, 3c8h
mov al, 0
out dx, al
inc dx
mov cx, 768
rep outsb
pop ds
End;
{ -------------------------------------------------------------------------- }
Procedure Fadecurs;
Var
Loop : Byte;
R, G, B : Byte;
Begin
GetPal(7, R, G, B);
For Loop := 0 to 63 do
Begin
WaitRetrace;
WaitRetrace;
Pal(7, R, G, B);
If R > 0 Then Dec(R);
If G > 0 Then Dec(G);
If B > 0 Then Dec(B);
End;
End;
{ -------------------------------------------------------------------------- }
Procedure GetPal(Col : Byte; Var R, G, B : Byte);
Var Rt,Gt,Bt : Byte;
Begin
Asm
mov dx, 3c7h
mov al, [Col]
out dx, al
inc dx
inc dx
in al, dx
mov [Rt],al
in al, dx
mov [Gt],al
in al, dx
mov [Bt],al
End;
R := Rt; G := Gt; B := Bt;
End;
{ -------------------------------------------------------------------------- }
Procedure FadeOut;
Var n, i : byte;
palt : Array[0..255,0..2] of Byte;
Begin
For n:=0 To 255 Do
getpal(n,palt[n,0],palt[n,1],palt[n,2]);
For i:=0 To 63 Do Begin
waitretrace;
For n:=0 To 255 Do Begin
If palt[n,0]>0 Then
dec(palt[n,0]);
If palt[n,1]>0 Then
dec(palt[n,1]);
If palt[n,2]>0 Then
dec(palt[n,2]);
pal(n,palt[n,0],palt[n,1],palt[n,2]);
End;
End;
End;
End.
