Sudoku robot

Advanced game related topics
MiLoo
User
User
Posts: 47
Joined: Fri Jan 28, 2011 12:26 pm

Sudoku robot

Post by MiLoo »

所带例子为难度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: Select all

;作者:迷路仟 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++
User avatar
blueb
Addict
Addict
Posts: 1041
Joined: Sat Apr 26, 2003 2:15 pm
Location: Cuernavaca, Mexico

Re: Sudoku robot

Post by blueb »

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: Select all

;==================================================================
;
; 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.

System : PB 6.10 Beta 9 (x64) and Win Pro 11 (x64)
Hardware: AMD Ryzen 9 5900X w/64 gigs Ram, AMD RX 6950 XT Graphics w/16gigs Mem
MiLoo
User
User
Posts: 47
Joined: Fri Jan 28, 2011 12:26 pm

Re: Sudoku robot

Post by MiLoo »

生成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++
User avatar
Kwai chang caine
Always Here
Always Here
Posts: 5342
Joined: Sun Nov 05, 2006 11:42 pm
Location: Lyon - France

Re: Sudoku robot

Post by Kwai chang caine »

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
User avatar
Michael Vogel
Addict
Addict
Posts: 2666
Joined: Thu Feb 09, 2006 11:27 pm
Contact:

Re: Sudoku robot

Post by Michael Vogel »

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: Select all

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
User avatar
tft
User
User
Posts: 84
Joined: Mon Dec 29, 2008 9:34 am

Re: Sudoku robot

Post by tft »

Sorry .... Goggle Drive made Virus allert
TFT seid 1989
Aktuelles Projekte : Driving School Evergarden
YouTube : Pure Basic to go
FaceBook : Temuçin SourceMagic Games
DISCORD : SourceMagic
W10 , i9 9900K ,32 GB Ram , GTX Titan , 3 Monitore FHD
ARDUINO Freak :-)
Post Reply