ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/BEEHIVE/UTILITYS/PUDD.ARC/PUDD-03.PAS

Pascal/Delphi Source File | 1991-08-11 | 6KB | 221 lines

{Pudd-03 contains the procedures used to write directly to the
 screen                                                       }


procedure DrawRow(y,PtrList:integer); {...........Draw row y from datalist }
var  BitList     :string[8];          { PtrList is addr of top of datalist }
     PixByte     :byte;
     i,j,k       :integer;
     Xpoz        :integer;
     Ptr         :integer;
     Xleft       :integer;
     color       :char;
     PrevColor   :char;
     value       :HexString;

begin
    PrevColor := '0';
    writemode(1);
    linecolor(1);
    setline(1);
    Ptr := PtrList;
    PixByte := mem[Ptr];
    ReadByte(PixByte,BitList);
    FlipList(BitList);
    if copy(BitList,1,1) = '1' then  {....find beginning color }
      begin
       Xleft := 0;
       color := '1';
      end
    else
      color := '0';
    Xpoz := 0;
    for i := 1 to 80 do  {.....80 bytes of 8 bits yields 640 pixels }
     begin
       if ((color = '0') and (PixByte = $00)) or
        ((color = '1') and (PixByte = $FF)) then
           begin
             Xpoz := Xpoz + 8;
          end
       else
         begin
           ReadByte(PixByte,BitList);
           FlipList(BitList);
           for j := 1 to 8 do
            begin
             if copy(BitList,j,1) <> color then
              begin
                 if color = '1' then  {....an end of a line }
                  begin
                   MoveTo(Xleft,y);
                   DrawTo(Xpoz-1,y);
                   color := '0';
                  end
                 else               {....beginning new line }
                  begin
                   Xleft := Xpoz;
                   Color := '1'
                  end
              end;
             Xpoz := Xpoz + 1;
            end;  {..........................out of bit searching loop}
         end;
       Ptr := Ptr + 1;
       PixByte := mem[Ptr];
       if (i = 80) and (color = '1') then {...at far left and done }
        begin
         MoveTo(Xleft,y);
         DrawTo(639,y);
        end;
     end;
end;







{***************************************************************************}
{*   Save will save the screen to a disk file.  The default file type      *}
{*   is .SCR.  These are 20k files, make sure there's room                 *}
{***************************************************************************}
procedure Save;
var  LineNum  :integer;
     i,j      :integer;
     block    :integer;
     trans    :integer;
     bytelist :scanline;
begin
 gotoXY(1,1);
 ClrSomeScr(1,10);
 NewFileName(drive,name,ftype,2,9);
 if name = '' then   {....no name selected }
  write(^G)
 else
   begin
    initgraph;
    LineNum := 0;
    assign(DiskFile,drive + ':' + name + '.' + ftype);
    rewrite(DiskFile);
    for block := 1 to 30 do        {...........30 disk writes of 640 bytes }
     begin
      j := 0;
      for trans := 1 to 8 do       {..................8 rows in each block }
       begin
        GetLine(LineNum,ByteList);
        LineNum := LineNum + 1;
        for i := 1 to 80 do        {..................80 bytes in each row }
         begin
          TransBuff[i+j] := ByteList[i];
         end;
        j := j + 80;
       end;
      BlockWrite(DiskFile,TransBuff,5);
     end;
    Alphamode;
    close(DiskFile);
   end;
end;


{***************************************************************************}
{*   Load will load the screen with a disk file saved earlier.  The        *}
{*   default file type is .SCR.                                            *}
{***************************************************************************}
procedure Load;
var  LineNum  :integer;
     i,j      :integer;
     block    :integer;
     trans    :integer;
     Next80Byte :integer;
begin
 gotoXY(1,1);
 ClrSomeScr(1,10);
 OldFileName(drive,name,ftype,2,9);
 if name = '' then   {....no name selected }
  write(^G)
 else
   begin
    gotoXY(10,20);
    initgraph;
    LineNum := 0;
    assign(DiskFile,drive + ':' + name + '.' + ftype);
    reset(DiskFile);
    for block := 1 to 30 do        {...........30 disk writes of 640 bytes }
     begin
      Next80Byte := addr(transBuff);
      BlockRead(DiskFile,Transbuff,5);
      j := 0;
      for trans := 1 to 8 do       {..................8 rows in each block }
       begin
        for i := 1 to 80 do        {..................80 bytes in each row }
         begin
          ByteList[i] := TransBuff[i+j];
         end;
       DrawRow(LineNum,Next80Byte);
        Next80Byte := Next80Byte + 80;
        LineNum := LineNum + 1;
        j := j + 80;
       end;
     end;
     alphamode;
     close(DiskFile);
   end;
end;


procedure ChangeDrive(x,y:integer);
var   ThisDrive  :char;
      NextDrive  :char;
begin
 gotoXY(x,y);
 clreol;
 write('Current drive is ');
 ThisDrive := CurrDrive;
 write(ThisDrive);
 write('  Change drive to ');
 read(kbd,NextDrive);
 write(NextDrive);
 gotoXY(x,y);
 clreol;
 NewDrive(NextDrive);
 gotoXY(x,y);
 clreol;
end;

{***************************************************************************}
{*   Files is the main procedure for the file subsection.  It is from      *}
{*   here that all file procedures are selected.                           *}
{***************************************************************************}
procedure Files;
var response  :char;
begin
 ClrScr;
 repeat
  gotoXY(10,5);
  writeln('FILE SUB-MENU.......');
  writeln('             1) Load screen from a disk file -new screen');
  writeln('             2) Load screen from a disk file -overlay on current screen');
  writeln('             3) Save current screen to a disk file');
  writeln('             4) Show directory of *.scr files');
  writeln('             5) Change logged drive');
  read(kbd,response);
  case response of
   '1':begin
        initgraph;
        ClearGraph;
        alphamode;
        Load;
       end;
   '2':Load;
   '3':Save;
   '5':ChangeDrive(10,22);

  end;  {....case }
 until not(response in ['1','2','3','4','5']);
 HeadLine;
end;