チョコレートパズルを継続渡しで
以前に作ったチョコレートパズルを継続渡しで解くプログラムを見つけた。せっかくなので載っけとく。継続を使ったサンプルプログラムって結構数が少なかったりする(と思う)ので、まぁ誰かの参考になれば嬉しい限り。
チョコレートパズルについて詳しくは各自で。大雑把には、6×10の長方形の枠に12個の異なる形のペントミノを隙間なく敷き詰めるパズル。他にも、6×11にヘキソミノを詰めるのとかいろんなバリエーションがあるらしい。
解答の描画にはGauche-rfbを使ってるので、試す場合はそちらを先にインストールすること。
使い方は、
gosh> (init) #gosh> (choco) # gosh>
として、ブラウザでhttp://localhost:8080/を見るなりすれば解答が表示される。この状態で、*choco*に次の解答を求める継続が束縛されているので、
gosh> (*cont*) #gosh>
と呼び出せば、表示が次のものに変わる。同様に*cont*をcallしていけば、どんどん次の解答を表示することができる。解答は全部で2339個あるようなので、暇な方はお試しあれ。
以下ソース。イカソース。
;; -*- coding: utf-8; mode: scheme -*- (use srfi-1) (use util.match) (use rfb) (define x-of car) (define y-of cdr) (define coord cons) (define x&y identity) (define (x&-y c) (coord (x-of c) (- (y-of c)))) (define (-x&y c) (coord (- (x-of c)) (y-of c))) (define (-x&-y c) (coord (- (x-of c)) (- (y-of c)))) (define (y&x c) (coord (y-of c) (x-of c))) (define (y&-x c) (coord (y-of c) (- (x-of c)))) (define (-y&x c) (coord (- (y-of c)) (x-of c))) (define (-y&-x c) (coord (- (y-of c)) (- (x-of c)))) (define (coord-< c1 c2) (or (< (y-of c1) (y-of c2)) (and (= (y-of c1) (y-of c2)) (< (x-of c1) (x-of c2))))) (define (min-coord cs) (fold (lambda (c so-far) (if (coord-< c so-far) c so-far)) (car cs) (cdr cs))) (define (x-sum&y-sum c1 c2) (values (+ (x-of c1) (x-of c2)) (+ (y-of c1) (y-of c2)))) (define (coord-+ c1 c2) (receive (x y) (x-sum&y-sum c1 c2) (coord x y))) (define (transform origin piece) (map (cut coord-+ (-x&-y origin) <>) piece)) (define (normalize piece) (sort (transform (min-coord piece) piece) coord-<)) (define (derivatives piece) (delete-duplicates (map (lambda (f) (normalize (map f piece))) (list x&y x&-y -x&y -x&-y y&x y&-x -y&x -y&-x)))) (define-constant *pento-pieces* (map derivatives '(((0 . 0) (0 . 1) (0 . 2) (1 . 2) (2 . 2)) ((0 . 0) (1 . 0) (2 . 0) (3 . 0) (4 . 0)) ((0 . 0) (0 . 1) (1 . 1) (2 . 1) (3 . 1)) ((0 . 0) (0 . 1) (1 . 1) (2 . 1) (1 . 2)) ((0 . 0) (0 . 1) (1 . 1) (2 . 1) (2 . 2)) ((0 . 0) (0 . 1) (0 . 2) (1 . 1) (2 . 1)) ((0 . 0) (1 . 0) (1 . 1) (2 . 0) (3 . 0)) ((0 . 0) (1 . 0) (1 . 1) (0 . 1) (1 . 2)) ((0 . 0) (0 . 1) (0 . 2) (1 . 2) (1 . 3)) ((0 . 0) (0 . 1) (0 . 2) (1 . 0) (1 . 2)) ((0 . 0) (1 . 0) (0 . 1) (-1 . 1) (-1 . 2)) ((0 . 0) (0 . 1) (1 . 1) (-1 . 1) (0 . 2))))) (define (paint-square origin offset color) (receive (x y) (x-sum&y-sum origin offset) (rfb-box (+ (* 50 x) 5) (+ (* 50 y) 5) (+ (* 50 x) 55) (+ (* 50 y) 55) color :filled? #t))) (define (paint-piece position piece color) (for-each (cut paint-square position <> color) piece)) (define-constant *chocomap-width* 6) (define-constant *chocomap-height* 10) (define (make-chocomap) (define (rec start num) (if (= num 0) '() (let* ([n (quotient num 2)] [mid (+ start n)]) (list (cons mid #f) (rec start n) (rec (+ mid 1) (- num n 1)))))) (rec 0 (* *chocomap-width* *chocomap-height*))) (define (coord->index x y) (+ (* y *chocomap-width*) x)) (define (chocomap-get chocomap x y) (define (rec chocomap v) (let ([key (caar chocomap)] [val (cdar chocomap)]) (cond [(< v key) (rec (cadr chocomap) v)] [(> v key) (rec (caddr chocomap) v)] [else val]))) (rec chocomap (coord->index x y))) (define (chocomap-set chocomap x y) (define (rec chocomap v) (match-let1 ((key . val) left right) chocomap (cond [(< v key) (list (cons key val) (rec left v) right)] [(> v key) (list (cons key val) left (rec right v))] [else (list (cons key #t) left right)]))) (rec chocomap (coord->index x y))) (define (valid-area? x y) (and (< -1 x *chocomap-width*) (< -1 y *chocomap-height*))) (define (paint-pieces pieces) (let ([colors '(white blue skyblue darkgreen green greenyellow yellow brown orange red pink violet)]) (let loop ([pieces pieces] [position '(0 . 0)] [chocomap (make-chocomap)] [colors colors]) (unless (null? pieces) (paint-piece position (car pieces) (car colors)) (let1 chocomap (next-chocomap chocomap position (car pieces)) (loop (cdr pieces) (first-empty-coord chocomap (car position) (cdr position)) chocomap (cdr colors))))))) (define (fail? chocomap position piece) (define (wall-or-nonempty? c) (receive (x y) (x-sum&y-sum position c) (or (not (valid-area? x y)) (chocomap-get chocomap x y)))) (any wall-or-nonempty? piece)) (define (next-chocomap chocomap position piece) (if (null? piece) chocomap (receive (x y) (x-sum&y-sum position (car piece)) (if (valid-area? x y) (chocomap-set (next-chocomap chocomap position (cdr piece)) x y) (next-chocomap chocomap position (cdr piece)))))) (define (first-empty-coord chocomap x y) (let1 next (+ x 1) (cond [(= next *chocomap-width*) (first-empty-coord chocomap -1 (+ y 1))] [(not (valid-area? next y)) #f] [(not (chocomap-get chocomap next y)) (coord next y)] [else (first-empty-coord chocomap next y)]))) (define (%choco cmap pos rest path succeed fail) (define (rec checked unchecked) (define (try pieces) (cond [(null? pieces) (rec (cons (car unchecked) checked) (cdr unchecked))] [(fail? cmap pos (car pieces)) (try (cdr pieces))] [else (let* ([cmap (next-chocomap cmap pos (car pieces))] [new-pos (first-empty-coord cmap (x-of pos) (y-of pos))] [next (lambda () (try (cdr pieces)))]) (if new-pos (%choco cmap new-pos (append checked (cdr unchecked)) (cons (car pieces) path) succeed next) (succeed (reverse (cons (car pieces) path)) next)))])) (if (null? unchecked) (fail) (try (car unchecked)))) (rec '() rest)) (define *cont* #f) (define (choco) (%choco (make-chocomap) '(0 . 0) *pento-pieces* '() (lambda (ans cont) (set! *cont* cont) (rfb-clear 'black) (paint-pieces ans)) (lambda () "no more alternatives."))) (define (init) (rfb-init (+ (* 50 *chocomap-width*) 10) (+ (* 50 *chocomap-height*) 10) :port 8080))
