油分け算
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)))
長い。
せめて探索そのものは切り出すべきか。