baroque.scm

;;;
;;; http://d.hatena.ne.jp/ayato0211/20130221/1361438221
;;;
;; =========
;; quotation
;; =========
(define (ok? ls)
  (let ((model-1 (list-ref ls 0))
        (model-2 (list-ref ls 1))
        (model-3 (list-ref ls 2))
        (model-4 (list-ref ls 3)))
    (and (= model-1 2)
         (= model-2 3)
         (= model-3 0)
         (= model-4 1))))

(define (next x)
  (let ((next-x (+ x 1)))
    (if (= next-x 4) 0
        next-x)))
;; =========


(use srfi-1 :only (append-map))
(use gauche.sequence :only (map-with-index))

(define (comb-with-list . lists)
  (if (null? lists) '()
  (let loop ([comb '(())] [lists (reverse lists)])
    (if (null? lists) comb
    (loop (append-map (^i (map (^j (cons i j)) comb)) (car lists))
          (cdr lists))))))

(define (名状しがたいマップ proc . lists)
  (map (pa$ apply proc) (apply comb-with-list lists)))

(define (apply-without-index fn lst n)
  (map-with-index (^[i e] (if (= i n) e (fn e))) lst))


#| field status
 零 | 0 | 一
 3  |   | 1
 三 | 2 | 二
|#

(define (baroque input)
  (define (check? map-info)
    (ok? (cadr map-info)))
  (define (rotate status pos)
    (apply-without-index next status pos))
  (define (reflush pos map-info)
    (let ([history (car map-info)] [status (cadr map-info)])
      (list (cons pos history) (rotate status pos))))
  (let loop ([map-infoes `((() ,input))])
    (cond [(find check? map-infoes) => ($ reverse $ car $)]
          [else (loop (名状しがたいマップ reflush (iota 4) map-infoes))])))