L-99 P97

数独を解く問題。Euler Project 問題 96 と同じです。

まず、問題をスクラッチバッファで加工して sudoku_p97.txt を作ります。
ファイルの中身はこんな感じ。未確定の部分は 0 にします。

Grid 01
004800017
670900000
508030004
300740100
069000780
001069005
100080306
000006091
240001500

コードがテキトーなので、データの末尾にタブやらスペースがあるとバグります。
注意してくださいw


次に数独を解くプログラムです。

(use util.list)

(define nil '())

(define (list->number lis)
  (fold (lambda (a b) (+ a (* b 10))) 0 lis))

(define (digit->integer c)
  (- (char->integer c) (char->integer #\0)))

(define (number->list num)
  (map digit->integer (string->list (number->string num))))

(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

(define (filter pred items)
  (cond ((null? items) nil)
        ((pred (car items))
         (cons (car items)
               (filter pred (cdr items))))
        (else
         (filter pred (cdr items)))))

(define (element-of-set? x set)
  (cond ((null? set) #f)
        ((equal? x (car set)) #t)
        (else (element-of-set? x (cdr set)))))

(define (uniq set)
  (define (iter x s)
    (if (null? x)
        s
        (iter (cdr x)
              (if (element-of-set? (car x) s)
                  s
                  (cons (car x) s)))))
  (iter set nil))

;

(define (bins->num bin-lis)
  (define (iter lis k num)
    (if (null? lis)
        num
        (iter (cdr lis) (* k 2) (+ num (* k (car lis))))))
  (iter (reverse bin-lis) 1 0))

(define (num->bins num k)
  (define (iter n)
    (if (= n 0)
      nil
      (append (iter (quotient n 2)) (list (remainder n 2)))))
  (let ((bins (iter num)))
    (append (make-list (- k (length bins)) 0) bins)))
  

(define (overlap-num lis)
  (if (null? (cdr lis))
      #f
      (if (= (car lis) (cadr lis))
          (car lis)
          (overlap-num (cdr lis)))))

(define (find-val num lis)
  (define (iter l i vals)
    (if (null? l)
        vals
        (iter (cdr l) (+ i 1) (if (= (car l) num) (append vals `(,i)) vals))))
  (iter lis 1 nil))

(define (find-vals lis lists)
  (define (iter l i vals)
    (if (null? l)
        vals
        (iter (cdr l) (+ i 1)
              (if (and (memq (car lis) (car l))
                       (memq (cadr lis) (car l)))
                  (append vals `(,i))
                  vals))))
  (iter lists 1 nil))

(define (find-lis lis lists)
  (define (iter l i vals)
    (if (null? l)
        vals
        (iter (cdr l)
              (+ i 1)
              (if (equal? (car l) lis)
                  (append vals `(,i))
                  vals))))
  (iter lists 1 nil))
        
;;

(define (make-grids filename)
  (define ip (open-input-file filename))
  (define (read-line ip)
    (define (iter lis)
      (let ((c (read-char ip)))
        (cond ((eof-object? c) lis)
              ((eq? c #\cr) (read-char ip) lis)
              (else
               (iter (append lis (list (digit->integer c))))))))
    (iter nil))
  (define (read-grids)
    (define (iter lis c)
      (if (= c 0)
          (list lis)
          (let ((line (read-line ip)))
            (if (null? line)
                (begin
                  (close-input-port ip)
                  nil)
                (iter (append lis (list line)) (- c 1))))))
    (read-line ip)
    (iter nil 9))
  (define (iter lis)
    (if (port-closed? ip)
        lis
        (iter (append lis (read-grids)))))
  (iter nil))

(define (grid->hash grid)
  (define ht (make-hash-table 'equal?))
  (define (list->hash lis y)
    (define (iter l x)
      (if (null? l)
          'done
          (begin
            (hash-table-put! ht (list x y) (car l))
            (iter (cdr l) (+ x 1)))))
    (iter lis 1))
  (define (init-hash lis y)
    (if (null? lis)
        ht
        (begin
          (list->hash (car lis) y)
          (init-hash (cdr lis) (+ y 1)))))
  (init-hash grid 1))

(define (gen-keys-mg key)
  (define (get-keys n)
    (cond ((< n 4) '(1 2 3))
          ((< n 7) '(4 5 6))
          (else '(7 8 9))))
  (let ((xs (get-keys (car key)))
        (ys (get-keys (cadr key))))
    (define (iter x lis)
      (if (null? x)
          lis
          (iter (cdr x) (append lis (map (lambda (y) (list (car x) y)) ys)))))
    (iter xs nil)))

(define (gen-keys-row key)
  (define keys (enumerate-interval 1 9))
  (filter (lambda (k) (not (equal? k key)))
          (map (lambda (x) (list x (cadr key))) keys)))

(define (gen-keys-col key)
  (define keys (enumerate-interval 1 9))
  (filter (lambda (k) (not (equal? k key)))
          (map (lambda (y) (list (car key) y)) keys)))

(define (gen-keys-rc key)
  (define keys (enumerate-interval 1 9))
  (append (map (lambda (x) (list x (cadr key))) keys)
          (map (lambda (y) (list (car key) y)) keys)))

(define (append-keys remove-keys keys1 keys2)
  (define (iter rk keys)
    (if (null? rk)
        keys
        (iter (cdr rk) (filter (lambda (k) (not (equal? k (car rk)))) keys))))
  (iter remove-keys (append keys1 keys2)))

;;

(define (improve-vals ht val keys)
  (define (iter k)
    (if (null? k)
        'done
        (let ((v (hash-table-get ht (car k))))
          (if (pair? v)
              (let ((new-v (filter (lambda (x) (not (= x val))) v)))
;;                (print ";IMPROVE_VALS key=" (car k) " old-val=" v " new-val=" new-v)
                (if (null? (cdr new-v))
                    (begin
                      (hash-table-put! ht (car k) (car new-v))
                      (improve-vals ht (car new-v) (append-keys (list (car k)) (gen-keys-mg (car k)) (gen-keys-rc (car k)))))
                    (hash-table-put! ht (car k) new-v))))
          (iter (cdr k)))))
;;  (print "IMPROVE-VALS val=" val " keys=" keys)
  (iter keys))

(define (solve-init ht)
  (define init-val '(1 2 3 4 5 6 7 8 9))
  (define (init-proc key val)
    (if (= val 0)
        (hash-table-put! ht key init-val)
        val))
  (define (init-imp-proc key val)
    (if (not (pair? val))
        (improve-vals ht val (append-keys (list key) (gen-keys-mg key) (gen-keys-rc key)))
        val))
  (hash-table-map ht init-proc)
  (hash-table-map ht init-imp-proc)
  ht)

(define (check ht val keys)
  (define (iter k)
    (if (null? k)
        #t
        (let ((v (hash-table-get ht (car k))))
          (if (pair? v)
              (if (not (null? (filter (lambda (x) (= val x)) v)))
                  #f
                  (iter (cdr k)))
              (iter (cdr k))))))
  (iter keys))


(define (refine-val ht gen-keys-proc key val)
  (define (iter v)
    (if (null? v)
        #f
        (let ((result (check ht (car v) (gen-keys-proc key))))
          (if result
              (begin
                ;;(print ";PUT! key=" key " val=" (car v))
                (hash-table-put! ht key (car v))
                (car v))
              (iter (cdr v))))))
  ;;(print ";REFINE-VAL key=" key " val=" val)
  (iter val))

(define (refine-val-mg ht key val)
  (refine-val ht gen-keys-mg key val))

(define (refine-val-rc ht key val)
  (refine-val ht gen-keys-rc key val))

(define (refine-val-row ht key val)
  (refine-val ht gen-keys-row key val))

(define (refine-val-col ht key val)
  (refine-val ht gen-keys-col key val))

(define (solve-proc-primary ht)
  (define (proc key val)
    (if (list? val)
        (let ((v1 (refine-val-mg ht key val))
              (v2 (refine-val-row ht key val))
              (v3 (refine-val-col ht key val)))
          ;;(print ";debug key=" key " val=" val " v1=" v1 " v2=" v2 " v3=" v3)
          (and v1 (improve-vals ht v1 (append-keys (list key) (gen-keys-mg key) (gen-keys-rc key))))
          (and v2 (improve-vals ht v2 (append-keys (list key) (gen-keys-mg key) (gen-keys-rc key))))
          (and v3 (improve-vals ht v3 (append-keys (list key) (gen-keys-mg key) (gen-keys-rc key))))
          )))
  (hash-table-map ht proc)
  ht)

(define (solve-proc-simple-chain ht)
  (define (find-sc ht mg-keys)
    (define (sc keys)
      (define (one? lis) (null? (cdr lis)))
      (let ((x (uniq (map car keys)))
            (y (uniq (map cadr keys))))
        (cond ((null? keys) '(0 0))
              ((one? x) (list (car x) 0))
              ((one? y) (list 0 (car y)))
              (else '(0 0)))))
  
    (define (key-iter num keys results)
      (if (null? keys)
          results
          (let ((val (hash-table-get ht (car keys))))
            (if (pair? val)
                (let ((v (filter (lambda (v) (= v num)) val)))
                  (key-iter num
                            (cdr keys)
                            (if (null? v)
                                results
                                (cons (car keys) results))))
                (key-iter num (cdr keys) results)))))

    (define (num-iter nums)
      (if (null? nums)
          'done
          (let ((key (sc (key-iter (car nums) mg-keys nil))))
            (if (not (null? key))
                (let ((val (car nums)))
                  ;;(print "val=" val " key=" key)
                  (and (not (= 0 (cadr key))) (improve-vals ht val (append-keys mg-keys (gen-keys-row key) nil)))
                  (and (not (= 0 (car key))) (improve-vals ht val (append-keys mg-keys (gen-keys-col key) nil)))
                  (num-iter (cdr nums)))))))
    
    (num-iter (enumerate-interval 1 9)))

  (define (iter keys)
    (if (null? keys)
        ht
        (begin
          (find-sc ht (gen-keys-mg (car keys)))
          (iter (cdr keys)))))
  (iter '((1 1) (4 1) (7 1) (1 4) (4 4) (7 4) (1 7) (4 7) (7 7))))

    (define (get-keys-col org idx)
      (list (car org) (+ (cadr org) (- idx 1))))
    (define (get-keys-row org idx)
      (list (+ (car org) (- idx 1)) (cadr org)))
    (define (get-keys-mg org idx)
      (let ((r (quotient (- idx 1) 3))
            (c (remainder (- idx 1) 3)))
        (list (+ (car org) r) (+ (cadr org) c))))

    (define (make-pair-num r c)
      (cond ((= r 0) nil)
            ((= c 1) (cons (list r c) (make-pair-num (- r 1) 9)))
            ((= r c) (make-pair-num r (- c 1)))
            (else (cons (list r c) (make-pair-num r (- c 1))))))

  (define (find-naked-num vals)
    (define (iter pn vals nks)
      (if (null? pn)
          nks
          (let ((n1 (find-lis (car pn) vals)))
            (let ((n2 (find-vals (car pn) vals)))
              (if  (and (not (null? n1)) (= 2 (length n1)))
                   (iter (cdr pn) vals (cons (car pn) nks))
                   (if (and (not (null? n2)) (= 2 (length n2)))
                       (iter (cdr pn) vals (cons (car pn) nks))
                       (iter (cdr pn) vals nks)))))))
    (iter (make-pair-num 9 9)
          (map (lambda (v) (if (pair? v) v (list v))) vals)
          nil))

  (define (find-naked ht org keys get-keys-proc)
    (let ((vals (map (lambda (k) (hash-table-get ht k)) keys)))
      (find-naked-num vals)
      (let ((n (filter (lambda (k) (and (pair? k) (null? (cddr k)))) vals)))
;;        (print ";;n=" n)
        (if (null? n)
            #f
            (let ((d (overlap-num (sort (map list->number n)))))
              (if d
                  (if (null? (cddr (find-lis (number->list d) vals)))
                      (cons (car n) (map (lambda (idx) (get-keys-proc org idx)) (find-lis (car n) vals)))
                      #f)
                  #f))))))

  (define (find-naked-row ht org keys)
    (find-naked ht org keys get-keys-row))

  (define (find-naked-col ht org keys)
    (find-naked ht org keys get-keys-col))

  (define (find-naked-mg ht org keys)
    (find-naked ht org keys get-keys-mg))

(define (solve-proc-naked ht)
  (define (iter keys gen-keys-proc find-naked-proc)
    (if (null? keys)
        ht
        (let ((gk (gen-keys-proc (car keys))))
          (let ((nk (find-naked-proc ht (car keys) gk)))
            (if nk
                (let ((vals (car nk)))
                  (improve-vals ht (car vals) (append-keys (cdr nk) gk nil))
                  (improve-vals ht (cadr vals) (append-keys (cdr nk) gk nil))))
            (iter (cdr keys) gen-keys-proc find-naked-proc)))))
;;  (iter '((1 1) (4 1) (7 1) (1 4) (4 4) (7 4) (1 7) (4 7) (7 7)) gen-keys-mg find-naked-mg)
;;  (iter (cons '(1 1) (gen-keys-col '(1 1))) (lambda (k) (cons k (gen-keys-row k))) find-naked-row)
;;  (iter (cons '(1 1) (gen-keys-row '(1 1))) (lambda (k) (cons k (gen-keys-col k))) find-naked-col)
  (iter (cons '(1 1) (gen-keys-col '(1 1))) (lambda (k) (cons k (gen-keys-row k))) find-naked-row)
  )

(define (solve-proc-xy-wing ht)
  (define (xy-wing lis)
    (let ((w (filter (lambda (l) (= 2 (apply + l))) lis)))
      (cond ((null? w) #f)
            ((null? (cdr w)) #f)
            (else
             (let ((bins (map bins->num w)))
               (let ((sb (sort bins)))
                 (let ((usb (sort (uniq sb))))
                   (if (= (abs (- (length sb) (length usb))) 1)
                       (num->bins (overlap-num sb) 9)
                       #f
                       ))))))))
  (define (xy-wing-imp-vals ht n r c)
    (let ((k1 (list (car c) (car r)))
          (k2 (list (cadr c) (cadr r))))
      (let ((rk (list k1 k2 (list (car k2) (cadr k1)) (list (car k1) (cadr k2)))))
        ;;(print "n=" n " r=" r " c=" c " k1=" k1 " k2=" k2 " rk=" rk)
        (improve-vals ht n (append-keys rk (gen-keys-row k1) (gen-keys-col k1)))
        (improve-vals ht n (append-keys rk (gen-keys-row k2) (gen-keys-col k2)))
        )))
  (define (find-xy-wing ht num keys)
    (define (iter vals results)
      (if (null? vals)
          results
          (if (pair? (car vals))
              (if (null? (filter (lambda (n) (= n num)) (car vals)))
                  (iter (cdr vals) (append results '(0)))
                  (iter (cdr vals) (append results '(1))))
              (iter (cdr vals) (append results '(0))))))
    (let ((vals (map (lambda (k) (hash-table-get ht k)) keys)))
      ;;(print "num=" num " keys=" keys " vals=" vals)
      (iter vals nil)))
  (define (r-iter n nums results)
    (if (null? nums)
        results
        (let ((rk (list 1 (car nums))))
          (r-iter n
                  (cdr nums)
                  (append results
                          (list (find-xy-wing ht n (cons rk (gen-keys-row rk)))))))))
  (define (c-iter n nums results)
    (if (null? nums)
        results
        (let ((ck (list (car nums) 1)))
          (c-iter n
                  (cdr nums)
                  (append results
                          (list (find-xy-wing ht n (cons ck (gen-keys-col ck)))))))))
  (define (iter nums)
    (if (null? nums)
        ht
        (begin
          (let ((r (r-iter (car nums) (enumerate-interval 1 9) nil)))
            (let ((rw (xy-wing r)))
              (and rw (xy-wing-imp-vals ht (car nums) (find-lis rw r) (find-val 1 rw)))))
          (let ((c (c-iter (car nums) (enumerate-interval 1 9) nil)))
            (let ((cw (xy-wing c)))
              (and cw (xy-wing-imp-vals ht (car nums) (find-val 1 cw) (find-lis cw c)))))
          (iter (cdr nums)))))
  (iter (enumerate-interval 1 9)))
  
  
#;(define (prov ht)
  (define (iter2 ht key v)
    (if (null? v)
        ht
        (let ((htwk (alist->hash-table (hash-table->alist ht) 'equal?)))
          (hash-table-put! htwk key (car v))
          (solve-proc-primary htwk)
          (if (check-uniq-nums? htwk)
              htwk
              (iter2 ht key (cdr v))))))
  
  (define (iter ht alis)
    (if (null? alis)
        ht
        (let ((key (car (car alis)))
              (val (cdr (car alis))))
          (iter (if (pair? val)
                    (iter2 ht key val)
                    ht)
                (cdr alis)))))

  (iter ht (hash-table->alist ht)))

(define (solve-main ht alis)
;;  (solve-proc ht)
  (if (solve-end? ht)
      ht
      (if (equal? (hash-table->alist ht) alis)
          ht
          (let ((old-alis (hash-table->alist ht)))
            (solve-proc-primary ht)
            (solve-proc-simple-chain ht)
            (solve-proc-xy-wing ht)
            ;;(solve-proc-naked ht)
            (solve-main ht old-alis)))))

(define (transpose grid)
  (define (iter lis new-lis)
    (if (null? (car lis))
        new-lis
        (iter (map cdr lis) (append new-lis (list (map car lis))))))
  (iter grid nil))

(define (check-grid grid)
  (map (lambda (l) (equal? l '(1 2 3 4 5 6 7 8 9))) (map sort grid)))

(define (check-grid-all grid)
  (equal? (list #t)
       (uniq (append (check-grid grid) (check-grid (transpose grid))))))

(define (check-uniq-nums? ht)
  (let ((grid (hash->grid ht)))
    (let ((lis (map (lambda (lis) (filter (lambda(x) (not (pair? x))) lis)) (append grid (transpose grid)))))
      (equal? (map sort lis) (map (lambda (l) (sort (uniq l))) lis)))))

(define (solve-end? ht)
  (let ((alis (hash-table->alist ht))
        (grid (hash->grid ht)))
    (and (null? (filter pair? (map cdr alis)))
         (equal? (list #t) (uniq (append (check-grid grid) (check-grid (transpose grid))))))))

(define (hash->grid ht)
  (let ((nums (enumerate-interval 1 9)))
    (map (lambda (y)
           (map (lambda (x) (hash-table-get ht `(,x ,y)))
                nums))
         nums)))

(define (get-num ht)
  (+ (* 100 (hash-table-get ht '(1 1)))
     (* 10 (hash-table-get ht '(2 1)))
     (hash-table-get ht '(3 1))))

(define (problem-096)
  (define (iter sum grids)
    (if (null? grids)
        sum
        (let ((ans (solve (grid->hash (car grids)))))
          (print (hash->grid ans))
          (iter (+ sum (get-num ans)) (cdr grids)))))
  (iter 0 (make-grids "./sudoku.txt")))

(define (problem-096-test grid-no)
  (define grids (make-grids "./sudoku_p97.txt"))
  (define ht (grid->hash (list-ref grids (- grid-no 1))))
  (define ans (solve-proc-naked (solve-main (solve-init ht) nil)))
  (print (hash->grid ans))
  ans)

;;

;; test
;;(define h1 (problem-096-test 50))
;;(define h2 (solve-main h1 nil))
;;(define h3 (solve-proc-naked h2))
;;(hash->grid h3)
;;(define vals (map (lambda (k) (hash-table-get h3 k)) (cons '(2 1) (gen-keys-col '(2 1)))))
;;(define v (map (lambda (v) (if (pair? v) v (list v))) vals))

;;(map (lambda (x) (list x (solve-end? (solve-main (problem-096-test x) nil)))) (enumerate-interval 1 50))

コメントアウトされたデバッグ用のコードがあちこちにありますが、面倒なのでそのままです。
プログラムを書くには数独の解き方を猛勉強しなければならず、その結果プログラムが出来た時にはもはやプログラムは要らなくなってしまいますw

結果

gosh> (problem-096-test 1)
((9 3 4 8 2 5 6 1 7) (6 7 2 9 1 4 8 5 3) (5 1 8 6 3 7 9 2 4) (3 2 5 7 4 8 1 6 9) (4 6 9 1 5 3 7 8 2) (7 8 1 2 6 9 4 3 5) (1 9 7 5 8 2 3 4 6) (8 5 3 4 7 6 2 9 1) (2 4 6 3 9 1 5 7 8))
#<hash-table equal? 0x600356cd0>

ハッシュテーブルを返しますが気にしてはいけません。
出力結果を整形したもの。

((9 3 4 8 2 5 6 1 7)
 (6 7 2 9 1 4 8 5 3)
 (5 1 8 6 3 7 9 2 4)
 (3 2 5 7 4 8 1 6 9)
 (4 6 9 1 5 3 7 8 2)
 (7 8 1 2 6 9 4 3 5)
 (1 9 7 5 8 2 3 4 6)
 (8 5 3 4 7 6 2 9 1)
 (2 4 6 3 9 1 5 7 8))

このように解けました。