Gauche:javacube解析

Gauche:javacube解析

javacube解析

javacubeにある問題を解くプログラムを書いてみた。

cube.scm(最初のバージョン)

just100行です。 問題に含まれるtrivialな切り捨てを入れました。

":"; exec gosh -b $0 "$@"
(use srfi-1)

(define (read-quest file)
  (call-with-input-file file
    (lambda (in)
      (define (chars)
        (let lp ((ch (read-char in))
                 (ret '()))
          (cond ((eof-object? ch) (reverse ret))
                ((char-set-contains? #[#.RGBY] ch)
                 (lp (read-char in) (cons ch ret)))
                (else (lp (read-char in) ret)))))

      (define (comb col row dep)
        (append-map (lambda (d)
                      (append-map (lambda (r)
                                    (map (lambda (c)
                                           (list c r d))
                                         (iota col)))
                                  (iota row)))
                    (iota dep)))
      (let ((col (read in))
            (row (read in))
            (dep (read in))
            (hint (read in)))
        (let1 quest (filter (lambda (v)
                              (char-set-contains? #[#RGBY] (last v)))
                            (zip (comb col row dep) (chars)))
          (list quest hint))))))

(define (color point) (last point))
(define (position point) (car point))
(define (same-color? p0 p1)
  (char=? (color p0) (color p1)))
(define (vect p0 p1)
  (map - (position p0) (position p1)))
(define (side-of p0 v)
  (map + p0 v))
(define (online? vect)
  (let1 vs (map abs (filter (compose not zero?) vect))
    (cond ((<= 0 (length vs) 1) #t)
          (else (apply = vs)))))
(define (unit vect)
  (let1 c (apply gcd vect)
    (map (lambda (v) (/ v c)) vect)))
(define (banishable? p0 p1 quest)
  (define (connect? p0 p1 uv)
    (let1 side (side-of p0 uv)
      (or (equal? side p1)
          (and (assoc side quest)
               (connect? side p1 uv)))))
  (let1 v (vect p1 p0)
    (and (same-color? p0 p1)
         (online? v)
         (connect? (position p0) (position p1) (unit v)))))
(define (banish p0 p1 quest)
  (define (banish-sub p0 p1 uv quest)
    (cond ((equal? p0 p1) quest)
          (else
           (banish-sub (side-of p0 uv) p1 uv
                       (remove (lambda (p)
                                 (equal? (position p) p0))
                               quest)))))
  (let ((uv (unit (vect p1 p0)))
        (p0 (position p0))
        (p1 (position p1)))
    (banish-sub p0 p1 uv quest)))
(define (search p0 q)
  (filter (lambda (p)
            (banishable? p0 p q))
          q))

(define (sequence-write seq)
  (print "ANALYSIS ANSWER!")
  (for-each (lambda (s)
              (let ((p0 (car s))
                    (p1 (cdr s)))
                (format #t "~a: ~a => ~a: ~a~%"
                        (color p0) (position p0) (color p1) (position p1))))
            seq))

(define (analysis quest hint)
  (define (analy p0 q seq)
    (let1 cs (search p0 q)
      (cond ((<= 0 (length q) 1) (sequence-write (reverse seq)))
            ((or (null? cs) (>= (length seq) hint)) '())
            (else
             (map (lambda (p1)
                    (let1 new-q (banish p0 p1 q)
                      (append-map (lambda (p2)
                                    (analy p2 new-q (cons (cons p0 p1) seq)))
                                  new-q)))
                  cs)))))
  (append-map (lambda (p)
                (analy p quest '()))
              quest))

(define (main args)
  (apply analysis (read-quest (cadr args))))

実行結果

cube.scmに問題ファイルを食わせれば、再帰的に探索を行い、 1個のcubeになるところまでの手順を印字する。 全解を探索するので、順不同的なものがごっそり。

しかし、ここまでやって、重大な問題が。。。 ロジックは単純で、あまり考えてないため簡単にはなったが、 q1以降のサンプルにすらとても現実的な速度で回答が出せない。
cubeの数が増えたら爆発的に探索範囲が広がるからなぁ。

誰か効率改善してやってくれ。 ちなみに効率の改善はちゃんとゲームをやって刈り取りが出来るケースを実装してやるってことだね。

q0.cube

こちらはすぐに出る。

cut-sea@nkisi> ./cube.scm quest/q0.cube
ANALYSIS ANSWER!
R: (0 4 0) => R: (4 4 4)
R: (0 0 4) => R: (4 0 4)
G: (0 2 4) => G: (4 2 4)
R: (4 0 4) => R: (4 4 4)
ANALYSIS ANSWER!
R: (0 4 0) => R: (4 4 4)
R: (0 0 4) => R: (4 0 4)
G: (0 2 4) => G: (4 2 4)
R: (4 4 4) => R: (4 0 4)

      :
      :
ANALYSIS ANSWER!
G: (0 2 4) => G: (4 2 4)
R: (0 0 4) => R: (4 0 4)
R: (4 0 4) => R: (4 4 4)
R: (0 4 0) => R: (4 4 4)
ANALYSIS ANSWER!
G: (0 2 4) => G: (4 2 4)
R: (0 0 4) => R: (4 0 4)
R: (4 0 4) => R: (4 4 4)
R: (4 4 4) => R: (0 4 0)
cut-sea@nkisi>

q1.cube

q1が答を出しはじめた。時間がかかる。

ANALYSIS ANSWER!
B: (0 1 1) => B: (3 1 1)
G: (4 1 1) => G: (5 1 2)
R: (5 1 1) => R: (4 2 2)
B: (0 2 2) => B: (3 2 2)
B: (3 2 2) => B: (3 1 1)
R: (2 0 0) => R: (4 2 2)
G: (3 3 2) => G: (5 1 2)
Y: (5 0 2) => Y: (5 3 2)
ANALYSIS ANSWER!
B: (0 1 1) => B: (3 1 1)
G: (4 1 1) => G: (5 1 2)
R: (5 1 1) => R: (4 2 2)
B: (0 2 2) => B: (3 2 2)
B: (3 2 2) => B: (3 1 1)
R: (2 0 0) => R: (4 2 2)
G: (3 3 2) => G: (5 1 2)
Y: (5 3 2) => Y: (5 0 2)
     :
     :

Last modified : 2012/02/23 03:39:18 UTC