あらためて油売り算

Scheme

斗桶 (a) に油が 1 斗 (10 升) ある。これを等分したい。7 升枡 (b) と 3 升枡 (c) しかない。この 2 つの枡だけで、5 升ずつ等分する方法を記述せよ。

この問題を解くにあたり、(a) に入っている油の容量を第 1 引数、(b) の容量を第 2 引数、(c) の容量を第 3 引数とするプログラムとせよ。

もちろん、(a), (b), (c) に条件を付けなければ解けない場合もあるが、その場合には条件としてどのようなものがふさわしいかを余力があれば考えよ。

http://karetta.jp/article/blog/ll-spirit/033840

下のコードをabura.scmとか適当な名前で保存して、 ./abura.scm 10 7 3 とやればOK。エラーチェックとかは手抜きなので変な値を渡すと動かないぽ。

一応任意の数の任意のサイズの容器に対応したつもりなので、 ./abura.scm 40 11 7 3 とかやっても動く。

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

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

;; <state> ::= (<unit> ...)
;; <unit> ::= (limit . value)
;; <search-state> ::= (<state> . <step>) = (<state> from<int> to<int>)
;; <step> ::= (from<int> to<int>)
;;
;; so, initial state is '((10 . 10) (7 . 0) (3 . 0))
;; and search state '(((10 . 10) (7 . 0) (3 . 0)) . (0 . 1)) means
;;     next state is '((10 . 3) (7 . 7) (3 . 0))

(define (main args)
  (pretty-print-result (apply search-abura (map x->integer args)))
  0)

(define nil ())

(define (value unit)
  (cdr unit))

(define (limit unit)
  (car unit))

;;; if unit is (10 . 3)
;;; then room is 7
(define (room unit)
  (- (car unit) (cdr unit)))

(define (finished? state)
  (let1 half (/ (car (ref state 0)) 2)
    (call/cc
     (lambda (cc)
       (map
	(lambda (m)
	  (for-each
	   (lambda (combi)
	     (if
	      (= half
		 (apply
		  + 0
		  (map
		   (lambda (index)
		     (cdr (ref state index)))
		   combi)))
		 (cc #t)
		 #f))
	   (combinations (iota (length state)) m)))
	(iota (- (length state) 1) 1))
       (cc #f)))))

(define (move state from to)
  (let* ((to-unit (ref state to))
	 (to-limit (limit to-unit))
	 (to-value (value to-unit))
	 (from-unit (ref state from))
	 (from-limit (limit from-unit))
	 (from-value (value from-unit)))
    (let loop((i 0) (ret ()) (state state))
      (if (null? state)
	  (reverse ret)
	  (loop
	   (+ i 1)
	   (let* ((unit (car state))
		  (unit-limit (limit unit))
		  (unit-value (value unit)))
	     (cons (cons
		    unit-limit
		    (cond
		     ((= i from)
		      (let1 val (- from-value (room to-unit))
			(if (< val 0) 0 val)))
		     ((= i to)
		      (if (< from-value (room to-unit))
			  (+ to-value from-value)
			  to-limit))
		     (else
		      unit-value)))
		   ret))
	   (cdr state))))))

(define (init-units . args)
  (let1 args (sort args >)
    (let1 initial-unit (cons (car args) (car args))
      (let loop((args (cdr args)) (ret `(,initial-unit)))
	(if (null? args)
	    (reverse ret)
	    (loop
	     (cdr args)
	     (cons (cons (car args) 0) ret)))))))

(define (search-abura . args)
  (search-recur (apply init-units args) '()))

(define (search-recur state past-states)
  (call/cc 
   (lambda (cc)
     (map
      (lambda (combi)
	(let1 next-state (apply move state combi)
	  ;(format #t "next: ~a, combi: ~a,  past: ~a\n" next-state combi past-states)
	  (cond
	   ((equal? state next-state) #f)
	   ((find (lambda (search-state)
		    (equal? (car search-state) next-state))
		  past-states) #f)
	   ((finished? next-state) 
	    (cc (cons (cons next-state nil) 
		      (cons (cons state combi)
			    past-states))))
	   (else
	    (let1 success? (search-recur next-state
					 (cons (cons state combi) past-states))
	      (if success?
		  (cc success?)
		  #f))))))
      (map (lambda (perm)
	     (head perm 2))
	   (permutations (iota (length state)))))
     (cc #f))))

(define (head ls len)
  (let loop((ls ls) (ret ()) (len len))
    (if (or (null? ls) (= len 0))
	(reverse ret)
	(loop (cdr ls) (cons (car ls) ret) (- len 1)))))

(define (pretty-print-result search-states)
  (define (print-search-state search-state)
    (let* ((state (car search-state)))	   
      (let loop((i 0) (state state))
	(if (null? state)
	    (begin)
	    (begin (format #t "s~a:~2,a  " i (cdr (car state)))
		   (loop (+ i 1) (cdr state)))))
      (let ((step (cdr search-state))
	    (state (car search-state)))
	(if (not (null? step))
	    (format #t ": s~a から s~a へ ~a 移す\n"
		(car step) (cadr step)
		(let ((from-value (cdr (ref state (car step))))
		      (to-unit (ref state (cadr step))))
		  (min from-value (room to-unit))))
	    (newline)))))

  (if search-states
      (let1 search-states (reverse search-states)
	(let loop((search-states search-states))
	  (if (null? search-states)
	      (begin)
	      (begin
		(print-search-state (car search-states))
		(loop (cdr search-states))))))
      (print "No answer.")))