Source Code 1992 March/Source_Code_CD-ROM_Walnut_Creek_March_1992.iso/msdos/mac/edmac.arc/EDMAC.PAS

Pascal/Delphi Source File | 1980-01-01 | 37.5 KB | 1,001 lines

{ EdMac - MacPaint file compatible graphics editor }
{ Ver. 1.00   03/16/87   by S.D. Gorrell }

program EdMac (input, output);

  const Vseg0   = $B800;     { Video memory map segment for lines 0,2,4, etc. }
        Vseg1   = $BA00;     { '                          ' lines 1,3,5, etc. }

        Pwide   = 71;      { McPaint picture width-1 in characters (576 bits) }
        Plines  = 799;                         { Max number of loadable lines }
        RO      = 8;                                      { Screen row offset }
        CO      = 4;                                   { Screen column offset }
        NR      = 200;                                { Number of screen rows }

  type  Picrec  = array [1..128] of CHAR;                { File record buffer }
        Str     = string [255];                      { General purpose string }

  var   Plc     : INTEGER;                               { Picture line count }
        Pic     : array [0..Plines, 0..Pwide] of CHAR;        { Picture array }

        Mrow,                                            { Magnify row origin }
        Mcol    : INTEGER;                            { Magnify column origin }
        Mag     : Array [0..47, 0..Pwide] of CHAR;            { Magnify array }

        Cursor,                                                   { Cursor on }
        Fast,                                          { Fast cursor movement }
        Pen,                                                       { Pen down }
        Erasr,                                                 { Draw / erase }
        Magnify : BOOLEAN;                                       { Magnify on }

        Mload   : BOOLEAN;                        { Magnify array loaded flag }

        CRT     : array [0..$3FFF] of CHAR absolute Vseg0:$0000; { Screen mem }

        Picfile,                                               { Picture file }
        Newfile : file of Picrec;                       { Edited picture file }

  {---------------------------------------------------------------------------}

  function Next_byte (var Rec    : Picrec;         { Read next byte from file }
                      var RP,
                          Recno,
                          Nrecs  : INTEGER) : CHAR;

    begin { Next_byte }

      if RP > 128 then                                  { Wrap to next record }
        begin
          Recno := Recno + 1;
          RP := 1;
          if Recno < Nrecs then
            begin
              seek (Picfile, Recno);
              read (Picfile, Rec);
              gotoXY (25,25);
              write (Recno+1:3)
            end
        end;

      if Recno < Nrecs then
        begin
          Next_byte := Rec[RP];                            { Return next byte }
          RP := RP + 1
        end
      else
        Next_byte := #0                              { ...or null if past eof }

    end;  { Next_byte }

  {---------------------------------------------------------------------------}

  procedure Load_pic;                                { Load picture from file }

    var I,J,K  : INTEGER;
        C      : CHAR;
        S      : Str;

        RP,                                             { Record char pointer }
        Recno,                                        { Current record number }
        Nrecs  : INTEGER;                         { Number of records in file }

        Rec    : Picrec;                                   { Record from file }

    begin { Load_pic }

      assign (Picfile, paramstr(1));
      reset (Picfile);
      Nrecs := filesize(Picfile);

      read (Picfile, Rec);                                    { Header record }
      I := ord(Rec[2]);
      S := copy(Rec,3,I);                                             { Title }
      gotoXY ((80-I) div 2, 1);
      write (S);
      gotoXY (1,25);
      write ('Now processing record     0  of  ', Nrecs:4, '.');

      RP := 129;         { Init record char pointer to end of previous record }
      Recno := 4;                              { Picture starts at byte $0280 }
      Plc := 0;                                          { Picture line count }

      K := 0;

      repeat                                                 { Unpack picture }
        C := Next_byte (Rec, RP, Recno, Nrecs);                  { Count byte }
        I := ord (C);

        if I < 128 then                       { Unpack next (I+1) chars as is }
          begin
            for J := 0 to I do
              if Plc <= Plines then
                begin
                  C := Next_byte (Rec, RP, Recno, Nrecs);
                  Pic[Plc, K] := chr(ord(C) xor 255);
                  K := (K+1) mod (Pwide+1);
                  if K = 0 then Plc := Plc + 1
                end
            end
        else                            { Repeat next char (2's comp I) times }
          begin
            C := Next_byte (Rec, RP, Recno, Nrecs);
            for J := 0 to 256-I do
              if Plc <= Plines then
                begin
                  Pic[Plc, K] := chr(ord(C) xor 255);
                  K := (K+1) mod (Pwide+1);
                  if K = 0 then Plc := Plc + 1
                end
          end
      until (Recno >= Nrecs) or (Plc > Plines);

      close (Picfile);
      gotoXY (1,25);
      write (Plc:4, '  displayable lines loaded. <RET> ');
      repeat until keypressed;
      read (kbd, C);
      gotoXY (1,25);
      write (' ':33)

    end;  { Load_pic }

  {---------------------------------------------------------------------------}

  procedure Show_pic (Top : INTEGER);                       { Display picture }

    var I,J,K : INTEGER;

    begin { Show_pic }

      I := (RO div 2) * 80 + CO;                        { Screen array offset }
      J := Top;                                                  { Array line }
      K := (NR div 2) * 80 + CO;                              { End of screen }

      repeat
        move (Pic[J, 0], CRT[I], Pwide+1);          { Write to even line page }
        move (Pic[J+1, 0], CRT[I+$2000], Pwide+1);   { Write to odd line page }
        I := I + 80;
        J := J + 2
      until (I = K) or (J = Plc)

    end;  { Show_pic }

  {---------------------------------------------------------------------------}

  procedure Load_mag (Top, Csr, Csc : INTEGER);          { Load magnify array }

    var I,J,K,R,C : INTEGER;
        B         : BYTE;

    begin { Load_mag }

      Mrow := Csr - 24;                                      { Set row origin }
      if Mrow < 0 then Mrow := 0
        else if Mrow > 144 then Mrow := 144;

      Mcol := Csc - 9;                                    { Set column origin }
      if Mcol < 0 then Mcol := 0
        else if Mcol > 54 then Mcol := 54;

      C := 0;                                          { Array row and column }

      for I := 0 to 47 do                                          { 48 lines }
        begin
          for J := 0 to 17 do                                 { 18 characters }
            begin
              K := 128;                                              { 8 bits }
              repeat
                B := 0;
                if (ord(Pic[Top+Mrow+I, Mcol+J]) and K) > 0  { Isolate hi bit }
                  then B := $F0;
                K := K div 2;

                if (ord(Pic[Top+Mrow+I, Mcol+J]) and K) > 0  { Isolate lo bit }
                  then B := B or $0F;
                K := K div 2;

                Mag[I,C] := chr(B);
                C := (C + 1) mod 72
              until K = 0
            end
        end;

      Mload := TRUE                           { Set magnify array loaded flag }

    end;  { Load_mag }

  {---------------------------------------------------------------------------}

  procedure Show_mag;                             { Display magnified picture }

    var I,J   : INTEGER;

    begin { Show_mag }

      I := (RO div 2) * 80 + CO;                        { Screen array offset }

      for J := 0 to 47 do
        begin
          move (Mag[J, 0], CRT[I], Pwide+1);        { Write to even line page }
          move (Mag[J, 0], CRT[I+$2000], Pwide+1);   { Write to odd line page }
          I := I + 80;

          move (Mag[J, 0], CRT[I], Pwide+1);        { Write to even line page }
          move (Mag[J, 0], CRT[I+$2000], Pwide+1);   { Write to odd line page }
          I := I + 80
        end

    end;  { Show_mag }

  {---------------------------------------------------------------------------}

  procedure Adjust_mag (var Csr, Csc, Csb : INTEGER);    { Adjust for magnify }

    var I : INTEGER;

    begin { Adjust_mag }

      Csr := (Csr-Mrow) * 4 + 2;                                 { Adjust row }
      Csc := (Csc-Mcol) * 4;                                  { Adjust column }

      I := Csb;                                                 { Adjust byte }
      Csb := 32;
      if I < 128 then
        repeat
          Csb := Csb div 16;
          if Csb = 0 then
            begin
              Csc := Csc + 1;
              Csb := 32
            end;
          I := I * 2
        until I = 128

    end;  { Adjust_mag }

  {---------------------------------------------------------------------------}

  procedure CRT_bit (Row, Col, Bit : INTEGER;             { Wiggle bit on CRT }
                     Op            : CHAR);      { (S)et, (R)eset, (T)oggle   }

    var I,J : INTEGER;
        B   : BYTE;

        MO  : INTEGER;                                        { Memory offset }

    begin { CRT_bit }

      if Magnify then                                    { Adjust for magnify }
        begin
          Adjust_mag (Row, Col, Bit);
          if Bit < 16 then Bit := $0F else Bit := $F0;
          Row := Row - 2;
          I := 3
        end
      else I := 0;

      for J := 0 to I do
        begin
          MO := ((Row+RO+J) div 2) * 80 + Col + CO; { Calculate memory offset }
          if (Row+RO+J) mod 2 = 0 then
            B := Mem[Vseg0 : MO]                      { Get byte in even line }
          else
            B := Mem[Vseg1 : MO];                      { Get byte in odd line }

          case Op of
            'S' : B := B and (Bit xor $FF);                { Set bit to black }
            'R' : B := B or Bit;                         { Clear bit to white }
            'T' : B := B xor Bit                                 { Toggle bit }
          end; { case }

          if (Row+RO+J) mod 2 = 0 then
            Mem[Vseg0 : MO] := B                      { Put byte in even line }
          else
            Mem[Vseg1 : MO] := B                       { Put byte in odd line }
        end

    end;  { CRT_bit }

  {---------------------------------------------------------------------------}

  procedure Ary_bit (Top, Row, Col, Bit : INTEGER;      { Wiggle bit in array }
                     Op                 : CHAR);   { (S)et, (R)eset, (T)oggle }

    var B : BYTE;

    begin { Ary_bit }

      B := ord(Pic[Row+Top, Col]);                      { Get byte from array }

      case Op of
        'S' : B := B and (Bit xor $FF);                    { Set bit to black }
        'R' : B := B or Bit;                             { Clear bit to white }
        'T' : B := B xor Bit                                     { Toggle bit }
      end; { case }

      Pic[Row+Top, Col] := chr(B);                        { Put byte in array }

      if Mload then                             { Wiggle bit in magnify array }
        begin
          Adjust_mag (Row, Col, Bit);                    { Adjust for magnify }
          if Bit < 16 then Bit := $0F else Bit := $F0;
          Row := (Row - 2) div 4;

          B := ord(Mag[Row, Col]);                      { Get byte from array }

          case Op of
            'S' : B := B and (Bit xor $FF);                { Set bit to black }
            'R' : B := B or Bit;                         { Clear bit to white }
            'T' : B := B xor Bit                                 { Toggle bit }
          end; { case }

          Mag[Row, Col] := chr(B)                         { Put byte in array }
        end

    end;  { CRT_bit }

  {---------------------------------------------------------------------------}

  procedure Set_csr (Csr, Csc, Csb : INTEGER);               { Display cursor }

    var I,J,K : INTEGER;

        Mflag : BOOLEAN;                                  { Temp magnify flag }

    begin { Set_csr }

      if Magnify then                                    { Adjust for magnify }
        begin
          Adjust_mag (Csr, Csc, Csb);
          Mflag := True;                                  { Save magnify flag }
          Magnify := False                             { Don't magnify cursor }
        end
      else Mflag := False;

      I := Csc;                                             { Left bar of '+' }
      J := Csb;
      for K := 1 to 6 do
        begin
          J := J * 2;
          if J > 128 then                                         { Next byte }
            begin
              J := 1;
              I := I - 1
            end;
          if (I >= 0) and (K > 1) then CRT_bit (Csr, I, J, 'T')
        end;

      I := Csc;                                            { Right bar of '+' }
      J := Csb;
      for K := 1 to 6 do
        begin
          J := J div 2;
          if J < 1 then                                           { Next byte }
            begin
              J := 128;
              I := I + 1
            end;
          if (I <= Pwide) and (K > 1) then CRT_bit (Csr, I, J, 'T')
        end;

      for I := Csr-4 to Csr-2 do                             { Top bar of '+' }
          if I >=0 then CRT_bit (I, Csc, Csb, 'T');

      for I := Csr+2 to Csr+4 do                          { Bottom bar of '+' }
          if I < NR-RO then CRT_bit (I, Csc, Csb, 'T');

      Magnify := Mflag                                 { Restore magnify flag }

    end;  { Set_csr }

  {---------------------------------------------------------------------------}

  procedure Clr_csr (Csr, Csc, Csb : INTEGER);                 { Blank cursor }

    begin { Clr_csr }

      Set_csr (Csr, Csc, Csb)                                   { Same as set }

    end;  { Clr_csr }

  {---------------------------------------------------------------------------}

  procedure Set_status;                                      { Display status }

    begin { Set_status }

      GotoXY (1,23);
      if Fast then write ('Fast') else write ('Slow');

      GotoXY (1,24);
      if Pen then write ('Down') else write (' Up ');

      GotoXY (1,25);
      if Erasr then write ('Eras') else write ('Draw');

      GotoXY (77,23);
      if Cursor then write ('    ') else write ('+Off');

      GotoXY (77,24);
      if Magnify then write ('Zoom') else write ('    ')

    end;  { Set_status }

  {---------------------------------------------------------------------------}

  procedure Edit_pic;                                        { Picture editor }

    var I,J   : INTEGER;
        C     : CHAR;

        Csr,                                              { Screen cursor row }
        Csc,                                           { Screen cursor column }
        Csb,                                              { Screen cursor bit }

        Top   : INTEGER;                                    { Top line number }

        K     : CHAR;                               { Character from keyboard }

        Kptr  : INTEGER;                                  { Key macro pointer }
        Kmac  : Str;                                       { Key macro string }

    begin { Edit_pic }

      Top := 0;                                             { Initial display }
      Show_pic (Top);

      Csr := 0;
      Csc := 0;
      Csb := 128;
      Set_csr (Csr, Csc, Csb);                               { Display cursor }

      Cursor  := TRUE;                                       { Display cursor }
      Fast    := TRUE;                                       { Fast cursor    }
      Pen     := FALSE;                                      { Pen up         }
      Erasr   := FALSE;                                      { Draw           }
      Magnify := FALSE;                                      { Magnify off    }

      Mload   := FALSE;                            { Magnify array not loaded }

      Kptr := 0;                                 { Init keyboard macro string }
      Kmac := '';

      Set_status;

      K := #0;

      repeat
        if Kptr = 0 then
          begin
            repeat until keypressed;                          { Read keyboard }
            read (kbd, K);
            K := upcase (K);

            if keypressed then                                 { Function key }
              begin
                read (kbd, K);
                K := chr(ord(K)+128)                           { Set high bit }
              end
          end
        else
          begin
            K := Kmac[Kptr];                              { Read macro string }
            Kptr := Kptr + 1;
            if Kptr > length (Kmac) then Kptr := 0;
          end;

        case K of                                            { Key processing }

          '!'  : Set_status;                                  { Update status }

          ' '  : begin                                 { Toggle bit at cursor }
                   if Cursor and Magnify then Clr_csr (Csr, Csc, Csb);
                   CRT_bit (Csr, Csc, Csb, 'T');
                   Ary_bit (Top, Csr, Csc, Csb, 'T');
                   if Cursor and Magnify then Set_csr (Csr, Csc, Csb)
                 end;

          'C'  : if not Cursor then                           { Toggle cursor }
                   begin
                     Cursor := True;
                     Set_csr (Csr, Csc, Csb);
                     if Kptr = 0 then Set_status
                   end
                 else
                   begin
                     Cursor := False;
                     Clr_csr (Csr, Csc, Csb);
                     if Kptr = 0 then Set_status
                   end;

          'F'  : if (not Fast) and (not Magnify) then              { Set fast }
                   begin
                     Fast := True;
                     if Kptr = 0 then Set_status
                   end;

          'S'  : if Fast then                                      { Set slow }
                   begin
                     Fast := False;
                     if Kptr = 0 then Set_status
                   end;

          '.'  : if not Magnify then                            { Toggle fast }
                   begin
                     Fast := not Fast;
                     if Kptr = 0 then Set_status
                   end;

          #13,'P'  : begin                                       { Toggle pen }
                   Pen := not Pen;
                   if Pen then
                     begin
                       if Cursor and Magnify then Clr_csr (Csr, Csc, Csb);
                       if Erasr then C := 'R' else C := 'S';   { Draw / erase }
                       CRT_bit (Csr, Csc, Csb, C);           { Set /reset bit }
                       Ary_bit (Top, Csr, Csc, Csb, C);
                       if Cursor and Magnify then Set_csr (Csr, Csc, Csb)
                     end;
                   if Kptr = 0 then Set_status
                 end;

          #211,'-' : if not Erasr then                                { Erase }
                   begin
                     Erasr := True;
                     if Pen then
                       begin
                         if Cursor and Magnify then Clr_csr (Csr, Csc, Csb);
                         CRT_bit (Csr, Csc, Csb, 'R');            { Reset bit }
                         Ary_bit (Top, Csr, Csc, Csb, 'R');
                         if Cursor and Magnify then Set_csr (Csr, Csc, Csb)
                       end;
                     if Kptr = 0 then Set_status
                   end;

          #210,'+' : if Erasr then                                     { Draw }
                   begin
                     Erasr := False;
                     if Pen then
                       begin
                         if Cursor and Magnify then Clr_csr (Csr, Csc, Csb);
                         CRT_bit (Csr, Csc, Csb, 'S');              { Set bit }
                         Ary_bit (Top, Csr, Csc, Csb, 'S');
                         if Cursor and Magnify then Set_csr (Csr, Csc, Csb)
                       end;
                     if Kptr = 0 then Set_status
                   end;

          'M'  : if not Magnify then                         { Toggle magnify }
                   begin
                     Magnify := True;
                     if not Mload then Load_mag (Top, Csr, Csc);
                     Show_mag;
                     Fast := False;                               { Auto slow }
                     if Cursor then Set_csr (Csr, Csc, Csb);
                     if Kptr = 0 then Set_status
                   end
                 else
                   begin
                     Magnify := False;
                     Show_pic (Top);
                     if Cursor then Set_csr (Csr, Csc, Csb);
                     if Kptr = 0 then Set_status
                   end;

          #201,'U' : if (Top > 0) and not Magnify then              { Page up }
                   begin
                     if Pen then                                { Auto pen up }
                       begin
                         Pen := not Pen;
                         if Kptr = 0 then Set_status
                       end;

                     Top := Top - (NR-RO) div 8;
                     if Top < 0 then Top := 0;
                     Show_pic (Top);
                     if Cursor then Set_csr (Csr, Csc, Csb);
                     Mload := FALSE
                   end;

          #209,'D' : if (Top < Plc-(NR-RO)) and not Magnify then  { Page down }
                   begin
                     if Pen then                                { Auto pen up }
                       begin
                         Pen := not Pen;
                         if Kptr = 0 then Set_status
                       end;

                     Top := Top + (NR-RO) div 8;
                     if Top > Plc-(NR-RO) then Top := Plc-(NR-RO);
                     Show_pic (Top);
                     if Cursor then Set_csr (Csr, Csc, Csb);
                     Mload := FALSE
                   end;

          '8',#200 : if ((Csr > 0) and not Magnify)               { Cursor up }
                     or ((Csr > Mrow) and Magnify) then
                   begin
                     if Cursor then Clr_csr (Csr, Csc, Csb);   { Blank cursor }

                     if (Csr < 4) or not Fast then             { Repeat count }
                       I := 1 else I := 4;

                     for J := 1 to I do
                       begin
                         Csr := Csr - 1;                      { Move up a row }
                         if Pen then
                           begin
                             if Erasr then
                               C := 'R' else C := 'S';         { Draw / erase }
                             CRT_bit (Csr, Csc, Csb, C);     { Set /reset bit }
                             Ary_bit (Top, Csr, Csc, Csb, C)
                           end
                       end;

                     if Cursor then Set_csr (Csr, Csc, Csb);
                     if not Magnify then Mload := FALSE
                   end;

          '2',#208 : if ((Csr < (NR-RO-1)) and not Magnify)     { Cursor down }
                     or ((Csr < Mrow+47) and Magnify) then
                   begin
                     if Cursor then Clr_csr (Csr, Csc, Csb);   { Blank cursor }

                     if (Csr >= (NR-RO-4)) or not Fast then    { Repeat count }
                       I := 1 else I := 4;

                     for J := 1 to I do
                       begin
                         Csr := Csr + 1;                    { Move down a row }
                         if Pen then
                           begin
                             if Erasr then
                               C := 'R' else C := 'S';         { Draw / erase }
                             CRT_bit (Csr, Csc, Csb, C);     { Set /reset bit }
                             Ary_bit (Top, Csr, Csc, Csb, C)
                           end
                       end;

                     if Cursor then Set_csr (Csr, Csc, Csb);
                     if not Magnify then Mload := FALSE
                   end;

          '4',#203 : if ((Csc > 0) and not Magnify)             { Cursor left }
                     or ((Csc > Mcol) and Magnify) or (Csb < 128) then
                   begin
                     if Cursor then Clr_csr (Csr, Csc, Csb);   { Blank cursor }

                     if ((Csc = 0) and (Csb > 8))              { Repeat count }
                       or not Fast then I := 1 else I := 4;

                     for J := 1 to I do
                       begin
                         Csb := Csb * 2;                    { Move left a bit }
                         if Csb = 256 then
                           begin
                             Csc := Csc - 1;
                             Csb := 1
                           end;
                         if Pen then
                           begin
                             if Erasr then
                               C := 'R' else C := 'S';         { Draw / erase }
                             CRT_bit (Csr, Csc, Csb, C);     { Set /reset bit }
                             Ary_bit (Top, Csr, Csc, Csb, C)
                           end
                       end;

                     if Cursor then Set_csr (Csr, Csc, Csb);
                     if not Magnify then Mload := FALSE
                   end;

          '6',#205 : if ((Csc < Pwide) and not Magnify) or     { Cursor right }
                     ((Csc < Mcol+17) and Magnify) or (Csb > 1) then
                   begin
                     if Cursor then Clr_csr (Csr, Csc, Csb);   { Blank cursor }

                     if ((Csc = Pwide) and (Csb < 16))         { Repeat count }
                       or not Fast then I := 1 else I := 4;

                     for J := 1 to I do
                       begin
                         Csb := Csb div 2;                 { Move right a bit }
                         if Csb = 0 then
                           begin
                             Csc := Csc + 1;
                             Csb := 128
                           end;
                         if Pen then
                           begin
                             if Erasr then
                               C := 'R' else C := 'S';         { Draw / erase }
                             CRT_bit (Csr, Csc, Csb, C);     { Set /reset bit }
                             Ary_bit (Top, Csr, Csc, Csb, C)
                           end
                       end;

                     if Cursor then Set_csr (Csr, Csc, Csb);
                     if not Magnify then Mload := FALSE
                   end;

          '7'  : begin                                     { Cursor up & left }
                   Kptr := 1;
                   if not Pen then                                { Just move }
                     Kmac := '84'
                   else
                     if not Fast then
                       Kmac := 'P84P'                           { Move & draw }
                     else
                       Kmac := 'SP84PP84PP84PP84PF';        { Move & draw (4) }
                   if Cursor then
                     Kmac := 'C' + Kmac + 'C'    { Cursor off for faster move }
                 end;

          '9'  : begin                                    { Cursor up & right }
                   Kptr := 1;
                   if not Pen then                                { Just move }
                     Kmac := '86'
                   else
                     if not Fast then
                       Kmac := 'P86P'                           { Move & draw }
                     else
                       Kmac := 'SP86PP86PP86PP86PF';        { Move & draw (4) }
                   if Cursor then
                     Kmac := 'C' + Kmac + 'C'    { Cursor off for faster move }
                 end;

          '1'  : begin                                   { Cursor down & left }
                   Kptr := 1;
                   if not Pen then                                { Just move }
                     Kmac := '24'
                   else
                     if not Fast then
                       Kmac := 'P24P'                           { Move & draw }
                     else
                       Kmac := 'SP24PP24PP24PP24PF';        { Move & draw (4) }
                   if Cursor then
                     Kmac := 'C' + Kmac + 'C'    { Cursor off for faster move }
                 end;

          '3'  : begin                                  { Cursor down & right }
                   Kptr := 1;
                   if not Pen then                                { Just move }
                     Kmac := '26'
                   else
                     if not Fast then
                       Kmac := 'P26P'                           { Move & draw }
                     else
                       Kmac := 'SP26PP26PP26PP26PF';        { Move & draw (4) }
                   if Cursor then
                     Kmac := 'C' + Kmac + 'C'    { Cursor off for faster move }
                 end

        end { case }

      until K = #27

    end;  { Edit_pic }

  {---------------------------------------------------------------------------}

  function Pac_rec (S : Str) : Str;                             { Pack record }

    var I,J,K : INTEGER;
        C     : CHAR;
        S1    : Str;

    begin { Pac_rec }

      I := 2;                                               { Start of window }
      J := 2;                                                 { End of window }
      K := 1;                                                    { S1 pointer }

      repeat
        if J < length(S) then
          begin
            repeat
              J := J + 1;
            until (S[J] <> S[I]) or (J > length (S));

            if J > I+1 then
              begin
                S1[K] := chr(257+I-J);             { 2's comp of repeat count }
                S1[K+1] := S[I];                        { Character to repeat }
                K := K + 2;
                I := J
              end
            else J := I
          end;

        if J <= length(S) then
          begin
            repeat
              J := J + 1;
            until ((J-I > 2) and (S[J] = S[J-1]) and (S[J] = S[J-2]))
            or (J > length (S));

            if J <= length(S) then J := J - 2;
            S1[K] := chr(J-I-1);                                 { Copy count }
            move (S[I], S1[K+1], J-I);                   { Characters to copy }
            K := K + (J-I) + 1;
            I := J
          end
        until I > length(S);

      S1[0] := chr(K-1);                                         { Set length }
      Pac_rec := S1                                    { Return packed record }

    end;  { Pac_rec }

  {---------------------------------------------------------------------------}

  function Save_pic : CHAR;                             { Save edited picture }

    var I,J,K : INTEGER;
        C     : CHAR;
        S     : Str;

        Pt    : INTEGER;                                     { Record pointer }
        Rec   : Picrec;                                              { Record }

    begin { Save_pic }

      GotoXY (20,25);                                                  { Save }
      write ('      Save edited picture (Y/N): _      ');
      GotoXY (53,25);

      C := #0;

      repeat
        repeat until keypressed;
        read (kbd, C);
        C := upcase (C);
        if C = #27 then                                       { Blank display }
          begin
            HiRes;
            GotoXY (34,25);
            write ('Save (Y/N): _');
            GotoXY (46,25)
          end
      until (C = 'Y') or (C = 'N');
      write (C);

      if C = 'Y' then
        begin
          S := paramstr(1);                             { Build .BAK filename }
          I := pos ('.', S);
          if I > 0 then S := copy (S, 1, I-1);
          S := S + '.BAK';

          assign (Picfile, S);                         { Delete old .BAK file }
          {$I-} erase (Picfile) {$I+};
          I := IOresult;

          assign (Picfile, paramstr(1));                 { Rename source file }
          rename (Picfile, S);

          assign (Newfile, paramstr(1));                      { Open new file }
          reset (Picfile);
          rewrite (Newfile);

          for I := 0 to 4 do                       { Copy 1st 5 records as is }
            begin
              read(Picfile, Rec);
              write(Newfile, Rec)
            end;

          GotoXY (20,25);
          write ('  Now processing line     0  of  ', Plc:4, '.  ');

          Pt := 1;                                           { Record pointer }

          for I := 0 to Plc-1 do                                      { Lines }
            begin
              GotoXY (43,25); write (I+1:4);

              S[0] := chr (Pwide+2);          { Pre-compression string length }
              S[1] := chr (Pwide);               { Length-1 of 1st data block }

              for J := 0 to Pwide do                                  { Chars }
                begin
                  S[J+2] := chr(ord(Pic[I, J]) xor $FF);    { Char from array }
                end;

              S := Pac_rec (S);                             { Pack the record }

              if length (S) < 129-Pt then { Data does not fill current record }
                begin
                  move (S[1], Rec[Pt], length(S));    { Move data into record }
                  Pt := Pt + length(S)                      { Advance pointer }
                end
              else                                { Data fills current record }
                begin
                  move (S[1], Rec[Pt], 129-Pt);       { Move data into record }
                  write (Newfile, Rec);                        { Write record }
                  if Pt+length(S) = 129 then              { Data fits exactly }
                    Pt := 1
                  else                            { Overflow into next record }
                    begin
                      move (S[130-Pt], Rec[1], length(S)+Pt-129); { Move data }
                      Pt := length(S)+Pt-128                 { Adjust pointer }
                    end
                end
            end;

          if Pt > 1 then                                   { Fill last record }
            begin
              for I := Pt to 128 do Rec[I] := #0;
              write (Newfile, Rec)
            end;

          close (Picfile);                                      { Close files }
          close (Newfile)

        end;

      GotoXY (20,25);                                                  { Exit }
      write ('        Continue editing (Y/N): _       ');
      GotoXY (52,25);

      C := #0;

      repeat
        repeat until keypressed;
        read (kbd, C);
        C := upcase (C)
      until (C = 'Y') or (C = 'N');
      write (C);

      Save_pic := C                                     { Return final answer }

    end;  { Save_pic }

  {===========================================================================}

  begin { EdMac }

    if paramcount <> 1 then
      begin
        TextColor (LightGray);
        clrscr;
        writeln ('EdMac - MacPaint file compatible graphics editor');
        writeln ('Ver. 1.00   03/16/87   FreeWare by S.D. Gorrell');
        writeln;
        writeln;

        writeln ('Usage -  Edmac [drive:][path/]filename.ext');
        writeln;
        writeln;

        writeln ('Cursor Keys   - Move up, down, left, right');
        writeln ('Num Pad       - Move up, down, left, right, and diagonal');
        writeln ('U, <PgUp>     - Scroll screen back');
        writeln ('D, <PgDn>     - Scroll screen forward');

        writeln ('F             - Set fast cursor movement');
        writeln ('S             - Set slow cursor movement');
        writeln ('.             - Toggle cursor movement fast / slow');

        writeln ('P, <CR>       - Toggle pen up / down');
        writeln ('+, <Ins>      - Set mode to draw');
        writeln ('-, <Del>      - Set mode to erase');
        writeln ('<Space>       - Toggle bit under cursor');

        writeln ('C             - Toggle cursor on / off');
        writeln ('M             - Toggle magnifiaction on / off');
        writeln;

        writeln ('<Esc>         - Exit with optional save');
        writeln
      end
    else
      begin
        HiRes;                                     { High resolution graphics }
        Load_pic;                                         { Load picture file }
        repeat
          Edit_pic                                                  { Edit it }
        until Save_pic = 'N';                           { Save edited picture }
        TextMode                                          { Back to text mode }
      end

  end.  { EdMac }