Sample code for PS1 #5
<![CDATA[
;;;;;;;;;;;;;;;;;;;;;
;;
;; Basic can-state constructors and selectors
(define (make-can-state c1 c2 c3 c4 parentstate)
(if (> c2 c1)
(list c2 c1 c3 c4 parentstate)
(list c1 c2 c3 c4 parentstate)))
(define (can-values can-state)
(reverse (cdr (reverse can-state))))
(define (parent-state can-state) (list-ref can-state 4))
(define (equal-states? can-state1 can-state2)
(equal? (can-values can-state1) (can-values can-state2)))
(define (can-capacity can)
(cond ((< can 2) 40)
((= can 2) 5)
(else 4)))
(define (parent-list state)
(cond ((null? (parent-state state)) '())
(else
(cons (parent-state state)
(parent-list (parent-state state))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Finding the "children" of a can-state
(define (transfer-can source targ can-state)
(define (transferwork can src trg start transamt)
(cond ((= can src) (- start transamt))
((= can trg) (+ start transamt))
(else start)))
(let* ((sourceval (list-ref can-state source))
(targval (list-ref can-state targ))
(targcapacity (can-capacity targ))
(targavailable (- targcapacity targval))
(transferamount (min targavailable sourceval)))
(cond ((= transferamount 0) can-state)
(else
(let ((newstate
(make-can-state
(transferwork
0 source targ
(list-ref can-state 0) transferamount)
(transferwork
1 source targ
(list-ref can-state 1) transferamount)
(transferwork
2 source targ
(list-ref can-state 2) transferamount)
(transferwork
3 source targ
(list-ref can-state 3) transferamount)
can-state)))
(if (equal-states? newstate can-state)
can-state
newstate))))))
(define (find-all-new-children-states can-state)
(remove-duplicates
(filter (lambda (st) (not (equal-states? st can-state)))
(map (lambda (src trg) (transfer-can src trg can-state))
'(0 0 0 1 1 1 2 2 2 3 3 3)
'(1 2 3 0 2 3 0 1 3 0 1 2)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Several useful procedures for our search
(define (remove-duplicates lis)
(cond ((or (null? lis) (null? (cdr lis))) lis)
((true-of-any? (lambda (elt) (equal-states? elt (car lis)))
(cdr lis))
(remove-duplicates (cdr lis)))
(else (cons (car lis) (remove-duplicates (cdr lis))))))
(define (goal-state? state) (and (= (list-ref state 2) 2)
(= (list-ref state 3) 2)))
(define (loop-state? state)
(true-of-any? (lambda (par) (equal-states? par state))
(parent-list state)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Problem 1. Size of the problem space.
(define *initcans* (make-can-state 40 40 0 0 '()))
(define (search-for-all-possible-states statelis)
(let* ((newstates
(remove-duplicates
(append
statelis
(map-append (lambda (state)
(find-all-new-children-states state))
statelis)))))
(cond ((= (length newstates) (length statelis))
(for-each
(lambda (state)
(newline) (display (reverse (cdr (reverse state)))))
newstates))
(else (search-for-all-possible-states newstates)))))
;;;;;;;;;;;;;;;;;;
;;
;; Problem 2. Several alternative depth-first-search algorithms
;; for solving the Loyd milk-can problem.
;;
;; This one checks for loops only.
(define (depth-first-search open)
(cond ((null? open) 'FAIL)
((goal-state? (first open)) (first open))
(else
(depth-first-search
(filter
(lambda (st) (not (loop-state? st)))
(append (find-all-new-children-states (first open))
(rest open)))))))
;; This one checks that a newly-found node is not already on
;; the open list.
(define (depth-first-search-2 open)
(cond ((null? open) 'FAIL)
((goal-state? (first open)) (first open))
(else
(let* ((newstates (find-all-new-children-states (first open)))
(reallynewstates
(filter (lambda (st)
(not (or (loop-state? st)
(true-of-any?
(lambda (op) (equal-states? st op))
open))))
newstates)))
(depth-first-search-2
(append reallynewstates (rest open)))))))
;; This one checks that a newly-found node is neither an open nor
;; a "closed" (already-searched) node.
(define (depth-first-search-3 open closed)
(cond ((null? open) 'FAIL)
((goal-state? (first open)) (first open))
(else (let*
((newstates
(find-all-new-children-states (first open)))
(reallynewstates
(filter
(lambda (st)
(not (or (loop-state? st)
(true-of-any?
(lambda (op) (equal-states? st op))
open)
(true-of-any?
(lambda (cl) (equal-states? st cl))
closed))))
newstates)))
(depth-first-search-3
(append reallynewstates (rest open))
(cons (first open) closed))))))
;;;;;;;;;;;;;;;
;;
;; A couple of usefully renamed procedures
(define first car)
(define rest cdr)
]]>