;;; This file includes problem-specific procedures for solving the
;;; Towers of Hanoi problem.

;;; State configurations are represented as a list of lists, each
;;; sublist representing the disks on one peg.  The numbers in each
;;; each sublist represent the sizes of the disks and they
;;; are in order from top to bottom.  The initial configuration for
;;; the 3-disk problem is
;;;   ((1 2 3) () ())

;;; Is state the goal state?  Are no disks left on the first
;;; and third pegs?

(define hanoi-goal?
  (lambda (state)
    (and (null? (car (state-config state)))
	 (null? (caddr (state-config state))))))

(define hanoi-bad-state?
  (lambda (state)
    (letrec
	((large-above-small?
	  (lambda (disks)
	    (cond ((or (null? disks) (null? (cdr disks)))
		   #f)
		  ((> (car disks) (cadr disks))
		   #t)
		  (else
		   (large-above-small? (cdr disks)))))))
      (or
       (large-above-small? (car (state-config state)))
       (large-above-small? (cadr (state-config state)))
       (large-above-small? (caddr (state-config state)))))))

;;; What states (legal or not) result from moving one disk?

(define hanoi-moves
  (lambda (state)
    (let ((dist (add1 (car state)))
	  (config (state-config state)))
    (append
     ;; States you get by moving the top disk from the first peg.
     (if (null? (car config))
	 '()
	 (let ((first (cdr (car config)))
	       (second (cadr config))
	       (third (caddr config))
	       (moved (car (car config))))
	   (list
	    (list dist 0 (list first (cons moved second) third))
	    (list dist 0 (list first second (cons moved third))))))
     ;; States you get by moving the top disk from the second peg.
     (if (null? (cadr config))
	 '()
	 (let ((first (car config))
	       (second (cdr (cadr config)))
	       (third (caddr config))
	       (moved (car (cadr config))))
	   (list
	    (list dist 0 (list (cons moved first) second third))
	    (list dist 0 (list first second (cons moved third))))))
     ;; States you get by moving the top disk from the third peg.
     (if (null? (caddr config))
	 '()
	 (let ((first (car config))
	       (second (cadr config))
	       (third (cdr (caddr config)))
	       (moved (car (caddr config))))
	   (list
	    (list dist 0 (list (cons moved first) second third))
	    (list dist 0 (list first (cons moved second) third)))))))))

;;; All of the possible states that are reachable in one "move"
;;; from state.

(define hanoi-extend
  (lambda (state)
    (filter
     hanoi-bad-state?
     (hanoi-moves state))))

;;; Everything in ls which does not return #t to pred.

(define filter
  (lambda (pred ls)
    (cond ((null? ls) '())
          ((pred (car ls))
           (filter pred (cdr ls)))
          (else
           (cons (car ls)
                 (filter pred (cdr ls)))))))

;;; How far away is the goal likely to be?
;;; How many disks need to moved onto the middle peg?

(define hanoi-estimate
  (lambda (state)
    (let ((config (state-config state)))
      (+ (length (car config))
	 (length (caddr config))))))

;;; Prints a pretty version of a state representation.

(define hanoi-print-state
  (lambda (state)
    (let* ((config (state-config state))
	   (width (+ 4 (* 2 (apply + (map length config))))))
      (printf "  DISTANCE: ~s, ESTIMATE: ~s  "
	      (state-distance state)
	      (state-estimate state))
      (if (null? (car config))
	  (display "_")
	  (display (car config)))
      (write-spaces (- width (+ 2 (* 2 (length (car config))))))
      (if (null? (cadr config))
	  (display "_")
	  (display (cadr config)))
      (write-spaces (- width (+ 2 (* 2 (length (cadr config))))))
      (if (null? (caddr config))
	  (display "_")
	  (display (caddr config)))
      (write-spaces (- width (+ 2 (* 2 (length (caddr config)))))))))

(define write-spaces
  (lambda (n)
    (if (not (zero? n))
        (begin (display " ")
               (write-spaces (sub1 n))))))