Talk:THROBOL
Jump to navigation
Jump to search
The computational class is in jeopardy because dequeuing enqueues 0 2 as well. I'm not exactly sure how to fix this, but it would likely involve ignoring 0 2 and dequeuing it when encountered. BoundedBeans (talk) 21:12, 5 January 2023 (UTC)
COBOL-THROBOL
Here's an implementation of THROBOL in GnuCOBOL. It hasn't been close to fully tested (and I don't see myself doing that any time soon), but it runs without errors, and at least runs the Print A example correctly.
The flags are:
-F file- Run THROBOL from a file-L (each line as a separate argument) END- Run THROBOL from command line arguments-D- Enable debug/trace mode (lessis your friend here)
Here's the COBOL code:
IDENTIFICATION DIVISION.
PROGRAM-ID. THROBOL.
*COBOL-THROBOL BY BOUNDED-BEANS/KRONOSTA
*FEATURES:
*- CODE SPACE UP TO 999 LINES OF 999 CHARACTERS EACH
*- UP TO 9999 SCOREBOARD ENTRIES
*- VELOCITY AND POWER UP TO 999 SINCE ANY MORE WOULDN'T DO MUCH
* WITH THE CODE SIZE LIMITS.
*- UP TO 50 BALLS (THREADS)
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT CODE-FILE ASSIGN TO CODE-FILENAME
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD CODE-FILE.
01 CODE-FILE-DATA.
05 CODE-FILE-LINE PIC X(999) VALUE SPACES.
WORKING-STORAGE SECTION.
01 ARGV PIC X(7) VALUE SPACES.
01 DEBUG-ON PIC 9 VALUE 0.
01 CODE-FILENAME PIC X(100).
01 CODE-EOF PIC 9 VALUE 0.
01 CI PIC 999 VALUE 1.
01 CJ PIC 999 VALUE 1.
01 CODE-SPACE.
05 CODE-CURRENT-ARG-LINE PIC X(999).
*AN ELEMENT OF CODE-LINES IS A ROW (A Y INDEX)
*AN ELEMENT OF CODE-CHARS IS A CHARACTER (AN X INDEX)
05 CODE-LINES OCCURS 999 TIMES.
10 CODE-CHARS OCCURS 999 TIMES PIC X.
01 SI PIC 9999 VALUE 1.
01 SCOREBOARD.
05 SI-2 PIC 9999.
05 SCOREBOARD-ENTRY OCCURS 9999 TIMES.
10 SCOREBOARD-DATA.
15 SCOREBOARD-POWER PIC 9(3).
15 SCOREBOARD-VELOCITY PIC 9(3).
10 SCOREBOARD-EXISTS PIC 9 VALUE 0.
05 SCOREBOARD-HOLDER-DATA.
10 SCOREBOARD-HOLDER-POWER PIC 9(3).
10 SCOREBOARD-HOLDER-VELOCITY PIC 9(3).
05 SCOREBOARD-LENGTH PIC 9999 VALUE 0.
05 SCOREBOARD-ADDED-TO PIC 9 VALUE 0.
01 BI PIC 99 VALUE 1.
01 BALLS.
05 BALLS-CURRENT-RETURN-POSSIBLE PIC 9.
*SINCE NEW BALLS CAN NEVER BE CREATED, WE CAN OPTIMIZE SOME
*OF THE BALL TURN-TAKING TO RUN LESS THAN 50 ITERATIONS IN MOST
*SCENARIOS. HOWEVER, BALLS WITHOUT A RETURN SYSTEM DISAPPEAR
*QUICKLY, SO SOME BALLS MIGHT NOT EXIST IN THE MIDDLE, WHICH
*IS TRICKIER TO OPTIMIZE. THOUGH YOU PROBABLY COULD OPTIMIZE THAT,
*I WON'T.
05 BALLS-LAST-INDEX PIC 99.
05 BSPI PIC 9.
05 BALL OCCURS 50 TIMES.
10 BALL-DATA.
15 BALL-POWER PIC 9(3) VALUE 3.
15 BALL-VELOCITY PIC 9(3) VALUE 100.
15 BALL-SAVED-POWER PIC 9(3).
15 BALL-SAVED-VELOCITY PIC 9(3).
15 BALL-POINTER PIC 9(4) VALUE 1.
10 BALL-SCORE.
15 BALL-SCORE-PAD OCCURS 2 TIMES PIC 9(3) VALUE 0.
15 BALL-SCORE-INDEX PIC 9 VALUE 1.
10 BALL-ENDING-ROUND PIC 9 VALUE 0.
10 BALL-ROUND-DISCARDED PIC 9 VALUE 0.
10 BALL-POSITION.
15 BALL-X PIC 9(3).
15 BALL-Y PIC 9(3).
10 BALL-RETURN.
15 BALL-RETURN-X PIC 9(3).
15 BALL-RETURN-Y PIC 9(3).
15 BALL-RETURN-EXISTS PIC 9 VALUE 0.
10 BALL-EXISTS PIC 9 VALUE 0.
01 PINS-KNOCKED PIC 999.
01 VELOCITY-COUNTER PIC 999.
01 POWER-COUNTER PIC 999.
01 IO-CHAR USAGE BINARY-CHAR.
01 IO-SHORT USAGE BINARY-SHORT.
PROCEDURE DIVISION.
MAIN.
MOVE 1 TO CI.
PERFORM PARSE-ARGS.
PERFORM FIND-BALLS.
PERFORM EXECUTE.
STOP RUN.
PARSE-ARGS.
PERFORM UNTIL NOT ARGV > LOW-VALUES
MOVE LOW-VALUES TO ARGV
ACCEPT ARGV FROM ARGUMENT-VALUE
EVALUATE TRUE
WHEN ARGV = '-F'
IF DEBUG-ON = 1 THEN
DISPLAY 'THROBOL FROM FILE'
END-IF
ACCEPT CODE-FILENAME FROM ARGUMENT-VALUE
IF DEBUG-ON = 1 THEN
DISPLAY 'THROBOL FILE: ' CODE-FILENAME
END-IF
PERFORM READ-FILE
WHEN ARGV = '-L'
IF DEBUG-ON = 1 THEN
DISPLAY 'THROBOL FROM ARGS'
END-IF
PERFORM READ-ARGS
WHEN ARGV = '-D'
MOVE 1 TO DEBUG-ON
END-EVALUATE
END-PERFORM.
READ-FILE.
IF DEBUG-ON = 1 THEN
DISPLAY 'START READING FILE'
END-IF.
OPEN INPUT CODE-FILE.
PERFORM UNTIL CODE-EOF = 1
READ CODE-FILE
AT END
MOVE 1 TO CODE-EOF
NOT AT END
MOVE CODE-FILE-LINE TO CODE-LINES(CI)
ADD 1 TO CI
END-READ
END-PERFORM.
CLOSE CODE-FILE.
IF DEBUG-ON = 1 THEN
DISPLAY 'FINISH READING FILE'
END-IF.
READ-ARGS.
IF DEBUG-ON = 1 THEN
DISPLAY 'START READING ARGS'
END-IF.
ACCEPT CODE-CURRENT-ARG-LINE FROM ARGUMENT-VALUE.
PERFORM UNTIL CODE-CURRENT-ARG-LINE = 'END'
MOVE CODE-CURRENT-ARG-LINE TO CODE-LINES(CI)
ADD 1 TO CI
ACCEPT CODE-CURRENT-ARG-LINE FROM ARGUMENT-VALUE
END-PERFORM.
IF DEBUG-ON = 1 THEN
DISPLAY 'FINISH READING ARGS'
END-IF.
FIND-BALLS.
IF DEBUG-ON = 1 THEN
DISPLAY 'START FINDING BALLS'
END-IF
MOVE 1 TO BI.
MOVE 1 TO CJ.
MOVE 1 TO CI.
PERFORM UNTIL CI = 0 OR BI > 50
IF CODE-CHARS(CI,CJ) = 'o' THEN
MOVE 1 TO BALLS-CURRENT-RETURN-POSSIBLE
MOVE 1 TO BALL-EXISTS(BI)
MOVE CI TO BALL-Y(BI)
MOVE CJ TO BALL-X(BI)
IF CI > 1 AND CJ < 999 THEN
ADD 1 TO CJ
IF NOT CODE-CHARS(CI,CJ) = '|' THEN
MOVE 0 TO BALLS-CURRENT-RETURN-POSSIBLE
END-IF
SUBTRACT 1 FROM CI
IF NOT CODE-CHARS(CI,CJ) = '%' THEN
MOVE 0 TO BALLS-CURRENT-RETURN-POSSIBLE
END-IF
SUBTRACT 1 FROM CJ
ADD 1 TO CI
ELSE
MOVE 0 TO BALLS-CURRENT-RETURN-POSSIBLE
END-IF
IF BALLS-CURRENT-RETURN-POSSIBLE = 1 THEN
MOVE CI TO BALL-RETURN-Y(BI)
MOVE CJ TO BALL-RETURN-X(BI)
MOVE 1 TO BALL-RETURN-EXISTS(BI)
MOVE 2 TO BALL-POWER(BI)
MOVE 4 TO BALL-VELOCITY(BI)
MOVE 2 TO BALL-SAVED-POWER(BI)
MOVE 4 TO BALL-SAVED-VELOCITY(BI)
END-IF
ADD 1 TO BI
IF DEBUG-ON = 1 THEN
DISPLAY 'FOUND BALL AT X = ' CJ ', Y = ' CI
WITH NO ADVANCING
IF BALLS-CURRENT-RETURN-POSSIBLE = 1 THEN
DISPLAY ' WITH RETURN SYSTEM'
WITH NO ADVANCING
END-IF
DISPLAY ' '
END-IF
END-IF
ADD 1 TO CJ
IF CJ = 0 THEN
MOVE 1 TO CJ
ADD 1 TO CI
END-IF
END-PERFORM.
MOVE BI TO BALLS-LAST-INDEX.
IF DEBUG-ON = 1 THEN
DISPLAY 'FINISHED FINDING BALLS'
END-IF.
EXECUTE.
PERFORM EXECUTE-ALL-TURNS UNTIL SCOREBOARD-LENGTH = 0 AND
SCOREBOARD-ADDED-TO = 1.
EXECUTE-ALL-TURNS.
PERFORM EXECUTE-TURN VARYING BI FROM 1 BY 1 UNTIL BI =
BALLS-LAST-INDEX.
EXECUTE-TURN.
IF SCOREBOARD-LENGTH = 0 AND SCOREBOARD-ADDED-TO = 1 THEN
GOBACK
END-IF.
IF BALL-EXISTS(BI) = 0 THEN
GOBACK
END-IF.
IF BALL-ENDING-ROUND(BI) = 1 OR BALL-ROUND-DISCARDED(BI) = 1
THEN
IF BALL-ENDING-ROUND(BI) = 1 THEN
IF DEBUG-ON = 1 THEN
DISPLAY 'ROUND ENDED AT X = ' BALL-X(BI) ' Y = '
BALL-Y(BI)
END-IF
MOVE 0 TO BALL-ENDING-ROUND(BI)
IF BALL-RETURN-EXISTS(BI) = 1 THEN
MOVE BALL-RETURN-X(BI) TO BALL-X(BI)
MOVE BALL-RETURN-Y(BI) TO BALL-Y(BI)
ELSE
MOVE 0 TO BALL-EXISTS(BI)
END-IF
IF BALL-SCORE-INDEX(BI) = 1 THEN
MOVE 2 TO BALL-SCORE-INDEX(BI)
MOVE BALL-SAVED-VELOCITY(BI) TO BALL-VELOCITY(BI)
MOVE BALL-SAVED-POWER(BI) TO BALL-POWER(BI)
ADD 1 TO BALL-VELOCITY(BI)
SUBTRACT 1 FROM BALL-POWER(BI)
ELSE
ADD 1 TO SCOREBOARD-LENGTH
MOVE SCOREBOARD-LENGTH TO SI
MOVE BALL-SCORE-INDEX(BI) TO BSPI
MOVE BALL-SCORE-PAD(BI,1) TO
SCOREBOARD-POWER(SI)
MOVE BALL-SCORE-PAD(BI,2) TO
SCOREBOARD-VELOCITY(SI)
MOVE 1 TO BALL-SCORE-INDEX(BI)
MOVE 1 TO SCOREBOARD-ADDED-TO
MOVE BALL-POINTER(BI) TO SI
MOVE SCOREBOARD-POWER(SI) TO BALL-POWER(BI)
MOVE SCOREBOARD-VELOCITY(SI) TO BALL-VELOCITY(BI)
MOVE BALL-POWER(BI) TO BALL-SAVED-POWER(BI)
MOVE BALL-VELOCITY(BI) TO BALL-SAVED-VELOCITY(BI)
MOVE 0 TO BALL-SCORE-PAD(BI,1)
MOVE 0 TO BALL-SCORE-PAD(BI,2)
END-IF
ELSE
MOVE 0 TO BALL-ROUND-DISCARDED(BI)
IF BALL-RETURN-EXISTS(BI) = 1 THEN
MOVE BALL-RETURN-X(BI) TO BALL-X(BI)
MOVE BALL-RETURN-Y(BI) TO BALL-Y(BI)
ELSE
MOVE 0 TO BALL-EXISTS(BI)
END-IF
MOVE 1 TO BALL-SCORE-INDEX(BI)
END-IF
IF DEBUG-ON = 1 THEN
DISPLAY 'SCOREBOARD:' WITH NO ADVANCING
PERFORM VARYING SI FROM 1 BY 1
UNTIL SI=10
DISPLAY "[" SCOREBOARD-POWER(SI) ","
SCOREBOARD-VELOCITY(SI) "]"
WITH NO ADVANCING
END-PERFORM
DISPLAY " "
END-IF
ELSE
SUBTRACT 1 FROM BALL-Y(BI)
IF BALL-Y(BI) = 0 THEN
DISPLAY "ERROR: BALL FELL OFF THE TOP EDGE OF THE " &
"PROGRAM"
END-IF
MOVE BALL-Y(BI) TO CI
MOVE BALL-X(BI) TO CJ
IF DEBUG-ON = 1 THEN
DISPLAY X"0A"
"BALL AT X = " BALL-X(BI) " Y = " BALL-Y(BI)
"CHAR IS '" CODE-CHARS(CI,CJ) "'"
END-IF
EVALUATE TRUE
WHEN CODE-CHARS(CI,CJ) = 'A'
IF NOT BALL-VELOCITY(BI) = 0 THEN
MOVE 1 TO PINS-KNOCKED
MOVE BALL-X(BI) TO CJ
MOVE BALL-POWER(BI) TO POWER-COUNTER
ADD 1 TO POWER-COUNTER
PERFORM UNTIL CJ = 0 OR NOT CODE-CHARS(CI,CJ)
= 'A' OR POWER-COUNTER = 0
SUBTRACT 1 FROM POWER-COUNTER
ADD 1 TO CJ
ADD 1 TO PINS-KNOCKED
END-PERFORM
MOVE BALL-X(BI) TO CJ
MOVE BALL-POWER(BI) TO POWER-COUNTER
ADD 1 TO POWER-COUNTER
PERFORM UNTIL CJ = 0 OR NOT CODE-CHARS(CI,CJ)
= 'A' OR POWER-COUNTER = 0
SUBTRACT 1 FROM POWER-COUNTER
SUBTRACT 1 FROM CJ
ADD 1 TO PINS-KNOCKED
END-PERFORM
SUBTRACT 2 FROM PINS-KNOCKED
MOVE BALL-SCORE-INDEX(BI) TO BSPI
ADD PINS-KNOCKED TO BALL-SCORE-PAD(BI,BSPI)
SUBTRACT 1 FROM BALL-VELOCITY(BI)
IF DEBUG-ON = 1 THEN
DISPLAY "KNOCKED " PINS-KNOCKED "PINS!"
END-IF
END-IF
WHEN CODE-CHARS(CI,CJ) = '>'
MOVE BALL-VELOCITY(BI) TO VELOCITY-COUNTER
ADD 1 TO VELOCITY-COUNTER
PERFORM UNTIL VELOCITY-COUNTER = 0 OR
CODE-CHARS(CI,CJ) = '|' OR CJ = 0
ADD 1 TO BALL-X(BI)
MOVE BALL-X(BI) TO CJ
SUBTRACT 1 FROM VELOCITY-COUNTER
END-PERFORM
SUBTRACT 1 FROM BALL-X(BI)
WHEN CODE-CHARS(CI,CJ) = '<'
MOVE BALL-VELOCITY(BI) TO VELOCITY-COUNTER
ADD 1 TO VELOCITY-COUNTER
PERFORM UNTIL VELOCITY-COUNTER = 0 OR
CODE-CHARS(CI,CJ) = '|' OR CJ = 0
SUBTRACT 1 FROM BALL-X(BI)
MOVE BALL-X(BI) TO CJ
SUBTRACT 1 FROM VELOCITY-COUNTER
END-PERFORM
ADD 1 TO BALL-X(BI)
WHEN CODE-CHARS(CI,CJ) = '.'
MOVE BALL-POWER(BI) TO IO-CHAR
CALL "printf" USING X"256300" BY VALUE IO-CHAR
WHEN CODE-CHARS(CI,CJ) = ':'
MOVE BALL-POWER(BI) TO IO-SHORT
CALL "printf" USING X"25640A00"
BY VALUE IO-SHORT
END-CALL
WHEN CODE-CHARS(CI,CJ) = ','
CALL "scanf" USING
X"256300"
BY REFERENCE IO-CHAR
END-CALL
MOVE IO-CHAR TO BALL-VELOCITY(BI)
WHEN CODE-CHARS(CI,CJ) = ';'
CALL "scanf" USING
X"25642000"
BY REFERENCE IO-SHORT
END-CALL
MOVE IO-CHAR TO BALL-VELOCITY(BI)
WHEN CODE-CHARS(CI,CJ) = '-'
IF BALL-VELOCITY(BI) = 0 THEN
MOVE 1 TO BALL-ENDING-ROUND(BI)
END-IF
WHEN CODE-CHARS(CI,CJ) = '='
MOVE 1 TO BALL-ENDING-ROUND(BI)
WHEN CODE-CHARS(CI,CJ) = ')'
ADD 1 TO BALL-POINTER(BI)
ON SIZE ERROR
SUBTRACT 1 FROM BALL-POINTER(BI)
END-ADD
WHEN CODE-CHARS(CI,CJ) = '('
SUBTRACT 1 FROM BALL-POINTER(BI)
ON SIZE ERROR
ADD 1 TO BALL-POINTER(BI)
END-ADD
WHEN CODE-CHARS(CI,CJ) = ']'
ADD 1 TO BALL-X(BI)
ON SIZE ERROR
SUBTRACT 1 FROM BALL-X(BI)
END-ADD
WHEN CODE-CHARS(CI,CJ) = '['
SUBTRACT 1 FROM BALL-X(BI)
ON SIZE ERROR
ADD 1 TO BALL-X(BI)
END-ADD
WHEN CODE-CHARS(CI,CJ) = '^'
ADD 1 TO BALL-POWER(BI)
ON SIZE ERROR
SUBTRACT 1 FROM BALL-POWER(BI)
END-ADD
WHEN CODE-CHARS(CI,CJ) = 'v'
SUBTRACT 1 FROM BALL-POWER(BI)
ON SIZE ERROR
ADD 1 TO BALL-POWER(BI)
END-ADD
WHEN CODE-CHARS(CI,CJ) = 'n'
ADD 1 TO BALL-VELOCITY(BI)
ON SIZE ERROR
SUBTRACT 1 FROM BALL-VELOCITY(BI)
END-ADD
WHEN CODE-CHARS(CI,CJ) = 'u'
SUBTRACT 1 FROM BALL-VELOCITY(BI)
ON SIZE ERROR
ADD 1 TO BALL-VELOCITY(BI)
END-ADD
WHEN CODE-CHARS(CI,CJ) = '"'
MOVE BALL-POINTER(BI) TO SI
PERFORM UNTIL SCOREBOARD-EXISTS(SI)=0 OR
SI = SCOREBOARD-LENGTH
ADD 1 TO SI
MOVE SCOREBOARD-DATA(SI) TO
SCOREBOARD-HOLDER-DATA
SUBTRACT 1 FROM SI
MOVE SCOREBOARD-HOLDER-DATA TO
SCOREBOARD-DATA(SI)
END-PERFORM
SUBTRACT 1 FROM SCOREBOARD-LENGTH
WHEN CODE-CHARS(CI,CJ) = '?'
MOVE 1 TO BALL-ROUND-DISCARDED(BI)
END-EVALUATE
END-IF.
BoundedBeans (talk) 01:49, 10 April 2024 (UTC)