# Gauche:javacube解析

Gauche:javacube解析

### javacube解析

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

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

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

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

(call-with-input-file file
(lambda (in)
(define (chars)
(ret '()))
(cond ((eof-object? ch) (reverse ret))
((char-set-contains? #[#.RGBY] ch)
(lp (read-char in) (cons ch 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)))
(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)
(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)
```

### 実行結果

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

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

#### q0.cube

こちらはすぐに出る。

```cut-sea@nkisi> ./cube.scm quest/q0.cube
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)
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)

:
:
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)
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)
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)
:
:
```
• えんどう2006/08/09 23:10:09 PDTそこで遺伝的アルゴリズムですよ
• 判定する関数は想像つくんですが、遺伝子をどう表現するかが想像つきません。cut-sea:2006/08/13 19:54:43 PDT