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 / LANGUAGS / PASCAL / INVENT.PQS / INVENT.PAS
Pascal/Delphi Source File  |  2000-06-30  |  14KB  |  484 lines
  1. {            INVENTORY PROGRAM FOR
  2.                 TURBO PASCAL
  3.                 WRITTEN BY CHARLES STEWART
  4.                                                }
  5.  
  6. PROGRAM INVENT;
  7. TYPE
  8.    ITEM=(A,E,T,F,J,M,X); { X IS FOR DELETED FILE FLAG}
  9.    INVRECORD=RECORD
  10.              ID:STRING[6];
  11.              INVTYPE:ITEM;
  12.              DESCRIPTION:STRING[20];
  13.              COST:STRING[6];
  14.    END;
  15.  
  16.    RINV= ARRAY[1..100] OF INVRECORD;
  17.  
  18. VAR
  19.    FNAME:STRING[12];
  20.    SELECTION:CHAR;
  21.    RIDNUMBER:STRING[6];
  22.    RTYPE:ITEM;
  23.    RDESCRIPTION:STRING[20];
  24.    RCOST:STRING[6];
  25.    RINVRECORD:INVRECORD;
  26.    INFILE, OUTFILE : FILE OF INVRECORD;
  27.    RESPONSE:STRING[30];
  28.    ALLDONE:BOOLEAN;
  29.    TEMP:INVRECORD;
  30.    TOTAL:REAL;
  31.    AMT:REAL;
  32.    CODE:INTEGER;
  33.    INVENTORY:RINV;
  34.  
  35. PROCEDURE STALL;
  36. BEGIN
  37.   WRITELN;
  38.   WRITELN('PRESS RETURN TO CONTINUE ');
  39.   WRITELN;
  40.   READLN;
  41. END; {STALL}
  42.  
  43. PROCEDURE DELETE(VAR R:RINV);
  44. VAR CODE, I:INTEGER;
  45.     ALLDONE:BOOLEAN;
  46.     RE:INTEGER;
  47.     CLASS:CHAR;
  48.     PP,PG:INTEGER;
  49.     RCLASS:ITEM;
  50. BEGIN
  51.    ALLDONE := FALSE;
  52.    CLRSCR;
  53.    PP := 0;
  54.    PG := 20;
  55.    ASSIGN(OUTFILE,FNAME);
  56.    RESET(OUTFILE);
  57.    I:=0;
  58.    CLRSCR;
  59.       REPEAT
  60.       IF PP < PG THEN
  61.        BEGIN
  62.         READ (OUTFILE,RINVRECORD);
  63.         WITH RINVRECORD DO
  64.         BEGIN
  65.            WRITE(I:3,' ');
  66.            WRITE(ID:8);
  67.            WRITE(DESCRIPTION:22);
  68.            WRITE(COST:8);
  69.            IF INVTYPE = X THEN WRITE('----DELETED---');
  70.            WRITELN;
  71.            PP := PP + 1;
  72.            I:=I+1;
  73.  
  74.          END;
  75.        END
  76.       ELSE
  77.        BEGIN
  78.          WRITE(' PRESS RETURN FOR NEXT PAGE');
  79.          PP := 0;
  80.          READLN;
  81.          CLRSCR;
  82.        END;
  83.    UNTIL EOF(OUTFILE);
  84.    WRITELN;
  85.    I:= I - 1;
  86.    WRITELN('DELETE WHICH ITEM ');
  87.    READLN(RE);
  88.      IF RE > I THEN
  89.         BEGIN
  90.            WRITELN('ERROR',^G,' THAT ITEM DOES NOT EXIST');
  91.            STALL;
  92.         END
  93.      ELSE
  94.         BEGIN
  95.            SEEK(OUTFILE,0); {REWIND THE POINTER TO 0 POS IN FILE}
  96.            SEEK(OUTFILE,RE);
  97.            RINVRECORD.INVTYPE := X; {DELETE FILE CODE}
  98.            WRITE(OUTFILE,RINVRECORD);
  99.         END;
  100. CLOSE(OUTFILE);
  101. END;{DELETE}
  102.  
  103. PROCEDURE CHANGE(VAR R:RINV);
  104. VAR CODE, I:INTEGER;
  105.     ALLDONE:BOOLEAN;
  106.     PP,PG:INTEGER;
  107.     CLASS:CHAR;
  108.     RE:INTEGER;
  109.     RCLASS:ITEM;
  110. BEGIN
  111.    ALLDONE := FALSE;
  112.    CLRSCR;
  113.    ASSIGN(OUTFILE,FNAME);
  114.    RESET(OUTFILE);
  115.    I:=0;
  116.    CLRSCR;
  117.       PP:= 0; PG := 20;
  118.       REPEAT
  119.       IF PP < PG THEN
  120.        BEGIN
  121.         READ (OUTFILE,RINVRECORD);
  122.         WITH RINVRECORD DO
  123.          BEGIN
  124.            WRITE(I:3,' ');
  125.            WRITE(ID:8);
  126.            WRITE(DESCRIPTION:22);
  127.            WRITE(COST:8);
  128.            IF INVTYPE = X THEN WRITE ('------DELETED-------');
  129.            WRITELN;
  130.            I:=I+1;
  131.            PP := PP +1;
  132.          END;
  133.        END
  134.       ELSE
  135.         BEGIN
  136.            WRITE('PRESS RETURN FOR NEXT PAGE');
  137.            PP :=0;
  138.            READLN;
  139.            CLRSCR;
  140.         END;
  141.    UNTIL EOF(OUTFILE);
  142.    WRITELN;
  143.    I:= I - 1;
  144.    WRITELN('CHANGE WHICH ITEM ');
  145.    READLN(RE);
  146.    IF RE > I THEN
  147.         BEGIN
  148.                  WRITELN('ERROR NO SUCH RECORD',^G);
  149.                  STALL;
  150.         END
  151.    ELSE
  152.         BEGIN
  153.                SEEK(OUTFILE,0); {REWIND THE POINTER TO 0 POS IN FILE}
  154.                SEEK(OUTFILE,RE);
  155.                    WRITELN('PURCHASE DATE AS YYMMDD');
  156.                        READLN(RIDNUMBER);
  157.                        R[I].ID := RIDNUMBER;
  158.                        WRITELN('INVENTORY TYPE  A,E,T,F,J,M,? ');
  159.                        READLN(CLASS);
  160.                        IF CLASS <> '?' THEN
  161.                           BEGIN
  162.                                IF CLASS = 'A' THEN RCLASS := A
  163.                                   ELSE
  164.                                       IF CLASS = 'E' THEN RCLASS := E
  165.                                       ELSE
  166.                                       IF CLASS = 'T' THEN RCLASS := T
  167.                                       ELSE
  168.                                       IF CLASS = 'F' THEN RCLASS := F
  169.                                       ELSE
  170.                                       IF CLASS = 'J' THEN RCLASS := J
  171.                                       ELSE
  172.                                       RCLASS := M;
  173.                           END
  174.                       ELSE
  175.                           BEGIN
  176.                              CLRSCR;
  177.                              WRITELN('A- > APPLIANCE');
  178.                              WRITELN('E- > ELECTRONIC');
  179.                              WRITELN('T- > TOY');
  180.                              WRITELN('F- > FURNITURE');
  181.                              WRITELN('J- > JEWERY');
  182.                              WRITELN('M- > MISC. ');
  183.                              WRITELN('INVENTORY TYPE  A,E,T,F,J,M');
  184.                              READLN(CLASS);
  185.                           END;
  186.  
  187.      WRITELN('DESCRIPTION OF ITEM 20 CHARACTER MAXIMUM ');
  188.      WRITELN('-------------------* AS INDICATED BY THE ASTERISK');
  189.      READLN(RDESCRIPTION);
  190.      R[I].DESCRIPTION := RDESCRIPTION;
  191.      WRITELN(' ITEM COST TO NEAREST DOLLAR (NO DECIMALS)');
  192.      READLN(RCOST);
  193.      R[I].COST := RCOST;
  194.      WRITE(OUTFILE,R[I]);
  195.      CLOSE(OUTFILE);
  196. END;
  197. END;{CHANGE}
  198.  
  199. PROCEDURE SORT(VAR R:RINV);
  200. VAR J,I,INDEX:INTEGER;
  201. BEGIN
  202.    CLRSCR;
  203.    WRITELN('SORT ROUTINE OF THE INPUT DATA');
  204.    ASSIGN(INFILE,FNAME);
  205.    RESET(INFILE);
  206.    INDEX := 0;
  207.    WHILE NOT EOF(INFILE) DO
  208.       BEGIN
  209.         INDEX := INDEX + 1;
  210.         READ (INFILE,R[INDEX]);
  211.       END;
  212.    CLOSE(INFILE);
  213.    ASSIGN(OUTFILE,FNAME);
  214.    REWRITE(OUTFILE);
  215.    FOR I := 1 TO INDEX-1 DO
  216.        FOR J := I+1 TO INDEX DO
  217.            IF R[I].ID > R[J].ID
  218.                     THEN
  219.                          BEGIN  {SWAP EM}
  220.                            TEMP := R[I];
  221.                            R[I] := R[J];
  222.                            R[J] := TEMP;
  223.                          END;
  224.    FOR I:= 1 TO INDEX DO
  225.        WRITE(OUTFILE,R[I]);
  226.    WRITELN(' SORTED FILE WRITTEN TO DISK FILE ',FNAME);
  227.    CLOSE(OUTFILE);
  228.    STALL;
  229. END; {SORT ROUTINE}
  230. PROCEDURE TYPESORT(VAR R:RINV);
  231. VAR J,I,INDEX:INTEGER;
  232. BEGIN
  233.    CLRSCR;
  234.    WRITELN('SORT ROUTINE OF THE INPUT DATA');
  235.    RESET(INFILE);
  236.    INDEX := 0;
  237.    WHILE NOT EOF(INFILE) DO
  238.       BEGIN
  239.         INDEX := INDEX + 1;
  240.         READ (INFILE,R[INDEX]);
  241.       END;
  242.    CLOSE(INFILE);
  243.    ASSIGN(OUTFILE,FNAME);
  244.    REWRITE(OUTFILE);
  245.    FOR I := 1 TO INDEX-1 DO
  246.        FOR J := I+1 TO INDEX DO
  247.            IF R[I].INVTYPE > R[J].INVTYPE
  248.                     THEN
  249.                          BEGIN  {SWAP EM}
  250.                            TEMP := R[I];
  251.                            R[I] := R[J];
  252.                            R[J] := TEMP;
  253.                          END;
  254.    FOR I:= 1 TO INDEX DO
  255.        WRITE(OUTFILE,R[I]);
  256.    CLOSE(OUTFILE);
  257. END; {SORT ROUTINE}
  258.  
  259. PROCEDURE CREATE(VAR R:RINV);
  260. VAR CLASS:CHAR;
  261.    RCLASS:ITEM;
  262. BEGIN
  263.    ALLDONE:=FALSE;
  264.    ASSIGN(OUTFILE,FNAME);
  265.    REWRITE(OUTFILE);
  266.    WHILE NOT ALLDONE DO
  267.       BEGIN
  268.      WRITELN('PURCHASE DATE AS YYMMDD');
  269.      READLN(RIDNUMBER);
  270.      RINVRECORD.ID := RIDNUMBER;
  271.      WRITELN('INVENTORY TYPE  A,E,T,F,J,M,? ');
  272.      READLN(CLASS);
  273.      IF CLASS <> '?' THEN
  274.      BEGIN
  275.          IF CLASS = 'A' THEN RCLASS := A
  276.      ELSE
  277.         IF CLASS = 'E' THEN RCLASS := E
  278.         ELSE
  279.            IF CLASS = 'T' THEN RCLASS := T
  280.            ELSE
  281.               IF CLASS = 'F' THEN RCLASS := F
  282.               ELSE
  283.                  IF CLASS = 'J' THEN RCLASS := J
  284.                  ELSE
  285.                     RCLASS := M;
  286.     END
  287.     ELSE
  288.        BEGIN
  289.          CLRSCR;
  290.          WRITELN('A- > APPLIANCE');
  291.          WRITELN('E- > ELECTRONIC');
  292.          WRITELN('T- > TOY');
  293.          WRITELN('F- > FURNITURE');
  294.          WRITELN('J- > JEWERY');
  295.          WRITELN('M- > MISC. ');
  296.          WRITELN('INVENTORY TYPE  A,E,T,F,J,M,? ');
  297.          READLN(CLASS);
  298.        END;
  299.  
  300.      RINVRECORD.INVTYPE := RCLASS;
  301.      WRITELN('DESCRIPTION OF ITEM 20 CHARACTER MAXIMUM ');
  302.      WRITELN('-------------------* AS INDICATED BY THE ASTERISK');
  303.      READLN(RDESCRIPTION);
  304.      RINVRECORD.DESCRIPTION := RDESCRIPTION;
  305.      WRITELN(' ITEM COST TO NEAREST DOLLAR (NO DECIMALS)');
  306.      READLN(RCOST);
  307.      RINVRECORD.COST := RCOST;
  308.      WRITE(OUTFILE,RINVRECORD);
  309.      WRITELN(' IF YOU ARE DONE TYPE AN ASTERISK (*), OTHERWISE JUST HIT ENTER');
  310.      READLN (RESPONSE);
  311.      IF RESPONSE = '*' THEN ALLDONE := TRUE;
  312.    END; {WHILE ALLDONE LOOP}
  313.    CLOSE(OUTFILE);
  314.    SORT(INVENTORY);
  315. END; {CREATE}
  316.  
  317.  
  318. PROCEDURE MENU(VAR SELECTION:CHAR);
  319.    BEGIN
  320.        CLRSCR;
  321.        WRITELN('Inventory Management System':53);
  322.        WRITELN('by Charles A. Stewart':50);
  323.        WRITELN;
  324.        WRITELN('Copyright 1986 all rights reserved':56);
  325.        WRITELN;
  326.        WRITELN('Work file name ',fname);
  327.        WRITELN;
  328.        WRITELN(' A--> Create new inventory file');
  329.        WRITELN(' B--> Add items to inventory  ');
  330.        WRITELN(' C--> Change items in inventory');
  331.        WRITELN(' D--> Delete item in inventory');
  332.        WRITELN(' E--> Print the inventory to printer');
  333.        WRITELN(' F--> Assign file name ');
  334.        WRITELN(' G--> END PROGRAM');
  335.        WRITELN;
  336.        READLN (SELECTION);
  337.        IF SELECTION = 'F' THEN
  338.           BEGIN
  339.             WRITE('File name please ');
  340.             readln(fname);
  341.           END;
  342.    END;{MENU}
  343.  
  344. PROCEDURE ADD(VAR R:RINV);
  345. VAR I:INTEGER;
  346.     ALLDONE:BOOLEAN;
  347.      CLASS:CHAR;
  348.      RCLASS:ITEM;
  349. BEGIN
  350.    ALLDONE := FALSE;
  351.    CLRSCR;
  352.    ASSIGN(OUTFILE,FNAME);
  353.    RESET(OUTFILE);
  354.    SEEK(OUTFILE,FILESIZE(OUTFILE));
  355.    WHILE NOT ALLDONE DO
  356.       BEGIN
  357.      WRITELN('PURCHASE DATE AS YYMMDD');
  358.      READLN(RIDNUMBER);
  359.      RINVRECORD.ID := RIDNUMBER;
  360.      WRITELN('INVENTORY TYPE  A,E,T,F,J,M,? ');
  361.      READLN(CLASS);
  362.      IF CLASS <> '?' THEN
  363.      BEGIN
  364.          IF CLASS = 'A' THEN RCLASS := A
  365.      ELSE
  366.         IF CLASS = 'E' THEN RCLASS := E
  367.         ELSE
  368.            IF CLASS = 'T' THEN RCLASS := T
  369.            ELSE
  370.               IF CLASS = 'F' THEN RCLASS := F
  371.               ELSE
  372.                  IF CLASS = 'J' THEN RCLASS := J
  373.                  ELSE
  374.                     RCLASS := M;
  375.     END
  376.     ELSE
  377.        BEGIN
  378.          CLRSCR;
  379.          WRITELN('A- > APPLIANCE');
  380.          WRITELN('E- > ELECTRONIC');
  381.          WRITELN('T- > TOY');
  382.          WRITELN('F- > FURNITURE');
  383.          WRITELN('J- > JEWERY');
  384.          WRITELN('M- > MISC. ');
  385.          WRITELN('INVENTORY TYPE  A,E,T,F,J,M,? ');
  386.          READLN(CLASS);
  387.        END;
  388.  
  389.      RINVRECORD.INVTYPE := RCLASS;
  390.      WRITELN('DESCRIPTION OF ITEM 20 CHARACTER MAXIMUM ');
  391.      WRITELN('-------------------* AS INDICATED BY THE ASTERISK');
  392.      READLN(RDESCRIPTION);
  393.      RINVRECORD.DESCRIPTION := RDESCRIPTION;
  394.      WRITELN(' ITEM COST TO NEAREST DOLLAR (NO DECIMALS)');
  395.      READLN(RCOST);
  396.      RINVRECORD.COST := RCOST;
  397.      WRITE(OUTFILE,RINVRECORD);
  398.      WRITELN(' IF YOU ARE DONE TYPE AN ASTERISK (*), OTHERWISE JUST HIT ENTER');
  399.      READLN (RESPONSE);
  400.      IF RESPONSE = '*' THEN ALLDONE := TRUE;
  401.    END; {WHILE ALLDONE LOOP}
  402.    FLUSH(OUTFILE);
  403.    CLOSE(OUTFILE);
  404.    SORT(INVENTORY);
  405. END; {ADD}
  406.  
  407. PROCEDURE PRINT(VAR R:RINV);
  408. CONST PP=56;
  409. VAR PG:INTEGER;
  410. BEGIN
  411.    CLRSCR;
  412.    ASSIGN (INFILE,FNAME);
  413.    RESET(INFILE);
  414.    TYPESORT(INVENTORY);
  415.    WRITELN(LST,'Household Inventory');
  416.    WRITELN;
  417.    WRITELN(LST,'Copyright 1986 by Charles Stewart');
  418.    WRITELN(LST,'All Rights Reserved.');
  419.    WRITELN(LST);
  420.    ASSIGN(INFILE,FNAME);
  421.    RESET(INFILE);
  422.    TOTAL := 0;
  423.    WRITELN(LST,'DATE':8,'DESCRIPTION':22,'       COST':6,'        CLASS');
  424.    WRITELN(LST,'===============================================================');
  425.    Pg := 7;
  426.    REPEAT
  427.         READ (INFILE,RINVRECORD);
  428.         WITH RINVRECORD DO
  429.         BEGIN
  430.          IF Pg > PP THEN
  431.             BEGIN
  432.                 WRITELN(LST,^l); { FORM FEED }
  433.                 WRITELN(LST,'Household Inventory');
  434.                 WRITELN;
  435.                 WRITELN(LST,'Copyright 1986 by Charles Stewart');
  436.                 WRITELN(LST,'All Rights Reserved.');
  437.                 WRITELN(LST);
  438.                 WRITELN(LST,'DATE':8,'DESCRIPTION':22,'       COST':6,'        CLASS');
  439.                 WRITELN(LST,'===============================================================');
  440.                 Pg := 7;
  441.             END; {IF PP}
  442.          IF INVTYPE <> X THEN
  443.           BEGIN
  444.            VAL (COST,AMT,CODE);
  445.            TOTAL := TOTAL + AMT;
  446.            Pg := Pg + 1;
  447.            WRITE(LST,ID:8);
  448.            WRITE(LST,DESCRIPTION:22);
  449.            WRITE(LST,'  $');
  450.            WRITE(LST,COST:6);
  451.            WRITE(LST,'    ');
  452.            CASE INVTYPE OF
  453.            A: WRITE(LST,'APPLANCE');
  454.            E: WRITE(LST,'ELECTRONIC');
  455.            T: WRITE(LST,'TOY');
  456.            J: WRITE(LST,'JEWELRY');
  457.            F: WRITE(LST,'FURNITURE');
  458.            M: WRITE(LST,'MISC. ');
  459.            END; {CASE}
  460.           WRITELN(LST);
  461.           END;{WHILE}
  462.         END;
  463.    UNTIL EOF(INFILE);
  464.    CLOSE(INFILE);
  465.    WRITELN(LST);
  466.    WRITELN(LST,'===============================================================');
  467.    WRITELN(LST,'TOTAL ----------------> $',TOTAL:5:2);
  468. END;{PRINT}
  469.  
  470. BEGIN {MAIN PROGRAM}
  471.  FNAME :=('INVENT.DAT'); {DEFAULT FILE NAME}
  472.  REPEAT
  473.   MENU(SELECTION);
  474.   CASE SELECTION OF
  475.    'A': CREATE(INVENTORY);
  476.    'B': ADD(INVENTORY);
  477.    'D': DELETE(INVENTORY);
  478.    'C': CHANGE(INVENTORY);
  479.    'E': PRINT(INVENTORY);
  480.   END;{CASE}
  481.  UNTIL SELECTION > 'F';
  482. END. {PROGRAM}
  483.  
  484.