This is a full-featured Sudoku program incorporating facilities such as game generation, import and export in various formats, game-playing aids (including snapshot/restore, multiple undo/redo, candidate elimination, number highlighting, auto-tidy) and printing. It will solve any Sudoku puzzle and check whether a puzzle is valid. Use the Help menu option for more details.
| Download SUDOKU.BBC | Run SUDOKU.EXE |
|---|
REM SUDOKU, by R.T.Russell and M.G.Marten
REM Version 3.18 (RTR), 24-Jul-2006
Version$ = "3.18 (RTR)"
SYS "SetWindowText", @hwnd%, "Sudoku version "+Version$+" in BBC BASIC for Windows"
INSTALL @lib$+"WINLIB" : REM Toolbar and Statusbar
INSTALL @lib$+"WINLIB2" : REM Dialogs
REM Set window style to disallow resizing
SYS "GetWindowLong", @hwnd%, -16 TO ws%
SYS "SetWindowLong", @hwnd%, -16, ws% AND NOT &50000
REM Set window size initially for XP Styles
VDU 23,22,453;532;8,20,16,128
OFF
REM Set up menus
AM$ = "AppendMenu"
SYS "CreatePopupMenu" TO hsub1%
SYS AM$, hsub1%, 0, 145, "1"+CHR$9+"F1"
SYS AM$, hsub1%, 0, 146, "2"+CHR$9+"F2"
SYS AM$, hsub1%, 0, 147, "3"+CHR$9+"F3"
SYS AM$, hsub1%, 0, 148, "4"+CHR$9+"F4"
SYS AM$, hsub1%, 0, 149, "5"+CHR$9+"F5"
SYS AM$, hsub1%, 0, 150, "6"+CHR$9+"F6"
SYS AM$, hsub1%, 0, 151, "7"+CHR$9+"F7"
SYS AM$, hsub1%, 0, 152, "8"+CHR$9+"F8"
SYS AM$, hsub1%, 0, 153, "9"+CHR$9+"F9"
SYS AM$, hsub1%, 0, 154, "Clear Filters"
SYS "CreatePopupMenu" TO hsub2%
SYS AM$, hsub2%, 0, 161, "1"+CHR$9+"Shift+F1"
SYS AM$, hsub2%, 0, 162, "2"+CHR$9+"Shift+F2"
SYS AM$, hsub2%, 0, 163, "3"+CHR$9+"Shift+F3"
SYS AM$, hsub2%, 0, 164, "4"+CHR$9+"Shift+F4"
SYS AM$, hsub2%, 0, 165, "5"+CHR$9+"Shift+F5"
SYS AM$, hsub2%, 0, 166, "6"+CHR$9+"Shift+F6"
SYS AM$, hsub2%, 0, 167, "7"+CHR$9+"Shift+F7"
SYS AM$, hsub2%, 0, 168, "8"+CHR$9+"Shift+F8"
SYS AM$, hsub2%, 0, 169, "9"+CHR$9+"Shift+F9"
SYS AM$, hsub2%, 0, 154, "Clear Filters"
SYS "CreatePopupMenu" TO hpop1%
SYS AM$, hpop1%, 0, 14, "&New"+CHR$9+"Ctrl+N"
SYS AM$, hpop1%, 0, 15, "&Open"+CHR$9+"Ctrl+O"
SYS AM$, hpop1%, 0, 19, "&Save"+CHR$9+"Ctrl+S"
SYS AM$, hpop1%, 0, 6, "Save &As"
SYS AM$, hpop1%, &800, 0, 0
SYS AM$, hpop1%, 0, 16, "&Print"+CHR$9+"Ctrl+P "
SYS AM$, hpop1%, &800, 0, 0
SYS AM$, hpop1%, 0, 12, "E&xit"
SYS "CreatePopupMenu" TO hpop2%
SYS AM$, hpop2%, 0, 26, "&Undo"+CHR$9+"Ctrl+Z"
SYS AM$, hpop2%, 0, 25, "&Redo"+CHR$9+"Ctrl+Y"
SYS AM$, hpop2%, &800, 0, 0
SYS AM$, hpop2%, 0, 24, "Cu&t All"+CHR$9+"Ctrl+X"
SYS AM$, hpop2%, 0, 3, "&Copy All"+CHR$9+"Ctrl+C"
SYS AM$, hpop2%, 0, 22, "&Paste Cells"+CHR$9+"Ctrl+V"
SYS AM$, hpop2%, 0, 14, "Clear &all"
SYS "CreatePopupMenu" TO hpop3%
SYS AM$, hpop3%, 0, 4, "Sna&pshot"
SYS AM$, hpop3%, 0, 18, "&Restore"+CHR$9+"Ctrl+R"
SYS AM$, hpop3%, 1, 8, "&Tidy Grid"+CHR$9+"Bkspc"
SYS AM$, hpop3%, 16, hsub2%, "&Highlight"
SYS AM$, hpop3%, 16, hsub1%, "&Filter"
SYS AM$, hpop3%, &800, 0,0
SYS AM$, hpop3%, 0, 23, "&Count Solutions"
SYS AM$, hpop3%, 0, 11, "Generate &New"
SYS "CreatePopupMenu" TO hpop4%
SYS AM$, hpop4%, 0, 7, "&Grid on/off"+CHR$9+"Ctrl+G"
SYS AM$, hpop4%, 1, 2, "&Reveal on/off"
SYS AM$, hpop4%, 0, 9, "&Auto-Count on/off"+CHR$9+"Tab"
SYS "CreatePopupMenu" TO hpop5%
SYS AM$, hpop5%, 0, 17, "&Help"
SYS AM$, hpop5%, &800, 0, 0
SYS AM$, hpop5%, 0, 1, "&Solve"
SYS AM$, hpop5%, 0, 21, "Show &Cell"
SYS AM$, hpop5%, &800, 0, 0
SYS AM$, hpop5%, 0, 5, "&About"
SYS "CreateMenu" TO H%
SYS AM$, H%, 16, hpop1%, "&File "
SYS AM$, H%, 16, hpop2%, "&Edit "
SYS AM$, H%, 16, hpop4%, "&Options "
SYS AM$, H%, 16, hpop3%, "&Tools "
SYS AM$, H%, 16, hpop5%, "&Help "
SYS AM$, H%, 0, 20, "&Website"
SYS "SetMenu",@hwnd%,H%
SYS "DrawMenuBar",@hwnd%
REM Create toolbar
nbutts% = 17
DIM button%(nbutts%-1),bindex%(nbutts%-1)
button%() = 6,7,8,14,0,3,4,0,1,2,5,0,12,0,15,0,16
bindex%() = 14,15,19,16,0,26,25,24,3,22,135,0,21,0,-7,0,4
ht% = FN_createtoolbar(nbutts%,button%(),bindex%())
REM Add tooltips to toolbar
DIM buttip$(nbutts%-1)
buttip$() = "New", "Open", "Save","Print","","Undo","Redo","Cut All","Copy All","Paste Cells","Reset Cell","","Show Cell","","Grid On/Off","","Snapshot"
PROC_addtooltips(ht%,nbutts%,buttip$(),bindex%())
REM Add some button bitmaps
S% = FN_custombutton(ht%,@dir$+"grid.bmp",7)
S% = FN_custombutton(ht%,@dir$+"snapshot.bmp",4)
REM Define a PRINTDLG 'structure'
DIM pd% 65
!pd% = 66
pd%!4 = @hwnd%
pd%!20 = &140
REM Global arrays and structures
DIM A%(8,8), Q%(8,8), Archive{(999)R&,C&,F&,Data%}
Empty% = %111111111 : REM one bit position for each number possible
A%() = Empty%
Q%() = Empty%
REM Create status bar
hs% = FN_createstatusbar("")
REM Adjust window size according to DPI setting and 'style'
DIM rc{l%,t%,r%,b%} : REM RECT structure for Windows "GetWindowRect"
SYS "GetWindowRect", hs% , rc{}
status_bar_height% = rc.b%-rc.t%
SYS "GetWindowRect", ht% , rc{}
tool_bar_height% = rc.b%-rc.t%
rc.l% = 0
rc.r% = 451
rc.t% = 0
rc.b% = 451 + status_bar_height% + tool_bar_height%
SYS "AdjustWindowRect", rc{}, &CF0000, 1
SYS "SetWindowPos", @hwnd%, 0, 0, 0, rc.r%-rc.l%, rc.b%-rc.t%, 6
VDU 26
ORIGIN 0,2*status_bar_height%
PROC_removestatusbar
hs% = FN_createstatusbar("")
DIM eg% 7 : REM split status bar
!eg% = @vdu%!28-150 : eg%!4 = -1
SYS "SendMessage",hs%,1028,2,eg%
REM Set up Structure for OpenFileName API call later
DIM Sofn{ \ OPENFILENAME Structure
\ lStructSize%, \ Size of structure
\ hwndOwner%, \ Calling Window handle
\ hInstance%, \
\ lpstrFilter%, \ Pointer to filter string
\ lpstrCustomFilter%, \
\ nMaxCustFilter%, \
\ nFilterIndex%, \ Index to selected filter starts at 1
\ lpstrFile%, \ Pointer to string to give/receive FileName
\ nMaxFile%, \ Size of FileName string
\ lpstrFileTitle%, \ Pointer to FileName string less path
\ nMaxFileTitle%, \
\ lpstrInitialDir%, \
\ lpstrTitle%, \ Pointer to string that displays in title bar
\ Flags%, \ Sets dialog box behaviour
\ nFileOffset{l&,h&}, \
\ nFileExtension{l&,h&}, \ Read Offset to where extension starts, 0 if none
\ lpstrDefExt%, \
\ lCustData%, \
\ lpfnHook%, \
\ lpTemplateName%}
REM populate structure
DIM ft% 80
Sofn.lStructSize% = 76
Sofn.hwndOwner% = @hwnd%
Sofn.nFilterIndex% = 1
Sofn.lpstrFileTitle% = ft%
Sofn.nMaxFileTitle% = 80
Sofn.Flags% = 6
REM Set up dialog box
dlg% = FN_newdialog("Select difficulty",125,40,153,61,8,400)
PROC_dlgitem(dlg%,"",101,10,10,130,12,&50000001,0)
temp% = dlg%!12-8
SYS "MultiByteToWideChar", 0, 0, "msctls_trackbar32", 17, temp%, 256 TO Len%
dlg%!12 = temp%+2*Len%+6
PROC_static(dlg%,"Easier",100,10,24,40,16,0)
PROC_static(dlg%,"Harder",100,100,24,40,16,2)
PROC_pushbutton(dlg%,"OK",1,22,40,42,14,&20001)
PROC_pushbutton(dlg%,"Cancel",2,89,40,42,14,&0)
REM draw the main grid
FOR L% = 0 TO 9
LINE 2,L%*100+2,902,L%*100+2
IF (L% MOD 3)=0 LINE 2,L%*100,902,L%*100 : LINE 2,L%*100+4,902,L%*100+4
LINE L%*100+2,2,L%*100+2,902
IF (L% MOD 3)=0 LINE L%*100,2,L%*100,902 : LINE L%*100+4,2,L%*100+4,902
NEXT
REM Initialise global variables
FileName$ = ""
Entry% = TRUE
Grid% = FALSE
Count% = FALSE
Reveal% = FALSE
Solved% = FALSE
Changed% = FALSE
Filter% = 0
Hilite% = 0
UndoPtr% = 0
MinPtr% = 0
MaxPtr% = 0
Click% = -1
CF_TEXT% = 1
ON MOUSE Click% = 10 : RETURN
ON SYS Click% = @wparam% : RETURN
ON CLOSE PROCexit : RETURN
ON ERROR IF ERR<>17 SYS "MessageBox",@hwnd%,REPORT$,0,48 ELSE PROCshow
PROCreset
COLOUR 8,255,224,224
REM Main Program loop
REPEAT
PROCstat2(FNstatus)
SYS "EnableMenuItem",hpop1%,19,ABSNOTChanged%
SYS "EnableMenuItem",hpop2%,26,ABSNOT(UndoPtr%<>MinPtr%)
SYS "EnableMenuItem",hpop2%,25,ABSNOT(UndoPtr%<>MaxPtr%)
SYS "EnableMenuItem",hpop3%,8,ABSNOTGrid%
SYS "EnableMenuItem",hpop4%,2,ABSNOTSolved%
SYS "EnableMenuItem",hpop5%,21,ABSNOTEntry%
SYS "SendMessage", ht%, 1041, 7, 4-Grid%
REM highlight current active square (Invert color)
GCOL 4,0
*ESC OFF
IF Entry% RECTANGLE FILL Col%*100+4,Row%*100+2,98,98
REPEAT
K% = INKEY(1)
REM if no key then check input from mouse
IF K%=-1 SWAP Click%,K%
UNTIL K%<>-1
IF Entry% RECTANGLE FILL Col%*100+4,Row%*100+2,98,98
*ESC ON
CASE K% OF
WHEN 10 : REM get mouse position
MOUSE X%,Y%,B%
IF X%>=2 AND Y%>=2 AND X%<902 AND Y%<902 AND B%>1 THEN
Col% = (X%-2)DIV100 : Row% = (Y%-2)DIV100
P% = A%(Row%,Col%)
IF NOT Reveal% Entry% = TRUE
REM switch on or off grid of possible entries if there is more than 1
IF Grid% IF NOT Reveal% IF P% AND (P%-1) THEN
X% = ((X%-2)MOD100)DIV33 : Y% = ((Y%-2)MOD100)DIV33
Changed% = TRUE : PROCsaveold(Row%,Col%,P%,0)
A%(Row%,Col%) EOR = 2^(X%+6-Y%*3)
REM write result to cell
PROCcell(A%(),Row%,Col%,4)
ENDIF
ELSE
Entry% = FALSE
ENDIF
:
WHEN 1,23 : REM menu items Solve (Ctrl+A) and Count (Ctrl+W)
Entry% = FALSE
PROCcheck_solutions(K%)
:
WHEN 2 : REM Reveal (Ctrl+B)
IF Solved% THEN
Entry% = FALSE : Reveal% = NOT Reveal% : PROCshow
IF Reveal% THEN
PROCstat1("Select Options...Reveal again to hide solution")
ELSE
PROCstat1("")
ENDIF
ENDIF
:
WHEN 3 : PROCcopy(FALSE) : REM Copy (Ctrl+C)
:
WHEN 4 : REM Snapshot (Ctrl+D)
Reveal% = FALSE : PROCshow
PROCsaveDat(FNtemppath+"SUDOKU.DAT")
PROCstat1("Select Tools...Restore to load saved snapshot")
:
WHEN 5 : PROCabout
:
WHEN 6 : IF FNsaveAs Changed% = FALSE ELSE PROCstat1("File not saved!") : REM SaveAs
:
WHEN 7 : REM Toggle grid (Ctrl+G)
Grid% = NOT Grid%
PROCshow
IF NOT Reveal% THEN
IF Grid% THEN
PROCstat1("Click on small numbers to eliminate them")
ELSE
PROCstat1("Enter your choice : Numbers 0 - 9")
ENDIF
ENDIF
:
WHEN 8 : IF Grid% IF NOT Reveal% THEN PROCtidy : REM Tidy (Backsp)
:
WHEN 9 : Count% = NOT Count% : REM Toggle count (Tab)
:
REM WHEN 10 used for mouse
:
WHEN 11 : IF FNch PROCgenerate
:
WHEN 12 : PROCexit
:
REM WHEN 13 is return, used later
:
WHEN 14 : IF FNch PROCnew : REM Clear All / File New
:
WHEN 15 : IF FNch PROCload
:
WHEN 16 : PROCprint
:
WHEN 17 : PROChelp
:
WHEN 18 : REM Restore (Ctrl-R)
PROCloadDat(FNtemppath+"SUDOKU.DAT")
Changed% = TRUE : Reveal% = FALSE : PROCshow
:
WHEN 19 : IF FNsave Changed% = FALSE : PROCstat1("File saved!") : REM Save
:
WHEN 20 : SYS "ShellExecute", 0, 0, "http://www.rtrussell.co.uk/", 0, "", 0
:
WHEN 21 : REM Show Cell
IF Entry% THEN
IF NOT Solved% PROCcheck_solutions(1)
Changed% = TRUE
PROCsaveold(Row%,Col%,A%(Row%,Col%),0)
A%(Row%,Col%) = Q%(Row%,Col%)
PROCcell(A%(),Row%,Col%,4)
ENDIF
:
WHEN 22 : PROCpaste : Reveal% = FALSE : PROCshow
:
WHEN 24 : PROCcopy(TRUE) : PROCshow : REM Cut (Ctrl+X)
:
WHEN 25 : IF NOT Reveal% PROCredo(Row%,Col%)
:
WHEN 26 : IF NOT Reveal% PROCundo(Row%,Col%)
:
WHEN 32,48,49,50,51,52,53,54,55,56,57,135 : REM Number entry
IF Entry% IF NOT Reveal% THEN
P% = A%(Row%,Col%)
REM If number input data is a 1 shifted n times
REM Space, 0 or Del removes an entry
Changed% = TRUE : PROCsaveold(Row%,Col%,P%,0)
IF K%<=48 OR K%=135 A%(Row%,Col%) = Empty% ELSE A%(Row%,Col%) = 1 << (K%-49)
PROCcell(A%(),Row%,Col%,4)
ENDIF
:
REM cursor key moves
WHEN 136 : Entry% = NOTReveal% : Col% -= 1 : IF Col%<0 Col% = 8 : Row% += 1 : IF Row%>8 Row% = 0
WHEN 13, 137 : Entry% = NOTReveal% : Col% += 1 : IF Col%>8 Col% = 0 : Row% -= 1 : IF Row%<0 Row% = 8
WHEN 138 : Entry% = NOTReveal% : Row% -= 1 : IF Row%<0 Row% = 8 : Col% += 1 : IF Col%>8 Col% = 0
WHEN 139 : Entry% = NOTReveal% : Row% += 1 : IF Row%>8 Row% = 0 : Col% += 1 : IF Col%>8 Col% = 0
:
REM Function keys
WHEN 145,146,147,148,149,150,151,152,153 :
IF Grid% THEN
Entry% = FALSE
IF Filter% = K%-144 Filter% = 0 ELSE Filter% = K%-144
PROCshow
IF Filter% PROCstat1("Remove filter by pressing F10 or F"+STR$Filter%) ELSE PROCstat1("")
ENDIF
:
WHEN 154 : Hilite% = 0 : Filter% = 0 : PROCshow : PROCstat1("") : REM F10
:
REM Shift+Function keys
WHEN 161,162,163,164,165,166,167,168,169 :
Entry% = FALSE
IF Hilite% = K%-160 Hilite% = 0 ELSE Hilite% = K%-160
PROCshow
IF Hilite% PROCstat1("Remove highlight by pressing F10 or Shift F"+STR$Hilite%) ELSE PROCstat1("")
ENDCASE
IF Solved% Solved% = (A%(Row%,Col%) AND Q%(Row%,Col%)) <> 0
UNTIL FALSE
END
DEFPROCreset
Grid% = FALSE : Filter% = 0 : Hilite% = 0
Reveal% = FALSE : Solved% = FALSE : PROCshow
UndoPtr% = 0 : MinPtr% = 0 : MaxPtr% = 0
Entry% = FALSE : Changed% = FALSE
Col% = 0 : Row% = 8
PROCstat1("Load file or enter numbers into the cells")
ENDPROC
DEFPROCnew : REM GLOBAL A%(), Q%(), Empty%, FileName$
A%() = Empty%
Q%() = Empty%
PROCreset
FileName$ = "" : PROCtitle(FileName$)
ENDPROC
DEF FNstatus : REM GLOBAL Changed%, Count%
LOCAL A$
IF Changed% A$ = "Changed : " ELSE A$ = "Unchanged : "
IF Count% A$ += "Auto count on" ELSE A$ += "Auto count off"
= A$
REM GLOBAL hs%
DEF PROCstat1(A$) : SYS "SendMessage",hs%,1025,0,A$ : ENDPROC
DEF PROCstat2(A$) : SYS "SendMessage",hs%,1025,1,A$ : ENDPROC
DEF PROCcheck_solutions(K%) : REM GLOBAL A%(), Q%(), Solved%
LOCAL S%,T%
Q%() = A%()
Solved% = FALSE
PROCstat1("Working (press Esc to abort)...")
S% = FNsolve(Q%(),K% = 1,T%)
REM K% = 1 is solve menu item
IF K% = 1 THEN
IF S% THEN
Solved% = TRUE
PROCstat1("Solved : Select Options...Reveal to show solution")
ELSE
PROCstat1("Impossible")
ENDIF
ELSE
IF S% = 1 THEN
PROCstat1("There is 1 solution")
ELSE
PROCstat1("There are "+STR$S%+" solutions")
ENDIF
ENDIF
ENDPROC
DEF PROCshow : REM GLOBAL A%(), Q%(), Reveal%
LOCAL C%,R%
FOR C% = 0 TO 8
FOR R% = 0 TO 8
IF Reveal% PROCcell(Q%(),R%,C%,2) ELSE PROCcell(A%(),R%,C%,4)
NEXT
NEXT
ENDPROC
DEF PROCcell(P%(),R%,C%,K%) : REM GLOBAL Grid%, Filter%, Hilite%
LOCAL P%,G%
P% = P%(R%,C%)
IF P% AND (P%-1) IF P%<>Empty% GCOL 8 ELSE GCOL 15
RECTANGLE FILL C%*100+6,R%*100+4,94,94
IF P% AND (P%-1) THEN
IF NOT Grid% ENDPROC
*FONT
REM draw grid
GCOL 7
FOR G% = 1 TO 2
LINE C%*100+6,R%*100+G%*32+4,C%*100+98,R%*100+G%*32+4
LINE C%*100+G%*32+4,R%*100+6,C%*100+G%*32+4,R%*100+98
NEXT
REM write numbers at graphics cursor
GCOL K%
FOR G% = 0 TO 8
MOVE C%*100+22+(G%MOD3)*32-@vdu%!216,R%*100+84-(G%DIV3)*32+@vdu%!220
IF Filter% THEN
IF G% = Filter%-1 GCOL K% ELSE GCOL 2
ENDIF
IF P% AND 2^G% VDU 5,G%+49,4
NEXT
ELSE
REM write a big number
GCOL K%
*FONT Arial,28
IF P% G% = LOGP%/.3 : REM Bit position to decimal conversion,
MOVE C%*100+50-@vdu%!216,R%*100+50+@vdu%!220
IF Hilite% THEN
IF G%=Hilite%-1 GCOL K% ELSE GCOL 11
ENDIF
VDU 5,G%+49,4
*FONT
ENDIF
ENDPROC
DEF PROCprint : REM GLOBAL A%(), Q%(), Reveal%, pd%
LOCAL ok%,dpix%,thin%,thick%,S%,L%,T%,X%,Y%,R%,C%,P%
SYS "PrintDlg", pd% TO ok%
IF ok% THEN
SYS "DeleteDC", @prthdc%
@prthdc% = pd%!16
*printerfont Arial,20
*MARGINS 10,10,10,10
SYS "GetDeviceCaps", @prthdc%, 88 TO dpix%
S% = dpix%/2.5
L% = @vdu%!232
T% = @vdu%!240
REM Screen Off, Printer On
VDU 2,21,32
SYS "CreatePen", 0, S%/32, 0 TO thin%
SYS "CreatePen", 0, S%/16, 0 TO thick%
X% = L%
FOR C% = 0 TO 9
IF (C% MOD 3)=0 THEN
SYS "SelectObject", @prthdc%, thick%
ELSE
SYS "SelectObject", @prthdc%, thin%
ENDIF
SYS "MoveToEx", @prthdc%, X%, T%, 0
SYS "LineTo", @prthdc%, X%, T% + 9*S%
X% += S%
NEXT
Y% = T%
FOR R% = 0 TO 9
IF (R% MOD 3)=0 THEN
SYS "SelectObject", @prthdc%, thick%
ELSE
SYS "SelectObject", @prthdc%, thin%
ENDIF
SYS "MoveToEx", @prthdc%, L%, Y%, 0
SYS "LineTo", @prthdc%, L% + 9*S%, Y%
Y% += S%
NEXT
FOR R% = 0 TO 8
FOR C% = 0 TO 8
@vdu%!-12 = L% + C%*S% + S%*0.3
@vdu%!-8 = T% + R%*S% + S%*0.15
IF Reveal% P% = Q%(8-R%,C%) ELSE P% = A%(8-R%,C%)
IF (P% AND (P%-1))=0 VDU LOGP%/.3 + 49
NEXT
NEXT
REM Screen On Printer Off
VDU 12,6,3
SYS "DeleteObject", thin%
SYS "DeleteObject", thick%
ENDIF
ENDPROC
DEF FNsolve(p%(),F%,RETURN H%)
REM F% is -1 for solve, 0 for count, 1 for tidy
LOCAL C%,D%,E%,M%,N%,R%,X%,Y%,q%()
PRIVATE T%
IF T% > H% H% = T%
DIM q%(8,8)
REPEAT
REM clear out the col, row and block exposed candidates
q%() = p%()
FOR R% = 0 TO 8
FOR C% = 0 TO 8
D% = p%(R%,C%)
IF (D% AND (D%-1))=0 THEN
REM only 1 chosen value bit
M% = NOT D%
REM set mask
FOR X% = 0 TO 8
REM mask off this value bit from all other row/col cells
IF X%<>C% p%(R%,X%) AND= M%
IF X%<>R% p%(X%,C%) AND= M%
NEXT
REM similarly for the rest of the block
FOR X% = C%DIV3*3 TO C%DIV3*3+2
FOR Y% = R%DIV3*3 TO R%DIV3*3+2
IF X%<>C% IF Y%<>R% p%(Y%,X%) AND= M%
NEXT
NEXT
ENDIF
NEXT
NEXT
q%() -= p%()
REM q%() still = p%() means we have made no more discoveries
UNTIL SUMq%() = 0
REM Tidy part of function exits here : removed all the simple candidates
IF F%=1 : = D%
REM Scan the grid to find the one with the fewest possibilities
M% = 10
FOR R% = 0 TO 8
FOR C% = 0 TO 8
D% = p%(R%,C%)
IF D%=0 M% = 0 : REM this only happens if Sudoku rules not adhered to
REM find number of bits set (candidates) if more than 1
IF D% AND (D%-1) THEN
N% = 0
REPEAT N% += (D% AND 1)
D% DIV = 2
UNTIL D% = 0
REM N% must be 2 - 9
IF N%<M% M% = N% : X% = C% : Y% = R%
ENDIF
NEXT
NEXT
REM if we get here with M% = 10 then the grid is complete already.
REM 0 solutions, impossible or 1 solution?
IF M%=0 THEN = 0
IF M%=10 THEN = 1
REM At this stage we have the coordinates of the (First) cell with lowest number of candidates
D% = 0
FOR M% = 0 TO 8
REM Check to see if it's a possible candidate, if so try this one
E% = 1 << M%
IF p%(Y%,X%) AND E% THEN
q%() = p%()
q%(Y%,X%) = E% : REM try possible number in this cell and test. Could be a Magic Number!
T% += 1
C% = FNsolve(q%(),F%,H%) : REM reentrant call
T% -= 1
D% += C%
IF C% IF F% p%() = q%() : = D%
ENDIF
NEXT
= D%
DEF PROCtidy : REM GLOBAL A%(), UndoPtr%, Changed%
LOCAL q%(),C%,R%,P%,F%
DIM q%(8,8)
REM Save old values so we can undo.
Changed% = TRUE
q%() = A%()
P% = FNsolve(A%(),1,C%)
FOR C% = 0 TO 8
FOR R% = 0 TO 8
P% = q%(R%,C%)
IF A%(R%,C%)<>P% PROCsaveold(R%,C%,P%,F%) : F%=TRUE
PROCcell(A%(),R%,C%,4)
NEXT
NEXT
ENDPROC
REM Get last value of Archive{}, decode and present to screen
DEF PROCundo(RETURN R%, RETURN C%)
REM GLOBAL A%(), Archive{}, UndoPtr%, MinPtr%, Changed%
IF UndoPtr%<>MinPtr% THEN
REPEAT
UndoPtr% = (UndoPtr%+999) MOD 1000
R% = Archive{(UndoPtr%)}.R&
C% = Archive{(UndoPtr%)}.C&
REM Now we have to display the data
SWAP A%(R%,C%),Archive{(UndoPtr%)}.Data%
PROCcell(A%(),R%,C%,4)
UNTIL Archive{(UndoPtr%)}.F&=0 OR UndoPtr%=MinPtr%
Changed% = TRUE
PROCstat1("")
ELSE
VDU 7 : PROCstat1("Nothing to Undo!")
ENDIF
ENDPROC
DEFPROCredo(RETURN R%, RETURN C%)
REM GLOBAL A%(), Archive{}, UndoPtr%, MaxPtr%, Changed%
IF UndoPtr%<>MaxPtr% THEN
REPEAT
R% = Archive{(UndoPtr%)}.R&
C% = Archive{(UndoPtr%)}.C&
REM Now we have to display the data
SWAP A%(R%,C%),Archive{(UndoPtr%)}.Data%
PROCcell(A%(),R%,C%,4)
UndoPtr% = (UndoPtr%+1) MOD 1000
UNTIL Archive{(UndoPtr%)}.F&=0 OR UndoPtr%=MaxPtr%
Changed% = TRUE
PROCstat1("")
ELSE
VDU 7 : PROCstat1("Nothing to Redo!")
ENDIF
ENDPROC
DEF PROCsaveold(R%,C%,P%,F%) : REM GLOBAL Archive{}, UndoPtr%, MinPtr%, MaxPtr%
Archive{(UndoPtr%)}.Data% = P%
Archive{(UndoPtr%)}.R& = R%
Archive{(UndoPtr%)}.C& = C%
Archive{(UndoPtr%)}.F& = F%
UndoPtr% = (UndoPtr%+1) MOD 1000
MaxPtr% = UndoPtr%
IF MinPtr%=MaxPtr% MinPtr% = (MinPtr%+1) MOD 1000
ENDPROC
DEF PROCload : REM GLOBAL Sofn{}, FileName$, Count%, A%(), Q%(), Empty%
LOCAL GOFN%, filter$
filter$ = "Sudoku files"+CHR$0+"*.DAT;*.TXT;*.SDK;*.SS"+CHR$0+"All Files"+CHR$0+"*.*"+CHR$0+CHR$0
Sofn.lpstrFilter% = !^filter$
SYS "GetOpenFileName",Sofn{} TO GOFN%
IF GOFN% THEN
FileName$ = FNextractFn(Sofn.lpstrFileTitle%)
PROCtitle(FileName$)
ELSE
PROCstat1("File Open Aborted!") : ENDPROC
ENDIF
A%() = Empty% : Q%() = Empty%
CASE RIGHT$(FileName$,4) OF
WHEN ".DAT",".dat": PROCloadDat(FileName$)
OTHERWISE: PROCloadTxt(FileName$)
ENDCASE
PROCreset
IF Count% PROCcheck_solutions(0)
ENDPROC
DEF PROCloadDat(F$) : REM GLOBAL A%()
LOCAL F%,R%,C%
F% = OPENIN(F$)
FOR R% = 0 TO 8
FOR C% = 0 TO 8
IF F% PROCsaveold(R%,C%,A%(R%,C%),(C%+R%)<>0) : INPUT #F%,A%(R%,C%)
NEXT
NEXT
CLOSE #F%
ENDPROC
DEF PROCloadTxt(F$) : REM GLOBAL A%(), Empty%
LOCAL P%,R%,C%,F%,SS%,SDK%,V%,D$
F% = OPENIN(F$)
IF RIGHT$(F$,4)=".sdk" OR RIGHT$(F$,4)=".SDK" SDK% = TRUE : REM for Sudo Cue files
IF RIGHT$(F$,3)=".ss" OR RIGHT$(F$,3)=".SS" SS% = TRUE : REM for non-archival Simple Sudoku files
FOR R% = 8 TO 0 STEP -1
FOR C% = 0 TO 8
REM Now do some integrity checks and extract data
REM Works with tab, comma, bracket or no delimiter
REM Empty cell as Space, 0, x or "." to get most common txt formats
REPEAT
P% = BGET#F%
V% = TRUE
CASE P% OF
WHEN 32 : IF NOT SS% A%(R%,C%) = Empty% ELSE V% = FALSE
WHEN 48,46,88,120 : A%(R%,C%) = Empty%
WHEN 49,50,51,52,53,54,55,56,57 : A%(R%,C%) = 1 << (P%-49)
WHEN 35 : V% = FALSE : IF SDK% INPUT #F%,D$
OTHERWISE V% = FALSE
ENDCASE
UNTIL V% OR EOF#F%
NEXT
NEXT
CLOSE #F%
ENDPROC
DEF FNsaveAs : REM GLOBAL Sofn{}, FileName$
LOCAL G%,E%,filter$
filter$ = "Text File (*.TXT)"+CHR$0+"*.TXT"+CHR$0+\
\ "Sudoku File (*.SS)" +CHR$0+"*.SS" +CHR$0+\
\ "Snapshot File (*.DAT)"+CHR$0+"*.DAT"+CHR$0+CHR$0
Sofn.lpstrFilter% = !^filter$
SYS "GetSaveFileName",Sofn{} TO G%
REM If nFileExtension = 0 after call no extension specified, otherwise gives position of "."
IF G% THEN
FileName$ = FNextractFn(Sofn.lpstrFileTitle%)
E% = Sofn.nFileExtension.l&
IF E% FileName$ = LEFT$(FileName$,E%-1-Sofn.nFileOffset.l&)
CASE Sofn.nFilterIndex% OF
REM Get File filter index nFilterIndex
WHEN 1 : FileName$ += ".txt" PROCsaveTxt(FileName$)
WHEN 2 : FileName$ += ".ss" PROCsaveSS(FileName$)
WHEN 3 : FileName$ += ".dat" PROCsaveDat(FileName$)
ENDCASE
PROCtitle(FileName$)
ENDIF
= G%
DEF FNsave : REM GLOBAL FileName$
IF FileName$ = "" THEN = FNsaveAs
CASE RIGHT$(FileName$,4) OF
WHEN ".dat",".DAT" : PROCsaveDat(FileName$)
WHEN ".txt",".TXT" : PROCsaveTxt(FileName$)
OTHERWISE:
CASE RIGHT$(FileName$,3) OF
WHEN ".ss", ".SS" : PROCsaveSS(FileName$)
OTHERWISE: PROCsaveTxt(FileName$+".txt")
ENDCASE
ENDCASE
= TRUE
DEF PROCsaveDat(F$) : REM GLOBAL A%()
LOCAL R%,C%,F%
F% = OPENOUT(F$)
FOR R% = 0 TO 8
FOR C% = 0 TO 8
PRINT #F%,A%(R%,C%)
NEXT
NEXT
CLOSE #F%
ENDPROC
DEF PROCsaveTxt(F$) : REM GLOBAL A%()
LOCAL P%,R%,C%,F%
F% = OPENOUT(F$)
FOR R% = 8 TO 0 STEP -1
FOR C% = 0 TO 8
P% = A%(R%,C%)
IF P% AND (P%-1) BPUT#F%,48 ELSE BPUT#F%, LOGP%/.3 + 49
NEXT
NEXT
CLOSE #F%
ENDPROC
DEF PROCsaveSS(F$) : REM GLOBAL A%()
LOCAL P%,R%,C%,F%
F% = OPENOUT(F$)
FOR R% = 8 TO 0 STEP -1
FOR C% = 0 TO 8
P% = A%(R%,C%)
IF P% AND (P%-1) BPUT#F%,46 ELSE BPUT#F%, LOGP%/.3 + 49
IF C%=2 OR C%=5 BPUT#F%,124
NEXT
BPUT#F%,13
IF R%=3 OR R%=6 PRINT#F%, "-----------"
NEXT
CLOSE #F%
ENDPROC
REM Get normal string from NUL-terminated string
DEF FNextractFn(P%)
LOCAL A$
WHILE ?P%
A$ += CHR$?P%
P% += 1
ENDWHILE
= A$
DEF PROChelp
LOCAL H$
H$ = "A left mouse click on any cell activates Entry mode; a right click deactivates Entry mode."+CHR$13
H$+= "Valid inputs are the numbers 123456789; Space, Delete or 0 can be used to reset a cell."+CHR$13
H$+= "Enter moves the input cursor to the right so new puzzles can be put in using the keypad."+CHR$13
H$+= "In Grid mode a left mouse click toggles a candidate on/off. Cells in which candidates have"+CHR$13
H$+= "been removed have a pink background; Solve only finds solutions from remaining candidates."+CHR$13
H$+= "The program accepts formatted or unformatted puzzle data cut from many Web sources and" +CHR$13
H$+= "most Sudoku data files. See http://www.sudocue.net/guide.htm for some solving techniques."+CHR$13+CHR$13
H$+= "File : 'Open' (Ctrl+O) reads most text formatted Sudoku puzzles and '.dat' files."+CHR$13
H$+= " 'Save' (Ctrl+S) saves the puzzle to a file in '.ss', '.txt' or '.dat' format."+CHR$13
H$+= "Edit : 'Undo' (Ctrl-Z) undoes clicks, key inputs, Show Cell, Tidy, Restore, Cut or Paste."+CHR$13
H$+= " 'Redo' (Ctrl-Y) undoes the Undo! Great for testing chains."+CHR$13
H$+= " 'Cut All' (Ctrl-X) copies the puzzle to the clipboard and clears all cells."+CHR$13
H$+= " 'Copy All' (Ctrl-C) copies the puzzle to the clipboard as a text block."+CHR$13
H$+= " 'Paste All' (Ctrl-V) pastes text blocks from the clipboard into the cells."+CHR$13
H$+= " Use for copying puzzles from other applications or text editors."+CHR$13
H$+= " 'Clear All' resets all pointers and clears the puzzle. Same as File : New."+CHR$13
H$+= "Options : 'Grid on/off' shows possible candidate list for each cell or just completed cells."+CHR$13
H$+= " 'Auto-Count on/off' allows for Count of number of solutions when file is Opened."+CHR$13
H$+= " 'Reveal on/off' toggles display of a puzzle solution. Use Help : Solve to get solution!"+CHR$13
H$+= "Tools : 'Snapshot' saves current puzzle data to file SUDOKU.DAT; Restore recovers this file"+CHR$13
H$+= " and resets the program. All history is lost and the previous Snapshot is overwritten."+CHR$13
H$+= " 'Tidy' : In Grid mode removes all possible candidates that would give rise to "+CHR$13
H$+= " duplications in rows, columns or blocks. Backspace is the shortcut key for this action."+CHR$13
H$+= " 'Highlight' and 'Filter' colour particular numbers using Function and Shift Function keys."+CHR$13
H$+= " Selecting again toggles the selection or F10 removes both effects."+CHR$13
H$+= " 'Count Solutions' determines how many solutions are possible from the currrent state."+CHR$13
H$+= " 'Generate New' makes new random puzzles with a user selected difficulty."+CHR$13
H$+= " You may not agree with the program's assessment of difficulty!"+CHR$13
H$+= "Help : 'Solve' finds the first valid solution (if any) from the current state."+CHR$13
H$+= " 'Show Cell' enters the answer for the selected cell if there is a valid solution."+CHR$13 +CHR$13
H$+= "To find out more about the BBC BASIC language click on the 'Website' link on the menu bar."+CHR$13+CHR$13
H$+= CHR$9+CHR$9+CHR$9+" RTR and MGM Feb 2006"
SYS "MessageBox",@hwnd%, H$,"Help",0
ENDPROC
DEF PROCabout : REM GLOBAL Version$
LOCAL H$
H$ = " Original Program by R.T.Russell Dec 2005"+CHR$13
H$+= "Also uses code from LibTutor examples by Jon Ripley" +CHR$13
H$+= " Additions by M.G.Marten"+CHR$13
H$+= " Coded in BBC BASIC for WINDOWS V5.21a"+CHR$13
H$+= " Program Version "+Version$+" Jul 2006"
SYS "MessageBox",@hwnd%,H$,"About Sudoku",0
ENDPROC
REM Generate a random puzzle
DEF PROCgenerate : REM GLOBAL A%(), Q%(), Empty%
LOCAL I%,P%,R%,C%,S%,D%,T%,R&()
DIM R&(80)
FOR I% = 0 TO 80 : R&(I%) = I% : NEXT
REM Randomize numbers 0 to 80
FOR I% = 0 TO 80 : SWAP R&(I%),R&(RND(81)-1) : NEXT
D% = FNdifficulty
IF D%>=0 THEN
A%() = Empty%
PROCreset
FOR I% = 0 TO 8
A%(R&(I%) DIV 9,R&(I%) MOD 9) = 1 << I%
NEXT
REM Solve to get a matrix
PROCcheck_solutions(1)
Solved% = FALSE
A%() = Q%()
FOR I% = 9 TO 80
PROCstat1("Puzzle Creation countdown "+STR$(81-I%) +" (Esc to terminate)")
REM Remove cells and check it is still solvable and not too difficult
R% = R&(I%) DIV 9 : C% = R&(I%) MOD 9
P% = Empty%
SWAP A%(R%,C%),P%
Q%() = A%()
T% = 0
S% = FNsolve(Q%(),0,T%)
IF S%<>1 OR T%>D% A%(R%,C%) = P% : REM Put last removal back
NEXT I%
PROCshow
PROCstat1("New Puzzle generated!")
ENDIF
ENDPROC
REM Get difficulty from a Dialog Box
DEF FNdifficulty : REM GLOBAL dlg%
LOCAL click%
PRIVATE diff%
PROC_showdialog(dlg%)
REM Set range 0-8
SYS "SendDlgItemMessage", !dlg%, 101, 1030, 1, &60000
REM Set initial value
SYS "SendDlgItemMessage", !dlg%, 101, 1029, 1, diff%
REM Pretend to be a modal dialog box
SYS "EnableWindow", @hwnd%, 0
REM Use ON SYS LOCAL to handle dialogue box events
ON SYS LOCAL click% = @wparam% AND &FFFF : RETURN
REPEAT WAIT 10 : UNTIL click% = 1 OR click% = 2 OR !dlg% = 0
ON SYS OFF
REM Handle results if click% = 1 "OK"
IF click%=1 THEN
SYS "SendDlgItemMessage", !dlg%, 101, 1024, 0, 0 TO diff%
ENDIF
REM Re-enable main window and close dialog
SYS "EnableWindow", @hwnd%, 1
SYS "BringWindowToTop", @hwnd%
PROC_closedialog(dlg%)
IF click%=1 THEN = diff% ELSE = -1
REM Copy grid to clipboard in Text format
DEFPROCcopy(cut%) : REM GLOBAL A%(), Empty%
LOCAL R%,C%,P%,S%,H%,L%,F%
REM block size 9*11+1 characters
SYS "GlobalAlloc",&2002, 100 TO H% : REM GMEM_MOVEABLE and GMEM_DDESHARE flags
SYS "GlobalLock", H% TO L%
REM Now move data to memory block
FOR R% = 8 TO 0 STEP -1
FOR C% = 0 TO 8
P% = A%(R%,C%)
IF cut% PROCsaveold(R%,C%,P%,F%) : A%(R%,C%) = Empty%: F% = TRUE
IF P% AND (P%-1) ?L% = 46 ELSE ?L% = LOGP%/.3 + 49
L% += 1
NEXT
?L% = 13 : L% += 1
?L% = 10 : L% += 1
NEXT
?L% = 0
SYS "OpenClipboard", @hwnd% TO S%
IF S% THEN
SYS "EmptyClipboard"
SYS "SetClipboardData",CF_TEXT%, H%
SYS "CloseClipboard"
ENDIF
SYS "GlobalUnlock",H%
ENDPROC
REM Get data from clipboard in Text format and parse into cells
DEFPROCpaste
LOCAL S%,H%,L%
SYS "IsClipboardFormatAvailable", CF_TEXT% TO S%
IF S% THEN
SYS "OpenClipboard", @hwnd% TO S%
IF S% THEN
REM Get clipboard handle to data
SYS "GetClipboardData",CF_TEXT% TO H%
IF H% THEN
REM Get actual memory location of data block
SYS "GlobalLock", H% TO L%
REM get data out of memory block
REM L% points to first data byte
PROCextract(L%)
REM release lock so others can use data
SYS "GlobalUnlock",H%
ENDIF
ENDIF
SYS "CloseClipboard"
ENDIF
ENDPROC
REM Attempts to get grid numbers from a Text format clipboard
DEFPROCextract(S%) : REM GLOBAL A%(),Changed%
LOCAL R%,C%,P&,V%,F%
FOR R% = 8 TO 0 STEP -1
FOR C% = 0 TO 8
PROCsaveold(R%,C%,A%(R%,C%),F%)
F% = TRUE
A%(R%,C%) = Empty%
REPEAT
P& = ?S%
V% = TRUE
CASE P& OF
WHEN 9,48,46,88,120 :
WHEN 49,50,51,52,53,54,55,56,57 : A%(R%,C%) = 1 << (P&-49)
OTHERWISE V% = FALSE
ENDCASE
IF P& S% += 1
UNTIL V% OR P& = 0
NEXT
NEXT
Changed% = TRUE
ENDPROC
DEF FNtemppath
LOCAL T%,L%
DIM T% LOCAL 255
SYS "GetTempPath", 256, T% TO L%
T%?L% = 13
= $T%
DEF FNch : REM GLOBAL Changed%
LOCAL R%
IF NOT Changed% THEN = TRUE
SYS "MessageBox", @hwnd%, "Save current puzzle?", "Confirm", 35 TO R%
IF R%=6 IF FNsave : Changed% = FALSE : = TRUE
IF R%=7 Changed% = FALSE : = TRUE
= FALSE
DEF PROCexit
IF FNch THEN
PROC_removestatusbar
PROC_removetoolbar
QUIT
ENDIF
ENDPROC
DEF PROCtitle(F$) : REM GLOBAL Version$
IF F$="" F$="(untitled)"
SYS "SetWindowText",@hwnd%,"Sudoku version "+Version$+" - "+F$
ENDPROC
