It is currently Sat Sep 22, 2018 12:31 am

All times are UTC + 1 hour




Post new topic Reply to topic  [ 5 posts ] 
Author Message
 Post subject: Sudoku robot
PostPosted: Thu Aug 30, 2018 7:37 am 
Offline
User
User

Joined: Fri Jan 28, 2011 12:26 pm
Posts: 28
所带例子为难度11级的数独题(2012年芬兰数学家所出).
程序只需要30毫秒就可以完成.
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

;线程函数,用来暴力穷举
Procedure Thread_Simulation(Index)
   Dim DimArrary.b(8,8)
   For y = 0 To 8
      For x = 0 To 8
         DimArrary(y,x) = Val(GetGadgetText(y*10+x))
         If DimArrary(y,x)
            SetGadgetColor(y*10+x, #PB_Gadget_FrontColor, $FF)
         Else
            SetGadgetColor(y*10+x, #PB_Gadget_FrontColor, $00)
         EndIf
      Next
   Next
   CopyMemory_(_DimResult(), DimArrary(), 81)
   Time = GetTickCount_()
   If Sudoku_Simulation(DimArrary())
      For y = 0 To 8
         For x = 0 To 8
            SetGadgetText(y*10+x, Str(_DimResult(y,x)))
         Next
      Next
      MessageRequester("迷路提示", "AI已完成数独!!"+#LF$+"用时: "+Str(GetTickCount_()-Time)+"毫秒")
   ElseIf _IsStopSudoku = #True
      MessageRequester("迷路提示", "中断推算!!"+#LF$+"用时: "+Str(GetTickCount_()-Time)+" 毫秒")
   Else 
      MessageRequester("迷路提示", "数独无解!!"+#LF$+"用时: "+Str(GetTickCount_()-Time)+" 毫秒")
   EndIf
   SetGadgetText(0100, "开始")
   _IsStopSudoku = #True
   DisableGadget(0101, #False)
EndProcedure

;运行事件
Procedure Event_Simulation()
   If _IsStopSudoku = #True
      SetGadgetText(0100, "停止")
      DisableGadget(0101, #True)
      _IsStopSudoku = #False
      CreateThread(@Thread_Simulation(), Index)
   Else
      SetGadgetText(0100, "开始")
      _IsStopSudoku = #True
      DisableGadget(0101, #False)
   EndIf
EndProcedure

;清空事件
Procedure Event_ClearGadget()
   For y = 0 To 8
      For x = 0 To 8
         If GetGadgetColor(y*10+x, #PB_Gadget_FrontColor) = 0
            SetGadgetText(y*10+x, "")
         EndIf
         SetGadgetColor(y*10+x, #PB_Gadget_FrontColor, 0)
      Next
   Next
EndProcedure

;- ##########################
;- [Main]
Dim DimArrary.b(8,8)
CopyMemory_(DimArrary(), ?__BIN_Test, 81)
LoadFont(16, "宋体", 16, #PB_Font_Bold)
SetGadgetFont(#PB_Default, FontID(16))
WindowFlags  = #PB_Window_SystemMenu |#PB_Window_MinimizeGadget |#PB_Window_ScreenCentered
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)
      SetGadgetColor(y*10+x, #PB_Gadget_FrontColor, Color)
   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 #PB_Event_Gadget
         Select EventGadget()
            Case 0100 : Event_Simulation()
            Case 0101 : Event_ClearGadget()
         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
 Profile  
Reply with quote  
 Post subject: Re: Sudoku robot
PostPosted: Thu Aug 30, 2018 1:22 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Sat Apr 26, 2003 2:15 pm
Posts: 738
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
Global _IsStopSudoku          ;Interrupt thread

;-[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

;Thread function for violent exhaustion
Procedure Thread_Simulation(Index)
   Dim DimArrary.b(8,8)
   For y = 0 To 8
      For x = 0 To 8
         DimArrary(y,x) = Val(GetGadgetText(y*10+x))
         If DimArrary(y,x)
            SetGadgetColor(y*10+x, #PB_Gadget_FrontColor, $FF)
         Else
            SetGadgetColor(y*10+x, #PB_Gadget_FrontColor, $00)
         EndIf
      Next
   Next
   CopyMemory_(_DimResult(), DimArrary(), 81)
   Time = GetTickCount_()
   If Sudoku_Simulation(DimArrary())
      For y = 0 To 8
         For x = 0 To 8
            SetGadgetText(y*10+x, Str(_DimResult(y,x)))
         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
   SetGadgetText(0100, "Start")
   _IsStopSudoku = #True
   DisableGadget(0101, #False)
EndProcedure

;Running event
Procedure Event_Simulation()
   If _IsStopSudoku = #True
      SetGadgetText(0100, "Stop")
      DisableGadget(0101, #True)
      _IsStopSudoku = #False
      CreateThread(@Thread_Simulation(), Index)
   Else
      SetGadgetText(0100, "Start")
      _IsStopSudoku = #True
      DisableGadget(0101, #False)
   EndIf
EndProcedure

;Empty event
Procedure Event_ClearGadget()
   For y = 0 To 8
      For x = 0 To 8
         If GetGadgetColor(y*10+x, #PB_Gadget_FrontColor) = 0
            SetGadgetText(y*10+x, "")
         EndIf
         SetGadgetColor(y*10+x, #PB_Gadget_FrontColor, 0)
      Next
   Next
EndProcedure

;- ##########################
;- [Main]
Dim DimArrary.b(8,8)
CopyMemory_(DimArrary(), ?__BIN_Test, 81)
LoadFont(16, "Verdana", 14, #PB_Font_Bold)
SetGadgetFont(#PB_Default, FontID(16))
WindowFlags  = #PB_Window_SystemMenu |#PB_Window_MinimizeGadget |#PB_Window_ScreenCentered
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)
      SetGadgetColor(y*10+x, #PB_Gadget_FrontColor, Color)
   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 #PB_Event_Gadget
         Select EventGadget()
            Case 0100 : Event_Simulation()
            Case 0101 : Event_ClearGadget()
         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
 Profile  
Reply with quote  
 Post subject: Re: Sudoku robot
PostPosted: Thu Aug 30, 2018 2:23 pm 
Offline
User
User

Joined: Fri Jan 28, 2011 12:26 pm
Posts: 28
生成EXE,速度很快,只需要30ms
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
 Profile  
Reply with quote  
 Post subject: Re: Sudoku robot
PostPosted: Sat Sep 08, 2018 6:57 am 
Offline
Addict
Addict
User avatar

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

_________________
ImageThe happiness is a road...
Not a destination


Top
 Profile  
Reply with quote  
 Post subject: Re: Sudoku robot
PostPosted: Tue Sep 11, 2018 7:26 am 
Offline
Addict
Addict
User avatar

Joined: Thu Feb 09, 2006 11:27 pm
Posts: 2309
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)...

Image

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
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 5 posts ] 

All times are UTC + 1 hour


Who is online

Users browsing this forum: No registered users and 1 guest


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

Search for:
Jump to:  

 


Powered by phpBB © 2008 phpBB Group
subSilver+ theme by Canver Software, sponsor Sanal Modifiye