home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / PASCSCR.LBR / DOSCREEN.PAS < prev    next >
Pascal/Delphi Source File  |  2000-06-30  |  14KB  |  483 lines
  1. PROGRAM DOSCREEN;
  2.  
  3. {Version 2.0 by Steve Cohen 2/13/85}
  4. {Released to Public Domain         }
  5. {To be compiled under Turbo-Pascal }
  6.  
  7. {I USED THE CP/M VERSION, BUT OFFHAND, I CAN'T }
  8. {SEE WHY IT SHOULDN'T WORK WITH MS-DOS AS WELL }
  9.  
  10. {$C-,V-}
  11.  
  12.  
  13. const
  14.  
  15.   { Change these if you don't have a 24x80 screen or if you    }
  16.   { wish to change the number of usable input lines.           }
  17.   { Configuration below mimics the format of BTREE.PAS included}
  18.   { in the Turbo-ToolBox                                       }
  19.  
  20.   Top = 4;
  21.   Bottom = 21;
  22.   Right = 80;
  23.   Left = 1;
  24.  
  25.   HV = #27#40; { these are the codes that generate normal      }
  26.   LV = #27#41; { intensity and reduced intensity characters on }
  27.                { my Advent System Kaypro video add-on board.   }
  28.                { Omit if you can't do reduced intensity.       }
  29.  
  30. type XAxis =0..81;
  31.      YAxis =0..25;
  32.      AnyStr = String[255];
  33.      Str80 = String[80];
  34.      FullScreen = array[Top..Bottom,Left..Right] of char;
  35.      DisplayField = record
  36.        XBegin : XAxis;
  37.        YBegin : YAxis;
  38.        Contents : String[80];
  39.      END;
  40.  
  41. Var Screen:FullScreen;
  42.     FieldTag,FieldBlank : Array[1..50] of DisplayField;
  43.     PasFile : Text;
  44.     ScrFile:File of FullScreen;
  45.     NoOfBlanks,NoOfTags : Integer;
  46.     FileName : String[10];
  47.  
  48. FUNCTION ConstStr(c:Char;N:Integer):AnyStr;
  49.  Var S: AnyStr;
  50.  BEGIN
  51.    S[0] := Chr(N);
  52.    FillChar(s[1],N,C);
  53.    ConstStr := S;
  54.  END;
  55.  
  56. PROCEDURE MKSCREEN (var Screen:FullScreen);
  57.  
  58. VAR
  59.   Ins                   : Boolean;
  60.   X                     : XAxis;
  61.   Y                     : YAxis;
  62.   C,Ch,Done             : Char;
  63.   Buffer                : str80;
  64.  
  65. PROCEDURE Display(VAR Screen: Fullscreen);
  66.   VAR I: XAxis;
  67.       J: YAxis;
  68.  
  69.   BEGIN
  70.     For J := Top to Bottom do
  71.     BEGIN
  72.       GotoXY(Left,J);
  73.       For I := Left to Right do
  74.         Write(Screen[J,I]);
  75.     END;
  76.     GotoXY(70,2);
  77.     If Ins then
  78.       Write(HV,'INSERT')
  79.     Else
  80.       Clreol;
  81.     GotoXY(1,23); Clreol;
  82.     Write('Type ^F to get screen from file, ^C when finished',LV);
  83.     X:=Left; Y := Top;
  84.     GotoXY(X,Y);
  85.   END;
  86.  
  87. PROCEDURE GETSCREEN (Var Screen:FullScreen);
  88. VAR FileName : String[10];
  89.     NScreen : FullScreen;
  90.     ScrFile  : File of Fullscreen;
  91.     C: Char;
  92. BEGIN
  93.   GotoXY(1,23); Clreol;
  94.   Write('Name of File to get:  ');
  95.   Readln(FileName);
  96.   FileName := FileName + '.SCR';
  97.   Assign(ScrFile,FileName);
  98.   {$I-}
  99.   Reset(ScrFile);
  100.   If IOResult <> 0 then
  101.   BEGIN
  102.     GotoXY(1,23); Clreol;
  103.     Write(^G,'FILE ',FILENAME,' NOT FOUND. TYPE ANY KEY TO CONTINUE.');
  104.     READ(KBD,C);
  105.   END ELSE
  106.   BEGIN
  107.     Read(ScrFile,NScreen);
  108.     If IOResult <> 0 then
  109.     BEGIN
  110.       GotoXY(1,23); Clreol;
  111.       Write('BAD FILE. Can''t Read.  Type any key to continue.');
  112.       Read(Kbd,C);
  113.     END ELSE
  114.       Screen := NScreen;
  115.   END;
  116.   Display(Screen);
  117. END;
  118.  
  119. {AddChar adds characters to the screen in the non-insert mode }
  120.  
  121. PROCEDURE AddChar(C:Char);
  122.   BEGIN
  123.     Write(C);
  124.     Screen[Y,X] := C;
  125.     X := Succ(X);
  126.     If X > Right Then
  127.       BEGIN
  128.         X := Left;
  129.         Y := Succ(Y);
  130.         If Y > Bottom Then Y := Top;
  131.         GotoXY(X,Y);
  132.       END; {If}
  133.   END;{AddChar}
  134.  
  135. { InsChar inserts characters into the screen display in the    }
  136. { insert mode.                                                 }
  137.  
  138. PROCEDURE InsChar(C:Char);
  139. VAR Buffer : Str80;
  140.     I : Integer;
  141.   BEGIN
  142.     If X < Right then
  143.     BEGIN
  144.       Move(Screen[Y,X],Buffer[1],Right - X);
  145.       Buffer[0] := Chr(Right - X);
  146.       Insert(C,Buffer,1);
  147.       Move(Buffer[1],Screen[Y,X],Right - Pred(x));
  148.       I := Succ(Length(Buffer));
  149.       REPEAT
  150.         I := Pred(I);
  151.         If Buffer[I] = ' ' then
  152.           Delete(Buffer,I,1)
  153.       UNTIL (Buffer[I] <> ' ') or (I <= 1);
  154.       Write(Buffer);
  155.       X := Succ(X);
  156.       If X > Right then
  157.       BEGIN
  158.         X := Left;
  159.         Y := Succ(Y);
  160.         If Y > Bottom then Y := Top;
  161.       END;
  162.       GotoXY(X,Y);
  163.     END else AddChar(C);
  164.   END;
  165.  
  166. { MoveCursor handles those control codes which simply move the }
  167. { cursor around the screen display.                            }
  168.  
  169. PROCEDURE MoveCursor(C:Char);
  170.   BEGIN
  171.     Case C of
  172.       #24,#10 : Y := Succ(Y);
  173.       #19,#8  : X := Pred(X);
  174.       #4,#12  : X := Succ(X);
  175.       #5,#11  : Y := Pred(Y);
  176.       #13     : BEGIN
  177.                   Y := Succ(Y);
  178.                   X := Left;
  179.                 END;{13}
  180.  
  181.     END;{Case}
  182.       If X < Left then
  183.         BEGIN
  184.           X := Right;
  185.           Y := Pred(Y);
  186.         END;{If}
  187.       If X > Right then
  188.         BEGIN
  189.           X := Left;
  190.           Y := Succ(Y);
  191.         END;{If}
  192.       If Y < Top then Y := Bottom;
  193.       If Y > Bottom then Y := Top;
  194.       GotoXY(X,Y);
  195.     END;{MoveCursor}
  196.  
  197.   { Delchar deletes a character both from the screen and from  }
  198.   { its proper place in memory.                                }
  199.  
  200.   PROCEDURE Delchar;
  201.   BEGIN
  202.     Move(Screen[Y,X],Buffer[1],Right-Pred(X));
  203.     Buffer[0] := Chr(Right - Pred(X));
  204.     Delete(Buffer,1,1);
  205.     Buffer := Buffer + ' ';
  206.     Write(Buffer);
  207.     Move(Buffer[1],Screen[Y,X],Length(Buffer));
  208.     GotoXY(X,Y);
  209.   END;
  210.  
  211.   {TabOver implements an 8-character fixed tab                 }
  212.  
  213.   PROCEDURE TabOver(Var XPos: XAxis; Var YPos: YAxis);
  214.   BEGIN
  215.     If X <= 72 then
  216.       XPos := Succ(8 * (Succ(Pred(XPos) div 8)))
  217.     Else
  218.     BEGIN
  219.       XPos := 1;
  220.       YPos := Succ(YPos);
  221.       If YPos > Bottom then
  222.         YPos := Top;
  223.     END;
  224.     GotoXY(XPos,YPos);
  225.   END;
  226.  
  227.  
  228. BEGIN {MkScreen}
  229.   Ins := True;
  230.   Done := ' ';
  231.   Clrscr;
  232.  
  233.    { the following four lines produce the bordering effect I   }
  234.    { chose for the screens I wish to generate.  Modify or omit }
  235.    { if you wish.  If you do change these you may also wish to }
  236.    { change the 'Top' and 'Bottom' constants declared at the   }
  237.    { start of this program.                                    }
  238.  
  239.   GotoXY(1,1);Write(LV,ConstStr('-',79));
  240.   GotoXY(1,3);Write(ConstStr('-',79));
  241.   GotoXY(1,22);Write(ConstStr('-',79));
  242.   GotoXY(1,24);Write(ConstStr('-',79));
  243.  
  244.   Ins := True;
  245.   Display(Screen);
  246.  
  247.   REPEAT
  248.     Read(Kbd,Ch);
  249.     Case Ch of
  250.       #32 .. #126 : If Ins then InsChar(Ch) else
  251.                                    AddChar(Ch);
  252.       ^D,^E,^H,^J,
  253.       ^K,^L,^M,^S,
  254.       ^X          : MoveCursor(Ch);
  255.       ^I          : TabOver(X,Y);
  256.       ^G          : Delchar;
  257.       #127        : BEGIN
  258.                       MoveCursor(^H);
  259.                       Delchar;
  260.                     END;
  261.       ^N          : {Code to insert a line}
  262.                     BEGIN
  263.                       Move(Screen[Y,1],Screen[Succ(Y),1],
  264.                         (Right-Pred(Left)) * (Bottom - Y));
  265.                       FillChar(Screen[Y,1],Right - Pred(Left),' ');
  266.                       GotoXY(1,Bottom);DelLine;
  267.                       GotoXY(1,Y);InsLine;
  268.                     END;
  269.       ^Y          : {Code to delete a line}
  270.                     BEGIN
  271.                       If Y < Bottom then
  272.                         Move(Screen[Succ(Y),1],Screen[Y,1],
  273.                            (Right - Pred(Left)) * (Bottom - Y));
  274.                       FillChar(Screen[Bottom,1],Right - Pred(Left),' ');
  275.                       DelLine;
  276.                       GotoXY(1,Bottom);InsLine;
  277.                       GotoXY(X,Y);
  278.                     END;
  279.       ^V          : BEGIN
  280.                       Ins := Not Ins;
  281.                       GotoXY(70,2);
  282.                       If Ins then
  283.                         Write('INSERT') else
  284.                         Clreol;
  285.                       GotoXY(X,Y);
  286.                     END;
  287.        ^C         : BEGIN
  288.                       GotoXY(1,23);Clreol;
  289.                       Write('Sure you want to stop now (Y/N)?');
  290.                       REPEAT
  291.                         Read(Kbd,Done);
  292.                         Done := UpCase(Done);
  293.                         If Not (Done in ['Y','N']) then Write(^G);
  294.                       UNTIL (Done in ['Y','N']);
  295.                       GotoXY(1,23);Clreol;
  296.                       If Done = 'N' then GotoXY(X,Y);
  297.                     END;
  298.        ^F         : GetScreen(Screen);
  299.     END;{Case}
  300.   UNTIL Done = 'Y';
  301. END;
  302.  
  303.   { FormStrings concatenates the various characters entered    }
  304.   { under Mkscreen into strings -- either strings of solid     }
  305.   { underscores (data entry blanks) -- or prompt strings.      }
  306.  
  307. PROCEDURE FormStrings(Screen:FullScreen);
  308.   TYPE
  309.     Action = (Skip,Tag,Blank);
  310.   VAR
  311.     Y    : Top..Bottom;
  312.     X,X1 : Left..Right;
  313.     I,J : Integer;
  314.     S : String[80];
  315.     Mode : Action;
  316.     Spaces : Integer;
  317.  
  318.     { Terminate stops the string formation process when a      }
  319.     { string is completed, and reinitializes the process of    }
  320.     { formation for the next string                            }
  321.  
  322.     PROCEDURE Terminate(Var Stg : Str80);
  323.       BEGIN
  324.         Case Mode of
  325.           Tag : BEGIN
  326.                   REPEAT
  327.                     If Stg[Length(Stg)] = ' ' then
  328.                       Delete(Stg,Length(Stg),1);
  329.                   UNTIL (Stg[Length(Stg)] <> ' ') or (Length(Stg) = 0);
  330.                   I := Succ(I);
  331.                   With FieldTag[I] do
  332.                   BEGIN
  333.                     XBegin := X1;
  334.                     YBegin := Y;
  335.                     Contents := Stg;
  336.                   END;
  337.                 END;
  338.           Blank : BEGIN
  339.                     J := Succ(J);
  340.                     With FieldBlank[J] do
  341.                     BEGIN
  342.                       XBegin := X1;
  343.                       YBegin := Y;
  344.                       Contents := Stg;
  345.                     END;
  346.                   END;
  347.         END; {Case}
  348.         Stg := '';
  349.         X1 := X;
  350.       END;{Terminate}
  351.  
  352. BEGIN {Formstrings}
  353.   I := 0; J := 0;
  354.   For Y := Top to Bottom Do
  355.   BEGIN
  356.     S := '';
  357.     Spaces := 0;
  358.     Mode := Skip;
  359.     For X := Left to Right Do
  360.     BEGIN
  361.       CASE Mode Of
  362.         Skip : If Screen[Y,X] <> ' ' then
  363.                BEGIN
  364.                  If Screen[Y,X] = '_' then
  365.                    Mode := Blank else
  366.                    Mode := Tag;
  367.                  S := S + Screen[Y,X];
  368.                  X1 := X;
  369.                END;
  370.         Tag : BEGIN
  371.                 If Screen[Y,X] = ' ' then
  372.                 BEGIN
  373.                   Spaces := Succ(Spaces);
  374.                   If Spaces > 2 then
  375.                   BEGIN
  376.                     Terminate(S);
  377.                     Mode := Skip;
  378.                   END else
  379.                     S := S + Screen[Y,X];
  380.                 END else
  381.  
  382.                 If Screen[Y,X] = '_' then
  383.                 BEGIN
  384.                   Spaces := 0;
  385.                   Terminate(S);
  386.                   S := '_';
  387.                   Mode := Blank;
  388.                 END else
  389.                 BEGIN
  390.                   S := S + Screen[Y,X];
  391.                   Spaces := 0;
  392.                   If Screen[Y,X] = #39 then
  393.                     S := S + #39;
  394.                 END;
  395.               END;
  396.         Blank:   If Screen[Y,X] = '_' then
  397.                    S := S + '_'  else
  398.                    BEGIN
  399.                      Terminate(S);
  400.                      If Screen[Y,X] <> ' ' then
  401.                      BEGIN
  402.                        S := S + Screen[Y,X];
  403.                        Mode := Tag;
  404.                      END else
  405.                      Mode := Skip;
  406.                    END;
  407.         END;{case}
  408.       END;{For X}
  409.       If Mode <> Skip then Terminate(S);
  410.     END;{FOR Y}
  411.   NoOfTags := I;
  412.   NoOfBlanks := J;
  413. END;{FormStrings}
  414.  
  415. { WriteFiles writes two files                                     }
  416. { 1> a Turbo-Pascal source code Procedure file with type '.PAS'   }
  417. {    containing the following:                                    }
  418. {    'Outform' - a procedure which will put the prompts that have }
  419. {    been input onto the screen in their proper places.         }
  420. {    'ClearForm' - a procedure that will clear any characters   }
  421. {    from the screen in the  places which you have designated   }
  422. {    (by '_') as  data-entry places.  Use the ClearForm         }
  423. {    coordinates as the starting locations for your input       }
  424. {    routines.                                                  }
  425. {    The 'Main Program which is simply to test Outform -  once  }
  426. {    tested, you'll want to throw it away.                      }
  427. { 2> A screen File for later access by screendo with Type '.SCR'}
  428.  
  429. PROCEDURE WriteFiles;
  430. Const
  431.   S2 = '  ';
  432.   S4 = '    ';
  433.   S6 = '      ';
  434.   G = 'GotoXY(';
  435.   W = 'Write(''';
  436. Var
  437.   I : Integer;
  438.  
  439. BEGIN
  440.   GotoXY(1,23);Clreol;
  441.   Write('Enter File Name:  ');
  442.   Readln(FileName);
  443.   Assign(PasFile,FileName + '.PAS');
  444.   ReWrite(PasFile);
  445.   Writeln(PasFile,'PROCEDURE OutForm;');
  446.   Writeln(PasFile,'BEGIN');
  447.   For I := 1 to NoOfTags do With FieldTag[I] do
  448.   BEGIN
  449.     Write(PasFile,S2,G,XBegin,',',YBegin,'); ');
  450.     Writeln(PasFile,W,Contents,''');');
  451.   END;
  452.   Writeln(PasFile,'END;');
  453.   Writeln(PasFile);
  454.   Writeln(PasFile,'PROCEDURE ClearForm;');
  455.   Writeln(PasFile,'BEGIN');
  456.   For I := 1 to NoOfBlanks do With FieldBlank[I] do
  457.   BEGIN
  458.     Write(PasFile,S2,G,XBegin,',',YBegin,'); ');
  459.     Writeln(PasFile,W,'''',':',Length(Contents),');');
  460.   END;
  461.   Writeln(PasFile,'END;');
  462.   Writeln(PasFile);
  463.   Writeln(PasFile,'BEGIN');
  464.   Writeln(PasFile,S2,'ClrScr;');
  465.   Writeln(PasFile,S2,'OutForm;');
  466.   Writeln(PasFile,'END.');
  467.   Close(PasFile);
  468.   Assign(ScrFile,FileName + '.SCR');
  469.   ReWrite(ScrFile);
  470.   Write(ScrFile,Screen);
  471.   Close(ScrFile);
  472. END;
  473.  
  474. BEGIN
  475.   FillChar(FileName,SizeOf(FileName),0);
  476.   FillChar(Screen,SizeOf(Screen),' ');
  477.   FillChar(FieldTag,SizeOf(FieldTag),0);
  478.   FillChar(FieldBlank,SizeOf(FieldBlank),0);
  479.   MkScreen(Screen);
  480.   FormStrings(Screen);
  481.   WriteFiles;
  482. END.
  483.