CP/M/CPM_CDROM.iso/mbug/mbug120.arc/PASCAL.LBR/TURBOPCG.PZS/TURBOPCG.PAS

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;