Archive for the ‘sudoku’ Tag

newLISP で GUI する。。。数独入力スクリプト

 先日の数独解法スクリプトは、如何だったでしょうか?
 さて今回は、予告通り(笑)GUI による数独の入力スクリプトです。

; utility
(define *newlispDir* (env "NEWLISPDIR"))
(load (append *newlispDir* "/guiserver.lsp")) 

; initialization
(gs:init)
(define *size* 40)
(define *sudoku* (explode (dup 0 81) 9))
(define *temporary* (explode (dup 0 81) 9))
(setq X-pos 0 Y-pos 0)
(define *fileName* (real-path))
(define *filemask* "sdk SDK")
(define *description* "sudoku file")

; define sub-routine
(define (sudoku1pass nums)
  (let (res)
  (for (i 0 8)
    (let (row)
    (for (j 0 8)
      (let (n (nums i j))
       (if (> n 0) (push (list n) row -1)
         (letn (can (difference '(1 2 3 4 5 6 7 8 9) (nums i))
                can (difference can (map (curry nth j) nums))
                can (difference can (flat (map (curry (* (/ j 3) 3) 3) ((* (/ i 3) 3) 3 nums)))))
           (if (= (length can) 1) (setf (nums i j) (can 0)))
           (push can row -1)))))
    (let (tmp (ref-all 1 (count '(0 1 2 3 4 5 6 7 8 9) (apply append row))))
      (if tmp (dolist (k (apply append tmp)) (setf (nums i ((ref k row) 0)) k))))
    (push row res -1)))
    (for (j 0 8)
      (letn (col (map (curry nth j) res)
             tmp (ref-all 1 (count '(0 1 2 3 4 5 6 7 8 9) (apply append col))))
      (if tmp (dolist (k (apply append tmp)) (setf (nums ((ref k col) 0) j) k)))))
  (list nums res)))

; define handler
(define (item-action id)
  (set-number X-pos Y-pos (int (id -1))))
(define (mouse-pressed-action x y button modifiers tags)
  (when (= button 3)
    (let (lst (sudoku1pass *temporary*))
      (for (i 1 9) (gs:disable (sym (string i))))
      (if (> ((lst 0) Y-pos X-pos) 0) (gs:enable (sym  ((lst 0) Y-pos X-pos)))
      (dolist (i (map string ((lst -1) Y-pos X-pos)))
        (gs:enable (sym i))))
      (gs:show-popup 'numlist 'Sudoku x y))))
(define (move-cell x y)
  (if x (setq X-pos x))
  (if y (setq Y-pos y))
  (gs:delete-tag 'R) (gs:set-stroke 3.0) 
  (gs:draw-rect 'R (+ (* X-pos *size*) 2) (+ (* Y-pos *size*) 2) (- *size* 4) (- *size* 4) gs:lightGray)
  (gs:update))
(define (mouse-clicked-action x y button cnt modifiers tags)
  (unless (find "S" tags 0)
    (move-cell (/ x *size*) (/ y *size*))))
(define (mouse-moved-action x y)
  (let (xc (/ x *size*) yc (/ y *size*))
    (gs:set-text 'SudokuFrame (string "moved row: " (+ 1 yc) " col:" (+ 1 xc)))))
(define (delete-num x y)
  (gs:delete-tag (string "T" x y))
  (gs:delete-tag (string "S" x y)))
(define (set-number x y num)
  (delete-num x y)
  (setf (*temporary* y x) num)
  (gs:draw-text (string "T" x y)
                (string num)
                (+ (* x *size*) (/ *size* 4))
                (- (* (+ 1 y) *size*) (/ *size* 8)))
  (gs:update))
(define (set-sudoku x y num)
  (delete-num x y)
  (setf (*sudoku* y x) num)
  (gs:draw-text (string "S" x y)
                (string num)
                (+ (* x *size*) (/ *size* 4))
                (- (* (+ 1 y) *size*) (/ *size* 8))
                gs:blue)
  (gs:update))
(define (move x y)
  (do-until (= 0 (*sudoku* Y-pos X-pos))
    (if (= x "up") (++ X-pos)
        (= y "up") (++ Y-pos)
        (= x "down") (-- X-pos)
        (= y "down") (-- Y-pos))
    (if (< X-pos 0) (setq X-pos 8)
        (< 8 X-pos) (setq X-pos 0))
    (if (< Y-pos 0) (setq Y-pos 8)
        (< 8 Y-pos) (setq Y-pos 0))  )
  (move-cell))
(define (key-action id type code modifiers)
  (when (= type "released")
  (case code 
    ( 8 (move "down" nil)); bs
    (37 (move "down" nil)); left
    (38 (move nil "down")); up
    (39 (move "up" nil)); right
    (40 (move nil "up")); downt
    (127 (gs:delete-tag (string "T" X-pos Y-pos))
         (setf (*temporary* Y-pos X-pos) 0)); del
    (true (let (key (& code 0xF))
            (when (and (> key 0) (> 10 key)
                  (find key (((sudoku1pass *temporary*) -1) Y-pos X-pos)))
              (set-number X-pos Y-pos key)))))))
(define (draw-sudoku)
  (for (r 0 8) (for (c 0 8)
    (let (s (*sudoku* r c)
          t (*temporary* r c))
      (if (> s 0) (set-sudoku c r s)
          (> t 0) (set-number c r t))))))
(define (open-action id op file)
  (when file
    (setq *fileName* (base64-dec file))
    (unless (directory? *fileName*)
      (load *fileName*)
      (for (r 0 8) (for (c 0 8)
        (let (s (*sudoku* r c)
              t (*temporary* r c))
          (if (> s 0) (set-sudoku c r s)
              (> t 0) (set-number c r t)
              (delete-num c r)))))
      (let (it (ref 0 *sudoku*)) (if it (apply move-cell (reverse it)))))))
(define (open-file-dialog)
  (gs:open-file-dialog 'SudokuFrame 'open-action *fileName* *filemask* *description*))
(define (save-action id op file)
  (when file
    (setq *fileName* (base64-dec file))
    (unless (directory? *fileName*)
      (save *fileName* '*sudoku* '*temporary*))))
(define (save-file-dialog)
  (if (directory? *fileName*)
      (gs:save-file-dialog 'SudokuFrame 'save-action *fileName* "" *filemask* *description*)
    (gs:save-file-dialog 'SudokuFrame 'save-action *fileName* *fileName* *filemask* *description*)))
(define (fix-action id)
  (when (ref 0 *temporary*)
    (setq *sudoku* *temporary*)
    (draw-sudoku)))
(define (release-action id)
  (setq *sudoku* (explode (dup 0 81) 9))
  (draw-sudoku))

; making frame & canvas
(gs:frame 'SudokuFrame 100 100 400 400 "Sudoku")
(gs:canvas 'Sudoku 'SudokuFrame)
(gs:add-to 'SudokuFrame 'Sudoku)
(gs:set-background 'Sudoku gs:white)
(gs:mouse-pressed 'Sudoku 'mouse-pressed-action true)
(gs:mouse-clicked 'Sudoku 'mouse-clicked-action true)
(gs:mouse-moved 'Sudoku 'mouse-moved-action)
(gs:key-event 'Sudoku 'key-action)
(gs:menu-popup 'numlist "Candidate")
(for (i 1 9)
  (let (n (string i)) 
    (gs:menu-item (sym n) 'item-action (string i))
    (gs:add-to 'numlist (sym n))))
(gs:menu 'File "Tools")
(gs:menu-item 'Load 'open-file-dialog "load")
(gs:menu-item 'Save 'save-file-dialog "save")
(gs:menu-item 'Fix 'fix-action "fix")
(gs:menu-item 'Release 'release-action "release")
(gs:add-to 'File 'Load 'Save)
(gs:add-separator 'File)
(gs:add-to 'File 'Fix 'Release)
(gs:menu-bar 'SudokuFrame 'File)
(gs:set-anti-aliasing true)
(gs:set-font'Sudoku "Monospaced" (- *size* 1) "bold")
(gs:set-stroke 2.0)
(for (r 1 9)
  (if (= 0 (mod r 3)) (gs:set-stroke 3.0) (gs:set-stroke 1.0))
  (gs:draw-line 'L (* r *size*) 0 (* r *size*) (* 9 *size*) gs:black)
  (gs:draw-line 'L 0 (* r *size*) (* 9 *size*) (* r *size*) gs:black))
(gs:set-visible 'SudokuFrame true)
(let (size (gs:get-bounds 'Sudoku))
  (gs:set-size 'SudokuFrame (- 400 (- (size 2) (* 9 *size*))) (- 400 (- (size 3) (* 9 *size*))))
  (gs:update))
(move-cell)

; main routine
(while (gs:check-event 10000) (gs:request-focus 'Sudoku))

(exit)

 実行すれは、右図のような数独のマスが現れます。後は、数字を入力するだけ、数字を変更するには、del キーで空きマスにしてから再度入力して下さい。空きマスの入力には、右クリックで出てくる入力可能な数字からも可能です。
 数独を入力し終わったら、メニュー Tools から、fix を選択すると、数字が青に変わり、変更できなくなります。解除するには、同じ Tools から、release を選択します。数字の青を変えたいときは、スクリプト中の gs:blue を適当な値に変更して下さい。(例えば、gs:cyan gs:darkGray gs:gray gs:green gs:lightGray gs:magenta gs:orange gs:pink gs:red gs:yellow 等)
 Tools の残りは、loadsave ですから、説明するまでもありませんね(笑)。
 下図のように、数独を解いている途中の状態も保存できます。

 ここまでできれば、後は数独出題スクリプト? なんてね(笑)。

 以上、如何でしょうか?

広告

newLISP で数独を解いてみる。

 超難解な数独があります。

解けたら天才! フィンランドの数学者が作った「世界一難しい数独」

 フィンランドの数学者Arto Inkala氏が作成に3ヶ月を要したというもの。
 タイトル通り、全然歯が立ちませんでした(汗)。
 ということで、newLISP で解くことに(笑)。
 手始めに、空いているマスの数字の候補を調べるスクリプト。

(define (sudoku1pass nums)
  (let (res)
  (for (i 0 8)
    (let (row)
    (for (j 0 8)
      (let (n (nums i j))
       (if (> n 0) (push (list n) row -1)
         (letn (can (difference '(1 2 3 4 5 6 7 8 9) (nums i))
                can (difference can (map (curry nth j) nums))
                can (difference can (flat (map (curry (* (/ j 3) 3) 3) ((* (/ i 3) 3) 3 nums)))))
           (if (= (length can) 1) (setf (nums i j) (can 0)))
           (push can row -1)
         )
    )))
    (let (tmp (ref-all 1 (count '(0 1 2 3 4 5 6 7 8 9) (apply append row))))
      (if tmp (dolist (k (apply append tmp)) (setf (nums i ((ref k row) 0)) k))))
    (push row res -1)))
    (for (j 0 8)
      (letn (col (map (curry nth j) res)
             tmp (ref-all 1 (count '(0 1 2 3 4 5 6 7 8 9) (apply append col))))
      (if tmp (dolist (k (apply append tmp)) (setf (nums ((ref k col) 0) j) k)))))
  (list nums res)))

 数独自体は、空いているマスを 0 で埋めて、9 行 9 列のリスト testx にします。
 実行してみると、

> (sudoku1pass testz)
(((0 0 5 3 0 0 0 0 0) 
  (8 0 0 0 5 0 0 2 0) 
  (0 7 0 0 1 0 5 0 0) 
  (4 0 0 0 0 5 3 0 0) 
  (0 1 0 0 7 3 0 0 6) 
  (0 0 3 2 0 0 0 8 0) 
  (0 6 0 5 0 0 0 0 9) 
  (0 0 4 0 0 0 0 3 0) 
  (0 0 0 0 0 9 7 0 0)) 
 (((1 2 6 9) (2 4 9) (5) (3) (2 4 6 8 9) (2 4 6 7 8) (1 4 6 8 9) (1 4 6 7 9) (1 4 7 8)) 
  ((8) (3 4 9) (1 6 9) (4 6 7 9) (4 5 6 9) (4 6 7) (1 4 6 9) (2) (1 3 4 7)) 
  ((2 3 6 9) (7) (2 6 9) (4 6 8 9) (1) (2 4 6 8) (5) (4 6 9) (3 4 8)) 
  ((4) (2 8 9) (2 6 7 8 9) (1 6 8 9) (6 8 9) (5) (3) (1 7 9) (1 2 7)) 
  ((2 5 9) (1) (2 8 9) (4 8 9) (7) (3 4 8) (2 4 9) (4 5 9) (6)) 
  ((5 6 7 9) (5 9) (3) (2) (4 6 9) (1 4 6) (1 4 9) (8) (1 4 5 7)) 
  ((1 2 3 7) (6) (1 2 7 8) (5) (2 3 4 8) (1 2 4 7 8) (1 2 4 8) (1 4) (9)) 
  ((1 2 5 7 9) (2 5 8 9) (4) (1 6 7 8) (2 6 8) (1 2 6 7 8) (1 2 6 8) (3) (1 2 5 8)) 
  ((1 2 3 5) (2 3 5 8) (1 2 8) (1 4 6 8) (2 3 4 6 8) (9) (7) (1 4 5 6) (1 2 4 5 8))))
> 

 こんな感じ。返り値リストの第一項が数独リスト、二項目が数字の候補リストです。
(戻り値は、見やすいように改行を入れてあります。)
 これだけでは、簡単見つかる 3 と 5 しか埋まりません(汗)。
 簡単な数独であれば、何回か繰り返すと解答が出るはずですが、

(define (sudoku-loop lst (cnt 0))
  (let (old lst)
    (setq lst (sudoku1pass lst))
    (if (= (lst 0) old) 
        (begin (println cnt) (if (ref 0 (lst 0)) lst (list (lst 0)) ))
      (sudoku-loop (lst 0) (++ cnt)))))

 試してみると、

> (sudoku-loop testz)
1
(((0 0 5 3 0 0 0 0 0) 
  (8 0 0 0 5 0 0 2 0) 
  (0 7 0 0 1 0 5 0 0) 
  (4 0 0 0 0 5 3 0 0) 
  (0 1 0 0 7 3 0 0 6) 
  (0 0 3 2 0 0 0 8 0) 
  (0 6 0 5 0 0 0 0 9) 
  (0 0 4 0 0 0 0 3 0) 
  (0 0 0 0 0 9 7 0 0)) 
 (((1 2 6 9) (2 4 9) (5) (3) (2 4 6 8 9) (2 4 6 7 8) (1 4 6 8 9) (1 4 6 7 9) (1 4 7 8)) 
  ((8) (3 4 9) (1 6 9) (4 6 7 9) (5) (4 6 7) (1 4 6 9) (2) (1 3 4 7)) 
  ((2 3 6 9) (7) (2 6 9) (4 6 8 9) (1) (2 4 6 8) (5) (4 6 9) (3 4 8)) 
  ((4) (2 8 9) (2 6 7 8 9) (1 6 8 9) (6 8 9) (5) (3) (1 7 9) (1 2 7)) 
  ((2 5 9) (1) (2 8 9) (4 8 9) (7) (3) (2 4 9) (4 5 9) (6)) 
  ((5 6 7 9) (5 9) (3) (2) (4 6 9) (1 4 6) (1 4 9) (8) (1 4 5 7)) 
  ((1 2 3 7) (6) (1 2 7 8) (5) (2 3 4 8) (1 2 4 7 8) (1 2 4 8) (1 4) (9)) 
  ((1 2 5 7 9) (2 5 8 9) (4) (1 6 7 8) (2 6 8) (1 2 6 7 8) (1 2 6 8) (3) (1 2 5 8)) 
  ((1 2 3 5) (2 3 5 8) (1 2 8) (1 4 6 8) (2 3 4 6 8) (9) (7) (1 4 5 6) (1 2 4 5 8))))
> 

 最初に出力されている 1 は、sudoku1pass を実行した回数 – 1 です。
 見ての通り、この超難解問題には、まったく歯が立ちません。
 そこで(?)、力技で解きます(笑)。

(define (sudoku-solve lst)
  (let (org lst
        ans (sudoku-loop lst 0))
    (if (= 2 (length ans))
      (letn (options (ans 1)
             tmp (ans 0)
             pos (ref nil options (fn (x y) (and (list? y) (> 9 (length y)) (> (length y) 1)))))
        (if pos
            (do-until (or (= 1 (length ans)) (not (options pos)))
              (setf (tmp pos) ((options pos) 0))
              (setf (options pos) (rest (options pos)))
              (setq ans (sudoku-solve tmp 0))))))
    ans))

 要するに、候補の数字を片っ端から入れて試すというスクリプト(汗)。
 試してみると、

> (sudoku-solve testz)
1
0
11
0
0
0
4
1
1
5
4
4
5
(ここから解答が出力されますが、削除してあります)
 :
> 

 解けました、、、当たり前か(笑)。
 数独の中には、解答が一つ以上のものがあります。この sudoku-solve は解けたところで終わりますが、ちょっとした変更で、全ての候補を試して、全ての解答を出すことができます。はたして、この超難解問題の解答は、1 つでした。つまり、解法が必ずあるということ、、、その内、sudoku1pass を改良しよっと(汗)。
 入力のチェックを入れれば、

(define (sudoku lst)
  (let (res (and (list? lst)
                 (let (len (length lst))
                   (cond ((and (= len 9) (for-all (fn (x) (= x 9)) (map length lst)))
                          (sudoku-solve lst))
                         ((= len 81)(sudoku-solve (explode lst 9)))
                         (true (println lst " is wrong list. Please 9 x 9 matrix.") nil)))))
    (if (= (length res) 1) 
        (res 0)
      (println "Soory, I can't solve. Please check input list:\n" lst nil))))

 数独解法スクリプト sudoku の完成です(笑)。
 その内、GUI の入力スクリプトでも書くことにしましょう。

 以上、如何でしょうか?