Skip to content

Instantly share code, notes, and snippets.

@feltnerm

feltnerm/as7.scm

Created November 18, 2014 16:00
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save feltnerm/6a58f0a53472f9693b2a to your computer and use it in GitHub Desktop.
Save feltnerm/6a58f0a53472f9693b2a to your computer and use it in GitHub Desktop.
Download ZIP
A* Algorithm in Scheme
Raw
as7.scm
;; ;;;;;;;;
;; as7.scm
;;
;; ;;;;;;;;
;; (North, East) intersection
(define-struct intersect (north east))
;; Intersections
;; ----------
(define (intersect->list int)
(list (intersect-north int) 'N (intersect-east int) 'E))
(define (intersect= int1 int2)
;; True if two intersections are equivalent
(and
(equal? (intersect-north int1) (intersect-north int2))
(equal? (intersect-east int1) (intersect-east int2))))
;; States
;; ----------
(define-struct state (intersection cost est prev))
(define (state->list state)
(list (intersect->list (state-intersection state)) (state-cost state) (state-est state) (state-prev state)))
(define (state= state1 state2)
;; Equivalence for two states
;; could this just have one (and ...) ?
(and (equal? (state-cost state1) (state-cost state2))
(intersect= (state-intersection state1) (state-intersection state2))
(equal? (state-est state1) (state-est state2))
(equal? (state-prev state1) (state-prev state2))))
(define (same-state-&-cost-aux state1 state2 )
;; True if two states have the same cost
(= (+ (state-cost state1) (state-est state1))
(+ (state-cost state2) (state-est state2))))
(define (same-state-&-cost queue state)
;; True if the state has the same cost as the foremost state on the queue
(if (empty? queue ) false
(if (same-state-&-cost-aux (first queue) state)
true
(same-state-&-cost (rest queue) state))))
(define (state< state1 state2)
;; True if state1 costs less than state2
(<
(+ (state-cost state1) (state-est state1))
(+ (state-cost state2) (state-est state2))))
(define (cost< queue state)
;; True if state < the foremost state on the queue
(if (empty? queue ) false
(if (state< (first queue) state)
true
(same-state-&-cost (rest queue) state))))
;; State (Priority) Queue
;; ----------
(define (insert state1 sorted-queue )
;; Insert state onto the queue
(if (empty? sorted-queue ) (list state1)
(if (<=
(+ (state-cost state1) (state-est state1))
(+ (state-cost (first sorted-queue)) (state-est (first sorted-queue))))
(cons state1 sorted-queue)
(cons (first sorted-queue) (insert state1 (rest sorted-queue))))))
(define (sort1 queue)
(if (null? queue) '()
(insert (first queue ) (sort1 (rest queue)))))
;; State Queue API
;; ---------
(define (add-state-to-queue-aux state queue)
(if (equal? (same-state-&-cost queue state) true) (append queue (list state))
(append (list state) queue)))
(define (first-state-in-queue queue )
(first queue))
(define (rest-of-state-queue queue)
(rest queue))
(define (add-state-to-queue state queue)
;; Insert a given state into the queue in the proper location.
;; If there are already states in the queue with the same total cost,
;; add the new state to the end of that list.
(sort1 (add-state-to-queue-aux state queue)))
(define (remove-state-from-queue state queue)
;; Returns the queue without the target state in it.
;; That is, find the row in the queue for the specified cost and
;; remove the state from that row with the same intersection.
(if (state= state (first-state-in-queue queue))
(rest queue)
(cons (first-state-in-queue queue)
(remove-state-from-queue state (rest-of-state-queue queue)))))
(define (first-state-in-queue queue)
;; Returns the first (lowest cost) entry from the queue, but doesn't change the queue.
(if (null? queue) '()
(first queue)))
(define (rest-of-state-queue queue)
;; Returns the first (lowest cost) entry from the queue, but doesn't change the queue.
(if (null? queue) '()
(rest queue)))
(define (kid-in-queue queue kid)
(if (empty? queue) empty
(if (intersect= (state-intersection (first queue )) (state-intersection kid)) (first queue)
(kid-in-queue (rest queue) kid))))
;; Pathfinding and A* Algorithm
;; ----------
(define (find-neighbors int fun) (fun int))
(define(accumulate end-state )
(if (empty? end-state ) empty
(cons (state-intersection end-state) (accumulate (state-prev end-state)))))
(define (route-to-aux open close end fun )
(if (empty? open) 'fail
(let (( newopen (route-to-aux1 end open close fun ))
( newclose(route-to-aux4 end open close fun )))
(if (state? (kid-in-queue open (make-state end 0 0 empty) ))(reverse (accumulate (kid-in-queue open (make-state end 0 0 empty)) ))
(route-to-aux newopen newclose end fun )))))
(define (route-to-aux1 end open close fun)
(if (empty? open) open
(let* ((current-state (first open))
(newopen (rest open)))
(if (intersect= (state-intersection current-state) end) open
;(if ( intersect= (state-intersection current-state) (state-intersection (kid-in-queue open (make-state end 0 0 empty) ))) open
(let* ((list-of-states-children (map (λ (children) (make-state children (add1 (state-cost current-state))(manhattan-distance children end) current-state)) (fun (state-intersection current-state))) )
(closed (add-state-to-queue current-state close))
(newclosed (route-to-aux3 list-of-states-children open closed end ) )
(open (route-to-aux2 list-of-states-children open closed end )))
(route-to-aux1 end (rest open) newclosed fun ))))))
(define (route-to-aux4 end open close fun)
(if (empty? open ) open
(let* ((current-state (first open))
(newopen (rest open)))
(if (intersect= (state-intersection current-state) end) close
;(if ( state= current-state (kid-in-queue open (make-state end 0 0 empty) )) open
(let* ((list-of-states-children (map (λ (children) (make-state children (add1 (state-cost current-state))(manhattan-distance children end) current-state)) (fun (state-intersection current-state))) )
(closed (add-state-to-queue current-state close))
(newclosed (route-to-aux3 list-of-states-children open closed end ) )
(open (route-to-aux2 list-of-states-children open closed end )))
(route-to-aux4 end (rest open) newclosed fun ))))))
(define (route-to-aux2 list-of-states-children open closed end)
(if (empty? list-of-states-children) open
(let ((kid (first list-of-states-children)))
(cond [(state? (kid-in-queue open kid ))
(let ((state-kid-in-open (kid-in-queue open kid)))
(if (< (+ (state-cost kid) (manhattan-distance (state-intersection kid) end)) (+ (state-cost state-kid-in-open) (state-est state-kid-in-open)))
(route-to-aux2 (rest list-of-states-children) (add-state-to-queue kid (remove-state-from-queue state-kid-in-open open)) closed end)
(route-to-aux2 (rest list-of-states-children) open closed end) ))]
[(not (empty? (kid-in-queue closed kid)))
(let ((state-kid-in-closed (kid-in-queue closed kid)))
(if (< (+ (state-cost kid) (manhattan-distance (state-intersection kid) end)) (+ (state-cost state-kid-in-closed) (state-est state-kid-in-closed)))
(route-to-aux2 (rest list-of-states-children) (add-state-to-queue kid open ) (remove-state-from-queue state-kid-in-closed closed) end)
(route-to-aux2 (rest list-of-states-children) open closed end)))]
[else (route-to-aux2 (rest list-of-states-children) (add-state-to-queue kid open) closed end )]))))
(define (route-to-aux3 list-of-states-children open closed end)
(if (empty? list-of-states-children) closed
(let ((kid (first list-of-states-children)))
(cond [(state? (kid-in-queue open kid ))
(let ((state-kid-in-open (kid-in-queue open kid)))
(if (< (+ (state-cost kid) (manhattan-distance (state-intersection kid) end)) (+ (state-cost state-kid-in-open) (state-est state-kid-in-open)))
(route-to-aux3 (rest list-of-states-children) (add-state-to-queue kid (remove-state-from-queue state-kid-in-open open)) closed end)
(route-to-aux3 (rest list-of-states-children) open closed end) ))]
[(not (empty? (kid-in-queue closed (first list-of-states-children))))
(let ((state-kid-in-closed (kid-in-queue closed kid)))
(if (< (+ (state-cost kid) (manhattan-distance (state-intersection kid) end)) (+ (state-cost state-kid-in-closed) (state-est state-kid-in-closed)))
(route-to-aux3 (rest list-of-states-children) (add-state-to-queue kid open ) (remove-state-from-queue state-kid-in-closed closed) end)
(route-to-aux3 (rest list-of-states-children) open closed end)))]
[else (route-to-aux3 (rest list-of-states-children) (add-state-to-queue kid open) closed end )]))))
(define (route-to start end fun)
;; return path of the shortest route from start to end with a neighborhood function fun.
(let* ((open (add-state-to-queue (make-state start 0 (manhattan-distance start end) null) empty))
(close empty))
;(map(lambda (x) (state-intersection x))(route-to-aux open close end fun))))
(route-to-aux open close end fun)))
;(list-of-states-children (map (λ (children) (make-state children (add1 (state-cost (first open)))(manhattan-distance children end) (first open))) (fun start))))
;(map (λ (kid) ;; for each node in open:
; (let* ((current-state (first-state-in-queue open))
; (open (rest-of-state-queue open))
; (closed (add-state-to-queue current-state empty))
; (list-of-states-children (map (λ (children) (make-state children (add1 (state-cost current-state))(manhattan-distance children end) current-state)) (fun (state-intersection current-state))) )
;(answer (map (λ (kid) (let* ((state-kid-in-open (kid-in-queue open (state-intersection kid)))
; (state-kid-in-closed (kid-in-queue closed (state-intersection kid))))
; (if (state? state-kid-in-open)
; (if (< (manhattan-distance kid end) (+ (state-cost state-kid) (state-est state-kid)))
; (let ((new-open (add-state-to-queue kid (remove-state-from-queue state-kid-in-open open)))) new-open) open) open)
;(if (state? state-kid-in-closed)
; (if (< (manhattan-distance kid end) (+ (state-cost state-kid) (state-est state-kid)))
;(let (( new-close (remove-state-from-queue state-kid-in-closed closed))
; ( new-open ( add-state-to-queue kid open))) new-open) open ) open)
;(add-state-to-queue kid open))) list-of-states-children))) (map (lambda (x) (state-intersection x)) answer ))) list-of-states-children)))
(define (manhattan-distance int1 int2)
;; Manhattan distance is the number of blocks between two points.
;; Distance = (y_2 - y_1) + (x_2 - x_1)
(+ (- (intersect-north int2) (intersect-north int1))
(- (intersect-east int2) (intersect-east int1))))
;;
;; streets.scm: code for city streets
;;
(define *test-city-size*
20)
;; a sneaky way around assignments for testing purposes only - don't use this
;; technique!
(define-struct counter (value))
(define (reset c)
(set-counter-value! c 0))
(define (incr c)
(set-counter-value! c (+ 1 (counter-value c))))
(define *neighborhood-count*
(make-counter 0))
(define (1-way-neighbors int)
;; assume city fully connected; even roads go north or east and
;; odd roads go south or west
;; intersection -> list(intersection)
(incr *neighborhood-count*)
(let ((n (intersect-north int))
(e (intersect-east int)))
(append (if (and (> n 1) (odd? e))
(list (make-intersect (sub1 n) e))
empty)
(if (and (> e 1) (odd? n))
(list (make-intersect n (sub1 e)))
empty)
(if (and (< n *test-city-size*) (even? e))
(list (make-intersect (add1 n) e))
empty)
(if (and (< e *test-city-size*) (even? n))
(list (make-intersect n (add1 e)))
empty)
))
)
(define (2-way-neighbors int)
;; assume city fully connected;
;; intersection -> list(intersection)
(incr *neighborhood-count*)
(let ((n (intersect-north int))
(e (intersect-east int)))
(append (if (> n 1)
(list (make-intersect (sub1 n) e))
empty)
(if (> e 1)
(list (make-intersect n (sub1 e)))
empty)
(if (< n *test-city-size*)
(list (make-intersect (add1 n) e))
empty)
(if (< e *test-city-size*)
(list (make-intersect n (add1 e)))
empty)
))
)
(define (intersect->list int)
;; intersection -> list
(list (intersect-north int) 'N (intersect-east int) 'E)
)
(define (pair->intersect num-pair)
;; nat X nat -> intersect
;; turns a street into an intersection
(make-intersect (first num-pair) (second num-pair))
)
(define *village-streets*
;; list of all streets between intersections (where streets are "named"
;; by the intersections they connect)
;; type: -> list(pair(intersection, list(intersection)))
;; where "pair" is just a list with two items
(let ((all (list '((1 2) ((2 2)))
'((2 1) ((3 1) (2 2)))
'((2 2) ((2 1) (1 2) (3 2)))
'((3 1) ((2 1) (3 2) (4 1)))
'((3 2) ((3 1) (2 2) (4 2)))
'((4 1) ((3 1) (4 2)))
'((4 2) ((4 1) (3 2) (4 3)))
'((4 3) ((4 2) (5 3)))
'((5 3) ((4 3) (5 4) (5 2)))
'((5 4) ((5 3) (5 5)))
'((5 5) ((5 4) (5 6)))
'((5 6) ((5 5) (4 6)))
'((4 6) ((5 6) (4 5) (4 7)))
'((4 5) ((4 6) (4 4) (3 5)))
'((3 5) ((2 5) (4 5)))
'((2 5) ((3 5) (1 5) (2 4)))
'((1 5) ((1 4) (2 5)))
'((1 4) ((2 4) (1 5)))
'((2 4) ((2 3) (3 4) (1 4) (2 5)))
'((3 4) ((3 3) (2 4) (4 4)))
'((4 4) ((4 5) (3 4)))
'((3 3) ((3 4) (2 3)))
'((2 3) ((3 3) (3 4)))
)
))
(map (lambda (item)
(list (pair->intersect (first item))
(map pair->intersect (second item))))
all)
) ; let
)
(define *village-in-reverse*
;; -> list(pair(intersection, list(intersection)))
(map (lambda (ip)
(list (first ip) (reverse (second ip))))
*village-streets*)
)
(define (intersect-member? target intersections)
;; intersection X list(intersection) -> boolean
;; returns true if target in list of intersections, false otherwise
(cond ((empty? intersections)
false)
((and (= (intersect-north target)
(intersect-north (first intersections)))
(= (intersect-east target)
(intersect-east (first intersections))))
true)
(true
(intersect-member? target (rest intersections)))
)
)
(define (intersect-assoc target intersection-info)
;; intersect X list(list(intersect, T)) -> list(intersect, T) | false
;; Takes a target intersection and a list of items where each item is
;; an intersection followed by some other list of items and returns
;; the first match; this is equivalent to assoc but matches items
;; by comparing north and east components (assoc uses equal? which
;; doesn't work in this case)
;; See http://www.uwplatt.edu/csse/courses/cs303/notes/303n03.html#assoc
(if (empty? intersection-info)
false
(let* ((next (first intersection-info)))
(if (and (= (intersect-north target)
(intersect-north (first next)))
(= (intersect-east target)
(intersect-east (first next))))
next
(intersect-assoc target (rest intersection-info))))
)
)
(define (village-neighbors-1 int)
;; intersection -> list(intersection)
(incr *neighborhood-count*)
(let* ((assoc-result (intersect-assoc int *village-streets*)))
(if (not assoc-result)
empty
(second assoc-result))
)
)
(define (village-neighbors-2 int)
;; intersection -> list(intersection)
(incr *neighborhood-count*)
(let* ((assoc-result (intersect-assoc int *village-in-reverse*)))
(if (not assoc-result)
empty
(second assoc-result))
)
)
(define (village-neighbors-3 int)
;; intersection -> list(intersection)
(if (and (= (intersect-north int) 4) (= (intersect-east int) 5))
(begin
(incr *neighborhood-count*)
(list (make-intersect 4 6) (make-intersect 4 4) (make-intersect 3 5)
(make-intersect 5 5))
)
; else
(village-neighbors-2 int))
)
(define *bombed-intersections*
;; -> list(intersection)
(map pair->intersect
'((2 1) (2 4) (3 2) (3 6) (4 3) (4 5) (5 2) (5 5)
(6 2) (6 3) (6 4) (6 5) (6 6)))
)
(define (bombed? int)
;; intersection -> boolean
;; returns true if intersect INT is at a bombed location
(intersect-member? int *bombed-intersections*)
)
(define *village-streets-after-bombing*
;; list of *village-streets* after blocking out bombed intersections
;; -> list(intersection)
(let* ((unbombed-intersections (filter (lambda (int-with-connections)
(not (bombed? (first int-with-connections))))
*village-streets*))
)
(map (lambda (int-with-connections)
(list (first int-with-connections)
(filter (lambda (int) (not (bombed? int)))
(second int-with-connections))))
unbombed-intersections)
)
)
(define (neighbors-after-bombing int)
;; like 2-way-neighbors but minus those intersections which have
;; been bombed
;; intersection -> list(intersection)
(if (bombed? int)
(begin
(display (format
"### Illegal call to neighborhood function at (~S ~S)! ###\n"
(intersect-north int) (intersect-east int)))
(incr *neighborhood-count*)
empty
)
; else
(let ((neighbors (2-way-neighbors int)))
(filter (lambda (i) (not (bombed? i))) neighbors)
) ;let
) ;if
)
(define (connected? intersections neighbor-fun)
;; list(intersect) X neighborhood-function -> boolean
;; checks that all intersections in list are connected (in sequence)
(or
;; length is 0: all are connected
(empty? intersections)
;; length <= 1: all are connected in list of one
(empty? (rest intersections))
;; length > 1:
(and (intersect-member? (second intersections)
(neighbor-fun (first intersections)))
(connected? (rest intersections) neighbor-fun)))
)
(define (report-num-neighbor-calls)
;; report number of times neighborhood function was called
;; -> nat
(display (format "Calls to neighborhood function: ~S.\n"
(counter-value *neighborhood-count*)))
)
(define (minimal-route? intersections neighbor-fun start stop max-dist)
;; takes list of intersections and confirms that they comprise a
;; minimal route from start to stop
;;
;; (list(intersect)|'fail) X neighborhood-function X intersect
;; X intersect X (nat|'fail) -> bool
(cond ((equal? max-dist 'fail)
(equal? intersections 'fail))
((equal? intersections 'fail)
false)
((or (not (list? intersections)) (empty? intersections))
false)
(true
(let ((answer-start (first intersections))
(answer-stop (first (reverse intersections))))
(and (= (intersect-north start) (intersect-north answer-start))
(= (intersect-east start) (intersect-east answer-start))
(= (intersect-north stop) (intersect-north answer-stop))
(= (intersect-east stop) (intersect-east answer-stop))
(= max-dist (sub1 (length intersections)))
(connected? intersections neighbor-fun))))
) ;cond
)
(define (test-route-to start end neighborhood-fun max-dist)
;; call route-to for given start and end intersections using
;; neighborhood-fun; print result, confirm it's connected,
;; and confirm that it's length is max-dist
;; intersection X intersection X neighborhood-function X nat -> void
(reset *neighborhood-count*)
(display "----------------------------------------\n")
(let* ((_ (display (format "(route-to ~s ~s ~s):\n"
(intersect->list start)
(intersect->list end)
neighborhood-fun)))
(answer (route-to start end neighborhood-fun))
)
;; cases: fail in both: just report num neighbor calls
;; fail in route-to: missed path error
;; fail in max-dist: unexpected path
;; path in both: do following
(cond ((and (equal? max-dist 'fail) (equal? answer 'fail))
(begin
(display (format "No route from ~s to ~s.\n"
(intersect->list start)
(intersect->list end)))
(report-num-neighbor-calls)
))
((equal? answer 'fail)
(display (format "!! ERROR: path from ~s to ~s not found!\n"
(intersect->list start)
(intersect->list end))
))
((equal? max-dist 'fail)
(display (format "!! ERROR: invalid path ~s from ~s to ~s!\n"
(map intersect->list answer)
(intersect->list start)
(intersect->list end))
))
(true
(begin
(display "Path:\n")
(pretty-print (map intersect->list answer))
(report-num-neighbor-calls)
(if (connected? answer neighborhood-fun)
empty
(display (format
"!! ERROR: invalid path from ~s to ~s:\n ~s"
(intersect->list start)
(intersect->list end)
(map intersect->list answer))))
(if (minimal-route? answer neighborhood-fun start end max-dist)
empty
(display (format
"!! ERROR: route not minimal; one can go from ~s to ~s in ~s steps.\n"
(intersect->list start) (intersect->list end)
max-dist)))
) ; begin
)
) ; cond
) ; let*
) ; define
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; test cases
(define (test1-a)
(test-route-to (make-intersect 1 1) (make-intersect 1 1)
2-way-neighbors 0))
(define (test1-b)
(test-route-to (make-intersect 1 1) (make-intersect 2 1)
2-way-neighbors 1))
(define (test1-c)
(test-route-to (make-intersect 1 1) (make-intersect 2 2)
2-way-neighbors 2))
(define (test1-d)
(test-route-to (make-intersect 4 5) (make-intersect 2 1)
2-way-neighbors 6))
(define (test2-a)
(test-route-to (make-intersect 1 1) (make-intersect 1 1)
1-way-neighbors 0))
(define (test2-b)
(test-route-to (make-intersect 1 1) (make-intersect 2 2)
1-way-neighbors 'fail))
(define (test2-c)
(test-route-to (make-intersect 2 2) (make-intersect 1 1)
1-way-neighbors 4))
(define (test2-d)
(test-route-to (make-intersect 2 6) (make-intersect 2 2)
1-way-neighbors 8))
(define (test3-a)
(test-route-to (make-intersect 4 4) (make-intersect 1 2)
village-neighbors-1 11))
(define (test3-b)
(test-route-to (make-intersect 1 2) (make-intersect 4 4)
village-neighbors-1 11))
(define (test3-c)
(test-route-to (make-intersect 4 4) (make-intersect 1 2)
village-neighbors-2 11))
(define (test3-d)
(test-route-to (make-intersect 1 2) (make-intersect 4 4)
village-neighbors-2 11))
(define (test3-e)
(test-route-to (make-intersect 4 4) (make-intersect 1 2)
village-neighbors-3 9))
(define (test3-f)
(test-route-to (make-intersect 1 2) (make-intersect 4 4)
village-neighbors-3 11))
(define (test4-a)
(test-route-to (make-intersect 1 1) (make-intersect 6 1)
neighbors-after-bombing 19))
(define (test4-b)
(test-route-to (make-intersect 6 1) (make-intersect 1 1)
neighbors-after-bombing 19))
(test2-a)
(test2-b)
(test2-c)
(test2-d)
Raw
streets.scm
;;
;; streets.scm: code for city streets
;;
(define *test-city-size*
20)
;; a sneaky way around assignments for testing purposes only - don't use this
;; technique!
(define-struct counter (value))
(define (reset c)
(set-counter-value! c 0))
(define (incr c)
(set-counter-value! c (+ 1 (counter-value c))))
(define *neighborhood-count*
(make-counter 0))
(define (1-way-neighbors int)
;; assume city fully connected; even roads go north or east and
;; odd roads go south or west
;; intersection -> list(intersection)
(incr *neighborhood-count*)
(let ((n (intersect-north int))
(e (intersect-east int)))
(append (if (and (> n 1) (odd? e))
(list (make-intersect (sub1 n) e))
empty)
(if (and (> e 1) (odd? n))
(list (make-intersect n (sub1 e)))
empty)
(if (and (< n *test-city-size*) (even? e))
(list (make-intersect (add1 n) e))
empty)
(if (and (< e *test-city-size*) (even? n))
(list (make-intersect n (add1 e)))
empty)
))
)
(define (2-way-neighbors int)
;; assume city fully connected;
;; intersection -> list(intersection)
(incr *neighborhood-count*)
(let ((n (intersect-north int))
(e (intersect-east int)))
(append (if (> n 1)
(list (make-intersect (sub1 n) e))
empty)
(if (> e 1)
(list (make-intersect n (sub1 e)))
empty)
(if (< n *test-city-size*)
(list (make-intersect (add1 n) e))
empty)
(if (< e *test-city-size*)
(list (make-intersect n (add1 e)))
empty)
))
)
(define (intersect->list int)
;; intersection -> list
(list (intersect-north int) 'N (intersect-east int) 'E)
)
(define (pair->intersect num-pair)
;; nat X nat -> intersect
;; turns a street into an intersection
(make-intersect (first num-pair) (second num-pair))
)
(define *village-streets*
;; list of all streets between intersections (where streets are "named"
;; by the intersections they connect)
;; type: -> list(pair(intersection, list(intersection)))
;; where "pair" is just a list with two items
(let ((all (list '((1 2) ((2 2)))
'((2 1) ((3 1) (2 2)))
'((2 2) ((2 1) (1 2) (3 2)))
'((3 1) ((2 1) (3 2) (4 1)))
'((3 2) ((3 1) (2 2) (4 2)))
'((4 1) ((3 1) (4 2)))
'((4 2) ((4 1) (3 2) (4 3)))
'((4 3) ((4 2) (5 3)))
'((5 3) ((4 3) (5 4) (5 2)))
'((5 4) ((5 3) (5 5)))
'((5 5) ((5 4) (5 6)))
'((5 6) ((5 5) (4 6)))
'((4 6) ((5 6) (4 5) (4 7)))
'((4 5) ((4 6) (4 4) (3 5)))
'((3 5) ((2 5) (4 5)))
'((2 5) ((3 5) (1 5) (2 4)))
'((1 5) ((1 4) (2 5)))
'((1 4) ((2 4) (1 5)))
'((2 4) ((2 3) (3 4) (1 4) (2 5)))
'((3 4) ((3 3) (2 4) (4 4)))
'((4 4) ((4 5) (3 4)))
'((3 3) ((3 4) (2 3)))
'((2 3) ((3 3) (3 4)))
)
))
(map (lambda (item)
(list (pair->intersect (first item))
(map pair->intersect (second item))))
all)
) ; let
)
(define *village-in-reverse*
;; -> list(pair(intersection, list(intersection)))
(map (lambda (ip)
(list (first ip) (reverse (second ip))))
*village-streets*)
)
(define (intersect-member? target intersections)
;; intersection X list(intersection) -> boolean
;; returns true if target in list of intersections, false otherwise
(cond ((empty? intersections)
false)
((and (= (intersect-north target)
(intersect-north (first intersections)))
(= (intersect-east target)
(intersect-east (first intersections))))
true)
(true
(intersect-member? target (rest intersections)))
)
)
(define (intersect-assoc target intersection-info)
;; intersect X list(list(intersect, T)) -> list(intersect, T) | false
;; Takes a target intersection and a list of items where each item is
;; an intersection followed by some other list of items and returns
;; the first match; this is equivalent to assoc but matches items
;; by comparing north and east components (assoc uses equal? which
;; doesn't work in this case)
;; See http://www.uwplatt.edu/csse/courses/cs303/notes/303n03.html#assoc
(if (empty? intersection-info)
false
(let* ((next (first intersection-info)))
(if (and (= (intersect-north target)
(intersect-north (first next)))
(= (intersect-east target)
(intersect-east (first next))))
next
(intersect-assoc target (rest intersection-info))))
)
)
(define (village-neighbors-1 int)
;; intersection -> list(intersection)
(incr *neighborhood-count*)
(let* ((assoc-result (intersect-assoc int *village-streets*)))
(if (not assoc-result)
empty
(second assoc-result))
)
)
(define (village-neighbors-2 int)
;; intersection -> list(intersection)
(incr *neighborhood-count*)
(let* ((assoc-result (intersect-assoc int *village-in-reverse*)))
(if (not assoc-result)
empty
(second assoc-result))
)
)
(define (village-neighbors-3 int)
;; intersection -> list(intersection)
(if (and (= (intersect-north int) 4) (= (intersect-east int) 5))
(begin
(incr *neighborhood-count*)
(list (make-intersect 4 6) (make-intersect 4 4) (make-intersect 3 5)
(make-intersect 5 5))
)
; else
(village-neighbors-2 int))
)
(define *bombed-intersections*
;; -> list(intersection)
(map pair->intersect
'((2 1) (2 4) (3 2) (3 6) (4 3) (4 5) (5 2) (5 5)
(6 2) (6 3) (6 4) (6 5) (6 6)))
)
(define (bombed? int)
;; intersection -> boolean
;; returns true if intersect INT is at a bombed location
(intersect-member? int *bombed-intersections*)
)
(define *village-streets-after-bombing*
;; list of *village-streets* after blocking out bombed intersections
;; -> list(intersection)
(let* ((unbombed-intersections (filter (lambda (int-with-connections)
(not (bombed? (first int-with-connections))))
*village-streets*))
)
(map (lambda (int-with-connections)
(list (first int-with-connections)
(filter (lambda (int) (not (bombed? int)))
(second int-with-connections))))
unbombed-intersections)
)
)
(define (neighbors-after-bombing int)
;; like 2-way-neighbors but minus those intersections which have
;; been bombed
;; intersection -> list(intersection)
(if (bombed? int)
(begin
(display (format
"### Illegal call to neighborhood function at (~S ~S)! ###\n"
(intersect-north int) (intersect-east int)))
(incr *neighborhood-count*)
empty
)
; else
(let ((neighbors (2-way-neighbors int)))
(filter (lambda (i) (not (bombed? i))) neighbors)
) ;let
) ;if
)
(define (connected? intersections neighbor-fun)
;; list(intersect) X neighborhood-function -> boolean
;; checks that all intersections in list are connected (in sequence)
(or
;; length is 0: all are connected
(empty? intersections)
;; length <= 1: all are connected in list of one
(empty? (rest intersections))
;; length > 1:
(and (intersect-member? (second intersections)
(neighbor-fun (first intersections)))
(connected? (rest intersections) neighbor-fun)))
)
(define (report-num-neighbor-calls)
;; report number of times neighborhood function was called
;; -> nat
(display (format "Calls to neighborhood function: ~S.\n"
(counter-value *neighborhood-count*)))
)
(define (minimal-route? intersections neighbor-fun start stop max-dist)
;; takes list of intersections and confirms that they comprise a
;; minimal route from start to stop
;;
;; (list(intersect)|'fail) X neighborhood-function X intersect
;; X intersect X (nat|'fail) -> bool
(cond ((equal? max-dist 'fail)
(equal? intersections 'fail))
((equal? intersections 'fail)
false)
((or (not (list? intersections)) (empty? intersections))
false)
(true
(let ((answer-start (first intersections))
(answer-stop (first (reverse intersections))))
(and (= (intersect-north start) (intersect-north answer-start))
(= (intersect-east start) (intersect-east answer-start))
(= (intersect-north stop) (intersect-north answer-stop))
(= (intersect-east stop) (intersect-east answer-stop))
(= max-dist (sub1 (length intersections)))
(connected? intersections neighbor-fun))))
) ;cond
)
(define (test-route-to start end neighborhood-fun max-dist)
;; call route-to for given start and end intersections using
;; neighborhood-fun; print result, confirm it's connected,
;; and confirm that it's length is max-dist
;; intersection X intersection X neighborhood-function X nat -> void
(reset *neighborhood-count*)
(display "----------------------------------------\n")
(let* ((_ (display (format "(route-to ~s ~s ~s):\n"
(intersect->list start)
(intersect->list end)
neighborhood-fun)))
(answer (route-to start end neighborhood-fun))
)
;; cases: fail in both: just report num neighbor calls
;; fail in route-to: missed path error
;; fail in max-dist: unexpected path
;; path in both: do following
(cond ((and (equal? max-dist 'fail) (equal? answer 'fail))
(begin
(display (format "No route from ~s to ~s.\n"
(intersect->list start)
(intersect->list end)))
(report-num-neighbor-calls)
))
((equal? answer 'fail)
(display (format "!! ERROR: path from ~s to ~s not found!\n"
(intersect->list start)
(intersect->list end))
))
((equal? max-dist 'fail)
(display (format "!! ERROR: invalid path ~s from ~s to ~s!\n"
(map intersect->list answer)
(intersect->list start)
(intersect->list end))
))
(true
(begin
(display "Path:\n")
(pretty-print (map intersect->list answer))
(report-num-neighbor-calls)
(if (connected? answer neighborhood-fun)
empty
(display (format
"!! ERROR: invalid path from ~s to ~s:\n ~s"
(intersect->list start)
(intersect->list end)
(map intersect->list answer))))
(if (minimal-route? answer neighborhood-fun start end max-dist)
empty
(display (format
"!! ERROR: route not minimal; one can go from ~s to ~s in ~s steps.\n"
(intersect->list start) (intersect->list end)
max-dist)))
) ; begin
)
) ; cond
) ; let*
) ; define
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; test cases
(define (test1-a)
(test-route-to (make-intersect 1 1) (make-intersect 1 1)
2-way-neighbors 0))
(define (test1-b)
(test-route-to (make-intersect 1 1) (make-intersect 2 1)
2-way-neighbors 1))
(define (test1-c)
(test-route-to (make-intersect 1 1) (make-intersect 2 2)
2-way-neighbors 2))
(define (test1-d)
(test-route-to (make-intersect 4 5) (make-intersect 2 1)
2-way-neighbors 6))
(define (test2-a)
(test-route-to (make-intersect 1 1) (make-intersect 1 1)
1-way-neighbors 0))
(define (test2-b)
(test-route-to (make-intersect 1 1) (make-intersect 2 2)
1-way-neighbors 'fail))
(define (test2-c)
(test-route-to (make-intersect 2 2) (make-intersect 1 1)
1-way-neighbors 4))
(define (test2-d)
(test-route-to (make-intersect 2 6) (make-intersect 2 2)
1-way-neighbors 8))
(define (test3-a)
(test-route-to (make-intersect 4 4) (make-intersect 1 2)
village-neighbors-1 11))
(define (test3-b)
(test-route-to (make-intersect 1 2) (make-intersect 4 4)
village-neighbors-1 11))
(define (test3-c)
(test-route-to (make-intersect 4 4) (make-intersect 1 2)
village-neighbors-2 11))
(define (test3-d)
(test-route-to (make-intersect 1 2) (make-intersect 4 4)
village-neighbors-2 11))
(define (test3-e)
(test-route-to (make-intersect 4 4) (make-intersect 1 2)
village-neighbors-3 9))
(define (test3-f)
(test-route-to (make-intersect 1 2) (make-intersect 4 4)
village-neighbors-3 11))
(define (test4-a)
(test-route-to (make-intersect 1 1) (make-intersect 6 1)
neighbors-after-bombing 19))
(define (test4-b)
(test-route-to (make-intersect 6 1) (make-intersect 1 1)
neighbors-after-bombing 19))
Raw
test.scm
(load "as7.scm")
(load "streets.scm")
;; Utility Functions
(define (dump-state st)
(list 'total (+ (state-cost st) (state-est st))
'@ (list (intersect-north (state-int st))
(intersect-east (state-int st)))
'cost (state-cost st)
'est (state-est st)))
(define (test0)
(display "Testing Part 0. queue\n\n")
(define (dump-queue-for-test0 q)
(if (empty? q)
empty
(cons (dump-state (first-state-in-queue q))
(dump-queue-for-test0 (rest-of-state-queue q))))
)
(define q1 (add-state-to-queue (make-state (make-intersect 5 6) 7 12 empty)
empty))
(display (format "q1: ~s:\n" (dump-state (first-state-in-queue q1))))
(display (format "Rest of q1: ~s\n\n" (rest-of-state-queue q1)))
(define q2a (add-state-to-queue (make-state (make-intersect 1 4) 3 1 empty)
q1))
(display (format "head of q2a: ~s\n" (dump-state (first-state-in-queue q2a))))
(display "full q2a: ")
(pretty-print (dump-queue-for-test0 q2a))
(display (format "equal rest of q2a to q1: ~s\n"
(equal? q1 (rest-of-state-queue q2a))))
(display "q2a without (1 4): ")
(pretty-print
(dump-queue-for-test0 (remove-state-from-queue
(make-state (make-intersect 1 4) 3 1 empty)
q2a)))
(display "q2a without (5 6): ")
(pretty-print
(dump-queue-for-test0 (remove-state-from-queue
(make-state (make-intersect 5 6) 7 12 empty)
q2a)))
(display "\n")
(define q2b (add-state-to-queue (make-state (make-intersect 4 1) 9 8 empty)
q1))
(display "q2b: ")
(pretty-print (dump-queue-for-test0 q2b))
(display "\n")
(define q2c (add-state-to-queue (make-state (make-intersect 9 2) 12 7 empty)
q1))
(display "q2c: ")
(pretty-print (dump-queue-for-test0 q2c))
(display "\n")
(define q3 (add-state-to-queue (make-state (make-intersect 1 6) 5 1 empty)
q2a))
(display "q3:\n")
(pretty-print (dump-queue-for-test0 q3))
(display "\n")
(define q7 (add-state-to-queue
(make-state (make-intersect 7 12) 14 5 empty)
(add-state-to-queue
(make-state (make-intersect 3 7) 0 1 empty)
(add-state-to-queue
(make-state (make-intersect 8 7) 19 1 empty)
(add-state-to-queue (make-state (make-intersect 0 4) 6 0 empty)
q3))))
)
(display "q7:\n")
(pretty-print (dump-queue-for-test0 q7))
(display "\n")
(display "q7 with additional cost 1 state:\n")
(pretty-print (dump-queue-for-test0
(add-state-to-queue (make-state (make-intersect 13 17) 1 0 empty)
q7)))
(display "\n")
(define q8 (rest-of-state-queue
(rest-of-state-queue (rest-of-state-queue q7))))
(display (format "head of q8: ~s\n\n" (dump-state (first-state-in-queue q8))))
(define q9 (add-state-to-queue
(make-state (make-intersect 0 0) 0 0 empty)
(add-state-to-queue
(make-state (make-intersect 80 80) 80 0 empty) q8)))
(display "q9:\n")
(pretty-print (dump-queue-for-test0 q9))
(display "\n")
(display (format "head q9 without intersect 0 0: ~s\n"
(dump-state (first-state-in-queue
(remove-state-from-queue
(make-state (intersect 0 0) 0 0 empty) q9)))
)
)
(display "q9 without 80 80:\n")
(pretty-print
(dump-queue-for-test0
(remove-state-from-queue (make-state (intersect 80 80) 80 0 empty) q9)))
(define q9-sans-56
(remove-state-from-queue (make-state (intersect 5 6) 7 12 empty)
q9))
(display "q9 without (5 6):\n")
(pretty-print (dump-queue-for-test0 q9-sans-56))
(display "q9 w/o (5 6) as well as (7 12) and (8 7):\n")
(pretty-print
(dump-queue-for-test0
(remove-state-from-queue
(make-state (intersect 8 7) 19 1 empty)
(remove-state-from-queue (make-state (intersect 7 12) 14 5 empty)
q9-sans-56)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment