program ColorPrt;



uses

  Graph,

  Dos,

  Crt;



const

  Forever: boolean = false;



var

  InFile, OutFile:  string;

  SizeX,SizeY: integer;

  extended: boolean;

  Letter: array[1..40,1..255] of char;

  LetterColor: array[1..40,1..255] of byte;

  col, line: longint;

  PrintColor: byte;



Procedure InitializeLetterArray;

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

begin

  for col := 1 to 255 do

    for line := 1 to 40 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('This program takes FalcoNet distro lists and converts them into');

  writeln('ascii files spaced for printing out on labels for CQ distro.');

  writeln('The net distribution list must have been taken off the net and');

  writeln('stored on the personal computer''s disk.');

  writeln('Control-Break to quit.');

  writeln('C1C David W. Croft, class of 1990, CS-36, x4306');

  writeln;

  write('Name of distro list file:  ');

  readln(InFile);

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

  readln(OutFile);

end;



procedure LoadFile(Infile: string);

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

var

  InF:  text;

  alpha, x1, y1: integer;

  Khar: char;

begin

  assign(InF, InFile);

  reset(InF);

  Col := 1;

  Line := 1;

  repeat

    read(InF, Khar);

    Letter[Line,Col] := Khar;

    if Line < 41 then

      begin

        x1 := (Col-1)*SizeX;

        y1 := (Line-1)*SizeY;

        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 (col = 1) and (line/100 = int(line/100)) then

      readln;

  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, #27+'3'+ #14); {set line spacing to 14/216 inch}

  for line := 1 to 40 do

    for col := 1 to 255 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,White);

  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,2);

  x1 := (Col-1)*SizeX;

  y1 := (Line-1)*SizeY;

  x2 := Col*SizeX;

  y2 := Line*SizeY;

  write(#7);

  readln;

  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);

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

const

  Up = 0;

var

  alpha:  integer;

begin

  case Direction of

    Up:  for alpha := 1 to 40 do

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

  end; {case}

end;



Procedure UpdateComWin;

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

var

  OutStr,

  ColStr,

  LineStr: string;

begin

  SetFillStyle(SolidFill, 5);

  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);

end;



Procedure MoveCursor(direction: byte);

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

const

  Up = 0;

begin

  if not(Extended) then

    EraseCursor;

  case direction of

    72:  if Line > 1 then

           begin

             Dec(Line);

             UpdateComWin;

           end;

    75:  if Col > 1 then

           begin

             Dec(Col);

             UpdateComWin;

           end;

    77:  if Col < 255 then

           begin

             Inc(Col);

             UpdateComWin;

           end;

    80:  if Line < 40 then

           begin

             Inc(Line);

             UpdateComWin;

           end

         else

           ShiftScreen(Up);

  end;

  PlaceCursor;

end;



Procedure FlipExtended;

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

begin

  Extended := not(Extended);

end;



Procedure ChangeLetterColor(ColorCode: byte);

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

var

  NewColor: byte;

begin

  case ColorCode of

    59:  NewColor := 1; {black}

    60:  NewColor := 4; {red}

    61:  NewColor := 9; {blue}

    62:  NewColor := 5; {violet}

    63:  NewColor := 14; {yellow}

    64:  NewColor := 12; {orange}

    65:  NewColor := 10; {green}

  end;

  case NewColor of

    1:  PrintColor := 0;

    4:  PrintColor := 1;

    9:  PrintColor := 2;

    5:  PrintColor := 3;

    14:  PrintColor := 4;

    12:  PrintColor := 5;

    10:  PrintColor := 6;

  end;

  SetColor(NewColor);

  LetterColor[Line,Col] := PrintColor;

  PlaceCursor;

end;



Procedure MainLoop;

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

var

  alpha: char;

  bravo: byte;

begin

  extended := false;

  repeat

    alpha := readkey;

    if alpha = #27 then

      halt;

    if alpha = #0 then

      begin

        bravo := ord(readkey);

        if bravo in [72,75,77,80] then

          MoveCursor(bravo);

        if bravo in [59..65] then

          ChangeLetterColor(bravo);

        if bravo = 68 then

          FlipExtended;

        if bravo = 67 then

          SaveNewFile(OutFile);

      end;

   until Forever;

end;



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

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

begin

  SizeX := 8;

  SizeY := 8;

  InitializeLetterArray;

  intro(InFile,OutFile);

  InitGraphics;

  SetPalette(2, White);

  SetBkColor(White);

  SetPalette(1, Black);

  SetColor(1);

  PrintColor := 0;

  ClearDevice;

  SetTextStyle(DefaultFont, HorizDir, 1);

  MoveTo(2,2);

  LoadFile(InFile);

  PlaceCursor;



  write(#7);



  UpdateComWin;

  MainLoop;

  CloseGraph;

end.