CSCI 3202: Artificial Intelligence

Sample code for PS1 #5

;;;;;;;;;;;;;;;;;;;;; ;; ;; 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)