{----------------------------------- 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.