Решавање судоку

Прошле године су нам у посети били моји родитељи и при том сам сазнао да је мој отац постао пасионирани играч судоку. Мало сам играо и ја, врло интересантна мозгалица. Природно, дошао сам на идеју да решавање "аутоматизујем". У то време сам учио "Scheme" језик - шема ме још занима али се нема времена.

Ипак, склепао сам некакав програмчић а ових дана га пречистио и проверио. Програм следи у целини.

Програм је развијан и тестиран коришћењем "Petite Chez Scheme" http://www.scheme.com/petitechezscheme.html.

; Решавање судоку матрице.
; Функција за решавање је:
; (solve sudo azbuka)
; где је sudo низ који описује почетно
; стање судоку, а azbuka низ који дефинише
; могуће елементе. Класичан судоку ће
; у азбуци имати цифре 1 до 9.


;
; Дефиниција примера судоку проблема
; Судоку таблица се задаје као низ
; по редовима.
;
; Редови и колоне су нумерисане
; бројевима 1 до 9.
;
; Непознати елементи су задати елементом
; који није садржан у азбуци. У примеру
; који следи, елементе које сам хтео да
; прогласим непознатим сам обележио подвлаком.
;
; Резултат обележава решене елементе
; заградом (под листа). Уколико
; једнозначно решење није нађено,
; у загради ће бити изслитана могућа
; решења.
;
(define sudo '(  _1  2 _3  4  5  6 _7 _8 _9
                  4 _5  6  7 _8 _9  1  2  3
                 _7 _8 _9 _1  2  3 _4 _5  6
                  2  3 _4  5  6  7 _8 _9  1
                 _5  6  7 _8 _9  1  2  3  4
                 _8 _9  1  2  3  4  5  6  7
                 _3  4  5  6 _7 _8 _9  1  2
                 _6  7 _8 _9  1  2  3  4  5
                 _9 _1  2  3 _4  5  6 _7  8   ))


;
; Азбука.
; Азбука може бити произвољна све док задовољава
; услов да је број елемената једнак квадрату
; целобројног позитивног броја.
;       
(define azbuka '(1 2 3 4 5 6 7 8 9))

(define a2 '(0 1 2 3))
(define s2 '( ? 1 2 3
              3 2 1 ?
              1 3 0 2
              2 0 ? 1))
              


;
; Основна функција за решавање судоку.
;
(define (solve sudo azbuka)
    (solve1 sudo azbuka 0))

; 
; Помоћна функција за решавање
;
(define (solve1 sudo azbuka rc)
    (cond
   ((>= rc (* (list-len azbuka) (list-len azbuka))) sudo)
      (else
        (solve1
          (append 
            (front (reduce sudo azbuka) rc)
            (cons
              (possible (reduce sudo azbuka) azbuka (row-idx azbuka rc) (col-idx azbuka rc))
              (skip-n (reduce sudo azbuka) (1+ rc))))
          azbuka
          (1+ rc)))))



;
; Редукуј све непознате чланове на листе могућих
; решења
;
(define (reduce sudo azbuka)
 (reduce1 sudo azbuka 0))

;
; Помоћна функција.
; Редукуј све непознате чланове на листе могућих
;
(define (reduce1 sudo azbuka rc)
 (cond
  ((> (1+ rc) (* (list-len azbuka) (list-len azbuka))) '())
  (else
   (cons
    (possible sudo azbuka (row-idx azbuka rc) (col-idx azbuka rc))
    (reduce1 sudo azbuka (1+ rc))))))


;
; Помоћна функција - број елемената у 
; датој листи.
;
(define (list-len lst)
    (cond
      ((or (null? lst) (is-atom? lst)) 0)
      (else
        (1+ (list-len (cdr lst))))))
        
; 
; Помоћна функција - израчунава димензију под-судоку
; матрице.
;
(define (koren azbuka) (sqrt (list-len azbuka)))
                                                                     
;                                                                    
; Одређивање природе вредности aorl
; Враћа #f уколико дата вредност није
; атом.
;
(define is-atom? atom?)

;(define (is-atom? aorl)
;    (cond
;      ((or 
;           (list? aorl)
;           (not (number? aorl))) #f)
;      (else (atom? aorl))))

; 
; Да ли је дати елемент слово азбуке
;
(define (member? at lst)
 (cond
  ((null? lst) #f)
  (else
   (or (eq? at (car lst))
    (member? at (cdr lst))))))

;
; Да ли је дата вредност задата?
;
(define (is-given? aorl azbuka)
    (and (is-atom? aorl) (member? aorl azbuka)))

;
; Да ли је вредност решена?
;
; Решена је само онда када је представљена
; листом са тачно једним елементом који
; није 0.
;
(define (is-solved? lat azbuka)
    (cond
      ((eq? 1 (list-len lat)) #t)
      (else (is-given? lat azbuka))))

;
; Помоћна функција - број елемената у 
; датој листи.
;
(define (list-len lst)
    (cond
      ((or (null? lst) (is-atom? lst)) 0)
      (else
        (1+ (list-len (cdr lst))))))

;
; Прескочи n елемената и врати
; n-ти елемент.
;
(define (skip-n sudo n)
    (cond
      ((null? sudo) '())
      ((eq? 0 n) sudo)
      (else
        (skip-n (cdr sudo) (1- n)))))

;
; Врати листу од n елемената почев од
; датог елемента sudo
;
(define (front sudo n)
    (cond
      ((null? sudo) '())
      ((eq? 0 n) '())
      (else
        (cons (car sudo) (front (cdr sudo) (1- n))))))

;
; Издвој ред n
; 
(define (row sudo azbuka n)
    (cond
      ((null? sudo) '())
      (else
        (front (skip-n sudo (* (1- n) (list-len azbuka))) (list-len azbuka)))))

;
; Помоћна функција за издвајање колоне
;
(define (getcol sudo azbuka n)
    (cond
      ((null? sudo) '())
      ((eq? 0 n) '())
      (else
        (cons (car sudo) (getcol (skip-n sudo (list-len azbuka)) azbuka (1- n))))))

;
; Издвоји колону n
;
(define (col sudo azbuka n)
    (cond
      ((null? sudo) '())
      (else
        (getcol (skip-n sudo (1- n)) azbuka (list-len azbuka)))))
       
;
; помоћна функција - врати ред (почев од 1)
; на основу датог индекса листе која дефинише
; судоку. Индекс почиње са 0.
; 
(define (row-idx azbuka idx)
 (1+ (floor (/ idx (list-len azbuka)))))
 
;
; помоћна функција - врати колону (почев од 1)
; на основу датог индекса листе која дефинише
; судоку. Индекс почиње са 0.
; 
(define (col-idx azbuka idx)
 (1+ (- idx (* (1- (row-idx azbuka idx)) (list-len azbuka)))))

;
; Помоћна функција за издвајање "мини судоку" односно
; подматрице
;
(define (sub-sudo-row sudo azbuka r c rn koren)
 (cond 
  ((> rn koren) '())
  ((null? sudo) '())
 (else
  (append
   (front (skip-n (row sudo azbuka (+ rn (* (1- r) koren))) (* (1- c) koren)) koren)
   (sub-sudo-row sudo azbuka r c (1+ rn) koren)))))

;
; Издвој мини судоку (a пута a, где је а корен
; броја елемената у азбуци) са задате позиције.
; Позиције мини судоку су нумерисане 1 до (list-len azbuka).
;
(define (sub-sudo sudo azbuka r c)
 (sub-sudo-row sudo azbuka r c 1 (koren azbuka)))

;
; 
;
(define (extract-solved su azbuka)
    (cond
      ((null? su) '())
      ((is-solved? (car su) azbuka) 
    (cons 
  (cond
    ((list? (car su)) (caar su))
    (else
    (car su)))
    (extract-solved (cdr su) azbuka)))
      (else
        (extract-solved (cdr su) azbuka))))

;
; Разлика две судоку
;
(define (diff su lat)
    (cond
      ((null? su) '())
      ((null? lat) su)
      ((member? (car su) lat) (diff (cdr su) lat))
      (else
        (cons (car su) (diff (cdr su) lat)))))

;
; Да ли је вредност at члан низа lat?
;
(define (member? at lat)
    (cond
      ((null? lat) #f)
      ((eq? at (car lat)) #t)
      (else
        (member? at (cdr lat)))))

;
; Врати сва немогућа решења за дату позицију.
; (сви елементи азбуке који су већ дати или
; нађени у датом реду, колони и под судоку).
;
(define (allsolved sudo azbuka r c)
    (append
      (extract-solved (row sudo azbuka r) azbuka)
      (extract-solved (col sudo azbuka c) azbuka)
      (extract-solved 
  (sub-sudo 
   sudo azbuka (ceiling (/ r (koren azbuka))) (ceiling (/ c (koren azbuka))))
  azbuka)))


;
; Врати листу могућих решења за дати елемент.
; 
(define (possible sudo azbuka r c)
    (cond
      ((is-solved? (element sudo azbuka r c) azbuka)
       (element sudo azbuka r c))
      (else
        (diff azbuka (allsolved sudo azbuka r c)))))

;
; Помоћна функција. Врати дати елемент.
; Ред и колона почињу од 1
;
(define (element sudo azbuka r c)
    (car (skip-n sudo (+ (* (list-len azbuka) (1- r)) (1- c)))))