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