# PureBasic Forum

 It is currently Thu Jun 27, 2019 1:12 am

 All times are UTC + 1 hour

 Page 1 of 1 [ 5 posts ]
 Print view Previous topic | Next topic
Author Message
 Post subject: Sudoku robotPosted: Thu Aug 30, 2018 7:37 am
 User

Joined: Fri Jan 28, 2011 12:26 pm
Posts: 29

The example presented is a sudoku problem(produced by Finnish mathematicians in 2012) at level 11.
The program takes only 30 milliseconds to complete.

Code:
;作者:迷路仟 QQ:714095563
;最后修改:2018.08.29
;V001:基础版功能:采用空格最少的单元进行枚举(网上大部分这么干),速度要几十秒到几百秒
;V002:优化速度,采用可能性最小的单元进行枚举,将时间降到毫秒级

;-[Constant]
Enumeration
#winScreen
EndEnumeration

;-[Structure]
;用到输入/输出结果的结构
Structure __ResultInfo
FindValue.l
MaxCount.l
MinRow.l
MinCol.l
EndStructure

;-[Global]
Global Dim _DimResult.b(8,8)  ;用到存放单元枚举结果
Global _IsStopSudoku          ;中断线程

;-[Function]
;判断某个空格的[待填数],返回[待填数]数量
Procedure Sudoku_Judgment(Array DimOracle.b(2), *pResult.__ResultInfo)
With *pResult
\FindValue = \$3FE    ; \$3FE=(1<<1)|(1<<2)|(1<<3)|...|(1<<9),用位来记录,
For k = 0 To 8       ;将纵列和横行的出现过的[待填数]去除掉
If _IsStopSudoku = #True : ProcedureReturn : EndIf
If DimOracle(\MinRow,k) : \FindValue & ~(1<<DimOracle(\MinRow,k)) : EndIf
If DimOracle(k,\MinCol) : \FindValue & ~(1<<DimOracle(k,\MinCol)) : EndIf
Next
r = \MinRow/3*3 : c = \MinCol/3*3
For i = 0 To 2       ;将3x3区域中出现过的[待填数]去除掉
For j = 0 To 2
If DimOracle(r+i,c+j) : \FindValue & ~(1<<DimOracle(r+i,c+j)) : EndIf
Next
Next
For k = 1 To 9       ;有占位情况的,就可以我们要求的[待填数]
If (\FindValue >> k) & 1 : Count+1 : EndIf
Next
EndWith
ProcedureReturn Count
EndProcedure

;找到最有价值的单元[待填数]最小的空格获胜.
Procedure Sudoku_FindCell(Array DimOracle.b(2), *pResult.__ResultInfo)
MaxCount = 9 : Result.__ResultInfo
For r = 0 To 8
For c = 0 To 8
If DimOracle(r, c) : Continue : EndIf
If _IsStopSudoku = #True : ProcedureReturn : EndIf
Result\MinRow = R
Result\MinCol = C
Count = Sudoku_Judgment(DimOracle(), Result) ;获取[待填数]数量
Complete+Count                               ;累计[待填数]数量,如果为0,说明已经完成
If Count < MaxCount                          ;[待填数]数量最小的获胜
MaxCount = Count
CopyMemory_(*pResult, Result, SizeOf(__ResultInfo))
EndIf
Next
Next
ProcedureReturn Complete
EndProcedure

;递归函数,用于进行递层枚举,
Procedure Sudoku_Simulation(Array DimArrary.b(2))
Dim DimOracle.b(8,8)
CopyMemory_(DimOracle(), DimArrary(), 81)
If Sudoku_FindCell(DimOracle(), Result.__ResultInfo) = 0    ;如果已经完成,保存各个单元的记录,用于输出到界面
CopyMemory_(_DimResult(), DimArrary(), 81)
ProcedureReturn #True
EndIf
Bit = 1
While Bit < 10                      ;将[待填数],进行逐一枚举
If Result\FindValue >> Bit & 1   ;有占位情况的,才是[待填数]
DimOracle(Result\MinRow, Result\MinCol) = Bit
If _IsStopSudoku = #True : ProcedureReturn #False : EndIf
If Sudoku_Simulation(DimOracle()) = #True: ProcedureReturn #True : EndIf
EndIf
Bit+1
Wend
ProcedureReturn #False
EndProcedure

;线程函数,用来暴力穷举
Dim DimArrary.b(8,8)
For y = 0 To 8
For x = 0 To 8
If DimArrary(y,x)
Else
EndIf
Next
Next
CopyMemory_(_DimResult(), DimArrary(), 81)
Time = GetTickCount_()
If Sudoku_Simulation(DimArrary())
For y = 0 To 8
For x = 0 To 8
Next
Next
MessageRequester("迷路提示", "AI已完成数独!!"+#LF\$+"用时: "+Str(GetTickCount_()-Time)+"毫秒")
ElseIf _IsStopSudoku = #True
MessageRequester("迷路提示", "中断推算!!"+#LF\$+"用时: "+Str(GetTickCount_()-Time)+" 毫秒")
Else
MessageRequester("迷路提示", "数独无解!!"+#LF\$+"用时: "+Str(GetTickCount_()-Time)+" 毫秒")
EndIf
_IsStopSudoku = #True
EndProcedure

;运行事件
Procedure Event_Simulation()
If _IsStopSudoku = #True
_IsStopSudoku = #False
Else
_IsStopSudoku = #True
EndIf
EndProcedure

;清空事件
For y = 0 To 8
For x = 0 To 8
EndIf
Next
Next
EndProcedure

;- ##########################
;- [Main]
Dim DimArrary.b(8,8)
CopyMemory_(DimArrary(), ?__BIN_Test, 81)
hWindow = OpenWindow(#winScreen, 0, 0, 400,300, "[迷路]9x9数独-AI", WindowFlags)

For y = 0 To 8
For x = 0 To 8
If DimArrary(y,x) = 0
Color = 0 : Text\$ = ""
Else
Color = \$0000FF : Text\$ = Str(DimArrary(y,x) )
EndIf
StringGadget(y*10+x, 10+x*30+x/3*5, 10+y*30+y/3*5, 30, 30, Text\$, #PB_String_Numeric|#ES_CENTER)
Next
Next
ButtonGadget(0101, 310, 010, 080, 030, "清空")
ButtonGadget(0100, 310, 050, 080, 030, "开始")
_IsStopSudoku = #True

Repeat
Select WindowEvent()
Case #PB_Event_CloseWindow : IsExitWindow = #True : _IsStopTraining = #True
Case 0100 : Event_Simulation()
EndSelect
Default
EndSelect
Delay(1)
Until IsExitWindow = #True

;- [Data] 实例
DataSection
__BIN_Test:
Data.b 8,0,0,0,0,0,0,0,0
Data.b 0,0,3,6,0,0,0,0,0
Data.b 0,7,0,0,9,0,2,0,0
Data.b 0,5,0,0,0,7,0,0,0
Data.b 0,0,0,0,4,5,7,0,0
Data.b 0,0,0,1,0,0,0,3,0
Data.b 0,0,1,0,0,0,0,6,8
Data.b 0,0,8,5,0,0,0,1,0
Data.b 0,9,0,0,0,0,4,0,0
EndDataSection

_________________
I came to the ancient oriental country - China
I will PureBasic called B++

Top

 Post subject: Re: Sudoku robotPosted: Thu Aug 30, 2018 1:22 pm

Joined: Sat Apr 26, 2003 2:15 pm
Posts: 802
Location: Cuernavaca, Mexico
Thanks MiLoo,

I took the liberty of 'Google Translating' the source and testing it with easier puzzle data
to see if level 11 took longer.

Here's the source, it might help others.
Code:
;==================================================================
;
; Author:     'lost thousand' (MiLoo)
; Date:       August 30, 2018
; Explain:    The example is a Sudoku question with difficulty level 11 (Finnish mathematician in 2012).
;            The program takes only 30 milliseconds to complete.
;
;==================================================================
;Author: lost thousand QQ:714095563
;Last Revised:2018.08.29
;V001:Basic version of the function: enumerate the unit with the least space (most of the online), the speed is tens of seconds to hundreds of seconds
;V002:Optimize the speed, enumerate with the least likely unit, and reduce the time to millisecond

; Prepare for use.
If #PB_Compiler_Debugger = 1
MessageRequester("Error", "Please de-select the 'Use Debugger' option for best elapsed times.")
End
EndIf

;-[Constant]
Enumeration
#winScreen
EndEnumeration

;-[Structure] Structure used for input/output results
Structure __ResultInfo
FindValue.l
MaxCount.l
MinRow.l
MinCol.l
EndStructure

;-[Global]
Global Dim _DimResult.b(8,8)  ;Use the storage unit to enumerate the results

;-[Functions]

;Determine the [to be filled in] of a space and return the number of [to be filled]
Procedure Sudoku_Judgment(Array DimOracle.b(2), *pResult.__ResultInfo)
With *pResult
\FindValue = \$3FE    ; \$3FE=(1<<1)|(1<<2)|(1<<3)|...|(1<<9), record by bit
For k = 0 To 8       ;Remove the [to-fill number] of the column and the horizontal line
If _IsStopSudoku = #True : ProcedureReturn : EndIf
If DimOracle(\MinRow,k) : \FindValue & ~(1<<DimOracle(\MinRow,k)) : EndIf
If DimOracle(k,\MinCol) : \FindValue & ~(1<<DimOracle(k,\MinCol)) : EndIf
Next
r = \MinRow/3*3 : c = \MinCol/3*3
For i = 0 To 2       ;Remove the [to-fill number] that has appeared in the 3x3 area
For j = 0 To 2
If DimOracle(r+i,c+j) : \FindValue & ~(1<<DimOracle(r+i,c+j)) : EndIf
Next
Next
For k = 1 To 9       ;If there is a placeholder, we can ask for [waiting for the number]
If (\FindValue >> k) & 1 : Count+1 : EndIf
Next
EndWith
ProcedureReturn Count
EndProcedure

;Find the most valuable unit [to be filled in] the smallest space to win.
Procedure Sudoku_FindCell(Array DimOracle.b(2), *pResult.__ResultInfo)
MaxCount = 9 : Result.__ResultInfo
For r = 0 To 8
For c = 0 To 8
If DimOracle(r, c) : Continue : EndIf
If _IsStopSudoku = #True : ProcedureReturn : EndIf
Result\MinRow = R
Result\MinCol = C
Count = Sudoku_Judgment(DimOracle(), Result) ;Get the number of [to be filled in]
Complete+Count                               ;The cumulative [to be filled in] number, if it is 0, the description has been completed
If Count < MaxCount                          ;[to be filled out] the smallest number of wins
MaxCount = Count
CopyMemory_(*pResult, Result, SizeOf(__ResultInfo))
EndIf
Next
Next
ProcedureReturn Complete
EndProcedure

;Recursive function for performing hierarchical enumeration,
Procedure Sudoku_Simulation(Array DimArrary.b(2))
Dim DimOracle.b(8,8)
CopyMemory_(DimOracle(), DimArrary(), 81)
If Sudoku_FindCell(DimOracle(), Result.__ResultInfo) = 0    ;If it has been completed, save the records of each unit for output to the interface.
CopyMemory_(_DimResult(), DimArrary(), 81)
ProcedureReturn #True
EndIf
Bit = 1
While Bit < 10                      ;Put [to be filled in], one by one
If Result\FindValue >> Bit & 1   ;If there is a placeholder, it is [to be filled]
DimOracle(Result\MinRow, Result\MinCol) = Bit
If _IsStopSudoku = #True : ProcedureReturn #False : EndIf
If Sudoku_Simulation(DimOracle()) = #True: ProcedureReturn #True : EndIf
EndIf
Bit+1
Wend
ProcedureReturn #False
EndProcedure

Dim DimArrary.b(8,8)
For y = 0 To 8
For x = 0 To 8
If DimArrary(y,x)
Else
EndIf
Next
Next
CopyMemory_(_DimResult(), DimArrary(), 81)
Time = GetTickCount_()
If Sudoku_Simulation(DimArrary())
For y = 0 To 8
For x = 0 To 8
Next
Next
MessageRequester("Lost tips", "AI has completed Sudoku!!"+#LF\$+"elapsed time: "+Str(GetTickCount_()-Time)+"milliseconds")
ElseIf _IsStopSudoku = #True
MessageRequester("Lost tips", "Interrupt calculation!!"+#LF\$+"elapsed time: "+Str(GetTickCount_()-Time)+" milliseconds")
Else
MessageRequester("Lost tips", "Sudoku has no solution!!"+#LF\$+"elapsed time: "+Str(GetTickCount_()-Time)+" milliseconds")
EndIf
_IsStopSudoku = #True
EndProcedure

;Running event
Procedure Event_Simulation()
If _IsStopSudoku = #True
_IsStopSudoku = #False
Else
_IsStopSudoku = #True
EndIf
EndProcedure

;Empty event
For y = 0 To 8
For x = 0 To 8
EndIf
Next
Next
EndProcedure

;- ##########################
;- [Main]
Dim DimArrary.b(8,8)
CopyMemory_(DimArrary(), ?__BIN_Test, 81)
hWindow = OpenWindow(#winScreen, 0, 0, 400,300, "[Bajo] Sudoku 9x9 - AI", WindowFlags)

For y = 0 To 8
For x = 0 To 8
If DimArrary(y,x) = 0
Color = 0 : Text\$ = ""
Else
Color = \$0000FF : Text\$ = Str(DimArrary(y,x) )
EndIf
StringGadget(y*10+x, 10+x*30+x/3*5, 10+y*30+y/3*5, 30, 30, Text\$, #PB_String_Numeric|#ES_CENTER)
Next
Next
ButtonGadget(0101, 310, 010, 080, 030, "Empty")
ButtonGadget(0100, 310, 050, 080, 030, "Start")
_IsStopSudoku = #True

Repeat
Select WindowEvent()
Case #PB_Event_CloseWindow : IsExitWindow = #True : _IsStopTraining = #True
Case 0100 : Event_Simulation()
EndSelect
Default
EndSelect
Delay(1)
Until IsExitWindow = #True

;- [Data] Instance
DataSection
__BIN_Test:
Data.b 8,0,0,0,0,0,0,0,0
Data.b 0,0,3,6,0,0,0,0,0
Data.b 0,7,0,0,9,0,2,0,0
Data.b 0,5,0,0,0,7,0,0,0
Data.b 0,0,0,0,4,5,7,0,0
Data.b 0,0,0,1,0,0,0,3,0
Data.b 0,0,1,0,0,0,0,6,8
Data.b 0,0,8,5,0,0,0,1,0
Data.b 0,9,0,0,0,0,4,0,0
EndDataSection

; -------------------------------------------------------------
;This is a much simpler seed for the Sudoku puzzle data grid. (not level 11)
;I wanted to see if the above was slower... it was. :)
; -------------------------------------------------------------

; DataSection
;    __BIN_Test:
;    Data.b 0,9,0,4,0,0,0,0,3
;    Data.b 0,0,0,0,0,9,0,6,0
;    Data.b 4,0,0,3,0,0,0,0,1
;    Data.b 8,0,0,6,7,3,4,1,0
;    Data.b 1,0,0,9,0,0,6,0,0
;    Data.b 9,0,0,0,5,1,7,0,8
;    Data.b 0,1,0,0,4,0,3,8,0
;    Data.b 0,0,8,0,0,0,0,9,0
;    Data.b 0,5,0,0,9,0,0,0,0
; EndDataSection

_________________
- It was too lonely at the top.

Top

 Post subject: Re: Sudoku robotPosted: Thu Aug 30, 2018 2:23 pm
 User

Joined: Fri Jan 28, 2011 12:26 pm
Posts: 29

I'm going to generate EXE very quickly, and I only need 30ms

_________________
I came to the ancient oriental country - China
I will PureBasic called B++

Top

 Post subject: Re: Sudoku robotPosted: Sat Sep 08, 2018 6:57 am

Joined: Sun Nov 05, 2006 11:42 pm
Posts: 4457
Location: Lyon - France
Really impressive works
And very useful in case of brain breakdown
Works very well here
Thanks for sharing and also for the translate

_________________
Not a destination

Top

 Post subject: Re: Sudoku robotPosted: Tue Sep 11, 2018 7:26 am

Joined: Thu Feb 09, 2006 11:27 pm
Posts: 2425
Cool, nice approach...

I did a simplier way by backtracking, you'll see the main part of the code below (numbers are in the array 'o', there's also an array 't' containing all valid numbers).

The windows program could be found here. Press Ctrl+N to choose a puzzle and '°' to start the solver (hopefully you'll find that one on your keyboard)...

Here's the code snippet:
Code:
Procedure BruteforceSolver()

Protected i,j,z
Protected bfMax
Protected bfNow

Structure BruteType
x.i
y.i
Tag.i
EndStructure

Protected Dim bf.BruteType(81)

bfMax=0
For i=1 To 9
For j=1 To 9
If o(i,j)=#Null
bfMax+1
With bf(bfMax)
\x=i
\y=j
EndWith
EndIf
Next j
Next i

If bfMax=#Null
Debug "Panic :("
ProcedureReturn #False
EndIf

bfNow=0
bfAction=#bfNextField

While bfAction<#bfAborted

With bf(bfNow)

If bfAction=#bfNextField
bfNow+1
If bfNow>bfMax
; Debug "Hurray"
RedrawBoard(#DrawBoard)
bfAction=#bfSolutionFound
Else
\Tag=t(\x,\y)&#TagAllCiphers
If \Tag=#Null
; Debug "No more numbers"
bfAction=#bfBacktrack
Else
bfAction=#bfNextNumber
EndIf
EndIf
EndIf

If bfAction=#bfBacktrack
o(\x,\y)=#Null
bfNow-1
If bfNow
bfAction=#bfNextNumber
Else
; Debug "No Solution :("
bfAction=#bfNoSolution
EndIf
EndIf

If bfAction=#bfNextNumber
o(\x,\y)=ld(\Tag)
If o(\x,\y)
\Tag-1<<o(\x,\y)
CheckTags(#CheckTagsNil)
If BruteforceCheck();   board valid?
bfAction=#bfNextField
Else
bfAction=#bfNextNumber
EndIf
Else
bfAction=#bfBacktrack
EndIf
EndIf

EndWith

bfAction=BruteForceExit(1);      aborting? (mouse or escape key)

Wend

ProcedureReturn Bool(bfAction=#bfSolutionFound)

EndProcedure

Top

 Display posts from previous: All posts1 day7 days2 weeks1 month3 months6 months1 year Sort by AuthorPost timeSubject AscendingDescending
 Page 1 of 1 [ 5 posts ]

 All times are UTC + 1 hour

#### Who is online

Users browsing this forum: No registered users and 2 guests

 You cannot post new topics in this forumYou cannot reply to topics in this forumYou cannot edit your posts in this forumYou cannot delete your posts in this forum

Search for:
 Jump to:  Select a forum ------------------ PureBasic    Coding Questions    Game Programming    3D Programming    Assembly Programming    The PureBasic Editor    The PureBasic Form Designer    General Discussion    Feature Requests and Wishlists    Tricks 'n' Tips Bug Reports    Bugs - Windows    Bugs - Linux    Bugs - Mac OSX    Bugs - Documentation OS Specific    AmigaOS    Linux    Windows    Mac OSX Miscellaneous    Announcement    Off Topic Showcase    Applications - Feedback and Discussion    PureFORM & JaPBe    TailBite