program ColorPrt;



uses

  Graph,

  Dos,

  Crt;



const

  BackColor = LightGray;

  InitCharColor = Black;



  ESC = #27;

  Home = 71;

  EndLine = 79;

  PgUp = 73;

  PgDn = 81;

  Left = 75;

  Right = 77;

  Up = 72;

  Down = 80;



  LastCol = 80;

  LastLine = 40;



  ColorKeys = [59..65];

  FlipExt = 68;

  SaveKey = 67;



  FunctionLineStr =

    'F1 - F7: Change Color, F9: Save, F10: Extended, Esc: Quit';



var

  DumInt: integer;

  InFile, OutFile:  string;

  SizeX,SizeY: integer;

  extended: boolean;

  Letter: array[1..LastLine,1..LastCol] of char;

  LetterColor: array[1..LastLine,1..LastCol] of byte;

  col, line: longint;

  PrintColor: byte;

  Quit: boolean;

  CursorColor: shortint;

  ComWinColor: shortint;



Procedure InitializeLetterArray;

{***************************************************************************}

begin

  for col := 1 to LastCol do

    for line := 1 to LastLine do

      begin

        Letter[line,col] := #0;

        LetterColor[line,col] := 0;

      end;

end;



Procedure InitGraphics;

{***************************************************************************}

{*  Task:  This procedure switches from CRT mode text output to graphics.

{*    Your program must include the turbo unit Graph.

{*    The *.BGI (graphics driver) program must be available.

{*  Author:  C1C David W. Croft, CS-36, x4306

{***************************************************************************}

var

  GraphDriver: integer;

  GraphMode: integer;

  ErrorCode: integer;

begin

  DetectGraph(GraphDriver, GraphMode);

  InitGraph(GraphDriver, GraphMode, '');

  ErrorCode := GraphResult;

  if ErrorCode <> grOk then

    begin

      RestoreCrtMode;

      Writeln('Graphics error:  ',GraphErrorMsg(ErrorCode));

      Writeln('Program aborted...');

      Halt(1);

    end;

end;



procedure intro(var InFile, OutFile: string);

{***************************************************************************}

begin

  clrscr;

  writeln('COLORPRT adds color to your printable files.');

  writeln('It works with the STAR NX-1000 Rainbow printer or any');

  writeln('printer that uses the control code ((C))n to change colors.');

  writeln('Copyright 1990 -- David W. Croft');

  writeln;

  writeln('Work on the shift procedure.');

  write('Name of input file:  ');

  readln(InFile);

  write('Name of output file to be created:  ');

  readln(OutFile);

end;



function Converted(PrinterColor: byte): integer;

{***************************************************************************}

var

  NewColor: integer;

begin

  case PrinterColor of

    0:  NewColor := Black; {black}

    1:  NewColor := LightMagenta; {red}

    2:  NewColor := Blue; {blue}

    3:  NewColor := Magenta; {violet}

    4:  NewColor := Yellow; {yellow}

    5:  NewColor := LightRed; {orange}

    6:  NewColor := LightGreen; {green}

  end;

  Converted := NewColor;

end;





procedure LoadFile(Infile: string);

{***************************************************************************}

var

  InF:  file of char;

  alpha, bravo, OldFilePos, x1, y1: integer;

  Khar: char;

  CurrentFilePos: integer;

  TempArray: array[1..4] of char;

  ColorChar: char;

begin

  assign(InF, InFile);

  reset(InF);

  Col := 1;

  Line := 1;

  PrintColor := 0; {black}

  repeat

    CurrentFilePos := FilePos(InF);

    read(InF, Khar);

    if Khar in ['('] then

      begin

        case Khar of

          '(':  begin

                  for bravo := 1 to 4 do

                    read(InF, TempArray[bravo]);

                  if TempArray = '(C))' then

                    begin

                      CurrentFilePos := CurrentFilePos + 6;

                      read(InF, ColorChar);

                      val(ColorChar, PrintColor, DumInt);

                    end;

                end;

        end; {case}

      end;

    Seek(Inf,CurrentFilePos);



        read(InF, Khar);

        Letter[Line,Col] := Khar;

        LetterColor[Line,Col] := PrintColor;

        if Line <= LastLine then

          begin

            x1 := (Col-1)*SizeX;

            y1 := (Line-1)*SizeY;

            SetColor(Converted(LetterColor[Line,Col]));

            if (x1 < GetMaxX) and (y1 < GetMaxY) then

              OutTextXY(x1+2,y1+2,Khar);

          end;

        Inc(Col);

        if Khar = #10 then

          begin

            Col := 1;

            Inc(Line);

          end;

        if line > LastLine then

          write(#7);



  until eof(InF);

  close(InF);

  Col := 1;

  Line := 1;

end;



Procedure SaveNewFile(OutFile: string);

{***************************************************************************}

var

  OutF: text;

  PresentColor: byte;

  CharPrintColor: string[1];

begin

  assign(OutF, OutFile);

  rewrite(OutF);

  write(OutF, '((C))0');

  PresentColor := 0; {black}



{  write(OutF, ESC+'3'+ #14);   }

{set line spacing to 14/216 inch}



  for line := 1 to LastLine do

    for col := 1 to LastCol do

      if Letter[line,col] <> #0 then

        begin

          if LetterColor[line,col] <> PresentColor then

            begin

              str(LetterColor[line,col], CharPrintColor);

              write(OutF, '((C))'+CharPrintColor);

              PresentColor := LetterColor[line,col];

            end;

          write(OutF, Letter[line,col]);

        end;

  close(OutF);

end;



Procedure EraseCursor;

{***************************************************************************}

var

  x1,y1,x2,y2: integer;

begin

  SetFillStyle(SolidFill,BackColor);

  x1 := (Col-1)*SizeX;

  y1 := (Line-1)*SizeY;

  x2 := Col*SizeX;

  y2 := Line*SizeY;

  Bar(x1+2,y1+2,x2-1+2,y2-1+2);

  OutTextXY(x1+2,y1+2, Letter[Line,Col]);

end;



Procedure PlaceCursor;

{***************************************************************************}

var

  x1,y1,x2,y2: integer;

begin

  SetFillStyle(SolidFill,CursorColor);

  x1 := (Col-1)*SizeX;

  y1 := (Line-1)*SizeY;

  x2 := Col*SizeX;

  y2 := Line*SizeY;

  Bar(x1+2,y1+2,x2-1+2,y2-1+2);

  OutTextXY(x1+2,y1+2, Letter[Line,Col]);

  LetterColor[line,col] := PrintColor;

end;



Procedure ShiftScreen(Direction: byte);

{***************************************************************************}

var

  alpha:  integer;

begin

  write(#7);

  case Direction of

    Up:  for alpha := 1 to LastLine do

           OutTextXY((Col-1)*SizeX, Line*SizeY, Letter[Line+1,Col]);

  end; {case}

end;



Procedure UpdateComWin;

{***************************************************************************}

var

  OutStr,

  ColStr,

  LineStr: string;

begin

  SetFillStyle(SolidFill, ComWinColor);

  Bar(0,349-3*8-1,639,349);

  str(col, colstr);

  str(line, linestr);

  OutStr := 'Line: ' + LineStr + ' Col: ' + ColStr;

  OutTextXY(1,349-25+1, OutStr);

  OutTextXY(1,349-25+1+SizeY, FunctionLineStr);

end;



Procedure MoveCursor(direction: byte);

{***************************************************************************}

begin

  if not(Extended) then

    EraseCursor;

  LetterColor[line,col] := PrintColor;

  case direction of

    Home:  Col := 1;

    EndLine:  Col := LastCol;

    PgUp:  Line := 1;

    PgDn:  Line := LastLine;

    Up:  if Line > 1 then

           begin

             Dec(Line);

           end;

    Left:  if Col > 1 then

           begin

             Dec(Col);

           end;

    Right:  if Col < LastCol then

           begin

             Inc(Col);

           end;

    Down:  if Line < LastLine then

           begin

             Inc(Line);

           end

         else

           ShiftScreen(Up);

  end;

  PlaceCursor;

end;



Procedure FlipExtended;

{***************************************************************************}

begin

  Extended := not(Extended);

  write(#7);

end;



Procedure ChangeLetterColor(ColorCode: byte);

{***************************************************************************}

var

  NewColor: byte;

begin

  case ColorCode of

    59:  NewColor := Black; {black}

    60:  NewColor := LightMagenta; {red}

    61:  NewColor := Blue; {blue}

    62:  NewColor := Magenta; {violet}

    63:  NewColor := Yellow; {yellow}

    64:  NewColor := LightRed; {orange}

    65:  NewColor := LightGreen; {green}

  end;

  case ColorCode of

    59:  PrintColor := 0;

    60:  PrintColor := 1;

    61:  PrintColor := 2;

    62:  PrintColor := 3;

    63:  PrintColor := 4;

    64:  PrintColor := 5;

    65:  PrintColor := 6;

  end;

  SetColor(NewColor);

  LetterColor[Line,Col] := PrintColor;

  PlaceCursor;

end;



Procedure MainLoop;

{***************************************************************************}

var

  alpha: char;

  bravo: byte;

begin

  extended := false;

  repeat

    alpha := readkey;

    case alpha of

      ESC: Quit := true;

       #0:  begin

              bravo := ord(readkey);

              if bravo in [Up,Left,Right,Down,Home,EndLine,PgUp,PgDn] then

                MoveCursor(bravo);

              if bravo in ColorKeys then

                ChangeLetterColor(bravo);

              if bravo = FlipExt then

                FlipExtended;

              if bravo = SaveKey then

                SaveNewFile(OutFile);

            end;

       else

         begin

           letter[line, col] := alpha;

           MoveCursor(right);

         end;

    end; {case}

    UpdateComWin;

  until Quit;

end;



{***************************************************************************}

{***************************************************************************}

begin

  CursorColor := LightCyan;

  ComWinColor := LightCyan;

  SizeX := 8;

  SizeY := 8;

  InitializeLetterArray;

  intro(InFile,OutFile);

  InitGraphics;

  PrintColor := InitCharColor;

  SetBkColor(Black);

  SetFillStyle(SolidFill, BackColor);

  Bar(0,0,GetMaxX,GetMaxY);

  PrintColor := InitCharColor;

  SetColor(PrintColor);

  SetTextStyle(DefaultFont, HorizDir, 1);

  MoveTo(2,2);

  LoadFile(InFile);

  PlaceCursor;

  UpdateComWin;

  Quit := false;

  MainLoop;

  CloseGraph;

  clrscr;

end.