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.
Related
I'm working through a textbook on programming languages, and one of the exercises was to make a function in Scheme that flips tuples in a list. Here's my code:
; invert : Listof(List(Int,Int)) -> Listof(List(Int,int))
; usage: (invert '((a 1) (a 2) (1 b) (2 b))) -> ((1 a) (2 a) (b 1) (b 2))
(define invert
(lambda (lst)
(if (null? lst)
'()
(cons
(flip (car lst))
(invert (cdr lst))))))
; flip : List(Int,Int) -> List(Int,int)
; usage: (flip '(a 1)) -> (1 a)
(define flip
(lambda (tuple)
(if (not (eqv? (length (tuple)) 2))
(eopl:error 'flip
"Tuple is not length 2~%")
(cons (cdr tuple) (car tuple)))))
I tried testing my program in chez-scheme. When I use the test case in the usage comment, I get this error: Exception: attempt to apply non-procedure (a 1). I've never worked with Scheme before, so I'd greatly appreciate any help and advice. Thanks!
You have a coupe of errors in flip, this should fix them:
(define flip
(lambda (tuple)
(if (not (= (length tuple) 2))
(eopl:error 'flip "Tuple is not length 2~%")
(list (cadr tuple) (car tuple)))))
In particular:
The specific error reported was because of this expression: (tuple). We must not surround variables with (), unless they're procedures that we intend to call.
We should use = for comparing numbers, not eqv?.
In this expression: (cons (cdr tuple) (car tuple)) there are two issues, for building a list of two elements we use list, not cons. And for accessing the second element we use cadr, not cdr - you should read a bit about how cons, car and cdr are used for building lists.
Notice that there's a simpler way to solve this problem if we use map; I'll skip error checking for simplicity:
(define (invert lst)
(map (lambda (tuple) (list (cadr tuple) (car tuple)))
lst))
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)
Assume that my "map-diff" function works properly for the following code. I am wondering how to take an arithmetic parse tree and output it in preorder notation. I want to be able to use my "map-diff" function inside my "preorder" function, but I can't figure out how to go about doing this. Are my base cases here correct?
(define (make-tree value left right) (list value left right))
(define (value tree) (car tree))
(define (left tree) (cadr tree))
(define (right tree) (caddr tree))
(define (prepare x)
(cond ((number? x) (number->string x))
((char? x) (string x))))
(define x
(map-diff (lambda (x) (prepare x))
(list #\+
(list #\*
(list 3 '() '())
(list 9 '() '()))
(list #\+
(list #\/ (list 5 '() '()) '())
(list 4 '() '())))))
(define (preorder T)
(cond ((null? T) "")
((eq? (value T) "+")
(cons (value T) (cons (preorder (left T)) (preorder (right T)))))
((eq? (value T) "*")
(cons (value T) (cons (preorder (left T)) (preorder (right T)))))
((eq? (value T) "-")
(cons "-" (preorder (left T))))
((eq? (value T) "/")
(cons "/" (preorder (left T))))
(else (value T))))
(preorder x)
First , don't mix your ADT and primative types together. If you define an ADT stick with it thoughout the program. X should be defined in terms of make-tree rather than list). And make-tree rather than cons in preorder. The way you have it now your going to get a dotted list as output rather than a nice proper list form.
I'm not sure what your trying to do with prepare, casting things to strings to parse them is fairly unusual, considering lisps dynamic typing.
Anyways here is one possibility
(define (preorder T)
(let ((top (prepare (value T))))
(cond ((null? T) "")
((eq? top "+")
(cons top (cons (preorder (left T)) (preorder (right T)))))
((eq? top "*")
(cons top (cons (preorder (left T)) (preorder (right T)))))
((eq? top "-")
(cons "-" (preorder (left T))))
((eq? top "/")
(cons "/" (preorder (left T))))
(else top)))
;; helper
(define (list-ref-at n)
(lambda (l) (list-ref l n)))
;; node data type
(define (make-node value left right)
`(NODE ,value ,left ,right))
(define node-value (list-ref-at 1))
(define node-left (list-ref-at 2))
(define node-right (list-ref-at 3))
;; leaf data type (as special node)
(define (make-leaf value)
(make-node value '() '()))
(define (node-is-leaf? node)
(and (null? (node-left node))
(null? (node-right node))))
;; convert to list
(define (node->preorder-list node)
(if (node-is-leaf? node)
(node-value node)
(let ((v (node-value node))
(l (node-left node))
(r (node-right node)))
(assert (not (null? l)))
(if (null? r)
(list v (node->preorder-list l)) ; unop
(list v (node->preorder-list l) (node->preorder-list r)))))) ;binop
;; test
> (define x (make-node '* (make-node '+ (make-leaf 1) (make-leaf 2)) (make-leaf 10))
> (node->preorder-list x)
(* (+ 1 2) 10)
> (set! x (make-node '- x '()))
> (node->preorder-list x)
(- (* (+ 1 2) 10))
I wrote 90% of a tree-map function in scheme, but I encountered a major problem that I am having trouble with. When I test my code with binary tree, all but the first node gets mapped properly. The first node drops out, and I can't seem to think of a way around this. Any advice here as would be appreciated.
(define (value tree)
(car tree))
(define (left tree)
(car (cdr tree)))
(define (right tree)
(car (cdr (cdr tree))))
(define (tree-map f T)
(cond ((null? T) '())
((and (null? (right T))(null? (left T))) '())
((and (null? (right T))(not (null? (left T))))
(make-tree (f (value(left T)))
(tree-map f (left T))
(right T)))
((and (null? (left T))(not (null? (right T))))
(make-tree (f (value(right T)))
(left T)
(tree-map f (right T))
))))
This code is really convoluted. First I don't see an else statement, and a pretty big case drop (if both branches are not null tress). Second why are you worrying if the left or right is null when you have a case already for null trees?
(define (tree-map f T)
(cond ((null? T) '())
(else (make-tree (f (value T))
(tree-map f (left T))
(tree-map f (right T))))))
Being a human compiler is no fun. All you've don with you leaf, empty-left, and empty-right cases is rewrite the same code, but manually drop in the '() where appropriate instead of relying on the function to do it for you.
It seems that there are a couple of errors:
If a leaf node is found, you aren't applying the function to that node
The case where a node has both subtrees is missing
The part where the function is applied is wrong
Try this with one of your samples, the question doesn't include all the necessary code to test it myself:
(define (tree-map f T)
; empty tree
(cond ((null? T)
'())
; leaf node
((and (null? (right T)) (null? (left T)))
(make-tree (f (value T)) '() '()))
; empty right subtree
((and (null? (right T)) (not (null? (left T))))
(make-tree (f (value T))
(tree-map f (left T))
'()))
; empty left subtree
((and (null? (left T)) (not (null? (right T))))
(make-tree (f (value T))
'()
(tree-map f (right T))))
; both subtrees are present
(else
(make-tree (f (value T))
(tree-map f (left T))
(tree-map f (right T))))))