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