UNIT MCGA256;

{***************************************************************************}
{																			}
{		Author:				Kevin A. Lee									}
{																			}
{		Last Amended:	    18th April, 1993								}
{																			}
{		Description:		The pasKAL graphics library. Version 2.0		}
{							POSTCARD-WARE (c) Kevin A. Lee. 1992, 1993.     }
{                                                                           }
{ A Turbo Pascal V6 MCGA 320x200 256 colour	graphics library. This library 	}
{ was originally intended for games programming but the routines are 		}
{ suitable for many other applications.										}
{																			}
{ The main features of the library are:										}
{ 	- all routines write either directly to the screen or to a hidden page 	}
{	  in memory.															}
{   - quick and easy sprite routines; as many sprites as you can fit into 	}
{	  memory, with user definable sizes upto 160*200. 						}
{	- loading of PCX files, either as entire screens or as individual 		}
{	  sprites.																}
{	- individual pixel reading and writing.									}
{	- line and rectangle drawing.											}
{	- character and string writing at any position.							}
{	- simple area-rectangle stretching.										}
{	- different font styles and sizes.										}
{	- font creation utility.												}
{	- DAC palette manipulation.												}
{	- quick palette fades (both in and out).								}
{	- Microsoft mouse routines.												}
{	- joystick routines.													}
{	- Adlib FM sound routines												}
{	- FASTish - most of the code is assembler.								}
{	- full source code included.											}
{	- its completely free.													}
{                                                                           }
{ For more details refer to the file PASKAL.DOC	included with this library.	}
{																			}
{ N.B. Unfortunately this code is not completely bug free; I don't really 	}
{ have the time or inclination to find and fix all of them so its over to 	}
{ you!																		}
{																			}
{ ALL OF THESE ROUTINES ARE FREE. YOU MAY USE THESE ROUTINES AS IS, FOR		}
{ UNLIMITED USE IN BOTH COMMERICIAL AND NON-COMMERICAL ENVIRONMENTS. YOU 	}
{ MAY USE AND AMEND THE SOURCE IN ANY WAY YOU WISH AS LONG AS THE RESULTING }
{ PROGRAM(S) DO NOT CONFLICT WITH THIS LIBRARY. THAT IS TO SAY, YOU MAY NOT }
{ SELL THE LIBRARY OR ANY SUCH LIBRARY BASED ON IT. IF YOU DO MAKE SOME 	}
{ MONEY USING THE ROUTINES AND YOU FEEL GENEROUS YOU COULD SEND ME SOME. 	}
{ HOWEVER, YOU ARE NOT REQUIRED TO DO SO. ALL I ASK IS THAT YOU GIVE ME 	}
{ SOME CREDIT IN YOUR FINAL PROGRAM AND SEND ME A POSTCARD.	HENCE THE 		}
{ POSTCARD-WARE TAG.                                            			}
{																			}
{								Kevin A. Lee								}
{ 						 73, Frederick Neal Avenue,							}
{						  Eastern Green, Coventry,							}
{						   Warwickshire, CV5 7EJ.							}
{							   UNITED KINGDOM.								}
{																			}
{ THE ROUTINES ARE DISTRIBUTED AS IS. I (Kevin Lee) SPECIFICALLY DISCLAIM	}
{ ANY RESPONSIBILITY FOR ANY LOSS OF PROFIT OR ANY INCIDENTAL, CONSEQUEN- 	}
{ TIAL OR OTHER DAMAGES.													}
{***************************************************************************}

INTERFACE


uses
	Dos, Memory;


const
	MinX = 0;							{ Minimum X coordinate			}
    MinY = 0;  							{ Minimum Y coordinate			}
    MaxX = 319;							{ Maximum X coordinate			}
    MaxY = 199;                         { Maximum Y coordinate			}
    MaxColor = 255;						{ Maximum number of colours		}
    MaxFont = 3;						{ Maximum font number			}
	MaxSpriteSize = 160*200;  			{ Size of largest sprite (x*y) 	}

type
	{ which page are we writing to }
    PageType = (UserScreen, VirtualScreen);

	{ definition of a palette: 256 triples with each triple containing 	}
    { red, green and blue intensities for each colour					}
	PaletteArray = array [0..768] of byte;

	{ definition of the VirtualScreen }
	ScreenPointer = ^ScreenType;
	ScreenType = array [1..64000] of byte;		

    { definition of a sprite }
    SpriteData = array [0..MaxSpriteSize-1] of byte;
    SpritePointer = ^SpriteType;
	SpriteType = record							
    	oldx, oldy,						{ old location 		}
		x, y,			      			{ current location  }
		w, h, offbuf: integer;         	{ width, height and offset into buf. }
		SpriteData, buffer: SpriteData; { sprite image and sprite background }
    end;

var
	{ The actual virtual screen }
  	VirtualScrPtr: ScreenPointer;


function VGACardExists: boolean;
{																			}
{	Returns:			true if this computer has a VGA card, else false.	}
{																			}
{	Description:		Checks if the computer has the correct video card	}
{						in order to run the graphics library.				}


function OpenGraphics: boolean;
{																			}
{	Returns:			false if the graphics library cannot be opened 		}
{						else true.											}
{																			}
{	Description:		Sets the screen mode to MCGA 256 color mode,		}
{						allocates memory for the VirtualScreen and 			}
{						initialise all relevant variables.					}


procedure CloseGraphics;
{																			}
{	Description:		Deallocates the memory used by the VirtualScreen	}
{						and returns to text mode.							}


function CreateSprite(Width, Height: word): SpritePointer;
{																			}
{	Parameters:			Width, Height - width and height of sprite to		}
{						create. NB width*height should be < MaxSpriteSize.	}
{                                                                           }
{	Returns:			A pointer to a sprite if succesful, else nil.      	}
{                                                                           }
{	Description:        Allocates the memory required for a sprite.			}


procedure DestroySprite(Sprite: SpritePointer);
{																			}
{	Parameters:			Sprite - sprite which to destroy.					}
{                                                                           }
{	Description:		Deallocates all memory used by a sprite.			}


function LoadSprite(FileName: string; Sprite: SpritePointer): boolean;
{																			}
{	Parameters:			FileName - name of file to load.					}
{						Sprite - Sprite to place data into.					}
{                                                                           }
{	Returns:			false if an error occurs (i.e. file does not exist	}
{						or it contains invalid data), else true.			}
{																			}
{	Description:		Loads the sprite data from a sprite file.			}
{						See the file PASKAL.DOC for an explanation of the	}
{						construction of the file.							}


procedure SetActivePage(Page: PageType);
{																			}
{	Parameters:			Page - page which output is to be sent to, one of	}
{						UserScreen, VirtualScreen.							}
{																			}
{	Description:		Controls whether output is sent to the user or		}
{						virtual screen.										}


procedure CopyAllVirtualScreen;
{																			}
{	Description:		Copies all the virtual screen to the users screen.	}
{						Only use this if you are writing over the entire	}
{						virtual screen.										}


procedure CopyVirtualScreen(y1, y2: word);
{																			}
{	Parameters:			Copies the virtual screen from row y1 to row y2 	}
{						onto the user screen. Use this procedure if you		}
{						are only writing over part of the virtual screen.	}


procedure DrawSprite(Sprite: SpritePointer);
{																			}
{	Parameters:			Sprite - the sprite to be drawn.					}
{                                                                           }
{	Description:		Draws the sprite 'Sprite' using its current			}
{						coordinates x and y.								}
{						Save/RestoreSprite should be used if you want to    }
{						keep the user screen intact.    					}


procedure SaveSprite(Sprite: SpritePointer);
{																			}
{	Parameters:			Sprite - the background of the sprite to be saved.	}
{                                                                           }
{	Description:		Saves the area of the screen which is under	the 	}
{						sprite 'Sprite'.									}
{						Call before RestoreSprite.							}


procedure RestoreSprite(Sprite: SpritePointer);
{																			}
{	Parameters:			Sprite - the background of the sprite to restore. 	}
{                                                                           }
{	Description:		Restores the area of the screen which is under the	}
{						sprite 'Sprite'.									}
{						Call after SaveSprite.								}


procedure PutPixel(x, y: word; colour: byte);
{																			}
{	Parameters:			x, y - coordinates of pixel.						}
{						colour - colour of pixel.							}
{																			}
{	Description:		Puts a pixel on the screen at the specified			}
{						position.											}


function GetPixel(x, y: word): byte;
{																			}
{	Parameters:			x, y - coordinates of pixel.						}
{																			}
{	Returns:			The colour of the specified pixel.					}
{																			}
{	Description:		Gets the colour of a pixel on the screen at the		}
{						specified position.									}


procedure Line(x1, y1, x2, y2: word; colour: byte);
{																			}
{	Parameters:			x1, y1, x2, y2 - coordinates of line.				}
{						colour - colour to draw line in.					}
{																			}
{	Description:		Draws a line on the screen with upper left 			}
{						corner x1, y1 and lower right corner x2, y2.		}


procedure Rectangle(x1, y1, x2, y2: word; colour: byte);
{																			}
{	Parameters:			x1, y1, x2, y2 - coordinates of rectangle.			}
{						colour - colour to draw rectangle in.				}
{																			}
{	Description:		Draw a rectangle on the screen with upper left		}
{						corner x1, y1 and lower right corner x2, y2.		}


procedure FillRectangle(x1, y1, x2, y2: word; colour: byte);
{																			}
{	Parameters:			x1, y1, x2, y2 - coordinates of rectangle.			}
{						colour - colour to draw/fill rectangle in.			}
{																			}
{	Description:		Draws a filled rectangle on the screen with	uppper 	}
{						left corner x1, y1 and lower right corner x2, y2.   }


procedure SetTextFont(font: word);
{																			}
{	Parameters:			font - number of font to choose.					}
{																			}
{	Description:		Sets the font number.								}
{						See the file PASKAL.DOC for a description of the	}
{						fonts available.									}



procedure SetTextWidth(width: word);
{																			}
{	Parameters:			width - factor to multiply width of text by.		}
{						e.g. if 2 width will be doubled.					}
{																			}
{	Description:		Sets the width of a text font.						}


procedure SetTextHeight(height: word);
{																			}
{	Parameters:			height - factor to multiply height of text by.		}
{						e.g. if 2 height will be doubled.					}
{																			}
{	Description:		Sets the height of a text font.						}


procedure SetTextSpacing(spacing: integer);
{																			}
{	Parameters:			spacing - the space between characters for			}
{						displaying strings.									}
{																			}
{	Description:		Sets the spacing interval of a text font.			}


procedure DisplayChar(ch: char; x, y: word; colour: byte);
{																			}
{	Parameters:			ch - character to display.							}
{						x, y - coordinates of character.					}
{						colour - colour of character.						}
{																			}
{	Description:		Writes a character on the screen using the			}
{						current	width and height factors.					}


procedure DisplayString(str: string; x, y: word; colour: byte);
{																			}
{	Parameters:			str - string to display.							}
{						x, y - start coordinates of string.					}
{						colour - colour of string.							}
{																			}
{	Description:		Writes a string on the screen using the	current		}
{						width, height and spacing factors.					}


procedure DACRemapColour(index, red, green, blue: byte);
{																			}
{	Parameters:			index - colour index (0-255).						}
{						red, green, blue - values of red green and blue		}
{						registers (0-63).									}
{																			}
{	Description:		Remaps the DAC colour 'index' to the values			}
{						specified.											}


function LoadPalette(FileName: string; var Pal: PaletteArray): boolean;
{																			}
{	Parameters:			FileName - name of file containing palette.			}
{						Pal - array in which to place palette values.		}
{                                                                           }
{	Returns:			false if an error occurs, else true.                }
{																			}
{	Description:		Loads into an array a 256 colour palette.			}
{						The	palette	is in the form of 256 three byte sets.	}
{						Each set comprises of R, G, and B values, the first }
{						three bytes being for colour zero the 256th triple 	}
{						being for colour 255.								}


procedure SetPalette(Pal: PaletteArray);
{																			}
{	Parameters:			Pal - array containing 256 colour palette.			}
{																			}
{	Description:		Sets the palette to the values specified in the		}
{						array. The construction of this array is described	}
{						in LoadPalette.										}


procedure FadeIn(var Pal: PaletteArray);
{																			}
{	Parameters:			Pal - the palette to fade into.						}
{																			}
{	Description:		Fades the entire palette from its existing values	}
{						into the array passed.								}


procedure FadeOut(var Pal: PaletteArray);
{																			}
{	Parameters:			Pal - the palette to fade out to.					}
{																			}
{	Description:		Fades the entire palette from its existing values	}
{						out to the array passed.							}


function LoadPCX(FileName: string; ScrPtr: pointer): boolean;
{																			}
{	Parameters:			FileName - name of file to load.					}
{						ScrPtr - area to place in memory e.g. VirtualScreen	}
{                                                                           }
{	Returns:			false if an error occurs, else true.				}
{																			}
{	Description:		Loads a 320x200 256 colour PCX file into memory.	}


procedure RectStretch(xs1, ys1, xs2, ys2, xd1, yd1, xd2, yd2: word);
{																			}
{	Parameters:			xs1, ys1, xs2, ys2 - source rectangle.				}
{						xd1, yd1, xd2, yd2 - destination rectangle.			}
{																			}
{	Description:        Stretches an existing rectangle on the screen		}
{						to a different sized rectangle on the screen.		}




IMPLEMENTATION

type
	FontChar = array[0..7] of byte;			{ Each font is 8x8 in size 		}
    Font = array[32..127] of FontChar;		{ Only describe charcters in 	}
    										{ the range 32..127 ASCII		}

{$I TinyFont}			{ include Tiny Font definitions }
{$I LineFont}			{ include Line Font definitions }

var
	TextWidth: word;  			{ factor to increase width of text by 		}
	TextHeight: word;			{ factor to increase height of text by 		}
	TextSpacing: integer;		{ space (in pixels) between characters 		}
    TextFont: word;				{ which text font to use 					}
	SegVirtual: word;			{ which segment is the virtual screen in	}
    SegScreen: word;			{ which screen are we writing to			}



function Sign(x: integer): integer;
begin
	if (x > 0) then Sign := 1
    else Sign := -1;
end; {Sign}



function VGACardExists: boolean;
var card: byte;
begin
	asm
    	mov		ah, 12h
        xor		al, al
        mov		bl, 32h
        int		10h
        mov		card, al
    end;

    VGACardExists := (card = $12);
end; {VGACardExists}



function OpenGraphics: boolean;
begin
	TextWidth   := 1;
    TextHeight  := 1;
    TextSpacing := 1;
    TextFont 	:= 1;

   	VirtualScrPtr := MemAllocSeg(sizeof(ScreenType));
    if (VirtualScrPtr = nil) then
	begin
	 	{ ErrNoMemory }
     	OpenGraphics := false;
        exit;
    end;
    SegVirtual := Seg(VirtualScrPtr^);

	asm
    	mov 	ax, 13h
    	int 	10h
  	end;

    OpenGraphics := true;
end; {OpenGraphics}



procedure CloseGraphics;
begin
    FreeMem(VirtualScrPtr, sizeof(ScreenType));

    asm
    	mov 	ax, 3h
        int 	10h
    end;
end; {CloseGraphics}



function CreateSprite(Width, Height: word): SpritePointer;
var TempSprite: SpritePointer;
begin
	if (Width*Height > MaxSpriteSize) then
    begin
    	CreateSprite := nil;
        exit;
    end;

	TempSprite := MemAlloc(sizeof(SpriteType)-2*(MaxSpriteSize-Width*Height));
    if (TempSprite = nil) then
    begin
    	{ ErrNoMemory }
    	CreateSprite := nil;
    end
    else
    begin
	    TempSprite^.w := Width;
		TempSprite^.h := Height;
        TempSprite^.offbuf := Width*Height + 14;  {How far through structure
                                                  is background buffer}
    	CreateSprite := TempSprite;
    end;
end; {CreateSprite}



procedure DestroySprite(Sprite: SpritePointer);
begin
	FreeMem(Sprite, sizeof(SpriteType)-2*(MaxSpriteSize-Sprite^.w*Sprite^.h));
end; {DestroySprite}



function LoadSprite(FileName: string; Sprite: SpritePointer): boolean;
label quit;
var
  	f: file;
  	Buf: array [1..200] of Byte;
  	BufPointer, Off, NumRead, i, SprSeg, SprOfs,
	SprSize, Count, Value, What: word;
    SprBuf: ^SpriteData;
begin
	assign(f, FileName);
  	{$I-} reset(f, 1); {$I+}
    if (IOResult <> 0) then
    begin
    	{ ErrFileNotFound }
    	LoadSprite := false;
        exit;
    end;

    SprSeg := seg(Sprite^);
    SprOfs := ofs(Sprite^) + 14;
    SprSize := Sprite^.w*Sprite^.h;
    BufPointer := 0;
    Off := 0;

    { skip header }
    {$I-} BlockRead(f, Buf, 128, NumRead); {$I+}
    if (IOResult <> 0) then goto quit;

    SprBuf := MemAlloc(sizeof(SpriteData));
    if (SprBuf = nil) then
    begin
    	{ ErrNoMemory }
        LoadSprite := false;
        exit;
    end;

    {$I-} BlockRead(f, SprBuf^, sizeof(SpriteData), NumRead); {$I+}
    if (IOResult <> 0) then goto quit;

    while (Off < SprSize) do
    begin
        What := SprBuf^[BufPointer];
        Inc(BufPointer);
        Count := What and $C0;
        if (Count = $C0) then
        begin
            Value := SprBuf^[BufPointer];
            Inc(BufPointer);
            Count := What and $3F;
        end
        else
        begin
        	Value := What;
            Count := 1;
        end;

        asm
            cld
        	mov di, SprSeg				{ Copy cx bytes of colour ax 	}
			mov es, di					{ into sprite data area.		}
            mov di, SprOfs
			add di, Off
			mov ax, Value
			mov cx, Count
            add Off, cx
			rep stosb
        end;
 	end;

    FreeMem(SprBuf, sizeof(SpriteData));

quit:
	close(f);
    LoadSprite := (IOResult = 0);
end; {LoadSprite}



procedure SetActivePage(Page: PageType);
begin
	if (Page = VirtualScreen) then SegScreen := SegVirtual
    else SegScreen := $A000;
end; {SetActivePage}



procedure CopyAllVirtualScreen; assembler;
label
	_Retrace, _NoRetrace;
asm
				push	ds
                push	es
   	            mov 	dx, 3DAh		{ input status 1 }
	_Retrace:	in 		al, dx
				test 	al, 1000b		{ are we in a retrace/bit 4 set }
				jnz 	_Retrace		{ if so, look for non-retrace }
	_NoRetrace:	in 		al, dx			{ no, now look for next }
 				test 	al, 1000b		{ is bit 4 set }
				jz 		_NoRetrace
				xor  	si, si
			    xor  	di, di
                cld
			    mov  	ax, SegVirtual
			    mov  	ds, ax
			    mov  	ax, 0A000h
			    mov  	es, ax
			    mov  	cx, 7D00h
			    rep  	movsw
			    pop  	es
			    pop  	ds
end; {CopyAllVirtualScreen}



procedure CopyVirtualScreen(y1, y2: word); assembler;
label
	_Retrace, _NoRetrace;
asm
    			push	ds
                push	es
                mov 	dx, 3DAh		{ input status 1 }
	_Retrace:	in 		al, dx
				test 	al, 1000b		{ are we in a retrace/bit 4 set }
				jnz 	_Retrace		{ if so, look for non-retrace }
	_NoRetrace:	in 		al, dx			{ no, now look for next }
 				test 	al, 1000b		{ is bit 4 set }
				jz 		_NoRetrace
				xor  	si, si
			    xor  	di, di
                cld
                mov		ax, y1			{ calculate start address }
                mov		bx, 320
                mul		bx
                mov		bx, ax
                mov		ax, SegVirtual
                mov		ds, ax
                mov		si, bx
			    mov  	ax, 0A000h
			    mov  	es, ax
                mov		di, bx
			    mov  	ax, y2
                sub     ax, y1
                mov		cx, 320
                mul		cx
                mov		cx, ax
			    rep  	movsw  			{ again, eventuall use movsd }
                pop		es
                pop		ds
end; {CopyVirtualScreen}



procedure DrawSprite(Sprite: SpritePointer); assembler;
label
	_Redraw, _DrawLoop, _Exit, _LineLoop, _NextLine, _Store, _Retrace;
asm
    			push  	ds
    			push  	es
                mov		ax, SegScreen
                mov		es, ax
    			lds   	si, Sprite
    			mov   	ax, [si+4]
    			mov   	bx, [si+6]
	_Redraw:    mov   	[si], ax	  	{ oldx := x }
    			mov   	[si+2], bx		{ oldy := y }
    			push  	ax
    			mov   	ax, 320			{ calculate start address }
    			mul   	bx
    			pop   	bx            	
    			add   	ax, bx
				mov   	di, ax
    			mov   	dx, [si+10]
    			mov   	cx, [si+8]
    			add   	si, 14
    			cld
	_DrawLoop:  push  	di            	
    			push  	cx            	
	_LineLoop:  mov   	bl, byte ptr [si]
    			or    	bl, bl          { if colour zero don't overwrite }
    			jnz   	_Store
	 			inc   	si
    			inc   	di
    			loop  	_LineLoop
    			jmp   	_NextLine
	_Store:		movsb
    			loop  	_LineLoop
	_NextLine:  pop   	cx
    			pop   	di
    			dec   	dx
    			jz    	_Exit
    			add   	di, 320        	
    			jmp   	_DrawLoop
	_Exit:	    pop   	es
    			pop   	ds
end; {DrawSprite}



procedure SaveSprite(Sprite: SpritePointer); assembler;
label
	_Redraw, _DrawLoop, _Exit;
asm
    			push  	ds
    			push  	es
                mov   	ax, SegScreen
    			mov   	ds, ax
    			les   	di, Sprite
    			mov   	ax, es:[di+4]
    			mov   	bx, es:[di+6]
    			push  	ax
    			mov   	ax, 320         { calculate start address }
    			mul   	bx            	
    			pop   	bx            	
    			add   	ax, bx
    			mov   	si, ax
    			mov   	dx, es:[di+10]
    			mov   	cx, es:[di+8]
    			add   	di, es:[di+12]
    			cld
	_DrawLoop:  push  	si            	
    			push  	cx            	
    			rep   	movsb
    			pop   	cx
    			pop   	si
    			dec   	dx
    			jz    	_Exit
    			add   	si, 320        	
    			jmp   	_DrawLoop
	_Exit:	    pop   	es
    			pop   	ds
end; {SaveSprite}



procedure RestoreSprite(Sprite: SpritePointer); assembler;
label
	_Redraw, _DrawLoop, _Exit, _LineLoop, _Retrace;
asm
				push  	ds
    			push  	es
                mov   	ax, SegScreen
    			mov   	es, ax
    			lds   	si, Sprite
    			mov   	ax, [si]
    			mov   	bx, [si+2]     	
    			push  	ax
    			mov   	ax, 320			{ calculate start address }
    			mul   	bx            	
    			pop   	bx            	
    			add   	ax, bx
    			mov   	di, ax
    			mov   	dx, [si+10]
    			mov   	cx, [si+8]
    			add   	si, [si+12]
    			cld
	_DrawLoop:  push  	di              { what no comments - sorry! }
    			push  	cx            	
    			rep   	movsb
    			pop   	cx
    			pop   	di
    			dec   	dx
    			jz    	_Exit
    			add   	di, 320        	
    			jmp   	_DrawLoop
	_Exit:	    pop   	es
    			pop   	ds
end; {RestoreSprite}



procedure PutPixel(x, y: word; colour: byte); assembler;
label _Error;
asm
				mov 	ax, y			
				mov 	bx, x			
				cmp 	ax, MinY        { check y value in range }
				jl 		_Error
				cmp 	ax, MaxY
				jg 		_Error
				cmp 	bx, MinX		{ check x value in range }
				jl 		_Error
				cmp 	bx, MaxX
				jg 		_Error
				xchg 	ah, al			{ ax := 256 * y }
				add 	bx, ax			{ bx := 256 * y + x }
				shr		ax, 1
				shr 	ax, 1			{ ax := 64 * y }
				add 	bx, ax			{ bx := 320 * y - x }
				mov 	ax, SegScreen
				mov 	es, ax			{ es:bx := byte address of pixel }
				mov 	al, colour		
				mov 	es:[bx], al     { replace pixel colour }
    _Error:
end; {PutPixel}



function GetPixel(x, y: word): byte;
label _Error;
var	colour: byte;
begin
	colour := 0;
	asm
    			mov 	ax, y			
				mov 	bx, x			
				cmp 	ax, MinY        { check y value in range }
				jl 		_Error
				cmp 	ax, MaxY
				jg 		_Error
				cmp 	bx, MinX		{ check x value in range }
				jl 		_Error
				cmp 	bx, MaxX
				jg 		_Error
				xchg 	ah, al			{ ax := 256 * y }
				add 	bx, ax			{ bx := 256 * y + x }
				shr		ax, 1
				shr 	ax, 1			{ ax := 64 * y }
				add 	bx, ax			{ bx := 320 * y - x }
				mov 	ax, SegScreen
				mov 	es, ax			{ es:bx := byte address of pixel }
				mov 	al, es:[bx]		
				mov 	colour, al		
    	_Error:
    end;
	GetPixel := colour;
end; {GetPixel}



procedure Line(x1, y1, x2, y2: word; colour: byte);
var
	x, y, t, e, dx, dy, denom, xinc, yinc, aux: integer;
    vertlonger: boolean;
begin
	xinc := 1;
    yinc := 1;
    vertlonger := false;
    dx := x2 - x1;
    dy := y2 - y1;

    if (dx < 0) then begin 	xinc := -1;  dx := -dx;   end;
    if (dy < 0) then begin  yinc := -1;  dy := -dy;   end;

    if (dy > dx) then
    begin
    	vertlonger := TRUE;
        aux := dx;
        dx := dy;
        dy := aux;
    END;

    denom := dx SHL 2; 				{ denom := 2 * dx }
	t := dy SHL 2;					{ t := 2 * dy }
    e := -dx;
    x := x1;
	y := y1;

    while (dx >= 0) do
    begin
    	dx := dx - 1;
        PutPixel(x, y, colour);

        e := e + t;
        if (e > 0) then
        begin
        	if (vertlonger) then x := x + xinc
			else y := y + yinc;
            e := e - denom;
        end;

        if (vertlonger) then y := y + yinc
        else x := x + xinc;
    end;
end; {Line}



procedure Rectangle(x1, y1, x2, y2: word; colour: byte);
begin
	Line(x1, y1, x2, y1, colour);
    Line(x2, y1, x2, y2, colour);
    Line(x2, y2, x1, y2, colour);
    Line(x1, y2, x1, y1, colour);
end; {Rectangle}



procedure FillRectangle(x1, y1, x2, y2: word; colour: byte); assembler;
label _DrawLoop;
asm
				push  	ds
  				push  	es
  				mov   	ax, SegScreen
  				mov   	es, ax
  				mov   	ax, y1
  				mov   	bx, 320         { calculate start address }
  				mul   	bx
  				mov   	di, ax
  				add   	di, x1
  				mov   	ax, y1
  				mov   	dx, y2
  				sub   	dx, ax          { and length of each line }
  				inc   	dx
  				mov   	ax, x1
    			mov   	cx, x2
    			sub   	cx, ax
  				inc   	cx
  				mov   	al, colour
  				cld
	_DrawLoop:	push  	di              { draw one line }
  				push  	cx
  				rep   	stosb
  				pop   	cx
  				pop   	di
  				add   	di, 320
  				dec   	dx
  				jnz   	_DrawLoop		{ and loop to next }
  				pop   	es
  				pop   	ds
end; {FillRectangle}



procedure SetTextFont(font: word);
begin
	if (font >= 1) and (font <= MaxFont) then
		TextFont := font;
end;



procedure SetTextWidth(width: word);
begin
	TextWidth := width;
end; {SetTextWidth}



procedure SetTextHeight(height: word);
begin
	TextHeight := height;
end; {SetTextHeight}



procedure SetTextSpacing(spacing: integer);
begin
	TextSpacing := spacing;
end; {SetTextSpacing}



procedure DisplayChar(ch: char; x, y: word; colour: byte);
var
	chrNum, rowVal, whichFont, k, l, m, n: word;
begin
	whichFont := TextFont;
	chrNum := Ord(ch);
	for k := 0 to 7 do
    begin
    	for l := 0 to TextHeight-1 do
        begin
        	for m := 0 to 7 do
            begin
            	for n := 0 to TextWidth-1 do
                begin
                    if (ch < ' ') then whichFont := 1;
                	case whichFont OF
                    	1:	rowVal := mem[$F000:$FA6E+chrNum*8+k];
                        2:  rowVal := TinyFont[chrNum][k];
                        3:  rowVal := LineFont[chrNum][k];
                        ELSE
                    end;
                    rowVal := rowVAl SHR (7-m);
                    rowVal := rowVal and 1;
                    if (rowVal <> 0) then
						PutPixel(x+m*TextWidth+n, y+k*TextHeight+l, colour);
                end;
            end;
        end;
    end;
end; {DisplayChar}



procedure DisplayString(str: string; x, y: word; colour: byte);
var
	i: integer;
    strpos: word;
begin
	strpos := x;
	for i := 1 to Length(str) do
    begin
		DisplayChar(str[i], strpos, y, colour);
        INC(strpos, 8*TextWidth+TextSpacing);
    end;
end; {DisplayString}



procedure DACRemapColour(index, red, green, blue: byte); assembler;
asm
	{ N.B. no wiat for vertical retrace is done }
				mov 	dx, 3c8h		{ DAC set write mode }
				mov 	al, index		
				out 	dx, al			{ set to write mode }
				mov 	dx, 3c9h	    { address of DAC read data }
				mov 	al, red			
	        	out 	dx, al			{ set new red value }
				mov 	al, green
	       		out 	dx, al			{ set new green value }
				mov 	al, blue
	       		out 	dx, al			{ set new blue value }
end; {DACRemapColour}



function LoadPalette(FileName: string; var Pal: PaletteArray): boolean;
label quit;
var
	f: file;
  	i, NumRead: word;
begin
	assign(f, FileName);
    {$I-} reset(f, 1); {$I+}
    if (IOResult <> 0) then
	begin
    	{ ErrFileNotFound }
		LoadPalette := FALSE;
        exit;
    end;

    {$I-} BlockRead(f, Pal, 768, NumRead); {$I+}
    if (IOResult <> 0) then goto quit;

    for i := 0 to 768 do Pal[i] := Pal[i] DIV 4;

quit:
	close(f);
    LoadPalette := (IOResult = 0);
end; {LoadPalette}



procedure SetPalette(Pal: PaletteArray);
var	i: word;
begin
    for i := 0 to 255 do
		DACRemapColour(i, Pal[i*3], Pal[i*3+1], Pal[i*3+2]);
end; {SetPalette}



procedure FadeIn(var Pal: PaletteArray);
label
	_FadeIt, _Retrace, _NoRetrace, _SkipRetrace,
	_SetDAC, _SkipR, _SkipG, _SkipB;
var
	r, g, b: byte;
begin

	asm
				xor 	cx, cx
	_FadeIt:    lds 	si, Pal
                xor 	ax, ax
				xor 	bx, bx
	_SetDAC:    mov 	dx, 3C7h		{ address of DAC set read mode }
				mov 	al, bl
				out 	dx, al			{ set to read mode }

				mov 	dx, 3C9h		{ address of DAC read data }
				in 		al, dx			{ read red value }
				mov 	r, al
				in 		al, dx			{ read green value }
				mov 	g, al
				in 		al, dx			{ read blue value }
				mov 	b, al

       			mov		al, [si]
 				cmp 	r, al 			{ has red value been reached }
				jnl		_SkipR
				inc 	r
	_SkipR:     inc		si
    			mov		al, [si]
				cmp 	g, al			{ has green value been reached }
				jnl		_SkipG
				inc 	g
	_SkipG:     inc 	si
    			mov		al, [si]
				cmp 	b, al			{ has blue value been reached }
				jnl		_SkipB
				inc 	b
	_SkipB:     inc		si

                mov 	dx, 3C8h		{ address of DAC set write mode }
				mov 	al, bl
				out 	dx, al			{ set to write mode }
                mov 	dx, 3C9h   		{ address of DAC read data }
                mov 	al, r
			 	out 	dx, al			{ set new red value }
				mov 	al, g
				out 	dx, al			{ set new green value }
				mov 	al, b
				out 	dx, al			{ set new blue value }

                push	ax
                push	dx
                push	bx
                and		bx, 63
                jnz		_SkipRetrace
                mov 	dx, 3DAh		{ input status 1 }
	_Retrace:	in 		al, dx
				test 	al, 1000b		{ are we in a retrace/bit 4 set }
				jnz 	_Retrace		{ if so, look for non-retrace }
	_NoRetrace:	in 		al, dx			{ no, now look for next }
 				test 	al, 1000b		{ is bit 4 set }
				jz 		_NoRetrace
   	_SkipRetrace:
				pop		bx
                pop		dx
                pop		ax

    			inc 	bx
				cmp 	bx, 256			{ have we set all 256 colours }
				jnz 	_SetDAC
				inc 	cx
				cmp 	cx, 64			{ faded in all the colours }
				jnz 	_FadeIt
	end;
end; {FadeIn}



procedure FadeOut(var Pal: PaletteArray);
label
	_FadeIt, _Retrace, _NoRetrace, _SkipRetrace,
	_SetDAC, _SkipR, _SkipG, _SkipB;
var
	r, g, b: byte;
begin

	asm
				xor 	cx, cx
	_FadeIt:    lds 	si, Pal
                xor 	ax, ax
				xor 	bx, bx
	_SetDAC:    mov 	dx, 3c7h		{ address of DAC set read mode }
				mov 	al, bl
				out 	dx, al			{ set to read mode }

				mov 	dx, 3c9h		{ address of DAC read data }
				in 		al, dx			{ read red value }
				mov 	r, al
				in 		al, dx			{ read green value }
				mov 	g, al
				in 		al, dx			{ read blue value }
				mov 	b, al

                mov		al, [si]
 				cmp 	r, al 			{ has red value been reached }
				jng		_SkipR
				dec 	r
	_SkipR:     inc		si
    			mov		al, [si]
				cmp 	g, al			{ has green value been reached }
				jng		_SkipG
				dec 	g
	_SkipG:     inc 	si
    			mov		al, [si]
				cmp 	b, al			{ has blue value been reached }
				jng		_SkipB
				dec 	b
	_SkipB:     inc		si

    			mov 	dx, 3c8h		{ address of DAC set write mode }
				mov 	al, bl
				out 	dx, al			{ set to write mode }

				mov 	dx, 3c9h   		{ address of DAC read data }
                mov 	al, r
			 	out 	dx, al			{ set new red value }
				mov 	al, g
				out 	dx, al			{ set new green value }
				mov 	al, b
				out 	dx, al			{ set new blue value }

                push	ax
                push	dx
                push	bx
                and		bx, 63
                jnz		_SkipRetrace
                mov 	dx, 3DAh		{ input status 1 }
	_Retrace:	in 		al, dx
				test 	al, 1000b		{ are we in a retrace/bit 4 set }
				jnz 	_Retrace		{ if so, look for non-retrace }
	_NoRetrace:	in 		al, dx			{ no, now look for next }
 				test 	al, 1000b		{ is bit 4 set }
				jz 		_NoRetrace
   	_SkipRetrace:
				pop		bx
                pop		dx
                pop		ax

				inc 	bx
				cmp 	bx, 256			{ have we set all 256 colours }
				jnz 	_SetDAC
				inc 	cx
				cmp 	cx, 64			{ faded in all the colours }
				jnz 	_FadeIt
	end;
end; {FadeOut}



function LoadPCX(FileName: string; ScrPtr: pointer): boolean;
label quit;
var
  	f: file;
  	Buf: array [1..200] of Byte;
  	BloaksRead, BufPointer, Off, NumRead, i, ScrSize,
	ScrSeg, ScrOfs, Count, Value, What: word;
    PicBuf: ^ScreenType;
begin
	assign(f, FileName);
  	{$I-} reset(f, 1); {$I+}
    if (IOResult <> 0) then
    begin
    	{ ErrFileNotFound }
    	LoadPCX := FALSE;
        exit;
    end;

    ScrSeg := seg(ScrPtr^);
    ScrOfs := ofs(ScrPtr^);
    ScrSize := 320*200;				{ only cope with pics of max screen size }
    BufPointer := 1;
    Off := 0;

    { skip header }
    {$I-} BlockRead(f, Buf, 128, NumRead); {$I+}
    if (IOResult <> 0) then goto quit;

    PicBuf := MemAlloc(sizeof(ScreenType));
    if (PicBuf = nil) then
    begin
    	{ ErrNoMemory }
        LoadPCX := false;
        exit;
    end;

    {$I-} BlockRead(f, PicBuf^, sizeof(ScreenType), NumRead); {$I+}
    if (IOResult <> 0) then goto quit;

    while (Off < ScrSize) do
    begin
        What := PicBuf^[BufPointer];
        Inc(BufPointer);
        Count := What and $C0;
        if (Count = $C0) then
        begin
            Value := PicBuf^[BufPointer];
            Inc(BufPointer);
            Count := What and $3F;
        end
        else
        begin
        	Value := What;
            Count := 1;
        end;

        asm
        	cld
		   	mov di, ScrSeg					{ copy cx bytes of colour ax 	}
			mov es, di						{ into screen area.				}
            mov di, ScrOfs
			add di, Off
			mov ax, Value
			mov cx, Count
            add Off, cx
			rep stosb
        end;
 	end;

    FreeMem(PicBuf, sizeof(ScreenType));

quit:
	close(f);
    LoadPCX := (IOResult = 0);
end; {LoadPCX}



procedure RectStretch(xs1, ys1, xs2, ys2, xd1, yd1, xd2, yd2: word);

	procedure Stretch(x1, x2, y1, y2, yr, yw: word);
	var
		dx, dy, e, d, dx2, sx, sy: integer;
    	colour: byte;
	begin
		dx := Abs(x2-x1);
		dy := Abs(y2-y1);
		sx := Sign(x2-x1);
		sy := Sign(y2-y1);
		e := (dy shl 1) - dx;
		dx2 := dx shl 1;
		dy := dy shl 1;

    	for d := 0 to dx-1 do
    	begin
			colour := GetPixel(y1, yr);		{ talk about slow! }
            if (colour <> 0) then PutPixel(x1, yw, colour);
			while (e >= 0) do
        	begin
				y1 := y1 + sy;
				e := e - dx2;
			end;
			x1 := x1 + sx;
			e := e + dy;
		end;
	end; {Stretch}

var
	dx, dy, e, d, dx2, sx, sy: integer;
begin
	dx := Abs(yd2-yd1);
	dy := Abs(ys2-ys1);
    sx := Sign(yd2-yd1);
	sy := Sign(ys2-ys1);
	e := (dy shl 1) - dx;
	dx2 := dx shl 1;
	dy := dy shl 1;

    for d := 0 to dx-1 do
    begin
		Stretch(xd1, xd2, xs1, xs2, ys1, yd1);
        while (e >= 0) do
        begin
			ys1 := ys1 + sy;
			e := e - dx2;
		end;
		yd1 := yd1 + sx;
		e := e + dy;
	end;
end; {RectStretch}



begin
	SegScreen := $A000;
end.