Home Page

R. T. RUSSELL

BBC BASIC for Windows

Sudoku



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.20 (RTR), 24-Nov-2010
     
Version$ = "3.20 (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!WC Windows Constants
     
_LOGPIXELSX = 88
     IDCANCEL = 2
     IDOK = 1
     MB_ICONWARNING = &30
     IDNO = 7
     IDYES = 6
     MAX_PATH = 260
     MB_ICONQUESTION = &20
     MB_YESNOCANCEL = &3
     NULL = 0
     PD_PRINTSETUP = &40
     PD_RETURNDC = &100
     TBM_SETPOS = &405
     SB_SETTEXT =  &401
     TB_SETSTATE = &411
     GMEM_DDESHARE = &2000
     GMEM_MOVEABLE = &2
     TBM_GETPOS = &400
     TBM_SETRANGE = &406
     SB_SETPARTS = &404
     SWP_NOMOVE = &2
     SWP_NOZORDER = &4
     WS_MAXIMIZEBOX = &10000
     WS_SIZEBOX = &40000
     GWL_STYLE = -16
     CF_TEXT = 1

     REM Set window style to disallow resizing
     
SYS "GetWindowLong", @hwnd%, GWL_STYLE TO ws%
     ws% AND= NOT(WS_SIZEBOX OR WS_MAXIMIZEBOX)
     SYS "SetWindowLong", @hwnd%, GWL_STYLE, ws%

     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{                    \
     
\  lStructSize%,           \
     
\  hwndOwner%,             \ A handle to the window that owns the dialog box.
     
\  hDevMode%,              \ If both hDevMode and hDevNames are NULL,
     
\  hDevNames%,             \ PrintDlg uses the current default printer.
     
\  hDC%,                   \ A handle to the printer's device context
     
\  Flags%,                 \
     
\  nFromPage{l&,h&},       \
     
\  nToPage{l&,h&},         \
     
\  nMinPage{l&,h&},        \
     
\  nMaxPage{l&,h&},        \
     
\  nCopies{l&,h&},         \
     
\  hInstance%,             \
     
\  lCustData%,             \
     
\  lpfnPrintHook%,         \
     
\  lpfnSetupHook%,         \
     
\  lpPrintTemplateName%,   \
     
\  lpSetupTemplateName%,   \
     
\  hPrintTemplate%,        \
     
\  hSetupTemplate% }

     REM Populate PRINTDLG structure
     
Pd.lStructSize% = DIM(Pd{})
     Pd.hwndOwner% = @hwnd%
     Pd.Flags% = PD_RETURNDC OR PD_PRINTSETUP

     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 '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% = 453
     rc.t% = 0
     rc.b% = 453 + status_bar_height% + tool_bar_height%
     SYS "AdjustWindowRect", rc{}, ws%, 1
     SYS "SetWindowPos", @hwnd%, 0, 0, 0, rc.r%-rc.l%, rc.b%-rc.t%, SWP_NOMOVE OR SWP_NOZORDER
     VDU 26
     ORIGIN 0,2*status_bar_height%
     PROC_removestatusbar  :REM It would be in the wrong place if we resize
     
hs% = FN_createstatusbar("")

     REM Partition Status bar
     
num_parts% = 2
     DIM edge%(num_parts%-1)
     edge%() = @vdu.tr%-155, -1 : REM position of RH edges
     
SYS "SendMessage", hs%, SB_SETPARTS, num_parts%, ^edge%(0)

     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
     DIM fn% MAX_PATH
     Sofn.lStructSize% = DIM(Sofn{})
     Sofn.hwndOwner% = @hwnd%
     Sofn.nFilterIndex% = 1
     Sofn.lpstrFileTitle% = ft%
     Sofn.nMaxFileTitle% = 80
     Sofn.lpstrFile% = fn%
     Sofn.nMaxFile% = MAX_PATH
     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

     REM Set up interrupts
     
ON MOUSE Click% = 10 : RETURN
     ON SYS
Click% = @wparam% : RETURN
     ON CLOSE PROC
exit : RETURN
     ON ERROR IF ERR
<>17 SYS "MessageBox",@hwnd%,REPORT$,0,MB_ICONWARNING ELSE PROCshow

     PROCreset
     COLOUR 8,255,224,224

     REM Main Program loop
     
REPEAT
       PROC
stat2(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%, TB_SETSTATE, 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
         
REM Program spends nearly all the time polling this loop.
         REM If a menu or toolbutton pressed or the mouse clicked we move on
         REM and act on the ID of the menu item or button, or 10 for mouse
         REM which is held in K%.
         
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
           PROC
check_solutions(K%)
           :
         WHEN 2 : REM Reveal (Ctrl+B)
           
IF Solved% THEN
             
Entry% = FALSE : Reveal% = NOT Reveal% : PROCshow
             IF Reveal% THEN
               PROC
stat1("Select Options...Reveal again to hide solution")
             ELSE
               PROC
stat1("")
             ENDIF
           ENDIF
           
:
         WHEN 3 : PROCcopy(FALSE) : REM Copy (Ctrl+C)
           
:
         WHEN 4 : REM Snapshot (Ctrl+D)
           
Reveal% = FALSE : PROCshow
           PROCsaveDat(FNspecialfolder(26)+"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
               PROC
stat1("Click on small numbers to eliminate them")
             ELSE
               PROC
stat1("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(FNspecialfolder(26)+"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
             PROC
saveold(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% . Sends text strings to status bar.
     
DEF PROCstat1(A$) : SYS "SendMessage",hs%,SB_SETTEXT,0,A$ : ENDPROC
     
DEF PROCstat2(A$) : SYS "SendMessage",hs%,SB_SETTEXT,1,A$ : ENDPROC

     
DEF PROCcheck_solutions(K%) : REM GLOBAL A%(), Q%(), Solved%
     
LOCAL S%,T%
     Q%() = A%()
     Solved% = FALSE
     PROC
stat1("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
         PROC
stat1("Solved : Select Options...Reveal to show solution")
       ELSE
         PROC
stat1("Impossible")
       ENDIF
     ELSE
       IF
S% = 1 THEN
         PROC
stat1("There is 1 solution")
       ELSE
         PROC
stat1("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, we want LOG to base 2
       REM to get the bit position which equals LOG base 10 divided by 2 LOG 10 or 0.3010.
       REM e.g. %000010000 equivalent to 4. Shift to 5 occurs as we print it.
       
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 : REM 49 is ASCII for 1 so result from %000010000 is to print a 5
       
*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.hDC%
       *printerfont Arial,20
       *MARGINS 10,10,10,10
       SYS "GetDeviceCaps", @prthdc%, _LOGPIXELSX 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
         PROC
cell(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
       PROC
stat1("")
     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
       PROC
stat1("")
     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$ = $$Sofn.lpstrFile%
       PROCtitle($$Sofn.lpstrFileTitle%)
     ELSE
       PROC
stat1("File Open Aborted!") : ENDPROC
     ENDIF
     
A%() = Empty% : Q%() = Empty%
     CASE RIGHT$(FileName$,4) OF
       WHEN
".DAT",".dat": PROCloadDat(FileName$)
       OTHERWISE:          PROCloadTxt(FileName$)
     ENDCASE
     PROC
reset
     IF Count% PROCcheck_solutions(0)
     ENDPROC

     
DEF PROCloadDat(F$) : REM GLOBAL A%()
     
LOCAL F%,R%,C%
     F% = OPENIN(F$)
     IF F% THEN
       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%
     ELSE
       SYS
"MessageBox",@hwnd%,"Failed to open file "+F$,0,MB_ICONWARNING
     ENDIF
     ENDPROC

     
DEF PROCloadTxt(F$) : REM GLOBAL A%(), Empty%
     
LOCAL P%,R%,C%,F%,SS%,SDK%,V%,D$
     F% = OPENIN(F$)
     IF F% THEN
       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%
     ELSE
       SYS
"MessageBox",@hwnd%,"Failed to open file "+F$,0,MB_ICONWARNING
     ENDIF
     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$
     IF FileName$="" THEN $$Sofn.lpstrFile%="Untitled"
     SYS "GetSaveFileName",Sofn{} TO G%

     IF G% THEN
       
FileName$ = $$Sofn.lpstrFile%
       E% = Sofn.nFileExtension.l&
       IF E% FileName$ = LEFT$(FileName$,E%-1)
       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
       PROC
title($$Sofn.lpstrFileTitle%)
     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$)
     IF F% THEN
       FOR
R% = 0 TO 8
         FOR C% = 0 TO 8
           PRINT #F%,A%(R%,C%)
         NEXT
       NEXT
       CLOSE
#F%
     ELSE
       SYS
"MessageBox",@hwnd%,"Failed to save file "+F$,0,MB_ICONWARNING
     ENDIF
     ENDPROC

     
DEF PROCsaveTxt(F$) : REM GLOBAL A%()
     
LOCAL P%,R%,C%,F%
     F% = OPENOUT(F$)
     IF F% THEN
       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%
     ELSE
       SYS
"MessageBox",@hwnd%,"Failed to save file "+F$,0,MB_ICONWARNING
     ENDIF
     ENDPROC

     
DEF PROCsaveSS(F$) : REM GLOBAL A%()
     
LOCAL P%,R%,C%,F%
     F% = OPENOUT(F$)
     IF F% THEN
       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%
     ELSE
       SYS
"MessageBox",@hwnd%,"Failed to save file "+F$,0,MB_ICONWARNING
     ENDIF
     ENDPROC

     
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 Nov 2010"
     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.91b"+CHR$13
     H$+= "            Program Version "+Version$+" Nov 2010"
     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!")
       FileName$ = "" : REM Reset name
       
PROCtitle(FileName$)
     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, TBM_SETRANGE, 1, &60000
     REM Set initial value
     
SYS "SendDlgItemMessage", !dlg%, 101, TBM_SETPOS, 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% = IDOK OR click% = IDCANCEL OR !dlg% = 0
     ON SYS OFF
     
REM Handle results if click% = 1 "OK"
     
IF click%=1 THEN
       SYS
"SendDlgItemMessage", !dlg%, 101, TBM_GETPOS, 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", GMEM_MOVEABLE OR GMEM_DDESHARE, 100 TO H%
     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 : REM ASCII 46 is blank cell
         
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 FNch : REM GLOBAL Changed%
     
LOCAL R%
     IF NOT Changed% THEN = TRUE
     SYS
"MessageBox", @hwnd%, "Save current puzzle?", "Confirm", MB_ICONQUESTION OR MB_YESNOCANCEL TO R%
     IF R%=IDYES IF FNsave : Changed% = FALSE : = TRUE
     IF
R%=IDNO 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

     
DEF FNspecialfolder(id%)
     LOCAL ppidl%, folder%, malloc%
     DIM folder% LOCAL 255
     SYS "SHGetSpecialFolderLocation", @hwnd%, id%, ^ppidl%
     SYS "SHGetPathFromIDList", ppidl%, folder%
     SYS "SHGetMalloc", ^malloc%
     SYS !(!malloc%+20), malloc%, ppidl% : REM. IMalloc::Free
     
= $$folder% + "\"


Home - Products - Contact us

Best viewed with Any Browser Valid HTML 3.2!
© Richard Russell 2010