Experimenty s VGA
Příloha 1.

program vga;

uses
	crt, dos;

type
	ModeRecord = record
		Code: byte;
		SizeX: word;
		SizeY: word;
	end;
const
	SetReset		= 0;		{ registry VGA }
	EnableSetReset		= 1;
	ColorCompare		= 2;
	DataRotate		= 3;
	ReadMapSelect		= 4;
	ModeRegister		= 5;
	MiscGraphicsCtrl	= 6;
	ColorMask		= 7;
	BitMask			= 8;

	{ informace k modu 640 na 480 }
	Mode640x480: ModeRecord = (Code: $12; SizeX: 640; SizeY: 480);

var
	SizeX: word;				{ pocet bodu v x }
	SizeY: word;				{ pocet bodu v y }
	OriginalMode: byte;			{ puvodni obrazovy mod }

procedure Pause;				{ ceka na stisk klavesy }
begin
	while keypressed do
		readkey;
	while not keypressed do;
end;

procedure InitGraph;				{ prepnuti do grafickeho rezimu }
	var r: Registers;
begin
	r.AH:= $0F;				{ cteni stavajiciho modu }
	Intr($10, r);
	OriginalMode:= r.AL;			{ uloz stavajici mod }
	SizeX:= Mode640x480.SizeX;
	SizeY:= Mode640x480.SizeY;
	r.AL:= Mode640x480.Code;
	r.AH:= $00;				{ sluzba nastaveni zobrazovaciho modu }
	Intr($10, r);
end;

procedure CloseGraph;
	var r: Registers;
begin
	r.AL := OriginalMode;
	r.AH := $00;				{ sluzba nastaveni zobrazovaciho modu }
	Intr($10, r);
end;

{ zapis do VGA grafickeho registru }
procedure SetReg(reg: byte; data: byte);
begin
	port[$3CE]:= reg;
	port[$3CF]:= data;
end;

procedure PutPixel(x, y: integer; color: byte);
	var
		addr: word;
		bit: word;
begin
	addr:= y * 80 + x shr 3;
	bit:= $80 shr (x and 7);
	SetReg(ModeRegister, 2);		{ zapis typu 2 }
	SetReg(BitMask, bit);			{ urcuje bit, který se bude modifikovat }
	mem[SegA000:addr]:= mem[SegA000:addr];	{ cteni latch registru }
	mem[SegA000:addr]:= color;		{ barva }
end;


function GetPixel(x, y: integer): byte;
	var
		addr: word;
		bit, maskb, maskc: word;
		colors: array[0..3] of byte;
		color: byte;
		i: integer;
begin
	addr:= y * 80 + x shr 3;
	bit:= $80 shr (x and 7);
	SetReg(ModeRegister, 0);		{ cteni }
	for i:= 0 to 3 do begin
		SetReg(ReadMapSelect, i);	{ volba cteci roviny, jedna ze tri }
		colors[i]:= mem[SegA000:addr];
	end;
	maskb:= 1; maskb:= maskb shl bit; maskc:= 1;
	color:=0;
	for i:=0 to 3 do begin
		if ((colors[i] and maskb) > 0) then
			color:= color or maskc;
		maskc:= maskc shl 1;
	end;
	GetPixel:= color;
end;

procedure ChoosePalette(Color, DACColor: byte);
begin
	if (Color >= 0) and (Color <= 15) then begin
		{ cekani na VSYNC inicializace portu $3C0 adr. registr }
		while (port[$3DA]) and $9 <> $9 do;

		{ 011111, nulovy bit 5 zakazuje zobrazovani }
		port[$3C0] := Color and $1F;

		{ nastaveni barvy }
		port[$3C0] := DACColor;

		{ 100000, povoleni zobrazovani }
		port[$3C0] := $20;
	end;
end;

procedure SetPalette(DACColor:byte; Red, Green, Blue: byte);
begin
	port[$3C6] := $FF;
	port[$3C8] := DACColor;
	port[$3C9] := Red;
	port[$3C9] := Green;
	port[$3C9] := Blue;
end;

procedure PutByte(x, y: integer; color: byte);
	var
		addr: word;
		bit: word;
		i, j: byte;
begin
	addr:= y * 80 + x shr 3;
	bit:= $80 shr (x and 7);
	i:= bit div 2;
	while i > 0 do begin
		bit:= bit + i;
		i:= i div 2;
	end;

	SetReg(ModeRegister, 2);
	SetReg(BitMask, bit);
	mem[SegA000:addr]:= mem[SegA000:addr];
	mem[SegA000:addr]:= color;

	j := x mod 8; i := 64; bit := 128;
	while j > 1 do begin
		bit:= bit + i;
		i:= i div 2;
		dec(j);
	end;
	if (x mod 8) <> 0 then begin
		inc(addr);
		SetReg(ModeRegister, 2);
		SetReg(BitMask, bit);
		mem[SegA000:addr]:= mem[SegA000:addr];
		mem[SegA000:addr]:= color;
	end;
end;

procedure Task1;
	var
		x, y: integer;
		color: byte;
begin
	for y := 0 to 399 do
		for x := 0 to 399 do begin
			color:=  (4 * (y div 100) + (x div 100));
			PutPixel(x, y, color);
		end;
end;

procedure Task2;
	var x, y: integer;
begin
	for x:= 0 to 399 do
		PutPixel(x, 100, 0);
	for y:= 0 to 399 do
		PutPixel(100, y, 0);
end;

procedure Task3;
	var
		i:integer;
begin
	for i:= 0 to 15 do
		ChoosePalette(i, i);
	for i:= 0 to 63 do
		SetPalette(i, 4 * i, 0 ,0);
end;

procedure Task4;
	var x, y, i: integer;
begin
	for x:=1 to 4 do
		for y:=0 to 479 do
			PutByte(x * 31, y, 15);
end;

procedure Save(FileName: string);
	var
		f: text;
		x, y: integer;
		color: byte;
		hex: word;
		i: integer;
	const
		hexdig: array [0..15] of char='0123456789ABCDEF';
begin
	assign(f, FileName); rewrite(f);
	for y:= 0 to 399 do begin
		for x:= 0 to 399 do begin
			color:= GetPixel(x, y);
			hex:= color mod 16 ;
			write(f, hexdig[hex]);
		end;
	end;
	close(f);
end;

procedure Load(FileName: string);
	var
		f: text;
		x, y: integer;
		c: char;
		color: byte;
begin
	x:= -1; y:= -1;
	assign(f, FileName); reset(f);
	while (not(eof(f))) do begin
		x:= (x + 1) mod 400;
		if x = 0 then
			y:= y + 1;
		read(f, c);
		if (c >= '0') and (c <= '9') then
			color:= ord(c) - ord('0')
		else
			color:= ord(c) - ord('A') + 10;
		PutPixel(x, y, color);
	end;
end;

begin
	InitGraph;

	Task1;
	Save('screen.dat');
	Pause;
	Task3;
	Pause;
	Task2;
	Pause;
	Task4;
	Pause;
	Load('screen.dat');
	Pause;

	CloseGraph;
end.