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)
:
: