Ипак, склепао сам некакав програмчић а ових дана га пречистио и проверио. Програм следи у целини.
Програм је развијан и тестиран коришћењем "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)))))
