I am trying to take a list representing a binary search tree and output a list elements in order so (displayBST '(10(5(3(2()())())())())) -> (2 3 5 10). All I can seem to mange to get is list looking like (((2 3) 5) 10) and I am not sure how to make all numbers base elements.
(let((SUMS))
(defun displayBST(elements)
;IF NO ELEMENTS return SUMS
(cond((null elements)
nil)
;if both branches null return first element
((and(null (second elements))(null (third elements)))
(print (first elements))
(first elements))
;if left branch not null
((not(null (second elements)))
;if right branch null
(cond((null (third elements))
;set SUMS to (left branch) and first element
(setf SUMS (list (displayBST(second elements)) (first elements))))
;else set SUMS to (left branch) and first element and (right branch)
(t(SETF sums (append (displayBST(second elements))(first elements)(displayBST(third elements)))))))
;if left branch null and right not null
((not (null(third elements)))
;set SUMS to first element and (right branch)
(setf SUMS (list (first elements) (displayBST(third elements))))))))
Think about how you join a given element to the value returned recursively by the function. If you want X + Y = (X Y) you should use (cons X (list Y)). Therefore the base case (i.e. (null (second elements)) and (null (third elements)) should return (list (first elements)).
What you want is something like this:
(let((SUMS))
(defun displayBST(elements)
;IF NO ELEMENTS return SUMS
(cond((null elements)
nil)
;if both branches null return first element
((and(null (second elements))(null (third elements)))
(print (first elements))
(list (first elements)))
;if left branch not null
((not(null (second elements)))
;if right branch null
(cond((null (third elements))
;set SUMS to (left branch) and first element
(setf SUMS (append (displayBST(second elements)) (list (first elements)))))
;else set SUMS to (left branch) and first element and (right branch)
(t(SETF sums (append (displayBST(second elements))(first elements)(displayBST(third elements)))))))
;if left branch null and right not null
((not (null(third elements)))
;set SUMS to first element and (right branch)
(setf SUMS (cons (first elements) (displayBST(third elements))))))))
Related
I'm arduously struggling my way through the N-queens problem in SICP (the book; I spent a few days on it -- last question here: Solving Eight-queens in scheme). Here is what I have for the helper functions:
#lang sicp
; the SICP language in Racket already defines this:
; (define nil '()
; boilerplate: filter function and range functions
(define (filter func lst)
(cond
((null? lst)
nil)
(else
(if (func (car lst))
(cons (car lst) (filter func (cdr lst)))
(filter func (cdr lst))))))
(define (range a b)
(if (> a b)
nil
(cons a (range (+ 1 a) b))))
; Selectors/handlers to avoid confusion on the (col, row) notation:
; representing it a position as (col, row), using 1-based indexing
(define (make-position col row) (cons col (list row)))
(define (col p) (car p))
(define (row p) (cadr p))
; adding a new position to a board
(define (add-new-position existing-positions p)
(append existing-positions
(list (make-position (col p) (row p)))))
; The 'safe' function
(define (any? l proc)
(cond ((null? l) #f)
((proc (car l)) #t)
(else (any? (cdr l) proc))))
(define (none? l proc) (not (any? l proc)))
(define (safe? existing-positions p)
(let ((bool (lambda (x) x)) (r (row p)) (c (col p)))
(and
; is the row safe? i.e., no other queen occupies that row?
(none? (map (lambda (p) (= (row p) r)) existing-positions)
bool)
; safe from the diagonal going up
(none? (map (lambda (p) (= r (+ (row p) (- c (col p)))))
existing-positions)
bool)
; safe from the diagonal going down
(none? (map (lambda (p) (= r (- (row p) (- c (col p)))))
existing-positions)
bool))))
And now, with that boilerplate, the actual/monstrous first working version I have of the queens problem:
(define (positions-for-col col size)
(map (lambda (ri) (make-position col ri))
(range 1 size)))
(define (queens board-size)
(define possible-positions '())
(define safe-positions '())
(define all-new-position-lists '())
(define all-positions-list '())
; existing-positions is a LIST of pairs
(define (queen-cols col existing-positions)
(if (> col board-size)
(begin
(set! all-positions-list
(append all-positions-list (list existing-positions))))
(begin
; for the column, generate all possible positions,
; for example (3 1) (3 2) (3 3) ...
(set! possible-positions (positions-for-col col board-size))
; (display "Possible positions: ") (display possible-positions) (newline)
; filter out the positions that are not safe from existing queens
(set! safe-positions
(filter (lambda (pos) (safe? existing-positions pos))
possible-positions))
; (display "Safe positions: ") (display safe-positions) (newline)
(if (null? safe-positions)
; bail if we don't have any safe positions
'()
; otherwise, build a list of positions for each safe possibility
; and recursively call the function for the next column
(begin
(set! all-new-position-lists
(map (lambda (pos)
(add-new-position existing-positions pos))
safe-positions))
; (display "All positions lists: ") (display all-new-position-lists) (newline)
; call itself for the next column
(map (lambda (positions-list) (queen-cols (+ 1 col)
positions-list))
all-new-position-lists))))))
(queen-cols 1 '())
all-positions-list)
(queens 5)
(((1 1) (2 3) (3 5) (4 2) (5 4))
((1 1) (2 4) (3 2) (4 5) (5 3))
((1 2) (2 4) (3 1) (4 3) (5 5))
((1 2) (2 5) (3 3) (4 1) (5 4))
((1 3) (2 1) (3 4) (4 2) (5 5))
To be honest, I think I did all the set!s so that I could more easily debug things (is that common?) How could I remove the various set!s to make this a proper functional-procedure?
As an update, the most 'terse' I was able to get it is as follows, though it still appends to a list to build the positions:
(define (queens board-size)
(define all-positions-list '())
(define (queen-cols col existing-positions)
(if (> col board-size)
(begin
(set! all-positions-list
(append all-positions-list
(list existing-positions))))
(map (lambda (positions-list)
(queen-cols (+ 1 col) positions-list))
(map (lambda (pos)
(add-new-position existing-positions pos))
(filter (lambda (pos)
(safe? existing-positions pos))
(positions-for-col col board-size))))))
(queen-cols 1 nil)
all-positions-list)
Finally, I think here is the best I can do, making utilization of a 'flatmap' function that helps deal with nested lists:
; flatmap to help with reduction
(define (reduce function sequence initializer)
(let ((elem (if (null? sequence) nil (car sequence)))
(rest (if (null? sequence) nil (cdr sequence))))
(if (null? sequence)
initializer
(function elem
(reduce function rest initializer)))))
(define (flatmap proc seq)
(reduce append (map proc seq) nil))
; actual
(define (queens board-size)
(define (queen-cols col existing-positions)
(if (> col board-size)
(list existing-positions)
(flatmap
(lambda (positions-list)
(queen-cols (+ 1 col) positions-list))
(map
(lambda (pos)
(add-new-position existing-positions
pos))
(filter
(lambda (pos)
(safe? existing-positions pos))
(positions-for-col col board-size))))))
(queen-cols 1 nil))
Are there any advantages of this function over the one using set! or is it more a matter of preference (I find the set! one easier to read and debug).
When you are doing the SICP problems, it would be most beneficial if you strive to adhere to the spirit of the question. You can determine the spirit from the context: the topics covered till the point you are in the book, any helper code given, the terminology used etc. Specifically, avoid using parts of the scheme language that have not yet been introduced; the focus is not on whether you can solve the problem, it is on how you solve it. If you have been provided helper code, try to use it to the extent you can.
SICP has a way of building complexity; it does not introduce a concept unless it has presented enough motivation and justification for it. The underlying theme of the book is simplification through abstraction, and in this particular section you are introduced to various higher order procedures -- abstractions like accumulate, map, filter, flatmap which operate on sequences/lists, to make your code more structured, compact and ultimately easier to reason about.
As illustrated in the opening of this section, you could very well avoid the use of such higher programming constructs and still have programs that run fine, but their (liberal) use results in more structured, readable, top-down style code. It draws parallels from the design of signal processing systems, and shows how we can take inspiration from it to add structure to our code: using procedures like map, filter etc. compartmentalize our code's logic, not only making it look more hygienic but also more comprehensible.
If you prematurely use techniques which don't come until later in the book, you will be missing out on many key learnings which the authors intend for you from the present section. You need to shed the urge to think in an imperative way. Using set! is not a good way to do things in scheme, until it is. SICP forces you down a 'difficult' path by making you think in a functional manner for a reason -- it is for making your thinking (and code) elegant and 'clean'.
Just imagine how much more difficult it would be to reason about code which generates a tree recursive process, wherein each (child) function call is mutating the parameters of the function. Also, as I mentioned in the comments, assignment places additional burden upon the programmers (and on those who read their code) by making the order of the expressions have a bearing on the results of the computation, so it is harder to verify that the code does what is intended.
Edit: I just wanted to add a couple of points which I feel would add a bit more insight:
Your code using set! is not wrong (or even very inelegant), it is just that in doing so, you are being very explicit in telling what you are doing. Iteration also reduces the elegance a bit in addition to being bottom up -- it is generally harder to think bottom up.
I feel that teaching to do things recursively where possible is one of the aims of the book. You will find that recursion is a crucial technique, the use of which is inevitable throughout the book. For instance, in chapter 4, you will be writing evaluators (interpreters) where the authors evaluate the expressions recursively. Even much earlier, in section 2.3, there is the symbolic differentiation problem which is also an exercise in recursive evaluation of expressions. So even though you solved the problem imperatively (using set!, begin) and bottom-up iteration the first time, it is not the right way, as far as the problem statement is concerned.
Having said all this, here is my code for this problem (for all the structure and readability imparted by FP, comments are still indispensable):
; the board is a list of lists - a physical n x n board, where
; empty positions are 0 and filled positions are 1
(define (queens board-size)
(let ((empty-board (empty-board-gen board-size))) ; minor modification - making empty-board available to queen-cols
(define (queen-cols k)
(if (= k 0)
(list empty-board)
(filter (lambda (positions) (safe? k positions))
; the flatmap below generates a list of new positions
; by 'adjoining position'- adding 'board-size' number
; of new positions for each of the positions obtained
; recursively from (queen-cols (- k 1)), which have
; been found to be safe till column k-1. This new
; set (list) of positions is then filtered using the
; safe? function to filter out unsafe positions
(flatmap
(lambda (rest-of-queens)
; the map below adds 'board-size' number of new
; positions to 'rest-of-queens', which is an
; element of (queen-cols (- k 1))
(map (lambda (new-row)
(adjoin-position new-row k rest-of-queens))
(enumerate-interval 1 board-size)))
(queen-cols (- k 1))))))
(queen-cols board-size)) ; end of let block
)
; add a column having a queen placed at position (new-row, col).
(define (adjoin-position new-row col rest-queens)
(let ((board-dim (length rest-queens))) ;length of board
; first create a zero 'vector', put a queen in it at position
; 'new-row', then put (replace) this new vector/column at the
; 'col' position in rest-queens
(replace-elem (replace-elem 1 new-row (gen-zero-vector board-dim)) col rest-queens)))
(define (safe? k positions) ; the safe function
(let ((row-pos-k (non-zero-index (item-at-index k positions)))) ; get the row of the queen in column k
(define (iter-check col rem) ;iteratively check if column 'col' of the board is safe wrt the kth column
(let ((rw-col (non-zero-index (car rem)))) ; get the row of 'col' in which a queen is placed
(cond ((= k 1) #t); 1x1 board is always safe
((= col k) #t); if we reached the kth column, we are done
; some simple coordinate geometry
; checks if the row of the queen in col and kth
; column is same, and also checks if the 'slope' of
; the line connecting the queens of the two columns
; is 1 (i.e. if it's a diagonal), if either is true,
; the kth queen is not safe
((or (= row-pos-k rw-col) (= (- k col) (abs (- row-pos-k rw-col)))) #f)
(else (iter-check (+ col 1) (cdr rem)))))) ; check the next column
(iter-check 1 positions))) ; start checking from the first column
; helper functions follow
(define (item-at-index n items) ; given a list, return the nth element
(define (iter idx rem)
(if (= idx n)
(car rem)
(iter (+ idx 1) (cdr rem))))
(iter 1 items))
(define (non-zero-index items)
; gives the first non-zero element from items - used for
; determining the row at which a queen is placed
(define (iter a rem)
(if (> (car rem) 0)
a
(iter (+ a 1) (cdr rem))))
(iter 1 items))
(define (empty-board-gen n) ; the empty board is n lists, each list with n zeros
(map (lambda (x) (map (lambda (y) 0) (enumerate-interval 1 n))) (enumerate-interval 1 n)))
(define (replace-elem new-elem pos items) ; replace item at position pos in items by new-elem, ultimately used for replacing an empty column with a column which has a queen
(define (iter i res rem)
(if (= i pos)
(append res (list new-elem) (cdr rem))
(iter (+ i 1) (append res (list(car rem))) (cdr rem)))) (iter 1 '() items))
(define (gen-zero-vector n) ; generate a list of length n with only zeros as elements
(define (iter a res)
(if (> a n)
res
(iter (+ a 1) (append res (list 0))))) (iter 1 '()))
(define (flatmap proc seq)
(accumulate append '() (map proc seq)))
(define (length items) ; not particularly efficient way for length of a list
(accumulate + 0 (map (lambda (x) 1) items)))
(define (accumulate op null-value seq)
(if (null? seq)
null-value
(op (car seq) (accumulate op null-value (cdr seq)))))
(define (enumerate-interval low high) ; a list of integers from low to hi
(define (iter a b res)
(if (> a b)
res
(iter (+ a 1) b (append res (cons a '())))))
(iter low high '()))
There are many ways to tackle this problem. I'll attempt to write a short and concise solution using Racket-specific procedures, explaining each step of the way. A solution using only the Scheme procedures explained in SICP is also possible, but it'll be more verbose and I'd argue, more difficult to understand.
My aim is to write a functional-programming style solution reusing as many built-in procedures as possible, and avoiding mutation at all costs - this is the style that SICP encourages you to learn. I'll deviate from the template solution in SICP if I think we can get a clearer solution by reusing existing Racket procedures (it follows then, that this code must be executed using the #lang racket language), but I've provided another answer that fits exactly exercise 2.42 in the book, implemented in standard Scheme and compatible with #lang sicp.
First things first. Let's agree on how are we going to represent the board - this is a key point, the way we represent our data will have a big influence on how easy (or hard) is to implement our solution. I'll use a simple representation, with only the minimum necessary information.
Let's say a "board" is a list of row indexes. My origin of coordinates is the position (0, 0), on the top-left corner of the board. For the purpose of this exercise we only need to keep track of the row a queen is in, the column is implicitly represented by its index in the list and there can only be one queen per column. Using my representation, the list '(2 0 3 1) encodes the following board, notice how the queens' position is uniquely represented by its row number and its index:
0 1 2 3
0 . Q . .
1 . . . Q
2 Q . . .
3 . . Q .
Next, let's see how are we going to check if a new queen added at the end of the board is "safe" with respect to the previously existing queens. For this, we need to check if there are any other queens in the same row, or if there are queens in the diagonal lines starting from the new queen's position. We don't need to check for queens in the same column, we're trying to set a single new queen and there aren't any others in this row. Let's split this task in multiple procedures.
; main procedure for checking if a queen in the given
; column is "safe" in the board; there are no more
; queens to the "right" or in the same column
(define (safe? col board)
; we're only interested in the queen's row for the given column
(let ([row (list-ref board (sub1 col))])
; the queen must be safe on the row and on the diagonals
(and (safe-row? row board)
(safe-diagonals? row board))))
; check if there are any other queens in the same row,
; do this by counting how many times `row` appears in `board`
(define (safe-row? row board)
; only the queen we want to add can be in this row
; `curry` is a shorthand for writing a lambda that
; compares `row` to each element in `board`
(= (count (curry equal? row) board) 1))
; check if there are any other queens in either the "upper"
; or the "lower" diagonals starting from the current queen's
; position and going to the "left" of it
(define (safe-diagonals? row board)
; we want to traverse the row list from right-to-left so we
; reverse it, and remove the current queen from it; upper and
; lower positions are calculated starting from the current queen
(let loop ([lst (rest (reverse board))]
[upper (sub1 row)]
[lower (add1 row)])
; the queen is safe after checking all the list
(or (null? lst)
; the queen is not safe if we find another queen in
; the same row, either on the upper or lower diagonal
(and (not (= (first lst) upper))
(not (= (first lst) lower))
; check the next position, updating upper and lower
(loop (rest lst) (sub1 upper) (add1 lower))))))
Some optimizations could be done, for example stopping early if there's more than one queen in the same row or stopping when the diagonals' rows fall outside of the board, but they'll make the code harder to understand and I'll leave them as an exercise for the reader.
In the book they suggest we use an adjoin-position procedure that receives both row and column parameters; with my representation we only need the row so I'm renaming it to add-queen, it simply adds a new queen at the end of a board:
; add a new queen's row to the end of the board
(define (add-queen queen-row board)
(append board (list queen-row)))
Now for the fun part. With all of the above procedures in place, we need to try out different combinations of queens and filter out those that are not safe. We'll use higher-order procedures and recursion for implementing this backtracking solution, there's no need to use set! at all as long as we're in the right mindset.
This will be easier to understand if you read if from the "inside out", try to grok what the inner parts do before going to the outer parts, and always remember that we're unwinding our way in a recursive process: the first case that will get executed is when we have an empty board, the next case is when we have a board with only one queen in position and so on, until we finally have a full board.
; main procedure: returns a list of all safe boards of the given
; size using our previously defined board representation
(define (queens board-size)
; we need two values to perform our computation:
; `queen-col`: current row of the queen we're attempting to set
; `board-size`: the full size of the board we're trying to fill
; I implemented this with a named let instead of the book's
; `queen-cols` nested procedure
(let loop ([queen-col board-size])
; if there are no more columns to try exit the recursion
(if (zero? queen-col)
; base case: return a list with an empty list as its only
; element; remember that the output is a list of lists
; the book's `empty-board` is just the empty list '()
(list '())
; we'll generate queen combinations below, but only the
; safe ones will survive for the next recursive call
(filter (λ (board) (safe? queen-col board))
; append-map will flatten the results as we go, we want
; a list of lists, not a list of lists of lists of...
; this is equivalent to the book's flatmap implementation
(append-map
(λ (previous-boards)
(map (λ (new-queen-row)
; add a new queen row to each one of
; the previous valid boards we found
(add-queen new-queen-row previous-boards))
; generate all possible queen row values for this
; board size, this is similar to the book's
; `enumerate-interval` but starting from zero
(range board-size)))
; advance the recursion, try a smaller column
; position, as the recursion unwinds this will
; return only previous valid boards
(loop (sub1 queen-col)))))))
And that's all there is to it! I'll provide a couple of printing procedures (useful for testing) which should be self-explanatory; they take my compact board representation and print it in a more readable way. Queens are represented by 'o and empty spaces by 'x:
(define (print-board board)
(for-each (λ (row) (printf "~a~n" row))
(map (λ (row)
(map (λ (col) (if (= row col) 'o 'x))
board))
(range (length board)))))
(define (print-all-boards boards)
(for-each (λ (board) (print-board board) (newline))
boards))
We can verify that things work and that the number of solutions for the 8-queens problem is as expected:
(length (queens 8))
=> 92
(print-all-boards (queens 4))
(x x o x)
(o x x x)
(x x x o)
(x o x x)
(x o x x)
(x x x o)
(o x x x)
(x x o x)
As a bonus, here's another solution that works with the exact definition of queens as provided in the SICP book. I won't go into details because it uses the same board representation (except that here the indexes start in 1 not in 0) and safe? implementation of my previous answer, and the explanation for the queens procedure is essentially the same. I did some minor changes to favor standard Scheme procedures, so hopefully it'll be more portable.
#lang racket
; redefine procedures already explained in the book with
; Racket equivalents, delete them and use your own
; implementation to be able to run this under #lang sicp
(define flatmap append-map)
(define (enumerate-interval start end)
(range start (+ end 1)))
; new definitions required for this exercise
(define empty-board '())
(define (adjoin-position row col board)
; `col` is unused
(append board (list row)))
; same `safe?` implementation as before
(define (safe? col board)
(let ((row (list-ref board (- col 1))))
(and (safe-row? row board)
(safe-diagonals? row board))))
(define (safe-row? row board)
; reimplemented to use standard Scheme procedures
(= (length (filter (lambda (r) (equal? r row)) board)) 1))
(define (safe-diagonals? row board)
(let loop ((lst (cdr (reverse board)))
(upper (- row 1))
(lower (+ row 1)))
(or (null? lst)
(and (not (= (car lst) upper))
(not (= (car lst) lower))
(loop (cdr lst) (- upper 1) (+ lower 1))))))
; exact same implementation of `queens` as in the book
(define (queens board-size)
(define (queen-cols k)
(if (= k 0)
(list empty-board)
(filter
(lambda (positions) (safe? k positions))
(flatmap
(lambda (rest-of-queens)
(map (lambda (new-row)
(adjoin-position new-row k rest-of-queens))
(enumerate-interval 1 board-size)))
(queen-cols (- k 1))))))
(queen-cols board-size))
; debugging
(define (print-board board)
(for-each (lambda (row) (display row) (newline))
(map (lambda (row)
(map (lambda (col) (if (= row col) 'o 'x))
board))
(enumerate-interval 1 (length board)))))
(define (print-all-boards boards)
(for-each (lambda (board) (print-board board) (newline))
boards))
The above code is more in spirit with the original exercise, which asked you to implement just three definitions: empty-board, adjoin-position and safe?, thus this was more of a question about data representation. Unsurprisingly, the results are the same:
(length (queens 8))
=> 92
(print-all-boards (queens 4))
(x x o x)
(o x x x)
(x x x o)
(x o x x)
(x o x x)
(x x x o)
(o x x x)
(x x o x)
Write a Lisp program to check whether a binary tree is a Binary Search Tree.
The left sub-tree of a node has a key less than or equal to its parent node's key. The right sub-tree of a node has a key greater than to its parent node's key.
A list can be used to represent the structure of a binary tree as follows:
'(8 (3 (1 () ()) (6 (4 () ())( 7 () ()))) (10 (()) (14 (13) ()))) where this would return true.
I am trying to write a binary recursive approach but I'm a beginner and I have no idea where to go from here.
(defun isBST (L)
(cond
((null (first L)) t)
((and (not (null (caadr L)) ) (< (first L) (caadr L)) ) nil)
((and (not (null (caaddr L))) (> (car L) (caaddr L))) nil)
((and (not (isBST (cadr L))) (not (isBST (caddr L)))) ))
)
You can express your definitions in code to make your life easier.
A node is represented as a list of three things: a key, a left subtree, and a right subtree.
(defun node-key (node)
(first node))
(defun node-left-subtree (node)
(second node))
(defun node-right-subtree (node)
(third node))
For a tree to be a binary search tree, four conditions must be met, unless both subtrees are empty:
the left subtree must be a binary search tree
the right subtree must be a binary search tree
the largest key of the left subtree (if present) must be smaller than the root key
the smallest key of the right subtree (if present) must be bigger than the root key
Note: the naming convention in Lisp is to write everything in lower case, with word parts separated by dashes. A predicate, i. e. a function that is used to obtain a truth value, ends with p. The predicate for a binary search tree might be named bst-p or binary-search-tree-p. The function to obtain the largest key of a bst might be called bst-largest-key.
In order to get the largest (smallest) key of a BST, you only need to recurse on the right (left) subtree.
Here's a scheme procedure that might help you.
(define (is-bst l)
(define (loop node proc)
(if (null? node)
#t
(and (proc (car node))
(loop (cadr node)
(curry > (car node)))
(loop (caddr node)
(curry < (car node))))))
(loop l (const #t)))
It can be frustrating to fix a program when your input data is the source of the bugs. I had to fix your (()) and (13). Use multiple lines and the auto-indenter to easily find mistakes.
(is-bst '(8 (3 (1 () ())
(6 (4 () ())
(7 () ())))
(10 ()
(14 (13 () ())
()))))
;; #t
Invalidate one of the nodes to ensure is-bst detects a non-bst.
(is-bst '(8 (3 (1 () ())
(6 (4 () ())
(7 () ())))
(10 ()
(2 (13 () ()) ;; 14 changed to 2; invalid tree
()))))
;; #f
To make a slight improvement, notice we called (car node) three times in the procedure above. This should be avoided with the use of let.
(define (is-bst l)
(define (loop node proc)
(if (null? node)
#t
(let ((value (car node)))
(and (proc value)
(loop (cadr node)
(curry > value))
(loop (caddr node)
(curry < value))))))
(loop l (const #t)))
Another interesting way is using streams, which can be easily implemented using basic procedures. We could write a generic traverse procedure to traverse our trees.
(define (traverse bst)
(if (null? bst)
empty-stream
(stream-append (traverse (cadr bst))
(stream (car bst))
(traverse (caddr bst)))))
(define tree
'(8 (3 (1 () ())
(6 (4 () ())
(7 () ())))
(10 ()
(14 (13 () ())
()))))
(stream->list (traverse tree))
;; '(1 3 4 6 7 8 10 13 14)
Now we write is-bst to simply check that the values come out in ascending order.
(define (is-bst l)
(define (loop x s)
(if (stream-empty? s)
#t
(let ((y (stream-first s)))
(and (< x y)
(loop y (stream-rest s))))))
(loop -inf.0
(traverse l)))
(is-bst tree)
; #t
(is-bst '(1 (2 () ())
(3 () ())))
; #f
Because a stream is used, the values come out lazily. If an early #f is found, iteration of the stream is stopped and the computation is finished.
I'm new to Lisp and I'm trying to solve an 8-puzzle using simple dfs (depth-first search).
But I am getting a program stack overflow.
My code:
(setq used (list))
(defun is_used (state lst)
(cond
((null lst) nil)
((equalp (car lst) state) t)
(t (is_used state (cdr lst)))))
(defun move (lst direction)
(let* ( (zero (find_zero lst))
(row (floor zero 3))
(col (mod zero 3))
(res (copy-list lst)))
(cond
((eq direction 'L)
(if (> col 0)
(rotatef (elt res zero) (elt res (- zero 1)))))
((eq direction 'R)
(if (< col 2)
(rotatef (elt res zero) (elt res (+ zero 1)))))
((eq direction 'U)
(if (> row 0)
(rotatef (elt res zero) (elt res (- zero 3)))))
((eq direction 'D)
(if (< row 2)
(rotatef (elt res zero) (elt res (+ zero 3))))))
(if (equalp res lst)
(return-from move nil))
(return-from move res))
nil)
(defun dfs (cur d prev)
; (write (length used))
; (terpri)
(push cur used)
(let* ((ways '(L R U D)))
(loop for dir in ways
do (if (move cur dir)
(if (not (is_used (move cur dir) used))
(dfs (move cur dir) (+ d 1) cur))))))
state here is a list of 9 atoms.
With uncommented (write (length used)) it prints 723 - number of items in used before the stack overflow occurs.
Now, before solving 8-puzzle, I just want to iterate over all possible states (there are exactly 9! / 2 = 181440 possible states). Sure, it may take some time, but how can I avoid the stack overflow here?
This is a typical problem explained in some AI programming books. If you need to search a large / unbounded amount of states, you should not use recursion. Recursion in CL is limited by the stack depth. Some implementations can optimize tail recursion - but then you need architecture your code, so that it is tail recursive.
Typically a data structure for that will be called an agenda. It keeps the states still to explore. If you look at a state, you push all states to explore from there onto the agenda. Make sure the agenda is in some way sorted (this might determine if it is depths or breadths first). Then take the next state from the agenda and examine it. If the goal is reached, then you are done. If the agenda is empty before the goal is found, then there is no solution. Otherwise loop...
Your code, simplified, is
(setq *used* (list))
(defun move (position direction)
(let* ( (zero (position 0 position))
(row (floor zero 3))
(col (mod zero 3))
(command (find direction `((L ,(> col 0) ,(- zero 1))
(R ,(< col 2) ,(+ zero 1))
(U ,(> row 0) ,(- zero 3))
(D ,(< row 2) ,(+ zero 3)))
:key #'car)))
(if (cadr command)
(let ((res (copy-list position)))
(rotatef (elt res zero) (elt res (caddr command)))
res))))
(defun dfs-rec (cur_pos depth prev_pos)
(write (length *used*)) (write '_) (write depth) (write '--)
; (terpri)
(push cur_pos *used*)
(let* ((dirs '(L R U D)))
(loop for dir in dirs
do (let ((new_pos (move cur_pos dir)))
(if (and new_pos
(not (member new_pos *used* :test #'equalp)))
(dfs-rec new_pos (+ depth 1) cur_pos))))))
(print (dfs-rec '(0 1 2 3 4 5 6 7 8) 0 '()))
Instead of processing the four moves one by one while relying on recursion to keep track of what-to-do-next on each level, just push all the resulting positions at once to a to-do list, then pop and continue with the top one; repeating while the to-do list is not empty (i.e. there is something to do, literally):
(defun new-positions (position)
(let* ( (zero (position 0 position))
(row (floor zero 3))
(col (mod zero 3)) )
(mapcan
#'(lambda (command)
(if (cadr command)
(let ((res (copy-list position)))
(rotatef (elt res zero) (elt res (caddr command)))
(list res))))
`((L ,(> col 0) ,(- zero 1))
(R ,(< col 2) ,(+ zero 1))
(U ,(> row 0) ,(- zero 3))
(D ,(< row 2) ,(+ zero 3))) )))
; non-recursive dfs function skeleton
(defun dfs (start-pos &aux to-do curr new)
(setf to-do (list start-pos))
(loop while to-do
do (progn (setf curr (pop to-do))
(setf new (new-positions curr))
(setf to-do (nconc new to-do)))))
This way there's no more info to keep track of, with recursion -- it's all in the to-do list.
This means the generated positions will be processed in the LIFO order, i.e. the to-do list will be used as a stack, achieving the depth-first search strategy.
If you'd instead append all the new positions on each step at the end of the to-do list, it'd mean it being used as a queue, in a FIFO order, achieving the breadth-first search.
I wish to replace the first occurrence of a symbol within pairs. For example:
take
(define n '((a . b) . (a . d)))
and i define a method context to replace the first instance (left most) of X with '()
replacing a should give me:
((() . b) a . d)
however i am stuck as my method replaces ALL instances and i am not sure how to add a check for this.
my code is as follows:
(define (context s sym)
(cond ((null? s) #f)
((atom? s)
(if (equal? s sym) '() s ))
(else (cons (context (car s) sym)
(context (cdr s) sym)))))
which gives : ((() . b) () . d)
any help? Thank you
The quickest way is to use a flag indicating whether the replacement has already been done, something along the lines of:
(define (context sxp sym)
(define done #f)
(let loop ((sxp sxp))
(cond (done sxp)
((pair? sxp) (cons (loop (car sxp)) (loop (cdr sxp))))
((eq? sym sxp) (set! done #t) '())
(else sxp))))
It's not very elegant to use set!, but the alternative would be to have the procedure return 2 values, and the resulting let-values code would be even worse in terms of readability IMO.
Also note that I didn't use atom? because it's not defined in standard Scheme; the usual way is to successively test null? then pair?, and handle the atom case in the else clause.
This is a bit more general (you can replace things other than symbols, and you can customize the test, and you can specify any particular number of instances to replace, not just one), and may be a little bit more complicated at first glance than what you're looking for, but here's a solution that works by internally using a continuation-passing style helper function. The main function, subst-n takes a new element, and old element, a tree, a test, and a count. It replaces the first count occurrences of new (as compared with test) with old (or all, if count is not a non-negative integer).
(define (subst-n new old tree test count)
(let substs ((tree tree)
(count count)
(k (lambda (tree count) tree)))
(cond
;; If count is a number and zero, we've replaced enough
;; and can just "return" this tree unchanged.
((and (number? count) (zero? count))
(k tree count))
;; If the tree is the old element, then "return" the new
;; element, with a decremented count (if count is a number).
((test old tree)
(k new (if (number? count) (- count 1) count)))
;; If tree is a pair, then recurse on the left side,
;; with a continuation that will recurse on the right
;; side, and then put the sides together.
((pair? tree)
(substs (car tree) count
(lambda (left count)
(substs (cdr tree) count
(lambda (right count)
(k (cons left right) count))))))
;; Otherwise, there's nothing to do but return this
;; tree with the unchanged count.
(else
(k tree count)))))
> (display (subst-n '() 'a '((a . b) . (a . d)) eq? 1))
((() . b) a . d)
> (display (subst-n '() 'a '((a . b) . (a . d)) eq? 2))
((() . b) () . d)
I am trying to delete a node from a Binary Search Tree in scheme, but I am having trouble with the removing part of the code. How can I delete a node value without creating a new tree in scheme?
(define (delete-node v T)
(cond ((null? T) '())
((< v (value T))
(delete-node v (left T)))
((> v (value T))
(delete-node v (right T)))
(else
(cond ((and (null? (right T))(not (null? (left T)))) '())
;promote the (left T) to the node
;repeat
((and (null? (left T))(not (null? (right T)))) '())
;promote the (right T) to the node
;repeat
For deleting a node in-place, your tree would have to be mutable - meaning: that either the value, the right subtree or the left subtree of a node can be modified in-place with new values.
It's easier to just build a new tree while traversing it, but even so there are a couple of implementation choices that must be made. Here's a sketch of a solution:
(define (delete-node v T)
(cond ((null? T) '())
((< v (value T))
; see how we build the new tree
(make-node (value T)
(delete-node v (left T))
(right T)))
((> v (value T))
; see how we build the new tree
(make-node (value T)
(left T)
(delete-node v (right T))))
(else
(cond ((and (null? (right T)) (and (null? (left T))))
; this case was missing
'())
((and (null? (right T)) (not (null? (left T))))
(left tree))
((and (null? (left T)) (not (null? (right T))))
(right tree))
(else
; implementation detail: if both subtrees of the
; node to be deleted are non-null, who should take
; the place of the deleted node? the new subtree
; must preserve the order property of the tree
<???>)))))
The interesting case is marked with <???>. There are several options, it's up to you to pick and implement one. For instance, in a sorted tree (which I assume is the case here), one could pick the biggest element from the left subtree, and recursively delete it before moving it into place.
Notice that if the tree has to remain balanced after deleting the node (according to the balancing definition in use), the algorithm is trickier - I'm assuming that the tree is not balanced.