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 OX = 4:OY = 2
240 TX = 6:TY = 3
250 SC = 3
260 D$ = CHR$(4):PRINT D$;"PR#3":IF PEEK(43698) = 0 THEN PR#3
270 POKE 49246,0:REM Enable double lo-res
280 GOSUB 2110:REM Read everything from DATA

500 REM Face editor
510 GR:HOME
520 GOSUB 1910
530 GX = 0:GY = 0
540 K$ = "":GOSUB 1410

600 GET K$
610 IF K$ >= "a" AND K$ <= "z" THEN K$ = CHR$(ASC(K$) - 32)
620 IF K$ = "I" OR K$ = "J" OR K$ = "K" OR K$ = "M" THEN GOSUB 1410
630 IF K$ = "W" OR K$ = "A" OR K$ = "S" OR K$ = "Z" THEN GOSUB 1510
640 IF K$ = "F" THEN GOSUB 1710
650 IF K$ = "Q" THEN VTAB 24:END

700 GOTO 600

1000 REM Move cursor to X,Y
1010 VTAB Y+1:HTAB X+1
1020 RETURN

1100 REM Display tile TN at GX,GY
1110 FOR I = 0 TO TY - 1
1120 X = GX * TX + OX:Y = GY * TY + I + OY
1130 GOSUB 1010
1140 PRINT MID$(TL$(TN),I * TX * SC + 1,TX * SC);CHR$(24);CHR$(14);
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 X = 0:Y = 20:GOSUB 1010
1260 RETURN

1300 REM Display cursor as color CS at GX,GY
1310 COLOR=CS
1320 X = GX * TX + OX:Y = OY - 1:HLIN X,X+TX-1 AT Y*2+1
1330 Y = 5 * TY + OY:HLIN X,X+TX-1 AT Y*2
1340 X = OX - 1:Y = GY * TY + OY:VLIN Y*2,(Y+TY)*2-1 AT X
1350 X = 5 * TX + OX:VLIN Y*2,(Y+TY)*2-1 AT X
1360 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 = 0:GOSUB 1310
1460 GX = NX:GY = NY:CS = 12: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:D = D - INT(D / 64) * 64
1830 C = C + D * 64:C = C - INT(C / 256) * 256
1840 IV = 0:IF C > 128 THEN IV = 1:C = C - 128
1850 MT = 0:IF C < 32 THEN MT = 1:C = C + 64
1860 C$ = CHR$(14 + IV) + CHR$(24 + 3 * MT) + CHR$(C)
1870 RETURN

1900 REM Display instructions and grid
1910 X = OX:Y = 20
1920 GOSUB 1010:PRINT "IJKM to move cursor"
1930 Y = Y + 1
1940 GOSUB 1010:PRINT "WASZ to swap"
1950 Y = Y + 1
1960 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 tiles, blocks from DATA
2110 PRINT "Setting up tiles"

2270 REM Load tiles from DATA
2280 READ TN:DIM TL$(TN):REM Tiles for each face
2290 MX = TN * TX * TY + 25 * 6 + 25
2300 FOR I = 1 TO TN
2310 T$ = ""
2320 FOR J = 1 TO TX * TY
2330 PC = INT(LC / MX * 100):PRINT STR$(PC);"%";:POKE 36,0:POKE 1403,0
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);"%";:POKE 36,0:POKE 1403,0
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);"%";:POKE 36,0:POKE 1403,0
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

5000 DATA 55 :REM Number of tiles
5010 DATA UB,*A,5C,'D,3C,&D,5A,&D,3C,&D,3C,&D,3C,&D,3C,&D,3C,&D
5020 DATA 3C,&D,3C,&D,3C,&D,3C,&D,3C,&D,3C,&D,3C,&D,3C,&D,3C,&D
5030 DATA 3C,&D,;C,*D,UB,*A,3C,&D,3C,&D,3C,":D",3C,&D,3C,&D,3C,&D
5040 DATA @C,@C,@C,@C,@C,@C,@C,@C,@C,@C,@C,@C,@C,@C,@C,@C,@C,@C
5050 DATA 3C,&D,3C,&D,3C,&D,[B,&D,3C,&D,3C,&D,UB,*A,SB,6D,3C,&D
5060 DATA 3C,&D,3C,&D,3C,&D,3C,&D,3C,&D,3C,'A,3C,&D,3A,&A,UB,*A
5070 DATA UB,*A,UB,*A,UB,*A,UB,*A,UB,*A,UB,*A,UB,*A,UB,*A,UB,*A
5080 DATA UB,*A,UB,*A,UB,7D,UB,*A,UB,*A,UB,&D,5A,":D",5C,*D,3C,&D
5090 DATA %A,ZB,%A,ZB,5B,":B",ZB,PB,@C,0B,?B,/A,UB,*A,UB,*A,UB,*A
5100 DATA UB,*A,UB,*A,UB,*A,UB,*A,?B,?B,UB,*A,UB,*A,?B,?B,UB,*A
5110 DATA ;A,*A,UB,*A,UB,*A,3C,*A,UB,*A,UB,*A,3C,&D,5C,*D,5A,":D"
5120 DATA [B,'A,SB,&A,3C,&D,UB,*A,UB,*A,UB,&D,UB,*A,UB,*A,UB,7D
5130 DATA UB,*A,UB,*A,UB,*D,[B,*D,5C,*D,3C,&D,UB,*A,SB,6D,3C,&D
5140 DATA 3C,'D,5A,":D",;C,&D,3C,&D,3C,&D,3C,&D,3C,6D,[B,'A,3A,&D
5150 DATA 5C,*A,UB,*A,UB,*A,3C,&D,5C,*D,5C,'A,3C,&D,3A,&A,UB,*A
5160 DATA 3C,&D,SB,&A,[B,'A,3C,*A,UB,*A,UB,*A,;A,*A,UB,*A,UB,*A
5170 DATA UB,*A,UB,*A,UB,ZB,UB,*A,UB,*A,UB,EC,UB,ZB,%A,JC,@C,@C
5180 DATA %A,*A,UB,*A,UB,*A,JC,*A,UB,*A,UB,*A,@C,@C,EC,ZB,%A,*A
5190 DATA ZB,PB,@C,@C,@C,@C,UB,*A,ZB,PB,@C,@C,UB,*A,UB,*A,ZB,PB
5200 DATA @C,@C,@C,@C," A",%A,@C,@C," A",%A,UB,*A," A",%A,UB,*A,UB,*A
5210 DATA UB,*A,UB,*A,UB,*A,%A,%A,ZB,%A,ZB,ZB,UB,*A,UB,*A,UB,*A
5220 DATA 3C,&D,3C,'A,UB,*A,3C,&D,3C,*A,UB,*A,3C,&D,SB,*A,UB,*A
5230 DATA UB,*A,ZB,%A,UB,*A,UB,*A,UB,*A,UB,*A,UB,*A,UB,*A,UB,*A
5240 DATA UB,*A,[B,&D,3C,&D,UB,*A,UB,&D,3C,&D,UB,*A,UB,&A,3C,&D
5250 DATA UB,*A,EC,EC,@C,@C,%A,@C,@C,@C,@C,@C,@C,@C,@C,@C,@C,@C
5260 DATA UB,*A,*A,UB,UB,*A,UB,*A,*A,UB,UB,*A,UB,ZB,*A,UB,%A,*A
5270 DATA @C,@C,JC,JC,UB,*A,@C,@C,@C,@C,@C,ZB,@C,@C,@C,@C,@C,@C
5280 DATA @C,@C,@C,PB,ZB,*A,ZB,@C,@C,*A,UB,*A,UB,*A,PB,ZB,UB,*A
5290 DATA UB,*A,UB,JC,@C,@C,UB,*A,UB,@C,@C,@C,UB,*A,%A,@C,@C,@C
5300 DATA @C,EC,%A,ZB,JC,@C,@C,@C,@C,@C,@C,@C,@C,PB,ZB,%A," A",@C
5310 DATA @C,@C,EC,*A,UB,*A,@C,@C,@C,*A,UB,*A,@C,@C,@C,ZB,UB,*A
5320 DATA UB,%A," A",@C,@C,@C,UB,*A,UB,@C,@C,%A,UB,*A,%A," A",UB,*A
5330 DATA @C,@C,PB,%A,ZB,*A," A",*A,UB,*A,UB,*A,ZB,*A,UB,*A,UB,*A
5340 DATA UB,*A,5C,*D,UB,*A,UB,&D,3C,&D,3C,*A,UB,*A,SB,&A,UB,*A
5350 DATA UB,%A,ZB," A",@C,@C,UB,*A,UB,*A,UB,PB,UB,*A,UB,*A,UB,%A
5360 DATA @C,@C,@C,@C,@C,@C,@C,@C," A",PB,@C,@C,@C,PB,UB,*A," A",@C
5370 DATA 3C,&D,3C,&D,3C,&D,3C,&D,SB,&A,3C,&D,SB,*A,UB,*A,UB,&A
5380 DATA 5A,'D,3C,&D,;C,":D",3C,&D,3C,&D,3C,&D,[B,6D,3C,&D,3A,'A
5390 DATA UB,*A,UB,*A,UB,*A,EC,*A,UB,*A,UB,JC,ZB,UB,EC,JC,*A,%A
5400 DATA UB,*A,*A,UB,UB,*A,UB,*A,*A,UB,UB,*A,UB,*A,*A,UB,UB,*A
5410 DATA UB,*A,UB,*A,UB,*A,UB,*A,*A,*A,UB,*A,UB,*A,UB,*A,UB,*A
5420 DATA " A",@C,@C,@C,@C,PB,UB,UB,@C,@C,*A,*A,JC,@C,@C,@C,@C,EC
5430 DATA UB,*A,5A,":D",UB,*A,UB,&D,3C,&D,3C,*A,UB,*A,[B,'A,UB,*A
5440 DATA UB,*A,EC,%A,UB,*A,%A,@C,@C,*A,UB,*A,@C,@C,@C,EC,%A,*A
5450 DATA UB,*A,ZB,JC,UB,*A,UB,*A,UB,@C,@C,ZB,UB,ZB,JC,@C,@C,@C
5460 DATA @C,@C,@C,@C,@C,@C,ZB,@C,@C,@C,@C,@C,UB,*A,PB,PB,@C,@C
5470 DATA @C,@C," A",PB,@C,@C,@C,UB,UB,*A,*A,@C,@C,@C,JC,EC,@C,@C
5480 DATA @C,@C,@C,@C,@C,@C,@C,@C,@C,@C,@C,%A,@C,@C," A"," A",UB,*A
5490 DATA UB,*A,UB,*D,3C,&D,UB,*A,UB,&D,3C,&D,UB,*A,5A,&D,3C,&D
5500 DATA ?B,?B,":B",5B,?B,?B,UB,/A,_B,/A,_B,*A,UB,*A,UB,*A,UB,*A
5510 DATA 3C,&D,5C,*A,UB,*A,3C,&D,3C,*A,UB,*A,3C,&D,3C,":D",UB,*A
5520 DATA UB,*A,5C,*D,UB,*A,UB,'A,3C,&D,[B,*A,UB,*A,UB,*A,UB,*A
5530 DATA 3C,&D,3C,6D,[B,*A,3C,&D,3C,*A,UB,*A,3C,&D,3C,'D,5A,*A
5540 DATA UB,'A,3A,&D,3C,&D,UB,*A,UB,&D,3C,&D,UB,":D",;C,&D,3C,&D
5550 DATA UB," A",@C,@C,PB,*A,UB,*A,*A,UB,UB,*A,UB,*A,UB,*A,UB,*A

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