perm filename PONYSY.SAI[PNY,SYS]3 blob sn#115934 filedate 1974-08-22 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	BEGIN "PONYSY" 
C00005 00003	STRING PROCEDURE CENTS(INTEGER P)
C00010 00004	SIMPLE PROCEDURE NOECHO
C00014 00005	In case you were wondering, as I was, where this starts, you've found it
C00025 ENDMK
C⊗;
BEGIN "PONYSY" 

REQUIRE "PHONEY.SAI[1,LES]" SOURCE_FILE;
 
PRELOAD_WITH "JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP",
             "OCT","NOV","DEC";
STRING ARRAY MONTH[1:12];
 

DEFINE ↓ = "'15&'12",
   INTTY = "1",
     LIM = "10",
  TTYUUO = "'051000000000",
     TOP = "300",
 VMICONO = "'736600000000",
   CALLI = "'47000000000";

LABEL START, RETRY0, RETRY, STOP, AGAIN;

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;

INTEGER I, CNT, BRK, EOF, A, B, INCH, OUCH, C, PASS, DAY, N, FLAG,
        NUM, N1, ID, K, NUMT, ZZ, KK, BN, ADR, LNGTH, D, TRY, TOTAL_FLAG;
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;

PROCEDURE CHARGES(INTEGER NME); BEGIN
	INTEGER TAMT,ZOT,CMAX,I;
	INTEGER ARRAY TEMP[0:127];
	LNGTH ← TAMT ← 0;
	LOOKUP(OUCH,MON&".PNY[PNY,SYS]",FLAG);
	IF ¬FLAG THEN BEGIN
	    	FILEINFO(CHARGF);
	        LNGTH ← -(CHARGF[3] ROT 18);
		END;
	WHILE LNGTH>0 DO BEGIN
		ARRYIN(OUCH,TEMP[0],128);
		CMAX←(128 MIN LNGTH);
		LNGTH←LNGTH-128;
		FOR I←0 STEP 2 UNTIL CMAX-1 DO
			IF NME=TEMP[I] LAND '777777000000 THEN BEGIN
			ZOT ← TEMP[I+1];
				START_CODE;
				HRRE 1,ZOT;
				ADDM 1,TAMT;
				END;
			END;
		END;
	OUT(INTTY,"TOTAL CHARGES FOR THE MONTH = "&CENTS(TAMT)&↓);
	CLOSE(OUCH);
	END;

SIMPLE PROCEDURE DATE;
	BEGIN INTEGER D;
	D ← CALL(0,"DATE");
	DAY ← D MOD 31 + 1;
	MON ← MONTH[(D←D DIV 31) MOD 12 + 1];
	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;

INTEGER PROCEDURE PASSWD(STRING P);
	BEGIN INTEGER T;
	IF (T ← CVSIX(P)) THEN WHILE (T LAND '77) = 0 DO T ← T LSH -6;
	RETURN(T*T LAND '777777);             
	END;


STRING PROCEDURE ERROR(INTEGER E);
    BEGIN
	IF 0<E<8 THEN CASE E OF BEGIN
	[1] OUT(INTTY,"YOU ARE NOT AN AUTHORIZED USER."&↓&↓);
	[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;

SIMPLE PROCEDURE NOECHO;
		Comment Turn off echo;
		START_CODE;
		GETSTS INTTY,1;
		TRO 1,'600;
		SETSTS INTTY,(1);
		END;

SIMPLE PROCEDURE ECHO;
		Comment Turn on echo;
		START_CODE;
		GETSTS INTTY,1;
		TRZ 1,'600;
		SETSTS INTTY,(1);
		END;

PROCEDURE NEWPASS(INTEGER AA,MAX,NM);
	COMMENT AA IS PPN ARRAY PLACE, MAX IS MAX SIZE OF ARRAY, NM IS PPN;
	BEGIN INTEGER AP,LINCHR; LABEL SKIP;
	NOECHO;
	OUT(INTTY,"NEW PASSWORD = ");
	PASS ← PASSWD(INPUT(INTTY,1));                            
	ECHO;
	OUT(INTTY,↓);
	IF (PPN[AA] LAND '777777) THEN BEGIN        
		AP ← PPN[AA] LAND '777777;             
		KEY[AP] ← (NM LAND '777777000000) LOR PASS;
	END
	ELSE IF C < MAX THEN BEGIN                       
		KEY[C←C+1] ← (NM LAND '777777000000) LOR PASS;
		PPN[AA] ← PPN[AA] LOR C;
	END
	ELSE BEGIN OUT(INTTY,"PASSWORD FILE CONTAINS "&CVS(C)&
		       " ENTRIES. PLEASE NOTIFY THE FRONT OFFICE OF THIS."&↓&
		       "YOU WILL BE UNABLE TO ENTER A PASSWORD UNTIL THE PROGRAM IS CHANGED"&↓);
		GO TO SKIP;
	END;
	ENTER(INCH,"KEYWD[PNY,SYS]",FLAG);
	IF FLAG THEN BEGIN
		OUT(INTTY,"CANNOT ENTER FILE KEYWD[PNY,SYS]. PLEASE NOTIFY THE FRONT OFFICE"&↓&
        		  "OF THIS. YOU WILL BE UNABLE TO USE THE TELETYPE TO ENTER CHARGES. SORRY");
		GO TO STOP;
	END;
  	ARRYOUT(INCH,KEY[1],C);
	CLOSE(INCH);
SKIP:
END;


PROCEDURE FIXKEY; BEGIN
	IF (PPN[1] LAND '777777) ≤ 0 THEN NEWPASS(A,TOP,ID)
	ELSE BEGIN
	    OUT(INTTY,"PPN = ");
	    ID ← CVSIX(LEFT(3,INPUT(INTTY,1)));
	    OUT(INTTY,↓);
 	    FOR A ← 1 STEP 1 UNTIL C DO
	 	IF ID = KEY[A] LAND ('777777000000) THEN DONE;
		IF A > C THEN ERROR(1) 
		ELSE KEY[A] ← ID;
	END;
	GO TO START;
END;

PROCEDURE PRICE_DOOR; BEGIN
	OUT(INTTY,"NUMBER OF PRICE BAR TO BE SET = ");
	K ← CVD(INPUT(INTTY,1));
	WHILE 0<K<10 DO BEGIN
	    OUT(INTTY,"CURRENT PRICE = "&CVS(DOOR[K])&↓);
	    OUT(INTTY,"PRICE TO BE SET = ");
	    DOOR[K] ← CVD(INPUT(INTTY,1));  
	    OUT(INTTY,"NUMBER OF PRICE BAR TO BE SET = ");
	    K ← CVD(INPUT(INTTY,1));
	END;
	ENTER(INCH,"DOORP[PNY,SYS]",FLAG);
	    IF FLAG THEN BEGIN
	   	OUT(INTTY,"CANNOT ENTER FILE DOORP[PNY,SYS]."&↓&↓);
		GO TO START;
	    END;
	    ARRYOUT(INCH,DOOR[1],10);
	    CLOSE(INCH);
	OUT(INTTY,↓);
	GO TO START;
END;

COMMENT In case you were wondering, as I was, where this starts, you've found it;

DATE;
C ← 0;
START_CODE;
SETOM D;
TTYUUO 6,D;
END;

Comment If we're attached to a real console, ask if we want to talk to tty4;
IF D≠-1 THEN BEGIN 
	OUTSTR("Type Y to use TTY4, else use attached tty: ");
	SFOO←INCHWL; IF SFOO="Y" OR SFOO="y" THEN D←-1;
	END;

Comment INIT the TTY we're using. 400 bit means don't wait for it;
OPEN(INTTY,IF D = -1 THEN "TTY4" ELSE "TTY",'401,1,1,CNT←200,BRK,EOF);
IF EOF THEN GO TO STOP;  Comment in case open failed;

Comment Repair TTY IOS;
START_CODE;
SETSTS INTTY,1;
END;

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;

Comment Zero the keyword array. If keyword file exists, read it into keyword array;
KEY[2]←0; ARRBLT(KEY[3],KEY[2],TOP-2);
LOOKUP(INCH,"KEYWD[PNY,SYS]",FLAG);
IF ¬FLAG THEN BEGIN "SETC"
	ARRYIN(INCH,KEY[1],TOP+1);
	C ← EOF LAND '777777;
	CLOSE(INCH);
	END;

FOR N ← 1 STEP 1 UNTIL 10 DO DOOR[N] ← 0;
LOOKUP(INCH,"DOORP[PNY,SYS]",FLAG);
IF ¬FLAG THEN BEGIN
	ARRYIN(INCH,DOOR[1],10);
	CLOSE(INCH);
	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");

COMMENT CHECK KEYWORD FILE TO SEE THAT USERS ARE STILL IN PHONE LIST.
        IF NOT DELETE THEM FROM KEYWORD FILE;

	FOR B ← 1 STEP 1 UNTIL C DO BEGIN  "BLOOP"
		FOR A ← 1 STEP 1 UNTIL I DO      
		    IF (KEY[B] LAND ('777777000000)) = PPN[A] THEN DONE;
		IF A ≤ I THEN PPN[A] ← PPN[A] LOR B 
	        ELSE BEGIN
			ARRBLT(KEY[B],KEY[B+1],C-B);                               
			C ← C-1;		                     
		END;
	END;

IF DOOR[1] = 0 THEN OUT(INTTY,"VENDING MACHINE PRICES ARE NOT SET. THE FRONT OFFICE"&↓&
			      "WILL HAVE TO SET THEM BEFORE THE VENDING MACHINE CAN"&↓&
			      "BE ACTIVATED. PLEASE NOTIFY THEM OF THIS."&↓&↓);


START:
	GOODS←S ← ""; ID ← 0; TOTAL_FLAG ← 0;
	OUT(INTTY,↓&"NEXT! ");
	S ← INPUT(INTTY,1);
	IF LENGTH(S)=0 THEN GO TO START; Comment flush null commands;
	SFOO ← SCAN(S,2,BRK);
	IF LENGTH(SFOO) > 3 THEN ERROR(1); Comment flush PPN's over 3 char. long;
	ID ← CVSIX(LEFT(3,SFOO));
	FOR A ← 1 STEP 1 UNTIL I DO
	IF ID = PPN[A] LAND ('777777000000) THEN DONE;
	IF A > I THEN ERROR(1);
	IF (PPN[A] LAND '777777) THEN BEGIN
		TRY ← 0;
AGAIN:
		NOECHO;
		OUT(INTTY,"PASSWORD = ");
		PASS ← PASSWD(INPUT(INTTY,1));
		ECHO;
		OUT(INTTY,↓);
		K ← PPN[A] LAND '777777;
		IF PASS ≠ (KEY[K] LAND '777777) THEN BEGIN        
			OUT(INTTY,"WRONG PASSWORD"&↓&↓);
			TRY ← TRY +1;
			IF TRY < 2 THEN GO TO AGAIN;
			GO TO START; 
		END;
	END;
	IF ID = PPN[1] LAND ('777777000000) THEN BEGIN 
		IF S = "F" THEN FIXKEY
		ELSE IF S = "P" THEN PRICE_DOOR 
		ELSE BEGIN
		    OUT(INTTY,"WRONG CODE. CODE MUST BE F OR P."&↓&↓);
		    GO TO START;
		END;
	END;
RETRY0:
	ZZ ← 0;
	WHILE LENGTH(S) DO BEGIN
		GOODS ← SCAN(S,2,BRK);
RETRY:
		IF(K←GOODS) = "V" ∨
		       K = "M" ∨
		       K = "C" ∨
		       K = "D" ∨
		       K = "S" ∨
		       K = "B" THEN BEGIN 
			IF LENGTH(GOODS) = 1 ∧ LENGTH(S) = 2 THEN 
			GOODS ← GOODS&SCAN(S,2,BRK);
			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 < 5 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 NUM > 600 THEN ERROR(3);
			IF NUM MOD 5 THEN ERROR(4);
			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);
			IF K = "V" THEN BEGIN
			    FOR D ← 1 STEP 1 UNTIL  9 DO
			        IF DOOR[D] = NUM THEN DONE;
			    IF D >  9 THEN ERROR(7);
			    D ← (D LSH 4) XOR '370;
			END;
			AMOUNT[ZZ] ← NUM*N1;
	        END 
		ELSE IF GOODS = "P" THEN NEWPASS(A,TOP,ID)
		ELSE IF GOODS = "T" THEN TOTAL_FLAG ← 1
		ELSE ERROR(2);
	END;
	DATE;

BN←1; LNGTH←0;
LOOKUP(OUCH,MON&".PNY[PNY,SYS]",FLAG);
IF ¬FLAG THEN BEGIN
    	FILEINFO(CHARGF);
        LNGTH ← -(CHARGF[3] ROT 18);
        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
	NUMT ← NUMT + AMOUNT[K];
       	IF CDE[K] = "V" ∧ AMOUNT[K] > 0 THEN BEGIN
	       	START_CODE;
		CALLI '400005;
	        VMICONO  @D;         
		CALLI '400006;
	       	END;
	        OUT(INTTY,"V/M READY"&↓);
	        END;
	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);
IF LNGTH > 0 THEN ARRYOUT(OUCH,REC[1],LNGTH);
CLOSE(OUCH);  Comment Release accounting file;
IF NUMT ≠ 0 THEN OUT(INTTY,"TOTAL: "&CENTS(NUMT)&↓&↓);
IF TOTAL_FLAG THEN CHARGES(ID);
FOR K ← 1 STEP 1 UNTIL ZZ DO AMOUNT[K] ← 0;
NUMT ← 0;
GO TO START;

STOP:
RELEASE(INTTY);
RELEASE(INCH);
RELEASE(OUCH);
END;