;;; B551 Fall 08 ;;; Hwk 2 (Search) solution ;;; Mark Wilson ;;; ;;; Manhattan-distance division fixed, 2008-12-2 (thanks Yuheng) ;;; This solution set makes use of some simple data structures, ;;; including a queue for fringe nodes in uniformed search, a (simple) hashtable ;;; for the node history, and a priority queue for fringe nodes in informed search. ;;; This runs faster but is longer and more complicated to read. For a more ;;; readable solution, see the simplified solution set. ;;; ;;; (Note that, although this version runs faster, its informed search doesn't always ;;; find the same [or even as good a] solution as the informed search in the simplified solution: ;;; since the priority queues are maintained differently, equal-valued nodes may ;;; not be pulled out in the same order.) ;;;------------------------------------------------------------------------------ ;;; The original skeleton code for the assignment (define make-node (lambda (state parent operator depth path-cost) (list state parent operator depth path-cost))) (define general-search (lambda (queue test-procedure expand-procedure limit num-runs output-procedure) (cond [(null? queue) #f] [(test-procedure (car queue)) (output-procedure num-runs (car queue))] [(zero? limit) "Limit reached"] [else (general-search (expand-procedure (car queue) (cdr queue)) test-procedure expand-procedure (sub1 limit) (add1 num-runs) output-procedure)]))) ;;;----------------------------------------------------------- ;;; Some helpful things for working with "nodes" ;; (define node-state (lambda (node) (list-ref node 0))) (define node-parent (lambda (node) (list-ref node 1))) (define node-op (lambda (node) (list-ref node 2))) (define node-depth (lambda (node) (list-ref node 3))) (define node-cost (lambda (node) (list-ref node 4))) (define make-op (lambda (pos dir) (list pos dir))) ;;;----------------------------------------------------------- ;;; Basics of board operations ;; State is represented as a list ;; 'blank represents the empty spot (define make-state (lambda (nw n ne w c e sw s se) (list nw n ne w c e sw s se))) ;; Some lists of useful symbols ; The positions of a list (define pos-ls '(nw n ne w c e sw s se)) ; Directions we can move (define mv-ls '(n e s w)) ; And their opposites (define mv-inv-ls '(s w n e)) ; Get a list index from a symbol representing a position on the board ; (Used for looking up a position in a state list) (define ref-from-pos (lambda (sym) (case sym [(nw) 0] [(n) 1] [(ne) 2] [(w) 3] [(c) 4] [(e) 5] [(sw) 6] [(s) 7] [(se) 8]))) ; Get a symbol corresponding to a given list position ; (inverse of ref-from-pos) (define pos-from-ref (lambda (ref) (case ref [(0) 'nw] [(1) 'n] [(2) 'ne] [(3) 'w] [(4) 'c] [(5) 'e] [(6) 'sw] [(7) 's] [(8) 'se]))) ;; Another way to do the above conversions is to look through lists ;(define find-pos ; (lambda (sym ls) ; (letrec ((find-pos-tail ; (lambda (sym ls a) ; (if (eq? (car ls) sym) ; a ; (find-pos-tail sym ls (add1 a)))))) ; (find-pos-tail sym ls 0)))) ; ;(define ref-from-pos ; (lambda (sym) ; (find-pos sym pos-ls))) ;(define pos-from-ref ; (lambda (ref) ; (list-ref pos-ls ref))) ; Given a position "pos" and a direction "dir", gives the ; symbol for the position one step from pos in dir ; Gives symbol 'dne if the move is out of bounds (define neighbor (lambda (pos dir) ; Get the list index corresponding to the position (let ((posn (ref-from-pos pos))) (case dir ; if moving north, the new position is the old one - 3 [(n) (if (< posn 3) 'dne (pos-from-ref (- posn 3)))] ; if moving east, the new position is the old one + 1 [(e) (if (= (modulo posn 3) 2) 'dne (pos-from-ref (+ posn 1)))] ; if moving south, the new position is the old one + 3 [(s) (if (> posn 5) 'dne (pos-from-ref (+ posn 3)))] ; if moving west, the new position is the old one - 1 [(w) (if (= (modulo posn 3) 0) 'dne (pos-from-ref (- posn 1)))])))) ; Gives the value at a given position on a board -- a ; numbered tile or the symbol 'blank (define board-val (lambda (board pos) (list-ref board (ref-from-pos pos)))) ; Finds the position of the blank on a given board (define blank-pos (lambda (board) (letrec ((find-blank-tail (lambda (board a) (if (eq? (car board) 'blank) (pos-from-ref a) (find-blank-tail (cdr board) (add1 a)))))) (find-blank-tail board 0)))) ; Given a board, a tile position, and a direction to move it in, ; gives #t if the move is possible and #f otherwise (define can-move? (lambda (board pos dir) (if (eq? pos 'dne) #f (let ((newpos (neighbor pos dir))) ; possible only if the new position exists and contains a blank (and (not (eq? newpos 'dne)) (eq? (board-val board newpos) 'blank)))))) ; Given a board, a position, and a direction, returns the board ; resulting from the indicated move. (define move (lambda (board pos dir) (if (not (can-move? board pos dir)) ; Make sure we don't do anything illegal (error 'move "Can't move from ~a toward ~a" pos dir) ; Otherwise, convert the board to a vector, make the move, and convert back to a list. ; (Gives us two linear-time ops as opposed to three [including the ref]) (let ((newpos (neighbor pos dir)) (boardv (list->vector board))) (begin (vector-set! boardv (ref-from-pos newpos) (vector-ref boardv (ref-from-pos pos))) (vector-set! boardv (ref-from-pos pos) 'blank) (vector->list boardv)))))) ; Tests two boards for equality (define board-eq? (lambda (board1 board2) (cond ((null? board1) (if (null? board2) #t #f)) ((eq? (car board1) (car board2)) (board-eq? (cdr board1) (cdr board2))) (else #f)))) ; Given a goal board, gives a one-argument goal test function ; (useful for the skeleton code) (define goal-board? (lambda (goal) (lambda (test) (board-eq? goal test)))) ;;;------------------------------------------------------------ ;;; A queue data structure ;;; Lists make great stacks, but horrible queues, which slows BFS down ;;; Real queues speed things up ;; This one's adapted from The Scheme Programming Language ;; (see Section 2.9, Assignment) ;; (define make-queue (lambda () (let ((end (cons 'ignored '()))) (cons end end)))) (define putq! (lambda (q v) (let ((end (cons 'ignored '()))) (set-car! (cdr q) v) (set-cdr! (cdr q) end) (set-cdr! q end)))) ; putting at front of list lets us use it as a DFS stack too (define putq-front! (lambda (q v) (let ((n (cons v '()))) (set-cdr! n (car q)) (set-car! q n)))) (define getq (lambda (q) (car (car q)))) (define emptyq? (lambda (q) (eq? (getq q) 'ignored))) (define delq! (lambda (q) (set-car! q (cdr (car q))))) ;;;------------------------------------------------------------------------------ ;;; Maintaining a history of visited nodes ;;; I've used a (very) basic hashtable with lists for collisions ; a good hashtable-size prime in the neighborhood of 50,000 (define history-size 49157) ; the history is a hashtable (stored in a vector) of lists containing boards (define history (make-vector history-size '())) ; a useful list of the first nine prime numbers (define prime-ls '(29 23 19 17 13 11 7 5 3)) ; a simple (possibly simple-minded) hashing function (define board-hash (lambda (board) (let loop ((ls board) (a 0) (primes prime-ls)) (if (null? ls) ; if we've hashed the whole board, return the accumulator (modulo a history-size) ; otherwise, add to the accumulator a prime number ; times the tile at the current position and recur ; on the board and prime numbers (loop (cdr ls) (+ a (* (if (eq? 'blank (car ls)) 9 (car ls)) (car primes))) (cdr primes)))))) ; empty the history (define history-reset (lambda () (vector-fill! history '()))) ; check to see if a board is in a particular list from the hashtable (define history-search (lambda (board ls) (cond [(null? ls) #f] [(board-eq? (car ls) board) #t] [else (history-search board (cdr ls))]))) ; put a board in the history (define add-to-history (lambda (board) ; hash the board (let ((index (board-hash board))) ; add it to the list at that index and stick the new list in the vector (vector-set! history index (cons board (vector-ref history index)))))) ; look for a board in the hashtable (define in-history? (lambda (board) ; hash the board (let ((index (board-hash board))) ; look for it in the list at that index (history-search board (vector-ref history index))))) ;;;------------------------------------------------------------------------------- ;;; The guts for uninformed search ;; ; A version of general-search that works with the TSPL queue (define general-search-tspl-q (lambda (queue test-procedure expand-procedure limit num-runs output-procedure) (cond ; Check the tspl queue [(emptyq? queue) #f] ; Get the first element of the tspl queue [(test-procedure (node-state (getq queue))) (output-procedure num-runs (getq queue))] [(zero? limit) "Limit reached"] [else ; Get the first element of the tspl queue (let ((node (getq queue))) ; Remove that element (delq! queue) ; Expand the node (alters the queue in-place) (expand-procedure node queue) ; Recur on the altered queue (general-search-tspl-q queue test-procedure expand-procedure (sub1 limit) (add1 num-runs) output-procedure))]))) ; basic expansion, provides a list of moves we can make from one node (define expand (lambda (node eval-fn) (let* ((board (node-state node)) (blankpos (blank-pos board))) (letrec ((expand-moves ; given a list of moves, their opposites, and an accumulator of altered boards (lambda (mv mv-inv a) (if (null? mv) ; if no more moves to compute, give the accumulator a ; compute the tile to be moved (a neighbor of the blank), its direction, and whether the move is legal (let* ((mv-tile (neighbor blankpos (car mv))) (mv-dir (car mv-inv)) (can-move (can-move? board mv-tile mv-dir))) (if can-move ; if the move is legal, compute it (let ((nboard (move board mv-tile mv-dir))) (if (not (in-history? nboard)) ; if the new board is not in our history, add it to the history and our accumulator, and recur ; on the list of moves to compute (begin (add-to-history nboard) (expand-moves (cdr mv) (cdr mv-inv) (cons (make-node nboard node (make-op mv-tile mv-dir) (add1 (node-depth node)) (eval-fn nboard)) a))) ; if the new board is in our history, just recur on the list of moves (expand-moves (cdr mv) (cdr mv-inv) a))) ; if the new board isn't legal, just recur on the list of moves (expand-moves (cdr mv) (cdr mv-inv) a))))))) (expand-moves mv-ls mv-inv-ls '()))))) (define cost1 (lambda (board) 1)) ; A BFS expand procedure that works with the TSPL queue (define expand-bfs-tspl-q (lambda (node q) (letrec ((add-nodes ; given a list of expanded nodes (lambda (exp-ls) (if (null? exp-ls) ; if the end of the list, return #t (begin ; otherwise, put a node at the back of the queue (in-place) (putq! q (car exp-ls)) ; and recur (add-nodes (cdr exp-ls))))))) (let ((exp-ls (expand node cost1))) (add-nodes exp-ls))))) ; A DFS expand procedure that works with the TSPL queue (define expand-dfs-tspl-q (lambda (node q) (letrec ((add-nodes (lambda (exp-ls) (if (null? exp-ls) #t (begin ; just like bfs expansion, except we add to the front of the queue (putq-front! q (car exp-ls)) (add-nodes (cdr exp-ls))))))) (let ((exp-ls (expand node cost1))) (add-nodes exp-ls))))) ;;;-------------------------------------------------------------------------------------- ;;; Binary min-heap (for best-first search) ;;; ;;; Since best-first search relies on pulling out the "best" move from a queue, ;;; our most efficient strategy is to have a priority queue which orders expanded nodes ;;; by their value according to our heuristic. ;;; ;;; I've implemented a binary min-heap in a vector ; given a vector index, calculate the index of the parent node in the heap (define heap-parent (lambda (n) (if (odd? n) (/ (- n 1) 2) (/ (- n 2) 2)))) ; given a vector index, calculate the index of the left child in the heap (define heap-lchild (lambda (n) (+ (* n 2) 1))) ; given a vector index, calculate the index of the right child in the heap (define heap-rchild (lambda (n) (+ (* n 2) 2))) ; make a heap of a size and fill it with default values (define make-heap-h (lambda (size) ; cons cell with vector in car and the next-empty-element index in cdr (cons (make-vector size #f) 0))) ; a generic make-heap function (define make-heap (lambda args (case (length args) [(0) (make-heap-h 10)] [(1) (make-heap-h (car args))] [else (error 'make-heap "make-heap takes 0 or 1 arguments")]))) ; get the entire entry (key . value) at a given index (define heap-entry (lambda (heap n) (vector-ref (car heap) n))) ; get the key from a given index (define heap-key (lambda (heap n) (car (heap-entry heap n)))) ; get the value from a given index (define heap-val (lambda (heap n) (cdr (heap-entry heap n)))) ; does the heap contain any elements? (define heap-empty? (lambda (heap) ; if there's no root, there are no other elements (not (heap-entry heap 0)))) ; start at the last element in the heap and switch upwards as necessary ; modifies the given heap in-place (define heapify! (lambda (heap) (let loop ((index (sub1 (cdr heap)))) (cond ; if we've reached the top of the heap, return [(= index 0) #t] ; if the current entry has a lower key than its parent, switch them and recur [(< (heap-key heap index) (heap-key heap (heap-parent index))) (let ((tmp (heap-entry heap (heap-parent index)))) (vector-set! (car heap) (heap-parent index) (heap-entry heap index)) (vector-set! (car heap) index tmp) (loop (heap-parent index)))] ; otherwise, we're done [else #t])))) ; start at the root of the heap and switch downwards as necessary ; modifies the heap in-place (define heapify-down! (lambda (heap) ; the loop point, set up the index and the child indices (let loop ((index 0) (lchild 1) (rchild 2)) (cond ; if the left child doesn't exist, we're at a leaf [(or (>= lchild (vector-length (car heap))) (not (heap-entry heap lchild))) #t] ; otherwise, swap with the maximal child if it's greater than this [else (let ((max-i (cond ; if right child doesn't exist, left child is maximal [(or (>= rchild (vector-length (car heap))) (not (heap-entry heap rchild))) lchild] ; if left child has a greater key than right, left child is maximal [(> (heap-key heap lchild) (heap-key heap rchild)) lchild] ; otherwise, right child is maximal [else rchild]))) (if (> (heap-key heap index) (heap-key heap max-i)) ; if the maximal child has a greater key than the current element, swap them and loop (let ((tmp (heap-entry heap max-i))) (vector-set! (car heap) max-i (heap-entry heap index)) (vector-set! (car heap) index tmp) (loop max-i (heap-lchild max-i) (heap-rchild max-i))) ; if the maximal child is less than the current element, we're done #t))])))) ; make a heap bigger (define heap-resize! (lambda (heap) ; make a new vector 2 times as big as this one (let loop ((newv (make-vector (* 2 (cdr heap)) #f)) (i 0) (m (cdr heap))) (cond ; if we've reached the last element of the old heap, attach the new vector to the heap [(= i m) (set-car! heap newv)] ; otherwise, copy an entry and recur [else (begin (vector-set! newv i (heap-entry heap i)) (loop newv (add1 i) m))])))) ; adds an entry with the given key and value to the heap ; (modifies the heap in-place) (define heap-add! (lambda (heap k v) (begin ; set the next empty element of the heap to a cons cell with the key and value (vector-set! (car heap) (cdr heap) (cons k v)) ; update the next-empty-element value (set-cdr! heap (add1 (cdr heap))) (heapify! heap) ; if the heap's run out of room, resize it (if (>= (cdr heap) (vector-length (car heap))) (heap-resize! heap))))) ; return the value of the smallest-keyed element in the heap (define heap-get (lambda (heap) (heap-val heap 0))) ; remove the smallest-keyed element in the heap (define heap-del! (lambda (heap) (begin ; update the next-empty-element value (set-cdr! heap (sub1 (cdr heap))) ; move the last (rightmost on the bottom row) element of the heap to the root (vector-set! (car heap) 0 (heap-entry heap (cdr heap))) ; make the last element empty (vector-set! (car heap) (cdr heap) #f) (heapify-down! heap)))) ;;;---------------------------------------------------------------------------------- ;;; Informed search ;;; A Best-first implementation ;; ; helper function for the heuristic, finds a given value in a list (define vector-find (lambda (v n) (let loop ((i 0)) (cond [(eq? (vector-ref v i) n) i] [else (loop (add1 i))])))) ; A simple heuristic: sum of Manhattan distance from goal for all 8 tiles (define manhattan (lambda (board1 board2) (let ((boardv1 (list->vector board1)) (boardv2 (list->vector board2))) (let loop ((i 1) (a 0)) (cond [(= i 9) a] [else (let ((p1 (vector-find boardv1 i)) (p2 (vector-find boardv2 i))) (loop (add1 i) (+ a (+ (modulo (abs (- p2 p1)) 3) (quotient (abs (- p2 p1)) 3)))))]))))) ; A version of general-search that works with the min-heap ; basically the same as general-search-tspl-queue but with the heap instead (define general-search-min-heap (lambda (queue test-procedure expand-procedure limit num-runs output-procedure) (cond [(heap-empty? queue) #f] [(test-procedure (node-state (heap-get queue))) (output-procedure num-runs (heap-get queue))] [(zero? limit) "Limit reached"] [else (let ((node (heap-get queue))) (heap-del! queue) (expand-procedure node queue) (general-search-min-heap queue test-procedure expand-procedure (sub1 limit) (add1 num-runs) output-procedure))]))) ; A best-first expansion working with the priority queue (define expand-best-min-heap (lambda (node q eval-fn) (letrec ((add-nodes (lambda (exp-ls) (if (null? exp-ls) #t (begin (heap-add! q (node-cost (car exp-ls)) (car exp-ls)) (add-nodes (cdr exp-ls))))))) (let ((exp-ls (expand node eval-fn))) (add-nodes exp-ls))))) (define expand-best-min-heap-wrap (lambda (eval-fn) (lambda (node q) (expand-best-min-heap node q eval-fn)))) ;;;------------------------------------------------------------------------------ ;;; Output ;; ; builds a formatted string representing a board ; suitable for use with printf (define board-string (lambda (board) (letrec ((board-string-h ; given a string buffer, a list of board positions, and a count accumulator (lambda (buf pos-ls count) (if (null? pos-ls) ; if no more positions to write, we return the buffer buf ; otherwise, append to the buffer and recur (board-string-h (string-append buf ; print numbers as numbers and the 'blank as a blank space (if (number? (board-val board (car pos-ls))) (number->string (board-val board (car pos-ls))) " ") ; if we've printed three positions, insert a newline (if (= (modulo count 3) 2) "~%" " ")) (cdr pos-ls) (add1 count)))))) (board-string-h "" pos-ls 0)))) ; builds a formatted string representing a tree node ; suitable for use with printf (define node-string (lambda (node) (string-append "Tile moved: " (symbol->string (car (node-op node))) "~%In direction: " (symbol->string (cadr (node-op node))) "~%Depth: " (number->string (node-depth node)) "~%Path-cost: " (number->string (node-cost node)) "~%" (board-string (node-state node))))) ; builds a formatted string representing a chain (path) of tree nodes (define chain-string (lambda (node) (letrec ((chain-string-h ; given a node and a string buffer (lambda (node str) (if (null? (node-parent node)) ; if the node has no parent, just append the buffer to its string and return (string-append (node-string node) str) ; otherwise, append the buffer to its string and recur on the parent (chain-string-h (node-parent node) (string-append (node-string node) str)))))) (chain-string-h node "")))) ; prints a chain (path) of tree nodes (define output-chain ; given number of nodes searched and a result node (lambda (n node) ; output the path's string and the number of nodes searched (printf (string-append (chain-string node) "~%" "Searched " (number->string n) " nodes~%")))) ;;;--------------------------------------------------------------------------------------- ;;; Interface ;; (define test-bfs (lambda (init goal limit) (let ((q (make-queue))) (history-reset) (printf "Initializing queue...~%") (putq! q (make-node init '() (make-op 'dne 'dne) 0 0)) (printf "Running general search...~%") (general-search-tspl-q q (goal-board? goal) expand-bfs-tspl-q limit 0 output-chain)))) (define test-dfs (lambda (init goal limit) (let ((q (make-queue))) (history-reset) (printf "Initializing queue...~%") (putq! q (make-node init '() (make-op 'dne 'dne) 0 0)) (printf "Running general search...~%") (general-search-tspl-q q (goal-board? goal) expand-dfs-tspl-q limit 0 output-chain)))) (define test-uninformed-search (lambda (init goal limit) (test-bfs init goal limit))) (define test-best (lambda (init goal limit) (let ((q (make-heap 50000))) (history-reset) (printf "Initializing queue...~%") (heap-add! q (manhattan init goal) (make-node init '() (make-op 'dne 'dne) 0 0)) (printf "Running general search...~%") (general-search-min-heap q (goal-board? goal) (expand-best-min-heap-wrap (lambda (board) (manhattan board goal))) limit 0 output-chain)))) (define test-informed-search (lambda (init goal limit) (test-best init goal limit))) (define make-initial-state (lambda (nw n ne w c e sw s se) (make-state nw n ne w c e sw s se))) (define make-goal-state (lambda (nw n ne w c e sw s se) (make-state nw n ne w c e sw s se)))