読者です 読者をやめる 読者になる 読者になる

チョコレートパズルを継続渡しで

以前に作ったチョコレートパズルを継続渡しで解くプログラムを見つけた。せっかくなので載っけとく。継続を使ったサンプルプログラムって結構数が少なかったりする(と思う)ので、まぁ誰かの参考になれば嬉しい限り。

チョコレートパズルについて詳しくは各自で。大雑把には、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))