Power-Programmierung/CD1.mdf/pascal/utility/crossref/pxl/pxlinst.pas

Pascal/Delphi Source File | 1988-05-03 | 20.8 KB | 642 lines

{$R-}    {Range checking off}
{$B-}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}
{$M 32768,16384,65536}

program PXLInst (input,output);                                       {.CP38}
{  Creates &/or updates PXL.PRN data file of print control characters for   }
{  use by PXL Pascal X-Ref lister.                                          }
{                                                                           }
{  Allows up to three control characters for six actions:                   }
{                                                                           }
{      (1) underlining on             (2) underlining off,                  }
{      (3) elite off,                 (4) elite off,                        }
{      (5) condensed on               (6) condensed off                     }
{                                                                           }
{  plus                                                                     }
{                                                                           }
{      (7) page control (either by Char #12 or by line count).              }
{                                                                           }
{  Data is stored in of string[3], though the program (like PXL) thinks     }
{  of them as bytes (arrays of [0..4] bytes where [0] shows how many of     }
{  the other 3 are significant).                                            }
{                                                                           }
{  Programmer: R. N. Wisan, 7/6,1985       (Converted for TP4, 1988)        }


Uses
  CRT,
  DOS;

const
   Blank      = '           ';
   Bright     = 14;               {Colors for screen.  Set 'em as you like. }
   Dim        =  2;               {Inverse text will be Background on Dim.  }
   Background =  0;

type
   LineType = string[79];
   Str48    = string[48];
   Str11    = string[11];
   Tpface   = (MrkB, MrkE, SmallB,SmallE,CondB,CondE,FF);
   ByteLine = array[0..3] of byte;
   Bytes    = array [MrkB..FF] of ByteLine;
   Fil      = File of ByteLine;
var                                                                   {.CP15}
   I:           integer;
   B,OrigAtt:   byte;
   Ch:          char;
   F:           file of ByteLine;
   T:           TpFace;
   Inst:        Bytes;
   Line:        Str11;
   Changed,
   FFFlag,
   Quit,
   GotFile,
   Extended:    boolean;
   TypeLabel:   array[MrkB..FF] of string[20];
   TypeLine:    array[MrkB..FF] of byte;
   FName,
   HeadLine:    LineType;
   CRet:        string[3];

procedure Bip;                                                         {.CP5}
begin
   sound(1760); delay(10); sound(440); delay(30);
   sound(1760); delay(15); nosound
end;

procedure Blanklines (Top,Bot: byte);                                  {.CP9}
var
   Col,Row:   byte;
begin
   for Row := Top to Bot do begin
      GotoXY(1,Row);
      for Col := 1 to 79 do write(#32)
   end {for Row}
end; {Blanklines}

function CurrentAttribute: byte;                                      {.CP12}
var
   R:    Registers;
begin
   GotoXY(1,pred(WhereY));
   with R do begin
      AH := $08;
      BH := 0;
      Intr($10,R);
      CurrentAttribute := AH
   end {with R}
end; {CurrentAttribute}

procedure RestoreScreen(Att: byte);                                   {.CP17}
{ Put screen back politely (if Att is the atribute found by CurrentAttribute}
{ on entry).  Scrolls up one line to set color, but does not overwrite any  }
{ other part of the screen.                                                 }
var
   Filler:    integer;
   R:         Registers;
begin
   GotoXY(1,24);
   with R do begin {Scroll up one line at bottom of screen coloring   }
      AX := $0601;    {BIOS Video Svc 6 in AH, 1 line to scroll in AL }
      CX := $1800;    {Top row 23 in CH, Lft col 0 in CL }
      DX := $194F;    {Bot row 24 in CH, Rt col 79 in CL }
      BH := Att;      {Attribute in BH }
   end; {with R}
   Intr($10,R);    {BIOS Video service}
end; {RestoreScreen}

procedure Center(S: LineType; Row: byte);                              {.CP9}
var
   B:    byte;
begin
   BlankLines(Row,Row);
   GotoXY(1,Row);
   for B := 1 to (40 - (length(S) div 2)) do write(#32);
   write(S);
end; {Center}

function EnvironLine(LineStart: LineType): LineType;                  {.CP30}
{ Searches DOS Environment for line beginning with LineStart        }
{ Returns line with LineStart removed it in EnvironLine if found.   }
{ Returns "NONE" if not found. }
var
   S:               LineType;
   EnvAdd:          word;
   B:               byte;
   LineFound:       boolean;
begin
   EnvAdd := MemW[PrefixSeg:$2C];
   LineFound := False;
   for B := 1 to ord(LineStart[0]) do LineStart[B] := UpCase(LineStart[B]);
   B := 0;
   repeat
      S := '';
      while Mem[EnvAdd:B]<>0 do begin
         S := S + UpCase(char(Mem[EnvAdd:B]));
         B := succ(B)
      end; {while}
      if pos(LineStart,S)=1 then begin
         delete(S,1,ord(LineStart[0]));
         while S[1] in [' ','='] do delete(S,1,1);
         EnvironLine := S;
         LineFound := True
      end; {if PATH}
      B := succ(B)
   until (S[0]=#0) or LineFound;
   if not LineFound then EnvironLine := 'NONE'
end; {EnvironLine}

function FindFile(var FName: LineType): boolean;                       {.CP9}
{Takes File name.  Searches for file on default drive & along DOS PATH.  }
{Reports success or failure in FindFile.                                 }
{If file is found, returns openable FName with successful path prefixed. }
var
   Paths,
   Try:       LineType;
   F:         text;   {File type doesn't matter.  File only reset, not read.}
   GotIt:     boolean;

   function Path(var P: LineType): LineType;                          {.CP15}
   {Takes DOS PATH line and peels one path specifier from it.  }
   {Returns specifier in Path, bobtailed DOS PATH line in P.   }
   var
      Chunk:     LineType;
   begin
      Chunk := '';
      while (P[1]<>';') and (P[0]<>#0) do begin
         Chunk := Chunk + P[1];
         delete(P,1,1)
      end; {while not ";"}
      while (P[1]=';') and (P[0]<>#0) do delete(P,1,1);
      if Chunk[ord(Chunk[0])]<>'\' then Chunk := Chunk + '\';
      Path := Chunk
   end; {Path}

   function Found(var F: text): boolean;                              {.CP14}
   {Takes file variable, tries to open it.  Closes file if opened. }
   {Reports success or failure in Found.                           }
   begin
      {$I-}
      reset(F);
      {$I+}
      if IOresult=0 then begin
         Found := True;
         close(F);
      end {if 0}
      else
         Found := False;
   end; {Found}

begin {FindFile}                                                      {.CP23}
   assign(F,FName);
   if Found(F) then
      GotIt := True
   else begin                                          {Strip all path specs}
      while (pos(':',FName)<>0) or (pos('\',FName)<>0) do
         delete(FName,1,1);
      Paths := EnvironLine('PATH');               {Get PATH from Environment}
      if Paths='NONE' then begin
         assign(F,FName);                     {if no PATH, try default drive}
         GotIt := Found(F)
      end {if NONE}
      else begin                                     {else search along PATH}
         repeat
            Try :=  Path(Paths);
            assign(F,Try + FName);
            GotIt := Found(F)
         until (Try='\') or GotIt;
         if GotIt then FName := Try + FName
      end {else found a PATH}
   end; {else not on default drive}
   FindFile := GotIt;
end; {FindFile}

procedure ReadFile;                                                   {.CP19}
var
   I:              integer;
   B:              byte;       C: CHAR;
begin
   FName := 'PXL.PRN';
   if FindFile(Fname) then begin
      assign(F,FName);
      Reset(F);
      for T := MrkB to FF do
         if not Eof(F) then read(F,Inst[T]);
      close(F);
      GotFile := TRUE;
   end {if}
   else Begin
      GotFile := FALSE;
      GotoXY(1,23)
   end; {else}
end; {ReadFile}

procedure MakeFile;                                                    {.CP9}
begin
   if FName=''
      then Assign(F,'PXL.PRN')
      else assign(F,FName);
   rewrite(F);
   for T := MrkB to FF do write(F,Inst[T]);
   close(F)
end; {MakeFile}

procedure ParseLine(var Line: Str11; var Inst: ByteLine);             {.CP13}
var
   I,X,C:    integer;
   Temp:     string[3];
   B,NBytes: byte;

   procedure Strip;
   var
      Ch:          char;
   begin
      while (not (Line[1] in ['0'..'9'])) and (Length(Line)>0) do
         delete(Line,1,1);
   end; {Strip}

   procedure GetDigit(var X: integer);                             {.CP20}
   var
      Delimit:       integer;

      procedure FindDelimit;
      var
         Limiter:   array[0..3] of byte;
         B:          byte;
      begin {FindDelimit}
         Limiter[1] := pos(',',Line);
         Limiter[2] := pos('/',Line);
         Limiter[3] := pos(' ',Line);
         Limiter[0] := 255;
         for B := 1 to 3 do
            if (Limiter[B]<Limiter[0]) and (Limiter[B]>0) then
               Limiter[0] := Limiter[B];
         if Limiter[0] = 255
            then Delimit := 0
            else Delimit := Limiter[0];
      end; {FindDelimit}

   begin {GetDigit}                                                   {.CP12}
      FindDelimit;
      if Delimit=0 then Begin                        {if line has no Delimit}
         Temp := Line;
         Line := ''
      end {if no Delimit}
      else begin                                      {if Line has a Delimit}
         Temp := Copy(Line,1,pred(Delimit));
         delete(Line,1,Delimit);
      end; {if Delimit}
      val(Temp,X,C)
   end; {GetDigit}

Begin {ParseLine}                                                     {.CP16}
   Inst[0] := 0;
   if T=FF
      then NBytes := 1
      else NBytes := 3;
   For I := 1 to NBytes do begin
      If length(Line)>0 then Strip;                {Strip leading non-digits}
      If (Length(Line)>0) then Begin
         GetDigit(X);                             {Get 1st digit & Chop Line}
         Inst[0] := I;
         Inst[I] := X mod 256;
      End {if Line not zero}
      Else
         Inst[I] := 255
   End {For I}
End; {ParseLine}

Function KbIn: char;                                                  {.CP13}
var
   C:              char;
begin
   C := ReadKey;
   if C<>#0 then
      Extended := False
   else begin         {get extended code}
      Extended := True;
      C := ReadKey;
   end; {else}
   KbIn := C;
end; {KbIn}

procedure VideoInv;                                                    {.CP5}
begin
   TextColor(Background);
   TextBackGround(Dim)
end; {VideoInv}

procedure VideoNorm;                                                   {.CP5}
begin
   TextColor(Dim);
   TextBackGround(Background)
end; {VideoNorm}

procedure Initialize;                                                 {.CP12}
var
   T:      TpFace;
begin
   for T := MrkB to FF do
      Inst[T,0] := 0;
   Quit := False;
   FFFlag := True;
   CRet := #17+#196+#217;
   Changed := False
end; {Initialize}

procedure MakeLabels;                                                 {.CP23}
var
   B:     byte;
begin
   Headline := '   Font Style:        ';
   for B := length(HeadLine) to 39 do HeadLine := HeadLine + #32;
   HeadLine := HeadLine + 'Present Data:      ';
   If GotFile then HeadLine := HeadLine + '  In File:';
   TypeLabel[MrkB]   := 'Underlined: start: ';
   TypeLabel[MrkE]   := '            stop:  ';
   TypeLabel[SmallB] := 'Elite:      start: ';
   TypeLabel[SmallE] := '            stop:  ';
   TypeLabel[CondB]  := 'Condensed:  start: ';
   TypeLabel[CondE]  := '            stop:  ';
   TypeLabel[FF]     := 'Page Control:      ';
   TypeLine[MrkB]   :=  7;
   TypeLine[MrkE]   :=  8;
   TypeLine[SmallB] := 10;
   TypeLine[SmallE] := 11;
   TypeLine[CondB]  := 13;
   TypeLine[CondE]  := 14;
   TypeLine[FF]     := 16;
end; {MakeLabels}

procedure PrintData (Instruc: Byteline);                              {.CP16}
var
   B:         byte;
begin
   if Instruc[0]=0 then
      write(' [Nothing] ')
   else if (T=FF) and (Instruc[0]=1) and (Instruc[1]=66) then
      write(' 66 [Default]')
   else if (T=FF) and (Instruc[0]=1) and (Instruc[1]=12) then
      write(' 12 [Form Feed]')
   else
      for B := 1 to Instruc[0] do begin
         write(Instruc[B]:3);
         if B<Instruc[0] then write('  ')
      end {for B}
end; {PrintData}

procedure LayOut;                                                     {.CP15}

   procedure WriteHelpLine;
   begin
      write('Use ');
      TextColor(Bright); write(#27);     VideoNorm; write(', ');
      TextColor(Bright); write(#26);     VideoNorm; write(', ');
      TextColor(Bright); write(#24);     VideoNorm; write(', ');
      TextColor(Bright); write(#25);     VideoNorm; write(', ');
      TextColor(Bright); write('Home');  VideoNorm; write(', ');
      TextColor(Bright); write('End');   VideoNorm; write(', ');
      TextColor(Bright); write('PgUp');  VideoNorm; write(', & ');
      TextColor(Bright); write('PgDn');  VideoNorm; write(' to move, ');
      TextColor(Bright); write('Esc');   VideoNorm; write(' to quit.');
   end; {WriteHelpLine}

begin {LayOut}                                                        {.CP22}
   Center('Printer Installation for PXL Pascal Lister',1);
   GotoXY(31,3); write('To exit, press <');
   TextColor(Bright); write('Esc'); VideoNorm; write('>');
   GotoXY(1,5); write(HeadLine);
   for T := MrkB to FF do begin
      GotoXY(1,TypeLine[T]);
      write(TypeLabel[T]);
      GotoXY(40,TypeLine[T]);
      PrintData(Inst[T]);
      if GotFile then begin
         GotoXY(60,TypeLine[T]);
         PrintData(Inst[T])
      end {if GotFile}
   end; {for T}
   if not GotFile then begin
      GotoXY(60,TypeLine[MrkE]);
      write('  --- No File ---')
   end {if not GotFile}
   else
      Center('File is ' + FName, 2);
   GotoXY(10,25);
   WriteHelpLine
end; {Layout}

procedure Message;                                                    {.CP32}
begin
   if FFFlag then begin
      GotoXY(5,18);
      write('     Enter the ASCII numbers ('); TextColor(Bright); write('numbers');
      VideoNorm; write(' not characters) of the print     ')
   end; {if FFFlag}
   GotoXY(5,19);
   case T of
      MrkB..SmallE:  write('        ');
      CondB..CondE:  write('      ');
   end; {case}
   write('control symbols your printer needs to ');
   TextColor(Bright);
   case T of
      MrkB:   write('start underlining.        ');
      MrkE:   write('stop underlining.         ');
      SmallB: write('start elite print.        ');
      SmallE: write('stop elite print.         ');
      CondB:  write('start condensed print.    ');
      CondE:  write('stop condensed print.     ');
   end; {case}
   VideoNorm;
   if FFFlag then begin
      Center('    Enter up to 3 numbers, separated by comma,' +
         ' space, or slash (/).     ',21);
      GotoXY(17,22);
      write('Then press <CR> ('); TextColor(Bright); write(CRet);
      VideoNorm; write(') to enter them as data.');
      FFFlag := False
   end {if FFFlag}
end; {Message}

procedure FFMessage;                                                  {.CP15}
begin
   GotoXY(5,18);
   write(' If Character #12 makes your printer feed out a fresh page, enter');
      TextColor(Bright); write(' 12 '); VideoNorm;
   GotoXY(5,19);
   write('Otherwise, enter ');
      TextColor(Bright); write('the number of lines you get on a page,');
      VideoNorm; write(' (66 is common)');
   GotoXY(5,21);
   write('   Type a single number.  Then press <CR> ('); TextColor(Bright);
      write(CRet); VideoNorm; write(') to enter it as data.   ');
   if not FFFlag then BlankLines(22,22);
   FFFlag := True
end; {FFMessage}

procedure SortExtent(B: char);                                        {.CP14}
begin
   case B of
      'H':     if T=MrkB                     {Up arrow}
                  then T := FF
                  else dec(T);
      'G','I': T := MrkB;                    {Home or PgUp}
      'P':     if T=FF                       {Down arrow}
                  then T := MrkB
                  else inc(T);
      'O','Q': T := FF;                      {End or PgDn}
      else Bip;
   end; {case}
end;

procedure GoGetEm;                                                    {.CP13}

   procedure ReadLine(var Line:Str11);

      procedure BackSpace;
      begin
         if length(Line)>0 then begin
            write(#8,#32,#8);
            delete(Line,length(Line),1)
         end {if length}
         else
            Bip
      end; {BackSpace}

      procedure ProcCharacter;                                         {.CP9}
      begin
         if length(Line)<11 then begin
            Line := Line + Ch;
            write(Ch)
         end {if length}
         else
            Bip
      end; {ProcCharacter}

   begin {ReadLine}                                                   {.CP18}
      Ch := #0; Extended := False; Line := '';
      while not (Extended or Quit or (WhereX>31)
            or (Ch=#13) or (length(Line)>11)) do begin
         Ch := Kbin;
         if (Ch=#8) or (Extended and (Ch='K')) then begin         {Backspace}
            BackSpace;
            Extended := False
         end {if backspace}
         else if Extended and (Ch='M') then begin               {Right Arrow}
            Ch := #32;
            ProcCharacter;
            Extended := False
         end {else if Rt arrow}
         else if Ch=#27 then Quit := True                            {Escape}
         else if not extended and (Ch<>#13) then ProcCharacter     {Reg Char}
      end {While}
   end; {ReadLine}

   procedure PrintCurrentLine;                                         {.CP6}
   begin
      GotoXY(20,TypeLine[T]); for B := 20 to 39 do write(#32);
      PrintData(Inst[T]);
      for B := WhereX to 59 do write(#32);
   end;

begin {GoGetEm}                                                       {.CP22}
   T := MrkB;
   while not Quit do begin
      if T = FF then FFMessage else Message;
      GotoXY(20,TypeLine[T]); VideoInv; write(Blank); GotoXY(20,TypeLine[T]);
      ReadLine(Line);
      VideoNorm;
      PrintCurrentLine;
      if Ch=#13 then begin
         Changed := True;
         ParseLine(Line,Inst[T]);
         if (T=FF) and (Inst[T,0]=0) then begin  {FF may not be empty, so   }
            Inst[T,0] := 1;                      {default to 66 (lines/page)}
            Inst[T,1] := 66
         end; {if FF}
         PrintCurrentLine;
         if T=FF
            then T := MrkB
            else inc(T);
      end {if CR}
      else if Extended then
         SortExtent(Ch);
   end; {while}
end; {GoGetEm}

procedure SaveIt;                                                      {.CP8}
begin
   MakeFile;
   if GotFile then
      Center('Okay, data in PXL.PRN updated',22)
   else
      Center('Okay, new PXL.PRN file created & data stored in it',22)
end; {SaveIt}

procedure QuitIt;                                                      {.CP7}
begin
   if GotFile then
      Center('Okay, new data are ignored.  PXL.PRN is unchanged.',22)
   else
      Center('Okay, new data are ignored.  No PXL.PRN created.',22)
end; {QuitIt}

procedure AskSave;                                                    {.CP27}
const
   Answers: set of char = ['Y','N'];
   Yesses: set of char = ['Y','y'];
var
   Ch:        char;
begin {AskSave}
   BlankLines(18,24);
   repeat
      if GotFile then
         Center('Do you want PXL.PRN updated with this new data?  ',20)
      else
         Center('Do you want this data saved in PXL.PRN?  ',20);
      Ch := UpCase(ReadKey);
      if not (Ch in Answers) then begin
         BlankLines(19,19);
         Bip;
         gotoXY(5,19);
         write('You must answer ');
         TextColor(Bright); write('Y');
         VideoNorm; write(' or ');
         TextColor(Bright); write('N');
         VideoNorm; write(':')
      end {if not answer}
      else
         write(Ch)
   until Ch in Answers;
   if Ch in Yesses then SaveIt else QuitIt (* := True else Save := False*)
end; {AskSave}

procedure PartFriends;
begin
   BlankLines(18,24);
   Center('Nothing changed.  Nothing saved.',20);
   Center('Nothing venture, nothing win.',21)
end; {PartFriends}

begin {install main}                                                  {.CP18}
   OrigAtt := CurrentAttribute;
   CheckBreak := False;
   VideoNorm;
   ClrScr;
   Initialize;
   ReadFile;
   MakeLabels;
   LayOut;
   GoGetEm;
   if Changed
      then AskSave
      else PartFriends;
   RestoreScreen(OrigAtt);
end.