100 REM BASIC Month 7: Make-a-Face
110 REM http://RetroBattlestations.com
120 REM written by FozzTexx

200 REM Initialize variables
210 DIM GD$(5, 5):REM Face grid is 5x5
220 DIM BK(25, 6):REM There are 25 blocks with up to 6 faces each
230 DIM CL$(16):REM Codes to print to change color
240 IV$ = CHR$(18):OV$ = CHR$(146):OC$ = CHR$(154)
250 GOSUB 2110:REM Read everything from DATA
260 POKE 53281,15
270 OX = 5:OY = 3

500 REM Face editor
510 PRINT CHR$(147): REM Clear the screen
520 PRINT CHR$(142);CL$(0):REM Set graphics charset and black text
530 GOSUB 1910
540 GX = 0:GY = 0
550 K$ = "":GOSUB 1410

600 GET K$:IF K$ = "" THEN 600
610 IF K$ = "I" OR K$ = "J" OR K$ = "K" OR K$ = "M" THEN GOSUB 1410
620 IF K$ = "W" OR K$ = "A" OR K$ = "S" OR K$ = "Z" THEN GOSUB 1510
630 IF K$ = "F" THEN GOSUB 1710
640 IF K$ = "E" THEN GOTO 3010

700 GOTO 600

1000 REM Move cursor to X,Y
1010 POKE 781,Y:POKE 782,X
1020 POKE 783,0:SYS 65520
1030 RETURN

1100 REM Display tile TN at GX,GY
1110 FOR I = 0 TO 2
1120 X = GX * 3 + OX:Y = GY * 3 + I + OY
1130 GOSUB 1010
1140 PRINT MID$(TL$(TN),I*9+1,9);OV$;OC$;
1150 NEXT I
1160 RETURN

1200 REM Display grid location GX,GY
1210 GS$ = GD$(GX,GY)
1220 BN = ASC(GS$) - 65:FC = ASC(MID$(GS$,2)) - 49
1230 TN = BK(BN, FC)
1240 GOSUB 1110
1250 RETURN

1300 REM Display cursor CS$ at GX,GY
1310 X = GX * 3 + OX:Y = OY - 1:GOSUB 1010:PRINT LEFT$(CS$,9);
1320 Y = 5 * 3 + OY:GOSUB 1010:PRINT MID$(CS$,10,9);
1330 FOR I = 0 TO 2
1340 X = OX - 1:Y = GY * 3 + OY + I:GOSUB 1010:PRINT MID$(CS$,19+I*3,3);
1350 X = 5 * 3 + OX:GOSUB 1010:PRINT MID$(CS$,28+I*3,3);
1360 NEXT I
1370 RETURN

1400 REM Move cursor
1410 IF K$ = "I" THEN NY = GY - 1:IF NY < 0 THEN NY = 4
1420 IF K$ = "J" THEN NX = GX - 1:IF NX < 0 THEN NX = 4
1430 IF K$ = "K" THEN NX = GX + 1:IF NX > 4 THEN NX = 0
1440 IF K$ = "M" THEN NY = GY + 1:IF NY > 4 THEN NY = 0
1450 IF GX <> NX OR GY <> NY THEN CS$ = CB$:GOSUB 1310
1460 GX = NX:GY = NY:CS$ = CR$:GOSUB 1310
1470 RETURN

1500 REM Swap block
1510 IF K$ = "W" THEN NY = GY - 1:IF NY < 0 THEN NY = 4
1520 IF K$ = "A" THEN NX = GX - 1:IF NX < 0 THEN NX = 4
1530 IF K$ = "S" THEN NX = GX + 1:IF NX > 4 THEN NX = 0
1540 IF K$ = "Z" THEN NY = GY + 1:IF NY > 4 THEN NY = 0
1550 OB$ = GD$(GX,GY):GD$(GX,GY) = GD$(NX,NY):GD$(NX,NY) = OB$
1560 GOSUB 1210
1570 PX = GX:PY = GY:GX = NX:GY = NY
1580 GOSUB 1210
1590 REM Restore GX,GY and let move cursor routine do RETURN
1600 GX = PX:GY = PY:GOTO 1410

1700 REM Flip or roll a block
1710 GS$ = GD$(GX,GY)
1720 BN = ASC(GS$) - 65:FC = ASC(MID$(GS$,2)) - 49
1730 FC = FC + 1:IF FC > 5 OR BK(BN,FC) = 0 THEN FC = 0
1740 GD$(GX,GY) = CHR$(65 + BN) + CHR$(49 + FC)
1750 REM Display tile and let that subroutine do RETURN
1760 GOTO 1210

1800 REM Convert encoded D$ to decoded C$
1810 C = ASC(D$):D = ASC(MID$(D$, 2))
1820 D = (D - 1) AND 63
1830 CL = INT(D / 4):D = D AND 3
1840 C = (C - 32 + D * 64 AND 127) + 32
1850 C$ = OV$:IF D >= 2 THEN C$ = IV$
1860 IF C >= 128 AND C < 160 THEN C = C + 32
1870 C$ = C$ + CL$(CL) + CHR$(C)
1880 RETURN

1900 REM Display instructions and grid
1910 X = OX + 5 * 3 + 2 + 4:Y = OY
1920 GOSUB 1010:PRINT "IJKM TO MOVE"
1930 X1 = X:X = X + 5:Y = Y + 1
1940 GOSUB 1010:PRINT "CURSOR"
1950 X = X1:Y = Y + 1
1960 GOSUB 1010:PRINT "WASZ TO SWAP"
1970 Y = Y + 1
1980 GOSUB 1010:PRINT "F TO FLIP"

2000 REM Display entire grid
2010 FOR GN = 0 TO 24
2020 GY = INT(GN / 5):GX = GN - GY * 5
2030 GOSUB 1210
2040 NEXT GN
2050 RETURN

2100 REM Read colors, cursor, tiles, blocks from DATA
2110 PRINT "Setting up tiles"
2120 MX = 16 + 12 + 150 * 9 + 25 * 6 + 25:LC = 0
2130 FOR I = 0 TO 15
2140 PC = INT(LC / MX * 100):PRINT STR$(PC);"%";CHR$(13);CHR$(145);
2150 READ CL
2160 CL$(I) = CHR$(CL)
2170 LC = LC + 1
2180 NEXT I

2190 REM Read grid cursor from DATA
2200 CR$ = "":CB$ = "":B$ = " " + CHR$(0) + CHR$(0)
2210 FOR I = 1 TO 12
2220 PC = INT(LC / MX * 100):PRINT STR$(PC);"%";CHR$(13);CHR$(145);
2230 READ D$:GOSUB 1810
2240 CR$ = CR$ + C$:CB$ = CB$ + B$
2250 LC = LC + 1
2260 NEXT I

2270 REM Load tiles from DATA
2280 READ TN:DIM TL$(TN):REM Tiles for each face
2290 MX = 16 + 12 + TN * 9 + 25 * 6 + 25
2300 FOR I = 1 TO TN
2310 T$ = ""
2320 FOR J = 1 TO 9
2330 PC = INT(LC / MX * 100):PRINT STR$(PC);"%";CHR$(13);CHR$(145);
2340 READ D$:IF LEN(D$) > 2 THEN D$ = MID$(D$, 2)
2350 GOSUB 1810
2360 T$ = T$ + C$
2370 LC = LC + 1
2380 NEXT J
2390 TL$(I) = T$
2400 NEXT I

2410 FOR I = 0 TO 24
2420 FOR J = 0 TO 5
2430 PC = INT(LC / MX * 100):PRINT STR$(PC);"%";CHR$(13);CHR$(145);
2440 BK(I, J) = 0
2450 LC = LC + 1
2460 NEXT J
2470 Y = INT(I / 5):X = I - Y * 5
2480 GD$(X,Y) = CHR$(65+I) + "1"
2490 NEXT I

2500 REM Read blocks from DATA
2510 READ BN:IF BN = -1 THEN RETURN
2520 PC = INT(LC / MX * 100):PRINT STR$(PC);"%";CHR$(13);CHR$(145);
2530 READ TN:FOR I = 1 TO TN
2540 READ T:BK(BN-1, I-1) = T
2550 LC = LC + 1
2560 NEXT I
2570 GOTO 2510

3000 REM Lines 3000-3990 are the optional block and tile editor
3010 PRINT CHR$(147): REM Clear the screen
3020 GS$ = GD$(GX,GY)
3030 EB = ASC(GS$) - 65:FC = ASC(MID$(GS$,2)) - 49
3040 PRINT "BLOCK: ";EB

3100 REM Display all faces of block
3110 FOR K = 0 TO 5
3120 GY = INT(K / 3):GX = K - GY * 3
3130 GY = GY * 2:GX = GX * 2
3140 TN = BK(EB, K)
3150 IF TN > 0 THEN GOSUB 1110:X = GX*3+OX:Y = GY*3+OY-1:GOSUB 1010:PRINT TN
3160 NEXT K
3170 GX = 0:GY = 0:FC = 0
3180 GOSUB 3310

3200 FX = 0:FY = 0:K$ = "":GOSUB 3410
3210 GET K$:IF K$ = "" THEN 3210
3220 IF K$ = "I" OR K$ = "J" OR K$ = "K" OR K$ = "M" THEN GOSUB 3410
3230 IF K$ = CHR$(13) THEN GOSUB 3610
3240 IF K$ >= "1" AND K$ <= "6" THEN GOSUB 3810
3250 IF K$ = "Q" THEN GOTO 510
3260 GOTO 3210

3300 REM Display tile code of selected face
3310 TN = BK(EB, FC):IV = 0
3320 FOR K = 1 TO 9
3330 FY = INT((K - 1) / 3):FX = K - 1 - FY*3
3340 GOSUB 3510
3350 NEXT K
3360 RETURN

3400 REM Move cursor to another tile square
3410 IF K$ = "I" THEN NY = FY - 1:IF NY < 0 THEN NY = 2
3420 IF K$ = "J" THEN NX = FX - 1:IF NX < 0 THEN NX = 2
3430 IF K$ = "K" THEN NX = FX + 1:IF NX > 2 THEN NX = 0
3440 IF K$ = "M" THEN NY = FY + 1:IF NY > 2 THEN NY = 0
3450 IV = 0:GOSUB 3510
3460 FX = NX:FY = NY
3470 IV = 1:GOSUB 3510
3480 RETURN

3500 REM Display tile cursor
3510 SQ = FY * 3 + FX
3520 C$ = MID$(TL$(TN), SQ*3+1, 3):GOSUB 3910
3530 X = FX*3 + OX:Y = FY*2 + OY + 11:GOSUB 1010
3540 IF IV THEN PRINT IV$;
3550 PRINT D$;OV$;
3560 RETURN

3600 REM Ask user for encoded character
3610 X = 5:Y = 20:GOSUB 1010
3620 PRINT "VALUE: ";
3630 D$ = ""
3640 GET KK$:IF KK$ = "" THEN 3640
3650 K = ASC(KK$) - 32:IF K < 0 OR K > 63 THEN 3640
3660 PRINT KK$;
3670 D$ = D$ + KK$:IF LEN(D$) < 2 THEN 3640
3680 GOSUB 1010:PRINT "                   "
3690 GOSUB 1810
3700 SQ = FY * 3 + FX
3710 T$ = LEFT$(TL$(TN), SQ*3) + C$ + MID$(TL$(TN), SQ*3+4)
3720 TL$(TN) = T$
3730 GOSUB 1110
3740 GOTO 3510:REM Let display tile cursor subroutine do RETURN

3800 REM Choose another face
3810 FC = ASC(K$) - 49
3820 GY = INT(FC / 3):GX = FC - GY * 3
3830 GX = GX * 2:GY = GY * 2
3840 TN = BK(EB, FC)
3850 GOSUB 1110:GOSUB 3310
3860 K$ = "":GOTO 3410 :REM Let display tile code subroutine do RETURN

3900 REM Convert character C$ to encoded D$
3910 V = 1 - INT((ASC(C$) - 18) / 128)
3920 L$ = MID$(C$,2,1):C = ASC(MID$(C$,3))
3930 FOR L = 0 TO 15:IF CL$(L) <> L$ THEN NEXT L
3940 IF C >= 160 AND C < 192 THEN C = C - 32
3950 D = INT((C + 256 - 32 AND 255) / 64)
3960 C = C - D * 64:REM Remove multiplier from C
3970 D = (D + V * 2 + L * 4 + 33 AND 63) + 32:REM Make 0 equal A
3980 D$ = CHR$(C) + CHR$(D)
3990 RETURN

4000 REM Colors
4010 DATA 144,5,28,159,156,30,31,158,129,149,150,151,152,153,154,155

4100 REM Grid cursor
4110 DATA BB,BB,BB,BD,BD,BD,AD,AD,AD,AB,AB,AB

5000 DATA 61 :REM Number of tiles
5010 DATA " A"," A"," A"," A"," A"," A"," A"," A"," A"
5020 DATA " ="," =",IL,IL," K"," K"," K"," K"," K"
5030 DATA " K"," K"," K",IJ," =",?J,TJ," =",JJ
5040 DATA " K"," K"," K"," K",=L," K",IJ," =",?J
5050 DATA ?L," ="," ="," K"," K",?L," K"," K"," K"
5060 DATA " ="," ="," ="," ="," ="," ="," ="," ="," ="
5070 DATA " ="," =",ID,ID," C"," C"," C"," C"," C"
5080 DATA " C"," C"," C"," C",=D," C",IB," =",?B
5090 DATA ?D," ="," ="," C"," C",?D," C"," C"," C"
5100 DATA " K"," K"," K"," K"," K"," K"," K"," K"," K"
5110 DATA " ="," ="," =",=B," =",=B,*B,#B,+B
5120 DATA " =",ID," C"," ="," C"," C",ID," C"," C"
5130 DATA " C"," C"," C"," C"," C",AB," C",BD," ="
5140 DATA " C"," C"," C",AD," C"," C"," =",BD," C"
5150 DATA " C",?D," ="," C"," C"," ="," C"," C",?D
5160 DATA " K"," K",IJ," K",IJ," =",?J,?L," ="
5170 DATA " =",."B," ="," =",."B," =",1B,."B,1B
5180 DATA ?J," K"," K"," =",?J," K"," =",IL,IJ
5190 DATA " C"," C",IB," C"," C"," ="," C"," C",?D
5200 DATA 5F,#F,)F,."F," =",VD,*F,#F,+F
5210 DATA 5F,#F,)F,UD," =",."F,*F,#F,+F
5220 DATA ?B," C"," C"," ="," C"," C",ID," C"," C"
5230 DATA 5B,1B,)B,."B," =",."B,*B,#B,+B
5240 DATA ?L," ="," ="," K",?L," ="," K"," K",?L
5250 DATA " ="," ="," =",LJ,YJ,[J,XJ,OL,XJ
5260 DATA " ="," =",IL," =",IL," K",IL," K"," K"
5270 DATA " C"," C"," C"," C"," C"," C"," C"," C"," C"
5280 DATA AB," ="," ="," C"," ="," ="," C"," C",BB
5290 DATA " ="," =",AD," ="," ="," C",BB," C"," C"
5300 DATA ?D," =",ID," C",."D," C",IB," =",?B
5310 DATA LJ,XL,[J,EL," K",GL,\J,OL,^J
5320 DATA ID,IB," ="," C",?D," ="," C"," C",?D
5330 DATA " =",BB," C",AD," C"," C"," C"," C"," C"
5340 DATA " C",BB," ="," C"," C",AB," C"," C"," C"
5350 DATA " =",?B,?D," =",ID," C",ID," C"," C"
5360 DATA " C"," C"," C",?B," C"," C"," ="," =",?B
5370 DATA " C"," C"," C"," C"," C",IB,IB," ="," ="
5380 DATA " C"," C"," C"," C",":D"," C"," C"," C"," C"
5390 DATA " =",IL," K"," ="," K"," K",IL," K"," K"
5400 DATA " ="," ="," =",IH," G",?D," ="," ="," ="
5410 DATA " =",=B," ="," ="," C"," =",UD," C",VD
5420 DATA " K",?L," ="," K"," K"," ="," K"," K",?L
5430 DATA \B,OD,^B," ="," ="," ="," ="," ="," ="
5440 DATA " =",=B," ="," =",=B," =",1B,=B,1B
5450 DATA " K"," K"," K"," K"," K"," K",IJ," =",?J
5460 DATA " K"," K"," K",AL," K"," K"," =",BL," K"
5470 DATA ?L," =",IL," K"," K"," K"," K"," K"," K"
5480 DATA " K"," K"," K"," K"," K",AJ," K",BL," ="
5490 DATA BL," K"," K"," =",\J," K"," ="," =",AL
5500 DATA " K"," K",BL," K",^J," =",AJ," ="," ="
5510 DATA AJ," ="," ="," K",[J," ="," K"," K",BJ
5520 DATA " ="," =",AL," =",LJ," K",BJ," K"," K"
5530 DATA " K",BJ," ="," K"," K",AJ," K"," K"," K"
5540 DATA " K"," K",IJ," K"," K"," ="," K"," K",?L
5550 DATA " C"," C",IB," C",IB," =",?B,?D," ="
5560 DATA ?D," =",ID," C",=D," C",IB," =",?B
5570 DATA ?B," C"," C"," =",?B," C"," =",ID,IB
5580 DATA " ="," ="," =",LJ,YJ,[J,XJ," K",XJ
5590 DATA " C"," C",BD," C",^B," ="," ="," ="," ="
5600 DATA " ="," ="," ="," =",":B"," ="," ="," ="," ="
5610 DATA BD," C"," C"," =",\B," C"," ="," =",AD

6000 REM Which tiles are on which blocks
6010 DATA 1,5,2,7,37,42,59
6020 DATA 2,4,3,8,39,55, 3,4,4,9,40,10
6030 DATA 4,5,3,12,41,39,52
6040 DATA 5,4,5,13,40,56, 6,3,10,14,42
6050 DATA 7,5,11,15,2,45,10, 8,3,6,32,51
6060 DATA 9,6,11,19,4,42,60,10
6070 DATA 10,4,10,20,35,53
6080 DATA 11,4,16,21,5,10, 12,3,6,33,52
6090 DATA 13,4,17,31,38,57
6100 DATA 14,4,6,34,33,40
6110 DATA 15,6,18,22,16,49,61,6
6120 DATA 16,4,23,27,44,54
6130 DATA 17,4,24,28,46,50
6140 DATA 18,4,25,36,43,31
6150 DATA 19,6,26,29,47,46,34,48
6160 DATA 20,4,23,27,43,52
6170 DATA 21,4,6,27,34,51, 22,3,10,27,44
6180 DATA 23,4,6,30,48,58, 24,3,10,27,43
6190 DATA 25,5,6,27,18,33,10
6200 DATA -1