home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CP/M
/
CPM_CDROM.iso
/
mbug
/
mbug120.arc
/
PASCAL.LBR
/
TURBOPCG.PZS
/
TURBOPCG.PAS
Wrap
Pascal/Delphi Source File
|
1979-12-31
|
5KB
|
158 lines
{
_________________________________________________________
| MicroBee Turbo Pascal Pcg Handler for 80 x 24 screen |
| Written by Phil Parton. |
---------------------------------------------------------
}
Const
PCGHeight = 11; PCGWidth = 8;
ScrChrWidth = 80; ScrChrHeight = 24;
Xmax = 639; Ymax = 263;
MinPCG = 128; MaxPCG = 255;
Type
PCGdef = array [1..11] of byte;
PCGrecord = record
Pattern: PCGdef;
CheckSum: Integer;
Count: Integer;
Spare: Byte;
end;
var
PCGmem: array [MinPCG..MaxPCG] of PCGrecord absolute $F800;
ScreenMem: array [1..ScrChrHeight,1..ScrChrWidth] of byte absolute $F000;
WorkX,WorkY,WorkCode,UsedPCG: integer;
GrafOk: Boolean;
WorkType: (Text,PCG);
Work: PCGrecord;
Procedure InitBee;
var
Row,RowSize: integer;
begin
GrafOk := True;
FillChar(PCGmem[MinPCG].Pattern,PCGHeight,0);
PCGmem[MinPCG].CheckSum := 0;
PCGmem[MinPCG].Count := SizeOf(ScreenMem);
FillChar(ScreenMem[1,1],SizeOf(ScreenMem),MinPCG);
UsedPCG := MinPCG;
end;
Procedure SetWorkCell(x,y: Integer);
begin
{calculate cell coordinates}
WorkX := (x div PCGWidth) + 1;
WorkY := (y div PCGHeight) + 1;
WorkCode := ScreenMem[WorkY,WorkX];
if WorkCode < MinPCG then
WorkType := Text
else begin
Worktype := PCG;
Work := PCGmem[WorkCode];
PCGmem[WorkCode].Count := Pred(PCGmem[WorkCode].Count);
end;
end;
Function AssignCode: integer;
var
Row,Code: Integer;
Match: Boolean;
begin
Code := MinPCG; Match := False;
While (Code <= UsedPCG) and not Match do
begin
if Work.CheckSum = PCGmem[Code].CheckSum then
begin
Row := 1; Match := True;
While (Row <= PCGHeight) and Match do
begin
Match := (PCGmem[Code].Pattern[Row] = Work.Pattern[Row]);
Row := Succ(Row);
end;
end;
Code := Succ(Code);
end;
if Match then AssignCode := Pred(Code)
else AssignCode := Code;
end;
Function Sum(var Patt: PCGdef): Integer;
var
RowSum,Row: Integer;
begin
RowSum := 0;
for Row := 1 to PCGHeight do
begin
RowSum := RowSum + Patt[Row]
end;
Sum := RowSum;
end;
Procedure DeletePCG(Code: Integer);
var
ScreenAddress,ScreenSize: Integer;
DelCode: Byte;
begin
DelCode := UsedPCG;
PCGmem[WorkCode] := PCGmem[UsedPCG];
if WorkCode <> UsedPCG then
begin {Change screen ram pointers}
ScreenAddress := Addr(ScreenMem[1,1]);
ScreenSize := SizeOf(ScreenMem);
Inline ($2A/ScreenAddress/ { LD HL,(ScreenAddress) }
$3A/DelCode/ { LD A,(DelCode) }
$ED/$4B/ScreenSize/ { LD BC,(ScreenSize) }
$ED/$B1/ { CPIR }
$2B/ { DEC HL }
$22/ScreenAddress); { LD (ScreenAddress),HL }
mem[ScreenAddress] := Code;
end;
end;
Procedure DisplayWorkCell;
var
Code: Integer;
begin
{see if new pattern already exists}
Work.CheckSum := Sum(Work.Pattern);
Code := AssignCode;
if Code > MaxPCG then
GrafOk := False
else begin
If Code > UsedPCG then
begin {Not found, store it.}
UsedPCG := UsedPCG + 1;
Work.Count := 1;
PCGmem[Code] := Work;
end
else begin {Pattern already exists}
PCGmem[Code].Count := Succ(PCGmem[Code].Count);
end;
{now display it}
ScreenMem[WorkY,WorkX] := Code;
{Now check if the old pattern is redundant, if so, delete it.}
if PCGmem[WorkCode].Count = 0 then
begin {delete work cell PCG}
DeletePCG(WorkCode);
UsedPCG := UsedPCG - 1;
end;
end;
end;
Procedure SetPixel(x,y: Integer);
var
Row,BitShift: Integer;
begin
if ((Trunc(x) div PCGWidth) <> WorkX - 1) or
((Trunc(y) div PCGHeight) <> WorkY - 1) then
begin
if (WorkType = PCG) and GrafOk then DisplayWorkCell;
SetWorkCell(x,y);
end;
if (WorkType = PCG) and GrafOk then
begin
BitShift := x mod PCGWidth;
Row := (y mod PCGHeight) + 1;
Work.Pattern[Row] := Work.Pattern[Row] or (128 shr BitShift);
end;
end;