;;; goat.scm
;;;
;;; the wolf, goat, cabbage puzzle in scheme
;;;
;;; demonstrates searching a cyclic state space using Scheme
;;;
;;; demo for CS 313     Daniel Scharstein


;; the following functions can be used for any puzzle with a cyclic
;; state graph

; the top-level function to start the search
(define (solveIt)
  (solve (initstate) (list (initstate)) '())
  #t) ; avoid "unspecified return value" message

; recursively explore all states
(define (solve currentstate oldstates oldmoves)
  (if (finalstate? currentstate)
      (begin
	(write 'solution:) (newline)
	(printlist oldmoves)
	(newline))
      (makemoves (possiblemoves currentstate)
		 currentstate oldstates oldmoves)))

; print the list of moves in reverse order
(define (printlist moves)
  (if (not (null? moves))
      (begin
	(printlist (cdr moves))
	(write (car moves))
	(newline))))

; tries all moves in movelist; if they are legal and result in a new
; state, call solve recursively
(define (makemoves movelist currentstate oldstates oldmoves)
  (if (not (null? movelist))
      (let* ((move (car movelist))
	     (newstate (makemove move currentstate)))
	(if (and (legalstate? newstate)
		 (not (member newstate oldstates)))
	    (begin
;;	      (write 'newstate)  ;; useful for debugging
;;	      (write newstate)
;;	      (newline)
	      (solve newstate (cons newstate oldstates) (cons move oldmoves))))
	(makemoves (cdr movelist) currentstate oldstates oldmoves))))


;;; functions below are specific to the current puzzle

; Represent states as lists with two elements, each a list of the objects
; on the left/right river bank.  Make sure that representation is unique
; by maintaining the relative ordering man < wolf < goat < cabbage.

(define (left state)
  (car state))
(define (right state)
  (cadr state))

; the initial state
(define (initstate)
  '((man wolf goat cabbage) ()))

; are we done?
(define (finalstate? state)
  (null? (left state)))

; return list of possible moves from current state
; for example:
; > (possiblemoves '((man wolf goat) (cabbage)))
; '((goright man) (goright man wolf) (goright man goat))
(define (possiblemoves state)
  (if (eqv? 'man (car (left state)))
      (mapcons 'goright (makepassengerlist (left state)))
      (mapcons 'goleft (makepassengerlist (right state)))))

; conses a onto each element in l
(define (mapcons a l)
  (map (lambda (x)
	 (cons a x))
       l))

; extracts all possible lists of passengers from a group containing 'man'
; for example:
; > (makepassengerlist '(man wolf goat))
; '((man) (man wolf) (man goat))
(define (makepassengerlist group)
  (cons '(man) (mapcons 'man (map list (cdr group)))))

; applies move 'move' to current state and returns new state
(define (makemove move state)
  (let* ((goright? (eqv? (car move) 'goright))
	 (passengers (cdr move))
	 (from (if goright? (left state) (right state)))
	 (to (if goright? (right state) (left state)))
	 (newfrom (removelist passengers from))
	 (newto (mergelists passengers to)))
    (if goright?
	(list newfrom newto)
	(list newto newfrom))))

; removes all elements in list a from list b
(define (removelist a b)
  (if (null? a) b
      (remove (car a) (removelist (cdr a) b))))

; removes first occurence of x from list b
(define (remove x b)
  (if (null? b) '()
      (if (eqv? x (car b)) (cdr b)
	  (cons (car b) (remove x (cdr b))))))

; merges ordered lists a and b into ordered result, using predicate 'less?'
; to determine order
(define (mergelists a b)
  (cond ((null? a) b)
	((null? b) a)
	((less? (car a) (car b))
	 (cons (car a) (mergelists (cdr a) b)))
	(else
	 (cons (car b) (mergelists a (cdr b))))))

; decides whether a is smaller than b
(define (less? a b)
  (let* ((ranks '((man 1) (wolf 2) (goat 3) (cabbage 4)))
	 (na (cadr (assoc a ranks)))
	 (nb (cadr (assoc b ranks))))
    (< na nb)))

; is state legal?
(define (legalstate? state)
  (and (legalgroup? (left state))
       (legalgroup? (right state))))

; is group legal?
(define (legalgroup? group)
  (or (null? group)
      (eqv? 'man (car group))
      (and (not (and (member 'wolf group)
		     (member 'goat group)))
	   (not (and (member 'goat group)
		     (member 'cabbage group))))))

; Sample run:
;
; > (solveIt)
; solution:
; (goright man goat)
; (goleft man)
; (goright man wolf)
; (goleft man goat)
; (goright man cabbage)
; (goleft man)
; (goright man goat)
;
; solution:
; (goright man goat)
; (goleft man)
; (goright man cabbage)
; (goleft man goat)
; (goright man wolf)
; (goleft man)
; (goright man goat)