;;; SCCS %W%	%D%
;;; jd-bucket-solver.el --- Buckets puzzles solver

;;; Author: Jacques Duthen <duthen@bigfoot.com>
;;; Keywords: emacs-lisp
;;; Maintainer's Time-stamp: <01/06/20 17:27 Jacques Duthen>

;;; This file is not yet part of GNU Emacs.
;;; ----------------------------------------------------------------
;;;
;;; The buckets puzzle
;;; ------------------
;;; You are given a certain number of buckets with different capacities.
;;; Some of them are full of liquid.
;;; You have to find how to isolate a certain volume, using only
;;; full decants.

;;; Example
;;; -------
;;; You are given three buckets with capacities are 3 5 and 8 litres.
;;; (Exotic people may use gallons or any exotic unit).
;;; The smallest buckets is empty and the largest one is full.
;;; You have to find how to isolate 4 litres, in 6 decants.

;;; Implementation
;;; --------------
;;; This bucket solver is implemented using the breadth-first algorithm
;;; in conjunction with the `fun2' implementation.

;;; Domain-dependant objects
;;; ------------------------
;;; <buckets>       ::= (<bucket-state>*)
;;; <bucket-state>  ::= (<bucket-capacity> . <bucket-content>)
;;; <transition>    ::= (<num-bucket-from> . <num-bucket-to>)

;;; A <buckets> is a list of <bucket-state>.
;;; A <bucket-state> is a pair (<bucket-capacity> . <bucket-content>)
;;;   where <bucket-capacity> is the maximum capacity of the bucket
;;;   and   <bucket-content>  is the current content  of the bucket
;;;
;;; Example:
;;; -------
;;;
;;; (bs-configure)
;;; (bs-solve '((3 . 0) (5 . 0) (8 . 8)) 4 "Buckets")
;;;
;;; =>
;;;
;;; Generation #6
;;;   Solution #1
;;;     (0 0 8) [3 -> 2]
;;;     (0 5 3) [2 -> 1]
;;;     (3 2 3) [1 -> 3]
;;;     (0 2 6) [2 -> 1]
;;;     (2 0 6) [3 -> 2]
;;;     (2 5 1) [2 -> 1]
;;;     (3 4 1)

(defun bs-configure ()
  (require 'jd-breadth-first)
  (bf-fun2-configure 'bs-buckets-new-transitions
                     'bs-buckets-fill
                     'bs-buckets-solution?)
  'bs-configure)

;;; Internal variables
(defvar *bs-goal*)

;;; Ex: (bs-solve '((3 . 0) (5 . 0) (8 . 8)) 4 "Buckets")

(defun bs-solve (starting-buckets-data goal &optional buffer)
  (let ((*bs-goal* goal)
        buckets l-sol)
    (setq buckets
          (mapcar (lambda (ca-co) (bs-bucket-new (car ca-co) (cdr ca-co)))
                  starting-buckets-data))
    (setq l-sol (bf-solve 0 (list (bf-fun1-path-new buckets))))
    ;; Print the solutions
    (bs-print-solutions l-sol buffer)
    l-sol))

;;; ----------------------------------------------------------------
;;; bs-solutions
;;;
(defun bs-print-solutions (solutions buffer)
  (when buffer
    (setq buffer (get-buffer-create buffer))
    (set-buffer buffer)
    (erase-buffer))
  (mapc (lambda (sol)
          (let ((no-generation (car sol))
                (l-path (cdr sol)))
            (bs-print-generation no-generation l-path)))
        solutions)
  (display-buffer buffer 'not-this-window))

(defun bs-print-generation (no-generation l-path)
  (insert (format "Generation #%d\n" no-generation))
  (let ((num-sol 0))
    (mapc (lambda (path) (bs-print-solution (incf num-sol) path))
          l-path)))

(defun bs-print-solution (num-sol path)
  (insert (format "  Solution #%d\n" num-sol))
  (bs-print-path path))

(defun bs-print-path (path)
  (let ((l-buckets-trans (bf-fun1-path-l-nodes-trans path)))
    (insert "    " (bs-buckets-format (pop l-buckets-trans)))
    (while l-buckets-trans
      (insert " "
              (bs-transition-format (pop l-buckets-trans))
              "\n    "
              (bs-buckets-format    (pop l-buckets-trans))))
    (insert "\n")))

;;; ----------------------------------------------------------------
;;; bs-transition
;;;
(defun bs-transition-format (transition)
  (format "[%s -> %s]"
          (1+ (bs-transition-num-bucket-from transition))
          (1+ (bs-transition-num-bucket-to   transition))))

(defmacro bs-transition-new (num-bucket-from num-bucket-to)
  `(cons ,num-bucket-from ,num-bucket-to))

(defmacro bs-transition-num-bucket-from (transition) `(car ,transition))
(defmacro bs-transition-num-bucket-to   (transition) `(cdr ,transition))

;;; ----------------------------------------------------------------
;;; bs-buckets
;;;
;;; Function used to configure the bf system
(defun bs-buckets-new-transitions (buckets)
  (let ((l-transitions (list)))
    (dolist (num-bucket-from (bs-buckets-nums-from buckets))
      (dolist (num-bucket-to (bs-buckets-nums-to   buckets))
        ;; Optimisation: don't try to decant a bucket into itself
        ;; (though the program would handle it correctly anyway)
        (unless (eq num-bucket-from num-bucket-to)
          (push (bs-transition-new num-bucket-from num-bucket-to)
                l-transitions))))
    (nreverse l-transitions)))

;;; Function used to configure the bf system
(defun bs-buckets-solution? (buckets)
  (bs-buckets-some-contains? buckets *bs-goal*))

(defun bs-buckets-format (buckets)
  (format "%s" (mapcar (lambda (bucket) (bs-bucket-content bucket)) buckets)))

(defun bs-buckets-nums-from (buckets)
  (let ((num-buckets-from (list)) (num-bucket 0))
    (dolist (bucket buckets)
      ;; Optimisation: don't try to decant an empty bucket
      ;; (though the program would handle it correctly anyway)
      (unless (bs-bucket-empty? bucket)
        (push num-bucket num-buckets-from))
      (incf num-bucket))
    (nreverse num-buckets-from)))

(defun bs-buckets-nums-to (buckets)
  (let ((num-buckets-from (list)) (num-bucket 0))
    (dolist (bucket buckets)
      ;; Optimisation: don't try to decant into a full bucket
      ;; (though the program would handle it correctly anyway)
      (unless (bs-bucket-full? bucket)
        (push num-bucket num-buckets-from))
      (incf num-bucket))
    (nreverse num-buckets-from)))

;;; Function used to configure the bf system
(defun bs-buckets-fill (buckets transition)
  (let ((bucket-from
         (bs-buckets-nth buckets (bs-transition-num-bucket-from transition)))
        (bucket-to
         (bs-buckets-nth buckets (bs-transition-num-bucket-to   transition)))
        added)
    (setq added (min (bs-bucket-addable bucket-to)
                     (bs-bucket-content bucket-from)))
    (mapcar
     (lambda (bucket)
       (cond
         ((eq bucket bucket-from)
          (setq bucket (bs-bucket-add bucket (- added))))
         ((eq bucket bucket-to)
          (setq bucket (bs-bucket-add bucket added))))
       bucket)
     buckets)))

;;; Limitation: don't do (bs-buckets-nth (pop l) (pop l))
;;;
(defmacro bs-buckets-nth (buckets num-bucket)
  `(nth ,num-bucket ,buckets))

(defun bs-buckets-some-contains? (buckets content)
  (some (lambda (bucket) (eq content (bs-bucket-content bucket))) buckets))

;;; ----------------------------------------------------------------
;;; bucket
;;;
(defun bs-bucket-add (bucket added)
  (bs-bucket-new (bs-bucket-capacity bucket)
                 (+ (bs-bucket-content bucket) added)))

(defmacro bs-bucket-empty?   (bucket)
  `(zerop (bs-bucket-content ,bucket)))

(defmacro bs-bucket-full?    (bucket)
  `(zerop (bs-bucket-addable ,bucket)))

(defun bs-bucket-addable  (bucket)
  (- (bs-bucket-capacity bucket) (bs-bucket-content bucket)))

(defmacro bs-bucket-new (capacity &rest content)
  `(cons ,capacity ,(if content (car content) 0)))

(defmacro bs-bucket-capacity (bucket) `(car ,bucket))
(defmacro bs-bucket-content  (bucket) `(cdr ,bucket))