Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
#Compiler PBWin 10
#Compile Exe
#Dim All
%Unicode = 1
#Include "Win32API.inc"
Enum Equates Singular
IDC_Graphic = 500
IDM_0
IDM_1
IDM_2
IDM_3
IDM_4
IDM_5
IDM_6
IDM_7
IDM_8
IDM_9
IDM_Up
IDM_Down
IDM_Left
IDM_Right
IDM_Test
End Enum
Global hDlg,hFont As Dword, LastX, LastY, D() As Long
Global CurrentX, CurrentY As Long
Function PBMain() As Long
Dialog New Pixels, 0, "Suduku Puzzle",300,300,400,400, %WS_SysMenu To hDlg
Control Add Graphic, hDlg, %IDC_Graphic,"", 0,0,400,400, %SS_Notify
Graphic Attach hDlg, %IDC_Graphic, ReDraw
Graphic Set Mix %R2_CopyPen
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Local w,h,x,y,i,j As Long
Select Case Cb.Msg
Case %WM_InitDialog
BuildAcceleratorTable
CurrentX = 3 : CurrentY = 3
Font New "Tahoma",12,1 To hFont
Graphic Set Font hFont
BuildPuzzle
DrawPuzzle
LastX = -1
Case %WM_LButtonDown
SetCapture hDlg 'start capturing, so can detect LButtonUp when it occurs
Case %WM_MouseMove
If GetCapture() = hDlg Then 'app has capture 'why?
x = Lo(Integer,Cb.LParam)
y = Hi(Integer,Cb.LParam)
If LastX = -1 Then LastX = x : LastY = y
Graphic Line (LastX,LastY)-(x,y), %Red
LastX = x : LastY = y
End If
Case %WM_LButtonUp
ReleaseCapture
LastX = -1
Case %WM_Command
Select Case Cb.Ctl
Case %IDM_0 : D(CurrentX,Currenty) = 0 : DrawPuzzle
Case %IDM_1 : If RuleCheck(1) Then D(CurrentX,Currenty) = 1 : DrawPuzzle : GameCheck
Case %IDM_2 : If RuleCheck(2) Then D(CurrentX,Currenty) = 2 : DrawPuzzle : GameCheck
Case %IDM_3 : If RuleCheck(3) Then D(CurrentX,Currenty) = 3 : DrawPuzzle : GameCheck
Case %IDM_4 : If RuleCheck(4) Then D(CurrentX,Currenty) = 4 : DrawPuzzle : GameCheck
Case %IDM_5 : If RuleCheck(5) Then D(CurrentX,Currenty) = 5 : DrawPuzzle : GameCheck
Case %IDM_6 : If RuleCheck(6) Then D(CurrentX,Currenty) = 6 : DrawPuzzle : GameCheck
Case %IDM_7 : If RuleCheck(7) Then D(CurrentX,Currenty) = 7 : DrawPuzzle : GameCheck
Case %IDM_8 : If RuleCheck(8) Then D(CurrentX,Currenty) = 8 : DrawPuzzle : GameCheck
Case %IDM_9 : If RuleCheck(9) Then D(CurrentX,Currenty) = 9 : DrawPuzzle : GameCheck
Case %IDM_Up : Decr CurrentY : CurrentY = Max(1,CurrentY) : DrawPuzzle
Case %IDM_Down : Incr CurrentY : CurrentY = Min(9,CurrentY) : DrawPuzzle
Case %IDM_Left : Decr CurrentX : CurrentX = Max(1,CurrentX) : DrawPuzzle
Case %IDM_Right: Incr CurrentX : CurrentX = Min(9,CurrentX) : DrawPuzzle
Case %IDM_Test : ReadText "Congratulations! You have solved the Suduku puzzle!"
? "bingo"
Case %IDC_Graphic
If Cb.CtlMsg = %STN_Clicked Then
GetCurrentXY
DrawPuzzle
End If
End Select
End Select
End Function
Sub DrawPuzzle
Graphic Clear
DrawPuzzleLines
DrawBoxLines
DrawPuzzleNumbers
DrawSelection
Graphic ReDraw
End Sub
Sub BuildPuzzle
Local x,y,iCount As Long, temp$
ReDim D(9,9) 'all values set to zero
Data 0,3,0,8,0,0,0,0,0
Data 0,0,6,0,2,0,0,0,3
Data 0,0,0,3,0,9,0,5,0
Data 0,0,5,0,9,0,7,0,1
Data 0,2,0,4,0,1,0,8,0
Data 6,0,1,0,7,0,4,0,0
Data 0,5,0,7,0,3,0,0,0
Data 0,0,0,0,0,2,0,6,0
For y = 1 To 9 : For x = 1 To 9
Incr iCount : temp$ = Read$(iCount) : D(x,y) = Val(temp$)
Next x : Next y
End Sub
Sub DrawPuzzleLines
Local i,j,x,y,m,wp,hp,w,h As Long
Dialog Get Client hDlg To w,h
m = 10 : wp = (w-2*m)/9 : hp = (h-2*m)/9
Graphic Width 1
For i = 0 To 8 : For j = 0 To 8
x = i*wp+m : y = j*hp+m
Graphic Box (x,y)-(x+wp,y+hp),,%Black
Next j : Next i
Graphic Width 4
End Sub
Sub DrawBoxLines
Local i,j,x,y,m,wp,hp,w,h As Long
Dialog Get Client hDlg To w,h
m = 10 : wp = (w-2*m)/9 : hp = (h-2*m)/9
Graphic Width 5
'vertical lines
For i = 0 To 9 Step 3
x = i*wp+m : y = j*hp+m
Graphic Line (x,m)-(x,h-m-2),%Black
Next i
'horizontal lines
For j = 0 To 9 Step 3
y = j*hp+m
Graphic Line (m,y)-(w-m-2,y),%Black
Next j
Graphic Width 4
End Sub
Sub DrawPuzzleNumbers
Local i,j,x,y,m,wp,hp,w,h As Long
Dialog Get Client hDlg To w,h
m = 10 : wp = (w-2*m)/9 : hp = (h-2*m)/9
Graphic Width 1
For i = 1 To 9 : For j = 1 To 9
x = (i-1)*wp+m : y = (j-1)*hp+m
If D(i,j) <> 0 Then Graphic Set Pos (x+wp/3, y+hp/3) : Graphic Print D(i,j)
Next j : Next i
Graphic Width 4
End Sub
Sub DrawSelection
Local i,j,x,y,m,wp,hp,w,h As Long
Dialog Get Client hDlg To w,h
m = 10 : wp = (w-2*m)/9 : hp = (h-2*m)/9
Graphic Width 5
For i = 1 To 9 : For j = 1 To 9
y = (i-1)*wp+m : x = (j-1)*hp+m
If (j = CurrentX) And (i = CurrentY) Then Graphic Box (x,y)-(x+wp,y+hp),,%Red
Next j : Next i
Dialog Set Text hDlg, "Suduku Puzzle Selection: " + Str$(CurrentX) + "," + Str$(CurrentY)
Graphic Width 4
End Sub
Sub GetCurrentXY
Local pt As Point, x,y,w,h As Long
GetCursorPos pt 'pt has xy screen coordinates
ScreenToClient hDlg, pt 'pt now has dialog client coordinates
Dialog Get Client hDlg To w,h
x = pt.x/w * 10
CurrentX = Max(0,x)
y = pt.y/h * 10
CurrentY = Max(0,y)
End Sub
Sub BuildAcceleratorTable
Local c As Long, ac() As ACCELAPI, hAccelerator As Dword ' for keyboard accelator table values
Dim ac(15)
ac(c).fvirt = %FVIRTKEY : ac(c).key = %VK_0 : ac(c).cmd = %IDM_0 : Incr c
ac(c).fvirt = %FVIRTKEY : ac(c).key = %VK_1 : ac(c).cmd = %IDM_1 : Incr c
ac(c).fvirt = %FVIRTKEY : ac(c).key = %VK_2 : ac(c).cmd = %IDM_2 : Incr c
ac(c).fvirt = %FVIRTKEY : ac(c).key = %VK_3 : ac(c).cmd = %IDM_3 : Incr c
ac(c).fvirt = %FVIRTKEY : ac(c).key = %VK_4 : ac(c).cmd = %IDM_4 : Incr c
ac(c).fvirt = %FVIRTKEY : ac(c).key = %VK_5 : ac(c).cmd = %IDM_5 : Incr c
ac(c).fvirt = %FVIRTKEY : ac(c).key = %VK_6 : ac(c).cmd = %IDM_6 : Incr c
ac(c).fvirt = %FVIRTKEY : ac(c).key = %VK_7 : ac(c).cmd = %IDM_7 : Incr c
ac(c).fvirt = %FVIRTKEY : ac(c).key = %VK_8 : ac(c).cmd = %IDM_8 : Incr c
ac(c).fvirt = %FVIRTKEY : ac(c).key = %VK_9 : ac(c).cmd = %IDM_9 : Incr c
ac(c).fvirt = %FVIRTKEY Or %FCONTROL : ac(c).key = %VK_T : ac(c).cmd = %IDM_Test : Incr c
ac(c).fvirt = %FVIRTKEY : ac(c).key = %VK_Up : ac(c).cmd = %IDM_Up : Incr c
ac(c).fvirt = %FVIRTKEY : ac(c).key = %VK_Down : ac(c).cmd = %IDM_Down : Incr c
ac(c).fvirt = %FVIRTKEY : ac(c).key = %VK_Left : ac(c).cmd = %IDM_Left : Incr c
ac(c).fvirt = %FVIRTKEY : ac(c).key = %VK_Right : ac(c).cmd = %IDM_Right : Incr c
Accel Attach hDlg, AC() To hAccelerator
End Sub
Function RuleCheck(n As Long) As Long
Local x,y,sum,OldD As Long
'user has entered a value for a cell.
'test to see if valid entry in rows
OldD = D(CurrentX,CurrentY)
D(CurrentX,Currenty) = n 'undo later if need be
For y = 1 To 9
ReDim T(9) As Long
For x = 1 To 9
If D(x,y) = 0 Then Iterate For
Incr T(D(x,y))
If T(D(x,y))> 1 Then
Beep
ReadText Str$(n) + " is already used in row" + Str$(y)
D(CurrentX,CurrentY) = OldD
Function = 0
Exit Function
End If
Next x
Next y
Function = 1
'test to see if valid entry in columns
OldD = D(CurrentX,CurrentY)
D(CurrentX,Currenty) = n 'undo later if need be
For x = 1 To 9
ReDim T(9) As Long
For y = 1 To 9
If D(x,y) = 0 Then Iterate For
Incr T(D(x,y))
If T(D(x,y))> 1 Then
Beep
ReadText Str$(n) + " is already used in column" + Str$(x)
D(CurrentX,CurrentY) = OldD
Function = 0
Exit Function
End If
Next x
Next y
Function = 1
'test to see if valid entry in Boxes
End Function
Sub GameCheck
Local x,y As Long
'puzzle ocmplete (no zeros)
For x = 1 To 9
For y = 1 To 9
If D(x,y) = 0 Then Exit Sub 'value zero, not a success
Next y
Next x
ReadText "Congratulations! You have solved the Suduku puzzle!"
End Sub
Sub ReadText (sText As String)
Local vRes, vTxt, vTime As Variant, oSp As Dispatch
Let oSp = NewCom "SAPI.SpVoice"
If IsFalse IsObject(oSp) Then Exit Sub
vTxt = sText
Object Call oSp.Speak(vTxt) To vRes
vTime = -1 As Long
Object Call oSp.WaitUntilDone(vTime) To vRes
End Sub
'gbs_01377
'Date: 05-11-2013
http://www.garybeene.com/sw/gbsnippets.htm