This is a big program, so it's in the Big Programs section:

http://www.network54.com/Forum/190883/message/1180558953/Speed+up+with+DEFINT+A-Z

http://www.network54.com/Forum/190883/message/1205677521/Version+with+Instructions

It is a good fun program and would put a lot of people off not knowing how to castle,exit,move etc.
You have to play against it in a cavalier manner to make it interesting, due to the fact that the Queen comes out like Rambo on steroids giving White a strong position if playing sensibly.
I have also noticed that Black never seems to castle and does not seem to obey all the rules.
It has given me some interesting games and must be worth playing for beginners or fun situations.
If anyone does download it, then I would reccomend that you compile it for a quicker game.
Nice work, I know you have put a lot of effort into it.

http://www.network54.com/Forum/190883/message/1206051115/Version+w-+en+passant

DECLARE SUB MORSE (ASCII!)
DIM SHARED CHAR(57), SIZE(57)
FOR X = 0 TO 56
READ CHAR(X)
NEXT
FOR X = 0 TO 56
READ SIZE(X)
NEXT
DATA 18,00,00,00,00,30,45
DATA 45,00,00,51,33,42, 9,31,30,28
DATA 24,16, 0, 1, 3, 7,15, 7,00,00
DATA 17,00,12,22, 2, 1, 5, 1, 0, 4
DATA 3, 0, 0,14, 5, 2, 3, 1 ,7, 6
DATA 11, 2, 0, 1, 4, 8, 6, 9,13, 3
DATA 6,00,00,00,00, 6, 6
DATA 6,00,00, 6, 6, 6, 5, 5, 5, 5
DATA 5, 5, 5, 5, 5, 5, 5, 6,00,00
DATA 5,00, 6, 6, 2, 4, 4, 3, 1, 4
DATA 3, 4, 2, 4, 3, 4, 2, 2, 3, 4
DATA 4, 3, 3, 1, 3, 4, 3, 4, 4, 4
IF COMMAND$ = "" THEN INPUT "FILE? ", FILE$ ELSE FILE$ = COMMAND$
OPEN FILE$ FOR INPUT AS #1
WHILE NOT EOF(1)
INPUT #1, A$
FOR X = 1 TO LEN(A$)
B$ = UCASE$(MID$(A$, X, 1))
CALL MORSE(ASC(B$))
NEXT
PRINT " "
WEND

SUB MORSE (ASCII)
BITS = 0
IF ASCII = 32 THEN
SLEEP 1: PRINT " "
EXIT SUB
END IF
IF ASCII > 33 AND ASCII < 91 THEN
CODE = CHAR(ASCII - 34)
BITS = SIZE(ASCII - 34)
END IF
FOR I = 1 TO BITS
IF (CODE MOD 2) THEN SOUND 500, 9: PRINT "-"; ELSE SOUND 500, 3: PRINT ".";
SLEEP 1
CODE = INT(CODE / 2)
NEXT
IF BITS THEN
T = TIMER: D = .5
WHILE T + D >= TIMER: WEND
PRINT "/";
END IF
END SUB

RANDOMIZE TIMER
CLS
DIM playerbd(0 TO 9, 0 TO 9) AS STRING
DIM compbd(0 TO 9, 0 TO 9) AS STRING
DIM comphits(0 TO 9, 0 TO 9) AS STRING
PRINT "Co-ordinates range from 0 to 9"
PRINT "* represents part of ship"
PRINT "+ represents hit part of ship."
PRINT "------------------------------"
PRINT "PLACE SHIP [LENGTH 2]"
INPUT "X CO-ORDINATE [0-9]:", x
INPUT "Y CO-ORDINATE [0-9]:", y
INPUT "DIRECTION [N,S,E,W]:", DIRECTION$
playerbd(x, y) = "*"
IF LCASE$(DIRECTION$) = "w" THEN
playerbd(x - 1, y) = "*"
END IF
IF LCASE$(DIRECTION$) = "e" THEN
playerbd(x + 1, y) = "*"
END IF
IF LCASE$(DIRECTION$) = "s" THEN
playerbd(x, y + 1) = "*"
END IF
IF LCASE$(DIRECTION$) = "n" THEN
playerbd(x, y - 1) = "*"
END IF
PRINT "PLACE SHIP [LENGTH 3]"
INPUT "X CO-ORDINATE [0-9]:", x
INPUT "Y CO-ORDINATE [0-9]:", y
INPUT "DIRECTION [N,S,E,W]:", DIRECTION$
playerbd(x, y) = "*"
IF LCASE$(DIRECTION$) = "w" THEN
playerbd(x - 1, y) = "*"
playerbd(x - 2, y) = "*"
END IF
IF LCASE$(DIRECTION$) = "e" THEN
playerbd(x + 1, y) = "*"
playerbd(x + 2, y) = "*"
END IF
IF LCASE$(DIRECTION$) = "s" THEN
playerbd(x, y + 1) = "*"
playerbd(x, y + 2) = "*"
END IF
IF LCASE$(DIRECTION$) = "n" THEN
playerbd(x, y - 1) = "*"
playerbd(x, y - 2) = "*"
END IF
PRINT "PLACE SHIP [LENGTH 3]"
INPUT "X CO-ORDINATE [0-9]:", x
INPUT "Y CO-ORDINATE [0-9]:", y
INPUT "DIRECTION [N,S,E,W]:", DIRECTION$
playerbd(x, y) = "*"
IF LCASE$(DIRECTION$) = "w" THEN
playerbd(x - 1, y) = "*"
playerbd(x - 2, y) = "*"
END IF
IF LCASE$(DIRECTION$) = "e" THEN
playerbd(x + 1, y) = "*"
playerbd(x + 2, y) = "*"
END IF
IF LCASE$(DIRECTION$) = "s" THEN
playerbd(x, y + 1) = "*"
playerbd(x, y + 2) = "*"
END IF
IF LCASE$(DIRECTION$) = "n" THEN
playerbd(x, y - 1) = "*"
playerbd(x, y - 2) = "*"
END IF
PRINT "PLACE SHIP [LENGTH 4]"
INPUT "X CO-ORDINATE [0-9]:", x
INPUT "Y CO-ORDINATE [0-9]:", y
INPUT "DIRECTION [N,S,E,W]:", DIRECTION$
playerbd(x, y) = "*"
IF LCASE$(DIRECTION$) = "W" THEN
playerbd(x - 1, y) = "*"
playerbd(x - 2, y) = "*"
playerbd(x - 3, y) = "*"
END IF
IF LCASE$(DIRECTION$) = "E" THEN
playerbd(x + 1, y) = "*"
playerbd(x + 2, y) = "*"
playerbd(x + 3, y) = "*"
END IF
IF LCASE$(DIRECTION$) = "S" THEN
playerbd(x, y + 1) = "*"
playerbd(x, y + 2) = "*"
playerbd(x, y + 3) = "*"
END IF
IF LCASE$(DIRECTION$) = "N" THEN
playerbd(x, y - 1) = "*"
playerbd(x, y - 2) = "*"
playerbd(x, y - 3) = "*"
END IF
PRINT "PLACE SHIP [LENGTH 5]"
INPUT "X CO-ORDINATE [0-9]:", x
INPUT "Y CO-ORDINATE [0-9]:", y
INPUT "DIRECTION [N,S,E,W]:", DIRECTION$
playerbd(x, y) = "*"
IF LCASE$(DIRECTION$) = "w" THEN
playerbd(x - 1, y) = "*"
playerbd(x - 2, y) = "*"
playerbd(x - 3, y) = "*"
playerbd(x - 4, y) = "*"
END IF
IF LCASE$(DIRECTION$) = "e" THEN
playerbd(x + 1, y) = "*"
playerbd(x + 2, y) = "*"
playerbd(x + 3, y) = "*"
playerbd(x + 4, y) = "*"
END IF
IF LCASE$(DIRECTION$) = "s" THEN
playerbd(x, y + 1) = "*"
playerbd(x, y + 2) = "*"
playerbd(x, y + 3) = "*"
playerbd(x, y + 4) = "*"
END IF
IF LCASE$(DIRECTION$) = "n" THEN
playerbd(x, y - 1) = "*"
playerbd(x, y - 2) = "*"
playerbd(x, y - 3) = "*"
playerbd(x, y - 4) = "*"
END IF
a = INT(RND(1) * 10)
b = INT(RND(1) * 10)
FOR c = 1 TO 4
compbd(a, b) = "*"
DO
x = INT(RND(1) * 4)
IF x = 0 AND a - c >= 0 THEN
FOR d = 1 TO c
compbd(a - c, b) = "*"
NEXT
EXIT DO
END IF
IF x = 1 AND a + c <= 9 THEN
FOR d = 1 TO c
compbd(a + c, b) = "*"
NEXT
EXIT DO
END IF
IF x = 2 AND b - c >= 0 THEN
FOR d = 1 TO c
compbd(a, b - c) = "*"
NEXT
EXIT DO
END IF
IF x = 3 AND b + c <= 9 THEN
FOR d = 1 TO c
compbd(a, b + c) = "*"
NEXT
EXIT DO
END IF
LOOP
NEXT
c = 2
compbd(a, b) = "*"
DO
x = INT(RND(1) * 4)
IF x = 0 AND a - c >= 0 THEN
FOR d = 1 TO c
compbd(a - c, b) = "*"
NEXT
EXIT DO
END IF
IF x = 1 AND a + c <= 9 THEN
FOR d = 1 TO c
compbd(a + c, b) = "*"
NEXT
EXIT DO
END IF
IF x = 2 AND b - c >= 0 THEN
FOR d = 1 TO c
compbd(a, b - c) = "*"
NEXT
EXIT DO
END IF
IF x = 3 AND b + c <= 9 THEN
FOR d = 1 TO c
compbd(a, b + c) = "*"
NEXT
EXIT DO
END IF
LOOP
DO
PRINT SPACE$(2);"0123456789"
FOR a = 0 TO 9
PRINT a;
FOR b = 0 TO 9
IF b < 9 AND playerbd(b, a) = "*" THEN PRINT "*";
IF b < 9 AND playerbd(b, a) = "+" THEN PRINT "+";
IF b < 9 AND playerbd(b, a) = "" THEN PRINT " ";
IF b = 9 AND playerbd(b, a) = "*" THEN PRINT "*"
IF b = 9 AND playerbd(b, a) = "" THEN PRINT " "
IF b = 9 AND playerbd(b, a) = "+" THEN PRINT "+"
NEXT
NEXT
PRINT "-----------"
PRINT SPACE$(2);"0123456789"
FOR a = 0 TO 9
PRINT a,
FOR b = 0 TO 9
IF b < 9 AND comphits(b, a) = "+" THEN PRINT "+";
IF b < 9 AND comphits(b, a) = "" THEN PRINT " ";
IF b = 9 AND comphits(b, a) = "" THEN PRINT " "
IF b = 9 AND comphits(b, a) = "+" THEN PRINT "+"
NEXT
NEXT
INPUT "FIRE X CO-ORDINATE [0-9]:", x
INPUT "FIRE Y CO-ORDINATE [0-9]:", y
IF compbd(x, y) = "*" THEN
compbd(x, y) = "+"
comphits(x, y) = "+"
END IF
a = INT(RND(1) * 10)
b = INT(RND(1) * 10)
IF playerbd(a, b) = "*" THEN
playerbd(a, b) = "+"
END IF
countera = 0
counterb = 0
FOR a = 0 TO 9
FOR b = 0 TO 9
IF compbd(a, b) = "*" THEN countera = countera + 1
NEXT
NEXT
IF countera = 0 THEN
PRINT "YOU WIN"
EXIT DO
END IF
FOR a = 0 TO 9
FOR b = 0 TO 9
IF playerbd(a, b) = "*" THEN counterb = counterb + 1
NEXT
NEXT
IF counterb = 0 THEN
PRINT "YOU LOSE"
EXIT DO
END IF
LOOP

INPUT "BILL"; BILL
INPUT "CASH"; CASH
IF CASH<BILL THEN PRINT "INSUFFICIENT FUNDS": END
CHANGE = CASH - BILL
PRINT "CHANGE:"; CHANGE
PRINT "DOLLARS:"; INT(CHANGE)
CHANGE = (100 * CHANGE) MOD 100
' Uncomment these lines if Half-dollars are used.
' PRINT "HALF-DOLLARS:"; CHANGE \ 50
' CHANGE = CHANGE MOD 50
PRINT "QUARTERS:"; CHANGE \ 25
CHANGE = CHANGE MOD 25
PRINT "DIMES:"; CHANGE \ 10
CHANGE = CHANGE MOD 10
PRINT "NICKLES:"; CHANGE \ 5
CHANGE = CHANGE MOD 5
PRINT "PENNIES:"; CHANGE

INPUT "BILL"; BILL
INPUT "CASH"; CASH
CHANGE = CASH - BILL
PRINT "CHANGE:"; USING "#.##"; CHANGE
PRINT "DOLLARS:"; INT(CHANGE)
CHANGE = (100 * CHANGE) MOD 100
' Uncomment for half-dollars
' PRINT "HALF-DOLLARS:"; CHANGE \ 50
' CHANGE = CHANGE MOD 50
PRINT "QUARTERS:"; CHANGE \ 25
CHANGE = CHANGE MOD 25
PRINT "DIMES:"; CHANGE \ 10
CHANGE = CHANGE MOD 10
PRINT "NICKLES:"; CHANGE \ 5
CHANGE = CHANGE MOD 5
PRINT "PENNIES:"; CHANGE

DIM BILL, CASH, CHANGE AS CURRENCY
INPUT "BILL"; BILL
INPUT "CASH"; CASH
CHANGE = CASH - BILL
PRINT "CHANGE:"; CHANGE
PRINT "DOLLARS:"; INT(CHANGE)
CHANGE = (100 * CHANGE) MOD 100
PRINT "QUARTERS:"; CHANGE \ 25
CHANGE = CHANGE MOD 25
PRINT "DIMES:"; CHANGE \ 10
CHANGE = CHANGE MOD 10
PRINT "NICKLES:"; CHANGE \ 5
CHANGE = CHANGE MOD 5
PRINT "PENNIES:"; CHANGE

DECLARE SUB drawcursor (angle!)
DECLARE SUB drawinner (delta!)
DECLARE SUB drawouter ()

SCREEN 12

CONST pi = 3.141592654#

DIM SHARED dialsize

dialsize = 200 'This is the coolist part change the size of the clock!
DO
LOCATE 1, 4
PRINT "Outer Scale: "; EXP(((angle / (2 * pi)) - INT(angle / (2 * pi))) * LOG(10)),
PRINT "Inner Scale: "; EXP((((angle - delta) / (2 * pi)) - INT((angle - delta) / (2 * pi))) * LOG(10))
drawouter
drawinner delta
drawcursor angle
SELECT CASE INKEY$
CASE CHR$(0) + CHR$(80)
delta = delta + .01: CLS
CASE CHR$(0) + CHR$(72)
delta = delta - .01: CLS
CASE CHR$(0) + CHR$(77)
angle = angle + .01: CLS
CASE CHR$(0) + CHR$(75)
angle = angle - .01: CLS
END SELECT
LOOP

SUB drawcursor (angle)
cursorx = COS(angle) * dialsize
cursory = SIN(angle) * dialsize
LINE (320, 240)-(320 + cursorx, 240 + cursory), 4
END SUB

SUB drawinner (delta)
innersize = dialsize * .8
CIRCLE (320, 240), innersize, 7
FOR t = 10 TO 99
cool = LOG(t / 10) / LOG(10) * pi * 2 + delta
coolx = COS(cool) * innersize
cooly = SIN(cool) * innersize
IF t MOD 10 = 0 THEN
hatchsize = 1.2
ELSEIF t MOD 10 = 5 THEN
hatchsize = 1.1
ELSE
hatchsize = 1.05
END IF
cool2y = SIN(cool) * (innersize / hatchsize)
cool2x = COS(cool) * (innersize / hatchsize)
LINE (coolx + 320, cooly + 240)-(cool2x + 320, cool2y + 240)
NEXT t
END SUB

SUB drawouter
CIRCLE (320, 240), dialsize, 7
FOR t = 10 TO 99
cool = LOG(t / 10) / LOG(10) * pi * 2
coolx = COS(cool) * dialsize
cooly = SIN(cool) * dialsize
IF t MOD 10 = 0 THEN
hatchsize = 1.2
ELSEIF t MOD 10 = 5 THEN
hatchsize = 1.1
ELSE
hatchsize = 1.05
END IF
cool2y = SIN(cool) * (dialsize / hatchsize)
cool2x = COS(cool) * (dialsize / hatchsize)
LINE (coolx + 320, cooly + 240)-(cool2x + 320, cool2y + 240)
NEXT t

END SUB

DECLARE SUB drawcursor (angle!)
DECLARE SUB drawinner (delta!)
DECLARE SUB drawouter ()

SCREEN 12, 0, 0, 0

CONST pi = 3.141592654#

DIM SHARED dialsize

dialsize = 200 'This is the coolist part change the size of the clock!
DO
LOCATE 1, 4
PRINT "Outer Scale: "; EXP(((angle / (2 * pi)) - INT(angle / (2 * pi))) * LOG(10)),
PRINT "Inner Scale: "; EXP((((angle - delta) / (2 * pi)) - INT((angle - delta) / (2 * pi))) * LOG(10))
drawouter
drawinner delta
drawcursor angle

DO
Key$ = INKEY$
LOOP UNTIL Key$ <> ""
IF Key$ = CHR$(27) THEN SYSTEM

z1 = TIMER
DO
z2 = TIMER
IF z2 < z1 THEN z2 = z2 - 86400
IF z2 - z1 > .04 THEN EXIT DO
null$ = INKEY$
LOOP

SELECT CASE Key$
CASE CHR$(0) + CHR$(80)
delta = delta + .01: CLS
CASE CHR$(0) + CHR$(72)
delta = delta - .01: CLS
CASE CHR$(0) + CHR$(77)
angle = angle + .01: CLS
CASE CHR$(0) + CHR$(75)
angle = angle - .01: CLS
END SELECT
LOOP

SUB drawcursor (angle)
cursorx = COS(angle) * dialsize
cursory = SIN(angle) * dialsize
LINE (320, 240)-(320 + cursorx, 240 + cursory), 4

END SUB

SUB drawinner (delta)
innersize = dialsize * .8
CIRCLE (320, 240), innersize, 7
FOR t = 10 TO 99
cool = LOG(t / 10) / LOG(10) * pi * 2 + delta
coolx = COS(cool) * innersize
cooly = SIN(cool) * innersize
IF t MOD 10 = 0 THEN
hatchsize = 1.2
ELSEIF t MOD 10 = 5 THEN
hatchsize = 1.1
ELSE
hatchsize = 1.05
END IF
cool2y = SIN(cool) * (innersize / hatchsize)
cool2x = COS(cool) * (innersize / hatchsize)
LINE (coolx + 320, cooly + 240)-(cool2x + 320, cool2y + 240)
NEXT t

END SUB

SUB drawouter
CIRCLE (320, 240), dialsize, 7
FOR t = 10 TO 99
cool = LOG(t / 10) / LOG(10) * pi * 2
coolx = COS(cool) * dialsize
cooly = SIN(cool) * dialsize
IF t MOD 10 = 0 THEN
hatchsize = 1.2
ELSEIF t MOD 10 = 5 THEN
hatchsize = 1.1
ELSE
hatchsize = 1.05
END IF
cool2y = SIN(cool) * (dialsize / hatchsize)
cool2x = COS(cool) * (dialsize / hatchsize)
LINE (coolx + 320, cooly + 240)-(cool2x + 320, cool2y + 240)
NEXT t

END SUB


------------------------------------------------

It is a shame that page flipping is not supported in screen 12 and 13 but a time delay and clearing the keyboard buffer can help. I hope you like the addition I made, which was something I could do. I will admit this type of mathematical programming has never been something I have learned; so projects like these are foreign to me. It appears you have a real gift for them.

Great job!

Pete

http://www.network54.com/Forum/178387/message/1188750793/Added+Sine-Cosine+Scale

DECLARE SUB DrawInner (delta!)
DECLARE SUB DrawCursor (angle!, delta!)
DECLARE SUB DrawOuter ()
SCREEN 12
DIM SHARED PI
DIM SHARED dialsize
DIM SHARED OldAngle, OldX, OldY, OldDelta
PI = 3.141592654#
dialsize = 200 'This is the coolist part change the size of the clock!
DIM SHARED H(10 TO 99, 4)' History
DIM SHARED HH(6 TO 90, 4)
DIM dD AS SINGLE, dC AS INTEGER: dD = .01: dC = 2
DrawInner .02: DrawCursor .02, .02: CLS
LOCATE 1, 1: PRINT "Log: ";
LOCATE 2, 1: PRINT "D: "
LOCATE 3, 1: PRINT "C: ";
LOCATE 4, 1: PRINT "Sin: ";
LOCATE 5, 1: PRINT "Cos: ";
DO
LOCATE 1, 7: PRINT (angle / (2 * PI)) - INT(angle / (2 * PI))
LOCATE 2, 7: PRINT EXP(((angle / (2 * PI)) - INT(angle / (2 * PI))) * LOG(10))
LOCATE 3, 7: PRINT EXP((((angle - delta) / (2 * PI)) - INT((angle - delta) / (2 * PI))) * LOG(10));
ang = EXP((((angle - delta) / (2 * PI)) - INT((angle - delta) / (2 * PI)) - 1) * LOG(10))
ang2 = 2 * ATN(ang / (1 + SQR(1 - ang * ang))) * 180 / PI
LOCATE 4, 7: PRINT ang2;
ang3 = 90 - ang2
LOCATE 5, 7: PRINT ang3;
DrawOuter
DrawInner delta
DrawCursor angle, delta
WHILE INKEY$ <> "": WEND: DO: k$ = UCASE$(INKEY$): LOOP WHILE k$ = ""
SELECT CASE k$
CASE CHR$(27): SYSTEM
CASE "F", "S": GOSUB AdjustSpeed
CASE CHR$(0) + CHR$(80): delta = delta + dD
CASE CHR$(0) + CHR$(72): delta = delta - dD
CASE CHR$(0) + CHR$(77): angle = angle + dD
CASE CHR$(0) + CHR$(75): angle = angle - dD
END SELECT
LOOP
AdjustSpeed:
SELECT CASE dC
CASE 1: IF k$ = "F" THEN dD = .01: dC = 2
CASE 2: IF k$ = "F" THEN dD = .1: dC = 3 ELSE dD = .001: dC = 1
CASE 3: IF k$ = "F" THEN dD = 1: dC = 4 ELSE dD = .01: dC = 2
CASE ELSE: IF k$ = "S" THEN dD = .1: dC = 3
END SELECT
w$ = "----": MID$(w$, dC, 1) = "o"
LOCATE 6, 1: PRINT w$
RETURN

SUB DrawCursor (angle, delta)
IF OldAngle = angle THEN
LINE (320, 240)-(OldX, OldY), 4
EXIT SUB
END IF
OldAngle = angle
cursorX = COS(angle) * dialsize * 1.18
cursorY = SIN(angle) * dialsize * 1.18
LINE (320, 240)-(OldX, OldY), 0
OldX = 320 + cursorX
OldY = 240 + cursorY
LINE (320, 240)-(OldX, OldY), 4
DrawOuter
DrawInner delta
LINE (320, 240)-(OldX, OldY), 4
END SUB

SUB DrawInner (delta)
innersize = dialsize * .8
sinesize = dialsize * .6
IF delta = OldDelta THEN
FOR T = 10 TO 99
COLOR 7: LINE (H(T, 1), H(T, 2))-(H(T, 3), H(T, 4))
NEXT T
FOR T = 6 TO 90
COLOR 7: LINE (HH(T, 1), HH(T, 2))-(HH(T, 3), HH(T, 4))
NEXT
CIRCLE (320, 240), innersize, 7
CIRCLE (320, 240), sinesize, 7
EXIT SUB
END IF
OldDelta = delta
FOR T = 10 TO 99
cool = LOG(T / 10) / LOG(10) * PI * 2 + delta
coolx = COS(cool) * innersize
cooly = SIN(cool) * innersize
IF T MOD 10 = 0 THEN
hatchsize = 1.15
ELSEIF T MOD 10 = 5 THEN
hatchsize = 1.08
ELSE
hatchsize = 1.05
END IF
cool2y = SIN(cool) * (innersize / hatchsize)
cool2x = COS(cool) * (innersize / hatchsize)
COLOR 0: LINE (H(T, 1), H(T, 2))-(H(T, 3), H(T, 4))
H(T, 1) = coolx + 320: H(T, 2) = cooly + 240
H(T, 3) = cool2x + 320: H(T, 4) = cool2y + 240
COLOR 7: LINE (H(T, 1), H(T, 2))-(H(T, 3), H(T, 4))
NEXT T
FOR T = 6 TO 90
sine = LOG(SIN(T * PI / 180)) / LOG(10) * PI * 2 + delta
sinex = COS(sine) * sinesize
siney = SIN(sine) * sinesize
IF T MOD 10 = 0 THEN
hatchsize = 1.15
ELSEIF T MOD 10 = 5 THEN
hatchsize = 1.08
ELSE
hatchsize = 1.05
END IF
sine2x = COS(sine) * (sinesize / hatchsize)
sine2y = SIN(sine) * (sinesize / hatchsize)
COLOR 0: LINE (HH(T, 1), HH(T, 2))-(HH(T, 3), HH(T, 4))
HH(T, 1) = sinex + 320: HH(T, 2) = siney + 240
HH(T, 3) = sine2x + 320: HH(T, 4) = sine2y + 240
COLOR 7: LINE (HH(T, 1), HH(T, 2))-(HH(T, 3), HH(T, 4))
NEXT
CIRCLE (320, 240), innersize, 7
CIRCLE (320, 240), sinesize, 7
END SUB

SUB DrawOuter
asdfsize = dialsize * 1.18
FOR T = 1 TO 100
asdf = (T / 100) * PI * 2
asdfx = COS(asdf) * asdfsize
asdfy = SIN(asdf) * asdfsize
IF T MOD 10 = 0 THEN
hatchsize = 1.15
ELSEIF T MOD 10 = 5 THEN
hatchsize = 1.08
ELSE
hatchsize = 1.05
END IF
asdf2y = SIN(asdf) * (asdfsize / hatchsize)
asdf2x = COS(asdf) * (asdfsize / hatchsize)
LINE (asdfx + 320, asdfy + 240)-(asdf2x + 320, asdf2y + 240)
NEXT
FOR T = 10 TO 99
dial = LOG(T / 10) / LOG(10) * PI * 2
dialx = COS(dial) * dialsize
dialy = SIN(dial) * dialsize
IF T MOD 10 = 0 THEN
hatchsize = 1.15
ELSEIF T MOD 10 = 5 THEN
hatchsize = 1.08
ELSE
hatchsize = 1.05
END IF
dial2y = SIN(dial) * (dialsize / hatchsize)
dial2x = COS(dial) * (dialsize / hatchsize)
LINE (dialx + 320, dialy + 240)-(dial2x + 320, dial2y + 240)
NEXT T
CIRCLE (320, 240), asdfsize, 7
CIRCLE (320, 240), dialsize, 7
END SUB

CLS
INPUT search$
SHELL "FIND /C /I " + CHR$(34) + search$ + CHR$(34) + " DICT.DAT > RESULTS.DAT"
OPEN "results.dat" FOR INPUT AS #1
INPUT #1, line$
INPUT #1, line$
CLOSE #1
SHELL "del results.dat"
IF INSTR(line$, " 0") = 0 THEN PRINT "Word is in dictionary.": END
search$ = LTRIM$(RTRIM$(UCASE$(search$)))
firstletter$ = LEFT$(search$, 1)
search$ = RIGHT$(search$, LEN(search$) - 1)
FOR i = 1 TO LEN(search$)
c$ = MID$(search$, i, 1)
SELECT CASE c$
CASE "B", "F", "P", "V"
soundex$ = soundex$ + "1"
CASE "C", "G", "J", "K", "Q", "S", "X", "Z"
soundex$ = soundex$ + "2"
CASE "D", "T"
soundex$ = soundex$ + "3"
CASE "L"
soundex$ = soundex$ + "4"
CASE "M", "N"
soundex$ = soundex$ + "5"
CASE "R"
soundex$ = soundex$ + "6"
END SELECT
NEXT
FOR i = 2 TO LEN(soundex$)
IF MID$(soundex$, i, 1) = MID$(soundex$, i - 1, 1) THEN
soundex$ = LEFT$(soundex$, i - 1) + MID$(soundex$, i + 1)
END IF
NEXT i
soundex$ = LEFT$(soundex$ + "000", 3)
soundex$ = firstletter$ + soundex$
OPEN "DICT.DAT" FOR INPUT AS #1
OPEN "DICT2.DAT" FOR INPUT AS #2
WHILE NOT (EOF(1))
INPUT #2, sndx$
INPUT #1, word$
IF sndx$ = soundex$ THEN PRINT word$,
WEND
END

http://samanddeanus.no-ip.org/dict.dat

The above link is to a comprehensive spelling list at qbguy's website (Pete)

1) Use 'View Source' in you browser.

2) Copy the data with the <br> tags as listed.

3) Save it to your QB directory as: "Dictraw.dat"

4) Run this:

CLS
OPEN "dictraw.dat" FOR INPUT AS #1
OPEN "dict.dat" FOR OUTPUT AS #2
DO UNTIL EOF(1)
LINE INPUT #1, a$
a$ = MID$(a$, 1, LEN(a$) - 4)
PRINT #2, a$
LOOP
SYSTEM

---------------------

Just delete the file you don't need or write your own NAME AS statement in the code, instead.

OPEN "DICT.DAT" FOR INPUT AS #1
OPEN "DICT2.DAT" FOR OUTPUT AS #2
WHILE NOT (EOF(1))
soundex$=""
INPUT #1, search$
search$ = LTRIM$(RTRIM$(UCASE$(search$)))
firstletter$ = LEFT$(search$, 1)
search$ = RIGHT$(search$, LEN(search$) - 1)
FOR i = 1 TO LEN(search$)
c$ = MID$(search$, i, 1)
SELECT CASE c$
CASE "B", "F", "P", "V"
soundex$ = soundex$ + "1"
CASE "C", "G", "J", "K", "Q", "S", "X", "Z"
soundex$ = soundex$ + "2"
CASE "D", "T"
soundex$ = soundex$ + "3"
CASE "L"
soundex$ = soundex$ + "4"
CASE "M", "N"
soundex$ = soundex$ + "5"
CASE "R"
soundex$ = soundex$ + "6"
END SELECT
NEXT
FOR i = 2 TO LEN(soundex$)
IF MID$(soundex$, i, 1) = MID$(soundex$, i - 1, 1) THEN
soundex$ = LEFT$(soundex$, i - 1) + MID$(soundex$, i + 1)
END IF
NEXT i
soundex$ = LEFT$(soundex$ + "000", 3)
soundex$ = firstletter$ + soundex$
PRINT #2, soundex$
WEND
END

OPEN "DICT.DAT" FOR INPUT AS #1
OPEN "DICT2.DAT" FOR OUTPUT AS #2
WHILE NOT (EOF(1))
soundex$ = ""
INPUT #1, search$
search$ = LTRIM$(RTRIM$(UCASE$(search$)))
firstletter$ = LEFT$(search$, 1)
search$ = RIGHT$(search$, LEN(search$) - 1)
FOR i = 1 TO LEN(search$)
c$ = MID$(search$, i, 1)
SELECT CASE c$
CASE "B", "F", "P", "V"
soundex$ = soundex$ + "1"
CASE "C", "G", "J", "K", "Q", "S", "X", "Z"
soundex$ = soundex$ + "2"
CASE "D", "T"
soundex$ = soundex$ + "3"
CASE "L"
soundex$ = soundex$ + "4"
CASE "M", "N"
soundex$ = soundex$ + "5"
CASE "R"
soundex$ = soundex$ + "6"
END SELECT
NEXT
FOR i = 2 TO LEN(soundex$)
IF MID$(soundex$, i, 1) = MID$(soundex$, i - 1, 1) THEN
soundex$ = LEFT$(soundex$, i - 1) + MID$(soundex$, i + 1)
END IF
NEXT i
soundex$ = LEFT$(soundex$ + "00000", 5)
soundex$ = firstletter$ + soundex$
PRINT #2, soundex$
WEND

DECLARE FUNCTION SOUNDEX$ (NAME$)
DECLARE FUNCTION FRONTV! (X$)
DECLARE FUNCTION VOWEL! (X$)
DECLARE FUNCTION VARSON! (X$)
OPEN "DICT.DAT" FOR INPUT AS #1
OPEN "DICT2.DAT" FOR OUTPUT AS #2
WHILE NOT (EOF(1))
INPUT #1, WORD$
WORD$ = SOUNDEX$(WORD$)
PRINT #2, WORD$
WEND
END

FUNCTION FRONTV (X$)
FRONTV = INSTR("EIY", X$)
END FUNCTION

FUNCTION SOUNDEX$ (NAME$)
NAME$ = UCASE$(NAME$)
TWO$ = MID$(NAME$, 1, 2)
IF TWO$ = "PN" OR TWO$ = "AR" OR TWO$ = "KN" OR TWO$ = "GN" OR TWO$ = "WR" OR TWO$ = "AE" THEN NAME$ = MID$(NAME$, 2)
IF TWO$ = "WH" THEN NAME$ = "W" + MID$(NAME$, 3)
IF LEFT$(NAME$, 1) = "X" THEN NAME$ = "S" + MID$(NAME$, 2)
L = LEN(NAME$)
FOR I = 1 TO L
SYMB$ = MID$(NAME$, I, 1)
IF I > 1 THEN PREV$ = MID$(NAME$, I - 1, 1) ELSE PREV$ = "."
IF I > 2 THEN PREV2$ = MID$(NAME$, I - 2, 1) ELSE PREV2$ = "."
IF I < L THEN NEXT$ = MID$(NAME$, I + 1, 1) ELSE NEXT$ = "."
IF I < L - 1 THEN NEXT2$ = MID$(NAME$, I + 2, 1) ELSE NEXT2$ = ""
IF I < L - 2 THEN NEXT3$ = MID$(NAME$, I + 3, 1) ELSE NEXT3$ = ""
IF SYMB$ <> "C" AND I > 1 AND PREV$ = SYMB$ THEN NEW = 0 ELSE NEW = -1
IF NEW THEN
IF VOWEL(SYMB$) AND I = 1 THEN
METAPH$ = METAPH$ + SYMB$
ELSE
SELECT CASE SYMB$
CASE "B"
IF I = L AND PREV$ = "M" THEN SILENT = -1 ELSE SILENT = 0
IF NOT SILENT THEN METAPH$ = METAPH$ + "B"
CASE "C"
IF NOT (PREV$ = "S" AND FRONTV(NEXT$)) THEN
IF NEXT$ = "I" AND NEXT2$ = "A" THEN
METAPH$ = METAPH$ + "X"
ELSE
IF FRONTV(NEXT$) THEN
METAPH$ = METAPH$ + "S"
ELSEIF NEXT$ = "H" AND PREV$ = "S" THEN
METAPH$ = METAPH$ + "K"
ELSEIF NEXT$ = "H" THEN
IF I = 0 AND VOWEL(NEXT2$) = 0 THEN
METAPH$ = METAPH$ + "K"
ELSE
METAPH$ = METAPH$ + "X"
END IF
ELSE
METAPH$ = METAPH$ + "K"
END IF
END IF
END IF
CASE "D"
IF NEXT$ = "G" AND FRONTV(NEXT2$) THEN
METAPH$ = METAPH$ + "J"
ELSE
METAPH$ = METAPH$ + "T"
END IF
CASE "G"
IF NEXT$ = "H" AND VOWEL(NEXT2$) THEN SILENT = -1 ELSE SILENT = 0
IF (I + 1 = L OR (NEXT$ = "N" AND NEXT2$ = "E" AND NEXT3$ = "D")) AND NEXT$ = "N" THEN SILENT = -1
IF PREV$ = "G" THEN HARD = -1 ELSE HARD = 0
IF NOT SILENT THEN
IF FRONTV(NEXT$) AND NOT HARD THEN
METAPH$ = METAPH$ + "J"
ELSE
METAPH$ = METAPH$ + "K"
END IF
END IF
CASE "H"
IF VARSON(PREV$) AND VOWEL(NEXT$) THEN METAPH$ = METAPH$ + "H"
CASE "F", "J", "L", "M", "N", "R"
METAPH$ = METAPH$ + SYMB$
CASE "K"
IF PREV$ <> "C" THEN METAPH$ = METAPH$ + "K"
CASE "P"
IF NEXT$ = "H" THEN
METAPH$ = METAPH$ + "F"
ELSE
METAPH$ = METAPH$ + "K"
END IF
CASE "Q"
METAPH$ = METAPH$ + "K"
CASE "S"
IF NEXT$ = "I" AND (NEXT2$ = "O" OR NEXT2$ = "A") THEN
METAPH$ = METAPH$ + "X"
ELSEIF NEXT$ = "H" THEN
METAPH$ = MEATPH$ + "X"
ELSE
METAPH$ = METAPH$ + "S"
END IF
CASE "T"
IF NEXT$ = "I" AND (NEXT$ = "O" OR NEXT$ = "A") THEN
METAPH$ = METAPH$ + "X"
ELSEIF NEXT$ = "H" THEN
METAPH$ = METAPH$ + "0"
ELSEIF NOT (NEXT$ = "C" AND NEXT2$ = "H") THEN
METAPH$ = METAPH$ + "T"
END IF
CASE "V"
METAPH$ = METAPH$ + "F"
CASE "W", "Y"
IF VOWEL(NEXT$) THEN METAPH$ = METAPH$ + SYMB$
CASE "X"
METAPH$ = METAPH$ + "KS"
CASE "Z"
METAPH$ = METAPH$ + "S"
END SELECT
END IF
END IF
NEXT
SOUNDEX$ = METAPH$
END FUNCTION

FUNCTION VARSON (X$)
VARSON = INSTR("CSPTG", X$)
END FUNCTION

FUNCTION VOWEL (X$)
VOWEL = INSTR("AEIOU", X$)
END FUNCTION

CLS
INPUT search$
search$ = LTRIM$(RTRIM$(UCASE$(search$)))
firstletter$ = LEFT$(search$, 1)
search$ = RIGHT$(search$, LEN(search$) - 1)
FOR i = 1 TO LEN(search$)
c$ = MID$(search$, i, 1)
SELECT CASE c$
CASE "B", "F", "P", "V"
soundex$ = soundex$ + "1"
CASE "C", "G", "J", "K", "Q", "S", "X", "Z"
soundex$ = soundex$ + "2"
CASE "D", "T"
soundex$ = soundex$ + "3"
CASE "L"
soundex$ = soundex$ + "4"
CASE "M", "N"
soundex$ = soundex$ + "5"
CASE "R"
soundex$ = soundex$ + "6"
END SELECT
NEXT
FOR i = 2 TO LEN(soundex$)
IF MID$(soundex$, i, 1) = MID$(soundex$, i - 1, 1) THEN
soundex$ = LEFT$(soundex$, i - 1) + MID$(soundex$, i + 1)
END IF
NEXT i
soundex$ = LEFT$(soundex$ + "00000", 5)
soundex$ = firstletter$ + soundex$
OPEN "DICT.DAT" FOR INPUT AS #1
OPEN "DICT2.DAT" FOR INPUT AS #2
OPEN "RESULTS.DAT" FOR OUTPUT AS #3
WHILE NOT (EOF(1))
INPUT #2, sndx$
INPUT #1, word$
IF sndx$ = soundex$ THEN PRINT #3, word$; " "
WEND
CLOSE #1
CLOSE #2
CLOSE #3
SHELL "FIND /I /C " + CHR$(34) + search$ + CHR$(32) + CHR$(34) + " results.dat > found"
OPEN "found" FOR INPUT AS #1
INPUT #1, line$
INPUT #1, line$
IF INSTR(line$, " 0") THEN SHELL "MORE RESULTS.DAT": END ELSE PRINT "IN DICTIONARY"
END

DECLARE FUNCTION FRONTV! (X$)
DECLARE FUNCTION SOUNDEX$ (NAME$)
DECLARE FUNCTION VARSON! (X$)
DECLARE FUNCTION VOWEL! (X$)
CLS
INPUT search$
search$ = LTRIM$(RTRIM$(UCASE$(search$)))
soundx$ = SOUNDEX$(search$)
OPEN "DICT.DAT" FOR INPUT AS #1
OPEN "DICT2.DAT" FOR INPUT AS #2
OPEN "RESULTS.DAT" FOR OUTPUT AS #3
WHILE NOT (EOF(1))
INPUT #2, sndx$
INPUT #1, word$
IF sndx$ = soundx$ THEN PRINT #3, word$; " "
WEND
CLOSE #1
CLOSE #2
CLOSE #3
SHELL "FIND /I /C " + CHR$(34) + search$ + CHR$(32) + CHR$(34) + " results.dat > found"
OPEN "found" FOR INPUT AS #1
INPUT #1, line$
INPUT #1, line$
IF INSTR(line$, " 0") THEN SHELL "MORE RESULTS.DAT": END ELSE PRINT "IN DICTIONARY"
END


FUNCTION FRONTV (X$)
FRONTV = INSTR("EIY", X$)
END FUNCTION

FUNCTION SOUNDEX$ (NAME$)
NAME$ = UCASE$(NAME$)
TWO$ = MID$(NAME$, 1, 2)
IF TWO$ = "PN" OR TWO$ = "AR" OR TWO$ = "KN" OR TWO$ = "GN" OR TWO$ = "WR" OR TWO$ = "AE" THEN NAME$ = MID$(NAME$, 2)
IF TWO$ = "WH" THEN NAME$ = "W" + MID$(NAME$, 3)
IF LEFT$(NAME$, 1) = "X" THEN NAME$ = "S" + MID$(NAME$, 2)
L = LEN(NAME$)
FOR I = 1 TO L
SYMB$ = MID$(NAME$, I, 1)
IF I > 1 THEN PREV$ = MID$(NAME$, I - 1, 1) ELSE PREV$ = "."
IF I > 2 THEN PREV2$ = MID$(NAME$, I - 2, 1) ELSE PREV2$ = "."
IF I < L THEN NEXT$ = MID$(NAME$, I + 1, 1) ELSE NEXT$ = "."
IF I < L - 1 THEN NEXT2$ = MID$(NAME$, I + 2, 1) ELSE NEXT2$ = ""
IF I < L - 2 THEN NEXT3$ = MID$(NAME$, I + 3, 1) ELSE NEXT3$ = ""
IF SYMB$ <> "C" AND I > 1 AND PREV$ = SYMB$ THEN NEW = 0 ELSE NEW = -1
IF NEW THEN
IF VOWEL(SYMB$) AND I = 1 THEN
METAPH$ = METAPH$ + SYMB$
ELSE
SELECT CASE SYMB$
CASE "B"
IF I = L AND PREV$ = "M" THEN SILENT = -1 ELSE SILENT = 0
IF NOT SILENT THEN METAPH$ = METAPH$ + "B"
CASE "C"
IF NOT (PREV$ = "S" AND FRONTV(NEXT$)) THEN
IF NEXT$ = "I" AND NEXT2$ = "A" THEN
METAPH$ = METAPH$ + "X"
ELSE
IF FRONTV(NEXT$) THEN
METAPH$ = METAPH$ + "S"
ELSEIF NEXT$ = "H" AND PREV$ = "S" THEN
METAPH$ = METAPH$ + "K"
ELSEIF NEXT$ = "H" THEN
IF I = 0 AND VOWEL(NEXT2$) = 0 THEN
METAPH$ = METAPH$ + "K"
ELSE
METAPH$ = METAPH$ + "X"
END IF
ELSE
METAPH$ = METAPH$ + "K"
END IF
END IF
END IF
CASE "D"
IF NEXT$ = "G" AND FRONTV(NEXT2$) THEN
METAPH$ = METAPH$ + "J"
ELSE
METAPH$ = METAPH$ + "T"
END IF
CASE "G"
IF NEXT$ = "H" AND VOWEL(NEXT2$) THEN SILENT = -1 ELSE SILENT = 0
IF (I + 1 = L OR (NEXT$ = "N" AND NEXT2$ = "E" AND NEXT3$ = "D")) AND NEXT$ = "N" THEN SILENT = -1
IF PREV$ = "G" THEN HARD = -1 ELSE HARD = 0
IF NOT SILENT THEN
IF FRONTV(NEXT$) AND NOT HARD THEN
METAPH$ = METAPH$ + "J"
ELSE
METAPH$ = METAPH$ + "K"
END IF
END IF
CASE "H"
IF VARSON(PREV$) AND VOWEL(NEXT$) THEN METAPH$ = METAPH$ + "H"
CASE "F", "J", "L", "M", "N", "R"
METAPH$ = METAPH$ + SYMB$
CASE "K"
IF PREV$ <> "C" THEN METAPH$ = METAPH$ + "K"
CASE "P"
IF NEXT$ = "H" THEN
METAPH$ = METAPH$ + "F"
ELSE
METAPH$ = METAPH$ + "K"
END IF
CASE "Q"
METAPH$ = METAPH$ + "K"
CASE "S"
IF NEXT$ = "I" AND (NEXT2$ = "O" OR NEXT2$ = "A") THEN
METAPH$ = METAPH$ + "X"
ELSEIF NEXT$ = "H" THEN
METAPH$ = MEATPH$ + "X"
ELSE
METAPH$ = METAPH$ + "S"
END IF
CASE "T"
IF NEXT$ = "I" AND (NEXT$ = "O" OR NEXT$ = "A") THEN
METAPH$ = METAPH$ + "X"
ELSEIF NEXT$ = "H" THEN
METAPH$ = METAPH$ + "0"
ELSEIF NOT (NEXT$ = "C" AND NEXT2$ = "H") THEN
METAPH$ = METAPH$ + "T"
END IF
CASE "V"
METAPH$ = METAPH$ + "F"
CASE "W", "Y"
IF VOWEL(NEXT$) THEN METAPH$ = METAPH$ + SYMB$
CASE "X"
METAPH$ = METAPH$ + "KS"
CASE "Z"
METAPH$ = METAPH$ + "S"
END SELECT
END IF
END IF
NEXT
SOUNDEX$ = METAPH$
END FUNCTION

FUNCTION VARSON (X$)
VARSON = INSTR("CSPTG", X$)
END FUNCTION

FUNCTION VOWEL (X$)
VOWEL = INSTR("AEIOU", X$)
END FUNCTION

DECLARE FUNCTION DISTANCE% (S$, T$)
DECLARE FUNCTION MINIMUM% (A%, B%, C%)
DEFINT A-Z
OPEN "DICT.DAT" FOR INPUT AS #1
OPEN "RESULTS.TMP" FOR OUTPUT AS #2
INPUT SEARCH$
SEARCH$ = LTRIM$(RTRIM$(UCASE$(SEARCH$)))
WHILE NOT EOF(1)
INPUT #1, WORD$
WORD$ = UCASE$(WORD$)
IF DISTANCE(WORD$, SEARCH$) < 2 THEN PRINT #2, WORD$; " "
WEND
CLOSE #1
CLOSE #2
SHELL "FIND /I /C " + CHR$(34) + SEARCH$ + CHR$(32) + CHR$(34) + " RESULTS.TMP > FOUND.TMP"
OPEN "FOUND.TMP" FOR INPUT AS #1
INPUT #1, LINE$: INPUT #1, LINE$
IF INSTR(LINE$, " 0") THEN SHELL "MORE RESULTS.TMP": END ELSE PRINT "IN DICTIONARY"
CLOSE #1
SHELL "DEL *.TMP"
END

FUNCTION DISTANCE (S$, T$)
' RETURNS THE LEVENSHTEIN DISTANCE BETWEEN TWO STRINGS
DIM D(0 TO LEN(S$), 0 TO LEN(T$))
FOR I = 0 TO LEN(S$)
D(I, 0) = I
NEXT
FOR J = 1 TO LEN(T$)
D(0, J) = J
NEXT
FOR I = 1 TO LEN(S$)
FOR J = 1 TO LEN(T$)
IF MID$(S$, I, 1) = MID$(T$, J, 1) THEN COST = 0 ELSE COST = 1
A = D(I - 1, J) + 1
IF J = LEN(T$) THEN B = 32767 ELSE B = D(I, J + 1) + 2
C = D(I - 1, J - 1) + COST
D(I, J) = MINIMUM(A, B, C)
NEXT
NEXT
DISTANCE = D(LEN(S$), LEN(T$))
END FUNCTION

FUNCTION MINIMUM (A, B, C)
IF A <= B AND A <= C THEN MINIMUM = A
IF B <= A AND B <= C THEN MINIMUM = B
IF C <= A AND C <= B THEN MINIMUM = C
END FUNCTION

DECLARE FUNCTION DISTANCE% (S$, T$)
DECLARE FUNCTION MINIMUM% (A%, B%, C%)
DEFINT A-Z
OPEN "DICT.DAT" FOR INPUT AS #1
OPEN "RESULTS.TMP" FOR OUTPUT AS #2
INPUT SEARCH$
SEARCH$ = LTRIM$(RTRIM$(UCASE$(SEARCH$)))
WHILE NOT EOF(1)
INPUT #1, WORD$
WORD$ = UCASE$(WORD$)
IF DISTANCE(WORD$, SEARCH$) < 2 THEN PRINT #2, WORD$; " "
WEND
CLOSE #1
CLOSE #2
SHELL "FIND /I /C " + CHR$(34) + SEARCH$ + CHR$(32) + CHR$(34) + " RESULTS.TMP > FOUND.TMP"
OPEN "FOUND.TMP" FOR INPUT AS #1
INPUT #1, LINE$: INPUT #1, LINE$
IF INSTR(LINE$, " 0") THEN SHELL "MORE RESULTS.TMP": END ELSE PRINT "IN DICTIONARY"
CLOSE #1
SHELL "DEL *.TMP"
END

FUNCTION DISTANCE (S$, T$)
' RETURNS THE DAMERAU-LEVENSHTEIN DISTANCE BETWEEN TWO STRINGS
DIM D(0 TO LEN(S$), 0 TO LEN(T$))
FOR I = 0 TO LEN(S$)
D(I, 0) = I
NEXT
FOR J = 1 TO LEN(T$)
D(0, J) = J
NEXT
FOR I = 1 TO LEN(S$)
FOR J = 1 TO LEN(T$)
IF MID$(S$, I, 1) = MID$(T$, J, 1) THEN COST = 0 ELSE COST = 1
A = D(I - 1, J) + 1
IF J = LEN(T$) THEN B = 32767 ELSE B = D(I, J + 1) + 2
C = D(I - 1, J - 1) + COST
D(I, J) = MINIMUM(A, B, C)
IF I > 1 AND J > 1 THEN IF MID$(S$, I, 1) = MID$(T$, J - 1, 1) AND MID$(S$, I - 1, 1) = MID$(T$, J, 1) THEN D(I, J) = MINIMUM(D(I, J), D(I - 2, J - 2) + COST, 32767)
NEXT
NEXT
DISTANCE = D(LEN(S$), LEN(T$))
END FUNCTION

FUNCTION MINIMUM (A, B, C)
IF A <= B AND A <= C THEN MINIMUM = A
IF B <= A AND B <= C THEN MINIMUM = B
IF C <= A AND C <= B THEN MINIMUM = C
END FUNCTION

DECLARE FUNCTION DISTANCE% (S$, T$)
DECLARE FUNCTION MINIMUM% (A%, B%, C%)
DEFINT A-Z
CONST ALPHABET = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
INPUT "FILE"; FILE$
INPUT "OUTFILE"; OUT$
OPEN FILE$ FOR INPUT AS #1
OPEN OUT$ FOR OUTPUT AS #2
WHILE NOT EOF(1)
I = 1
LINE INPUT #1, X$
WHILE RTRIM$(LTRIM$(X$)) <> ""
A$ = ""
B$ = ""
I = INSTR(X$, " ")
W$ = LEFT$(X$, I)
X$ = MID$(X$, I + 1)
IF I = 0 THEN W$ = X$: X$ = ""
FOR J = 1 TO LEN(W$)
IF INSTR(ALPHABET, MID$(W$, J, 1)) THEN EXIT FOR
A$ = A$ + MID$(W$, J, 1)
NEXT
W2$ = W$
W$ = MID$(W$, J)
FOR J = LEN(W$) TO 1 STEP -1
IF INSTR(ALPHABET, MID$(W$, J, 1)) THEN EXIT FOR
B$ = MID$(W$, J, 1) + B$
NEXT
W$ = LEFT$(W$, J)
CAPS = 0
IF W$ = UCASE$(W$) THEN
CAPS = 1
ELSEIF W$ = UCASE$(LEFT$(W$, 1)) + LCASE$(MID$(W$, 2)) THEN
CAPS = 2
END IF
W$ = LCASE$(W$)
REDIM SUGGEST$(0 TO 9)
Z = 0
PRINT W$; CHR$(32);
IF W$ = "" THEN PRINT #2, W2$; : GOTO 1
OPEN "DICT.DAT" FOR INPUT AS #3
WHILE NOT (EOF(3))
LINE INPUT #3, WORD$
SELECT CASE DISTANCE(WORD$, W$)
CASE 0
PRINT #2, W2$;
CLOSE #3
GOTO 1
CASE 1
IF Z <= 9 THEN
SUGGEST$(Z) = WORD$
Z = Z + 1
END IF
END SELECT
WEND
GOTO 2
1 GOTO 3
2 CLOSE #3
PRINT
PRINT W$; " is not in dictionary. Select number or -1 to suggest"
FOR I = 0 TO Z - 1
PRINT I; SUGGEST$(I)
NEXT
XYZ$ = ""
DO UNTIL XYZ$ <> "" AND VAL(XYZ$) > -2 AND VAL(XYZ$) < 10
INPUT XYZ$
LOOP
IF VAL(XYZ$) = -1 THEN LINE INPUT SUGGEST$(0): Z = 0 ELSE Z = VAL(XYZ$)
W$ = SUGGEST$(Z)
SELECT CASE CAPS
CASE 1
W$ = UCASE$(W$)
CASE 2
W$ = UCASE$(LEFT$(W$, 1)) + LCASE$(MID$(W$, 2))
END SELECT
PRINT #2, A$ + W$ + B$;
3 WEND
PRINT #2, ""
WEND
CLOSE

FUNCTION DISTANCE (S$, T$)
' RETURNS THE DAMERAU-LEVENSHTEIN DISTANCE BETWEEN TWO STRINGS
DIM D(0 TO LEN(S$), 0 TO LEN(T$))
IF S$ = T$ THEN DISTANCE = 0: EXIT FUNCTION
FOR I = 0 TO LEN(S$)
D(I, 0) = I
NEXT
FOR J = 1 TO LEN(T$)
D(0, J) = J
NEXT
FOR I = 1 TO LEN(S$)
FOR J = 1 TO LEN(T$)
IF MID$(S$, I, 1) = MID$(T$, J, 1) THEN COST = 0 ELSE COST = 1
A = D(I - 1, J) + 1
IF J = LEN(T$) THEN B = 32767 ELSE B = D(I, J + 1) + 2
C = D(I - 1, J - 1) + COST
D(I, J) = MINIMUM(A, B, C)
IF I > 1 AND J > 1 THEN IF MID$(S$, I, 1) = MID$(T$, J - 1, 1) AND MID$(S$, I - 1, 1) = MID$(T$, J, 1) THEN D(I, J) = MINIMUM(D(I, J), D(I - 2, J - 2) + COST, 32767)
NEXT
NEXT
DISTANCE = D(LEN(S$), LEN(T$))
END FUNCTION

FUNCTION MINIMUM (A, B, C)
IF A <= B AND A <= C THEN MINIMUM = A
IF B <= A AND B <= C THEN MINIMUM = B
IF C <= A AND C <= B THEN MINIMUM = C
END FUNCTION

DECLARE SUB AI ()
DECLARE SUB PLAYGAME ()
DECLARE SUB MOVEPILE (N%, START%, FINISH%)
DECLARE SUB MOVEDISK (START%, FINISH%)
DECLARE SUB SHOWDISKS ()
DEFINT A-Z
CONST NUMDISKS = 8
DIM SHARED TOWERS(0 TO 2, 1 TO NUMDISKS), TOP(0 TO 2), COLORS(1 TO NUMDISKS)
CLS
TOP(0) = NUMDISKS: TOP(1) = 0: TOP(2) = 0
FOR I = 1 TO NUMDISKS
TOWERS(0, I) = NUMDISKS - I + 1
READ COLORS(I)
NEXT
DATA 6, 9, 4, 10, 11, 12, 13, 14
DATA 6, 9, 4, 10, 11, 12, 13, 14
LOCATE 1, 26
PRINT CHR$(218); STRING$(14, CHR$(196)); CHR$(191)
LOCATE 2, 26
PRINT CHR$(179); "TOWER OF HANOI"; CHR$(179)
LOCATE 3, 26
PRINT CHR$(192); STRING$(14, CHR$(196)); CHR$(217)
PRINT STRING$(80, CHR$(196))
PRINT
PRINT "1: AI"
PRINT "2: HUMAN"
PRINT STRING$(20, CHR$(196))
WHILE CHOICE <> 1 AND CHOICE <> 2
INPUT "CHOOSE ONE: ", CHOICE
WEND
IF CHOICE = 1 THEN CALL AI ELSE CALL PLAYGAME

SUB AI
CALL SHOWDISKS
CALL MOVEPILE(8, 0, 2)
END SUB

SUB MOVEDISK (START, FINISH)
TOWERS(FINISH, TOP(FINISH) + 1) = TOWERS(START, TOP(START))
TOP(FINISH) = TOP(FINISH) + 1
TOWERS(START, TOP(START)) = 0
TOP(START) = TOP(START) - 1
CALL SHOWDISKS
T! = TIMER
WHILE TIMER - T! < .2:
IF INKEY$ = CHR$(27) THEN END
WEND
END SUB

SUB MOVEPILE (N, START, FINISH)
IF N > 1 THEN CALL MOVEPILE(N - 1, START, 3 - START - FINISH)
CALL MOVEDISK(START, FINISH)
IF N > 1 THEN CALL MOVEPILE(N - 1, 3 - START - FINISH, FINISH)
END SUB

SUB PLAYGAME
CALL SHOWDISKS
DO
LOCATE 1, 1
COLOR 7
PRINT "TYPE NUMBER OF START PEG FOLLOWED BY NUMBER OF END PEG"
PRINT "LEFT = 1", "MIDDLE = 2", "RIGHT=3"
DO
KEY$ = INKEY$
SELECT CASE KEY$
CASE CHR$(27)
END
CASE "1"
START = 0
EXIT DO
CASE "2"
START = 1
EXIT DO
CASE "3"
START = 2
EXIT DO
END SELECT
LOOP
DO
KEY$ = INKEY$
SELECT CASE KEY$
CASE CHR$(27)
END
CASE "1"
FINISH = 0
EXIT DO
CASE "2"
FINISH = 1
EXIT DO
CASE "3"
FINISH = 2
EXIT DO
END SELECT
LOOP
IF TOP(FINISH) > 0 THEN
IF TOWERS(START, TOP(START)) >= TOWERS(FINISH, TOP(FINISH)) THEN GOTO 1
END IF
CALL MOVEDISK(START, FINISH)
IF TOP(0) = 0 AND TOP(1) = 0 THEN EXIT DO
IF TOP(0) = 0 AND TOP(2) = 0 THEN EXIT DO
1 LOOP
END SUB

SUB SHOWDISKS
CLS
LOCATE 25, 1
PRINT STRING$(80, CHR$(196));

FOR I = 1 TO TOP(0)
LOCATE 25 - I, I + 1
X = TOWERS(0, I)
IF X = 0 THEN EXIT FOR
COLOR COLORS(X): PRINT STRING$(X * 2, CHR$(219));
NEXT
FOR I = 1 TO TOP(1)
LOCATE 25 - I, I + NUMDISKS * 3
X = TOWERS(1, I)
IF X = 0 THEN EXIT FOR
COLOR COLORS(X): PRINT STRING$(X * 2, CHR$(219));
NEXT
FOR I = 1 TO TOP(2)
LOCATE 25 - I, I + NUMDISKS * 6
X = TOWERS(2, I)
IF X = 0 THEN EXIT FOR
COLOR COLORS(X): PRINT STRING$(X * 2, CHR$(219));
NEXT

END SUB

DECLARE SUB AUTO ()
DECLARE SUB PLAYGAME ()
DECLARE SUB MOVEPILE (N%, START%, FINISH%)
DECLARE SUB MOVEDISK (START%, FINISH%)
DECLARE SUB SHOWDISKS ()
DEFINT A-Z
CONST NUMDISKS = 8
DIM SHARED TOWERS(0 TO 2, 1 TO NUMDISKS), TOP(0 TO 2), COLORS(1 TO NUMDISKS)
CLS
TOP(0) = NUMDISKS: TOP(1) = 0: TOP(2) = 0
FOR I = 1 TO NUMDISKS
TOWERS(0, I) = NUMDISKS - I + 1
READ COLORS(I)
NEXT
DATA 6, 9, 4, 10, 11, 12, 13, 14
DATA 6, 9, 4, 10, 11, 12, 13, 14
LOCATE 1, 26
PRINT CHR$(218); STRING$(14, CHR$(196)); CHR$(191)
LOCATE 2, 26
PRINT CHR$(179); "TOWER OF HANOI"; CHR$(179)
LOCATE 3, 26
PRINT CHR$(192); STRING$(14, CHR$(196)); CHR$(217)
PRINT STRING$(80, CHR$(196))
PRINT
PRINT "1: AUTO"
PRINT "2: HUMAN"
PRINT STRING$(20, CHR$(196))
WHILE CHOICE <> 1 AND CHOICE <> 2
INPUT "CHOOSE ONE: ", CHOICE
WEND
IF CHOICE = 1 THEN CALL AUTO ELSE CALL PLAYGAME

SUB AUTO
CALL SHOWDISKS
CALL MOVEPILE(8, 0, 2)
END SUB

SUB MOVEDISK (START, FINISH)
TOWERS(FINISH, TOP(FINISH) + 1) = TOWERS(START, TOP(START))
TOP(FINISH) = TOP(FINISH) + 1
TOWERS(START, TOP(START)) = 0
TOP(START) = TOP(START) - 1
CALL SHOWDISKS
T! = TIMER
WHILE TIMER - T! < .2:
IF INKEY$ = CHR$(27) THEN END
WEND
END SUB

SUB MOVEPILE (N, START, FINISH)
IF N > 1 THEN CALL MOVEPILE(N - 1, START, 3 - START - FINISH)
CALL MOVEDISK(START, FINISH)
IF N > 1 THEN CALL MOVEPILE(N - 1, 3 - START - FINISH, FINISH)
END SUB

SUB PLAYGAME
CALL SHOWDISKS
DO
LOCATE 1, 1
COLOR 7
PRINT "TYPE NUMBER OF START PEG FOLLOWED BY NUMBER OF END PEG"
PRINT "LEFT = 1", "MIDDLE = 2", "RIGHT=3"
DO
KEY$ = INKEY$
SELECT CASE KEY$
CASE CHR$(27)
END
CASE "1"
START = 0
EXIT DO
CASE "2"
START = 1
EXIT DO
CASE "3"
START = 2
EXIT DO
END SELECT
LOOP
DO
KEY$ = INKEY$
SELECT CASE KEY$
CASE CHR$(27)
END
CASE "1"
FINISH = 0
EXIT DO
CASE "2"
FINISH = 1
EXIT DO
CASE "3"
FINISH = 2
EXIT DO
END SELECT
LOOP
IF TOP(START) = 0 THEN GOTO 1
IF TOP(FINISH) > 0 THEN
IF TOWERS(START, TOP(START)) >= TOWERS(FINISH, TOP(FINISH)) THEN GOTO 1
END IF
CALL MOVEDISK(START, FINISH)
IF TOP(0) = 0 AND TOP(1) = 0 THEN EXIT DO
IF TOP(0) = 0 AND TOP(2) = 0 THEN EXIT DO
1 LOOP
END SUB

SUB SHOWDISKS
CLS
LOCATE 25, 1
PRINT STRING$(80, CHR$(196));

FOR I = 1 TO TOP(0)
LOCATE 25 - I, I + 1
X = TOWERS(0, I)
IF X = 0 THEN EXIT FOR
COLOR COLORS(X): PRINT STRING$(X * 2, CHR$(219));
NEXT
FOR I = 1 TO TOP(1)
LOCATE 25 - I, I + NUMDISKS * 3
X = TOWERS(1, I)
IF X = 0 THEN EXIT FOR
COLOR COLORS(X): PRINT STRING$(X * 2, CHR$(219));
NEXT
FOR I = 1 TO TOP(2)
LOCATE 25 - I, I + NUMDISKS * 6
X = TOWERS(2, I)
IF X = 0 THEN EXIT FOR
COLOR COLORS(X): PRINT STRING$(X * 2, CHR$(219));
NEXT

END SUB

DECLARE SUB INSTRUCT ()
DECLARE SUB AUTO ()
DECLARE SUB PLAYGAME ()
DECLARE SUB MOVEPILE (N%, START%, FINISH%)
DECLARE SUB MOVEDISC (START%, FINISH%)
DECLARE SUB SHOWDISCS ()
DEFINT A-Z
CONST NUMDISCS = 8
DIM SHARED TOWERS(0 TO 2, 1 TO NUMDISCS), TOP(0 TO 2), COLORS(1 TO NUMDISCS), NUMMOVES AS LONG
CLS
TOP(0) = NUMDISCS: TOP(1) = 0: TOP(2) = 0
FOR I = 1 TO NUMDISCS
TOWERS(0, I) = NUMDISCS - I + 1
READ COLORS(I)
NEXT
DATA 6, 9, 4, 10, 11, 12, 13, 14
DATA 6, 9, 4, 10, 11, 12, 13, 14
LOCATE 1, 26
PRINT CHR$(218); STRING$(14, CHR$(196)); CHR$(191)
LOCATE 2, 26
PRINT CHR$(179); "TOWER OF HANOI"; CHR$(179)
LOCATE 3, 26
PRINT CHR$(192); STRING$(14, CHR$(196)); CHR$(217)
PRINT STRING$(80, CHR$(196))
PRINT
PRINT "1: AUTO"
PRINT "2: HUMAN"
PRINT STRING$(20, CHR$(196))
WHILE CHOICE <> 1 AND CHOICE <> 2
INPUT "CHOOSE ONE: ", CHOICE
WEND
IF CHOICE = 1 THEN CALL AUTO ELSE CALL PLAYGAME

SUB AUTO
CALL SHOWDISCS
CALL MOVEPILE(8, 0, 2)
END SUB

SUB INSTRUCT
PRINT "The TOWER OF HANOI is a mathematical game or puzzle. It consists"
PRINT "of three pegs and a number of discs which can slide onto any peg."
PRINT "The puzzle starts with the discs stacked in order of size on one peg."
PRINT
PRINT "The object of the game is to move the entire stack onto another peg,"
PRINT "obeying the following rules:"
PRINT TAB(2); CHR$(248); " Only one disc may be moved at a time."
PRINT TAB(2); CHR$(248); " Each move consists of taking the upper disc from"
PRINT TAB(4); "one peg and sliding it onto another peg, on top of any discs"
PRINT TAB(4); "that may already be on that peg."
PRINT TAB(2); CHR$(248); " No disc may be placed on top of another disc."
PRINT "PRESS ANY KEY TO CONTINUE..."
NULL$ = INPUT$(1)
END SUB

SUB MOVEDISC (START, FINISH)
DIM T AS SINGLE
TOWERS(FINISH, TOP(FINISH) + 1) = TOWERS(START, TOP(START))
TOP(FINISH) = TOP(FINISH) + 1
TOWERS(START, TOP(START)) = 0
TOP(START) = TOP(START) - 1
NUMMOVES = NUMMOVES + 1
CALL SHOWDISCS
T = TIMER
WHILE TIMER - T < .2:
IF INKEY$ = CHR$(27) THEN END
WEND
END SUB

SUB MOVEPILE (N, START, FINISH)
IF N > 1 THEN CALL MOVEPILE(N - 1, START, 3 - START - FINISH)
CALL MOVEDISC(START, FINISH)
IF N > 1 THEN CALL MOVEPILE(N - 1, 3 - START - FINISH, FINISH)
END SUB

SUB PLAYGAME
DO
INPUT "WOULD YOU LIKE INSTRUCTIONS"; NULL$
NULL$ = UCASE$(LEFT$(LTRIM$(NULL$), 1))
IF NULL$ = "Y" THEN CALL INSTRUCT: EXIT DO
IF NULL$ = "N" THEN EXIT DO
LOOP
CALL SHOWDISCS
DO
LOCATE 1, 1
COLOR 7
PRINT "TYPE NUMBER OF START PEG FOLLOWED BY NUMBER OF END PEG"
PRINT "LEFT = 1", "MIDDLE = 2", "RIGHT=3"
DO
KEY$ = INKEY$
SELECT CASE KEY$
CASE CHR$(27)
END
CASE "1"
START = 0
EXIT DO
CASE "2"
START = 1
EXIT DO
CASE "3"
START = 2
EXIT DO
END SELECT
LOOP
DO
KEY$ = INKEY$
SELECT CASE KEY$
CASE CHR$(27)
END
CASE "1"
FINISH = 0
EXIT DO
CASE "2"
FINISH = 1
EXIT DO
CASE "3"
FINISH = 2
EXIT DO
END SELECT
LOOP
IF TOP(START) = 0 THEN PRINT "There are no discs on that peg.": GOTO 1
IF START = FINISH THEN PRINT "The start peg is the same as the end peg.": GOTO 1
IF TOP(FINISH) > 0 THEN
IF TOWERS(START, TOP(START)) > TOWERS(FINISH, TOP(FINISH)) THEN PRINT "You may not put a larger disc on top of a smaller disc.": GOTO 1
END IF
CALL MOVEDISC(START, FINISH)
IF TOP(0) = 0 AND TOP(1) = 0 THEN EXIT DO
IF TOP(0) = 0 AND TOP(2) = 0 THEN EXIT DO
1 LOOP
END SUB

SUB SHOWDISCS
CLS
LOCATE 1, 60: PRINT "MOVES: "; NUMMOVES
LOCATE 25, 1
PRINT STRING$(80, CHR$(196));
FOR I = 1 TO TOP(0)
LOCATE 25 - I, I + 1
X = TOWERS(0, I)
IF X = 0 THEN EXIT FOR
COLOR COLORS(X): PRINT STRING$(X * 2, CHR$(219));
NEXT
FOR I = 1 TO TOP(1)
LOCATE 25 - I, I + NUMDISCS * 3
X = TOWERS(1, I)
IF X = 0 THEN EXIT FOR
COLOR COLORS(X): PRINT STRING$(X * 2, CHR$(219));
NEXT
FOR I = 1 TO TOP(2)
LOCATE 25 - I, I + NUMDISCS * 6
X = TOWERS(2, I)
IF X = 0 THEN EXIT FOR
COLOR COLORS(X): PRINT STRING$(X * 2, CHR$(219));
NEXT

END SUB

DECLARE SUB INSTRUCT ()
DECLARE SUB AUTO ()
DECLARE SUB PLAYGAME ()
DECLARE SUB MOVEPILE (N%, START%, FINISH%)
DECLARE SUB MOVEDISC (START%, FINISH%)
DECLARE SUB SHOWDISCS ()
DEFINT A-Z
CONST NUMDISCS = 8 ' alter this line to change number of discs
DIM SHARED TOWERS(0 TO 2, 1 TO NUMDISCS), TOP(0 TO 2), COLORS(1 TO NUMDISCS), NUMMOVES AS LONG
CLS
TOP(0) = NUMDISCS: TOP(1) = 0: TOP(2) = 0
FOR I = 1 TO NUMDISCS
TOWERS(0, I) = NUMDISCS - I + 1
READ COLORS(I)
NEXT
DATA 6, 9, 4, 10, 11, 12, 13, 14
DATA 6, 9, 4, 10, 11, 12, 13, 14
LOCATE 1, 26
PRINT CHR$(218); STRING$(14, CHR$(196)); CHR$(191)
LOCATE 2, 26
PRINT CHR$(179); "TOWER OF HANOI"; CHR$(179)
LOCATE 3, 26
PRINT CHR$(192); STRING$(14, CHR$(196)); CHR$(217)
PRINT STRING$(80, CHR$(196))
PRINT
PRINT "1: AUTO"
PRINT "2: HUMAN"
PRINT STRING$(20, CHR$(196))
WHILE CHOICE <> 1 AND CHOICE <> 2
INPUT "CHOOSE ONE: ", CHOICE
WEND
IF CHOICE = 1 THEN CALL AUTO ELSE CALL PLAYGAME

SUB AUTO
CALL SHOWDISCS
CALL MOVEPILE(NUMDISCS, 0, 2)
END SUB

SUB INSTRUCT
PRINT "The TOWER OF HANOI is a mathematical game or puzzle. It consists"
PRINT "of three pegs and a number of discs which can slide onto any peg."
PRINT "The puzzle starts with the discs stacked in order of size on one peg."
PRINT
PRINT "The object of the game is to move the entire stack onto another peg,"
PRINT "obeying the following rules:"
PRINT TAB(2); CHR$(248); " Only one disc may be moved at a time."
PRINT TAB(2); CHR$(248); " Each move consists of taking the upper disc from"
PRINT TAB(4); "one peg and sliding it onto another peg, on top of any discs"
PRINT TAB(4); "that may already be on that peg."
PRINT TAB(2); CHR$(248); " No disc may be placed on top of another disc."
PRINT "PRESS ANY KEY TO CONTINUE..."
NULL$ = INPUT$(1)
END SUB

SUB MOVEDISC (START, FINISH)
DIM T AS SINGLE
TOWERS(FINISH, TOP(FINISH) + 1) = TOWERS(START, TOP(START))
TOP(FINISH) = TOP(FINISH) + 1
TOWERS(START, TOP(START)) = 0
TOP(START) = TOP(START) - 1
NUMMOVES = NUMMOVES + 1
CALL SHOWDISCS
T = TIMER
WHILE TIMER - T < .2:
IF INKEY$ = CHR$(27) THEN END
WEND
END SUB

SUB MOVEPILE (N, START, FINISH)
IF N > 1 THEN CALL MOVEPILE(N - 1, START, 3 - START - FINISH)
CALL MOVEDISC(START, FINISH)
IF N > 1 THEN CALL MOVEPILE(N - 1, 3 - START - FINISH, FINISH)
END SUB

SUB PLAYGAME
DO
INPUT "WOULD YOU LIKE INSTRUCTIONS"; NULL$
NULL$ = UCASE$(LEFT$(LTRIM$(NULL$), 1))
IF NULL$ = "Y" THEN CALL INSTRUCT: EXIT DO
IF NULL$ = "N" THEN EXIT DO
LOOP
CALL SHOWDISCS
DO
LOCATE 1, 1
COLOR 7
PRINT "TYPE NUMBER OF START PEG FOLLOWED BY NUMBER OF END PEG"
PRINT "LEFT = 1", "MIDDLE = 2", "RIGHT=3"
DO
KEY$ = INKEY$
SELECT CASE KEY$
CASE CHR$(27)
END
CASE "1"
START = 0
EXIT DO
CASE "2"
START = 1
EXIT DO
CASE "3"
START = 2
EXIT DO
END SELECT
LOOP
DO
KEY$ = INKEY$
SELECT CASE KEY$
CASE CHR$(27)
END
CASE "1"
FINISH = 0
EXIT DO
CASE "2"
FINISH = 1
EXIT DO
CASE "3"
FINISH = 2
EXIT DO
END SELECT
LOOP
IF TOP(START) = 0 THEN PRINT "There are no discs on that peg.": GOTO 1
IF START = FINISH THEN PRINT "The start peg is the same as the end peg.": GOTO 1
IF TOP(FINISH) > 0 THEN
IF TOWERS(START, TOP(START)) > TOWERS(FINISH, TOP(FINISH)) THEN PRINT "You may not put a larger disc on top of a smaller disc.": GOTO 1
END IF
CALL MOVEDISC(START, FINISH)
IF TOP(0) = 0 AND TOP(1) = 0 THEN EXIT DO
IF TOP(0) = 0 AND TOP(2) = 0 THEN EXIT DO
1 LOOP
END SUB

SUB SHOWDISCS
CLS
LOCATE 1, 60: PRINT "MOVES: "; NUMMOVES
LOCATE 25, 1
PRINT STRING$(80, CHR$(196));
FOR I = 1 TO TOP(0)
LOCATE 25 - I, I + 1
X = TOWERS(0, I)
IF X = 0 THEN EXIT FOR
COLOR COLORS(X): PRINT STRING$(X * 2, CHR$(219));
NEXT
FOR I = 1 TO TOP(1)
LOCATE 25 - I, I + NUMDISCS * 3
X = TOWERS(1, I)
IF X = 0 THEN EXIT FOR
COLOR COLORS(X): PRINT STRING$(X * 2, CHR$(219));
NEXT
FOR I = 1 TO TOP(2)
LOCATE 25 - I, I + NUMDISCS * 6
X = TOWERS(2, I)
IF X = 0 THEN EXIT FOR
COLOR COLORS(X): PRINT STRING$(X * 2, CHR$(219));
NEXT

END SUB

DECLARE FUNCTION DISTANCE% (S$, T$)
DECLARE FUNCTION MINIMUM% (A%, B%, C%)
DEFINT A-Z
OPEN "DICT.DAT" FOR INPUT AS #1
OPEN "RESULTS.TMP" FOR OUTPUT AS #2
INPUT SEARCH$
SEARCH$ = LTRIM$(RTRIM$(UCASE$(SEARCH$)))
WHILE NOT EOF(1)
INPUT #1, WORD$
WORD$ = UCASE$(WORD$)
IF DISTANCE(WORD$, SEARCH$) < 3 THEN PRINT #2, WORD$; " "
WEND
CLOSE #1
CLOSE #2
SHELL "FIND /I /C " + CHR$(34) + SEARCH$ + CHR$(32) + CHR$(34) + " RESULTS.TMP > FOUND.TMP"
OPEN "FOUND.TMP" FOR INPUT AS #1
INPUT #1, LINE$: INPUT #1, LINE$
IF INSTR(LINE$, " 0") THEN SHELL "MORE RESULTS.TMP": END ELSE PRINT "IN DICTIONARY"
CLOSE #1
SHELL "DEL *.TMP"
END

FUNCTION DISTANCE (S$, T$)
' RETURNS THE DAMERAU-LEVENSHTEIN DISTANCE BETWEEN TWO STRINGS
DIM D(0 TO LEN(S$), 0 TO LEN(T$))
FOR I = 0 TO LEN(S$)
D(I, 0) = I
NEXT
FOR J = 1 TO LEN(T$)
D(0, J) = J
NEXT
FOR I = 1 TO LEN(S$)
FOR J = 1 TO LEN(T$)
IF MID$(S$, I, 1) = MID$(T$, J, 1) THEN COST = 0 ELSE COST = 1
A = D(I - 1, J) + 1
IF J = LEN(T$) THEN B = 32767 ELSE B = D(I, J - 1) + 1
C = D(I - 1, J - 1) + COST
D(I, J) = MINIMUM(A, B, C)
IF I > 1 AND J > 1 THEN
IF MID$(S$, I, 1) = MID$(T$, J - 1, 1) AND MID$(S$, I - 1, 1) = MID$(T$, J, 1) THEN
D(I, J) = MINIMUM(D(I, J), D(I - 2, J - 2) + COST, 32767)
END IF
END IF
NEXT
NEXT
DISTANCE = D(LEN(S$), LEN(T$))
END FUNCTION

FUNCTION MINIMUM (A, B, C)
MI = A
IF B < MI THEN MI = B
IF C < MI THEN MI = C
MINIMUM = MI
END FUNCTION

DECLARE SUB SCRAMBLE ()
DECLARE SUB GIVEUP ()
DECLARE SUB UP ()
DECLARE SUB DOWN ()
DECLARE SUB ROTATE (ROW%)
DEFINT A-Z
DIM SHARED PUZZLE(0 TO 5, 0 TO 5)
DIM COLORS(-1 TO 5)
CLS
FOR I = 0 TO 5
READ COLORS(I)
FOR J = 0 TO 5
PUZZLE(I, J) = J
NEXT
NEXT
DATA 8, 15, 12, 14, 10, 9
PUZZLE(5, 5) = -1
DO
CLS
FOR I = 0 TO 5
PRINT I + 1;
FOR J = 0 TO 5
COLOR COLORS(PUZZLE(I, J))
PRINT CHR$(219);
NEXT
COLOR 7: PRINT
NEXT
PRINT
PRINT "Instructions:"
PRINT STRING$(13, 196)
PRINT " "; CHR$(254); " The object of the game is to restore the puzzle back to its initial state"
PRINT SPACE$(3); "from a scrambled state."
PRINT " "; CHR$(254); " To scramble the puzzle, press S."
PRINT " "; CHR$(254); " To give up and reset the puzzle, type R."
PRINT " "; CHR$(254); " To shift a row right, press the number of that row."
PRINT " "; CHR$(254); " To move a tile up into the blank space, press the up arrow key."
PRINT " "; CHR$(254); " To move a tile down into the blank space, press the down arrow key."
N$ = ""
WHILE N$ = ""
N$ = INKEY$
WEND
SELECT CASE N$
CASE "R", "r"
CALL GIVEUP
CASE "S", "s"
CALL SCRAMBLE
CASE "1"
CALL ROTATE(0)
CASE "2"
CALL ROTATE(1)
CASE "3"
CALL ROTATE(2)
CASE "4"
CALL ROTATE(3)
CASE "5"
CALL ROTATE(4)
CASE "6"
CALL ROTATE(5)
CASE CHR$(0) + CHR$(72)
CALL UP
CASE CHR$(0) + CHR$(80)
CALL DOWN
CASE CHR$(27)
END
END SELECT
LOOP

SUB DOWN
FOR I = 0 TO 5
FOR J = 0 TO 5
K = PUZZLE(I, J)
IF K = -1 THEN GOTO 2
NEXT
NEXT
2 IF I = 0 THEN EXIT SUB
SWAP PUZZLE(I - 1, J), PUZZLE(I, J)
END SUB

SUB GIVEUP
FOR I = 0 TO 5
FOR J = 0 TO 5
PUZZLE(I, J) = J
NEXT
NEXT
PUZZLE(5, 5) = -1
END SUB

SUB ROTATE (ROW)
FOR I = 1 TO 5
SWAP PUZZLE(ROW, 0), PUZZLE(ROW, I)
NEXT
END SUB

SUB SCRAMBLE
FOR I = 1 TO 1000
J = INT(RND(1) * 7)
SELECT CASE J
CASE 0 TO 5
CALL ROTATE(J)
CASE 6
CALL UP
CASE 7
CALL DOWN
END SELECT
NEXT
END SUB

SUB UP
FOR I = 0 TO 5
FOR J = 0 TO 5
K = PUZZLE(I, J)
IF K = -1 THEN GOTO 1
NEXT
NEXT
1 IF I = 5 THEN EXIT SUB
SWAP PUZZLE(I + 1, J), PUZZLE(I, J)
END SUB

DECLARE SUB SCRAMBLE ()
DECLARE SUB GIVEUP ()
DECLARE SUB UP ()
DECLARE SUB DOWN ()
DECLARE SUB ROTATE (ROW%)
DEFINT A-Z
DIM SHARED PUZZLE(0 TO 5, 0 TO 5)
DIM COLORS(-1 TO 5)
CLS
FOR I = 0 TO 5
READ COLORS(I)
FOR J = 0 TO 5
PUZZLE(I, J) = J
NEXT
NEXT
DATA 8, 15, 12, 14, 10, 9
PUZZLE(5, 5) = -1
DO
CLS
FOR I = 0 TO 5
PRINT I + 1;
FOR J = 0 TO 5
COLOR COLORS(PUZZLE(I, J))
PRINT CHR$(219);
NEXT
COLOR 7: PRINT
NEXT
PRINT
PRINT "Instructions:"
PRINT STRING$(13, 196)
PRINT " "; CHR$(254); " The object of the game is to restore the puzzle back to its initial state"
PRINT SPACE$(3); "from a scrambled state."
PRINT " "; CHR$(254); " To scramble the puzzle, press S."
PRINT " "; CHR$(254); " To give up and reset the puzzle, type R."
PRINT " "; CHR$(254); " To shift a row right, press the number of that row."
PRINT " "; CHR$(254); " To move a tile up into the blank space, press the up arrow key."
PRINT " "; CHR$(254); " To move a tile down into the blank space, press the down arrow key."
N$ = ""
WHILE N$ = ""
N$ = INKEY$
WEND
SELECT CASE N$
CASE "R", "r"
CALL GIVEUP
CASE "S", "s"
CALL SCRAMBLE
CASE "1"
CALL ROTATE(0)
CASE "2"
CALL ROTATE(1)
CASE "3"
CALL ROTATE(2)
CASE "4"
CALL ROTATE(3)
CASE "5"
CALL ROTATE(4)
CASE "6"
CALL ROTATE(5)
CASE CHR$(0) + CHR$(72)
CALL UP
CASE CHR$(0) + CHR$(80)
CALL DOWN
CASE CHR$(27)
END
END SELECT
LOOP

SUB DOWN
FOR I = 0 TO 5
FOR J = 0 TO 5
K = PUZZLE(I, J)
IF K = -1 THEN GOTO 2
NEXT
NEXT
2 IF I = 0 THEN EXIT SUB
SWAP PUZZLE(I - 1, J), PUZZLE(I, J)
END SUB

SUB GIVEUP
FOR I = 0 TO 5
FOR J = 0 TO 5
PUZZLE(I, J) = J
NEXT
NEXT
PUZZLE(5, 5) = -1
END SUB

SUB ROTATE (ROW)
FOR I = 1 TO 5
SWAP PUZZLE(ROW, 0), PUZZLE(ROW, I)
NEXT
END SUB

SUB SCRAMBLE
FOR I = 1 TO 1000
J = INT(RND(1) * 8)
SELECT CASE J
CASE 0 TO 5
CALL ROTATE(J)
CASE 6
CALL UP
CASE 7
CALL DOWN
END SELECT
NEXT
END SUB

DECLARE SUB SCRAMBLE ()
DECLARE SUB GIVEUP ()
DECLARE SUB UP ()
DECLARE SUB DOWN ()
DECLARE SUB ROTATE (ROW%)
DEFINT A-Z
DIM SHARED PUZZLE(0 TO 5, 0 TO 5)
DIM COLORS(-1 TO 5)
CLS
FOR I = 0 TO 5
READ COLORS(I)
FOR J = 0 TO 5
PUZZLE(I, J) = J
NEXT
NEXT
DATA 8, 15, 12, 14, 10, 9
PUZZLE(5, 5) = -1
DO
CLS
FOR I = 0 TO 5
PRINT I + 1;
FOR J = 0 TO 5
COLOR COLORS(PUZZLE(I, J))
PRINT CHR$(219);
NEXT
COLOR 7: PRINT
NEXT
PRINT
PRINT "Instructions:"
PRINT STRING$(13, 196)
PRINT " "; CHR$(254); " The object of the game is to restore the puzzle back to its initial state"
PRINT SPACE$(3); "from a scrambled state."
PRINT " "; CHR$(254); " To scramble the puzzle, press S."
PRINT " "; CHR$(254); " To give up and reset the puzzle, type R."
PRINT " "; CHR$(254); " To shift a row right, press the number of that row."
PRINT " "; CHR$(254); " To move a tile up into the blank space, press the up arrow key."
PRINT " "; CHR$(254); " To move a tile down into the blank space, press the down arrow key."
N$ = ""
WHILE N$ = ""
N$ = INKEY$
WEND
SELECT CASE N$
CASE "R", "r"
CALL GIVEUP
CASE "S", "s"
CALL SCRAMBLE
CASE "1"
CALL ROTATE(0)
CASE "2"
CALL ROTATE(1)
CASE "3"
CALL ROTATE(2)
CASE "4"
CALL ROTATE(3)
CASE "5"
CALL ROTATE(4)
CASE "6"
CALL ROTATE(5)
CASE CHR$(0) + CHR$(72)
CALL UP
CASE CHR$(0) + CHR$(80)
CALL DOWN
CASE CHR$(27)
END
END SELECT
LOOP

SUB DOWN
FOR I = 0 TO 5
FOR J = 0 TO 5
K = PUZZLE(I, J)
IF K = -1 THEN GOTO 2
NEXT
NEXT
2 IF I = 0 THEN EXIT SUB
SWAP PUZZLE(I - 1, J), PUZZLE(I, J)
END SUB

SUB GIVEUP
FOR I = 0 TO 5
FOR J = 0 TO 5
PUZZLE(I, J) = J
NEXT
NEXT
PUZZLE(5, 5) = -1
END SUB

SUB ROTATE (ROW)
FOR I = 1 TO 5
SWAP PUZZLE(ROW, 0), PUZZLE(ROW, I)
NEXT
END SUB

SUB SCRAMBLE
FOR I = 1 TO 1000
J = INT(RND(1) * 8)
SELECT CASE J
CASE 0 TO 5
CALL ROTATE(J)
CASE 6
CALL UP
CASE 7
CALL DOWN
END SELECT
NEXT
END SUB

SUB UP
FOR I = 0 TO 5
FOR J = 0 TO 5
K = PUZZLE(I, J)
IF K = -1 THEN GOTO 1
NEXT
NEXT
1 IF I = 5 THEN EXIT SUB
SWAP PUZZLE(I + 1, J), PUZZLE(I, J)
END SUB

DECLARE SUB ROTCUBE (AXIS%)
DECLARE SUB SCRAMBLE ()
DECLARE FUNCTION GETFAC% (X%, Y%)
DECLARE SUB DISPLAY ()
DECLARE SUB ROTATE (FAC%, ROT%)
DECLARE SUB INIT ()
DECLARE SUB MIDLAYER (FAC%)
DECLARE SUB MOUSE (N%)

DEFINT A-Z

TYPE REGTYPE
  AX AS INTEGER
  BX AS INTEGER
  CX AS INTEGER
  DX AS INTEGER
  BP AS INTEGER
  SI AS INTEGER
  DI AS INTEGER
  FLAGS AS INTEGER
  DS AS INTEGER
  ES AS INTEGER
END TYPE

DIM SHARED REGS AS REGTYPE
DIM SHARED C(1 TO 6, 1 TO 3, 1 TO 3), F(1 TO 6, 1 TO 4)
DIM SHARED X(1 TO 6, 1 TO 3, 1 TO 3), Y(1 TO 6, 1 TO 3, 1 TO 3)

F(1, 1) = 5: F(1, 2) = 4: F(1, 3) = 6: F(1, 4) = 3
F(2, 1) = 4: F(2, 2) = 5: F(2, 3) = 3: F(2, 4) = 6
F(3, 1) = 1: F(3, 2) = 6: F(3, 3) = 2: F(3, 4) = 5
F(4, 1) = 6: F(4, 2) = 1: F(4, 3) = 5: F(4, 4) = 2
F(5, 1) = 3: F(5, 2) = 2: F(5, 3) = 4: F(5, 4) = 1
F(6, 1) = 2: F(6, 2) = 3: F(6, 3) = 1: F(6, 4) = 4

CALL INIT
CALL MOUSE(0) 'MOUSE RESET
CALL MOUSE(1) 'SHOW MOUSE
DO
  CALL DISPLAY
  REGS.BX = 0
  WHILE REGS.BX = 0
    CALL MOUSE(3)
    IF INKEY$ = CHR$(27) THEN END
  WEND
  FAC = GETFAC(REGS.CX \ 8 + 1, REGS.DX \ 8 + 1)
  PRINT FAC
  SELECT CASE FAC
    CASE -1
      CALL SCRAMBLE
    CASE -2
      CALL INIT
    CASE -3
      CALL ROTCUBE(1)
    CASE -4
      CALL ROTCUBE(2)
    CASE -5
      CALL ROTCUBE(3)
    CASE 1 TO 6
      IF REGS.BX = 1 THEN CALL ROTATE(FAC, 1)
      IF REGS.BX = 2 THEN CALL ROTATE(FAC, 3)
  END SELECT
  T! = TIMER + .25
  WHILE T! > TIMER: WEND

LOOP

SUB DISPLAY
  CLS
  FOR I = 3 TO 1 STEP -1
    LOCATE , 4
    FOR J = 3 TO 1 STEP -1
      COLOR C(1, J, I)
      PRINT CHR$(219);
    NEXT
    PRINT
  NEXT
  LOCATE 4
  FOR I = 1 TO 3
    FOR J = 3 TO 1 STEP -1
      COLOR C(3, J, I)
      PRINT CHR$(219);
    NEXT
    PRINT
  NEXT
  LOCATE 4
  FOR I = 1 TO 3
    LOCATE , 4
    FOR J = 1 TO 3
      COLOR C(5, I, J)
      PRINT CHR$(219);
    NEXT
    PRINT
  NEXT
  LOCATE 4
  FOR I = 3 TO 1 STEP -1
    LOCATE , 7
    FOR J = 3 TO 1 STEP -1
      COLOR C(4, I, J)
      PRINT CHR$(219);
    NEXT
    PRINT
  NEXT
  LOCATE 4
  FOR I = 3 TO 1 STEP -1
    LOCATE , 10
    FOR J = 3 TO 1 STEP -1
      COLOR C(6, J, I)
      PRINT CHR$(219);
    NEXT
    PRINT
  NEXT
  LOCATE 7
  FOR I = 3 TO 1 STEP -1
    LOCATE , 4
    FOR J = 1 TO 3
      COLOR C(2, I, J)
      PRINT CHR$(219);
    NEXT
    PRINT
  NEXT
  COLOR 7
  LOCATE 11, 1
  PRINT CHR$(218); STRING$(8, 196); CHR$(191)
  PRINT CHR$(179); "Scramble"; CHR$(179)
  PRINT CHR$(192); STRING$(8, 196); CHR$(217)
  LOCATE 11, 11
  PRINT CHR$(218); STRING$(10, 196); CHR$(191)
  LOCATE , 11
  PRINT CHR$(179); "Reset Cube"; CHR$(179)
  LOCATE , 11
  PRINT CHR$(192); STRING$(10, 196); CHR$(217)
  LOCATE 11, 23
  PRINT CHR$(218); STRING$(10, 196); CHR$(191)
  LOCATE , 23
  PRINT CHR$(179); " Rotate X "; CHR$(179)
  LOCATE , 23
  PRINT CHR$(192); STRING$(10, 196); CHR$(217)
  LOCATE 11, 35
  PRINT CHR$(218); STRING$(10, 196); CHR$(191)
  LOCATE , 35
  PRINT CHR$(179); " Rotate Y "; CHR$(179)
  LOCATE , 35
  PRINT CHR$(192); STRING$(10, 196); CHR$(217)
  LOCATE 11, 47
  PRINT CHR$(218); STRING$(10, 196); CHR$(191)
  LOCATE , 47
  PRINT CHR$(179); " Rotate Z "; CHR$(179)
  LOCATE , 47
  PRINT CHR$(192); STRING$(10, 196); CHR$(217)
END SUB

FUNCTION GETFAC (X, Y)
  IF X >= 4 AND X <= 6 AND Y >= 1 AND Y <= 3 THEN GETFAC = 1: EXIT FUNCTION
  IF X >= 4 AND X <= 6 AND Y >= 7 AND Y <= 9 THEN GETFAC = 2: EXIT FUNCTION
  IF X >= 1 AND X <= 3 AND Y >= 4 AND Y <= 6 THEN GETFAC = 3: EXIT FUNCTION
  IF X >= 7 AND X <= 9 AND Y >= 4 AND Y <= 6 THEN GETFAC = 4: EXIT FUNCTION
  IF X >= 4 AND X <= 6 AND Y >= 4 AND Y <= 6 THEN GETFAC = 5: EXIT FUNCTION
  IF X >= 10 AND X <= 12 AND Y >= 4 AND Y <= 6 THEN GETFAC = 6: EXIT FUNCTION
  IF X >= 1 AND X <= 10 AND Y >= 11 AND Y <= 14 THEN GETFAC = -1: EXIT FUNCTION
  IF X >= 11 AND X <= 22 AND Y >= 11 AND Y <= 14 THEN GETFAC = -2: EXIT FUNCTION
  IF X >= 23 AND X <= 34 AND Y >= 11 AND Y <= 14 THEN GETFAC = -3: EXIT FUNCTION
  IF X >= 35 AND X <= 46 AND Y >= 11 AND Y <= 14 THEN GETFAC = -4: EXIT FUNCTION
  IF X >= 47 AND X <= 58 AND Y >= 11 AND Y <= 14 THEN GETFAC = -5: EXIT FUNCTION

END FUNCTION

SUB INIT
  FOR N = 1 TO 6
    FOR I = 1 TO 3
      FOR J = 1 TO 3
        C(N, I, J) = N
      NEXT
    NEXT
  NEXT
END SUB

SUB MIDLAYER (FAC)
 T1 = C(F(FAC, 1), 2, 1): T2 = C(F(FAC, 1), 2, 2)
 T3 = C(F(FAC, 1), 2, 3)    'store temps
 C(F(FAC, 1), 2, 1) = C(F(FAC, 2), 2, 3)
 C(F(FAC, 1), 2, 2) = C(F(FAC, 2), 2, 2)
 C(F(FAC, 1), 2, 3) = C(F(FAC, 2), 2, 1)

 C(F(FAC, 2), 2, 3) = C(F(FAC, 3), 1, 2)
 C(F(FAC, 2), 2, 2) = C(F(FAC, 3), 2, 2)
 C(F(FAC, 2), 2, 1) = C(F(FAC, 3), 3, 2)

 C(F(FAC, 3), 1, 2) = C(F(FAC, 4), 3, 2)
 C(F(FAC, 3), 2, 2) = C(F(FAC, 4), 2, 2)
 C(F(FAC, 3), 3, 2) = C(F(FAC, 4), 1, 2)

 C(F(FAC, 4), 3, 2) = T1: C(F(FAC, 4), 2, 2) = T2
 C(F(FAC, 4), 1, 2) = T3
END SUB

SUB MOUSE (N)
  REGS.AX = N
  CALL INTERRUPT(&H33, REGS, REGS)
' If this bombs, ensure you are using "qb /L" (qb4.5) or better
END SUB

SUB ROTATE (FAC, ROT)
 DIM T1, T2, T3         'TEMPS FOR 1ST SQUARES
 FOR N = 1 TO ROT     '1, 2 OR 3 TIMES 90 DEG.
  T1 = C(FAC, 1, 1): T2 = C(FAC, 2, 1)'FACE SQUARES
  C(FAC, 1, 1) = C(FAC, 3, 1): C(FAC, 2, 1) = C(FAC, 3, 2)
  C(FAC, 3, 1) = C(FAC, 3, 3): C(FAC, 3, 2) = C(FAC, 2, 3)
  C(FAC, 3, 3) = C(FAC, 1, 3): C(FAC, 2, 3) = C(FAC, 1, 2)
  C(FAC, 1, 3) = T1: C(FAC, 1, 2) = T2
 'ROTATE ADJACENT SQUARES OF ADJACENT FACES
  T1 = C(F(FAC, 1), 1, 1): T2 = C(F(FAC, 1), 1, 2)
  T3 = C(F(FAC, 1), 1, 3)    'STORE TEMPS
  C(F(FAC, 1), 1, 1) = C(F(FAC, 2), 3, 3)
  C(F(FAC, 1), 1, 2) = C(F(FAC, 2), 3, 2)
  C(F(FAC, 1), 1, 3) = C(F(FAC, 2), 3, 1)

  C(F(FAC, 2), 3, 3) = C(F(FAC, 3), 1, 3)
  C(F(FAC, 2), 3, 2) = C(F(FAC, 3), 2, 3)
  C(F(FAC, 2), 3, 1) = C(F(FAC, 3), 3, 3)

  C(F(FAC, 3), 1, 3) = C(F(FAC, 4), 3, 1)
  C(F(FAC, 3), 2, 3) = C(F(FAC, 4), 2, 1)
  C(F(FAC, 3), 3, 3) = C(F(FAC, 4), 1, 1)
  C(F(FAC, 4), 3, 1) = T1: C(F(FAC, 4), 2, 1) = T2
  C(F(FAC, 4), 1, 1) = T3  'RECOVER TEMPS
 NEXT
END SUB

SUB ROTCUBE (AXIS)
  SELECT CASE AXIS
    CASE 1
      CALL ROTATE(5, 1)
      CALL MIDLAYER(5)
      CALL ROTATE(6, 3)
    CASE 2
      CALL ROTATE(3, 1)
      CALL MIDLAYER(3)
      CALL ROTATE(4, 3)
    CASE 3
      CALL ROTATE(1, 1)
      CALL MIDLAYER(1)
      CALL ROTATE(2, 3)
  END SELECT
END SUB

SUB SCRAMBLE
  FOR I = 1 TO 1000
    A = INT(RND * 6) + 1
    B = INT(RND * 3) + 1
    CALL ROTATE(A, B)
  NEXT
END SUB

DEFINT A-Z 'default integers
DECLARE SUB Init ()
DECLARE SUB Redraw ()
DECLARE SUB Grafic ()
DECLARE SUB MouseLimit ()
DECLARE SUB mouse (axx)
DECLARE SUB Rotate (fac, rot)
DECLARE SUB MidLayer (fac)
DECLARE SUB PrStr (st$, row)
DECLARE SUB Solve ()
DECLARE SUB RotCube ()
DECLARE SUB Rotpr (fac, rot)
DECLARE SUB Edges1 ()
DECLARE SUB Corners1 ()
DECLARE SUB Edges2 ()
DECLARE SUB Edges2a ()
DECLARE SUB Corners3 ()
DECLARE SUB Edges3 ()
DECLARE SUB Twirls ()
DECLARE SUB Flips ()
DIM SHARED face(6) AS STRING * 7
DIM SHARED ang(3) AS STRING * 3
DIM SHARED blank AS STRING * 22
DIM SHARED c(6, 3, 3), f(6, 4)
DIM SHARED x(6, 3, 3), y(6, 3, 3)
DIM SHARED a(1 TO 17)
FOR i = 1 TO 17: READ a(i): NEXT
DATA -18288,0,13261,-23762,26
DATA -30418,7198,11776,3721,30
DATA -30418,8214,-13568,0,0,0,0
DIM SHARED b(1 TO 8)
FOR i = 1 TO 8: READ b(i): NEXT
DATA -18288,0,-18032,0,-17776,0
DATA 13261,203
DIM SHARED pause, count
SCREEN 12 'VGA 640x480
mouse 0 'Reset mouse driver
MouseLimit
Grafic 'draw initial cube
DO 'the program loop
mouse 1 'show mouse
DO: mouse 3
LOOP UNTIL a(15) > 0
TIM! = TIMER + .33 'float tim
DO: LOOP UNTIL TIMER > TIM!
click = a(15)
cxx = a(16): dxx = a(17)
mouse 2 'hide mouse
IF click < 2 THEN
fac = INT((cxx + 8) / 56)
rot = INT((dxx - 16) / 16)
LOCATE 1, 1: PRINT fac; rot
IF fac > 0 AND fac < 8 THEN
IF rot > 0 AND rot < 5 THEN
IF fac = 7 THEN
IF rot = 1 THEN Init 'Reset
IF rot > 2 THEN Solve
IF rot = 2 THEN
pause = 1 - pause
IF pause = 1 THEN
PrStr "Pause ON ", 1
ELSE
PrStr "Pause OFF", 1
END IF
END IF
ELSE
IF rot < 4 THEN
Rotate fac, rot 'rotate face
ELSE 'rotate cube
IF fac < 3 THEN opp = 3 - fac
IF fac > 2 THEN opp = 7 - fac
IF fac > 4 THEN opp = 11 - fac
Rotate fac, 1'face clock
Rotate opp, 3'opp. anti
MidLayer fac 'middle,clock
END IF
END IF
END IF
END IF
Redraw 'recolour all squares
END IF
LOOP UNTIL click = 2
CLS : SCREEN 0 'back to text

SUB Corners1
' Rotate cube about vertical to 4 positions.
' At each, note correct u/f/r, find it (8 poss.
' locations) and moves it to d/f/r initially.
PrStr "Top layer corners", 3: uc = c(1, 2, 2)
FOR n = 1 TO 4: fc = c(5, 2, 2): rc = c(4, 2, 2)
'U & F & R centre colours. u/f/r corner
'must have same 3 colours, i, j & k.
'Even if u/f/r is correct , move it to d/f/r
i = c(1, 3, 1): j = c(5, 1, 3): k = c(4, 3, 3)
IF i = uc OR j = uc OR k = uc THEN '|copy
IF i = fc OR j = fc OR k = fc THEN '|
IF i = rc OR j = rc OR k = rc THEN '|
PrStr "Move u/f/r to d/f/r ", 4
PrStr "ie. R-1DR ", 5
Rotpr 4, 3: Rotpr 2, 1: Rotpr 4, 1
END IF '|copy
END IF '|
END IF '|
'if u/b/r is correct u/f/r, move it to d/f/r
i = c(1, 3, 3): j = c(6, 1, 3): k = c(4, 3, 1)
'copy 3 IF statements
IF i = uc OR j = uc OR k = uc THEN '|copy
IF i = fc OR j = fc OR k = fc THEN '|
IF i = rc OR j = rc OR k = rc THEN '|
PrStr "Move u/b/r to d/f/r ", 4
PrStr "ie. B-1D-1B ", 5
Rotpr 6, 3: Rotpr 2, 3: Rotpr 6, 1
'copy 3 END IFs
END IF '|copy
END IF '|
END IF '|
'if u/b/l is correct u/f/r, move it to d/f/r
i = c(1, 1, 3): j = c(6, 3, 3): k = c(3, 3, 1)
'copy 3 IF statements
IF i = uc OR j = uc OR k = uc THEN '|copy
IF i = fc OR j = fc OR k = fc THEN '|
IF i = rc OR j = rc OR k = rc THEN '|
PrStr "Move u/b/l to d/f/r ", 4
PrStr "ie. L-1D2L ", 5
Rotpr 3, 3: Rotpr 2, 2: Rotpr 3, 1
'copy 3 END IFs
END IF '|copy
END IF '|
END IF '|
'if u/f/l is correct u/f/r, move it to d/f/r
i = c(1, 1, 1): j = c(5, 1, 1): k = c(3, 1, 1)
'copy 3 IF statements
IF i = uc OR j = uc OR k = uc THEN '|copy
IF i = fc OR j = fc OR k = fc THEN '|
IF i = rc OR j = rc OR k = rc THEN '|
PrStr "Move u/f/l to d/f/r ", 4
PrStr "ie. LDL-1 ", 5
Rotpr 3, 1: Rotpr 2, 1: Rotpr 3, 3
'copy 3 END IFs
END IF '|copy
END IF '|
END IF '|
'if d/b/r is correct u/f/r, move it to d/f/r
i = c(2, 1, 1): j = c(6, 1, 1): k = c(4, 1, 1)
'copy 3 IF statements
IF i = uc OR j = uc OR k = uc THEN '|copy
IF i = fc OR j = fc OR k = fc THEN '|
IF i = rc OR j = rc OR k = rc THEN '|
PrStr "Move d/b/r to d/f/r ", 4
PrStr "ie. D-1 ", 5
Rotpr 2, 3
'copy 3 END IFs
END IF '|copy
END IF '|
END IF '|
'if d/b/l is correct u/f/r, move it to d/f/r
i = c(2, 1, 3): j = c(6, 3, 1): k = c(3, 3, 3)
'copy 3 IF statements
IF i = uc OR j = uc OR k = uc THEN '|copy
IF i = fc OR j = fc OR k = fc THEN '|
IF i = rc OR j = rc OR k = rc THEN '|
PrStr "Move d/b/l to d/f/r ", 4
PrStr "ie. D2 ", 5
Rotpr 2, 2
'copy 3 END IFs
END IF '|copy
END IF '|
END IF '|
'if d/f/l is correct u/f/r, move it to d/f/r
i = c(2, 3, 3): j = c(5, 3, 1): k = c(3, 1, 3)
'copy 3 IF statements
IF i = uc OR j = uc OR k = uc THEN '|copy
IF i = fc OR j = fc OR k = fc THEN '|
IF i = rc OR j = rc OR k = rc THEN '|
PrStr "Move d/f/l to d/f/r ", 4
PrStr "ie. D ", 5
Rotpr 2, 1
'copy 3 END IFs
END IF '|copy
END IF '|
END IF '|
' --------- u/f/r cube now at d/f/r. ----------
' --------- So move to it to u/f/r ----------
PrStr "Move d/f/r to u/f/r ", 4
IF c(2, 3, 1) = uc THEN 'if uc colour on D
'face, it must be moved to R face
PrStr "ie. R-1DRD2 ", 5
Rotpr 4, 3: Rotpr 2, 1: Rotpr 4, 1: Rotpr 2, 2
END IF
IF c(5, 3, 3) = uc THEN 'if uc colour on F
PrStr "ie. FDF-1 ", 5
Rotpr 5, 1: Rotpr 2, 1: Rotpr 5, 3'move to u/r
END IF
IF c(4, 1, 3) = uc THEN 'if uc colour on R
PrStr "ie. R-1D-1R ", 5
Rotpr 4, 3: Rotpr 2, 3: Rotpr 4, 1'move to u/r
END IF
IF n < 4 THEN RotCube
NEXT n
PrStr blank, 3: PrStr blank, 4
PrStr blank, 5: PrStr blank, 6
END SUB

SUB Corners3
PrStr "Sort top corners", 3: n = 0: order = 0
DO UNTIL (order > 900 AND order < 1100) OR order = 1111
n = n + 1 'number of loop
IF n > 1 THEN RotCube 'rotate whole cube
'is u/r/f in correct position ?
t1 = c(4, 2, 2): t2 = c(5, 2, 2)'r & f colours
i = c(1, 3, 1): j = c(5, 1, 3): k = c(4, 3, 3)
IF i = t1 OR j = t1 OR k = t1 THEN
IF i = t2 OR j = t2 OR k = t2 THEN order = 1000
END IF
'is u/r/b in correct position ?
t1 = c(4, 2, 2): t2 = c(6, 2, 2)'r & b colours
i = c(1, 3, 3): j = c(4, 3, 1): k = c(6, 1, 3)
IF i = t1 OR j = t1 OR k = t1 THEN
IF i = t2 OR j = t2 OR k = t2 THEN order = order + 100
END IF
'is u/l/b in correct position ?
t1 = c(3, 2, 2): t2 = c(6, 2, 2)'l & b colours
i = c(1, 1, 3): j = c(3, 3, 1): k = c(6, 3, 3)
IF i = t1 OR j = t1 OR k = t1 THEN
IF i = t2 OR j = t2 OR k = t2 THEN order = order + 10
END IF
'is u/l/f in correct position ?
t1 = c(5, 2, 2): t2 = c(3, 2, 2)'l & f colours
i = c(1, 1, 1): j = c(3, 1, 1): k = c(5, 1, 1)
IF i = t1 OR j = t1 OR k = t1 THEN
IF i = t2 OR j = t2 OR k = t2 THEN order = order + 1
END IF
IF order = 0 THEN 'no corners correct
PrStr "Rotate top layer only ", 4
Rotpr 1, 1: n = 0: PrStr blank, 4: PrStr blank, 6
END IF 'ie. need to go around loop again
LOOP
LOCATE 2, 58: PRINT "Order is "; order
SELECT CASE order
CASE 1000: 'only u/r/f correct so other 3
'must circulate - clock or anticlock?
lc = c(3, 2, 2): bc = c(6, 2, 2)'l & b colours
IF c(1, 1, 1) = lc OR c(3, 1, 1) = lc OR c(5, 1, 1) = lc THEN
IF c(1, 1, 1) = bc OR c(3, 1, 1) = bc OR c(5, 1, 1) = bc THEN
PrStr "ie. L-1URU-1LUR-1U-1 ", 5
'u/l/f goes clockw. to u/l/b
Rotpr 3, 3: Rotpr 1, 1: Rotpr 4, 1: Rotpr 1, 3
Rotpr 3, 1: Rotpr 1, 1: Rotpr 4, 3: Rotpr 1, 3
END IF
END IF
IF c(1, 3, 3) = lc OR c(4, 3, 1) = lc OR c(6, 1, 3) = lc THEN
IF c(1, 3, 3) = bc OR c(4, 3, 1) = bc OR c(6, 1, 3) = bc THEN
PrStr "ie. URU-1L-1UR-1U-1L ", 5
'u/r/b goes anticl. to u/l/b
Rotpr 1, 1: Rotpr 4, 1: Rotpr 1, 3: Rotpr 3, 3
Rotpr 1, 1: Rotpr 4, 3: Rotpr 1, 3: Rotpr 3, 1
END IF
END IF
CASE 1001: 'u/r/f and u/l/f correct
PrStr "ie. FU-1B-1UF-1U-1BU2 ", 5
Rotpr 5, 1: Rotpr 1, 3: Rotpr 6, 3: Rotpr 1, 1
Rotpr 5, 3: Rotpr 1, 3: Rotpr 6, 1: Rotpr 1, 2
CASE 1010: 'u/r/f and u/l/b correct
PrStr "ie. UFURU-1R-1F-1 ", 5
Rotpr 1, 1: Rotpr 5, 1: Rotpr 1, 1: Rotpr 4, 1
Rotpr 1, 3: Rotpr 4, 3: Rotpr 5, 3
END SELECT
PrStr blank, 3: PrStr blank, 4
PrStr blank, 5: PrStr blank, 6
END SUB

SUB Edges1
'locate u/f edge cube (23 other possible
'positions/orientations) and move to u/f
PrStr "Top layer edges", 3: uc = c(1, 2, 2) 'U &
FOR n = 1 TO 4: fc = c(5, 2, 2) '..F Centre colours
'if at u/f but flipped. (If not flipped, leave it)
IF c(1, 2, 1) = fc AND c(5, 1, 2) = uc THEN
PrStr "Flip u/f cube ", 4: PrStr "ie. F2LD-1L-1F", 5
Rotpr 5, 2: Rotpr 3, 1: Rotpr 2, 3: Rotpr 3, 3: Rotpr 5, 1
END IF
'if at r/f (2 orientations at each position)
IF c(4, 2, 3) = uc AND c(5, 2, 3) = fc THEN
PrStr "Move r/f to u/f", 4: PrStr "ie. F-1 ", 5
Rotpr 5, 3
END IF
IF c(4, 2, 3) = fc AND c(5, 2, 3) = uc THEN
PrStr "Move r/f to u/f", 4: PrStr "ie. FLD-1L-1F", 5
Rotpr 5, 1: Rotpr 3, 1: Rotpr 2, 3: Rotpr 3, 3: Rotpr 5, 1
END IF
'if at d/f
IF c(2, 3, 2) = uc AND c(5, 3, 2) = fc THEN
PrStr "Move d/f to u/f", 4: PrStr "ie. F2 ", 5
Rotpr 5, 2
END IF
IF c(2, 3, 2) = fc AND c(5, 3, 2) = uc THEN
PrStr "Move d/f to u/f", 4: PrStr "ie. LD-1L-1F ", 5
Rotpr 3, 1: Rotpr 2, 3: Rotpr 3, 3: Rotpr 5, 1
END IF
'if at l/f
IF c(3, 1, 2) = uc AND c(5, 2, 1) = fc THEN
PrStr "Move l/f to u/f", 4: PrStr "ie. F ", 5
Rotpr 5, 1
END IF
IF c(3, 1, 2) = fc AND c(5, 2, 1) = uc THEN
PrStr "Move l/f to u/f", 4: PrStr "ie.F-1LD-1L-1F", 5
Rotpr 5, 3: Rotpr 3, 1: Rotpr 2, 3: Rotpr 3, 3: Rotpr 5, 1
END IF
'if at d/l
IF c(2, 2, 3) = fc AND c(3, 2, 3) = uc THEN
PrStr "Move d/l to u/f", 4: PrStr "ie. L-1FL ", 5
Rotpr 3, 3: Rotpr 5, 1: Rotpr 3, 1
END IF
IF c(2, 2, 3) = uc AND c(3, 2, 3) = fc THEN
PrStr "Move d/l to u/f", 4: PrStr "ie. DF2 ", 5
Rotpr 2, 1: Rotpr 5, 2
END IF
'if at d/b
IF c(2, 1, 2) = uc AND c(6, 2, 1) = fc THEN
PrStr "Move d/b to u/f", 4: PrStr "ie. D2F2 ", 5
Rotpr 2, 2: Rotpr 5, 2
END IF
IF c(2, 1, 2) = fc AND c(6, 2, 1) = uc THEN
PrStr "Move d/b to u/f", 4: PrStr "ie. DL-1FL ", 5
Rotpr 2, 1: Rotpr 3, 3: Rotpr 5, 1: Rotpr 3, 1
END IF
'if at d/r
IF c(2, 2, 1) = fc AND c(4, 1, 2) = uc THEN
PrStr "Move d/r to u/f", 4: PrStr "ie. RF-1R-1 ", 5
Rotpr 4, 1: Rotpr 5, 3: Rotpr 4, 3
END IF
IF c(2, 2, 1) = uc AND c(4, 1, 2) = fc THEN
PrStr "Move d/r to u/f", 4: PrStr "ie. D-1F2 ", 5
Rotpr 2, 3: Rotpr 5, 2
END IF
'if at b/r
IF c(4, 2, 1) = fc AND c(6, 1, 2) = uc THEN
PrStr "Move b/r to u/f", 4: PrStr "ie. RD-1F2R-1", 5
Rotpr 4, 1: Rotpr 2, 3: Rotpr 5, 2: Rotpr 4, 3
END IF
IF c(4, 2, 1) = uc AND c(6, 1, 2) = fc THEN
PrStr "Move b/r to u/f", 4: PrStr "ie. R2F-1R2 ", 5
Rotpr 4, 2: Rotpr 5, 3: Rotpr 4, 2
END IF
'if at b/l
IF c(3, 3, 2) = fc AND c(6, 3, 2) = uc THEN
PrStr "Move b/l to u/f", 4: PrStr "ie. L-1DF2L ", 5
Rotpr 3, 3: Rotpr 2, 1: Rotpr 5, 2: Rotpr 3, 1
END IF
IF c(3, 3, 2) = uc AND c(6, 3, 2) = fc THEN
PrStr "Move b/l to u/f", 4: PrStr "ie. L2FL2 ", 5
Rotpr 3, 2: Rotpr 5, 1: Rotpr 3, 2
END IF
'if at l/u
IF c(3, 2, 1) = fc AND c(1, 1, 2) = uc THEN
PrStr "Move l/u to u/f", 4: PrStr "ie. L2DF2 ", 5
Rotpr 3, 2: Rotpr 2, 1: Rotpr 5, 2
END IF
IF c(3, 2, 1) = uc AND c(1, 1, 2) = fc THEN
PrStr "Move l/u to u/f", 4: PrStr "ie. LF ", 5
Rotpr 3, 1: Rotpr 5, 1
END IF
'if at b/u
IF c(6, 2, 3) = fc AND c(1, 2, 3) = uc THEN
PrStr "Move b/u to u/f", 4: PrStr "ie. B2D2F2 ", 5
Rotpr 6, 2: Rotpr 2, 2: Rotpr 5, 2
END IF
IF c(6, 2, 3) = uc AND c(1, 2, 3) = fc THEN
PrStr "Move b/u to u/f", 4: PrStr "ie. BL-1DLF2 ", 5
Rotpr 6, 1: Rotpr 3, 3: Rotpr 2, 1: Rotpr 3, 1: Rotpr 5, 2
END IF
'if at r/u
IF c(4, 3, 2) = fc AND c(1, 3, 2) = uc THEN
PrStr "Move r/u to u/f", 4: PrStr "ie. R2D-1F2 ", 5
Rotpr 4, 2: Rotpr 2, 3: Rotpr 5, 2
END IF
IF c(4, 3, 2) = uc AND c(1, 3, 2) = fc THEN
PrStr "Move r/u to u/f", 4: PrStr "ie. R-1F-1 ", 5
Rotpr 4, 3: Rotpr 5, 3
END IF
IF n < 4 THEN RotCube
NEXT n
PrStr blank, 3: PrStr blank, 4: PrStr blank, 5: PrStr blank, 6
END SUB

SUB Edges2
PrStr "Invert whole cube", 3'about L face axis
MidLayer 5: MidLayer 5 'need 2 x 90 deg.
Rotate 6, 2: Rotpr 5, 2: PrStr blank, 6
'The sorted layer is now on the bottom.
PrStr "Middle layer edges", 3 'tell the user
'Rotating about vert. to 4 separate positions
FOR n = 1 TO 4: lc = c(3, 2, 2): fc = c(5, 2, 2)
'First check 4 middle edge positions for l/f.
'if l/f in correct position and orientation,
'leave it. Otherwise, move it to top layer.
'First, if l/f in position but flipped
IF c(3, 1, 2) = fc AND c(5, 2, 1) = lc THEN
PrStr "l/f to top layer ", 4
PrStr "ie. FU2RUR-1U2F-1 ", 5
Rotpr 5, 1: Rotpr 1, 2: Rotpr 4, 1: Rotpr 1, 1
Rotpr 4, 3: Rotpr 1, 2: Rotpr 5, 3
END IF
'Now, check other 3 vertical edge positions
'if l/f at r/f, move to top layer
IF c(4, 2, 3) = fc OR c(5, 2, 3) = fc THEN
IF c(4, 2, 3) = lc OR c(5, 2, 3) = lc THEN
PrStr "r/f to top layer ", 4
PrStr "ie RU2BUB-1U2R-1 ", 5
Rotpr 4, 1: Rotpr 1, 2: Rotpr 6, 1: Rotpr 1, 1
Rotpr 6, 3: Rotpr 1, 2: Rotpr 4, 3
END IF
END IF
'if l/f at r/b, move to top layer
IF c(4, 2, 1) = fc OR c(6, 1, 2) = fc THEN
IF c(4, 2, 1) = lc OR c(6, 1, 2) = lc THEN
PrStr "r/b to top layer ", 4
PrStr "ie. BU2LUL-1U2B-1 ", 5
Rotpr 6, 1: Rotpr 1, 2: Rotpr 3, 1: Rotpr 1, 1
Rotpr 3, 3: Rotpr 1, 2: Rotpr 6, 3
END IF
END IF
'if l/f at l/b, move to top layer
IF c(3, 3, 2) = fc OR c(6, 3, 2) = fc THEN
IF c(3, 3, 2) = lc OR c(6, 3, 2) = lc THEN
PrStr "l/b to top layer ", 4
PrStr "ie. LU2FUF-1U2L-1 ", 5
Rotpr 3, 1: Rotpr 1, 2: Rotpr 5, 1: Rotpr 1, 1
Rotpr 5, 3: Rotpr 1, 2: Rotpr 3, 3
END IF
END IF
'NOW, find l/f in top layer, transfer to u/r,
'then to l/f using Edges2a()
IF c(4, 3, 2) = fc OR c(1, 3, 2) = fc THEN
IF c(4, 3, 2) = lc OR c(1, 3, 2) = lc THEN
Edges2a 'candidate already at u/l
END IF
END IF
IF c(6, 2, 3) = fc OR c(1, 2, 3) = fc THEN
IF c(6, 2, 3) = lc OR c(1, 2, 3) = lc THEN
PrStr "u/b to u/r ", 4
Rotpr 1, 1: Edges2a 'candidate at u/l
END IF
END IF
IF c(3, 2, 1) = fc OR c(1, 1, 2) = fc THEN
IF c(3, 2, 1) = lc OR c(1, 1, 2) = lc THEN
PrStr "u/l to u/r ", 4
Rotpr 1, 2: Edges2a 'candidate at u/l
END IF
END IF
IF c(5, 1, 2) = fc OR c(1, 2, 1) = fc THEN
IF c(5, 1, 2) = lc OR c(1, 2, 1) = lc THEN
PrStr "u/f to u/r ", 4
Rotpr 1, 3: Edges2a 'candidate at u/f
END IF
END IF
IF n < 4 THEN RotCube
NEXT n
PrStr blank, 3: PrStr blank, 4
PrStr blank, 5: PrStr blank, 6
END SUB

SUB Edges2a 'After Edges2() puts l/f cube to
' u/r position, this puts it in correct
' position and correct orientation.
PrStr "u/r to l/f ", 4
IF c(1, 3, 2) = c(3, 2, 2) THEN 'U face of u/r
PrStr "ie. FU2RUR-1U2F-1 ", 5 'is lc
Rotpr 5, 1: Rotpr 1, 2: Rotpr 4, 1: Rotpr 1, 1
Rotpr 4, 3: Rotpr 1, 2: Rotpr 5, 3
ELSE 'ie. U face of u/r = fc colour
PrStr "ie. UFU2RU-1R-1U2F-1 ", 5
Rotpr 1, 1: Rotpr 5, 1: Rotpr 1, 2: Rotpr 4, 1
Rotpr 1, 3: Rotpr 4, 3: Rotpr 1, 2: Rotpr 5, 3
END IF
END SUB

SUB Edges3
PrStr "Sort top edge cubes", 3: correct = 0
'first note centre colours of faces F, R, B & L
fc = c(5, 2, 2): rc = c(4, 2, 2): bc = c(6, 2, 2): lc = c(3, 2, 2)
'find which cubes are in correct position
IF c(1, 2, 1) = fc OR c(5, 1, 2) = fc THEN correct = 1000
IF c(1, 3, 2) = rc OR c(4, 3, 2) = rc THEN correct = correct + 100
IF c(1, 2, 3) = bc OR c(6, 2, 3) = bc THEN correct = correct + 10
IF c(1, 1, 2) = lc OR c(3, 2, 1) = lc THEN correct = correct + 1
IF correct = 0 THEN 'none of cubes in right place
IF c(1, 2, 1) = rc OR c(5, 1, 2) = rc THEN 'if u/r at u/f
RotCube 'rotate whole cube. note new centre colours
fc = c(5, 2, 2): rc = c(4, 2, 2): bc = c(6, 2, 2): lc = c(3, 2, 2)
END IF
IF c(1, 2, 1) = bc OR c(5, 1, 2) = bc THEN 'if u/b at u/f
PrStr "R2L2DR2L2U2R2L2DR2L2 ", 5'swap opposite pairs
Rotpr 4, 2: Rotpr 3, 2: Rotpr 2, 1: Rotpr 4, 2
Rotpr 3, 2: Rotpr 1, 2: Rotpr 4, 2: Rotpr 3, 2
Rotpr 2, 1: Rotpr 4, 2: Rotpr 3, 2
END IF
IF c(1, 2, 1) = lc OR c(5, 1, 2) = lc THEN 'if u/l at u/f
PrStr "RBUB-1U-1R2F-1U-1FUR ", 5'swap adjacent pairs
Rotpr 4, 1: Rotpr 6, 1: Rotpr 1, 1: Rotpr 6, 3
Rotpr 1, 3: Rotpr 4, 2: Rotpr 5, 3: Rotpr 1, 3
Rotpr 5, 1: Rotpr 1, 1: Rotpr 4, 1
END IF
END IF
SELECT CASE correct 'One cube only correct. Rotate
'whole cube to put it at u/r position
CASE 1000: RotCube: RotCube: RotCube
CASE 10: RotCube
CASE 1: RotCube: RotCube
END SELECT 'in effect, now correct = 100
bc = c(6, 2, 2): lc = c(3, 2, 2)'centre colours of B & L
IF c(1, 2, 1) = bc OR c(5, 1, 2) = bc THEN 'if u/b at u/f
PrStr "L2U-1F-1BL2FB-1U-1L2 ", 5 'circulate anticlock
Rotpr 3, 2: Rotpr 1, 3: Rotpr 5, 3: Rotpr 6, 1: Rotpr 3, 2
Rotpr 5, 1: Rotpr 6, 3: Rotpr 1, 3: Rotpr 3, 2
END IF
IF c(1, 2, 1) = lc OR c(5, 1, 2) = lc THEN 'if u/l at u/f
PrStr "ie. L2UF-1BL2FB-1UL2 ", 5 'circulate clockwise
Rotpr 3, 2: Rotpr 1, 1: Rotpr 5, 3: Rotpr 6, 1: Rotpr 3, 2
Rotpr 5, 1: Rotpr 6, 3: Rotpr 1, 1: Rotpr 3, 2
END IF
PrStr blank, 3: PrStr blank, 4
PrStr blank, 5: PrStr blank, 6
END SUB

SUB Flips 'flips top edge cubes
uc = c(1, 2, 2) 'colour of U centre
DO UNTIL c(1, 2, 1) = uc AND c(1, 1, 2) = uc AND c(1, 2, 3) = uc AND c(1, 3, 2) = uc
n = 0 'ie. until all top faces match uc
DO UNTIL c(1, 2, 1) = c(5, 2, 2) OR n = 4
n = n + 1: RotCube 'until u/f needs flip
LOOP 'if n reaches 4, all are correct
'cubes needing flip always occur in pairs
IF n < 4 THEN 'u/f needs flip. Find other
IF c(1, 3, 2) = c(4, 2, 2) THEN
other = 4 'u/r needs flip
PrStr "u/f & u/r need flip ", 2
ELSE
IF c(1, 2, 3) = c(6, 2, 2) THEN
other = 6 'u/b needs flip
PrStr "u/f & u/b need flip ", 2
ELSE
other = 3 'u/l needs flip
PrStr "u/f & u/l need flip ", 2
END IF
END IF
PrStr "Flip pair top edges ", 4
PrStr "Firstly FUD-1L2U2D2R ", 5
Rotpr 5, 1: Rotpr 1, 1: Rotpr 2, 3: Rotpr 3, 2
Rotpr 1, 2: Rotpr 2, 2: Rotpr 4, 1
PrStr "2nd of pair to u/r ", 5
IF other = 4 THEN Rotpr 1, 1
IF other = 6 THEN Rotpr 1, 2
IF other = 3 THEN Rotpr 1, 3
PrStr "Now R-1D2U2L2DU-1F-1", 5
Rotpr 4, 3: Rotpr 2, 2: Rotpr 1, 2: Rotpr 3, 2
Rotpr 2, 1: Rotpr 1, 3: Rotpr 5, 3
IF other = 4 THEN Rotpr 1, 3
IF other = 6 THEN Rotpr 1, 2
IF other = 3 THEN Rotpr 1, 1
PrStr blank, 2
END IF
LOOP
PrStr blank, 3: PrStr blank, 4
PrStr blank, 5: PrStr blank, 6
END SUB

SUB Grafic
' face name strings in face(6) array
face(1) = " UP ": face(2) = " DOWN "
face(3) = " LEFT ": face(4) = " RIGHT "
face(5) = " FRONT ": face(6) = " BACK "
ang(1) = "+90": ang(2) = "180": ang(3) = "-90"
' blank = " " '22 spaces
blank = SPACE$(22)
' each face's adjacent faces, anticlockwise
f(1, 1) = 5: f(1, 2) = 4: f(1, 3) = 6: f(1, 4) = 3
f(2, 1) = 4: f(2, 2) = 5: f(2, 3) = 3: f(2, 4) = 6
f(3, 1) = 1: f(3, 2) = 6: f(3, 3) = 2: f(3, 4) = 5
f(4, 1) = 6: f(4, 2) = 1: f(4, 3) = 5: f(4, 4) = 2
f(5, 1) = 3: f(5, 2) = 2: f(5, 3) = 4: f(5, 4) = 1
f(6, 1) = 2: f(6, 2) = 3: f(6, 3) = 1: f(6, 4) = 4
CLS : COLOR 15 'now print top table
PrStr "Rightclick to QUIT ", 7
LOCATE 6, 7: PRINT "Rotate whole cube 90"
LOCATE 6, 34: PRINT "Clock wise"
FOR n = 1 TO 6
LOCATE 1, n * 7: PRINT face(n)
LOCATE 2, n * 7 + 2: PRINT n
LOCATE 3, n * 7 + 2: PRINT ang(1)
LOCATE 4, n * 7 + 2: PRINT ang(2)
LOCATE 5, n * 7 + 2: PRINT ang(3)
LINE (n * 56 - 9, 32)-STEP(50, 16), 15, B
LINE (n * 56 - 9, 48)-STEP(50, 16), 15, B
LINE (n * 56 - 9, 64)-STEP(50, 16), 15, B
LINE (n * 56 - 9, 80)-STEP(50, 16), 15, B
NEXT n
LOCATE 3, 50: PRINT "RESET"
LINE (383, 32)-STEP(56, 16), 15, B
LOCATE 4, 50: PRINT "PAUSE"
LINE (383, 48)-STEP(56, 16), 15, B
LOCATE 5, 50: PRINT "SOLVE"
LINE (383, 64)-STEP(56, 32), 15, B
' now print face labels
LOCATE 11, 7: PRINT face(1)
LOCATE 11, 28: PRINT face(1)
LOCATE 25, 67: PRINT face(2)
LOCATE 25, 48: PRINT face(2)
LOCATE 27, 8: PRINT face(3)
LOCATE 9, 69: PRINT face(4)
LOCATE 27, 27: PRINT face(5)
LOCATE 9, 46: PRINT face(6)
LOCATE 8, 15: PRINT "OUTSIDE VIEW"
LOCATE 27, 55: PRINT "INSIDE VIEW"
' draw the cube - 9 times
dx = 40: dx3 = 3 * dx: dy = 24: dy3 = 3 * dy
xs = 20: ys = 24: ys2 = 2 * ys: ys6 = 6 * ys: c = 15
FOR xl = 159 TO 161: xr = xl + 320
FOR yl = 288 TO 290: yr = yl - 30
FOR i = 0 TO 3:
LINE (xl - i * dx, yl - i * dy)-STEP(0, ys6), c
LINE (xl - i * dx, yl - i * dy)-STEP(dx3, -dy3), c
LINE (xl + i * dx, yl - i * dy)-STEP(0, ys6), c
LINE (xl + i * dx, yl - i * dy)-STEP(-dx3, -dy3), c
LINE (xl, yl + i * ys2)-STEP(dx3, -dy3), c
LINE (xl, yl + i * ys2)-STEP(-dx3, -dy3), c
LINE (xr - i * dx, yr + i * dy)-STEP(0, -ys6), c
LINE (xr - i * dx, yr + i * dy)-STEP(dx3, dy3), c
LINE (xr + i * dx, yr + i * dy)-STEP(0, -ys6), c
LINE (xr + i * dx, yr + i * dy)-STEP(-dx3, dy3), c
LINE (xr, yr - i * ys2)-STEP(dx3, dy3), c
LINE (xr, yr - i * ys2)-STEP(-dx3, dy3), c
NEXT i: NEXT yl: NEXT xl
sx = xl - xr: sy = yl - yr'draw dashed lines
LINE (xr, yr - ys6)-STEP(sx, sy), c, , &H700
LINE (xr + dx3, yr - dy3)-STEP(sx, sy), c, , &H700
LINE (xr + dx3, yr + dy3)-STEP(sx, sy), c, , &H700
LINE (xr, yr + ys6)-STEP(sx, sy), c, , &H700
LINE (xr - dx3, yr - dy3)-STEP(sx / 3, sy / 3), c, , &H700
LINE (xr - dx3, yr + dy3)-STEP(sx / 4, sy / 4), c, , &H700
' starting coords to paint each square
FOR i = 1 TO 3: FOR j = 1 TO 3
x(1, i, j) = xl + i * dx - j * dx
y(1, i, j) = yl + dy - i * dy - j * dy
x(2, i, j) = xr - j * dx + i * dx
y(2, i, j) = yr - dy + i * dy + j * dy
x(3, i, j) = xl + xs - i * dx
y(3, i, j) = yl - ys + j * ys2 - i * dy
x(4, i, j) = xr - xs + j * dx
y(4, i, j) = yr + ys - i * ys2 + j * dy
x(5, i, j) = xl - xs + j * dx
y(5, i, j) = yl - ys + i * ys2 - j * dy
x(6, i, j) = xr + xs - i * dx
y(6, i, j) = yr + ys - j * ys2 + i * dy
NEXT j: NEXT i
Init 'set original colours
Redraw 'paint all squares
END SUB

SUB Init
FOR n = 1 TO 6: FOR i = 1 TO 3: FOR j = 1 TO 3
c(n, i, j) = n: NEXT j: NEXT i: NEXT n
END SUB

SUB MidLayer (fac)
t1 = c(f(fac, 1), 2, 1): t2 = c(f(fac, 1), 2, 2)
t3 = c(f(fac, 1), 2, 3) 'store temps
c(f(fac, 1), 2, 1) = c(f(fac, 2), 2, 3)
c(f(fac, 1), 2, 2) = c(f(fac, 2), 2, 2)
c(f(fac, 1), 2, 3) = c(f(fac, 2), 2, 1)
c(f(fac, 2), 2, 3) = c(f(fac, 3), 1, 2)
c(f(fac, 2), 2, 2) = c(f(fac, 3), 2, 2)
c(f(fac, 2), 2, 1) = c(f(fac, 3), 3, 2)
c(f(fac, 3), 1, 2) = c(f(fac, 4), 3, 2)
c(f(fac, 3), 2, 2) = c(f(fac, 4), 2, 2)
c(f(fac, 3), 3, 2) = c(f(fac, 4), 1, 2)
c(f(fac, 4), 3, 2) = t1: c(f(fac, 4), 2, 2) = t2
c(f(fac, 4), 1, 2) = t3
END SUB

SUB mouse (axx) 'Reset, show or hide mouse
a(2) = axx 'sets register ax
DEF SEG = VARSEG(a(1)) 'find address
CALL ABSOLUTE(VARPTR(a(1)))
DEF SEG 'bx,cx,dx now in a(15 to 17)
END SUB

SUB MouseLimit 'Restrict mouse to top panel
b(2) = 7: b(4) = 60: b(6) = 420 'ax,cx,dx
DEF SEG = VARSEG(b(1)) 'find address
CALL ABSOLUTE(VARPTR(b(1)))
DEF SEG 'x moves restricted
b(2) = 8: b(4) = 40: b(6) = 88 'ax,cx,dx
DEF SEG = VARSEG(b(1)) 'find address
CALL ABSOLUTE(VARPTR(b(1)))
DEF SEG 'y moves restricted
END SUB

SUB PrStr (st$, row) 'Prints a string, col 58
LOCATE row, 58: PRINT st$
END SUB

SUB Redraw 'recolour all squares
FOR n = 1 TO 6: FOR i = 1 TO 3: FOR j = 1 TO 3
PAINT (x(n, i, j), y(n, i, j)), c(n, i, j), 15
NEXT j: NEXT i: NEXT n
END SUB

SUB Rotate (fac, rot)
DIM t1, t2, t3 'temps for 1st squares
FOR n = 1 TO rot '1, 2 or 3 times 90 deg.
t1 = c(fac, 1, 1): t2 = c(fac, 2, 1)'face squares
c(fac, 1, 1) = c(fac, 3, 1): c(fac, 2, 1) = c(fac, 3, 2)
c(fac, 3, 1) = c(fac, 3, 3): c(fac, 3, 2) = c(fac, 2, 3)
c(fac, 3, 3) = c(fac, 1, 3): c(fac, 2, 3) = c(fac, 1, 2)
c(fac, 1, 3) = t1: c(fac, 1, 2) = t2
'rotate adjacent squares of adjacent faces
t1 = c(f(fac, 1), 1, 1): t2 = c(f(fac, 1), 1, 2)
t3 = c(f(fac, 1), 1, 3) 'store temps
c(f(fac, 1), 1, 1) = c(f(fac, 2), 3, 3)
c(f(fac, 1), 1, 2) = c(f(fac, 2), 3, 2)
c(f(fac, 1), 1, 3) = c(f(fac, 2), 3, 1)
c(f(fac, 2), 3, 3) = c(f(fac, 3), 1, 3)
c(f(fac, 2), 3, 2) = c(f(fac, 3), 2, 3)
c(f(fac, 2), 3, 1) = c(f(fac, 3), 3, 3)
c(f(fac, 3), 1, 3) = c(f(fac, 4), 3, 1)
c(f(fac, 3), 2, 3) = c(f(fac, 4), 2, 1)
c(f(fac, 3), 3, 3) = c(f(fac, 4), 1, 1)
c(f(fac, 4), 3, 1) = t1: c(f(fac, 4), 2, 1) = t2
c(f(fac, 4), 1, 1) = t3 'recover temps
NEXT
END SUB

SUB RotCube 'rotate about vertical axis
PrStr "Rotate whole cube +90 ", 6
PrStr blank, 4: PrStr blank, 5
IF pause = 1 THEN
DO: mouse 3 'get left click
LOOP UNTIL a(15) = 1
END IF
Rotate 1, 1: MidLayer 1: Rotate 2, 3
Redraw
PrStr blank, 6
END SUB

SUB Rotpr (fac, rot)
count = count + 1: LOCATE 1, 1: PRINT count; " "
LOCATE 6, 58: PRINT "Rotate "; face(fac); ang(rot)
IF pause = 1 THEN
DO: mouse 3: LOOP UNTIL a(15) = 1
TIM! = TIMER + .33: DO: LOOP UNTIL TIMER > TIM!
END IF
Rotate fac, rot: Redraw
END SUB

SUB Solve
count = 0 'set move counter to zero
IF pause = 1 THEN PrStr "Leftclick to go on", 7
Edges1 'Top edge cubes
Corners1 'Top corner cubes
Edges2 'Invert cube. Middle layer edges
Corners3 'Top corners. Ignore orientation
Edges3 'Top edges. ditto
Flips 'Flip edges to correct orientation
Twirls 'Twirl corners to ditto
PrStr "Rightclick to QUIT ", 7 'restore
END SUB

SUB Twirls 'twirls top corner cubes
uc = c(1, 2, 2) 'U centre colour
DO 'outer loop
i = 0: j = 0: k = 0: l = 0
IF c(5, 1, 3) = uc THEN i = 1 'u/f/r
IF c(4, 3, 3) = uc THEN i = -1
IF c(4, 3, 1) = uc THEN j = 1 'u/r/b
IF c(6, 1, 3) = uc THEN j = -1
IF c(6, 3, 3) = uc THEN k = 1 'u/b/l
IF c(3, 3, 1) = uc THEN k = -1
IF c(3, 1, 1) = uc THEN l = 1 'u/l/f
IF c(5, 1, 1) = uc THEN l = -1
sum = ABS(i) + ABS(j) + ABS(k) + ABS(l)
SELECT CASE sum
CASE 4, 2:
DO UNTIL c(5, 1, 3) = uc 'until..
RotCube '..u/f/r needs clock twirl
LOOP
IF c(5, 1, 1) = uc THEN num = 3
'ie. u/l/f needs anticlock twirl
IF c(3, 3, 1) = uc THEN num = 2
'ie. u/b/l needs anticlock twirl
IF c(6, 1, 3) = uc THEN num = 1
'ie. u/r/b needs anticlock twirl
CASE 3: num = 1
END SELECT
LOCATE 2, 58: PRINT sum; num;
IF sum > 0 THEN
PrStr "Twirl two top corners ", 3
PrStr "First of pair (u/r) ", 4
PrStr "ie. R-1DRFDF-1 ", 5
Rotpr 4, 3: Rotpr 2, 1: Rotpr 4, 1
Rotpr 5, 1: Rotpr 2, 1: Rotpr 5, 3
PrStr "Move 2nd to u/r ", 4
PrStr blank, 5: Rotpr 1, num
PrStr "2nd of pair (u/r) ", 4
PrStr "ie. FD-1F-1R-1D-1R ", 5
Rotpr 5, 1: Rotpr 2, 3: Rotpr 5, 3
Rotpr 4, 3: Rotpr 2, 3: Rotpr 4, 1
PrStr "Move 2nd to orig. pos.", 4
PrStr blank, 5: Rotpr 1, 4 - num
END IF
LOOP UNTIL sum = 0
PrStr blank, 2: PrStr blank, 3
PrStr blank, 4: PrStr blank, 5
PrStr blank, 6:
END SUB

DEFINT A-Z 'default integers
DECLARE SUB Scramble ()
DECLARE SUB Init ()
DECLARE SUB Redraw ()
DECLARE SUB Grafic ()
DECLARE SUB MouseLimit ()
DECLARE SUB mouse (axx)
DECLARE SUB Rotate (fac, rot)
DECLARE SUB MidLayer (fac)
DECLARE SUB PrStr (st$, row)
DECLARE SUB Solve ()
DECLARE SUB RotCube ()
DECLARE SUB Rotpr (fac, rot)
DECLARE SUB Edges1 ()
DECLARE SUB Corners1 ()
DECLARE SUB Edges2 ()
DECLARE SUB Edges2a ()
DECLARE SUB Corners3 ()
DECLARE SUB Edges3 ()
DECLARE SUB Twirls ()
DECLARE SUB Flips ()
DIM SHARED face(6) AS STRING * 7
DIM SHARED ang(3) AS STRING * 3
DIM SHARED blank AS STRING * 22
DIM SHARED c(6, 3, 3), f(6, 4)
DIM SHARED x(6, 3, 3), y(6, 3, 3)
DIM SHARED a(1 TO 17)
RANDOMIZE TIMER
FOR I = 1 TO 17: READ a(I): NEXT
DATA -18288,0,13261,-23762,26
DATA -30418,7198,11776,3721,30
DATA -30418,8214,-13568,0,0,0,0
DIM SHARED B(1 TO 8)
FOR I = 1 TO 8: READ B(I): NEXT
DATA -18288,0,-18032,0,-17776,0
DATA 13261,203
DIM SHARED pause, count
SCREEN 12 'VGA 640x480
mouse 0 'Reset mouse driver
MouseLimit
Grafic 'draw initial cube
DO 'the program loop
mouse 1 'show mouse
DO: mouse 3
LOOP UNTIL a(15) > 0
TIM! = TIMER + .33 'float tim
DO: LOOP UNTIL TIMER > TIM!
click = a(15)
cxx = a(16): dxx = a(17)
mouse 2 'hide mouse
IF click < 2 THEN
FAC = INT((cxx + 8) / 56)
rot = INT((dxx - 16) / 16)
LOCATE 1, 1: PRINT FAC; rot
IF FAC > 0 AND FAC < 8 THEN
IF rot > 0 AND rot < 5 THEN
IF FAC = 7 THEN
IF rot = 1 THEN Init 'Reset
IF rot = 3 THEN Solve
IF rot = 4 THEN Scramble
IF rot = 2 THEN
pause = 1 - pause
IF pause = 1 THEN
PrStr "Pause ON ", 1
ELSE
PrStr "Pause OFF", 1
END IF
END IF
ELSE
IF rot < 4 THEN
ROTATE FAC, rot 'rotate face
ELSE 'rotate cube
IF FAC < 3 THEN opp = 3 - FAC
IF FAC > 2 THEN opp = 7 - FAC
IF FAC > 4 THEN opp = 11 - FAC
ROTATE FAC, 1'face clock
ROTATE opp, 3'opp. anti
MidLayer FAC 'middle,clock
END IF
END IF
END IF
END IF
Redraw 'recolour all squares
END IF
LOOP UNTIL click = 2
CLS : SCREEN 0 'back to text

SUB Corners1
'Rotate cube about vertical to 4 positions.
'At each, note correct u/f/r, find it (8 poss.
'locations) and moves it to d/f/r initially.
PrStr "Top layer corners", 3: uc = c(1, 2, 2)
FOR n = 1 TO 4: fc = c(5, 2, 2): rc = c(4, 2, 2)
'U & F & R centre colours. u/f/r corner
'must have same 3 colours, i, j & k.
'Even if u/f/r is correct , move it to d/f/r
I = c(1, 3, 1): J = c(5, 1, 3): k = c(4, 3, 3)
IF I = uc OR J = uc OR k = uc THEN '|copy
IF I = fc OR J = fc OR k = fc THEN '|
IF I = rc OR J = rc OR k = rc THEN '|
PrStr "Move u/f/r to d/f/r ", 4
PrStr "ie. R-1DR ", 5
Rotpr 4, 3: Rotpr 2, 1: Rotpr 4, 1
END IF '|copy
END IF '|
END IF '|
'if u/b/r is correct u/f/r, move it to d/f/r
I = c(1, 3, 3): J = c(6, 1, 3): k = c(4, 3, 1)
'copy 3 IF statements
IF I = uc OR J = uc OR k = uc THEN '|copy
IF I = fc OR J = fc OR k = fc THEN '|
IF I = rc OR J = rc OR k = rc THEN '|
PrStr "Move u/b/r to d/f/r ", 4
PrStr "ie. B-1D-1B ", 5
Rotpr 6, 3: Rotpr 2, 3: Rotpr 6, 1
'copy 3 END IFs
END IF '|copy
END IF '|
END IF '|
'if u/b/l is correct u/f/r, move it to d/f/r
I = c(1, 1, 3): J = c(6, 3, 3): k = c(3, 3, 1)
'copy 3 IF statements
IF I = uc OR J = uc OR k = uc THEN '|copy
IF I = fc OR J = fc OR k = fc THEN '|
IF I = rc OR J = rc OR k = rc THEN '|
PrStr "Move u/b/l to d/f/r ", 4
PrStr "ie. L-1D2L ", 5
Rotpr 3, 3: Rotpr 2, 2: Rotpr 3, 1
'copy 3 END IFs
END IF '|copy
END IF '|
END IF '|
'if u/f/l is correct u/f/r, move it to d/f/r
I = c(1, 1, 1): J = c(5, 1, 1): k = c(3, 1, 1)
'copy 3 IF statements
IF I = uc OR J = uc OR k = uc THEN '|copy
IF I = fc OR J = fc OR k = fc THEN '|
IF I = rc OR J = rc OR k = rc THEN '|
PrStr "Move u/f/l to d/f/r ", 4
PrStr "ie. LDL-1 ", 5
Rotpr 3, 1: Rotpr 2, 1: Rotpr 3, 3
'copy 3 END IFs
END IF '|copy
END IF '|
END IF '|
'if d/b/r is correct u/f/r, move it to d/f/r
I = c(2, 1, 1): J = c(6, 1, 1): k = c(4, 1, 1)
'copy 3 IF statements
IF I = uc OR J = uc OR k = uc THEN '|copy
IF I = fc OR J = fc OR k = fc THEN '|
IF I = rc OR J = rc OR k = rc THEN '|
PrStr "Move d/b/r to d/f/r ", 4
PrStr "ie. D-1 ", 5
Rotpr 2, 3
'copy 3 END IFs
END IF '|copy
END IF '|
END IF '|
'if d/b/l is correct u/f/r, move it to d/f/r
I = c(2, 1, 3): J = c(6, 3, 1): k = c(3, 3, 3)
'copy 3 IF statements
IF I = uc OR J = uc OR k = uc THEN '|copy
IF I = fc OR J = fc OR k = fc THEN '|
IF I = rc OR J = rc OR k = rc THEN '|
PrStr "Move d/b/l to d/f/r ", 4
PrStr "ie. D2 ", 5
Rotpr 2, 2
'copy 3 END IFs
END IF '|copy
END IF '|
END IF '|
'if d/f/l is correct u/f/r, move it to d/f/r
I = c(2, 3, 3): J = c(5, 3, 1): k = c(3, 1, 3)
'copy 3 IF statements
IF I = uc OR J = uc OR k = uc THEN '|copy
IF I = fc OR J = fc OR k = fc THEN '|
IF I = rc OR J = rc OR k = rc THEN '|
PrStr "Move d/f/l to d/f/r ", 4
PrStr "ie. D ", 5
Rotpr 2, 1
'copy 3 END IFs
END IF '|copy
END IF '|
END IF '|
'--------- u/f/r cube now at d/f/r. ----------
'--------- So move to it to u/f/r ----------
PrStr "Move d/f/r to u/f/r ", 4
IF c(2, 3, 1) = uc THEN 'if uc colour on D
'face, it must be moved to R face
PrStr "ie. R-1DRD2 ", 5
Rotpr 4, 3: Rotpr 2, 1: Rotpr 4, 1: Rotpr 2, 2
END IF
IF c(5, 3, 3) = uc THEN 'if uc colour on F
PrStr "ie. FDF-1 ", 5
Rotpr 5, 1: Rotpr 2, 1: Rotpr 5, 3'move to u/r
END IF
IF c(4, 1, 3) = uc THEN 'if uc colour on R
PrStr "ie. R-1D-1R ", 5
Rotpr 4, 3: Rotpr 2, 3: Rotpr 4, 1'move to u/r
END IF
IF n < 4 THEN RotCube
NEXT n
PrStr blank, 3: PrStr blank, 4
PrStr blank, 5: PrStr blank, 6
END SUB

SUB Corners3
PrStr "Sort top corners", 3: n = 0: order = 0
DO UNTIL (order > 900 AND order < 1100) OR order = 1111
n = n + 1 'number of loop
IF n > 1 THEN RotCube 'rotate whole cube
'is u/r/f in correct position ?
t1 = c(4, 2, 2): t2 = c(5, 2, 2)'r & f colours
I = c(1, 3, 1): J = c(5, 1, 3): k = c(4, 3, 3)
IF I = t1 OR J = t1 OR k = t1 THEN
IF I = t2 OR J = t2 OR k = t2 THEN order = 1000
END IF
'is u/r/b in correct position ?
t1 = c(4, 2, 2): t2 = c(6, 2, 2)'r & b colours
I = c(1, 3, 3): J = c(4, 3, 1): k = c(6, 1, 3)
IF I = t1 OR J = t1 OR k = t1 THEN
IF I = t2 OR J = t2 OR k = t2 THEN order = order + 100
END IF
'is u/l/b in correct position ?
t1 = c(3, 2, 2): t2 = c(6, 2, 2)'l & b colours
I = c(1, 1, 3): J = c(3, 3, 1): k = c(6, 3, 3)
IF I = t1 OR J = t1 OR k = t1 THEN
IF I = t2 OR J = t2 OR k = t2 THEN order = order + 10
END IF
'is u/l/f in correct position ?
t1 = c(5, 2, 2): t2 = c(3, 2, 2)'l & f colours
I = c(1, 1, 1): J = c(3, 1, 1): k = c(5, 1, 1)
IF I = t1 OR J = t1 OR k = t1 THEN
IF I = t2 OR J = t2 OR k = t2 THEN order = order + 1
END IF
IF order = 0 THEN 'no corners correct
PrStr "Rotate top layer only ", 4
Rotpr 1, 1: n = 0: PrStr blank, 4: PrStr blank, 6
END IF 'ie. need to go around loop again
LOOP
LOCATE 2, 58: PRINT "Order is "; order
SELECT CASE order
CASE 1000: 'only u/r/f correct so other 3
'must circulate - clock or anticlock?
lc = c(3, 2, 2): bc = c(6, 2, 2)'l & b colours
IF c(1, 1, 1) = lc OR c(3, 1, 1) = lc OR c(5, 1, 1) = lc THEN
IF c(1, 1, 1) = bc OR c(3, 1, 1) = bc OR c(5, 1, 1) = bc THEN
PrStr "ie. L-1URU-1LUR-1U-1 ", 5
'u/l/f goes clockw. to u/l/b
Rotpr 3, 3: Rotpr 1, 1: Rotpr 4, 1: Rotpr 1, 3
Rotpr 3, 1: Rotpr 1, 1: Rotpr 4, 3: Rotpr 1, 3
END IF
END IF
IF c(1, 3, 3) = lc OR c(4, 3, 1) = lc OR c(6, 1, 3) = lc THEN
IF c(1, 3, 3) = bc OR c(4, 3, 1) = bc OR c(6, 1, 3) = bc THEN
PrStr "ie. URU-1L-1UR-1U-1L ", 5
'u/r/b goes anticl. to u/l/b
Rotpr 1, 1: Rotpr 4, 1: Rotpr 1, 3: Rotpr 3, 3
Rotpr 1, 1: Rotpr 4, 3: Rotpr 1, 3: Rotpr 3, 1
END IF
END IF
CASE 1001: 'u/r/f and u/l/f correct
PrStr "ie. FU-1B-1UF-1U-1BU2 ", 5
Rotpr 5, 1: Rotpr 1, 3: Rotpr 6, 3: Rotpr 1, 1
Rotpr 5, 3: Rotpr 1, 3: Rotpr 6, 1: Rotpr 1, 2
CASE 1010: 'u/r/f and u/l/b correct
PrStr "ie. UFURU-1R-1F-1 ", 5
Rotpr 1, 1: Rotpr 5, 1: Rotpr 1, 1: Rotpr 4, 1
Rotpr 1, 3: Rotpr 4, 3: Rotpr 5, 3
END SELECT
PrStr blank, 3: PrStr blank, 4
PrStr blank, 5: PrStr blank, 6
END SUB

SUB Edges1
'locate u/f edge cube (23 other possible
'positions/orientations) and move to u/f
PrStr "Top layer edges", 3: uc = c(1, 2, 2) 'U &
FOR n = 1 TO 4: fc = c(5, 2, 2) '..F Centre colours
'if at u/f but flipped. (If not flipped, leave it)
IF c(1, 2, 1) = fc AND c(5, 1, 2) = uc THEN
PrStr "Flip u/f cube ", 4: PrStr "ie. F2LD-1L-1F", 5
Rotpr 5, 2: Rotpr 3, 1: Rotpr 2, 3: Rotpr 3, 3: Rotpr 5, 1
END IF
'if at r/f (2 orientations at each position)
IF c(4, 2, 3) = uc AND c(5, 2, 3) = fc THEN
PrStr "Move r/f to u/f", 4: PrStr "ie. F-1 ", 5
Rotpr 5, 3
END IF
IF c(4, 2, 3) = fc AND c(5, 2, 3) = uc THEN
PrStr "Move r/f to u/f", 4: PrStr "ie. FLD-1L-1F", 5
Rotpr 5, 1: Rotpr 3, 1: Rotpr 2, 3: Rotpr 3, 3: Rotpr 5, 1
END IF
'if at d/f
IF c(2, 3, 2) = uc AND c(5, 3, 2) = fc THEN
PrStr "Move d/f to u/f", 4: PrStr "ie. F2 ", 5
Rotpr 5, 2
END IF
IF c(2, 3, 2) = fc AND c(5, 3, 2) = uc THEN
PrStr "Move d/f to u/f", 4: PrStr "ie. LD-1L-1F ", 5
Rotpr 3, 1: Rotpr 2, 3: Rotpr 3, 3: Rotpr 5, 1
END IF
'if at l/f
IF c(3, 1, 2) = uc AND c(5, 2, 1) = fc THEN
PrStr "Move l/f to u/f", 4: PrStr "ie. F ", 5
Rotpr 5, 1
END IF
IF c(3, 1, 2) = fc AND c(5, 2, 1) = uc THEN
PrStr "Move l/f to u/f", 4: PrStr "ie.F-1LD-1L-1F", 5
Rotpr 5, 3: Rotpr 3, 1: Rotpr 2, 3: Rotpr 3, 3: Rotpr 5, 1
END IF
'if at d/l
IF c(2, 2, 3) = fc AND c(3, 2, 3) = uc THEN
PrStr "Move d/l to u/f", 4: PrStr "ie. L-1FL ", 5
Rotpr 3, 3: Rotpr 5, 1: Rotpr 3, 1
END IF
IF c(2, 2, 3) = uc AND c(3, 2, 3) = fc THEN
PrStr "Move d/l to u/f", 4: PrStr "ie. DF2 ", 5
Rotpr 2, 1: Rotpr 5, 2
END IF
'if at d/b
IF c(2, 1, 2) = uc AND c(6, 2, 1) = fc THEN
PrStr "Move d/b to u/f", 4: PrStr "ie. D2F2 ", 5
Rotpr 2, 2: Rotpr 5, 2
END IF
IF c(2, 1, 2) = fc AND c(6, 2, 1) = uc THEN
PrStr "Move d/b to u/f", 4: PrStr "ie. DL-1FL ", 5
Rotpr 2, 1: Rotpr 3, 3: Rotpr 5, 1: Rotpr 3, 1
END IF
'if at d/r
IF c(2, 2, 1) = fc AND c(4, 1, 2) = uc THEN
PrStr "Move d/r to u/f", 4: PrStr "ie. RF-1R-1 ", 5
Rotpr 4, 1: Rotpr 5, 3: Rotpr 4, 3
END IF
IF c(2, 2, 1) = uc AND c(4, 1, 2) = fc THEN
PrStr "Move d/r to u/f", 4: PrStr "ie. D-1F2 ", 5
Rotpr 2, 3: Rotpr 5, 2
END IF
'if at b/r
IF c(4, 2, 1) = fc AND c(6, 1, 2) = uc THEN
PrStr "Move b/r to u/f", 4: PrStr "ie. RD-1F2R-1", 5
Rotpr 4, 1: Rotpr 2, 3: Rotpr 5, 2: Rotpr 4, 3
END IF
IF c(4, 2, 1) = uc AND c(6, 1, 2) = fc THEN
PrStr "Move b/r to u/f", 4: PrStr "ie. R2F-1R2 ", 5
Rotpr 4, 2: Rotpr 5, 3: Rotpr 4, 2
END IF
'if at b/l
IF c(3, 3, 2) = fc AND c(6, 3, 2) = uc THEN
PrStr "Move b/l to u/f", 4: PrStr "ie. L-1DF2L ", 5
Rotpr 3, 3: Rotpr 2, 1: Rotpr 5, 2: Rotpr 3, 1
END IF
IF c(3, 3, 2) = uc AND c(6, 3, 2) = fc THEN
PrStr "Move b/l to u/f", 4: PrStr "ie. L2FL2 ", 5
Rotpr 3, 2: Rotpr 5, 1: Rotpr 3, 2
END IF
'if at l/u
IF c(3, 2, 1) = fc AND c(1, 1, 2) = uc THEN
PrStr "Move l/u to u/f", 4: PrStr "ie. L2DF2 ", 5
Rotpr 3, 2: Rotpr 2, 1: Rotpr 5, 2
END IF
IF c(3, 2, 1) = uc AND c(1, 1, 2) = fc THEN
PrStr "Move l/u to u/f", 4: PrStr "ie. LF ", 5
Rotpr 3, 1: Rotpr 5, 1
END IF
'if at b/u
IF c(6, 2, 3) = fc AND c(1, 2, 3) = uc THEN
PrStr "Move b/u to u/f", 4: PrStr "ie. B2D2F2 ", 5
Rotpr 6, 2: Rotpr 2, 2: Rotpr 5, 2
END IF
IF c(6, 2, 3) = uc AND c(1, 2, 3) = fc THEN
PrStr "Move b/u to u/f", 4: PrStr "ie. BL-1DLF2 ", 5
Rotpr 6, 1: Rotpr 3, 3: Rotpr 2, 1: Rotpr 3, 1: Rotpr 5, 2
END IF
'if at r/u
IF c(4, 3, 2) = fc AND c(1, 3, 2) = uc THEN
PrStr "Move r/u to u/f", 4: PrStr "ie. R2D-1F2 ", 5
Rotpr 4, 2: Rotpr 2, 3: Rotpr 5, 2
END IF
IF c(4, 3, 2) = uc AND c(1, 3, 2) = fc THEN
PrStr "Move r/u to u/f", 4: PrStr "ie. R-1F-1 ", 5
Rotpr 4, 3: Rotpr 5, 3
END IF
IF n < 4 THEN RotCube
NEXT n
PrStr blank, 3: PrStr blank, 4: PrStr blank, 5: PrStr blank, 6
END SUB

SUB Edges2
PrStr "Invert whole cube", 3'about L face axis
MidLayer 5: MidLayer 5 'need 2 x 90 deg.
ROTATE 6, 2: Rotpr 5, 2: PrStr blank, 6
'The sorted layer is now on the bottom.
PrStr "Middle layer edges", 3 'tell the user
'Rotating about vert. to 4 separate positions
FOR n = 1 TO 4: lc = c(3, 2, 2): fc = c(5, 2, 2)
'First check 4 middle edge positions for l/f.
'if l/f in correct position and orientation,
'leave it. Otherwise, move it to top layer.
'First, if l/f in position but flipped
IF c(3, 1, 2) = fc AND c(5, 2, 1) = lc THEN
PrStr "l/f to top layer ", 4
PrStr "ie. FU2RUR-1U2F-1 ", 5
Rotpr 5, 1: Rotpr 1, 2: Rotpr 4, 1: Rotpr 1, 1
Rotpr 4, 3: Rotpr 1, 2: Rotpr 5, 3
END IF
'Now, check other 3 vertical edge positions
'if l/f at r/f, move to top layer
IF c(4, 2, 3) = fc OR c(5, 2, 3) = fc THEN
IF c(4, 2, 3) = lc OR c(5, 2, 3) = lc THEN
PrStr "r/f to top layer ", 4
PrStr "ie RU2BUB-1U2R-1 ", 5
Rotpr 4, 1: Rotpr 1, 2: Rotpr 6, 1: Rotpr 1, 1
Rotpr 6, 3: Rotpr 1, 2: Rotpr 4, 3
END IF
END IF
'if l/f at r/b, move to top layer
IF c(4, 2, 1) = fc OR c(6, 1, 2) = fc THEN
IF c(4, 2, 1) = lc OR c(6, 1, 2) = lc THEN
PrStr "r/b to top layer ", 4
PrStr "ie. BU2LUL-1U2B-1 ", 5
Rotpr 6, 1: Rotpr 1, 2: Rotpr 3, 1: Rotpr 1, 1
Rotpr 3, 3: Rotpr 1, 2: Rotpr 6, 3
END IF
END IF
'if l/f at l/b, move to top layer
IF c(3, 3, 2) = fc OR c(6, 3, 2) = fc THEN
IF c(3, 3, 2) = lc OR c(6, 3, 2) = lc THEN
PrStr "l/b to top layer ", 4
PrStr "ie. LU2FUF-1U2L-1 ", 5
Rotpr 3, 1: Rotpr 1, 2: Rotpr 5, 1: Rotpr 1, 1
Rotpr 5, 3: Rotpr 1, 2: Rotpr 3, 3
END IF
END IF
'NOW, find l/f in top layer, transfer to u/r,
'then to l/f using Edges2a()
IF c(4, 3, 2) = fc OR c(1, 3, 2) = fc THEN
IF c(4, 3, 2) = lc OR c(1, 3, 2) = lc THEN
Edges2a 'candidate already at u/l
END IF
END IF
IF c(6, 2, 3) = fc OR c(1, 2, 3) = fc THEN
IF c(6, 2, 3) = lc OR c(1, 2, 3) = lc THEN
PrStr "u/b to u/r ", 4
Rotpr 1, 1: Edges2a 'candidate at u/l
END IF
END IF
IF c(3, 2, 1) = fc OR c(1, 1, 2) = fc THEN
IF c(3, 2, 1) = lc OR c(1, 1, 2) = lc THEN
PrStr "u/l to u/r ", 4
Rotpr 1, 2: Edges2a 'candidate at u/l
END IF
END IF
IF c(5, 1, 2) = fc OR c(1, 2, 1) = fc THEN
IF c(5, 1, 2) = lc OR c(1, 2, 1) = lc THEN
PrStr "u/f to u/r ", 4
Rotpr 1, 3: Edges2a 'candidate at u/f
END IF
END IF
IF n < 4 THEN RotCube
NEXT n
PrStr blank, 3: PrStr blank, 4
PrStr blank, 5: PrStr blank, 6
END SUB

SUB Edges2a 'After Edges2() puts l/f cube to
'u/r position, this puts it in correct
'position and correct orientation.
PrStr "u/r to l/f ", 4
IF c(1, 3, 2) = c(3, 2, 2) THEN 'U face of u/r
PrStr "ie. FU2RUR-1U2F-1 ", 5 'is lc
Rotpr 5, 1: Rotpr 1, 2: Rotpr 4, 1: Rotpr 1, 1
Rotpr 4, 3: Rotpr 1, 2: Rotpr 5, 3
ELSE 'ie. U face of u/r = fc colour
PrStr "ie. UFU2RU-1R-1U2F-1 ", 5
Rotpr 1, 1: Rotpr 5, 1: Rotpr 1, 2: Rotpr 4, 1
Rotpr 1, 3: Rotpr 4, 3: Rotpr 1, 2: Rotpr 5, 3
END IF
END SUB

SUB Edges3
PrStr "Sort top edge cubes", 3: correct = 0
'first note centre colours of faces F, R, B & L
fc = c(5, 2, 2): rc = c(4, 2, 2): bc = c(6, 2, 2): lc = c(3, 2, 2)
'find which cubes are in correct position
IF c(1, 2, 1) = fc OR c(5, 1, 2) = fc THEN correct = 1000
IF c(1, 3, 2) = rc OR c(4, 3, 2) = rc THEN correct = correct + 100
IF c(1, 2, 3) = bc OR c(6, 2, 3) = bc THEN correct = correct + 10
IF c(1, 1, 2) = lc OR c(3, 2, 1) = lc THEN correct = correct + 1
IF correct = 0 THEN 'none of cubes in right place
IF c(1, 2, 1) = rc OR c(5, 1, 2) = rc THEN 'if u/r at u/f
RotCube 'rotate whole cube. note new centre colours
fc = c(5, 2, 2): rc = c(4, 2, 2): bc = c(6, 2, 2): lc = c(3, 2, 2)
END IF
IF c(1, 2, 1) = bc OR c(5, 1, 2) = bc THEN 'if u/b at u/f
PrStr "R2L2DR2L2U2R2L2DR2L2 ", 5'swap opposite pairs
Rotpr 4, 2: Rotpr 3, 2: Rotpr 2, 1: Rotpr 4, 2
Rotpr 3, 2: Rotpr 1, 2: Rotpr 4, 2: Rotpr 3, 2
Rotpr 2, 1: Rotpr 4, 2: Rotpr 3, 2
END IF
IF c(1, 2, 1) = lc OR c(5, 1, 2) = lc THEN 'if u/l at u/f
PrStr "RBUB-1U-1R2F-1U-1FUR ", 5'swap adjacent pairs
Rotpr 4, 1: Rotpr 6, 1: Rotpr 1, 1: Rotpr 6, 3
Rotpr 1, 3: Rotpr 4, 2: Rotpr 5, 3: Rotpr 1, 3
Rotpr 5, 1: Rotpr 1, 1: Rotpr 4, 1
END IF
END IF
SELECT CASE correct 'One cube only correct. Rotate
'whole cube to put it at u/r position
CASE 1000: RotCube: RotCube: RotCube
CASE 10: RotCube
CASE 1: RotCube: RotCube
END SELECT 'in effect, now correct = 100
bc = c(6, 2, 2): lc = c(3, 2, 2)'centre colours of B & L
IF c(1, 2, 1) = bc OR c(5, 1, 2) = bc THEN 'if u/b at u/f
PrStr "L2U-1F-1BL2FB-1U-1L2 ", 5 'circulate anticlock
Rotpr 3, 2: Rotpr 1, 3: Rotpr 5, 3: Rotpr 6, 1: Rotpr 3, 2
Rotpr 5, 1: Rotpr 6, 3: Rotpr 1, 3: Rotpr 3, 2
END IF
IF c(1, 2, 1) = lc OR c(5, 1, 2) = lc THEN 'if u/l at u/f
PrStr "ie. L2UF-1BL2FB-1UL2 ", 5 'circulate clockwise
Rotpr 3, 2: Rotpr 1, 1: Rotpr 5, 3: Rotpr 6, 1: Rotpr 3, 2
Rotpr 5, 1: Rotpr 6, 3: Rotpr 1, 1: Rotpr 3, 2
END IF
PrStr blank, 3: PrStr blank, 4
PrStr blank, 5: PrStr blank, 6
END SUB

SUB Flips 'flips top edge cubes
uc = c(1, 2, 2) 'colour of U centre
DO UNTIL c(1, 2, 1) = uc AND c(1, 1, 2) = uc AND c(1, 2, 3) = uc AND c(1, 3, 2) = uc
n = 0 'ie. until all top faces match uc
DO UNTIL c(1, 2, 1) = c(5, 2, 2) OR n = 4
n = n + 1: RotCube 'until u/f needs flip
LOOP 'if n reaches 4, all are correct
'cubes needing flip always occur in pairs
IF n < 4 THEN 'u/f needs flip. Find other
IF c(1, 3, 2) = c(4, 2, 2) THEN
other = 4 'u/r needs flip
PrStr "u/f & u/r need flip ", 2
ELSE
IF c(1, 2, 3) = c(6, 2, 2) THEN
other = 6 'u/b needs flip
PrStr "u/f & u/b need flip ", 2
ELSE
other = 3 'u/l needs flip
PrStr "u/f & u/l need flip ", 2
END IF
END IF
PrStr "Flip pair top edges ", 4
PrStr "Firstly FUD-1L2U2D2R ", 5
Rotpr 5, 1: Rotpr 1, 1: Rotpr 2, 3: Rotpr 3, 2
Rotpr 1, 2: Rotpr 2, 2: Rotpr 4, 1
PrStr "2nd of pair to u/r ", 5
IF other = 4 THEN Rotpr 1, 1
IF other = 6 THEN Rotpr 1, 2
IF other = 3 THEN Rotpr 1, 3
PrStr "Now R-1D2U2L2DU-1F-1", 5
Rotpr 4, 3: Rotpr 2, 2: Rotpr 1, 2: Rotpr 3, 2
Rotpr 2, 1: Rotpr 1, 3: Rotpr 5, 3
IF other = 4 THEN Rotpr 1, 3
IF other = 6 THEN Rotpr 1, 2
IF other = 3 THEN Rotpr 1, 1
PrStr blank, 2
END IF
LOOP
PrStr blank, 3: PrStr blank, 4
PrStr blank, 5: PrStr blank, 6
END SUB

SUB Grafic
'face name strings in face(6) array
face(1) = " UP ": face(2) = " DOWN "
face(3) = " LEFT ": face(4) = " RIGHT "
face(5) = " FRONT ": face(6) = " BACK "
ang(1) = "+90": ang(2) = "180": ang(3) = "-90"
'blank = " " '22 spaces
blank = SPACE$(22)
'each face's adjacent faces, anticlockwise
f(1, 1) = 5: f(1, 2) = 4: f(1, 3) = 6: f(1, 4) = 3
f(2, 1) = 4: f(2, 2) = 5: f(2, 3) = 3: f(2, 4) = 6
f(3, 1) = 1: f(3, 2) = 6: f(3, 3) = 2: f(3, 4) = 5
f(4, 1) = 6: f(4, 2) = 1: f(4, 3) = 5: f(4, 4) = 2
f(5, 1) = 3: f(5, 2) = 2: f(5, 3) = 4: f(5, 4) = 1
f(6, 1) = 2: f(6, 2) = 3: f(6, 3) = 1: f(6, 4) = 4
CLS : COLOR 15 'now print top table
PrStr "Rightclick to QUIT ", 7
LOCATE 6, 7: PRINT "Rotate whole cube 90"
LOCATE 6, 34: PRINT "Clock wise"
FOR n = 1 TO 6
LOCATE 1, n * 7: PRINT face(n)
LOCATE 2, n * 7 + 2: PRINT n
LOCATE 3, n * 7 + 2: PRINT ang(1)
LOCATE 4, n * 7 + 2: PRINT ang(2)
LOCATE 5, n * 7 + 2: PRINT ang(3)
LINE (n * 56 - 9, 32)-STEP(50, 16), 15, B
LINE (n * 56 - 9, 48)-STEP(50, 16), 15, B
LINE (n * 56 - 9, 64)-STEP(50, 16), 15, B
LINE (n * 56 - 9, 80)-STEP(50, 16), 15, B
NEXT n
LOCATE 3, 50: PRINT "RESET"
LINE (383, 32)-STEP(56, 16), 15, B
LOCATE 4, 50: PRINT "PAUSE"
LINE (383, 48)-STEP(56, 16), 15, B
LOCATE 5, 50: PRINT "SOLVE"
LINE (383, 64)-STEP(56, 16), 15, B
LOCATE 6, 50: PRINT "SCRMBL"
LINE (383, 80)-STEP(56, 16), 15, B
'now print face labels
LOCATE 11, 7: PRINT face(1)
LOCATE 11, 28: PRINT face(1)
LOCATE 25, 67: PRINT face(2)
LOCATE 25, 48: PRINT face(2)
LOCATE 27, 8: PRINT face(3)
LOCATE 9, 69: PRINT face(4)
LOCATE 27, 27: PRINT face(5)
LOCATE 9, 46: PRINT face(6)
LOCATE 8, 15: PRINT "OUTSIDE VIEW"
LOCATE 27, 55: PRINT "INSIDE VIEW"
'draw the cube - 9 times
dx = 40: dx3 = 3 * dx: dy = 24: dy3 = 3 * dy
xs = 20: ys = 24: ys2 = 2 * ys: ys6 = 6 * ys: c = 15
FOR xl = 159 TO 161: xr = xl + 320
FOR yl = 288 TO 290: yr = yl - 30
FOR I = 0 TO 3:
LINE (xl - I * dx, yl - I * dy)-STEP(0, ys6), c
LINE (xl - I * dx, yl - I * dy)-STEP(dx3, -dy3), c
LINE (xl + I * dx, yl - I * dy)-STEP(0, ys6), c
LINE (xl + I * dx, yl - I * dy)-STEP(-dx3, -dy3), c
LINE (xl, yl + I * ys2)-STEP(dx3, -dy3), c
LINE (xl, yl + I * ys2)-STEP(-dx3, -dy3), c

LINE (xr - I * dx, yr + I * dy)-STEP(0, -ys6), c
LINE (xr - I * dx, yr + I * dy)-STEP(dx3, dy3), c
LINE (xr + I * dx, yr + I * dy)-STEP(0, -ys6), c
LINE (xr + I * dx, yr + I * dy)-STEP(-dx3, dy3), c
LINE (xr, yr - I * ys2)-STEP(dx3, dy3), c
LINE (xr, yr - I * ys2)-STEP(-dx3, dy3), c
NEXT I: NEXT yl: NEXT xl
sx = xl - xr: sy = yl - yr'draw dashed lines
LINE (xr, yr - ys6)-STEP(sx, sy), c, , &H700
LINE (xr + dx3, yr - dy3)-STEP(sx, sy), c, , &H700
LINE (xr + dx3, yr + dy3)-STEP(sx, sy), c, , &H700
LINE (xr, yr + ys6)-STEP(sx, sy), c, , &H700
LINE (xr - dx3, yr - dy3)-STEP(sx / 3, sy / 3), c, , &H700
LINE (xr - dx3, yr + dy3)-STEP(sx / 4, sy / 4), c, , &H700
'starting coords to paint each square
FOR I = 1 TO 3: FOR J = 1 TO 3
x(1, I, J) = xl + I * dx - J * dx
y(1, I, J) = yl + dy - I * dy - J * dy
x(2, I, J) = xr - J * dx + I * dx
y(2, I, J) = yr - dy + I * dy + J * dy
x(3, I, J) = xl + xs - I * dx
y(3, I, J) = yl - ys + J * ys2 - I * dy
x(4, I, J) = xr - xs + J * dx
y(4, I, J) = yr + ys - I * ys2 + J * dy
x(5, I, J) = xl - xs + J * dx
y(5, I, J) = yl - ys + I * ys2 - J * dy
x(6, I, J) = xr + xs - I * dx
y(6, I, J) = yr + ys - J * ys2 + I * dy
NEXT J: NEXT I
Init 'set original colours
Redraw 'paint all squares
END SUB

SUB Init
FOR n = 1 TO 6: FOR I = 1 TO 3: FOR J = 1 TO 3
c(n, I, J) = n: NEXT J: NEXT I: NEXT n
END SUB

SUB MidLayer (FAC)
t1 = c(f(FAC, 1), 2, 1): t2 = c(f(FAC, 1), 2, 2)
t3 = c(f(FAC, 1), 2, 3) 'store temps
c(f(FAC, 1), 2, 1) = c(f(FAC, 2), 2, 3)
c(f(FAC, 1), 2, 2) = c(f(FAC, 2), 2, 2)
c(f(FAC, 1), 2, 3) = c(f(FAC, 2), 2, 1)

c(f(FAC, 2), 2, 3) = c(f(FAC, 3), 1, 2)
c(f(FAC, 2), 2, 2) = c(f(FAC, 3), 2, 2)
c(f(FAC, 2), 2, 1) = c(f(FAC, 3), 3, 2)

c(f(FAC, 3), 1, 2) = c(f(FAC, 4), 3, 2)
c(f(FAC, 3), 2, 2) = c(f(FAC, 4), 2, 2)
c(f(FAC, 3), 3, 2) = c(f(FAC, 4), 1, 2)

c(f(FAC, 4), 3, 2) = t1: c(f(FAC, 4), 2, 2) = t2
c(f(FAC, 4), 1, 2) = t3
END SUB

SUB mouse (axx) 'Reset, show or hide mouse
a(2) = axx 'sets register ax
DEF SEG = VARSEG(a(1)) 'find address
CALL ABSOLUTE(VARPTR(a(1)))
DEF SEG 'bx,cx,dx now in a(15 to 17)
END SUB

SUB MouseLimit 'Restrict mouse to top panel
B(2) = 7: B(4) = 60: B(6) = 420 'ax,cx,dx
DEF SEG = VARSEG(B(1)) 'find address
CALL ABSOLUTE(VARPTR(B(1)))
DEF SEG 'x moves restricted
B(2) = 8: B(4) = 40: B(6) = 88 'ax,cx,dx
DEF SEG = VARSEG(B(1)) 'find address
CALL ABSOLUTE(VARPTR(B(1)))
DEF SEG 'y moves restricted
END SUB

SUB PrStr (st$, row) 'Prints a string, col 58
LOCATE row, 58: PRINT st$
END SUB

SUB Redraw 'recolour all squares
FOR n = 1 TO 6: FOR I = 1 TO 3: FOR J = 1 TO 3
PAINT (x(n, I, J), y(n, I, J)), c(n, I, J), 15
NEXT J: NEXT I: NEXT n
END SUB

SUB ROTATE (FAC, rot)
DIM t1, t2, t3 'temps for 1st squares
FOR n = 1 TO rot '1, 2 or 3 times 90 deg.
t1 = c(FAC, 1, 1): t2 = c(FAC, 2, 1)'face squares
c(FAC, 1, 1) = c(FAC, 3, 1): c(FAC, 2, 1) = c(FAC, 3, 2)
c(FAC, 3, 1) = c(FAC, 3, 3): c(FAC, 3, 2) = c(FAC, 2, 3)
c(FAC, 3, 3) = c(FAC, 1, 3): c(FAC, 2, 3) = c(FAC, 1, 2)
c(FAC, 1, 3) = t1: c(FAC, 1, 2) = t2
'rotate adjacent squares of adjacent faces
t1 = c(f(FAC, 1), 1, 1): t2 = c(f(FAC, 1), 1, 2)
t3 = c(f(FAC, 1), 1, 3) 'store temps
c(f(FAC, 1), 1, 1) = c(f(FAC, 2), 3, 3)
c(f(FAC, 1), 1, 2) = c(f(FAC, 2), 3, 2)
c(f(FAC, 1), 1, 3) = c(f(FAC, 2), 3, 1)

c(f(FAC, 2), 3, 3) = c(f(FAC, 3), 1, 3)
c(f(FAC, 2), 3, 2) = c(f(FAC, 3), 2, 3)
c(f(FAC, 2), 3, 1) = c(f(FAC, 3), 3, 3)

c(f(FAC, 3), 1, 3) = c(f(FAC, 4), 3, 1)
c(f(FAC, 3), 2, 3) = c(f(FAC, 4), 2, 1)
c(f(FAC, 3), 3, 3) = c(f(FAC, 4), 1, 1)
c(f(FAC, 4), 3, 1) = t1: c(f(FAC, 4), 2, 1) = t2
c(f(FAC, 4), 1, 1) = t3 'recover temps
NEXT
END SUB

SUB RotCube 'rotate about vertical axis
PrStr "Rotate whole cube +90 ", 6
PrStr blank, 4: PrStr blank, 5
IF pause = 1 THEN
DO: mouse 3 'get left click
LOOP UNTIL a(15) = 1
END IF
ROTATE 1, 1: MidLayer 1: ROTATE 2, 3
Redraw
PrStr blank, 6
END SUB

SUB Rotpr (FAC, rot)
count = count + 1: LOCATE 1, 1: PRINT count; " "
LOCATE 6, 58: PRINT "Rotate "; face(FAC); ang(rot)
IF pause = 1 THEN
DO: mouse 3: LOOP UNTIL a(15) = 1
TIM! = TIMER + .33: DO: LOOP UNTIL TIMER > TIM!
END IF
ROTATE FAC, rot: Redraw
END SUB

SUB Scramble
FOR Z = 1 TO 1000
fac = INT(RND(1) * 6) + 1
i = INT(RND(1) * 3) + 1
CALL Rotate(fac, I)
NEXT
END SUB

SUB Solve
count = 0 'set move counter to zero
IF pause = 1 THEN PrStr "Leftclick to go on", 7
Edges1 'Top edge cubes
Corners1 'Top corner cubes
Edges2 'Invert cube. Middle layer edges
Corners3 'Top corners. Ignore orientation
Edges3 'Top edges. ditto
Flips 'Flip edges to correct orientation
Twirls 'Twirl corners to ditto
PrStr "Rightclick to QUIT ", 7 'restore
END SUB

SUB Twirls 'twirls top corner cubes
uc = c(1, 2, 2) 'U centre colour
DO 'outer loop
I = 0: J = 0: k = 0: l = 0
IF c(5, 1, 3) = uc THEN I = 1 'u/f/r
IF c(4, 3, 3) = uc THEN I = -1
IF c(4, 3, 1) = uc THEN J = 1 'u/r/b
IF c(6, 1, 3) = uc THEN J = -1
IF c(6, 3, 3) = uc THEN k = 1 'u/b/l
IF c(3, 3, 1) = uc THEN k = -1
IF c(3, 1, 1) = uc THEN l = 1 'u/l/f
IF c(5, 1, 1) = uc THEN l = -1
sum = ABS(I) + ABS(J) + ABS(k) + ABS(l)
SELECT CASE sum
CASE 4, 2:
DO UNTIL c(5, 1, 3) = uc 'until..
RotCube '..u/f/r needs clock twirl
LOOP
IF c(5, 1, 1) = uc THEN num = 3
'ie. u/l/f needs anticlock twirl
IF c(3, 3, 1) = uc THEN num = 2
'ie. u/b/l needs anticlock twirl
IF c(6, 1, 3) = uc THEN num = 1
'ie. u/r/b needs anticlock twirl
CASE 3: num = 1
END SELECT
LOCATE 2, 58: PRINT sum; num;
IF sum > 0 THEN
PrStr "Twirl two top corners ", 3
PrStr "First of pair (u/r) ", 4
PrStr "ie. R-1DRFDF-1 ", 5
Rotpr 4, 3: Rotpr 2, 1: Rotpr 4, 1
Rotpr 5, 1: Rotpr 2, 1: Rotpr 5, 3
PrStr "Move 2nd to u/r ", 4
PrStr blank, 5: Rotpr 1, num
PrStr "2nd of pair (u/r) ", 4
PrStr "ie. FD-1F-1R-1D-1R ", 5
Rotpr 5, 1: Rotpr 2, 3: Rotpr 5, 3
Rotpr 4, 3: Rotpr 2, 3: Rotpr 4, 1
PrStr "Move 2nd to orig. pos.", 4
PrStr blank, 5: Rotpr 1, 4 - num
END IF
LOOP UNTIL sum = 0
PrStr blank, 2: PrStr blank, 3
PrStr blank, 4: PrStr blank, 5
PrStr blank, 6:
END SUB

DECLARE FUNCTION FACTOR& (N&)
DEFLNG A-Z
CLS
WIDTH , 50
INPUT N
DO
X = FACTOR(N)
IF X = -1 THEN LOCATE , 40: PRINT N: END
PRINT X; "<"; STRING$(39 - POS(1), 196); CHR$(194); N
PRINT TAB(39); CHR$(179)
N = N \ X
LOOP

DEFLNG A-Z
FUNCTION FACTOR (N)
FOR I = 2 TO SQR(N)
IF (N MOD I) = 0 THEN FACTOR = I: EXIT FUNCTION
NEXT
FACTOR = -1
END FUNCTION

TYPE ELEMENT
NAME AS STRING * 20
SYMBOL AS STRING * 2
END TYPE
DIM ELEMENTS(1 TO 40) AS ELEMENT
CLS
RANDOMIZE TIMER
FOR I = 1 TO 40
READ ELEMENTS(I).NAME, ELEMENTS(I).SYMBOL
NEXT
DO
X = INT(RND(1) * 40) + 1
PRINT "What is the chemical symbol for "; RTRIM$(ELEMENTS(X).NAME);
INPUT ANSWER$
IF LTRIM$(RTRIM$(ANSWER$)) = RTRIM$(ELEMENTS(X).SYMBOL) THEN
PRINT "CORRECT"
ELSE
PRINT "Sorry, the answer is "; ELEMENTS(X).SYMBOL
END IF
LOOP

DATA Oxygen, O
DATA Mercury, Hg
DATA Gold, Au
DATA Lead, Pb
DATA Sulfur, S
DATA Antimony, Sb
DATA Sodium, Na
DATA Hydrogen, H
DATA Bromine, Br
DATA Potassium, K
DATA Helium, He
DATA Nitrogen, N
DATA Uranium, U
DATA Boron, B
DATA Iron, Fe
DATA Carbon, C
DATA Chlorine, Cl
DATA Silver, Ag
DATA Barium, Ba
DATA Flourine, F
DATA Argon, Ar
DATA Silicon, Si
DATA Aluminum, Al
DATA Neon, Ne
DATA Arsenic, As
DATA Lithium, Li
DATA Magnesium, Mg
DATA Phosphorus, P
DATA Iodine, I
DATA Zinc, Zn
DATA Copper, Cu
DATA Nickel, Ni
DATA Krypton, Kr
DATA Xenon, Xe
DATA Cobalt, Co
DATA Manganese, Mn
DATA Radon, Rn
DATA Calcium, Ca
DATA Titanium, Ti
DATA Plutonium, Pu

DECLARE SUB LLISTSTMT ()
DECLARE SUB LPRINTSTMT ()
DECLARE SUB INITGETSYM (N AS INTEGER)
DECLARE SUB VALIDLINENUM ()
DECLARE SUB DOCMD ()
DECLARE SUB CLEARVARS ()
DECLARE SUB LISTSTMT ()
DECLARE SUB GOTOSTMT ()
DECLARE SUB IFSTMT ()
DECLARE SUB INPUTSTMT ()
DECLARE SUB PRINTSTMT ()
DECLARE SUB SKIPTOEOL ()
DECLARE SUB IDSTMT ()
DECLARE SUB GETSYM ()
DECLARE SUB EXPECT (S AS STRING)
DECLARE SUB GOTOLINE ()
DECLARE FUNCTION EXPRESSION% ()
DECLARE FUNCTION ADDEXPR% ()
DECLARE FUNCTION TERM% ()
DECLARE FUNCTION FACTOR% ()
DECLARE FUNCTION GETVARINDEX% ()
DECLARE FUNCTION ACCEPT% (S AS STRING)
DECLARE SUB GETCH ()
DECLARE SUB READSTR ()
DECLARE SUB READIDENT ()
DECLARE SUB READINT ()

DIM SHARED CH$, THELIN$, PGM$(2000), TOK$


DIM SHARED VARS(26) AS INTEGER, CURLINE AS INTEGER, NUM AS INTEGER
DIM SHARED TEXTP AS INTEGER, ERRORS AS INTEGER


DO
ERRORS = 0
LINE INPUT "> ", PGM$(0)
IF PGM$(0) <> "" THEN
CALL INITGETSYM(0)
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
CALL VALIDLINENUM
PGM$(NUM) = MID$(PGM$(0), TEXTP, LEN(PGM$(0)) - TEXTP + 1)
ELSE
CALL DOCMD
END IF
END IF
LOOP

FUNCTION ACCEPT% (S AS STRING)
ACCEPT% = 0
IF TOK$ = S THEN ACCEPT% = 1: CALL GETSYM
END FUNCTION

FUNCTION ADDEXPR%
DIM N
N = TERM%
ADDEL:
IF TOK$ = "+" THEN CALL GETSYM: N = N + TERM%: GOTO ADDEL
IF TOK$ = "-" THEN CALL GETSYM: N = N - TERM%: GOTO ADDEL
ADDEXPR% = N
END FUNCTION

SUB CLEARVARS
DIM I AS INTEGER
FOR I = 1 TO 26
VARS(I) = 0
NEXT I
END SUB

SUB DOCMD
DIM I AS INTEGER
AGAIN:
IF ERRORS <> 0 THEN EXIT SUB
WHILE TOK$ = ""
IF CURLINE = 0 OR CURLINE >= 1999 THEN EXIT SUB
CALL INITGETSYM(CURLINE + 1)
WEND
IF ACCEPT("STOP") OR ACCEPT("END") THEN EXIT SUB
IF ACCEPT("NEW") THEN
CALL CLEARVARS
FOR I = 1 TO 1999
PGM$(I) = ""
NEXT I
EXIT SUB
END IF
IF ACCEPT("BYE") THEN END
IF ACCEPT("LIST") THEN CALL LISTSTMT: GOTO AGAIN
IF ACCEPT("LLIST") THEN CALL LLISTSTMT: GOTO AGAIN
IF ACCEPT("RUN") THEN
CALL CLEARVARS
CALL INITGETSYM(1)
GOTO AGAIN
END IF
IF ACCEPT("GOTO") THEN CALL GOTOSTMT: GOTO AGAIN
IF ACCEPT("IF") THEN CALL IFSTMT: GOTO AGAIN
IF ACCEPT("INPUT") THEN CALL INPUTSTMT: GOTO AGAIN
IF ACCEPT("PRINT") THEN CALL PRINTSTMT: GOTO AGAIN
IF ACCEPT("LPRINT") THEN CALL LPRINTSTMT: GOTO AGAIN
IF ACCEPT("REM") THEN CALL SKIPTOEOL: GOTO AGAIN
IF LEFT$(TOK$, 1) >= "A" AND LEFT$(TOK$, 1) <= "Z" THEN
CALL IDSTMT
GOTO AGAIN
END IF
PRINT "UNKNOWN TOKEN "; TOK$; " AT LINE "; CURLINE
END SUB

SUB EXPECT (S AS STRING)
IF ACCEPT(S) <> 0 THEN EXIT SUB
ERRORS = 1
PRINT "EXPECTING "; S; " BUT FOUND "; TOK$
END SUB

FUNCTION EXPRESSION%
DIM N
N = ADDEXPR%
EXPRL:
IF TOK$ = "=" THEN CALL GETSYM: N = N = ADDEXPR%: GOTO EXPRL
IF TOK$ = "<" THEN CALL GETSYM: N = N < ADDEXPR%: GOTO EXPRL
IF TOK$ = ">" THEN CALL GETSYM: N = N > ADDEXPR%: GOTO EXPRL
IF TOK$ = "<>" THEN CALL GETSYM: N = N <> ADDEXPR%: GOTO EXPRL
IF TOK$ = "<=" THEN CALL GETSYM: N = N <= ADDEXPR%: GOTO EXPRL
IF TOK$ = ">=" THEN CALL GETSYM: N = N >= ADDEXPR%: GOTO EXPRL
EXPRESSION% = N
END FUNCTION

FUNCTION FACTOR%
IF ACCEPT("-") THEN
FACTOR% = -FACTOR%
EXIT FUNCTION
END IF
IF ACCEPT("(") THEN
FACTOR% = EXPRESSION
CALL EXPECT(")")
EXIT FUNCTION
END IF
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
FACTOR% = NUM
CALL GETSYM
EXIT FUNCTION
END IF
IF LEFT$(TOK$, 1) >= "A" AND LEFT$(TOK$, 1) <= "Z" THEN
FACTOR% = VARS(GETVARINDEX)
EXIT FUNCTION
END IF
PRINT "UNEXPECTED SYM "; TOK$; " IN FACTOR": ERRORS = 1
END FUNCTION

SUB GETCH
IF TEXTP > LEN(THELIN$) THEN CH$ = "": EXIT SUB
CH$ = MID$(THELIN$, TEXTP, 1)
TEXTP = TEXTP + 1
END SUB

SUB GETSYM
TOK$ = ""
WHILE CH$ <= " "
IF CH$ = "" THEN EXIT SUB
CALL GETCH
WEND


TOK$ = CH$
IF INSTR(",;=+-*/()", CH$) > 0 THEN CALL GETCH: EXIT SUB
IF CH$ = "<" THEN
CALL GETCH
IF CH$ = "=" OR CH$ = ">" THEN
TOK$ = TOK$ + CH$
CALL GETCH
END IF
EXIT SUB
END IF
IF CH$ = ">" THEN
CALL GETCH
IF CH$ = "=" THEN TOK$ = TOK$ + CH$: CALL GETCH
EXIT SUB
END IF
IF CH$ = CHR$(34) THEN CALL READSTR: EXIT SUB
IF CH$ >= "A" AND CH$ <= "Z" THEN CALL READIDENT: EXIT SUB
IF CH$ >= "0" AND CH$ <= "9" THEN CALL READINT: EXIT SUB
PRINT "WHAT->"; CH$: ERRORS = 1
END SUB

FUNCTION GETVARINDEX%
IF LEFT$(TOK$, 1) < "A" OR LEFT$(TOK$, 1) > "Z" THEN
PRINT "NOT A VARIABLE": ERRORS = 1: EXIT FUNCTION
END IF
GETVARINDEX% = ASC(LEFT$(TOK$, 1)) - ASC("A")
CALL GETSYM
END FUNCTION

SUB GOTOLINE
CALL VALIDLINENUM
CALL INITGETSYM(NUM)
END SUB

SUB GOTOSTMT
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
CALL GOTOLINE
EXIT SUB
END IF
PRINT "LINE NUMBER MUST FOLLOW GOTO": ERRORS = 1
END SUB

SUB IDSTMT
DIM VAR AS INTEGER
VAR = GETVARINDEX
CALL EXPECT("=")
VARS(VAR) = EXPRESSION
END SUB

SUB IFSTMT
DIM B AS INTEGER
IF EXPRESSION = 0 THEN CALL SKIPTOEOL: EXIT SUB
B = ACCEPT("THEN")
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
CALL GOTOLINE
END IF
END SUB

SUB INITGETSYM (N AS INTEGER)
CURLINE = N
TEXTP = 1
THELIN$ = PGM$(CURLINE)
CH$ = " "
CALL GETSYM
END SUB

SUB INPUTSTMT
DIM VAR AS INTEGER
IF TOK$ = CHR$(34) THEN
PRINT MID$(TOK$, 2, LEN(TOK$) - 1);
CALL GETSYM
CALL EXPECT(",")
ELSE
PRINT "? ";
END IF
VAR = GETVARINDEX
INPUT VARS(VAR)
END SUB

SUB LISTSTMT
DIM I AS INTEGER
FOR I = 1 TO 1999
IF PGM$(I) <> "" THEN PRINT I; " "; PGM$(I)
NEXT I
PRINT
END SUB

SUB LLISTSTMT
DIM I AS INTEGER
FOR I = 1 TO 1999
IF PGM$(I) <> "" THEN LPRINT I; " "; PGM$(I)
NEXT I
PRINT
END SUB

SUB LPRINTSTMT
DIM LPRINTNL AS INTEGER
LPRINTNL = 1
DO WHILE TOK$ <> ""
LPRINTNL = 1
IF LEFT$(TOK$, 1) = CHR$(34) THEN
LPRINT MID$(TOK$, 2, LEN(TOK$) - 1);
CALL GETSYM
ELSE
LPRINT EXPRESSION;
END IF
IF ACCEPT(",") = 0 AND ACCEPT(";") = 0 THEN EXIT DO
PRINTNL = 0
LOOP
IF PRINTNL <> 0 THEN LPRINT

END SUB

SUB PRINTSTMT
DIM PRINTNL AS INTEGER
PRINTNL = 1
DO WHILE TOK$ <> ""
PRINTNL = 1
IF LEFT$(TOK$, 1) = CHR$(34) THEN
PRINT MID$(TOK$, 2, LEN(TOK$) - 1);
CALL GETSYM
ELSE
PRINT EXPRESSION;
END IF


IF ACCEPT(",") = 0 AND ACCEPT(";") = 0 THEN EXIT DO
PRINTNL = 0
LOOP
IF PRINTNL <> 0 THEN PRINT
END SUB

SUB READIDENT
TOK$ = ""
WHILE CH$ >= "A" AND CH$ <= "Z"
TOK$ = TOK$ + CH$
CALL GETCH
WEND
END SUB

SUB READINT
TOK$ = ""
WHILE CH$ >= "0" AND CH$ <= "9"
TOK$ = TOK$ + CH$
CALL GETCH
WEND
NUM = VAL(TOK$)
END SUB

SUB READSTR
TOK$ = CHR$(34)
CALL GETCH
WHILE CH$ <> CHR$(34)
IF CH$ = "" THEN
PRINT "STRING NOT TERMINATED": ERRORS = 1: EXIT SUB
END IF
TOK$ = TOK$ + CH$
CALL GETCH
WEND
CALL GETCH
END SUB

SUB SKIPTOEOL
WHILE CH$ <> ""
CALL GETCH
WEND
CALL GETSYM
END SUB

FUNCTION TERM%
DIM N
N = FACTOR%
TERML:
IF TOK$ = "*" THEN CALL GETSYM: N = N * FACTOR%: GOTO TERML
IF TOK$ = "/" THEN CALL GETSYM: N = N / FACTOR%: GOTO TERML
TERM% = N
END FUNCTION

SUB VALIDLINENUM
IF NUM > 0 AND NUM <= 1999 THEN EXIT SUB
PRINT "LINE NUMBER OUT OF RANGE": ERRORS = 1
END SUB

DEFINT A-Z
DECLARE SUB NEXTSTMT ()
DECLARE SUB FORSTMT ()
DECLARE SUB WIDTHSTMT ()
DECLARE SUB LOCATESTMT ()
DECLARE SUB COLORSTMT ()
DECLARE SUB GOSUBLINE ()
DECLARE SUB GOSUBSTMT ()
DECLARE SUB RETURNSTMT ()
DECLARE SUB LLISTSTMT ()
DECLARE SUB LPRINTSTMT ()
DECLARE SUB INITGETSYM (N AS INTEGER)
DECLARE SUB VALIDLINENUM ()
DECLARE SUB DOCMD ()
DECLARE SUB CLEARVARS ()
DECLARE SUB LISTSTMT ()
DECLARE SUB GOTOSTMT ()
DECLARE SUB IFSTMT ()
DECLARE SUB INPUTSTMT ()
DECLARE SUB PRINTSTMT ()
DECLARE SUB SKIPTOEOL ()
DECLARE SUB IDSTMT ()
DECLARE SUB GETSYM ()
DECLARE SUB EXPECT (S AS STRING)
DECLARE SUB GOTOLINE ()
DECLARE FUNCTION EXPRESSION% ()
DECLARE FUNCTION ADDEXPR% ()
DECLARE FUNCTION TERM% ()
DECLARE FUNCTION FACTOR% ()
DECLARE FUNCTION GETVARINDEX% ()
DECLARE FUNCTION ACCEPT% (S AS STRING)
DECLARE SUB GETCH ()
DECLARE SUB READSTR ()
DECLARE SUB READIDENT ()
DECLARE SUB READINT ()

CONST STACKSIZE = 500
CONST PGMSIZE = 2000
DIM SHARED CH$, THELIN$, PGM$(PGMSIZE), TOK$, STACK(STACKSIZE) AS INTEGER
DIM SHARED LOOPVARS(26) AS INTEGER, LOOPLINES(26) AS INTEGER
DIM SHARED LOOPMAX(26) AS INTEGER, LOOPSTEP(26) AS INTEGER
DIM SHARED WSTACK(STACKSIZE)
DIM SHARED STACKP AS INTEGER, LOOPP AS INTEGER, WHILEP AS INTEGER
STACKP = -1
LOOPP = -1
WHILEP = -1
DIM SHARED VARS(26) AS INTEGER, CURLINE AS INTEGER, NUM AS INTEGER
DIM SHARED TEXTP AS INTEGER, ERRORS AS INTEGER
DIM SHARED HEIGHT AS INTEGER, CURWIDTH AS INTEGER
WIDTH 80, 25
HEIGHT = 25
CURWIDTH = 80
DO
ERRORS = 0
LINE INPUT "> ", PGM$(0)
IF PGM$(0) <> "" THEN
CALL INITGETSYM(0)
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
CALL VALIDLINENUM
PGM$(NUM) = MID$(PGM$(0), TEXTP, LEN(PGM$(0)) - TEXTP + 1)
ELSE
CALL DOCMD
END IF
END IF
LOOP

DEFSNG A-Z
FUNCTION ACCEPT% (S AS STRING)
ACCEPT% = 0
IF TOK$ = S THEN ACCEPT% = 1: CALL GETSYM
END FUNCTION

FUNCTION ADDEXPR%
DIM N
N = TERM%
ADDEL:
IF TOK$ = "MOD" THEN CALL GETSYM: N = N MOD TERM%: GOTO ADDEL
IF TOK$ = "+" THEN CALL GETSYM: N = N + TERM%: GOTO ADDEL
IF TOK$ = "-" THEN CALL GETSYM: N = N - TERM%: GOTO ADDEL
ADDEXPR% = N
END FUNCTION

SUB CLEARVARS
DIM I AS INTEGER
FOR I = 1 TO 26
VARS(I) = 0
NEXT I
END SUB

SUB COLORSTMT
IF ACCEPT(",") THEN
  BACK = EXPRESSION
  IF (NOBACK = 0) AND (BACK > 15 OR BACK < 0) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
  COLOR , BACK
END IF
FORE = EXPRESSION
IF FORE < 0 OR FORE > 31 THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF ACCEPT(",") THEN BACK = EXPRESSION ELSE NOBACK = -1
IF (NOBACK = 0) AND (BACK > 15 OR BACK < 0) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF NOBACK = 0 THEN COLOR FORE, BACK ELSE COLOR FORE
END SUB

SUB DOCMD
DIM I AS INTEGER
AGAIN:
IF ERRORS <> 0 THEN EXIT SUB
WHILE TOK$ = ""
IF CURLINE = 0 OR CURLINE >= PGMSIZE THEN EXIT SUB
CALL INITGETSYM(CURLINE + 1)
WEND
IF ACCEPT("STOP") OR ACCEPT("END") THEN EXIT SUB
IF ACCEPT("NEW") THEN
CALL CLEARVARS
FOR I = 1 TO PGMSIZE
PGM$(I) = ""
NEXT I
EXIT SUB
END IF
IF ACCEPT("BYE") THEN END
IF ACCEPT("QUIT") THEN END
IF ACCEPT("LIST") THEN CALL LISTSTMT: GOTO AGAIN
IF ACCEPT("LLIST") THEN CALL LLISTSTMT: GOTO AGAIN
IF ACCEPT("RUN") THEN
CALL CLEARVARS
CALL INITGETSYM(1)
GOTO AGAIN
END IF
IF ACCEPT("GOSUB") THEN CALL GOSUBSTMT: GOTO AGAIN
IF ACCEPT("RETURN") THEN CALL RETURNSTMT: GOTO AGAIN
IF ACCEPT("GOTO") THEN CALL GOTOSTMT: GOTO AGAIN
IF ACCEPT("IF") THEN CALL IFSTMT: GOTO AGAIN
IF ACCEPT("INPUT") THEN CALL INPUTSTMT: GOTO AGAIN
IF ACCEPT("PRINT") THEN CALL PRINTSTMT: GOTO AGAIN
IF ACCEPT("LPRINT") THEN CALL LPRINTSTMT: GOTO AGAIN
IF ACCEPT("REM") THEN CALL SKIPTOEOL: GOTO AGAIN
IF ACCEPT("CLS") THEN CLS : GOTO AGAIN
IF ACCEPT("COLOR") THEN CALL COLORSTMT: GOTO AGAIN
IF ACCEPT("COLOUR") THEN CALL COLORSTMT: GOTO AGAIN
IF ACCEPT("LOCATE") THEN CALL LOCATESTMT: GOTO AGAIN
IF ACCEPT("WIDTH") THEN CALL WIDTHSTMT: GOTO AGAIN
IF ACCEPT("FOR") THEN CALL FORSTMT: GOTO AGAIN
IF ACCEPT("NEXT") THEN CALL NEXTSTMT: GOTO AGAIN
IF LEFT$(TOK$, 1) >= "A" AND LEFT$(TOK$, 1) <= "Z" THEN
CALL IDSTMT
GOTO AGAIN
END IF
PRINT "UNKNOWN TOKEN "; TOK$; " AT LINE "; CURLINE
END SUB

SUB EXPECT (S AS STRING)
IF ACCEPT(S) <> 0 THEN EXIT SUB
ERRORS = 1
PRINT "EXPECTING "; S; " BUT FOUND "; TOK$
END SUB

FUNCTION EXPRESSION%
DIM N
N = ADDEXPR%
EXPRL:
IF TOK$ = "=" THEN CALL GETSYM: N = N = ADDEXPR%: GOTO EXPRL
IF TOK$ = "<" THEN CALL GETSYM: N = N < ADDEXPR%: GOTO EXPRL
IF TOK$ = ">" THEN CALL GETSYM: N = N > ADDEXPR%: GOTO EXPRL
IF TOK$ = "<>" THEN CALL GETSYM: N = N <> ADDEXPR%: GOTO EXPRL
IF TOK$ = "<=" THEN CALL GETSYM: N = N <= ADDEXPR%: GOTO EXPRL
IF TOK$ = ">=" THEN CALL GETSYM: N = N >= ADDEXPR%: GOTO EXPRL
IF TOK$ = "NOT" THEN CALL GETSYM: N = NOT ADDEXPR%: GOTO EXPRL
IF TOK$ = "AND" THEN CALL GETSYM: N = N AND ADDEXPR%: GOTO EXPRL
IF TOK$ = "OR" THEN CALL GETSYM: N = N OR ADDEXPR%: GOTO EXPRL
IF TOK$ = "XOR" THEN CALL GETSYM: N = N XOR ADDEXPR%: GOTO EXPRL
IF TOK$ = "EQV" THEN CALL GETSYM: N = N EQV ADDEXPR%: GOTO EXPRL
IF TOK$ = "IMP" THEN CALL GETSYM: N = N IMP ADDEXPR%: GOTO EXPRL
EXPRESSION% = N
END FUNCTION

FUNCTION FACTOR%
IF ACCEPT("-") THEN
  FACTOR% = -EXPRESSION
  EXIT FUNCTION
END IF
IF ACCEPT("(") THEN
FACTOR% = EXPRESSION
CALL EXPECT(")")
EXIT FUNCTION
END IF
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
FACTOR% = NUM
CALL GETSYM
EXIT FUNCTION
END IF
IF LEFT$(TOK$, 1) >= "A" AND LEFT$(TOK$, 1) <= "Z" THEN
FACTOR% = VARS(GETVARINDEX)
EXIT FUNCTION
END IF
PRINT "UNEXPECTED SYM "; TOK$; " IN FACTOR": ERRORS = 1
END FUNCTION

DEFINT A-Z
SUB FORSTMT
  DIM VAR AS INTEGER
  VAR = GETVARINDEX
  IF LOOPP >= 0 THEN
    IF CURLINE = LOOPLINES(LOOPP) THEN CALL SKIPTOEOL: EXIT SUB
    FOR I = 0 TO LOOPP
      IF LOOPVARS(LOOPP) = VAR THEN PRINT "FOR INDEX VARIABLE ALREADY IN USE": ERRORS = 1: EXIT SUB
    NEXT
  END IF
  CALL EXPECT("=")
  VARS(VAR) = EXPRESSION
  LOOPP = LOOPP + 1
  LOOPVARS(LOOPP) = VAR
  LOOPLINES(LOOPP) = CURLINE
  CALL EXPECT("TO")
  LOOPMAX(LOOPP) = EXPRESSION
  IF ACCEPT("STEP") THEN LOOPSTEP(LOOPP) = EXPRESSION ELSE LOOPSTEP(LOOPP) = 1
END SUB

DEFSNG A-Z
SUB GETCH
IF TEXTP > LEN(THELIN$) THEN CH$ = "": EXIT SUB
CH$ = MID$(THELIN$, TEXTP, 1)
TEXTP = TEXTP + 1
END SUB

SUB GETSYM
TOK$ = ""
WHILE CH$ <= " "
IF CH$ = "" THEN EXIT SUB
CALL GETCH
WEND


TOK$ = CH$
IF INSTR(",;=+-*/^()", CH$) > 0 THEN CALL GETCH: EXIT SUB
IF CH$ = "<" THEN
CALL GETCH
IF CH$ = "=" OR CH$ = ">" THEN
TOK$ = TOK$ + CH$
CALL GETCH
END IF
EXIT SUB
END IF
IF CH$ = ">" THEN
CALL GETCH
IF CH$ = "=" THEN TOK$ = TOK$ + CH$: CALL GETCH
EXIT SUB
END IF
IF CH$ = CHR$(34) THEN CALL READSTR: EXIT SUB
IF CH$ = CHR$(39) THEN CALL SKIPTOEOL: EXIT SUB
CH$ = UCASE$(CH$)
IF CH$ >= "A" AND CH$ <= "Z" THEN CALL READIDENT: EXIT SUB
IF CH$ >= "0" AND CH$ <= "9" THEN CALL READINT: EXIT SUB
PRINT "WHAT->"; CH$: ERRORS = 1
END SUB

FUNCTION GETVARINDEX%
IF LEFT$(TOK$, 1) < "A" OR LEFT$(TOK$, 1) > "Z" THEN
PRINT "NOT A VARIABLE": ERRORS = 1: EXIT FUNCTION
END IF
GETVARINDEX% = ASC(LEFT$(TOK$, 1)) - ASC("A")
CALL GETSYM
END FUNCTION

SUB GOSUBLINE
  CALL VALIDLINENUM
  STACKP = STACKP + 1
  IF STACKP > 255 THEN PRINT "OUT OF STACK SPACE": ERRORS = 1
  STACK(STACKP) = CURLINE
  CALL INITGETSYM(NUM)
END SUB

SUB GOSUBSTMT
  IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
  CALL GOSUBLINE
  EXIT SUB
  END IF
  PRINT "LINE NUMBER MUST FOLLOW GOSUB": ERRORS = 1
END SUB

SUB GOTOLINE
CALL VALIDLINENUM
CALL INITGETSYM(NUM)
END SUB

SUB GOTOSTMT
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
CALL GOTOLINE
EXIT SUB
END IF
PRINT "LINE NUMBER MUST FOLLOW GOTO": ERRORS = 1
END SUB

SUB IDSTMT
DIM VAR AS INTEGER
VAR = GETVARINDEX
CALL EXPECT("=")
VARS(VAR) = EXPRESSION
END SUB

SUB IFSTMT
DIM B AS INTEGER
IF EXPRESSION = 0 THEN CALL SKIPTOEOL: EXIT SUB
B = ACCEPT("THEN")
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
CALL GOTOLINE
END IF
END SUB

SUB INITGETSYM (N AS INTEGER)
CURLINE = N
TEXTP = 1
THELIN$ = PGM$(CURLINE)
CH$ = " "
CALL GETSYM
END SUB

SUB INPUTSTMT
DIM VAR AS INTEGER
IF TOK$ = CHR$(34) THEN
PRINT MID$(TOK$, 2, LEN(TOK$) - 1);
CALL GETSYM
CALL EXPECT(",")
ELSE
PRINT "? ";
END IF
VAR = GETVARINDEX
INPUT VARS(VAR)
END SUB

SUB LISTSTMT
DIM I AS INTEGER
FOR I = 1 TO PGMSIZE
IF PGM$(I) <> "" THEN PRINT I; " "; PGM$(I)
NEXT I
PRINT
END SUB

SUB LLISTSTMT
OPEN "LPT1" FOR OUTPUT AS #1
DIM I AS INTEGER
FOR I = 1 TO 1999
IF PGM$(I) <> "" THEN PRINT #1, I; " "; PGM$(I)
NEXT I
PRINT
CLOSE #1
END SUB

SUB LOCATESTMT
IF ACCEPT(",") THEN COL = EXPRESSION: ROW = CSRLIN: GOTO 2
ROW = EXPRESSION
IF ROW <= 0 OR ROW > HEIGHT THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF ACCEPT(",") THEN COL = EXPRESSION ELSE NOCOL = -1
2 IF (NOCOL = 0) AND (COL <= 0 OR COL >= CURWIDTH) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF NOCOL = 0 THEN LOCATE ROW, COL ELSE LOCATE ROW
END SUB

SUB LPRINTSTMT
OPEN "LPT1" FOR OUTPUT AS #1
DIM LPRINTNL AS INTEGER
LPRINTNL = 1
DO WHILE TOK$ <> ""
LPRINTNL = 1
IF LEFT$(TOK$, 1) = CHR$(34) THEN
PRINT #1, MID$(TOK$, 2, LEN(TOK$) - 1);
CALL GETSYM
ELSE
PRINT #1, EXPRESSION;
END IF
IF ACCEPT(",") = 0 AND ACCEPT(";") = 0 THEN EXIT DO
PRINTNL = 0
LOOP
IF PRINTNL <> 0 THEN PRINT #1, ""
CLOSE #1
END SUB

DEFINT A-Z
SUB NEXTSTMT
  IF LOOPP < 0 THEN PRINT "NEXT WITHOUT FOR": EXIT SUB
  VARS(LOOPVARS(LOOPP)) = VARS(LOOPVARS(LOOPP)) + LOOPSTEP(LOOPP)
  IF VARS(LOOPVARS(LOOPP)) <= LOOPMAX(LOOPP) THEN
    CALL INITGETSYM(LOOPLINES(LOOPP))
  ELSE
    LOOPP = LOOPP - 1
  END IF
END SUB

DEFSNG A-Z
SUB PRINTSTMT
DIM PRINTNL AS INTEGER
PRINTNL = 1
DO WHILE TOK$ <> ""
PRINTNL = 1
IF LEFT$(TOK$, 1) = CHR$(34) THEN
PRINT MID$(TOK$, 2, LEN(TOK$) - 1);
CALL GETSYM
ELSE
PRINT EXPRESSION;
END IF

IF ACCEPT(",") = 0 AND ACCEPT(";") = 0 THEN EXIT DO
PRINTNL = 0
LOOP
IF PRINTNL <> 0 THEN PRINT
END SUB

SUB READIDENT
TOK$ = ""
WHILE CH$ >= "A" AND CH$ <= "Z"
TOK$ = TOK$ + CH$
CALL GETCH
WEND
END SUB

SUB READINT
TOK$ = ""
WHILE CH$ >= "0" AND CH$ <= "9"
TOK$ = TOK$ + CH$
CALL GETCH
WEND
NUM = VAL(TOK$)
END SUB

SUB READSTR
TOK$ = CHR$(34)
CALL GETCH
WHILE CH$ <> CHR$(34)
IF CH$ = "" THEN
PRINT "STRING NOT TERMINATED": ERRORS = 1: EXIT SUB
END IF
TOK$ = TOK$ + CH$
CALL GETCH
WEND
CALL GETCH
END SUB

SUB RETURNSTMT
  IF STACKP < 0 THEN PRINT "RETURN WITHOUT GOSUB": EXIT SUB
  LIN = STACK(STACKP)
  STACKP = STACKP - 1
  CALL INITGETSYM(LIN + 1)
END SUB

SUB SKIPTOEOL
WHILE CH$ <> ""
CALL GETCH
WEND
CALL GETSYM
END SUB

FUNCTION TERM%
DIM N
N = FACTOR%
TERML:
IF TOK$ = "*" THEN CALL GETSYM: N = N * FACTOR%: GOTO TERML
IF TOK$ = "/" THEN CALL GETSYM: N = N / FACTOR%: GOTO TERML
IF TOK$ = "^" THEN CALL GETSYM: N = N ^ FACTOR: GOTO TERML
TERM% = N
END FUNCTION

SUB VALIDLINENUM
IF NUM > 0 AND NUM <= 1999 THEN EXIT SUB
PRINT "LINE NUMBER OUT OF RANGE": ERRORS = 1
END SUB

DEFINT A-Z
SUB WIDTHSTMT
IF ACCEPT(",") THEN CHEIGHT = EXPRESSION: CWIDTH = CURWIDTH: GOTO 1
CWIDTH = EXPRESSION
IF (CWIDTH <> 40) AND (CWIDTH <> 80) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF ACCEPT(",") THEN CHEIGHT = EXPRESSION ELSE NOCHIEGHT = -1
1 IF (NOCHEIGHT = 0) AND (CHEIGHT <> 25 AND CHEIGHT <> 43 AND CHEIGHT <> 50) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF NOCHEIGHT THEN
  WIDTH CWIDTH
  CURWIDTH = CWIDTH
ELSE
  WIDTH CWIDTH, CHEIGHT
  CURWIDTH = CWIDTH
  HEIGHT = CHEIGHT
END IF
END SUB

DEFINT A-Z
DECLARE SUB NEXTSTMT ()
DECLARE SUB FORSTMT ()
DECLARE SUB WIDTHSTMT ()
DECLARE SUB LOCATESTMT ()
DECLARE SUB COLORSTMT ()
DECLARE SUB GOSUBLINE ()
DECLARE SUB GOSUBSTMT ()
DECLARE SUB RETURNSTMT ()
DECLARE SUB LLISTSTMT ()
DECLARE SUB LPRINTSTMT ()
DECLARE SUB INITGETSYM (N AS INTEGER)
DECLARE SUB VALIDLINENUM ()
DECLARE SUB DOCMD ()
DECLARE SUB CLEARVARS ()
DECLARE SUB LISTSTMT ()
DECLARE SUB GOTOSTMT ()
DECLARE SUB IFSTMT ()
DECLARE SUB INPUTSTMT ()
DECLARE SUB PRINTSTMT ()
DECLARE SUB SKIPTOEOL ()
DECLARE SUB IDSTMT ()
DECLARE SUB GETSYM ()
DECLARE SUB EXPECT (S AS STRING)
DECLARE SUB GOTOLINE ()
DECLARE FUNCTION EXPRESSION% ()
DECLARE FUNCTION ADDEXPR% ()
DECLARE FUNCTION TERM% ()
DECLARE FUNCTION FACTOR% ()
DECLARE FUNCTION GETVARINDEX% ()
DECLARE FUNCTION ACCEPT% (S AS STRING)
DECLARE SUB GETCH ()
DECLARE SUB READSTR ()
DECLARE SUB READIDENT ()
DECLARE SUB READINT ()

CONST STACKSIZE = 500
CONST PGMSIZE = 2000
DIM SHARED CH$, THELIN$, PGM$(PGMSIZE), TOK$, STACK(STACKSIZE) AS INTEGER
DIM SHARED LOOPVARS(26) AS INTEGER, LOOPLINES(26) AS INTEGER
DIM SHARED LOOPMAX(26) AS INTEGER, LOOPSTEP(26) AS INTEGER
DIM SHARED WSTACK(STACKSIZE)
DIM SHARED STACKP AS INTEGER, LOOPP AS INTEGER, WHILEP AS INTEGER
STACKP = -1
LOOPP = -1
WHILEP = -1
DIM SHARED VARS(26) AS INTEGER, CURLINE AS INTEGER, NUM AS INTEGER
DIM SHARED TEXTP AS INTEGER, ERRORS AS INTEGER
DIM SHARED HEIGHT AS INTEGER, CURWIDTH AS INTEGER
WIDTH 80, 25
HEIGHT = 25
CURWIDTH = 80
DO
ERRORS = 0
LINE INPUT "> ", PGM$(0)
IF PGM$(0) <> "" THEN
CALL INITGETSYM(0)
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
CALL VALIDLINENUM
PGM$(NUM) = MID$(PGM$(0), TEXTP, LEN(PGM$(0)) - TEXTP + 1)
ELSE
CALL DOCMD
END IF
END IF
LOOP

DEFSNG A-Z
FUNCTION ACCEPT% (S AS STRING)
ACCEPT% = 0
IF TOK$ = S THEN ACCEPT% = 1: CALL GETSYM
END FUNCTION

FUNCTION ADDEXPR%
DIM N
N = TERM%
ADDEL:
IF TOK$ = "MOD" THEN CALL GETSYM: N = N MOD TERM%: GOTO ADDEL
IF TOK$ = "+" THEN CALL GETSYM: N = N + TERM%: GOTO ADDEL
IF TOK$ = "-" THEN CALL GETSYM: N = N - TERM%: GOTO ADDEL
ADDEXPR% = N
END FUNCTION

SUB CLEARVARS
DIM I AS INTEGER
FOR I = 1 TO 26
VARS(I) = 0
NEXT I
END SUB

SUB COLORSTMT
IF ACCEPT(",") THEN
  BACK = EXPRESSION
  IF (NOBACK = 0) AND (BACK > 15 OR BACK < 0) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
  COLOR , BACK
END IF
FORE = EXPRESSION
IF FORE < 0 OR FORE > 31 THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF ACCEPT(",") THEN BACK = EXPRESSION ELSE NOBACK = -1
IF (NOBACK = 0) AND (BACK > 15 OR BACK < 0) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF NOBACK = 0 THEN COLOR FORE, BACK ELSE COLOR FORE
END SUB

SUB DOCMD
DIM I AS INTEGER
AGAIN:
IF ERRORS <> 0 THEN EXIT SUB
WHILE TOK$ = ""
IF CURLINE = 0 OR CURLINE >= PGMSIZE THEN EXIT SUB
CALL INITGETSYM(CURLINE + 1)
WEND
IF ACCEPT("STOP") OR ACCEPT("END") THEN EXIT SUB
IF ACCEPT("NEW") THEN
CALL CLEARVARS
FOR I = 1 TO PGMSIZE
PGM$(I) = ""
NEXT I
EXIT SUB
END IF
IF ACCEPT("BYE") THEN END
IF ACCEPT("QUIT") THEN END
IF ACCEPT("LIST") THEN CALL LISTSTMT: GOTO AGAIN
IF ACCEPT("LLIST") THEN CALL LLISTSTMT: GOTO AGAIN
IF ACCEPT("RUN") THEN
CALL CLEARVARS
CALL INITGETSYM(1)
GOTO AGAIN
END IF
IF ACCEPT("GOSUB") THEN CALL GOSUBSTMT: GOTO AGAIN
IF ACCEPT("RETURN") THEN CALL RETURNSTMT: GOTO AGAIN
IF ACCEPT("GOTO") THEN CALL GOTOSTMT: GOTO AGAIN
IF ACCEPT("IF") THEN CALL IFSTMT: GOTO AGAIN
IF ACCEPT("INPUT") THEN CALL INPUTSTMT: GOTO AGAIN
IF ACCEPT("PRINT") THEN CALL PRINTSTMT: GOTO AGAIN
IF ACCEPT("LPRINT") THEN CALL LPRINTSTMT: GOTO AGAIN
IF ACCEPT("REM") THEN CALL SKIPTOEOL: GOTO AGAIN
IF ACCEPT("CLS") THEN CLS : GOTO AGAIN
IF ACCEPT("COLOR") THEN CALL COLORSTMT: GOTO AGAIN
IF ACCEPT("COLOUR") THEN CALL COLORSTMT: GOTO AGAIN
IF ACCEPT("LOCATE") THEN CALL LOCATESTMT: GOTO AGAIN
IF ACCEPT("WIDTH") THEN CALL WIDTHSTMT: GOTO AGAIN
IF ACCEPT("FOR") THEN CALL FORSTMT: GOTO AGAIN
IF ACCEPT("NEXT") THEN CALL NEXTSTMT: GOTO AGAIN
IF LEFT$(TOK$, 1) >= "A" AND LEFT$(TOK$, 1) <= "Z" THEN
CALL IDSTMT
GOTO AGAIN
END IF
PRINT "UNKNOWN TOKEN "; TOK$; " AT LINE "; CURLINE
END SUB

SUB EXPECT (S AS STRING)
IF ACCEPT(S) <> 0 THEN EXIT SUB
ERRORS = 1
PRINT "EXPECTING "; S; " BUT FOUND "; TOK$
END SUB

FUNCTION EXPRESSION%
DIM N
N = ADDEXPR%
EXPRL:
IF TOK$ = "=" THEN CALL GETSYM: N = N = ADDEXPR%: GOTO EXPRL
IF TOK$ = "<" THEN CALL GETSYM: N = N < ADDEXPR%: GOTO EXPRL
IF TOK$ = ">" THEN CALL GETSYM: N = N > ADDEXPR%: GOTO EXPRL
IF TOK$ = "<>" THEN CALL GETSYM: N = N <> ADDEXPR%: GOTO EXPRL
IF TOK$ = "<=" THEN CALL GETSYM: N = N <= ADDEXPR%: GOTO EXPRL
IF TOK$ = ">=" THEN CALL GETSYM: N = N >= ADDEXPR%: GOTO EXPRL
IF TOK$ = "NOT" THEN CALL GETSYM: N = NOT ADDEXPR%: GOTO EXPRL
IF TOK$ = "AND" THEN CALL GETSYM: N = N AND ADDEXPR%: GOTO EXPRL
IF TOK$ = "OR" THEN CALL GETSYM: N = N OR ADDEXPR%: GOTO EXPRL
IF TOK$ = "XOR" THEN CALL GETSYM: N = N XOR ADDEXPR%: GOTO EXPRL
IF TOK$ = "EQV" THEN CALL GETSYM: N = N EQV ADDEXPR%: GOTO EXPRL
IF TOK$ = "IMP" THEN CALL GETSYM: N = N IMP ADDEXPR%: GOTO EXPRL
EXPRESSION% = N
END FUNCTION

FUNCTION FACTOR%
IF ACCEPT("-") THEN
  FACTOR% = -EXPRESSION
  EXIT FUNCTION
END IF
IF ACCEPT("(") THEN
FACTOR% = EXPRESSION
CALL EXPECT(")")
EXIT FUNCTION
END IF
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
FACTOR% = NUM
CALL GETSYM
EXIT FUNCTION
END IF
IF LEFT$(TOK$, 1) >= "A" AND LEFT$(TOK$, 1) <= "Z" THEN
FACTOR% = VARS(GETVARINDEX)
EXIT FUNCTION
END IF
PRINT "UNEXPECTED SYM "; TOK$; " IN FACTOR": ERRORS = 1
END FUNCTION

DEFINT A-Z
SUB FORSTMT
  DIM VAR AS INTEGER
  VAR = GETVARINDEX
  IF LOOPP >= 0 THEN
    IF CURLINE = LOOPLINES(LOOPP) THEN CALL SKIPTOEOL: EXIT SUB
    FOR I = 0 TO LOOPP
      IF LOOPVARS(LOOPP) = VAR THEN PRINT "FOR INDEX VARIABLE ALREADY IN USE": ERRORS = 1: EXIT SUB
    NEXT
  END IF
  CALL EXPECT("=")
  VARS(VAR) = EXPRESSION
  LOOPP = LOOPP + 1
  LOOPVARS(LOOPP) = VAR
  LOOPLINES(LOOPP) = CURLINE
  CALL EXPECT("TO")
  LOOPMAX(LOOPP) = EXPRESSION
  IF ACCEPT("STEP") THEN LOOPSTEP(LOOPP) = EXPRESSION ELSE LOOPSTEP(LOOPP) = 1
END SUB

DEFSNG A-Z
SUB GETCH
IF TEXTP > LEN(THELIN$) THEN CH$ = "": EXIT SUB
CH$ = MID$(THELIN$, TEXTP, 1)
TEXTP = TEXTP + 1
END SUB

SUB GETSYM
TOK$ = ""
WHILE CH$ <= " "
IF CH$ = "" THEN EXIT SUB
CALL GETCH
WEND


TOK$ = CH$
IF INSTR(",;=+-*/^()", CH$) > 0 THEN CALL GETCH: EXIT SUB
IF CH$ = "<" THEN
CALL GETCH
IF CH$ = "=" OR CH$ = ">" THEN
TOK$ = TOK$ + CH$
CALL GETCH
END IF
EXIT SUB
END IF
IF CH$ = ">" THEN
CALL GETCH
IF CH$ = "=" THEN TOK$ = TOK$ + CH$: CALL GETCH
EXIT SUB
END IF
IF CH$ = CHR$(34) THEN CALL READSTR: EXIT SUB
IF CH$ = CHR$(39) THEN CALL SKIPTOEOL: EXIT SUB
CH$ = UCASE$(CH$)
IF CH$ >= "A" AND CH$ <= "Z" THEN CALL READIDENT: EXIT SUB
IF CH$ >= "0" AND CH$ <= "9" THEN CALL READINT: EXIT SUB
PRINT "WHAT->"; CH$: ERRORS = 1
END SUB

FUNCTION GETVARINDEX%
IF LEFT$(TOK$, 1) < "A" OR LEFT$(TOK$, 1) > "Z" THEN
PRINT "NOT A VARIABLE": ERRORS = 1: EXIT FUNCTION
END IF
GETVARINDEX% = ASC(LEFT$(TOK$, 1)) - ASC("A")
CALL GETSYM
END FUNCTION

SUB GOSUBLINE
  CALL VALIDLINENUM
  STACKP = STACKP + 1
  IF STACKP > 255 THEN PRINT "OUT OF STACK SPACE": ERRORS = 1
  STACK(STACKP) = CURLINE
  CALL INITGETSYM(NUM)
END SUB

SUB GOSUBSTMT
  IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
  CALL GOSUBLINE
  EXIT SUB
  END IF
  PRINT "LINE NUMBER MUST FOLLOW GOSUB": ERRORS = 1
END SUB

SUB GOTOLINE
CALL VALIDLINENUM
CALL INITGETSYM(NUM)
END SUB

SUB GOTOSTMT
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
CALL GOTOLINE
EXIT SUB
END IF
PRINT "LINE NUMBER MUST FOLLOW GOTO": ERRORS = 1
END SUB

SUB IDSTMT
DIM VAR AS INTEGER
VAR = GETVARINDEX
CALL EXPECT("=")
VARS(VAR) = EXPRESSION
END SUB

SUB IFSTMT
DIM B AS INTEGER
IF EXPRESSION = 0 THEN CALL SKIPTOEOL: EXIT SUB
B = ACCEPT("THEN")
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
CALL GOTOLINE
END IF
END SUB

SUB INITGETSYM (N AS INTEGER)
CURLINE = N
TEXTP = 1
THELIN$ = PGM$(CURLINE)
CH$ = " "
CALL GETSYM
END SUB

SUB INPUTSTMT
DIM VAR AS INTEGER
IF TOK$ = CHR$(34) THEN
PRINT MID$(TOK$, 2, LEN(TOK$) - 1);
CALL GETSYM
CALL EXPECT(",")
ELSE
PRINT "? ";
END IF
VAR = GETVARINDEX
INPUT VARS(VAR)
END SUB

SUB LISTSTMT
DIM I AS INTEGER
FOR I = 1 TO PGMSIZE
IF PGM$(I) <> "" THEN PRINT I; " "; PGM$(I)
NEXT I
PRINT
END SUB

SUB LLISTSTMT
OPEN "LPT1" FOR OUTPUT AS #1
DIM I AS INTEGER
FOR I = 1 TO 1999
IF PGM$(I) <> "" THEN PRINT #1, I; " "; PGM$(I)
NEXT I
PRINT
CLOSE #1
END SUB

SUB LOCATESTMT
IF ACCEPT(",") THEN COL = EXPRESSION: ROW = CSRLIN: GOTO 2
ROW = EXPRESSION
IF ROW <= 0 OR ROW > HEIGHT THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF ACCEPT(",") THEN COL = EXPRESSION ELSE NOCOL = -1
2 IF (NOCOL = 0) AND (COL <= 0 OR COL >= CURWIDTH) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF NOCOL = 0 THEN LOCATE ROW, COL ELSE LOCATE ROW
END SUB

SUB LPRINTSTMT
OPEN "LPT1" FOR OUTPUT AS #1
DIM LPRINTNL AS INTEGER
LPRINTNL = 1
DO WHILE TOK$ <> ""
LPRINTNL = 1
IF LEFT$(TOK$, 1) = CHR$(34) THEN
PRINT #1, MID$(TOK$, 2, LEN(TOK$) - 1);
CALL GETSYM
ELSE
PRINT #1, EXPRESSION;
END IF
IF ACCEPT(",") = 0 AND ACCEPT(";") = 0 THEN EXIT DO
PRINTNL = 0
LOOP
IF PRINTNL <> 0 THEN PRINT #1, ""
CLOSE #1
END SUB

DEFINT A-Z
SUB NEXTSTMT
  IF LOOPP < 0 THEN PRINT "NEXT WITHOUT FOR": EXIT SUB
  VARS(LOOPVARS(LOOPP)) = VARS(LOOPVARS(LOOPP)) + LOOPSTEP(LOOPP)
  IF VARS(LOOPVARS(LOOPP)) <= LOOPMAX(LOOPP) THEN
    CALL INITGETSYM(LOOPLINES(LOOPP))
  ELSE
    LOOPP = LOOPP - 1
  END IF
END SUB

DEFSNG A-Z
SUB PRINTSTMT
DIM PRINTNL AS INTEGER
PRINTNL = 1
DO WHILE TOK$ <> ""
PRINTNL = 1
IF LEFT$(TOK$, 1) = CHR$(34) THEN
PRINT MID$(TOK$, 2, LEN(TOK$) - 1);
CALL GETSYM
ELSE
PRINT EXPRESSION;
END IF

IF ACCEPT(",") = 0 AND ACCEPT(";") = 0 THEN EXIT DO
PRINTNL = 0
LOOP
IF PRINTNL <> 0 THEN PRINT
END SUB

SUB READIDENT
TOK$ = ""
WHILE CH$ >= "A" AND CH$ <= "Z"
TOK$ = TOK$ + CH$
CALL GETCH
WEND
END SUB

SUB READINT
TOK$ = ""
WHILE CH$ >= "0" AND CH$ <= "9"
TOK$ = TOK$ + CH$
CALL GETCH
WEND
NUM = VAL(TOK$)
END SUB

SUB READSTR
TOK$ = CHR$(34)
CALL GETCH
WHILE CH$ <> CHR$(34)
IF CH$ = "" THEN
PRINT "STRING NOT TERMINATED": ERRORS = 1: EXIT SUB
END IF
TOK$ = TOK$ + CH$
CALL GETCH
WEND
CALL GETCH
END SUB

SUB RETURNSTMT
  IF STACKP < 0 THEN PRINT "RETURN WITHOUT GOSUB": EXIT SUB
  LIN = STACK(STACKP)
  STACKP = STACKP - 1
  CALL INITGETSYM(LIN + 1)
END SUB

SUB SKIPTOEOL
WHILE CH$ <> ""
CALL GETCH
WEND
CALL GETSYM
END SUB

FUNCTION TERM%
DIM N
N = FACTOR%
TERML:
IF TOK$ = "*" THEN CALL GETSYM: N = N * FACTOR%: GOTO TERML
IF TOK$ = "/" THEN CALL GETSYM: N = N / FACTOR%: GOTO TERML
IF TOK$ = "^" THEN CALL GETSYM: N = N ^ FACTOR: GOTO TERML
TERM% = N
END FUNCTION

SUB VALIDLINENUM
IF NUM > 0 AND NUM <= 1999 THEN EXIT SUB
PRINT "LINE NUMBER OUT OF RANGE": ERRORS = 1
END SUB

DEFINT A-Z
SUB WIDTHSTMT
IF ACCEPT(",") THEN CHEIGHT = EXPRESSION: CWIDTH = CURWIDTH: GOTO 1
CWIDTH = EXPRESSION
IF (CWIDTH <> 40) AND (CWIDTH <> 80) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF ACCEPT(",") THEN CHEIGHT = EXPRESSION ELSE NOCHIEGHT = -1
1 IF (NOCHEIGHT = 0) AND (CHEIGHT <> 25 AND CHEIGHT <> 43 AND CHEIGHT <> 50) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF NOCHEIGHT THEN
  WIDTH CWIDTH
  CURWIDTH = CWIDTH
ELSE
  WIDTH CWIDTH, CHEIGHT
  CURWIDTH = CWIDTH
  HEIGHT = CHEIGHT
END IF
END SUB

' It now supports decimals, trig functions, (more trig functions than QBASIC)
' -- It has SEC, CSC, COT, ASIN, ACOS, ASEC, ACSC, ACOT, and hyperbolic
' trig functions, DEG and RAD for converting to degrees and radians
' It also has logarithms, which also have more functions than QB
' [base10=LOG10, base e = LN or LOG, base n = LOG(x, n)]; random nunbers;
' GOSUB, RETURN, COLOR, LOCATE, WIDTH, FOR, NEXT, TIMER, variable names
' longer than 1 letter, lowercase keywords, correct order of operations,
' the useless unary plus operator, and probably some other stuff that I
' forgot.
DEFSTR A-Z
DECLARE FUNCTION ASECH# (Z AS DOUBLE)
DECLARE FUNCTION ACOTH# (Z AS DOUBLE)
DECLARE FUNCTION ASINH# (Z AS DOUBLE)
DECLARE FUNCTION ATANH# (Z AS DOUBLE)
DECLARE FUNCTION TANH# (Z AS DOUBLE)
DECLARE FUNCTION ACSCH# (Z AS DOUBLE)
DECLARE FUNCTION ACOSH# (Z AS DOUBLE)
DECLARE FUNCTION COSH# (Z AS DOUBLE)
DECLARE FUNCTION ASIN# (I AS DOUBLE)
DECLARE FUNCTION SINH# (Z AS DOUBLE)
DECLARE SUB RANDOMIZER ()
DECLARE FUNCTION EXPT# ()
DECLARE SUB NEXTSTMT ()
DECLARE SUB FORSTMT ()
DECLARE SUB WIDTHSTMT ()
DECLARE SUB LOCATESTMT ()
DECLARE SUB COLORSTMT ()
DECLARE SUB GOSUBLINE ()
DECLARE SUB GOSUBSTMT ()
DECLARE SUB RETURNSTMT ()
DECLARE SUB LLISTSTMT ()
DECLARE SUB LPRINTSTMT ()
DECLARE SUB INITGETSYM (N%)
DECLARE SUB VALIDLINENUM ()
DECLARE SUB DOCMD ()
DECLARE SUB CLEARVARS ()
DECLARE SUB LISTSTMT ()
DECLARE SUB GOTOSTMT ()
DECLARE SUB IFSTMT ()
DECLARE SUB INPUTSTMT ()
DECLARE SUB PRINTSTMT ()
DECLARE SUB SKIPTOEOL ()
DECLARE SUB IDSTMT ()
DECLARE SUB GETSYM ()
DECLARE SUB EXPECT (S AS STRING)
DECLARE SUB GOTOLINE ()
DECLARE FUNCTION EXPRESSION# ()
DECLARE FUNCTION ADDEXPR# ()
DECLARE FUNCTION TERM# ()
DECLARE FUNCTION FACTOR# ()
DECLARE FUNCTION GETVARINDEX% ()
DECLARE FUNCTION ACCEPT% (S AS STRING)
DECLARE SUB GETCH ()
DECLARE SUB READSTR ()
DECLARE SUB READIDENT ()
DECLARE SUB READINT ()
CONST VARSSIZE = 999
CONST STACKSIZE = 999
CONST PGMSIZE = 4000
CONST PI = 3.14159265358979#
CONST HALFPI = 1.5707963267949#
CONST E = 2.71828182845905#
DIM SHARED CH$, THELIN$, PGM$(PGMSIZE), TOK$, GOSUBSTACK(STACKSIZE) AS INTEGER
DIM SHARED LOOPVARS(VARSSIZE) AS INTEGER, LOOPLINES(VARSSIZE) AS INTEGER
DIM SHARED LOOPMAX(VARSSIZE) AS DOUBLE, LOOPSTEP(VARSSIZE) AS DOUBLE
DIM SHARED STACKP AS INTEGER, LOOPP AS INTEGER, NUMVARS AS INTEGER
STACKP = -1
LOOPP = -1
NUMVARS = 0
DIM SHARED VARNAMES(VARSSIZE) AS STRING
DIM SHARED VARS(VARSSIZE) AS DOUBLE, CURLINE AS INTEGER, NUM AS DOUBLE
DIM SHARED TEXTP AS INTEGER, ERRORS AS INTEGER
DIM SHARED HEIGHT AS INTEGER, CURWIDTH AS INTEGER
WIDTH 80, 25
HEIGHT = 25
CURWIDTH = 80
DO
ERRORS = 0
LINE INPUT "> ", PGM$(0)
IF PGM$(0) <> "" THEN
CALL INITGETSYM(0)
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
CALL VALIDLINENUM
PGM$(NUM) = MID$(PGM$(0), TEXTP, LEN(PGM$(0)) - TEXTP + 1)
ELSE
CALL DOCMD
END IF
END IF
LOOP

FUNCTION ACCEPT% (S AS STRING)
ACCEPT = 0
IF TOK$ = S THEN ACCEPT = 1: CALL GETSYM
END FUNCTION

FUNCTION ACOSH# (Z AS DOUBLE)
  ACOSH = LOG(Z + SQR(Z + 1) * SQR(Z - 1))
END FUNCTION

FUNCTION ACOTH# (Z AS DOUBLE)
  Z = .5 * (LOG(1 + 1 / Z) - LOG(1 - 1 / Z))
END FUNCTION

FUNCTION ACSCH# (Z AS DOUBLE)
  ACSCH = LOG(SQR(1 + Z ^ (-2)) + Z ^ (-1))
END FUNCTION

FUNCTION ADDEXPR#
DIM N AS DOUBLE
N = TERM
ADDEL:
IF TOK$ = "MOD" THEN CALL GETSYM: N = N MOD TERM: GOTO ADDEL
IF TOK$ = "+" THEN CALL GETSYM: N = N + TERM: GOTO ADDEL
IF TOK$ = "-" THEN CALL GETSYM: N = N - TERM: GOTO ADDEL
ADDEXPR = N
END FUNCTION

FUNCTION ASECH# (Z AS DOUBLE)
  ASECH = LOG(SQR(Z ^ (-1) - 1) * SQR(Z ^ (-1) + 1) + Z ^ (-1))
END FUNCTION

FUNCTION ASIN# (I AS DOUBLE)
IF I = -1 THEN
 ASIN = -HALFPI
ELSEIF I = 1 THEN
 ASIN = HALFPI
ELSE
  ASIN = ATN(I / SQR(1 - I * I))
END IF
END FUNCTION

FUNCTION ASINH# (Z AS DOUBLE)
  ASINH = LOG(Z + SQR(1 + Z ^ 2))
END FUNCTION

FUNCTION ATANH# (Z AS DOUBLE)
 ATANH = .5 * (LOG(1 + Z) - LOG(1 - Z))
END FUNCTION

SUB CLEARVARS
DIM I AS INTEGER
FOR I = 1 TO VARSSIZE
VARS(I) = 0
NEXT I
END SUB

SUB COLORSTMT
DIM BACK AS INTEGER, FORE AS INTEGER, NOBACK AS INTEGER
IF ACCEPT(",") THEN
  BACK = EXPRESSION
  IF (NOBACK = 0) AND (BACK > 15 OR BACK < 0) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
  COLOR , BACK
END IF
FORE = EXPRESSION
IF FORE < 0 OR FORE > 31 THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF ACCEPT(",") THEN BACK = EXPRESSION ELSE NOBACK = -1
IF (NOBACK = 0) AND (BACK > 15 OR BACK < 0) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF NOBACK = 0 THEN COLOR FORE, BACK ELSE COLOR FORE
END SUB

FUNCTION COSH# (Z AS DOUBLE)
  COSH = (E ^ Z + E ^ (-Z)) / 2
END FUNCTION

SUB DOCMD
DIM I AS INTEGER
AGAIN:
IF ERRORS <> 0 THEN EXIT SUB
WHILE TOK$ = ""
IF CURLINE = 0 OR CURLINE >= PGMSIZE THEN EXIT SUB
CALL INITGETSYM(CURLINE + 1)
WEND
IF ACCEPT("STOP") OR ACCEPT("END") THEN EXIT SUB
IF ACCEPT("NEW") THEN
CALL CLEARVARS
FOR I = 1 TO PGMSIZE
PGM$(I) = ""
NEXT I
EXIT SUB
END IF
IF ACCEPT("BYE") THEN END
IF ACCEPT("QUIT") THEN END
IF ACCEPT("LIST") THEN CALL LISTSTMT: GOTO AGAIN
IF ACCEPT("LLIST") THEN CALL LLISTSTMT: GOTO AGAIN
IF ACCEPT("RUN") THEN
CALL CLEARVARS
CALL INITGETSYM(1)
GOTO AGAIN
END IF
IF ACCEPT("RANDOMIZE") THEN CALL RANDOMIZER: GOTO AGAIN
IF ACCEPT("GOSUB") THEN CALL GOSUBSTMT: GOTO AGAIN
IF ACCEPT("RETURN") THEN CALL RETURNSTMT: GOTO AGAIN
IF ACCEPT("GOTO") THEN CALL GOTOSTMT: GOTO AGAIN
IF ACCEPT("GO") THEN
  IF ACCEPT("TO") THEN CALL GOTOSTMT: GOTO AGAIN
  IF ACCEPT("SUB") THEN CALL GOSUBSTMT: GOTO AGAIN
  PRINT "EXPECTED 'GO TO' OR 'GO SUB'": ERRORS = 1: EXIT SUB
END IF
IF ACCEPT("IF") THEN CALL IFSTMT: GOTO AGAIN
IF ACCEPT("INPUT") THEN CALL INPUTSTMT: GOTO AGAIN
IF ACCEPT("PRINT") THEN CALL PRINTSTMT: GOTO AGAIN
IF ACCEPT("LPRINT") THEN CALL LPRINTSTMT: GOTO AGAIN
IF ACCEPT("REM") THEN CALL SKIPTOEOL: GOTO AGAIN
IF ACCEPT("CLS") THEN CLS : GOTO AGAIN
IF ACCEPT("COLOR") OR ACCEPT("COLOUR") THEN CALL COLORSTMT: GOTO AGAIN
IF ACCEPT("LOCATE") THEN CALL LOCATESTMT: GOTO AGAIN
IF ACCEPT("WIDTH") THEN CALL WIDTHSTMT: GOTO AGAIN
IF ACCEPT("FOR") THEN CALL FORSTMT: GOTO AGAIN
IF ACCEPT("NEXT") THEN CALL NEXTSTMT: GOTO AGAIN
IF LEFT$(TOK$, 1) >= "A" AND LEFT$(TOK$, 1) <= "Z" THEN
CALL IDSTMT
GOTO AGAIN
END IF
PRINT "UNKNOWN TOKEN "; TOK$; " AT LINE "; CURLINE
END SUB

SUB EXPECT (S AS STRING)
IF ACCEPT(S) <> 0 THEN EXIT SUB
ERRORS = 1
PRINT "EXPECTING "; S; " BUT FOUND "; TOK$
END SUB

FUNCTION EXPRESSION#
DIM N AS DOUBLE
N = ADDEXPR
EXPRL:
IF TOK$ = "=" THEN CALL GETSYM: N = N = ADDEXPR: GOTO EXPRL
IF TOK$ = "<" THEN CALL GETSYM: N = N < ADDEXPR: GOTO EXPRL
IF TOK$ = ">" THEN CALL GETSYM: N = N > ADDEXPR: GOTO EXPRL
IF TOK$ = "<>" THEN CALL GETSYM: N = N <> ADDEXPR: GOTO EXPRL
IF TOK$ = "<=" THEN CALL GETSYM: N = N <= ADDEXPR: GOTO EXPRL
IF TOK$ = ">=" THEN CALL GETSYM: N = N >= ADDEXPR: GOTO EXPRL
IF TOK$ = "AND" THEN CALL GETSYM: N = N AND ADDEXPR: GOTO EXPRL
IF TOK$ = "OR" THEN CALL GETSYM: N = N OR ADDEXPR: GOTO EXPRL
IF TOK$ = "XOR" THEN CALL GETSYM: N = N XOR ADDEXPR: GOTO EXPRL
IF TOK$ = "EQV" THEN CALL GETSYM: N = N EQV ADDEXPR: GOTO EXPRL
IF TOK$ = "IMP" THEN CALL GETSYM: N = N IMP ADDEXPR: GOTO EXPRL
EXPRESSION = N
END FUNCTION

FUNCTION EXPT#
DIM N AS DOUBLE
N = FACTOR
EXPTL:
IF TOK$ = "^" THEN CALL GETSYM: N = N ^ FACTOR: GOTO EXPTL
EXPT = N
END FUNCTION

FUNCTION FACTOR#
DIM I AS DOUBLE
IF ACCEPT("-") THEN
   FACTOR = -EXPT
   EXIT FUNCTION
END IF
IF ACCEPT("+") THEN
   FACTOR = EXPRESSION
   EXIT FUNCTION
END IF
IF ACCEPT("NOT") THEN
  FACTOR = NOT EXPRESSION
  EXIT FUNCTION
END IF
IF ACCEPT("DEG") THEN
  CALL EXPECT("(")
  FACTOR = EXPRESSION * 180 / PI
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("RAD") THEN
  CALL EXPECT("(")
  FACTOR = EXPRESSION * PI / 180
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("SIN") THEN
  CALL EXPECT("(")
  FACTOR = SIN(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("COS") THEN
  CALL EXPECT("(")
  FACTOR = COS(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("TAN") THEN
  CALL EXPECT("(")
  FACTOR = TAN(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("ATN") OR ACCEPT("ATAN") THEN
  CALL EXPECT("(")
  FACTOR = ATN(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("ASIN") THEN
  CALL EXPECT("(")
  FACTOR = ASIN(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("ACOS") THEN
  CALL EXPECT("(")
  FACTOR = HALFPI - ASIN(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("ACOT") THEN
  CALL EXPECT("(")
  FACTOR = HALFPI - ATN(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("ASEC") THEN
  CALL EXPECT("(")
  FACTOR = HALFPI - ASIN(1 / EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("ACSC") THEN
  CALL EXPECT("(")
  FACTOR = ASIN(1 / EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("SEC") THEN
  CALL EXPECT("(")
  FACTOR = 1 / COS(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("CSC") THEN
  CALL EXPECT("(")
  FACTOR = 1 / SIN(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("COT") THEN
  CALL EXPECT("(")
  FACTOR = 1 / TAN(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("SINH") THEN
  CALL EXPECT("(")
  FACTOR = SINH(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("COSH") THEN
  CALL EXPECT("(")
  FACTOR = COSH(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("TANH") THEN
  CALL EXPECT("(")
  FACTOR = TANH(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("SECH") THEN
  CALL EXPECT("(")
  FACTOR = 1 / COSH(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("CSCH") THEN
  CALL EXPECT("(")
  FACTOR = 1 / SINH(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("COTH") THEN
  CALL EXPECT("(")
  FACTOR = 1 / TANH(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("ASINH") THEN
  CALL EXPECT("(")
  FACTOR = ASINH(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("ACOSH") THEN
  CALL EXPECT("(")
  FACTOR = ACOSH(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("ATANH") THEN
  CALL EXPECT("(")
  FACTOR = ATANH(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("ACSCH") THEN
  CALL EXPECT("(")
  FACTOR = ACSCH(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("ASECH") THEN
  CALL EXPECT("(")
  FACTOR = ASECH(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("ACOTH") THEN
  CALL EXPECT("(")
  FACTOR = ACOTH(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("SQR") OR ACCEPT("SQRT") THEN
  CALL EXPECT("(")
  FACTOR = SQR(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("LN") THEN
  CALL EXPECT("(")
  FACTOR = LOG(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("LOG10") THEN
    CALL EXPECT("(")
    FACTOR = LOG(EXPRESSION) / LOG(10)
    CALL EXPECT(")")
    EXIT FUNCTION
END IF
IF ACCEPT("LOG") THEN
  CALL EXPECT("(")
  I = LOG(EXPRESSION)
  IF ACCEPT(",") THEN
    FACTOR = I / LOG(EXPRESSION)
  ELSE
    FACTOR = I
  END IF
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("EXP") THEN
  CALL EXPECT("(")
  FACTOR = EXP(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("INT") THEN
  CALL EXPECT("(")
  FACTOR = INT(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("CINT") THEN
  CALL EXPECT("(")
  I = EXPRESSION
  FACTOR = SGN(I) * INT(ABS(I) + .5)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("CLNG") THEN
  CALL EXPECT("(")
  I = EXPRESSION
  FACTOR = SGN(I) * INT(ABS(I) + .5)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("FIX") THEN
  CALL EXPECT("(")
  FACTOR = FIX(EXPRESSION)
  CALL EXPECT(")")
  EXIT FUNCTION
END IF
IF ACCEPT("RND") THEN
  IF ACCEPT("(") THEN
    FACTOR = RND(EXPRESSION)
    CALL EXPECT(")")
  ELSE
    FACTOR = RND
  END IF
  EXIT FUNCTION
END IF
IF ACCEPT("TIMER") THEN
  FACTOR = TIMER
  EXIT FUNCTION
END IF
IF ACCEPT("(") THEN
FACTOR = EXPRESSION
CALL EXPECT(")")
EXIT FUNCTION
END IF
IF LEFT$(TOK$, 1) = "." OR (LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9") THEN
FACTOR = NUM
CALL GETSYM
EXIT FUNCTION
END IF
IF LEFT$(TOK$, 1) >= "A" AND LEFT$(TOK$, 1) <= "Z" THEN
FACTOR = VARS(GETVARINDEX)
EXIT FUNCTION
END IF
PRINT "UNEXPECTED SYM "; TOK$; " IN FACTOR": ERRORS = 1
END FUNCTION

SUB FORSTMT
  DIM VAR AS INTEGER, I AS INTEGER
  VAR = GETVARINDEX
  IF LOOPP >= 0 THEN
    IF CURLINE = LOOPLINES(LOOPP) THEN CALL SKIPTOEOL: EXIT SUB
    FOR I = 0 TO LOOPP
      IF LOOPVARS(LOOPP) = VAR THEN PRINT "FOR INDEX VARIABLE ALREADY IN USE": ERRORS = 1: EXIT SUB
    NEXT
  END IF
  CALL EXPECT("=")
  VARS(VAR) = EXPRESSION
  LOOPP = LOOPP + 1
  LOOPVARS(LOOPP) = VAR
  LOOPLINES(LOOPP) = CURLINE
  CALL EXPECT("TO")
  LOOPMAX(LOOPP) = EXPRESSION
  IF ACCEPT("STEP") THEN LOOPSTEP(LOOPP) = EXPRESSION ELSE LOOPSTEP(LOOPP) = 1
END SUB

SUB GETCH
IF TEXTP > LEN(THELIN$) THEN CH$ = "": EXIT SUB
CH$ = MID$(THELIN$, TEXTP, 1)
TEXTP = TEXTP + 1
END SUB

SUB GETSYM
TOK$ = ""
WHILE CH$ <= " "
IF CH$ = "" THEN EXIT SUB
CALL GETCH
WEND


TOK$ = CH$
IF INSTR(",;=+-*/\^()", CH$) > 0 THEN CALL GETCH: EXIT SUB
IF CH$ = "<" THEN
CALL GETCH
IF CH$ = "=" OR CH$ = ">" THEN
TOK$ = TOK$ + CH$
CALL GETCH
END IF
EXIT SUB
END IF
IF CH$ = ">" THEN
CALL GETCH
IF CH$ = "=" THEN TOK$ = TOK$ + CH$: CALL GETCH
EXIT SUB
END IF
IF CH$ = CHR$(34) THEN CALL READSTR: EXIT SUB
IF CH$ = CHR$(39) THEN CALL SKIPTOEOL: EXIT SUB
CH$ = UCASE$(CH$)
IF CH$ >= "A" AND CH$ <= "Z" THEN CALL READIDENT: EXIT SUB
IF (CH$ >= "0" AND CH$ <= "9") OR CH$ = "." THEN CALL READINT: EXIT SUB
PRINT "WHAT->"; CH$: ERRORS = 1
END SUB

FUNCTION GETVARINDEX%
DIM I AS INTEGER
IF LEFT$(TOK$, 1) < "A" OR LEFT$(TOK$, 1) > "Z" THEN
PRINT "NOT A VARIABLE": ERRORS = 1: EXIT FUNCTION
END IF
FOR I = 1 TO VARSSIZE
  IF VARNAMES(I) = TOK$ THEN
    GETVARINDEX = I
    CALL GETSYM
    EXIT FUNCTION
  END IF
NEXT
NUMVARS = NUMVARS + 1
GETVARINDEX = NUMVARS
VARNAMES(NUMVARS) = TOK$
CALL GETSYM
END FUNCTION

SUB GOSUBLINE
  CALL VALIDLINENUM
  STACKP = STACKP + 1
  IF STACKP > 255 THEN PRINT "OUT OF STACK SPACE": ERRORS = 1
  GOSUBSTACK(STACKP) = CURLINE
  CALL INITGETSYM(INT(NUM))
END SUB

SUB GOSUBSTMT
  IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
  CALL GOSUBLINE
  EXIT SUB
  END IF
  PRINT "LINE NUMBER MUST FOLLOW GOSUB": ERRORS = 1
END SUB

SUB GOTOLINE
CALL VALIDLINENUM
CALL INITGETSYM(INT(NUM))
END SUB

SUB GOTOSTMT
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
CALL GOTOLINE
EXIT SUB
END IF
PRINT "LINE NUMBER MUST FOLLOW GOTO": ERRORS = 1
END SUB

SUB IDSTMT
DIM VAR AS INTEGER
VAR = GETVARINDEX
CALL EXPECT("=")
VARS(VAR) = EXPRESSION
END SUB

SUB IFSTMT
DIM B AS INTEGER
IF EXPRESSION = 0 THEN CALL SKIPTOEOL: EXIT SUB
B = ACCEPT("THEN")
IF LEFT$(TOK$, 1) >= "0" AND LEFT$(TOK$, 1) <= "9" THEN
CALL GOTOLINE
END IF
END SUB

SUB INITGETSYM (N AS INTEGER)
CURLINE = N
TEXTP = 1
THELIN$ = PGM$(CURLINE)
CH$ = " "
CALL GETSYM
END SUB

SUB INPUTSTMT
DIM VAR AS INTEGER
IF TOK$ = CHR$(34) THEN
PRINT MID$(TOK$, 2, LEN(TOK$) - 1);
CALL GETSYM
CALL EXPECT(",")
ELSE
PRINT "? ";
END IF
VAR = GETVARINDEX
INPUT VARS(VAR)
END SUB

SUB LISTSTMT
DIM I AS INTEGER
FOR I = 1 TO PGMSIZE
IF PGM$(I) <> "" THEN PRINT I; " "; PGM$(I)
NEXT I
PRINT
END SUB

SUB LLISTSTMT
DIM I AS INTEGER
OPEN "LPT1" FOR OUTPUT AS #1
FOR I = 1 TO PGMSIZE
IF PGM$(I) <> "" THEN PRINT #1, I; " "; PGM$(I)
NEXT I
PRINT
CLOSE #1
END SUB

SUB LOCATESTMT
DIM ROW AS INTEGER, COL AS INTEGER, NOCOL AS INTEGER
IF ACCEPT(",") THEN COL = EXPRESSION: ROW = CSRLIN: GOTO 2
ROW = EXPRESSION
IF ROW <= 0 OR ROW > HEIGHT THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF ACCEPT(",") THEN COL = EXPRESSION ELSE NOCOL = -1
2 IF (NOCOL = 0) AND (COL <= 0 OR COL >= CURWIDTH) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF NOCOL = 0 THEN LOCATE ROW, COL ELSE LOCATE ROW
END SUB

SUB LPRINTSTMT
DIM LPRINTNL AS INTEGER
OPEN "LPT1" FOR OUTPUT AS #1
LPRINTNL = 1
DO WHILE TOK$ <> ""
LPRINTNL = 1
IF LEFT$(TOK$, 1) = CHR$(34) THEN
PRINT #1, MID$(TOK$, 2, LEN(TOK$) - 1);
CALL GETSYM
ELSE
PRINT #1, EXPRESSION;
END IF
IF ACCEPT(",") = 0 AND ACCEPT(";") = 0 THEN EXIT DO
LPRINTNL = 0
LOOP
IF LPRINTNL <> 0 THEN PRINT #1, ""
CLOSE #1
END SUB

SUB NEXTSTMT
  IF LOOPP < 0 THEN PRINT "NEXT WITHOUT FOR": EXIT SUB
  VARS(LOOPVARS(LOOPP)) = VARS(LOOPVARS(LOOPP)) + LOOPSTEP(LOOPP)
  IF VARS(LOOPVARS(LOOPP)) <= LOOPMAX(LOOPP) THEN
    CALL INITGETSYM(LOOPLINES(LOOPP))
  ELSE
    LOOPP = LOOPP - 1
  END IF
END SUB

SUB PRINTSTMT
DIM PRINTNL AS INTEGER
PRINTNL = 1
DO WHILE TOK$ <> ""
PRINTNL = 1
IF LEFT$(TOK$, 1) = CHR$(34) THEN
PRINT MID$(TOK$, 2, LEN(TOK$) - 1);
CALL GETSYM
ELSE
PRINT EXPRESSION;
END IF
IF ACCEPT(",") THEN
  PRINT ,
ELSEIF ACCEPT(";") = 0 THEN
  EXIT DO
END IF
PRINTNL = 0
LOOP
IF PRINTNL <> 0 THEN PRINT
END SUB

SUB RANDOMIZER
 RANDOMIZE EXPRESSION
END SUB

SUB READIDENT
TOK$ = ""
WHILE (UCASE$(CH$) >= "A" AND UCASE$(CH$) <= "Z") OR (CH$ >= "0" AND CH$ <= "9") OR (CH$ = "_")
TOK$ = TOK$ + UCASE$(CH$)
CALL GETCH
WEND
END SUB

SUB READINT
TOK$ = ""
WHILE CH$ >= "0" AND CH$ <= "9"
TOK$ = TOK$ + CH$
CALL GETCH
WEND
IF CH$ = "." THEN
  TOK$ = TOK$ + CH$
  CALL GETCH
  WHILE CH$ >= "0" AND CH$ <= "9"
    TOK$ = TOK$ + CH$
    CALL GETCH
  WEND
END IF
IF CH$ = "E" OR CH$ = "D" THEN
 TOK$ = TOK$ + "D"
 CALL GETCH
 IF CH$ = "+" OR CH$ = "-" THEN TOK$ = TOK$ + CH$: CALL GETCH
 WHILE CH$ >= "0" AND CH$ <= "9"
   TOK$ = TOK$ + CH$
   CALL GETCH
 WEND
END IF
NUM = VAL(TOK$)
END SUB

SUB READSTR
TOK$ = CHR$(34)
CALL GETCH
WHILE CH$ <> CHR$(34)
IF CH$ = "" THEN
PRINT "STRING NOT TERMINATED": ERRORS = 1: EXIT SUB
END IF
TOK$ = TOK$ + CH$
CALL GETCH
WEND
CALL GETCH
END SUB

SUB RETURNSTMT
  DIM LIN AS INTEGER
  IF STACKP < 0 THEN PRINT "RETURN WITHOUT GOSUB": EXIT SUB
  LIN = GOSUBSTACK(STACKP)
  STACKP = STACKP - 1
  CALL INITGETSYM(LIN + 1)
END SUB

FUNCTION SINH# (Z AS DOUBLE)
  SINH = (E ^ Z - E ^ (-Z)) / 2
END FUNCTION

SUB SKIPTOEOL
WHILE CH$ <> ""
CALL GETCH
WEND
CALL GETSYM
END SUB

FUNCTION TANH# (Z AS DOUBLE)
  TANH = (E ^ (2 * Z) - 1) / (E ^ (2 * Z) + 1)
END FUNCTION

FUNCTION TERM#
DIM N AS DOUBLE, I AS DOUBLE
N = EXPT
TERML:
IF TOK$ = "*" THEN CALL GETSYM: N = N * EXPT: GOTO TERML
IF TOK$ = "/" THEN
  CALL GETSYM
  I = EXPT
  IF I = 0 THEN PRINT "DIVISION BY ZERO": ERRORS = 1: EXIT FUNCTION
  N = N / I
  GOTO TERML
END IF
IF TOK$ = "\" THEN
  CALL GETSYM
  I = EXPT
  IF I = 0 THEN PRINT "DIVISION BY ZERO": ERRORS = 1: EXIT FUNCTION
  N = N \ I
  GOTO TERML
END IF
TERM = N
END FUNCTION

SUB VALIDLINENUM
IF NUM > 0 AND NUM <= PGMSIZE THEN EXIT SUB
PRINT "LINE NUMBER OUT OF RANGE": ERRORS = 1
END SUB

SUB WIDTHSTMT
DIM CHEIGHT AS INTEGER, CWIDTH AS INTEGER, NOCHEIGHT AS INTEGER
IF ACCEPT(",") THEN CHEIGHT = EXPRESSION: CWIDTH = CURWIDTH: GOTO 1
CWIDTH = EXPRESSION
IF (CWIDTH <> 40) AND (CWIDTH <> 80) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF ACCEPT(",") THEN CHEIGHT = EXPRESSION ELSE NOCHEIGHT = -1
1 IF (NOCHEIGHT = 0) AND (CHEIGHT <> 25 AND CHEIGHT <> 43 AND CHEIGHT <> 50) THEN PRINT "ILLEGAL FUNCTION CALL": ERRORS = 1: EXIT SUB
IF NOCHEIGHT THEN
  WIDTH CWIDTH
  CURWIDTH = CWIDTH
ELSE
  WIDTH CWIDTH, CHEIGHT
  CURWIDTH = CWIDTH
  HEIGHT = CHEIGHT
END IF
END SUB