Break ON

;
; Sudoku generator / solver
;
; Shamelessly ripped from the PHP code by Emanuele Feronato found here:
;	http://www.emanueleferonato.com/2008/12/09/sudoku-creatorsolver-with-php/
;
; This code is basically the original transliterated into KiXtart with some
; minor fixes and helpers added where KiXtart does not have the built-in
; support functionality of PHP.
;
$=SetOption("Explicit","ON")
$=SetOption("WrapAtEOL","ON")

Global $BLOCKSIZE	$BLOCKSIZE=3
Global $RANKSIZE	$RANKSIZE=$BLOCKSIZE*$BLOCKSIZE
Global $GRIDSIZE	$GRIDSIZE=$RANKSIZE*$RANKSIZE
GLOBAL $_StatusLine_StatusRow $_StatusLine_StatusRow=15
Dim $aSudoku[$RANKSIZE*$RANKSIZE]

udfSeedRandom(@TICKS,@MSECS)
 
; Get user to fill in grid
CLS $aSudoku=udfFillGrid($aSudoku)

; Show starting grid
CLS "Starting grid:"+@CRLF udfPrintSolution($aSudoku)

; Solve puzzle
$aSudoku=udfSolve($aSudoku)

; Show solution
At(0,20) "Solved grid:                                          "+@CRLF
udfPrintSolution($aSudoku,0,1,20)

Exit 0


; Seed RNG - salt is used to peturb algorithm by discarding numbers
Function udfSeedRandom($iSeed,Optional $iSalt)
	$iSalt=CDbl($iSalt)
	$iSeed=SRND($iSeed)
	$iSeed=Rnd()
	While $iSalt>1
		$iSalt=$iSalt-1
		$iSeed=Rnd()
	Loop
	Exit 0
EndFunction

; Calculate the row that the cell is in
Function udfGetRow($iCell)
	$udfGetRow= CInt($iCell/$RANKSIZE)
EndFunction
 
; Calculate the column that the cell is in
Function udfGetCol($iCell)
	$udfGetCol=$iCell mod $RANKSIZE
EndFunction

; Calculate cell from row/column
Function udfGetCell($iRow,$iCol)
	$udfGetCell=$iRow*$RANKSIZE+$iCol
EndFunction
 
; Top left cell of block in which this cell is located
Function udfGetBlockStart($iCell)
	$udfGetBlockStart=CInt(udfGetRow($iCell)/3)*3+CInt(udfGetCol($iCell)/3)
EndFunction
 
; Check if a number is allowed in a row
Function udfIsAllowedInRow($i,$iRow,$aSudoku)
	$udfIsAllowedInRow=1
	Dim $x
	For $x=0 To 8
		If $aSudoku[udfGetCell($iRow,$x)]=$i $udfIsAllowedInRow=0 EndIf
	Next
	Exit $udfIsAllowedInRow
EndFunction

; Check if a number is allowed in a column
Function udfIsAllowedInCol($i,$iCol,$aSudoku)
	$udfIsAllowedInCol=1
	Dim $x
	For $x=0 To 8
		If $aSudoku[udfGetCell($x,$iCol)]=$i $udfIsAllowedInCol=0 EndIf
	Next
	Exit $udfIsAllowedInCol
EndFunction
 
; Check if a number is allowed in a block
Function udfIsAllowedInBlock($i,$iBlockStart,$aSudoku)
	$udfIsAllowedInBlock=1
	Dim $x
	For $x=0 To 8
		If $aSudoku[CInt($iBlockStart/3)*27+($x mod 3)+$RANKSIZE*CInt($x/3)+3*($iBlockStart mod 3)]=$i
			$udfIsAllowedInBlock=0
		EndIf
	Next
	Exit $udfIsAllowedInBlock
EndFunction
 
; Check if a number is allowed in a cell
Function udfIsAllowedInCell($iCell,$i,$aSudoku)
	Dim $iRow,$iCol,$iBlockStart

	$iRow = udfGetRow($iCell)
	$iCol = udfGetCol($iCell)
	$iBlockStart = udfGetBlockStart($iCell)

	$udfIsAllowedInCell=udfIsAllowedInRow($i,$iRow,$aSudoku) AND udfIsAllowedInCol($i,$iCol,$aSudoku) AND udfIsAllowedInBlock($i,$iBlockStart,$aSudoku)
EndFunction
 
; Check if all the entries in the row are ok
Function udfIsRowOK($iRow,$aSudoku)
	Dim $x
	Dim $aPresent
	$aPresent=Split(". . . . . . . . . .")

	For $x=0 To 8
		$aPresent[CInt($aSudoku[udfGetCell($iRow,$x)])]="Y"
	Next
	If Join($aPresent,"")=".YYYYYYYYY" $udfIsRowOK=1 Else $udfIsRowOK=0 EndIf
	Exit $udfIsRowOK
EndFunction

; Check if all the entries in the column are ok
Function udfIsColOK($iCol,$aSudoku)
	Dim $x
	Dim $aPresent
	$aPresent=Split(". . . . . . . . . .")

	For $x=0 To 8
		$aPresent[CInt($aSudoku[udfGetCell($x,$iCol)])]="Y"
	Next
	If Join($aPresent,"")=".YYYYYYYYY" $udfIsColOK=1 Else $udfIsColOK=0 EndIf
	Exit $udfIsColOK
EndFunction
 
; Check if all the entries in the this cell's block are ok
Function udfIsBlockOK($iBlockStart,$aSudoku)
	Dim $x
	Dim $aPresent
	$aPresent=Split(". . . . . . . . . .")

	For $x=0 To 8
		$aPresent[CInt($aSudoku[Cint($iBlockStart/3)*27+($x mod 3)+$RANKSIZE*CInt($x/3)+3*($iBlockStart mod 3)])]="Y"
	Next
	If Join($aPresent,"")=".YYYYYYYYY" $udfIsBlockOK=1 Else $udfIsBlockOK=0 EndIf
	Exit $udfIsBlockOK
EndFunction
 
; Is the puzzle completely solved?
Function udfIsSolved($aSudoku)
	Dim $x

	For $x=0 To 8
		IF udfIsBlockOK($x,$aSudoku)+udfIsRowOK($x,$aSudoku)+udfIsColOK($x,$aSudoku)<3
			$udfIsSolved=0
			Exit $udfIsSolved
		EndIf
	Next
	$udfIsSolved=1
	Exit $udfIsSolved
EndFunction
 
; Return an array of numbers allowed in this cell
Function udfPossibleNumbers($iCell,$aSudoku)
	Dim $x
	For $x = 1 To $RANKSIZE
		If udfIsAllowedInCell($iCell,$x,$aSudoku) $udfPossibleNumbers=$udfPossibleNumbers+" "+$x EndIf
	Next
	If $udfPossibleNumbers="" Exit 1 Else $udfPossibleNumbers=Split(Trim($udfPossibleNumbers)) Exit 0 EndIf
EndFunction
 
; Return a random selection from the possible numbers allowed in this cell
Function udfGetRandomValue($aPossibilities,$iCell)
	$udfGetRandomValue=$aPossibilities[$iCell][IIf(UBound($aPossibilities[$iCell])>0,RND(UBound($aPossibilities[$iCell])),0)]
EndFunction
 
; Generate an array containing the possibilities for each unresolved cell in the grid
Function udfCreatePossibilityMap($aSudoku)
	Dim $x
	ReDim $udfCreatePossibilityMap[81]

	For $x = 0 To 80
		If $aSudoku[$x]=0
			$udfCreatePossibilityMap[$x] = udfPossibleNumbers($x,$aSudoku)
			If @ERROR Exit @ERROR EndIf
		EndIf
	Next
	Exit 0
EndFunction
 
; Drop a named entry from the array
Function udfDeleteEntry($aArray,$vEntryToDrop)
	Dim $vEntry
	For Each $vEntry in $aArray
		If $vEntry<>$vEntryToDrop
			$udfDeleteEntry=$udfDeleteEntry+" "+$vEntryToDrop
		EndIf
	Next
	If $udfDeleteEntry="" Exit 1 Else $udfDeleteEntry=Split(Trim($udfDeleteEntry)) Exit 0 EndIf
EndFunction
 
; Identify the next cell with the smallest number of possible solutions
Function udfGetCellWithLeastSolutions($aPossibilities)
	Dim $x,$iChoices,$y

	$iChoices = 9
	For $x = 0 To 80
		$y=UBound($aPossibilities[$x])
		; StatusLine("*X="+$x+", Choices="+$y)
		if ($y<$iChoices) AND ($y>=0)
			$iChoices = $y
			$udfGetCellWithLeastSolutions=$x
		EndIf
	Next
EndFunction
 
 
Function udfSolve($aSudoku)
	Dim $iSteps,$aPopPair,$iNextCell,$iValueToTry
	Dim $aStackPossibilities,$aStackSudoku
	Dim $aPossibilities
	Dim $iStartTicks
	$iStartTicks=@TICKS
	;$aStackPossibilities = array();	
	;$aStackSudoku = array()
	While(Not udfIsSolved($aSudoku))
		$iSteps=$iSteps+1
		AT(0,20) "Pass #"+$iSteps+" Time: "+(@TICKS-$iStartTicks)/1000+" seconds   "+@CRLF
		udfPrintSolution($aSudoku,0,1,20)
		$aPossibilities=udfCreatePossibilityMap($aSudoku)
		; One of the cells cannot be solved?  Then backtrack.
		If @ERROR
			$aPopPair=udfArrayPop($aStackPossibilities)
			$aStackPossibilities=$aPopPair[0]
			$aPossibilities=$aPopPair[1]
			$aPopPair=udfArrayPop($aStackSudoku)
			$aStackSudoku=$aPopPair[0]
			$aSudoku=$aPopPair[1]
		EndIf

		$iNextCell = udfGetCellWithLeastSolutions($aPossibilities);	
		$iValueToTry = udfGetRandomValue($aPossibilities,$iNextCell)
		If UBound($aPossibilities[$iNextCell])>0
			$aPossibilities[$iNextCell] = udfDeleteEntry($aPossibilities[$iNextCell],$iValueToTry)
			$aStackPossibilities=udfArrayPush($aStackPossibilities,$aPossibilities)
			$aStackSudoku=udfArrayPush($aStackSudoku,$aSudoku)
		EndIf
		$aSudoku[$iNextCell] = $iValueToTry
	Loop
	"Completed in "+(@TICKS-$iStartTicks)/1000+" seconds, "+$iSteps+" steps."+@CRLF
	$udfSolve=$aSudoku
EndFunction

; $iCheck=1 to colour code invalid cells
Function udfPrintSolution($aSudoku,Optional $iCheck,$x,$y)
	Dim $iRow,$iCol,$iTemp,$iCell
	Dim $BORDERCOLOR $BORDERCOLOR="g/n"
	$udfPrintSolution=""
	For $iRow=0 to 8
		If $x<>"" AT($x,$y) EndIf
		If ($iRow mod 3)=0 Color $BORDERCOLOR "+---+---+---+" COLOR w/n @CRLF $x=IIF($x="","",$x+1) EndIf
		If $x<>"" AT($x,$y) EndIf
		For $iCol=0 to 8
			If ($iCol mod 3)=0 COLOR $BORDERCOLOR "|" COLOR w/n EndIf
			If $iCheck
				$iCell=udfGetCell($iRow,$iCol)
				$iTemp=$aSudoku[$iCell]
				If $iTemp
					$aSudoku[$iCell]=0
					If Not udfIsAllowedInCell($iCell,$iTemp,$aSudoku) Color r+/n $udfPrintSolution=1 EndIf
					$aSudoku[$iCell]=$iTemp
				EndIf
			EndIf
			If $aSudoku[udfGetCell($iRow,$iCol)]>0
				$aSudoku[udfGetCell($iRow,$iCol)]
			Else
				COLOR n+/n "."
			EndIf
			Color w/n
		Next
		COLOR $BORDERCOLOR "|" COLOR w/n @CRLF
		$x=IIf($x="","",$x+1)
	Next
	If $x<>"" AT($x,$y) EndIf
	COLOR $BORDERCOLOR "+---+---+---+" COLOR w/n @CRLF
EndFunction

; -----------------------------------------------------
; KiXtart Helper functions to simulate push down stacks
; -----------------------------------------------------

; Pop last value off stack
Function udfArrayPop($a)
	Redim $udfArrayPop[1]
	If 8192 & VarType($a)
		$udfArrayPop[1]=$a[UBound($a)]
		If UBound($a)
			Redim Preserve $a[UBound($a)-1]
			$udfArrayPop[0]=$a
		EndIf
	Else
		Exit 1
	EndIf
EndFunction

; Push value on stack
Function udfArrayPush($a,$v)
	Redim Preserve $a[UBound($a)+1]
	$a[UBound($a)]=$v
	$udfArrayPush=$a
EndFunction

Function StatusLine($s)
	If Not IsDeclared($_StatusLine_StatusRow) GLOBAL $_StatusLine_StatusRow $_StatusLine_StatusRow=23 EndIf
	If Not IsDeclared($_StatusLine_LastStatus) GLOBAL $_StatusLine_LastStatus EndIf
	While Len($s)<Len($_StatusLine_LastStatus)$s=$s+" " Loop
	AT($_StatusLine_StatusRow,0) $s
	$_StatusLine_LastStatus=Trim($s)
EndFunction

Function udfFillGrid($aSudoku)
	Dim $iDone,$cKey,$cLastKey,$iInvalidGrid,$x,$y,$iUpdateGrid,$iCell,$i
	$iUpdateGrid=1
	While Not $iDone
		If $iUpdateGrid
			AT(0,0) "Enter starting grid, or leave blank to generate a grid"
			AT(5,18) Color y+/n "        Keys :" Color w/n
			AT(6,18) "  Arrow keys : Move the cursor"
			AT(7,18) "           - : Decrease the digit under the cursor"
			AT(8,18) "           + : Increase the digit under the cursor"
			AT(9,18) "       SPACE : Clear the digit under the cursor"
			AT(10,18) "       ENTER : Start solving the grid"
			AT(11,18) "           L : Enter the 81 grid characters as a string"
			AT(1,0)
			$iInvalidGrid=udfPrintSolution($aSudoku,1)
			$iUpdateGrid=0
		EndIf
		$cLastKey=$cKey
		At(2+$x+($x>2)+($x>5),1+$y+($y>2)+($y>5))
		Get $cKey
		StatusLine("")
		Select
		Case Asc($cLastKey)=224 AND Asc($cKey)=75
			$y=IIF($y>0,$y-1,8)
			$cLastKey=0
		Case Asc($cLastKey)=224 AND Asc($cKey)=77
			$y=IIF($y<8,$y+1,0)
			$cLastKey=0
		Case Asc($cLastKey)=224 AND Asc($cKey)=72
			$x=IIF($x>0,$x-1,8)
			$cLastKey=0
		Case Asc($cLastKey)=224 AND Asc($cKey)=80
			$x=IIF($x<8,$x+1,0)
			$cLastKey=0
		Case Asc($cKey)=13
			If $iInvalidGrid
				StatusLine("Sorry - cannot calulate grid with invalid values")
			Else
				$iDone=1
			EndIf
		Case $cKey="+"
			$iCell=udfGetCell($x,$y)
			$aSudoku[$iCell]=IIf($aSudoku[$iCell]<9,1+$aSudoku[$iCell],0)
			$iUpdateGrid=1
		Case $cKey=" "
			$iCell=udfGetCell($x,$y)
			$aSudoku[$iCell]=0
			$iUpdateGrid=1
		Case $cKey="-"
			$iCell=udfGetCell($x,$y)
			$aSudoku[$iCell]=IIf($aSudoku[$iCell]>0,Int($aSudoku[$iCell])-1,9)
			$iUpdateGrid=1
		Case $cKey='l'
			CLS
			"Enter a Sudoku grid string comprising 81 characters:"+@CRLF
			">" GetS $cKey
			For $i=0 to 80
				$aSudoku[$i]=CInt(SubStr($cKey,$i+1,1))
			Next
			$cLastKey=0
			$iUpdateGrid=1
			CLS
		Case "Default"
			;StatusLine("Unexpected keypress: "+Asc($cKey)+", Last="+Asc($cLastKey))
		EndSelect
	Loop
	$udfFillGrid=$aSudoku
EndFunction


; vim: ts=4 sw=4 ai