XQuery/Sudoku

Sudoku solver in XQuery

A Puzzle

A sudoku puzzle can be expressed in matrix form. Here is part of one from a Times book of sudokus.

<?xml version="1.0" encoding="UTF-8"?>
<sudoku name="Times 1 p1">
    <matrix>
        <row>
            <col/>
            <col>6</col>
            <col>1</col>
            <col/>
            <col>3</col>
            <col/>
            <col/>
            <col>2</col>
            <col/>
        </row>
        <row>
            <col/>
            <col>5</col>
            <col/>
            <col/>
            <col/>
            <col>8</col>
            <col>1</col>
            <col/>
            <col>7</col>
        </row>
        <row>
            <col/>

The Main script

The main script is passed a URL referencing the problem XML file. The matrix format is converted to a sequence of cells, the puzzle solved, the resultant cell list converted back to a matrix and the matrix printed. The elapsed time of the solution search is computed and displayed after the initial problem and the solution.

import module namespace su = 'http://www.cems.uwe.ac.uk/wiki/sudoku' at 'sudoku4.xqm';

declare option exist:serialize 'method=xhtml  media-type=text/html';

declare function local:duration-as-ms($t) {
      round((minutes-from-duration($t) * 60 + seconds-from-duration($t)) * 1000 )
};

let $url := request:get-parameter('url',())
let $sudoku :=doc($url)/sudoku
let $p := $sudoku/matrix
let $pc :=  su:matrix-to-cells($p)
let $start := util:system-time()
let $ps := su:solve($pc)  
let $finish := util:system-time()
let $elapsedms := local:duration-as-ms($finish - $start)
let $s := su:cells-to-matrix($ps)

return 
<div>
  <h1>Solving Sudoku problem {string($sudoku/@name)}</h1>
  <table border = '1'>
      <tr>
        <td>{su:matrix-to-table($p)}</td>
        <td>{su:matrix-to-table($s)}</td>
       </tr>
   </table>
   <p>Elapsed time in milliseconds : {$elapsedms}</p>
 </div>

Functions

This module defines the necessary functions to support a brute force, depth-first search of the solution tree. Two representations of a sudoku puzzle are used here:

nested columns within rows  -  element(matrix) - the input format
list of cells with explicit row and column numbers  - element(cells)

The algorithm starts with the cell list representation. The number of possible solutions to every empty square is calculated. If there there is a cell with only one value, that cell is added to the list of cells and the algorithm continues. If there is more than one possible value for a cell, the algorithm iterates over the possible values, positing that each in turn is the correct value. If there is no possible value, that partial solution is infeasible and that solution path is abandoned, returning null and the next possible cell value will be tried.

declare function su:matrix-to-table($s as element(matrix)) as element(table) {
<table class="sudoku">
    { for $r in $s/row
      return
       <tr>
          { for $c in $r/col
            return <td>{string($c)}</td>
          }
      </tr>
    }
</table>
};

declare function su:matrix-to-cells($s as element(matrix)) as element(cell)* {
 for $i in (1 to 9)
   for $j in (1 to 9)
   let $c := $s/row[$i]/col[$j]
   return
      if ($c/text())
      then <cell row='{$i}' col='{$j}'>{string($c)}</cell>
      else ()
};

declare function su:cells-to-matrix($s as element(cell)*) as element(matrix) {
<matrix>
  { for $i in (1 to 9)
    return
    <row>
     { for $j in (1 to 9)
       let $c := $s[@row = $i][@col = $j]
        return
          <col>{string($c)}</col>
      }
   </row>
  }
</matrix>
};

declare function su:block($s as element(cell)*, $i as xs:integer, $j as xs:integer ) as element(cell)+ {
(: return the block of 9 cells containing $i, $j :)
   let $tci := (($i - 1) idiv 3 * 3 ) + 1
   let $tcj := (($j - 1) idiv 3 * 3 ) + 1
   return $s[@row = ($tci to $tci + 2)][@col = ($tcj to $tcj + 2)]
};

declare function su:row($s as element(cell)*,$i as xs:integer) as element(cell)+ {
(:  return the cells in row $i :)
   $s[@row = $i]
};

declare function su:col($s as element(cell)* ,$j as xs:integer) as element(cell)+{
(: return the cells in column $j :)
   $s[@col = $j]
};

declare function su:values($s as element(cell)*, $i as xs:integer, $j as xs:integer) as xs:integer* {
(: return the set (sequence) of values in a cell's row, column and block :)
   distinct-values( (su:row($s,$i) ,su:col($s,$j) , su:block($s,$i,$j) ))
};

declare function su:missing-values($s as element(cell)*,$i as xs:integer,$j as xs:integer) as xs:integer* {
(: return the numbers missing from 1 to 9 i.e. the possible values for cell $i , $j :) 
   let $vals := su:values($s,$i,$j)
   return 
     (1 to 9) [not(. = $vals)]
};

declare function su:missing-cells($s as element(cell)*) as element(cells)* {
   for $i in (1 to 9)
   for $j in (1 to 9)
   where empty($s[@row = $i][@col = $j])
   return
     let $m := su:missing-values($s,$i,$j)
     return <cell row='{$i}' col='{$j}' n='{count($m)}'>{$m}</cell>
};

declare function su:best-cell($s as element(cell)*) as element(cell)* {
(: return (one of ) the cells with the minimum number of possible values :)
   let $empty :=  su:missing-cells($s)
   let $min := min( $empty/@n)
   return 
      ($empty[@n = $min])[1]
};

declare function su:search-for-solution($s as element(cell)*, $cell as element(cell), $posvalues as xs:string*) {
(: recursive search of a set of possible values for a cell :)
  if (empty($posvalues))
  then ()  
  else 
     let $pos:= $posvalues[1]   (: choose the first :) 
     let $posit := <cell row='{$cell/@row}' col='{$cell/@col}'>{$pos}</cell>
     let $sol := su:solve(($s,$posit)) (: try with this posited value for the cell :)
     return 
       if ($sol )  (: a solution :)
       then $sol
       else   (: continue with the rest of the possible values :)
             su:search-for-solution($s, $cell, subsequence($posvalues,2))
};

declare function su:solve($s as element(cell)*) as element(cell)* {
(:  solve a sudoku problem  - $s is  a sequence of cells with values :)
   let $cell:= su:best-cell($s)
   return
      if (empty($cell) )
      then $s  (: solved :)
      else if ( $cell/@n=0)  (: infeasible :)
      then ()
      else if ($cell/@n = 1)  (: forced move :)
      then su:solve(($s,$cell))
      else   (: multiple possible, so do depth-first search  :)
         su:search-for-solution($s, $cell, tokenize($cell, ' ' ))
};

Execution

With a few problems from the Times book of Sudoku problems:

Discussion

This code requires eXist 1.3 or above to run.