10 REM **************** 20 REM Devil's Abacus 30 REM By Robin Nixon 40 REM **************** 50 REM NC100 Version 60 REM Downloaded from Tim's Amstrad NC User's Site 70 REM http://www.ncus.org.uk 80 : 90 ON ERROR GOTO 2580 100 VDU 26:CLS:PROCsetup 110 REPEAT:PROCmenu:UNTIL FALSE 120 END 130 : 140 DEF PROCsetup 150 DIM tier$(7),pole%(3,7),level%(3),Z% &80:PROCassemble 160 tiers%=5:sc%=0:hi%=0 170 FOR t%=1 TO 7:pad$=STRING$(7-t%,CHR$(32)) 180 tier$(t%)=pad$+STRING$(t%*2,CHR$(223))+pad$:NEXT 190 CALL scrn_from_disk:IF ?flag=0 THEN CLS ELSE GOTO 260 200 MOVE 0,0:DRAW 100,0:DRAW 100,63:DRAW 0,63:DRAW 0,0 210 MOVE 380,0:DRAW 479,0:DRAW 479,63:DRAW 380,63:DRAW 380,0 220 PRINT TAB(1,1);CHR$(17);"Devil's Abacus";CHR$(18); 230 PRINT TAB(1,6);CHR$(17);"Towers of Hanoi";CHR$(18) 240 RESTORE 1780:PROCchinese(3,3):RESTORE 1950:PROCchinese(6,3) 250 RESTORE 2120:PROCchinese(9,3):RESTORE 2290:PROCchinese(12,3) 260 PROCwin2:CLS:PRINT TAB(4,0);CHR$(17);tiers%;CHR$(32);"Tiers";CHR$(18) 270 PRINT TAB(3,2);"Moves: ";sc% 280 PRINT TAB(4,3);"Best: ";hi% 290 CALL scrn_to_disk:ENDPROC 300 : 310 DEF PROCmenu 320 PROCwin1:CLS 330 PRINT TAB(15,0);CHR$(17);"MENU OF OPTIONS";CHR$(18) 340 PRINT TAB(8,2);:VDU 40,17,83,18,41:PRINT"tart a new game" 350 PRINT TAB(8,3);:VDU 40,17,67,18,41:PRINT"hange the number of Tiers" 360 PRINT TAB(8,4);:VDU 40,17,80,18,41:PRINT"lay the computer's solution" 370 PRINT TAB(8,5);:VDU 40,17,82,18,41:PRINT"ead the Rules of Play" 380 PRINT TAB(4,7);"Press the first letter of any Option"; 390 REPEAT:g%=GET AND 223 400 UNTIL g%=83 OR g%=67 OR g%=80 OR g%=82 410 IF g%=83 PROCplay:ENDPROC 420 IF g%=67 PROCtiers:ENDPROC 430 IF g%=80 PROCsolve:ENDPROC 440 IF g%=82 PROCrules:ENDPROC 450 ENDPROC 460 : 470 DEF PROCtiers 480 CLS:PRINT TAB(13,2);CHR$(17);"SET NUMBER OF TIERS";CHR$(18) 490 PRINT TAB(2,6);"Minumum Moves: 2 Tiers = 3, 7 Tiers = 127"; 500 REPEAT:PRINT TAB(11,4);"How many Tiers (2-7) "; 510 INPUT tiers%:UNTIL tiers%>=2 AND tiers%<=7 520 PROCwin2:PRINT TAB(4,0);CHR$(17);tiers%;CHR$(18) 530 sc%=0:hi%=0:PROCscore:PROChiscore:ENDPROC 540 : 550 DEF PROCplay 560 PROCprepare:PROCscore 570 REPEAT:result%=FNmove 580 IF result%=FALSE IF FNquit UNTIL TRUE:ENDPROC 590 UNTIL FNwin:IF sc%=49 AND g%<=51) OR (g% AND 223)=81 1080 IF (g% AND 223)=81 THEN = FALSE 1090 =g%-48 1100 : 1110 DEF FNlegal_start 1120 IF level%(start%)=0 THEN =FALSE 1130 legal%=FALSE:FOR p%=1 TO 3 1140 IF p%<>start% IF FNtop(start%)FNtop(end%) THEN =FALSE 1210 =TRUE 1220 : 1230 DEF FNtop(p%) 1240 IF level%(p%)=0 THEN = 99 1250 =pole%(p%,level%(p%)) 1260 : 1270 DEF PROCget(p%) 1280 PRINT TAB(15*p%-15,8-level%(p%));STRING$(14,CHR$(32)); 1290 store%=FNtop(p%):level%(p%)=level%(p%)-1 1300 ENDPROC 1310 : 1320 DEF PROCput(p%) 1330 level%(p%)=level%(p%)+1:pole%(p%,level%(p%))=store% 1340 PRINT TAB(15*p%-15,8-level%(p%));tier$(store%); 1350 ENDPROC 1360 : 1370 DEF PROCscore 1380 PROCwin2:PRINT TAB(10,2);sc%;SPC(2):ENDPROC 1390 : 1400 DEF PROChiscore 1410 PROCwin2:PRINT TAB(10,3);hi%;SPC(2):ENDPROC 1420 : 1430 DEF PROCprepare 1440 FOR t%=1 TO tiers%:pole%(1,t%)=tiers%+1-t%:NEXT:level%(1)=tiers% 1450 FOR p%=2 TO 3:FOR t%=1 TO 7:pole%(p%,t%)=0:NEXT:level%(p%)=0:NEXT 1460 PROCdrawstack:sc%=0:ENDPROC 1470 : 1480 DEF PROCchinese(col%,row%) 1490 x%=col%*6:y%=64-row%*8 1500 FOR r%=1 TO 16:READ r$ 1510 FOR c%=1 TO 16:p%=VAL(MID$(r$,c%,1)) 1520 IF p%=1 PLOT 69,x%+(c%-1),y%-(r%-1) 1530 NEXT:NEXT 1540 ENDPROC 1550 : 1560 DEF PROCsolve 1570 CLS:PRINT TAB(10,2);CHR$(17);"PLAY COMPUTER'S SOLUTION";CHR$(18) 1580 PRINT TAB(5,4);:VDU 40,17,65,18,41:PRINT"utomatic or"; 1590 VDU 32,40,17,77,18,41:PRINT"anual playback?"; 1600 PRINT TAB(0,6);"Q Quits playback - SPACE moves in Manual Mode"; 1610 REPEAT:g%=GET AND 223:UNTIL g%=65 OR g%=77 OR g%=81 1620 IF g%=81 ENDPROC ELSE IF g%=77 ss%=TRUE ELSE ss%=FALSE 1630 PROCprepare:PROCwin3:CLS:VDU 17 1640 IF ss% PRINT SPC(2);"Single Step"; ELSE PRINT SPC(1);"Auto Playback"; 1650 VDU 18:PROCwin1:RESTORE 2460:TIME=0:quit%=FALSE:REPEAT 1660 IF ss% PROCwait ELSE i%=INKEY(0) AND 223:IF i%=81 quit%=TRUE 1670 READ start%,end%:PROCget(start%):PROCput(end%) 1680 sc%=sc%+1:PROCscore:PROCwin1:UNTIL sc%=2^tiers%-1 OR quit% 1690 PROCwin3:CLS:IF quit% ENDPROC 1700 PRINT SPC(2);CHR$(17);"Press SPACE";CHR$(18); 1710 REPEAT:UNTIL GET=32:CLS:ENDPROC 1720 : 1730 DEF PROCwait 1740 REPEAT:i%=INKEY(0):quit%=(i%=81):UNTIL i%=32 OR quit% 1750 ENDPROC 1760 : 1770 REM Chinese Character "Devil" #1 1780 DATA "0000000110000000" 1790 DATA "0000000100000000" 1800 DATA "0111111111111110" 1810 DATA "0110000110000110" 1820 DATA "0110000110000110" 1830 DATA "0111111111111110" 1840 DATA "0110000110000110" 1850 DATA "0110000110000110" 1860 DATA "0111111111111110" 1870 DATA "0110000110001100" 1880 DATA "0000000110011000" 1890 DATA "0000000110100000" 1900 DATA "0000001011111110" 1910 DATA "0000110011000000" 1920 DATA "0111000011111111" 1930 DATA "0000000000000000" 1940 REM Chinese Character "Devil" #2 1950 DATA "0000000000000000" 1960 DATA "0000000000000100" 1970 DATA "0011111111111110" 1980 DATA "0000000000111000" 1990 DATA "0000000001100000" 2000 DATA "0000000011000000" 2010 DATA "0000000110000000" 2020 DATA "0000000110000010" 2030 DATA "1111111111111111" 2040 DATA "0000000110000000" 2050 DATA "0000000110000000" 2060 DATA "0000000110000000" 2070 DATA "0000000110000000" 2080 DATA "0000000110000000" 2090 DATA "0000111100000000" 2100 DATA "0000001000000000" 2110 REM Chinese Character "Abacus" #1 2120 DATA "0001100001100010" 2130 DATA "0111111111111111" 2140 DATA "1100000110011000" 2150 DATA "0001111111111000" 2160 DATA "0001100000011000" 2170 DATA "0001111111111000" 2180 DATA "0001100000011000" 2190 DATA "0001111111111000" 2200 DATA "0001100000011000" 2210 DATA "0001111111111000" 2220 DATA "0000110000110010" 2230 DATA "0111111111111111" 2240 DATA "0000110000110000" 2250 DATA "0001100000110000" 2260 DATA "1110000000100000" 2270 DATA "0000000000000000" 2280 REM Chinese Character "Abacus" #2 2290 DATA "0000000000000000" 2300 DATA "0000011000000000" 2310 DATA "0000010000000000" 2320 DATA "0001111111111000" 2330 DATA "0001101100011000" 2340 DATA "0001100110011000" 2350 DATA "0001100001011010" 2360 DATA "0111111111111111" 2370 DATA "0001101100011000" 2380 DATA "0011000110011000" 2390 DATA "0110000001011000" 2400 DATA "1111111111111000" 2410 DATA "0001100110011000" 2420 DATA "0001100110011010" 2430 DATA "0111111111111111" 2440 DATA "0000000000000000" 2450 REM Solution for all Tiers up to Seven 2460 DATA 1,2,1,3,2,3,1,2,3,1,3,2,1,2,1,3,2,3,2,1,3,1,2,3 2470 DATA 1,2,1,3,2,3,1,2,3,1,3,2,1,2,3,1,2,3,2,1,3,1,3,2 2480 DATA 1,2,1,3,2,3,1,2,3,1,3,2,1,2,1,3,2,3,2,1,3,1,2,3 2490 DATA 1,2,1,3,2,3,2,1,3,1,3,2,1,2,3,1,2,3,2,1,3,1,2,3 2500 DATA 1,2,1,3,2,3,1,2,3,1,3,2,1,2,1,3,2,3,2,1,3,1,2,3 2510 DATA 1,2,1,3,2,3,1,2,3,1,3,2,1,2,3,1,2,3,2,1,3,1,3,2 2520 DATA 1,2,1,3,2,3,1,2,3,1,3,2,1,2,3,1,2,3,2,1,3,1,2,3 2530 DATA 1,2,1,3,2,3,2,1,3,1,3,2,1,2,3,1,2,3,2,1,3,1,3,2 2540 DATA 1,2,1,3,2,3,1,2,3,1,3,2,1,2,1,3,2,3,2,1,3,1,2,3 2550 DATA 1,2,1,3,2,3,1,2,3,1,3,2,1,2,3,1,2,3,2,1,3,1,3,2 2560 DATA 1,2,1,3,2,3,1,2,3,1,3,2,1,2 2570 : 2580 ON ERROR GOTO 2600 2590 VDU 26:CLS:IF ERR=17 THEN CHAIN "AUTO" 2600 REPORT:PRINT" at line ";ERL 2610 PRINT:PRINT"Press [Function][X] for Notepad Main Menu" 2620 END 2630 : 2640 DEF PROCassemble 2650 fopenout=&B8A5 2660 fopenin=&B8A2 2670 foutblock=&B8AB 2680 finblock=&B896 2690 fclose=&B890 2700 : 2710 FOR PASS = 0 TO 2 STEP 2 2720 P%=Z% 2730 [ 2740 OPT PASS 2750 : 2760 .scrn_to_disk 2770 : 2780 CALL map_scrn_in 2790 LD HL,&F000 2800 LD DE,&8000 2810 LD BC,&1000 2820 LDIR 2830 CALL map_scrn_out 2840 LD HL,filename 2850 CALL fopenout 2860 RET NC 2870 LD HL,&8000 2880 LD BC,&1000 2890 CALL foutblock 2900 JP fclose 2910 : 2920 .scrn_from_disk 2930 : 2940 LD HL,filename 2950 CALL fopenin 2960 JR C,from1 2970 LD HL,flag 2980 LD (HL),0 2990 RET 3000 : 3010 .from1 3020 : 3030 LD HL,&8000 3040 LD BC,&1000 3050 CALL finblock 3060 CALL fclose 3070 CALL map_scrn_in 3080 LD HL,&8000 3090 LD DE,&F000 3100 LD BC,&1000 3110 LDIR 3120 CALL map_scrn_out 3130 LD HL,flag 3140 LD (HL),1 3150 RET 3160 : 3170 .map_scrn_in 3180 : 3190 LD A,(&B003) 3200 LD (state),A 3210 LD A,67 3220 LD (&B003),A 3230 OUT (&13),A 3240 RET 3250 : 3260 .map_scrn_out 3270 : 3280 LD A,(state) 3290 LD (&B003),A 3300 OUT (&13),A 3310 RET 3320 : 3330 .filename 3340 : 3350 OPT FNequs("DEVIL.SCN"):OPT FNequb(0) 3360 : 3370 .flag 3380 : 3390 OPT FNequb(0) 3400 : 3410 .state 3420 : 3430 OPT FNequb(0) 3440 ] 3450 NEXT 3460 ENDPROC 3470 : 3480 DEF FNequs(string$) 3490 $P%=string$ 3500 P%=P%+LEN(string$) 3510 =PASS 3520 : 3530 DEF FNequb(byte) 3540 ?P%=byte 3550 P%=P%+1 3560 =PASS >*SPOOL