perm filename PNYACT.SAI[PNY,SYS]1 blob
sn#131785 filedate 1974-11-26 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00013 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 BEGIN "PONYSY"
C00006 00003 EXTERNAL PROCEDURE SPOOL(STRING S INTEGER IOCHAN,FLAGS)
C00011 00004 PROCEDURE BILL(INTEGER MAX)
C00013 00005 PROCEDURE MERGE BEGIN "MERG"
C00019 00006 ENTER(OUCH2,MON&".BIL[P,PAW]",FLAG)
C00022 00007 WHILE LENGTH(LIN) > 0 ∨ NME < BMAX DO BEGIN "MAIN"
C00025 00008 IF SUMN ≠ 0 THEN BEGIN "WRITE_BILL"
C00033 00009 OUT(OUCH2,↓)
C00037 00010 outstr("sorting"&↓)
C00039 00011 BEGIN "HEAPSORT"
C00041 00012 CLOSE(OUCH)
C00044 00013 In case you were wondering, as I was, where this starts, you've found it
C00055 ENDMK
C⊗;
BEGIN "PONYSY"
REQUIRE "PHONEY.SAI[1,LES]" SOURCE_FILE;
PRELOAD_WITH "January","February","March","April","May","June",
"July","August","September","October","November","December";
STRING ARRAY BMONTH[1:12];
PRELOAD_WITH "JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP",
"OCT","NOV","DEC";
STRING ARRAY MONTH[1:12];
DEFINE ↓ = "'15&'12",
FF = "'14",
TAB = "'11",
INTTY = "1",
LIM = "10",
TTYUUO = "'051000000000",
TOP = "300",
VMICONO = "'736600000000",
CALLI = "'47000000000";
LABEL START, RETRY0, RETRY, STOP;
INTEGER ARRAY REC,PPN,KEY[1:TOP],CDE,AMOUNT[1:LIM],CHARGF[0:5],DOOR[1:10];
STRING ARRAY NAME[1:TOP];
STRING S, MON, GOODS, AMT, S1, S2, SFOO, MONOLD;
INTEGER I, CNT, BRK, EOF, A, B, INCH, OUCH, C, PASS, DAY, N, FLAG, LIMIT,
NUM, N1, ID, K, NUMT, ZZ, KK, BN, ADR, LNGTH, D;
EXTERNAL PROCEDURE SPOOL(STRING S; INTEGER IOCHAN,FLAGS);
SIMPLE PROCEDURE LOSE(STRING FILE);
BEGIN
OUTSTR("CANNOT OPEN FILE "&FILE);
CALL(0,"EXIT");
END;
STRING PROCEDURE CENTS(INTEGER P);
BEGIN STRING S;
IF P = 0 THEN RETURN("0");
S ← IF P < 0 THEN "-" ELSE "";
P ← ABS P;
IF P ≥ 100 THEN S ← S&CVS(P%100);
P ← P MOD 100;
RETURN(S&"."&("0"+P%10)&("0"+P MOD 10));
END;
SIMPLE PROCEDURE DATE;
BEGIN INTEGER D;
D ← CALL(0,"DATE");
DAY ← 32;
D ← (D ← D DIV 31) MOD 12 +1;
IF D = 1 THEN D ← 12
ELSE D ← D-1;
MON ← MONTH[D];
IF D = 1 THEN D ← 12
ELSE D ← D-1;
MONOLD ← MONTH[D];
END;
STRING PROCEDURE LEFT(INTEGER L; STRING Z);
BEGIN STRING BLANKS;
BLANKS ← " ";
RETURN(IF LENGTH(Z) < L THEN Z&BLANKS[1 TO L-LENGTH(Z)] ELSE Z[1 TO L]);
END;
STRING PROCEDURE RIGHT(INTEGER L; STRING Z);
BEGIN STRING BLANKS;
BLANKS ← " ";
RETURN(IF LENGTH(Z) < L THEN BLANKS[1 TO L-LENGTH(Z)]&Z ELSE Z[1 TO L]);
END;
STRING PROCEDURE CENTER(INTEGER L; STRING Z);
BEGIN STRING BLANKS;
BLANKS ← " ";
RETURN(IF LENGTH(Z) < L THEN BLANKS[1 TO (L-LENGTH(Z))DIV 2]&
Z & BLANKS[1 TO (L-LENGTH(Z)+1)DIV 2] ELSE Z[1 TO L]);
END;
STRING PROCEDURE ERROR(INTEGER E);
BEGIN
IF 0<E<8 THEN CASE E OF BEGIN
[1] OUT(INTTY,"YOU ARE NOT ON OUR USER LIST. PLEASE SEE THE FRONT OFFICE"&↓&
"TO GET YOUR NAME ADDED TO THE USER LIST."&↓&↓);
[2] OUT(INTTY,"WRONG CODE ON ITEM "&GOODS&↓&
"ALLOWABLE CODES ARE M,C,D,B,V,S,T AND P "&↓&
"RETYPE CODES AND AMOUNTS = ");
[3] OUT(INTTY,"TYPOGRAPHICAL ERROR IN ITEM "&CDE[ZZ]&AMT&↓&
"RETYPE CODES AND AMOUNTS = ");
[4] OUT(INTTY,"ERROR IN ITEM "&CDE[ZZ]&AMT&↓&
"AMOUNT IS NOT IN NICKEL INCREMENTS. AMOUNT MUST BE IN "&↓&
"5 CENT INCREMENTS."&↓&
"CORRECT CODE AND AMOUNT = ");
[5] OUT(INTTY,"ERROR IN ITEM "&CDE[ZZ]&AMT&↓&
"AMOUNT MUST BE A MULTIPLE OF THE PRICE OF THE GOODS INDICATED."&↓&
"CORRECT CODE AND AMOUNT = ");
[6] OUT(INTTY,"ERROR IN ITEM "&CDE[ZZ]&AMT&↓&
"DONUTS SELL FOR 20 CENTS."&↓&
"CORRECT CODE AND AMOUNT = ");
[7] OUT(INTTY,"ERROR IN ITEM "&CDE[ZZ]&AMT&↓&
"PRICE DOES NOT MATCH ANY VENDING MACHINE PRICE."&↓&
"CORRECT CODE AND AMOUNT = ")
END;
IF 3<E<8 THEN BEGIN
GOODS ← INPUT(INTTY,1);
OUT(INTTY,↓);
ZZ ← ZZ -1;
IF LENGTH(GOODS) THEN GO TO RETRY;
END;
IF 1<E<4 THEN BEGIN
S ← INPUT(INTTY,1);
OUT(INTTY,↓);
IF LENGTH(S) THEN GO TO RETRY0;
END;
GO TO START;
END;
PROCEDURE BILL(INTEGER MAX);
BEGIN INTEGER ARRAY CHARGES[1:MAX],BILLS[1:TOP+1,0:12];
INTEGER SWAP, II, NME, NME1, OUCH1, INCH1, OUCH2, BMAX, OUCH3, OUCH4;
INTEGER PROCEDURE ADDEM; BEGIN
INTEGER AMT;
COMMENT READ CODE AND DETERMINE ARRAY INDEX;
B ← IF (K ←CVXSTR(CHARGES[II←II+1] LAND '777777000000)) = "C" THEN 1
ELSE IF K = "D" THEN 2
ELSE IF K = "B" THEN 3
ELSE IF K = "S" THEN 4
ELSE IF K = "V" THEN 5
ELSE IF K = "A" THEN 5
ELSE IF K = "M" THEN 6
ELSE IF K = "X" THEN 7
ELSE IF K = "P" THEN 8
ELSE IF K = "R" THEN 9
ELSE 10;
COMMENT ACCUMULATE CHARGES;
AMT ← 0;
AMT ← (CHARGES[II] LSH 18) DIV 2↑18;
IF AMT < 0 THEN OUT(OUCH3,CVXSTR(BILLS[A,0])&" "&CVXSTR(CHARGES[II] LAND '777777000000)&CVS(AMT)&↓);
BILLS[A,B] ← BILLS[A,B] + AMT;
IF BILLS[A,B] < 0 THEN OUT(OUCH3,"TOTAL "&CVXSTR(BILLS[A,0])&" "&K&CVS(BILLS[A,B])&↓);
END;
SIMPLE PROCEDURE FAILURE(STRING SF); BEGIN
OUTSTR(SF&" MISSING"&↓); CALL(0,"EXIT");
END;
PROCEDURE MERGE; BEGIN "MERG"
LABEL BILL1, BILL2;
STRING LIN,PN,PNAME,LINEOUT, INTSTR, U;
REAL INTEREST, DIVIDEND, REPAY;
INTEGER SHARES, DIVBAL, SUMO, PRABO, PRAB, SUMINT,REDT,
SAUNO, SAUN, XERBO, XERB,VELBO, VELB,SUMN, PURBRK, PRAINT,
SHARETOT, DIVBALTOT, DIVNT, PRABOT, SAUNOT, XERBOT, VELBOT,
SUMOT, TOBUF, PRABN, SAUNN, XERBN, VELBN, SAUINT,SUMNT, PRABNT,
DIVIT, DIVID, REPT, SAUNNT, SHARET, DIVBALT, XERBNT, XERINT, VELINT,
VELBNT, END_FLAG, END_ARRY,cond1_flag;
STRING PROCEDURE DATE1;
BEGIN INTEGER J;
J ← CALL(0,"DATE");
RETURN(CVS(J MOD 31 +1)&" "&BMONTH[(J←J DIV 31)MOD 12 +1]&
" "&CVS(J DIV 12 + 1964));
END;
INTEGER PROCEDURE MONEY(REFERENCE STRING S); BEGIN
INTEGER I,J,N;
N ← 1;
IF I←S = "-" THEN BEGIN
N ← -1;
I ← LOP(S);
END;
I ← SCAN(S,6,BRK);
I ← CVD(SCAN(S,4,BRK));
IF BRK ≠ "." THEN J ← 0 ELSE BEGIN
J ← LOP(S);
J ← CVD(SCAN(S,4,BRK));
END;
RETURN(N*(100*I + (IF I ≥ 0 THEN J ELSE -J)));
END;
STRING PROCEDURE OUT1; BEGIN
STRING S;
S ← PN&"/"&PNAME;
IF LENGTH(S) ≤ 24 THEN S ← S&TAB;
IF SHARES ≠ 0 ∨ DIVBAL ≠ 0 THEN
S ← S&"["¢s(shares)&tab¢s(divbal)&"]";
IF SUMNT ≠ 0 THEN S ← S&TAB&"("&(IF PRABO ≠ 0 ∨ PRAB ≠ 0 THEN
CENTS(PRABO + PRAB)&"P"&" " ELSE NULL)&(IF SAUNN ≠ 0 THEN
CENTS(SAUNN)&"S"&" " ELSE NULL)&(IF XERBO ≠ 0 ∨ XERB ≠ 0 THEN
CENTS(XERBO + XERB)&"X"&" " ELSE NULL)&(IF VELBO ≠ 0 ∨ VELB ≠ 0 THEN
CENTS(VELBO + VELB)&"V"&" " ELSE NULL)&CENTS(SUMNT)&"T)";
RETURN(S);
END;
STRING PROCEDURE OUT2; BEGIN
STRING S;
S ← LEFT(3,CVXSTR(BILLS[NME,0]))&"/"&PNAME;
IF LENGTH(S) ≤ 24 THEN S ← S&TAB;
IF SUMNT > 0 THEN
S ← S&"("&(IF PRAB ≠ 0 THEN CENTS(PRAB)&"P"&TAB ELSE NULL)&
(IF SAUNN ≠ 0 THEN CENTS(SAUNN)&"S"&TAB ELSE NULL)&
(IF XERB ≠ 0 THEN CENTS(XERB)&"X"&TAB ELSE NULL)&
(IF VELB ≠ 0 THEN CENTS(VELB)&"V"&TAB ELSE NULL)&
CENTS(SUMNT)&"T)";
RETURN(S);
END;
STRING PROCEDURE FIND_NAME(INTEGER II); BEGIN
STRING S;
FOR A ← 1 STEP 1 UNTIL I DO
IF II = PPN[A] THEN DONE;
IF A > I THEN S ← (IF LENGTH(PNAME) THEN PNAME ELSE CVXSTR(II)) ELSE
S ← NAME[A];
RETURN(S);
END;
SIMPLE PROCEDURE PAST_DUE; BEGIN
PNAME ← SCAN(LIN,16,BRK);
COMMENT SCAN FOR SHARES AND DIVIDEND BALANCES;
IF "[" = BRK ∨ "{" = BRK THEN
BEGIN
PURBRK ← BRK;
U ← SCAN(LIN,16,BRK);
IF "]" ≠ BRK ≠ "}" THEN FAILURE(PNAME&"-]- OR -}-");
SHARETOT ← SHARETOT + (SHARES ← MONEY(U)); COMMENT TOTAL SHARES;
DIVBALTOT ← DIVBALTOT + (DIVBAL ← MONEY(U)); COMMENT TOTAL DIVIDENDS;
DIVBAL ← DIVBAL + (II←(SHARES*DIVIDEND+5000)%10000);
DIVNT ← DIVNT + II;
U ← SCAN(LIN,16,BRK);
END;
IF BRK = "(" THEN BEGIN
U ← SCAN(LIN,16,BRK);
IF BRK ≠ ")" THEN FAILURE(PNAME&"-)-");
LIN ← SCAN(LIN,7,BRK); COMMENT SCAN FOR A * INDICATING PAID BILL;
IF BRK ≠ "*" THEN BEGIN
LIN ← U;
WHILE LENGTH(LIN) > 0 DO BEGIN
U ← SCAN(LIN,8,BRK);
IF BRK = "P" THEN PRABOT ← PRABOT + (PRABO ← MONEY(U))
ELSE IF BRK = "S" THEN SAUNOT ← SAUNOT + (SAUNO ← MONEY(U))
ELSE IF BRK = "X" THEN XERBOT ← XERBOT + (XERBO ← MONEY(U))
ELSE IF BRK = "V" THEN VELBOT ← VELBOT + (VELBO ← MONEY(U))
ELSE IF BRK = "T" THEN SUMOT ← SUMOT + (SUMO ← MONEY(U))
ELSE FAILURE(PNAME&"-PSXVT-");
END;
END;
END;
END;
SIMPLE PROCEDURE COND1; BEGIN
PAST_DUE;
PNAME ← FIND_NAME(II← CVSIX(PN));
COND1_FLAG ← 1;
SUMN ← SUMO;
END;
SIMPLE PROCEDURE COND2; BEGIN
PRAB ← BILLS[NME,10];
SAUN ← BILLS[NME,8];
XERB ← BILLS[NME,7];
VELB ← BILLS[NME,9];
SUMN ← PRAB + SAUN + XERB +VELB;
PNAME ← "";
PNAME ← FIND_NAME(BILLS[NME,0]);
END;
ENTER(OUCH2,MON&".BIL[P,PAW]",FLAG);
IF FLAG THEN LOSE(MON&".BIL[P,PAW]");
LOOKUP(INCH1,MONOLD&".BIL[P,PAW]",FLAG);
IF FLAG THEN LOSE(MONOLD&".BIL[P,PAW]");
ENTER(OUCH1,"BILL.LST[P,PAW]",FLAG);
IF FLAG THEN LOSE("BILL.LST[P,PAW]");
SETBREAK(6,'15&'12&'40&'11&'14,NULL,"XNR");
SETBREAK(7,"*",NULL,"INS");
SETBREAK(8,"PSXVT",NULL,"INS");
SETBREAK(16,"/()[]{}",NULL,"INS");
SETBREAK(13,FF,NULL,"INS");
SETBREAK(14,"%",'11&" " ,"INS");
SETFORMAT(0,0);
COND1_FLAG ← END_ARRY ← 0;
NME ← 0;
COMMENT READ TV DIRECTORY;
LIN ← INPUT(INCH1,1);
IF EQU(LIN[1 TO 9],"COMMENT ⊗") THEN
DO INPUT(INCH1,13) UNTIL BRK=FF;
COMMENT READ IN INTEREST;
LINEOUT ← LIN ← INPUT(INCH1,1);
IF EQU(LIN[1 TO 8],"INTEREST") THEN BEGIN
OUT(OUCH2,LINEOUT&↓);
intstr ← scan(lineout,5,brk);
intstr ← lineout;
INTEREST ← REALSCAN(LIN,BRK)*100;
END
ELSE FAILURE("INTEREST");
COMMENT READ IN DIVIDEND;
LINEOUT ← LIN ← INPUT(INCH1,1);
IF EQU(LIN[1 TO 8],"DIVIDEND") THEN BEGIN
OUT(OUCH2,LINEOUT&↓);
DIVIDEND ← REALSCAN(LIN,BRK)*100;
END
ELSE FAILURE("DIVIDEND");;
COMMENT READ IN REPAY;
LINEOUT ← LIN ← INPUT(INCH1,1);
IF EQU(LIN[1 TO 5],"REPAY") THEN BEGIN
OUT(OUCH2,LINEOUT&↓);
REPAY ← REALSCAN(LIN,BRK)*100;
END
ELSE FAILURE("REPAY");
COMMENT SET TOTALS TO ZERO;
SHARETOT←DIVBALTOT←DIVNT←PRABOT←SAUNOT←REPT←SUMNT←XERBOT←VELBOT←SUMINT←
SUMOT←SAUNNT←SHARET←DIVBALT←XERBNT←VELBNT←PRABNT←praint←xerint←velint←sauint←divit←0;
NME ← NME +1;
COMMENT READ TO FIRST LINE OF DATA;
DO OUT(OUCH2,(LIN←INPUT(INCH1,1))&↓) UNTIL LENGTH(LIN) = 0;
LIN ← INPUT(INCH1,1); COMMENT READ FIRST DATA LINE;
END_FLAG ← 1;
IF LENGTH(LIN) THEN END_FLAG ← 0;
WHILE LENGTH(LIN) > 0 ∨ NME < BMAX DO BEGIN "MAIN"
PN ← LEFT(3,SCAN(LIN,16,BRK)); COMMENT READ PPN;
IF BRK ≠ "/" THEN FAILURE(PN&"-/-");
COMMENT MERGE WITH CHARGES FILE;
COMMENT IF PN > BILLS[NME,0] AND NME = BMAX THHE END OF NEW CHARGE FILE HAS BEEN
REACHED AND WE CAN WRITE OUT PAST DUE CHARGES;
BILL1:
COMMENT SET COUNTERS TO ZERO;
SHARES←DIVBAL←PRAB←SAUN←XERB←VELB←SUMN←PRABN←SAUNN←SUMNT←
XERBN←VELBN←DIVID←SUMO←PRABO←SAUNO←XERBO←VELBO←0;
IF NME > BMAX THEN BEGIN END_ARRY ← 1; NME ← BMAX; END;
IF CVSIX(PN) > BILLS[NME,0] ∧ END_ARRY = 1 THEN COND1 ELSE
COMMENT IF PN < BILLS[NME,0] AND LENGTH OF LIN IS ZERO THEN THE END OF PAST
DUE FILE HAS BEEN REACHED AND WE CAN WRITE OUT CURRENT CHARGES;
IF CVSIX(PN) < BILLS[NME,0] ∧ END_FLAG = 1 THEN COND2 ELSE
COMMENT IF PN < BILLS[NME,0] AND THE END OF NEW CHARGE FILE HAS NOT BEEN
REACHED THEN THERE ARE NO NEW CHARGES AND WE CAN WRITE OUT PSAT DUE CHARGES;
IF CVSIX(PN) < BILLS[NME,0] THEN COND1 ELSE
COMMENT IF PN = BILLS[NME,0] THEN MERGE FILES;
IF CVSIX(PN) = BILLS[NME,0] THEN BEGIN
PRAB ← BILLS[NME,10];
SAUN ← BILLS[NME,8];
XERB ← BILLS[NME,7];
VELB ← BILLS[NME,9];
SUMN ← PRAB + SAUN + XERB + VELB;
PAST_DUE;
PNAME ← FIND_NAME(BILLS[NME,0]);
COND1_FLAG ← 1;
SUMN ← SUMN + SUMO;
END ELSE
COMMENT IF PN IS GREATER THAN BILL[NME,0] THEN THERE IS NO OLD FILE FOR BILL[NME,0]
AND WE CAN WRITE OUT HIS CHARGES AND RETURN TO BILL1;
IF CVSIX(PN) > BILLS[NME,0] THEN COND2;
COMMENT collect totals write new file and bills;
IF SUMN ≠ 0 THEN BEGIN "WRITE_BILL"
OUT(OUCH1,FF&"Pony Bill of"&CENTER(37,PNAME)&RIGHT(18,DATE1)&↓&↓);
IF PRABO ∨ PRAB THEN BEGIN "PRANCING"
IF PRABO THEN OUT(OUCH4,PNAME&" "&CENTS(PRABO)&" "&CENTS(PRABOT)&↓);
OUT(OUCH1,"Prancing Pony"&↓);
IF PRABO > 0 ∧
INTEREST THEN BEGIN
A ← (PRABO*INTEREST+5000)%10000;
PRABO ← PRABO + A; PRAINT ← PRAINT + A;
OUT(OUCH1,(if a ≥ 1 then "Past Due: "¢s(prabo - a)&" + interest of "&
cents(a)&" at "&intstr&" = "¢s(prabo)
ELSE IF PRABO > 0 THEN "Past Due: "&CENTS(PRABO)
ELSE IF PRABO < 0 THEN "Credit: "&CENTS(PRABO)
ELSE null)&↓);
end;
IF PRAB THEN
OUT(OUCH1,"Charges:"&↓&(if bills[nme,1] then TAB&TAB&"Coffee "&
RIGHT(6,CENTS(BILLS[NME,1]))&↓ ELSE null)&(if bills[nme,2] then TAB&tab&"Donuts "&
RIGHT(6,CENTS(BILLS[NME,2]))&↓ ELSE NULL)&(IF BILLS[NME,3] THEN TAB&TAB&"Bagels "&
RIGHT(6,CENTS(BILLS[NME,3]))&↓ else null)&(if bills[nme,4] then TAB&tab&"Snacks "&
RIGHT(6,CENTS(BILLS[NME,4]))&↓ else null)&(if bills[nme,5] then TAB&tab&"V/M "&
RIGHT(6,CENTS(BILLS[NME,5]))&↓ ELSE NULL)&(IF BILLS[NME,6] THEN TAB&TAB&"Money "&
RIGHT(6,CENTS(bills[nme,6])) else null)&↓);
OUT(OUCH1,TAB&CENTS(prabn ← PRABO+PRAB)&" TOTAL"&↓&↓);
PRABNT ← PRABNT + PRABN;
END "PRANCING";
IF SAUNO ∨ SAUN THEN BEGIN "SAUNA"
OUT(OUCH1,↓&"Sauna"&↓);
IF SAUNO > 0 ∧
INTEREST THEN BEGIN
A ← (SAUNO*INTEREST+5000)%10000;
SAUNO ← SAUNO + A; SAUINT ← SAUINT + A;
OUT(OUCH1,(if a ≥ 1 then "Past Due: "&CENTS(SAUNO - a)&" + interest of "
¢S(A)&" at "&INTSTR&" = "&CENTS(SAUNO)
ELSE "Past Due: "&CENTS(SAUNO))&↓);
end;
IF SAUN THEN
OUT(OUCH1,"Charges: "&CENTS(SAUN)&↓);
SAUNN ← SAUNO + SAUN;
IF SAUNN ∧ DIVBAL THEN BEGIN
DIVIT ← DIVIT + (DIVID ← DIVBAL MIN SAUNN);
DIVBAL ← DIVBAL -DIVID; SAUNN ← SAUNN -DIVID;
OUT(OUCH1,"Less Dividend: "&CENTS(-DIVID)&↓&"Dividend Balance: "&CENTS(DIVBAL)&↓);
END;
IF REPAY ∧ SHARES THEN BEGIN
REPT ← REPT + (II ←(SHARES*REPAY+5000)%10000);
SHARES ← SHARES - II; SAUNN ← SAUNN -II;
OUT(OUCH1,"Repayment: "&-ii&"("&cvs(repay%100)&"% of share balance)"&↓);
END;
IF SAUNN > 0 ∧ PURBRK = "{" THEN BEGIN "REDUCE"
SHARES ← SHARES - (II←SHARES MIN SAUNN);
SAUNN ← SAUNN - II; REDT ← REDT + II;
OUT(OUCH1,"Reduction: "&-ii&"(Share Balance: "¢s(shares)&")"&↓);
end "REDUCE";
SAUNNT ← SAUNNT + SAUNN;
if shares then
out(ouch1,"Share Balance: "¢s(shares)&↓);
OUT(OUCH1,TAB&CENTS(SAUNN)&" TOTAL"&↓);
END "SAUNA";
IF XERB ∨ XERBO THEN BEGIN "XEROX"
OUT(OUCH1,↓&"Xerox"&↓);
IF XERBO > 0 ∧
INTEREST THEN BEGIN
A ← (XERBO*INTEREST+5000)%10000;
XERBO ←XERBO +A; XERINT ← XERINT + A;
OUT(OUCH1,(if a ≥ 1 then "Past Due: "&CENTS(XERBO - a)&" + interest of "
&CENTS(A)&" at "&INTSTR&" = "&CENTS(XERBO)
ELSE "Past Due: "&CENTS(XERBO))&↓);
end;
IF XERB THEN
OUT(OUCH1,"Charges: "&CENTS(XERB)&↓);
XERBNT ←XERBNT + (XERBN ← XERBO+XERB);
OUT(OUCH1,TAB&CENTS(XERBN)&" TOTAL"&↓);
END "XEROX";
IF VELB ∨ VELBO THEN BEGIN "VELO-BIND"
OUT(OUCH1,↓&"Velo-Bind"&↓);
IF VELBO > 0 ∧
INTEREST THEN BEGIN
A ← (VELBO*INTEREST+5000)%10000;
VELBO ← VELBO + A; VELINT ← VELINT + A;
OUT(OUCH1,(if a ≥ 1 then "Past Due: "&CENTS(VELBO - a)&" + interest of "
&CENTS(A)&" at "&INTSTR&" = "&CENTS(VELBO)
ELSE "Past Due: "&CENTS(VELBO))&↓);
end;
IF VELB THEN
OUT(OUCH1,"Charges: "&CENTS(VELB)&↓);
VELBNT ← VELBNT +(VELBN ← VELBO + VELB);
OUT(OUCH1,TAB&CENTS(VELBN)&" TOTAL"&↓);
END "VELO-BIND";
IF PRABN ∨ SAUNN ∨ XERBN ∨ VELBN THEN
OUT(OUCH1,↓&TAB&CENTS(SUMNT ← PRABN+SAUNN+XERBN+VELBN)&" GRAND TOTAL"&↓);
END "WRITE_BILL";
IF COND1_FLAG = 1 THEN BEGIN
LINEOUT ← OUT1;
COND1_FLAG ← 0;
END ELSE
LINEOUT ← OUT2;
OUT(OUCH2,LINEOUT&↓); COMMENT WRITE OUTPUT FILE;
OUTSTR(LINEOUT&↓);
SHARET ← SHARET + SHARES;
DIVBALT ← DIVBALT + DIVBAL;
IF CVSIX(PN) > BILLS[NME,0] ∧ END_ARRY = 1 THEN BEGIN
LIN ← INPUT(INCH1,1);
IF LENGTH(LIN) = 0 THEN END_FLAG ← 1;
END ELSE
IF CVSIX(PN) < BILLS[NME,0] ∧ END_FLAG = 1 THEN BEGIN
NME ← NME +1;
IF NME ≤ BMAX THEN GO TO BILL1;
END ELSE
IF CVSIX(PN) < BILLS[NME,0] THEN BEGIN
LIN ← INPUT(INCH1,1);
IF LENGTH(LIN) = 0 THEN END_FLAG ← 1;
END ELSE
IF CVSIX(PN) = BILLS[NME,0] THEN BEGIN
NME← NME+1;
LIN ← INPUT(INCH1,1);
IF LENGTH(LIN) = 0 THEN END_FLAG ← 1;
END ELSE
IF CVSIX(PN) > BILLS[NME,0] THEN BEGIN
NME ← NME +1;
GO TO BILL1;
END;
IF END_FLAG = 1 ∧ NME < BMAX THEN GO TO BILL1;
END "MAIN";
SUMINT ← PRAINT + SAUINT + XERINT + VELINT;
OUT(OUCH2,↓);
OUT(OUCH2,"PAST DUE TOTALS - "&↓&TAB&
"Prancing pony: "¢s(prabot)&" Interest: "&CENTS(PRAINT)&" Total: "¢s(prabot+praint)&↓&TAB&
"Sauna: "¢s(saunot)&" Interest: "¢s(sauint)&" Total: "¢s(saunot+sauint)&↓&tab&
"Xerox: "¢s(xerbot)&" Interest: "¢s(xerint)&" Total: "¢s(xerbot+xerint)&↓&tab&
"Velo-Bind: "¢s(velbot)&" Interest: "¢s(velint)&" Total: "¢s(velbot+velint)&↓&tab&
"TOTAL PAST DUE: "&CENTS(SUMOT)&" Interest: "¢s(sumint)&" Total: "¢s(sumot+sumint)&↓);
out(ouch2,"Share Totals - "&↓&
tab&"Old Share Totals: "¢s(sharetot)&" "&"New Share Totals: "¢s(sharet)&↓&
tab&"Old Dividend Balances: "¢s(divbaltot)&" "&"New Dividends Paid: "¢s(divnt)&↓&
tab&"Dividend Reductions: "¢s(-divit)&↓&
(IF REDT THEN TAB&"Repayments Total: "¢s(-redt)&↓ else null)&
tab&"TOTAL DIVIDENDS: "&CENTS(DIVBALT)&↓);
Out(ouch2,"New Charges Totals - "&↓&tab&
"Prancing Pony: "¢s(prabnt-prabot-PRAINT)&↓&tab&
"Sauna: "¢s(saunnt-saunot-SAUINT+DIVIT)&↓&tab&
"Dividends Paid: "¢s(-divit)&↓&tab&
"Xerox: "¢s(xerbnt-xerbot-XERINT)&↓&tab&
"Velo-Bind: "¢s(velbnt-velbot-VELINT)&↓&tab&
"Total New Charges: "¢s(prabnt+saunnt+xerbnt+velbnt-sumot-sumint)&↓);
out(ouch2,"Total Due - "&↓&tab&
"Prancing Pony: "¢s(prabnt)&" "&"Sauna: "¢s(saunnt)&↓&tab&
"Xerox: "¢s(xerbnt)&" "&"Velo-Bind: "¢s(velbnt)&↓&tab&
"TOTAL DUE: "&CENTS(prabnt+saunnt+xerbnt+velbnt)&↓);
CLOSE(OUCH2); CLOSE(OUCH1); CLOSE(OUCH3); CLOSE(INCH1); CLOSE(OUCH4);
END "MERG";
OPEN(INCH1←GETCHAN,"DSK",1,4,0,CNT←200,BRK,EOF);
OPEN(OUCH1←GETCHAN,"DSK",1,0,4,0,0,0);
OPEN(OUCH2←GETCHAN,"DSK",1,0,4,0,0,0);
OPEN(OUCH3←GETCHAN,"DSK",1,0,4,0,0,0);
OPEN(OUCH4←GETCHAN,"DSK",1,0,4,0,0,0);
ENTER(OUCH4,MON&".OLD[P,PAW]",FLAG);
IF FLAG THEN LOSE(MON&".OLD[P,PAW]");
ENTER(OUCH3,MON&".NEG[P,PAW]",FLAG);
IF FLAG THEN LOSE("CHARGE.NEG[P,PAW]");
LOOKUP(OUCH,MON&".PNY[PNY,SYS]",FLAG);
IF ¬FLAG THEN ARRYIN(OUCH,CHARGES[1],MAX+1)
ELSE OUT(INTTY,"CANNOT ENTER FILE "&MON&".PNY[PNY,SYS]. MAX = "&CVS(MAX));
SWAP ← 1;
outstr("sorting"&↓);
BEGIN "HEAPSORT"
INTEGER I,J,K,X,Y,Q,N;
DEFINE A="CHARGES";
N ← MAX/2;
COMMENT PHASE ONE, PUT 'EM UNDER THE HEAP & BIGGIES TRICKLE UP;
FOR K←2 STEP 1 UNTIL N DO
BEGIN
I←K;
X←A[2*K-1];
Y←A[2*K];
WHILE I>1 ∧ X>A[2*(J←I%2)-1] DO
BEGIN A[2*I-1]←A[2*J-1];A[2*I]←A[2*J];I←J END;
A[2*I-1]←X;
A[2*I]←Y;
END;
COMMENT PHASE TWO, TAKE 'EM OFF THE TOP & PROMOTE SUBORDINATES;
FOR K←N STEP -1 UNTIL 2 DO
BEGIN
X←A[2*K-1];Y←A[2*K];
A[2*K-1]←A[1];A[2*K]←A[2];
I←1;
WHILE (J←2*I)<K DO
BEGIN
IF A[2*(J+1)-1]>A[2*J-1] ∧ (J+1)<K THEN J←J+1;
IF X≥A[2*J-1] THEN DONE ELSE
BEGIN A[2*I-1]←A[2*J-1];A[2*I]←A[2*J];I←J;END;
END;
A[2*I-1]←X;
A[2*I]←Y;
END;
END "HEAPSORT";
CLOSE(OUCH);
A←0; II←0;
COMMENT READ AND STORE FIRST NAME;
BILLS[A←A+1,0] ← NME ← CHARGES[II←II+1] LAND '777777000000;
ADDEM;
COMMENT CLANK THROUGH FILE AND ACCUMULATE CHARGES UNTIL NEW NAME IS FOUND;
outstr("accumulate charges"&↓);
WHILE II < MAX-1 DO BEGIN
NME1 ← CHARGES[II←II+1] LAND '777777000000;
IF NME = NME1 THEN ADDEM ELSE BEGIN
COMMENT CHARGE $3.00 MAXIMUM FOR COFFEE;
IF BILLS[A,1] > 300 THEN BILLS[A,1] ← 300;
COMMENT ACCUMULATE PONY CHARGES;
FOR B ← 1 STEP 1 UNTIL 6 DO
BILLS[A,10] ← BILLS[A,10] + BILLS[A,B];
NME ← NME1;
BILLS[A←A+1,0] ← NME;
ADDEM;
END;
END;
IF BILLS[A,1] > 300 THEN BILLS[A,1] ← 300;
FOR B ← 1 STEP 1 UNTIL 6 DO
BILLS[A,10] ← BILLS[A,10] + BILLS[A,B];
ENTER(OUCH1,MON&".ACT[P,PAW]",FLAG);
IF ¬FLAG THEN BEGIN
BMAX ← A;
FOR NME ← 1 STEP 1 UNTIL A DO BEGIN
OUT(OUCH1,CVXSTR(BILLS[NME,0]));
FOR NME1 ←1 STEP 1 UNTIL 10 DO BEGIN
OUT(OUCH1," "&CVS(BILLS[NME,NME1]));
BILLS[A+1,NME1] ← BILLS[A+1,NME1] + BILLS[NME,NME1];
END;
OUT(OUCH1,↓);
END;
OUT(OUCH1,"TOTAL ");
FOR NME1 ← 1 STEP 1 UNTIL 10 DO
OUT(OUCH1," "&CVS(BILLS[A+1,NME1]));
CLOSE(OUCH1);
END;
MERGE;
RELEASE(INCH1); RELEASE(OUCH1); RELEASE(OUCH2); RELEASE(OUCH3); RELEASE(OUCH4);
GO TO STOP;
END;
COMMENT In case you were wondering, as I was, where this starts, you've found it;
DATE;
C ← 0;
Comment INIT the TTY we're using. 400 bit means don't wait for it;
OPEN(INTTY,"TTY",'401,1,1,CNT←200,BRK,EOF);
IF EOF THEN GO TO STOP; Comment in case open failed;
OPEN(INCH←GETCHAN,"DSK",'10,4,4,CNT←200,BRK,EOF);
IF EOF THEN BEGIN
OUT(INTTY,"CANNOT OPEN INPUT DISK FILE");
GO TO STOP;
END;
OPEN(OUCH←GETCHAN,"DSK",'17,0,0,CNT←200,BRK,EOF);
IF EOF THEN BEGIN
OUT(INTTY,"CANNOT OPEN OUTPUT DISK FILE");
GO TO STOP;
END;
SETBREAK(1,'12,'15,"INS");
SETBREAK(2," ,",NULL,"INS");
SETBREAK(3,"0123456789+-.",NULL,"INS");
SETBREAK(4,"0123456789+-","","XNR");
SETBREAK(5,"0123456789+-.",NULL,"INR");
SETBREAK(18,".",NULL,"INS");
SETBREAK(17,"0123456789",NULL,"XNR");
SETFORMAT(8,6);
I ← 0;
PPN[I←1] ← CVSIX("SYS");
WHILE READ ∧ (I < TOP) DO BEGIN
PPN[I←I+1] ← CVSIX(LEFT(3,PROG));
NAME[I] ← FRIENDLY&" "&LAST;
END;
IF I ≥ TOP THEN OUT(INTTY,"MAXIMUM NUMBER OF USERS IN SYSTEM. PROGRAM"&↓&
"REQUIRES ALTERATION TO ALLOW MORE USER'S."&↓&
"(TOP CURRENTLY = "&CVS(TOP)&") PLEASE NOTIFY"&↓&
"FRONT OFFICE");
OUT(INTTY,"CODES: X = XEROX, P = SAUNA, R = VELO-BIND"&↓&
"ALL CODES AND AMOUNTS MUST BE ENTERED IN UPPER CASE LETTERS"&↓&
"AFTER ALL CHARGES HAVE BEEN ENTERED TYPE `RUN' IN RESPONSE TO `NEXT!'"&↓&↓);
START:
GOODS←S ← ""; ID ← 0;
OUT(INTTY,↓&"NEXT! ");
S ← INPUT(INTTY,1);
IF EQU(S,"RUN") ∨ EQU(S,"run") THEN BEGIN
IF LIMIT ≤ 0 THEN BEGIN
LOOKUP(OUCH,MON&".PNY[PNY,SYS]",FLAG);
IF ¬FLAG THEN BEGIN
FILEINFO(CHARGF);
LIMIT ← -(CHARGF[3] ROT 18);
END
ELSE GO TO STOP;
CLOSE(OUCH);
END;
BILL(LIMIT);
END;
IF LENGTH(S)=0 THEN GO TO START; Comment flush null commands;
ID ← CVSIX(LEFT(3,SCAN(S,2,BRK)));
FOR A ← 1 STEP 1 UNTIL I DO
IF ID = PPN[A] LAND ('777777000000) THEN DONE;
IF A > I THEN BEGIN
OUT(INTTY,"PPN DOES NOT APPEAR IN A.I. DIRECTORY."&↓&
"TYPE `Y' IF IT IS CORRECT ELSE CR.");
SFOO←INCHWL; IF SFOO = "Y" ∨ SFOO = "y" THEN NAME[I] ← CVXSTR(PPN[I])
ELSE GO TO START;
END;
RETRY0:
ZZ ← 0;
WHILE LENGTH(S) DO BEGIN
GOODS ← SCAN(S,2,BRK);
RETRY:
IF(K←GOODS) = "V" ∨
K = "A" ∨
K = "R" ∨
K = "M" ∨
K = "P" ∨
K = "C" ∨
K = "X" ∨
K = "D" ∨
K = "S" ∨
K = "B" THEN BEGIN
CDE[ZZ←ZZ+1] ← LOP(GOODS);
AMT ← GOODS;
NUM ← 0;
N1 ← 1;
IF GOODS = "-" THEN N1 ← -1;
IF GOODS = "+" ∨ GOODS = "-" THEN K ← LOP(GOODS)
ELSE IF GOODS = "$" THEN K ← LOP(GOODS);
S1 ← SCAN(GOODS,18,BRK); COMMENT SCAN TO A DECIMAL;
IF BRK = 0 THEN BEGIN
S1 ← SCAN(S1,17,NUM);
IF NUM = 0 THEN NUM ← CVD(S1)
ELSE ERROR(3);
IF NUM < 4 THEN NUM ← NUM*100;
END
ELSE IF LENGTH(S1) THEN BEGIN
S1 ← SCAN(S1,17,NUM);
IF NUM = 0 THEN NUM ← CVD(S1)*100
ELSE ERROR(3);
END;
IF BRK = "." THEN BEGIN
IF LENGTH(GOODS) > 2 THEN ERROR(3);
GOODS ← GOODS&"00";
S2 ← GOODS[1 FOR 2];
S2 ← SCAN(S2,17,BRK); COMMENT SCAN FOR NUMERIC VALUES ONLY;
IF BRK = 0 THEN NUM ← NUM+CVD(S2)
ELSE ERROR(3);
END;
IF (K←CDE[ZZ]) = "S" ∧ NUM < 15
THEN ERROR(5);
IF K = "B" ∧ (NUM < 15 ∨ NUM MOD 15)
THEN ERROR(5);
IF K = "C" ∧ (NUM < 10 ∨ NUM MOD 10) THEN ERROR(5);
IF K = "D" ∧ NUM < 20 THEN ERROR(6);
AMOUNT[ZZ] ← NUM*N1;
END
ELSE ERROR(2);
END;
BN←1; LNGTH←0;
LOOKUP(OUCH,MON&".PNY[PNY,SYS]",FLAG);
IF ¬FLAG THEN BEGIN
FILEINFO(CHARGF);
LNGTH ← -(CHARGF[3] ROT 18);
LIMIT ← LNGTH;
OUT(INTTY,CVS(LIMIT)&↓);
BN ← (LNGTH%128)+1;
LNGTH ← LNGTH MOD 128;
IF LNGTH>0 THEN BEGIN
USETI(OUCH,BN);
ARRYIN(OUCH,REC[1],LNGTH);
END;
Comment Avoid CLOSE(OUCH) because we need to get into r/a mode;
END;
ENTER(OUCH,MON&".PNY[PNY,SYS]",FLAG);
IF FLAG THEN BEGIN
OUT(INTTY,"CANNOT ENTER FILE "&MON&".PNY[PNY,SYS]. PLEASE NOTIFY THE FRONT"&↓&
"OFFICE OF THIS. YOU WILL BE UNABLE TO USE THE TTY TO ENTER"&↓&
"CHARGES. SORRY");
GO TO STOP;
END;
FOR K ← 1 STEP 1 UNTIL ZZ DO BEGIN
IF AMOUNT[K] ≠ 0 THEN BEGIN
REC[LNGTH←LNGTH+1] ← ID LOR DAY;
REC[LNGTH←LNGTH+1] ← CVSIX(CDE[K]) LOR (AMOUNT[K] LAND '777777);
END;
END;
USETO(OUCH,BN);
ARRYOUT(OUCH,REC[1],LNGTH);
CLOSE(OUCH); Comment Release accounting file;
FOR K ← 1 STEP 1 UNTIL ZZ DO AMOUNT[K] ← 0;
GO TO START;
STOP:
RELEASE(INTTY);
RELEASE(INCH);
RELEASE(OUCH);
SPOOL(MON&".BIL[P,PAW]",GETCHAN,0);
SPOOL(MONOLD&".BIL[P,PAW]",GETCHAN,0);
SPOOL(MON&".NEG[P,PAW]",GETCHAN,0);
SPOOL(MON&".ACT[P,PAW]",GETCHAN,0);
OUTSTR("DO YOU WANT TO SPOOL THE INDIVIDUAL BILLS? ");
IF K←INCHWL = "Y" THEN
PTOSTR(0,"XSP BILL.LST/PMAR=0/DEL"&↓);
END;