油分け算

前の記事の続き

LispUser.netを参考に、見るからに冗長だったところを直した。

#!/usr/bin/env gosh
;; -*- coding: utf-8 mode: scheme -*-

(use util.queue)
(use util.match)
(use util.combinations)
(use srfi-1)


;; node
(define (make-node state parent index)
  (list state parent index))

(define (get-state x) (first x))
(define (get-parent node) (second node))
(define (get-index node) (third node))

;; utility
(define (make-cache)
  (make-hash-table 'equal?))

(define (appears-again? cache state)
  (hash-table-exists? cache state))

(define (new-state? cache state)
  (not (appears-again? cache state)))

(define (cache! c state)
  (hash-table-put! c state #t))

(define (finished? state)
  (and (= (car state) (cadr state))
       (= (caddr state) 0)))

(define (move l c from to)
  (let ((f (list-ref l from))
        (t (list-ref l to))
        (ct (list-ref c to)))
    (if (and (not (= f 0)) (not (= t ct)))
      (let ((m (min f (- ct t)))
            (nl (apply list l)))
        (set! (ref nl from) (- f m))
        (set! (ref nl to) (+ t m))
        nl)
      '())))

(define (all-moves n)
  (let1 x (combinations (iota n) 2)
    (append x (map reverse x))))

(define make-states
  (let1 pairs (all-moves 3)
    (lambda (state capacity)
      (map (lambda (pair)
             (move state capacity (first pair) (second pair)))
           pairs))))

(define print-procedure
  (let1 pairs (all-moves 3)
    (lambda (node)
      (let1 parent (get-parent node)
        (unless (null? parent)
          (print-procedure parent)
          (let* ((pair (list-ref pairs (get-index node)))
                 (f (first pair))
                 (t (second pair)))
            (format #t "~a から ~a に ~d 升移す ~s~%"
                    (integer->char (+ 97 f))
                    (integer->char (+ 97 t))
                    (- (list-ref (get-state parent) f) (list-ref (get-state node) f))
                    (get-state node))))))))


;; main code
(define (oil-separate init-state capacity)
  (let ((cache (make-cache))
        (queue (make-queue)))
    (let loop ((node (make-node init-state '() '())))
      (if (finished? (get-state node))
        (print-procedure node)
        (begin
          (map (lambda (state i)
                 (if (and (not (null? state)) (new-state? cache state))
                   (begin
                     (cache! cache state)
                     (enqueue! queue (make-node state node i)))))
               (make-states (get-state node) capacity) (iota 6))
          (let1 next-node (if (queue-empty? queue) #f (dequeue! queue))
            (if next-node
              (loop next-node)
              (error "failed."))))))))

(define (main args)
  (match (cdr args)
    ((n cb cc)
     (oil-separate `(,(string->number n) 0 0) `(10 ,(string->number cb) ,(string->number cc)))
     0)
    (_
     (print "invalid argument")
     1)))

長い。

せめて探索そのものは切り出すべきか。