Dear comp.lang.lisp
I'm working with trees and I have not been able to find any function
which does what I need done, that is, to substitute a leaf entry in a
tree (ie a symbol) with two symbols
So some examples:
(subtreefun tree oldsymbol newsymbol1 newsymbol2) ===> Subedtree
(subtreefun (1 2 (3 4 5) 6 4) '4 'a 'b) ===> (1 2 (3 a b 5) 6 a b)
This function does this substitution but for only one new entry, how
would an n new entry function look?
(defun sub (tree old new)
(cond ((null tree) nil)
((equal tree old) new )
((atom tree) tree)
(t (cons (sub (car tree) old new)
(sub (cdr tree) old new)))))
Thank you very much for your help
+ ········@gmail.com" <·······@gmail.com>:
| I'm working with trees and I have not been able to find any function
| which does what I need done, that is, to substitute a leaf entry in a
| tree (ie a symbol) with two symbols
| So some examples:
| (subtreefun tree oldsymbol newsymbol1 newsymbol2) ===> Subedtree
| (subtreefun (1 2 (3 4 5) 6 4) '4 'a 'b) ===> (1 2 (3 a b 5) 6 a b)
|
|
| This function does this substitution but for only one new entry, how
| would an n new entry function look?
| (defun sub (tree old new)
| (cond ((null tree) nil)
| ((equal tree old) new )
| ((atom tree) tree)
| (t (cons (sub (car tree) old new)
| (sub (cdr tree) old new)))))
Here's a hint: You cannot achieve what you want by simply replacing
leaved in the tree. Your specification calls for changing the
structure of the tree itself. So whenever you're seeing a pair
(oldsymbol . stuff)
you need to replace that by (newsymbol1 newsymbol2 . stuff). Also,
when you recurse be sure to skip over the two new symbols, or you'll
be screwed in case oldsymbol is the same as newsymbol1 or newsymbol2.
--
* Harald Hanche-Olsen <URL:http://www.math.ntnu.no/~hanche/>
- Debating gives most of us much more psychological satisfaction
than thinking does: but it deprives us of whatever chance there is
of getting closer to the truth. -- C.P. Snow
Thanks!
I've made some progress by this falls over... (please excuse the wip
debuging print call which I use to help be see what's happening)
(defun subsituteinlistv2 (what towhat1 towhat2 listinwhichtosub)
(progn (setf start (car listinwhichtosub)) (setf rest (cdr
listinwhichtosub)) (print listinwhichtosub) (print start) (print rest)
(cond
((equal what start) (setf output (cons towhat1 (cons towhat2
rest))))
; ((not listinwhichtosub) (setf output listinwhichtosub))
((eq (cdr rest) nil) (progn (print "I'm here now 4")))
((listp start) (progn (print "Im here now1")
(setf listoutput (subsituteinlistv2 what towhat1 towhat2 start))
(print "Im here now2")
(setf output (cons listoutput (subsituteinlistv2 what towhat1
towhat2 rest)))
(print "I'm here now 3")))
((not (equal what start)) (setf output (cons start
(subsituteinlistv2 what towhat1 towhat2 rest)))))
output))
but fails is there are branches in the tree :-(
(SUBSITUTEINLISTv2 2 'a 'b '(a b c (1 2 3) f g h))
+ ········@gmail.com" <·······@gmail.com>:
| Thanks!
| I've made some progress by this falls over...
I see you have already gotten a complete solution, so I won't try to
give you one. But in an effort to educate (a professional hazard I'm
afraid), I'll comment anyway.
| (please excuse the wip debuging print call which I use to help be
| see what's happening)
Those are easy to excuse. Somewhat harder is your strange indenting
style, which makes your code near impossible to read.
After removing the debug print statements and doing some trivial
cleanups, I get the following version of your code:
(defun subsituteinlistv2 (what towhat1 towhat2 listinwhichtosub)
(setf start (car listinwhichtosub))
(setf rest (cdr listinwhichtosub))
(cond
((equal what start)
(setf output (cons towhat1 (cons towhat2 rest))))
;; ((not listinwhichtosub) (setf output listinwhichtosub))
((eq (cdr rest) nil))
((listp start)
(setf listoutput (subsituteinlistv2 what towhat1 towhat2 start))
(setf output
(cons listoutput
(subsituteinlistv2 what towhat1 towhat2 rest))))
((not (equal what start))
(setf output
(cons start
(subsituteinlistv2 what towhat1 towhat2 rest)))))
output)
Some notes: You had scattered several unnecessary PROGNs around the
code. The body of a defun already behaves like a PROGN, and so does
the part after each test in a COND. So I removed them. PROGN is only
needed where the syntax of the language expects a single form but you
want a sequence of forms. Also, I replaced your single semicolon in
the code you had commented out by a double one: This makes editors
like emacs produce a better (in this case) indentation.
But wait - we can do better: You use variables START, REST, and OUTPUT
which have not been bound locally. You should have made them local
variables, for example by wrapping the entire body of the function in
a LET form. Moreover, I notice that each branch of the COND, with one
exception, ends in (setf output ...), and at the end, output is
returned. But since the COND form returns the value of the final form
in the branch chosen, that should be unnecessary, so we can do away
with this variable altogether. Now your code looks like ... oh, I
found another undeclared variable: LISTOUTPUT inside a branch of the
COND. You might bind that too with LET, but better is to use the
value directly, since it is used only once. So now we're left with
(defun subsituteinlistv2 (what towhat1 towhat2 listinwhichtosub)
(let ((start (car listinwhichtosub))
(rest (cdr listinwhichtosub)))
(cond
((equal what start)
(cons towhat1 (cons towhat2 rest)))
;; ((not listinwhichtosub) listinwhichtosub)
((eq (cdr rest) nil))
((listp start)
(cons (subsituteinlistv2 what towhat1 towhat2 start)
(subsituteinlistv2 what towhat1 towhat2 rest)))
((not (equal what start))
(cons start
(subsituteinlistv2 what towhat1 towhat2 rest))))))
So far, all I've done to your code is to clean it up. I haven't even
looked at whaty you're trying to do yet. But now it's easier. Look
at the first branch of the COND:
((equal what start)
(cons towhat1 (cons towhat2 rest)))
You have neglected to descend into the REST bit. Apply
subsituteinlistv2 to it.
Next, your test for (listp start) had better be (consp start), for
efficiency reasons.
Next, you final test is superfluous: (not (equal what start)) must be
true here, or the first test would have been triggered. So you can
replace it with t. Here is a new version:
(defun subsituteinlistv2 (what towhat1 towhat2 listinwhichtosub)
(let ((start (car listinwhichtosub))
(rest (cdr listinwhichtosub)))
(cond
((equal what start)
(cons towhat1
(cons towhat2 (subsituteinlistv2 what towhat1 towhat2 rest))))
;; ((not listinwhichtosub) listinwhichtosub)
((eq (cdr rest) nil))
((listp start)
(cons (subsituteinlistv2 what towhat1 towhat2 start)
(subsituteinlistv2 what towhat1 towhat2 rest)))
(t
(cons start
(subsituteinlistv2 what towhat1 towhat2 rest))))))
| but fails is there are branches in the tree :-(
|
| (SUBSITUTEINLISTv2 2 'a 'b '(a b c (1 2 3) f g h))
Indeed, it fails to do what you wanted. Since this is a highly
recursive function, it is probably useful to trace it:
CL-USER> (trace subsituteinlistv2)
(subsituteinlistv2)
CL-USER> (subsituteinlistv2 2 'a 'b '(a b c (1 2 3) f g h))
0: (subsituteinlistv2 2 a b (a b c (1 2 3) f g h))
1: (subsituteinlistv2 2 a b (b c (1 2 3) f g h))
2: (subsituteinlistv2 2 a b (c (1 2 3) f g h))
3: (subsituteinlistv2 2 a b ((1 2 3) f g h))
4: (subsituteinlistv2 2 a b (1 2 3))
5: (subsituteinlistv2 2 a b (2 3))
6: (subsituteinlistv2 2 a b (3))
6: subsituteinlistv2 returned t
5: subsituteinlistv2 returned (a b . t)
4: subsituteinlistv2 returned (1 a b . t)
4: (subsituteinlistv2 2 a b (f g h))
5: (subsituteinlistv2 2 a b (g h))
5: subsituteinlistv2 returned t
4: subsituteinlistv2 returned (f . t)
3: subsituteinlistv2 returned ((1 a b . t) f . t)
2: subsituteinlistv2 returned (c (1 a b . t) f . t)
1: subsituteinlistv2 returned (b c (1 a b . t) f . t)
0: subsituteinlistv2 returned (a b c (1 a b . t) f . t)
(a b c (1 a b . t) f . t)
The innermost call (level 6) should be a good place to start in order
to understand the problem. Oh, passing in the list (3) will trigger
the second branch in the COND, for which we have not provided a value.
Fix that, and also add a keyword parameter for the test:
(defun subsituteinlistv2
(what towhat1 towhat2 listinwhichtosub &key (test #'equal))
(let ((start (car listinwhichtosub))
(rest (cdr listinwhichtosub)))
(cond
((funcall test what start)
(cons towhat1
(cons towhat2 (subsituteinlistv2 what towhat1 towhat2 rest))))
;; ((not listinwhichtosub) listinwhichtosub)
((null (cdr rest))
(list start))
((listp start)
(cons (subsituteinlistv2 what towhat1 towhat2 start)
(subsituteinlistv2 what towhat1 towhat2 rest)))
(t
(cons start
(subsituteinlistv2 what towhat1 towhat2 rest))))))
I won't guarantee the correctness of this code, since I'm too lazy,
and you have to do some work youself. 8-)
--
* Harald Hanche-Olsen <URL:http://www.math.ntnu.no/~hanche/>
- Debating gives most of us much more psychological satisfaction
than thinking does: but it deprives us of whatever chance there is
of getting closer to the truth. -- C.P. Snow
+ Harald Hanche-Olsen <······@math.ntnu.no>:
| Next, your test for (listp start) had better be (consp start), for
| efficiency reasons.
But I forgot to actually do it. Replace listp by consp in the final
version of the code.
--
* Harald Hanche-Olsen <URL:http://www.math.ntnu.no/~hanche/>
- Debating gives most of us much more psychological satisfaction
than thinking does: but it deprives us of whatever chance there is
of getting closer to the truth. -- C.P. Snow
·······@gmail.com wrote:
> Dear comp.lang.lisp
>
> I'm working with trees and I have not been able to find any function
> which does what I need done, that is, to substitute a leaf entry in a
> tree (ie a symbol) with two symbols
> So some examples:
> (subtreefun tree oldsymbol newsymbol1 newsymbol2) ===> Subedtree
> (subtreefun (1 2 (3 4 5) 6 4) '4 'a 'b) ===> (1 2 (3 a b 5) 6 a b)
>
>
> This function does this substitution but for only one new entry, how
> would an n new entry function look?
> (defun sub (tree old new)
> (cond ((null tree) nil)
> ((equal tree old) new )
> ((atom tree) tree)
> (t (cons (sub (car tree) old new)
> (sub (cdr tree) old new)))))
>
> Thank you very much for your help
>
You can't recur down to the leaves. Keep always the tree itself at hand.
Here's a trivial solution to your problem.
(defun subtreefun (tree old new1 new2)
(cond ((null tree) nil)
((equal (car tree) old)
(cons new1
(cons new2
(subtreefun (cdr tree) old new1 new2))))
((atom (car tree))
(cons (car tree) (subtreefun (cdr tree) old new1 new2)))
(t (cons (subtreefun (car tree) old new1 new2)
(subtreefun (cdr tree) old new1 new2)))))
CL-USER> (subtreefun '(1 2 (3 4 5) 6 4) 4 'a 'b)
(1 2 (3 A B 5) 6 A B)
········@gmail.com" <·······@gmail.com> writes:
> Dear comp.lang.lisp
>
> I'm working with trees and I have not been able to find any function
> which does what I need done, that is, to substitute a leaf entry in a
> tree (ie a symbol) with two symbols
> So some examples:
> (subtreefun tree oldsymbol newsymbol1 newsymbol2) ===> Subedtree
> (subtreefun (1 2 (3 4 5) 6 4) '4 'a 'b) ===> (1 2 (3 a b 5) 6 a b)
>
>
> This function does this substitution but for only one new entry, how
> would an n new entry function look?
> (defun sub (tree old new)
> (cond ((null tree) nil)
> ((equal tree old) new )
> ((atom tree) tree)
> (t (cons (sub (car tree) old new)
> (sub (cdr tree) old new)))))
>
> Thank you very much for your help
You should do some abstraction, and define what is a tree:
(make-tree &key item children) --> tree
(tree-children tree) --> tree
(tree-item tree) --> item
(tree-leaf-p tree) <=> (null (tree-children tree))
You can have trees where each node is labelled (has an "item"), or
trees where only leaf nodes is labelled.
What you seem to be wanting is to substitute a leaf node with two leaf
nodes. Also are the children ordered or not? There's still an
ambiguity: should this be done by incrementing the number of children
in the parent node of the old leaf node, or by substituting this leaf
node by a subtree of two sub-nodes?
In the later case, it's trivial:
(defun tree-substitute-2 (new-item-1 new-item-2 old-item tree
&key (test (function eql)))
(if (tree-leaf-p tree)
(if (funcall test (tree-item tree) old-item)
(make-tree :children (list (make-tree :item new-item-1)
(make-tree :item new-item-2)))
tree)
(make-tree :item (tree-item tree)
:children (mapcar (lambda (tree)
(tree-substitute-2 new-item-1
new-item-2
old-item tree
:test test))
(tree-children tree)))))
In the former case, it's slightly more complicated:
;; Assuming children are not ordered:
(defun tree-substitute-2* (new-item-1 new-item-2 old-item tree
&key (test (function eql)))
(flet ((process (tree)
(mapcar (lambda (tree)
(tree-substitute-2* new-item-1
new-item-2
old-item tree
:test test))
tree)))
(let ((leaf-node
(find old-item
(remove-if (function tree-children) (tree-children tree))
:test test :key (function tree-item))))
(if leaf-node
(make-tree :item (tree-item tree)
:children (list*
(make-tree :item new-item-1)
(make-tree :item new-item-2)
(process (remove leaf-node (tree-children tree)))))
(make-tree :item (tree-item tree)
:children (process (tree-children tree)))))))
;; If the children are ordered:
(defun tree-substitute-2* (new-item-1 new-item-2 old-item tree
&key (test (function eql)))
(flet ((process (tree)
(mapcar (lambda (tree)
(tree-substitute-2* new-item-1
new-item-2
old-item tree
:test test))
tree)))
(let ((leaf-node
(find old-item
(remove-if (function tree-children) (tree-children tree))
:test test :key (function tree-item))))
(if leaf-node
(make-tree :item (tree-item tree)
:children (nconc
(process (subseq (tree-children tree)
0 (position leaf-node
(tree-children tree))))
(list*
(make-tree :item new-item-1)
(make-tree :item new-item-2)
(process
(subseq (tree-children tree)
(1+ (position leaf-node
(tree-children tree))))))))
(make-tree :item (tree-item tree)
:children (process (tree-children tree)))))))
In both cases, I'm sure you'll be able to modify the functions to take
a list of items instead of two.
Personnaly, I'd work with subtrees instead of items, but it's your
specifications...
According to your code:
> (defun sub (tree old new)
> (cond ((null tree) nil)
> ((equal tree old) new )
> ((atom tree) tree)
> (t (cons (sub (car tree) old new)
> (sub (cdr tree) old new)))))
you'd have to write:
(defun make-tree (&key item children)
(or item children))
(defun tree-children (tree)
(if (atom tree)
nil
tree))
(defun tree-item (tree)
(if (atom tree)
tree
nil))
(defun tree-leaf-p (tree) (null (tree-children tree)))
And your example tree would be:
(setf tree
(make-tree :children (list (make-tree :item 1)
(make-tree :item 2)
(make-tree :children (list (make-tree :item 3)
(make-tree :item 4)
(make-tree :item 5)))
(make-tree :item 6)
(make-tree :item 4))))
(TREE-SUBSTITUTE-2* 'a 'b 4 tree) --> (1 2 (3 A B 5) 6 A B)
But wouldn't this be as good:
(TREE-SUBSTITUTE-2 'a 'b 4 tree) --> (1 2 (3 (A B) 5) 6 (A B))
--
__Pascal Bourguignon__ http://www.informatimago.com/
In deep sleep hear sound,
Cat vomit hairball somewhere.
Will find in morning.
Thank you Pascal,
I was aiming for only the solution where:
tree = (1 2 (3 4 5) 6 4)
(TREE-SUBSTITUTE-2* 'a 'b 4 tree) --> (1 2 (3 A B 5) 6 A B)
which is solved by
(defun subtreefun (tree old new1 new2)
(cond ((null tree) nil)
((equal (car tree) old)
(cons new1
(cons new2
(subtreefun (cdr tree) old new1 new2))))
((atom (car tree))
(cons (car tree) (subtreefun (cdr tree) old new1 new2)))
(t (cons (subtreefun (car tree) old new1 new2)
(subtreefun (cdr tree) old new1 new2)))))
I missed the (atom (car tree)) test when trying to solve it myself
regards
········@gmail.com" <·······@gmail.com> writes:
> Thank you Pascal,
> I was aiming for only the solution where:
> tree = (1 2 (3 4 5) 6 4)
> (TREE-SUBSTITUTE-2* 'a 'b 4 tree) --> (1 2 (3 A B 5) 6 A B)
>
> which is solved by
>
> (defun subtreefun (tree old new1 new2)
> (cond ((null tree) nil)
> ((equal (car tree) old)
> (cons new1
> (cons new2
> (subtreefun (cdr tree) old new1 new2))))
> ((atom (car tree))
> (cons (car tree) (subtreefun (cdr tree) old new1 new2)))
> (t (cons (subtreefun (car tree) old new1 new2)
> (subtreefun (cdr tree) old new1 new2)))))
>
> I missed the (atom (car tree)) test when trying to solve it myself
The point is that it's good to abstract things a little. It allows
you to express your algorithms more clearly than when accessing
underlying implementation detaills directly as you do here.
(Therefore to better understand how to write it!) It allows you to
later change this underlying implementation if the specification
changes or if you need to optimize it. And finally, it allows you to
explicitly state your assumptions about your data structure (are
labels attached to any nodes or only to leaves? are children sorted?,
etc).
--
__Pascal Bourguignon__ http://www.informatimago.com/
This is a signature virus. Add me to your signature and help me to live
·······@gmail.com wrote:
> Dear comp.lang.lisp
>
> I'm working with trees and I have not been able to find any function
> which does what I need done, that is, to substitute a leaf entry in a
> tree (ie a symbol) with two symbols
> So some examples:
> (subtreefun tree oldsymbol newsymbol1 newsymbol2) ===> Subedtree
> (subtreefun (1 2 (3 4 5) 6 4) '4 'a 'b) ===> (1 2 (3 a b 5) 6 a b)
>
>
> This function does this substitution but for only one new entry, how
> would an n new entry function look?
> (defun sub (tree old new)
> (cond ((null tree) nil)
> ((equal tree old) new )
> ((atom tree) tree)
> (t (cons (sub (car tree) old new)
> (sub (cdr tree) old new)))))
>
(defun subtreefun (tree old &rest new)
(mapcan (lambda (element)
(typecase element
(atom (if (eql element old)
new
(list element)))
(list (list (apply #'subtreefun element old new)))))
tree))
CL-USER 14 > (subtreefun '(1 2 (3 4 5) 6 4) 4 'a 'b)
(1 2 (3 A B 5) 6 A B)
CL-USER 15 > (subtreefun '(1 2 (3 4 5) 6 4) 4 'a 'b 'c 'x 's)
(1 2 (3 A B C X S 5) 6 A B C X S)
CL-USER 16 >
Wade
Thank you all again, as you can see this is a start of a lengthy lisp
learning process for me...
Is there a library of these kind of functions you could suggest? In
words the kind of functions I'm looking for are:
(substitute-all-atoms-in-tree tree oldatom &restatoms atoms) ===>
thank you all for subtreefun, I have this now
(substitute-nth-atom-in-tree tree n oldatom &restatoms atoms) ,
counting n in order atoms appear in tree
(count-numberof-atoms-in-tree tree)
(dedupe-a-list-of-trees list) where each list element is a tree, is
any tree appears >1 then keep only one
(dedupe-a-list-of-trees-considering-only-structure list) where
structure is irrespective of contents of leafs so (1 (2 3) == (a (b d)
but (1 (2 3)) /= (a (b (c)))
; (this would probably use dedupe-a-list-of-trees with something list
a 'treestructure' function applied, which would turn all the atoms to
the same constant).
And this tricky one :-)
(create-a-list-of-all-trees-resulting-from-cmbinatorial-replacements-of-each-'oldatom'-with-either-'new1''new2'-OR-'new3'-in-the-tree
tree oldatom new1 new2 new3)
as en example it would behave list this:
(caloatrfcroeowennonitt '(1 2 (1)) 1 a b c) ===>
;;;let me thing about this one.... :-)
(
(a b 2 (a b))
(a b 2 (c ))
(c2 (a b))
(c2 (c ))
)
Why all this haste you might ask, I'm hoping to create a combinatorial
search through the space of all possible function definitions , testing
each one against a 'input output pair' , (lots will be syntactically
incorrect, but that's ok, we'll just escape with :error... I hope, and
ignore them) later adding some evolutionary ideas to cut the
combinatorial search... as inspired by
http://www-ia.hiof.no/~rolando/adate_intro.html
Kind regards.
G
Wade, your solution seems to fall into a infinate loop sometimes;
(subtreefun '(2 2) 2 'a 'b) --fails
(subtreefun '(2 1 2) 2 'a 'b) --fails
CL-USER> (subtreefun '(2 1 (2)) 2 'a 'b) -- works
·······@gmail.com wrote:
> Wade, your solution seems to fall into a infinate loop sometimes;
>
> (subtreefun '(2 2) 2 'a 'b) --fails
> (subtreefun '(2 1 2) 2 'a 'b) --fails
> CL-USER> (subtreefun '(2 1 (2)) 2 'a 'b) -- works
>
Here is the fix
(defun subtreefun (tree old &rest new)
(mapcan (lambda (element)
(typecase element
(atom (if (eql element old)
(copy-list new)
(list element)))
(list (list (apply #'subtreefun element old new)))))
tree))
The previous version was creating circular lists, (the reason
for this is that mapcan uses nconc.)
CL-USER 12 > (setf *print-circle* t)
T
CL-USER 13 > (subtreefun '(2 2) 2 'a 'b)
#1=(A B . #1#)
Just for interest, here is another version of subtreefun
(defun subtreefun (tree old &rest new)
(loop for element in tree
if (eql element old) append new
else if (atom element) collect element
else collect (apply #'subtreefun element old new)))
Wade