home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol019 / editfile.pas < prev    next >
Pascal/Delphi Source File  |  1984-04-29  |  9KB  |  353 lines
  1.  
  2. (*********************************************************
  3. *
  4. *        Donated by Ray Penley, June 1980
  5. *
  6. ********************************************************)
  7.  
  8.  
  9. {*  PROGRAM TITLE:    EDIT A LINEAR FILE
  10. **
  11. **  WRITTEN BY:         W.M. Yarnall
  12. **  DATE WRITTEN:       May 1980
  13. **
  14. **  WRITTEN FOR:    S100 Microsystems
  15. **            May/June 1980
  16. **
  17. **  SUMMARY:
  18. **        See the article in S100....
  19. **
  20. **  MODIFICATION RECORD:
  21. **    25 May 1980    -Modified for Pascal/Z by Raymond E. Penley
  22. **            -All files made local to Procedures.
  23. **             This insures that each file will be closed.
  24. **
  25. **
  26. **        ---NOTE---
  27. **
  28. ** The first logical record in Pascal/Z is No. 1, NOT record
  29. ** No. 0 as in PASCAL/M or UCSD PASCAL. This can be rectified
  30. ** very eaisly by adding a 'bias' to every record number.
  31. **        PASCAL/Z    bias = 1
  32. **        PASCAL/M    bias = 0
  33. **
  34. *}
  35. PROGRAM EDLINEAR;
  36. CONST
  37.   default = 80;       (* Default length for strings *)
  38.   FID_LENGTH = 14; (* MAXIMUM ALLOWED LENGTH FOR A FILE NAME *)
  39.   bias   =  1;       (* see comments above *)
  40.  
  41. TYPE
  42.   FREC = RECORD
  43.        CASE tag:integer of
  44.         0:  (NAME :STRING 6; N1, N2 :integer);
  45.         1:  (HEADER :STRING 64);
  46.         2:  (RNAME :STRING 6; RINDEX :integer; RHS :real);
  47.         4:  (CNAME :STRING 6; CINDEX :integer; OBJ :real);
  48.         6:  (R,S :integer; T :real);
  49.        99:  () {--end of file--}
  50.      END;
  51.  
  52.   FID        = STRING FID_LENGTH;
  53.   LINEAR    = FILE OF FREC;
  54.   STR0        = STRING 0;
  55.   STRING80  = STRING default;
  56.   STR255    = STRING 255;
  57.  
  58. VAR
  59.   OFIL,        (*---File Identifiers <FID>---*)
  60.   NFIL    : FID;
  61.   OBUFFER,       {buffer for OLD file}
  62.   NBUFFER       {buffer for NEW file}
  63.     : FREC;
  64.   editing,       {The state of editing the file}
  65.   valid,       {An answer must be valid to be accepted}
  66.   valid_build,       {All aspects of a "build" have been completed}
  67.   XEOF           {End_Of_File flag for a NON TEXT file}
  68.     : boolean;
  69.   bell,           {console bell}
  70.   Command       {Command answer}
  71.     : char;
  72.  
  73. PROCEDURE KEYIN(VAR X: char); EXTERNAL;
  74. (* Direct keyboard entry of a single char *)
  75.  
  76.     (*----Required for Pascal/Z functions----*)
  77. FUNCTION  LENGTH( X :STR255) :INTEGER; EXTERNAL;
  78. PROCEDURE SETLENGTH(VAR X :STR0; Y :INTEGER); EXTERNAL;
  79.  
  80. Function INREC : integer;
  81. {
  82. GLOBAL
  83.     valid_build : boolean }
  84. LABEL    10;
  85. VAR    Alfa : STRING 10;
  86.     j :integer;
  87.     valid : boolean;
  88. begin
  89.   Write(' Enter TAG .......... ');
  90.   REPEAT
  91.     READLN(j);
  92.     valid := false;
  93.     IF j>99 then
  94.       begin
  95.     j := 200;
  96.     {exit} goto 10
  97.       end;
  98.     If  (j=0) or (j=1) or (j=2) or
  99.     (j=4) or (j=6) or (j=99) then
  100.       begin{If valid}
  101.         valid := true;
  102.     NBUFFER.tag := j ;
  103.     WITH NBUFFER DO
  104.       CASE TAG OF
  105.       0:    begin
  106.         SETLENGTH(NAME,0);
  107.         write(' Program Name........ ');
  108.         READLN(ALFA);
  109.         If Length(ALFA)>6 then SETLENGTH(ALFA,6);
  110.         APPEND(NAME,ALFA);
  111.         write(' No. ROWS............ ');
  112.         READLN(N1);
  113.         write(' No. Columns......... ');
  114.         READLN(N2)
  115.         end;
  116.       1:    begin
  117.         write(' Header.............. ');
  118.         READLN(header)
  119.         end;
  120.       2:    begin
  121.         write(' ROW Name............ ');
  122.         READLN(RNAME);
  123.         write(' ROW No. ............ ');
  124.         READLN(RINDEX);
  125.         write(' RHS ................ ');
  126.         READLN(RHS)
  127.         end;
  128.       4:    begin
  129.         write(' Column Name ........ ');
  130.         READLN(CNAME);
  131.         write(' Column No. ......... ');
  132.         READLN(CINDEX);
  133.         write(' OBJ ................ ');
  134.         READLN(OBJ)
  135.         end;
  136.       6:    begin
  137.         write(' ROW NO. ............ ');
  138.         READLN(R);
  139.         write(' Column No. ......... ');
  140.         READLN(S);
  141.         write(' ABAR[R,S] .......... ');
  142.         READLN(T)
  143.         end;
  144.       99:   valid_build := true
  145.       End{With/CASE}
  146.       end{If valid}
  147.     Else
  148.       Write('INVALID TAG, Reenter ---> ')
  149.   UNTIL valid{TAG};
  150. 10: INREC := j
  151. End{of INREC};
  152.  
  153. Procedure PRINT( This_one: FREC; Rcd: INTEGER);
  154. begin
  155.   writeln;
  156.   writeln(' REC', Rcd:4, ' TAG:', This_one.tag:5);
  157.   With This_one do
  158.     CASE TAG of
  159.     0:    begin
  160.         writeln(' NAME: ', name);
  161.         writeln(' No ROWS: ', N1);
  162.         writeln(' No COLS: ', N2)
  163.           end;
  164.     1:    begin
  165.         writeln(' HEADING:');
  166.         writeln(header)
  167.           end;
  168.     2:    begin
  169.         writeln(' ROW: ', RNAME);
  170.         writeln(' INDEX: ', RINDEX);
  171.         writeln(' RHS: ', RHS)
  172.           end;
  173.     4:    begin
  174.         writeln(' COL: ', CNAME);
  175.         writeln(' INDEX: ', CINDEX);
  176.         Writeln(' OBJ: ', OBJ)
  177.           end;
  178.     6:    Writeln(' ABAR[', R:3, ',', S:3, ']: ', T);
  179.     99:    Writeln(' --- End of File ---')
  180.     End{of With/CASE};
  181.   writeln
  182. End{of PRINT};
  183.  
  184. PROCEDURE GETID( VAR ID: FID; Message: STRING80 );
  185. {-Pascal/Z does not like file names that are
  186.   not space filled to user specified length-}
  187. CONST    SPACE = ' ';
  188. begin
  189.   SETLENGTH(ID,0);
  190.   writeln;
  191.   write(message);
  192.   READLN(ID);
  193.   While Length(ID) < FID_length Do APPEND(ID,SPACE)
  194. end;
  195.  
  196. Procedure BUILD;
  197. VAR    FX : LINEAR;
  198.      N : INTEGER;
  199. begin
  200.   GETID(NFIL,' Build what File? ');
  201.   REWRITE(NFIL, FX);      (*---REWRITE( <FID> , <FCB> )---*)
  202.   valid_build := false;
  203.   N := 0;
  204.   While (N < 100) DO
  205.     begin
  206.     N := INREC;
  207.     If (N<100) then
  208.        Write(FX, NBUFFER);
  209.     If (N=99) AND valid_build then{finished}
  210.       N:=200
  211.     Else
  212.       If (N>99) AND (not valid_build) then
  213.         begin
  214.         writeln('You MUST enter a TAG record of 99');
  215.         N := 0
  216.         end
  217.     end{while}
  218. End{of build};{ CLOSE(FX) }
  219.  
  220. Procedure LIST;
  221. LABEL    2 {File not found};
  222. VAR    REC : integer;
  223.     fa  : LINEAR; (*---File descriptor <FCB>---*)
  224. begin
  225.   GETID(OFIL,' List what File? ');
  226.   WRITELN;
  227.   RESET(OFIL, fa);     (*---RESET( <FID> , <FCB> )---*)
  228.   If EOF(fa) then
  229.     begin
  230.     writeln(bell,'File ',OFIL,'not found');
  231.     {exit}goto 2
  232.     end;
  233.   WRITELN;
  234.   WRITE(' Starting at what record? ');
  235.   READLN(REC);
  236.   writeln;
  237.   READ(fa:REC+BIAS, OBUFFER);
  238.   XEOF := (OBUFFER.TAG=99);
  239.   WHILE NOT XEOF do
  240.     begin
  241.       write( REC:5, ': ' );
  242.       With OBUFFER do begin
  243.     Write(TAG:3,' ');
  244.     CASE TAG of
  245.       0:    Writeln(Name:8, N1:7, N2:7);
  246.       1:    Writeln(HEADER);
  247.       2:    Writeln(RNAME:8, RINDEX:7, RHS:14:8);
  248.       4:    Writeln(CNAME:8, CINDEX:7, OBJ:14:8);
  249.       6:    Writeln('ROW', R:3, ' COL', S:3, T:14:8)
  250.       End{of Case}
  251.     End{With};
  252.       REC := REC + 1;
  253.       READ(fa:REC+BIAS,OBUFFER);
  254.       XEOF := (OBUFFER.TAG=99);
  255.     end{while};
  256. 2:    {file not found}
  257. End{of LIST};{ CLOSE(fa) }
  258.  
  259. Procedure MODIFY;
  260. LABEL    3 {File not found};
  261. VAR    OLDF,        (*---File descriptors <FCB>---*)
  262.     NEWF    : LINEAR;
  263.     REC, j : integer;
  264.     ans : char;
  265. begin
  266.   GETID(OFIL,' Modify what File? ');
  267.   RESET(OFIL, OLDF);     (*---RESET( <FID> , <FCB> )---*)
  268.   If EOF(OLDF) then
  269.     begin
  270.     writeln(bell,'File ',OFIL,'not found');
  271.     {exit}goto 3
  272.     end;
  273.   GETID(NFIL,' Name of New File? ');
  274.   {--------------------------------------------------------
  275.     WITH PASCAL/Z, THE ACT OF OPENING A NEW FILE
  276.     USING THE SAME <FCB> CLOSES THE PREVIOUS FILE
  277.     BEFORE OPENING THE NEW FILE.
  278.    --------------------------------------------------------}
  279.   REWRITE(NFIL,NEWF);     (*---REWRITE( <FID> , <FCB> )---*)
  280.   Write(' Starting at which Record? ');
  281.   READLN(J);
  282.   If J>0 then begin
  283.     {Copy previous records from the old file
  284.      starting at the first record up to but not
  285.      including the requested record.}
  286.       REC := 0;
  287.       REPEAT
  288.     READ(OLDF:REC+BIAS,OBUFFER); XEOF := (OBUFFER.TAG=99);
  289.     WRITE(NEWF, OBUFFER);
  290.     REC := REC + 1;
  291.       UNTIL XEOF OR (REC = J);
  292.     END;
  293.   REC := J;
  294.   READ(OLDF:REC+BIAS,OBUFFER);
  295.   XEOF := (OBUFFER.TAG=99);
  296.   While not XEOF do
  297.     begin
  298.     PRINT(OBUFFER,REC);
  299.     writeln(' Process this Record?');
  300.     REPEAT
  301.       valid := true;
  302.       write(' K(eep, C(hange, I(nsert, D(elete   >');
  303.       KEYIN(ANS);WRITELN(ANS);
  304.       CASE ans of
  305.     'K','k': begin
  306.          write(NEWF,OBUFFER);
  307.          REC := REC + 1
  308.          end;
  309.     'C','c': begin
  310.          If INREC<100 then write(NEWF, NBUFFER);
  311.          REC := REC + 1
  312.          end;
  313.     'D','d': REC := REC + 1;
  314.     'I','i': If INREC<100 then write(NEWF,NBUFFER);
  315.     ELSE:    begin
  316.          write(BELL);
  317.          valid := false
  318.          end
  319.       End{case};
  320.     UNTIL VALID{ANSWER};
  321.     READ(OLDF:REC+BIAS,OBUFFER);
  322.     XEOF := (OBUFFER.TAG=99);
  323.     End{while not XEOF};
  324. {---Write the End_Of_File record to the New file---}
  325.   Write(NEWF,OBUFFER);
  326. 3:    {file not found}
  327. End{of MODIFY};{CLOSE(OLDF);CLOSE(NEWF)}
  328.  
  329. BEGIN (*---Main Program---*)
  330.   BELL := CHR(7);
  331.   editing := true;
  332.  
  333.   WHILE editing do
  334.     begin{ EDIT session }
  335.       REPEAT
  336.     valid := true;
  337.     writeln;
  338.     write(' EDIT: L(ist, B(uild, M(odify, Q(uit ');
  339.     KEYIN(Command);WRITELN(Command);
  340.         CASE Command of
  341.       'L','l':    LIST;
  342.       'B','b':    BUILD;
  343.       'M','m':    MODIFY;
  344.       'Q','q':    editing := false
  345.       ELSE:        begin
  346.              write(BELL);
  347.              valid := false
  348.              end
  349.         End{case}
  350.     UNTIL valid{command}
  351.     end{ EDIT session }
  352. End{---of Edit Linear---}.
  353.