structural recursion

[schatze...@gmail.com]

Need help turning this list

(abc
xyz
ef-gh
ef-xy
cl-f-a
cl-f-b
cl-x-y
cl-x-az
def)

into this tree

((abc)
(xyz)
(ef-
(ef-gh)
(ef-xy))
(cl-
(cl-f-
(cl-f-a)
(cl-f-b))
(cl-x-
(cl-x-y)
(cl-x-az)))
(def))

i.e. group symbols recursively, 2-dimensionally?

[Jack Mudge]

What have you already tried? Is this part of a larger problem or program that might benefit from a different analysis, or is this a stand-alone problem to solve?

If I were starting to tackle this problem, I'd probably find the (symbol-name), (position), and (mapcar) functions useful.

[Jack Mudge]

I worked out a way to do this given your example input and output. I make no promises that this is the cleanest or most efficient way to do it!

(Actually I'm kind of hoping someone else will come along and tear it apart so I can learn from it.)

Tested with SBCL on Linux.

>>>>>
(defparameter +input-list+
'(abc xyz ef-gh ef-xy cl-f-a cl-f-b cl-x-y cl-x-az def))

(defun tree-insert (tree path)
(cond ((null path) ; no more path to traverse
tree)
((find (car path) tree :test 'node-equal-p) ; have child node
(let* ((olditem (find (car path) tree :test 'node-equal-p))
(newitem (typecase olditem
(symbol (tree-insert (list olditem) (cdr path)))
(list (tree-insert olditem (cdr path))))))
(substitute newitem olditem tree)))
(t (tree-insert (append tree (list (car path))) ; no child node
path))))

(defun node-equal-p (symb node)
; node could be symbol, or list starting w/ symbol
(typecase node
(symbol (eq node symb))
(list (eq (car node) symb))))

(defun symbol-dash-list (symbol)
"Return 'parent' symbols of a symbol with dashes in its name, in order"
(let ((s (symbol-name symbol)))
(mapcar (lambda (pos) (intern (subseq s 0 pos)))
(loop for pos = (position #\- s)
then (position #\- s :start (1+ pos))
until (null pos)
collect (1+ pos) into ret
finally (return (nconc ret (list (length s))))))))

(defun expand-symbol-list (list)
(let ((tree nil))
(dolist (s list)
(setf tree (tree-insert tree (symbol-dash-list s))))
tree))


(expand-symbol-list +input-list+)
<<<<<

Output:
((ABC) (XYZ) (EF- (EF-GH) (EF-XY))
(CL- (CL-F- (CL-F-A) (CL-F-B)) (CL-X- (CL-X-Y) (CL-X-AZ))) (DEF))

[Kaz Kylheku]

On 2017-03-26, Jack Mudge <jaky...@theanythingbox.com> wrote:
> (defun symbol-dash-list (symbol)
> "Return 'parent' symbols of a symbol with dashes in its name, in order"
> (let ((s (symbol-name symbol)))
> (mapcar (lambda (pos) (intern (subseq s 0 pos)))
> (loop for pos = (position #\- s)
> then (position #\- s :start (1+ pos))
> until (null pos)
> collect (1+ pos) into ret
> finally (return (nconc ret (list (length s))))))))

Check this out:

$ txr
This is the TXR Lisp interactive listener of TXR 173.
Use the :quit command or type Ctrl-D on empty line to exit.
1> (let* ((s "du-hast-mich"))
(build
(each ((i (where (op eq #\-) s)))
(add [s 0..(succ i)]))
(add s)))
("du-" "du-hast-" "du-hast-mich")

TXR: the light-weight scripting language for us Lisp people.

[Jack Mudge]

Interesting. I'll have to check TXR out in a little more depth. Thanks for pointing it out!

[Madhu]

* Jack Mudge <e7abcdeb-7a1b-46df...@googlegroups.com> :
Wrote on Sun, 26 Mar 2017 12:10:10 -0700 (PDT):

| (defun tree-insert (tree path)
| (cond ((null path) ; no more path to traverse
| tree)
| ((find (car path) tree :test 'node-equal-p) ; have child node
| (let* ((olditem (find (car path) tree :test 'node-equal-p))
| (newitem (typecase olditem
| (symbol (tree-insert (list olditem) (cdr path)))
| (list (tree-insert olditem (cdr path))))))
| (substitute newitem olditem tree)))
| (t (tree-insert (append tree (list (car path))) ; no child node
| path))))

You can get rid of the typecase node-equal-p if you insist that tree is
always a list of conses: and tree-insert always returns such a
"wellformed" tree (even if the input tree is nil) - Eg.

(defun tree-insert (tree path &aux x)
(cond ((null path) tree)
((setq x (find (car path) tree :key #'car))
(prog1 tree
(rplacd x (tree-insert (cdr x) (cdr path)))))
(t (tree-insert (append tree (list (list (car path))))
path))))

[schatze...@gmail.com]

The "larger problem" consists in grouping the symbols of a package by their names.

------------------------------
list of some symbols in cl-fad
------------------------------
canonical-pathname
copy-file
copy-stream
delete-directory-and-files
directory-exists-p
directory-pathname-p
file-exists-p
list-directory
merge-pathnames-as-directory
merge-pathnames-as-file
open-temporary
pathname-absolute-p
pathname-as-directory
pathname-as-file
pathname-directory-pathname
pathname-equal
pathname-parent-directory
pathname-relative-p
pathname-root-p
walk-directory

------------------------------
this should be the tree structure
-inserted headers are in uppercase
-a header is needed only if there are more children
------------------------------
canonical-pathname
COPY-
copy-file
copy-stream
delete-directory-and-files
DIRECTORY-
directory-exists-p
directory-pathname-p
file-exists-p
list-directory
MERGE-PATHNAMES-AS-
merge-pathnames-as-directory
merge-pathnames-as-file
open-temporary
PATHNAME-
pathname-absolute-p
PATHNAME-AS-
pathname-as-directory
pathname-as-file
pathname-directory-pathname
pathname-equal
pathname-parent-directory
pathname-relative-p
pathname-root-p
walk-directory

[Jack Mudge]

That is a substantial improvement.

One thing I was trying to do (although unstated) was keep tree-insert side effect free, but rplacd is probably faster (and I think I can see what would need to change to keep it side effect free too). Thanks!

[Madhu]

* Jack Mudge <4c2d93bd-b0b2-45d3...@googlegroups.com> :
Wrote on Mon, 27 Mar 2017 22:24:31 -0700 (PDT):

|> (defun tree-insert (tree path &aux x)
|> (cond ((null path) tree)
|> ((setq x (find (car path) tree :key #'car))
|> (prog1 tree
|> (rplacd x (tree-insert (cdr x) (cdr path)))))
|> (t (tree-insert (append tree (list (list (car path))))
|> path))))
|
| That is a substantial improvement.
|
| One thing I was trying to do (although unstated) was keep tree-insert
| side effect free, but rplacd is probably faster (and I think I can see
| what would need to change to keep it side effect free too)

Indeed, the same `substitute' trick used upthread would work to keep it
sideeffect free, (and you are still sharing structure).

But if you are only ever building up the tree starting with an empty
tree, and repeated tree-inserts, it doesn't really make sense to keep
things copy-only. And if I were writing a version which mutates the
tree, then I would have used NCONC instead of APPEND or better yet, I'd
have said (cons (list (car path)) tree), to insert a new path.

[Kaz Kylheku]

More complete solution, minus triviality oof mapping from symbols to names and back:

(defun spread-prefixes (str)
(build
(each ((i (where (op eq #\-) str)))
(add [str 0..(succ i)]))
(add str)))

(defun hierarchify (pfx-clusters)
(collect-each ((group [partition-by car pfx-clusters]))
(tree-case group
(((leader . pack) next . others)
(list leader (hierarchify [mapcar cdr group])))
(((loner))
loner))))

(let ((data '#"abc xyz ef-gh ef-xy cl-f-a cl-f-b cl-x-y cl-x-az def"))
(prinl (hierarchify [mapcar spread-prefixes data])))

Output:

("abc" "xyz"
("ef-" ("ef-gh" "ef-xy"))
("cl-" (("cl-f-" ("cl-f-a" "cl-f-b"))
("cl-x-" ("cl-x-y" "cl-x-az"))))
"def")

Is that right?

[Kaz Kylheku]

Nope. But that's a trivial tweak.

What we do is change (list leader ..) -> (list* leader ...)
and loner -> (list loner)

(defun hierarchify (pfx-clusters)
(collect-each ((group [partition-by car pfx-clusters]))
(tree-case group
(((leader . pack) next . others)

(list* leader (hierarchify [mapcar cdr group])))
(((loner))
(list loner)))))

Now we get:

(("abc")
("xyz")
("ef-" ("ef-gh")
("ef-xy"))
("cl-" ("cl-f-" ("cl-f-a")
("cl-f-b"))
("cl-x-" ("cl-x-y")
("cl-x-az")))
("def"))

[Kaz Kylheku]

On 2017-03-28, Kaz Kylheku <336-98...@kylheku.com> wrote:
>> More complete solution, minus triviality oof mapping from symbols to names and back:
>>
>> (defun spread-prefixes (str)
>> (build
>> (each ((i (where (op eq #\-) str)))
>> (add [str 0..(succ i)]))
>> (add str)))
>>
>
> (defun hierarchify (pfx-clusters)
> (collect-each ((group [partition-by car pfx-clusters]))
> (tree-case group
> (((leader . pack) next . others)

> (list* leader (hierarchify [mapcar cdr group])))

^^ two argument list* --> cons!

> (((loner))
> (list loner)))))

Shortened, still without "golfing":

(defun spread-prefixes (str)
(build
(each ((i (where (op eq #\-) str)))
(add [str 0..(succ i)]))
(add str)))

(defun hierarchify (pfx-clusters)
(collect-each ((group [partition-by car pfx-clusters]))

(tree-bind ((head . tail) . others) group
(cons head (if tail (hierarchify [mapcar cdr group]))))))

(let ((data '#"abc xyz ef-gh ef-xy cl-f-a cl-f-b cl-x-y cl-x-az def"))
(prinl (hierarchify [mapcar spread-prefixes data])))

All you need is partition-by and hieararchify will translate reasonably
to CL.

tree-bind is just destructuring-bind, and collect-each
can be done with loop/collect.

What partition-by does is carve the list into partitions based on equal
values of some function. The default equality is equal, which handles
strings; in contrast to the usual #'eql convention in CL.

The spec is here: http://www.nongnu.org/txr/txr-manpage.html#N-000167DF

[Robert L.]

MatzLisp (Ruby):

def foo( array, prefix = "" )
array.
chunk{|s| s[ /^#{ prefix }.*?(_|$)/ ] }.
map{|(key,values)|
if values.one?
values
else
[key.to_sym, foo( values, key )]
end
}
end

foo([:abc, :xyz, :ef_gh, :ef_xy, :cl_f_a, :cl_f_b, :cl_x_y, :cl_x_az, :def])

[[:abc],
[:xyz],
[:ef_,
[[:ef_gh],
[:ef_xy]]],
[:cl_,
[[:cl_f_,
[[:cl_f_a],
[:cl_f_b]]],
[:cl_x_,
[[:cl_x_y],
[:cl_x_az]]]]],
[:def]]

--
Goyim were born only to serve us.... They will work, they will plow, they will
reap. We will sit like an effendi and eat. --- Rabbi Ovadia Yosef
web.archive.org/web/20101020044210/http://www.jpost.com/JewishWorld/JewishNews/Article.aspx?id=191782
archive.org/download/DavidDuke_videos/TopRabbiExposesJewishRacism-cybsdwjezqi.ogv

[Robert L.]

On 3/26/2017, Kaz Kylheku wrote:

> 1> (let* ((s "du-hast-mich"))
> (build
> (each ((i (where (op eq #\-) s)))
> (add [s 0..(succ i)]))
> (add s)))
> ("du-" "du-hast-" "du-hast-mich")

MatzLisp (Ruby):

a = 'du-hast-mich'.scan(/[^-]+-?/)
(1..a.size).map{|n| a.take(n).join}

===>
["du-", "du-hast-", "du-hast-mich"]

--
Jews totally run Hollywood.... But I don't care if Americans think we're
running the news media, Hollywood, Wall Street, or the government. I just care
that we get to keep running them. --- Joel Stein
articles.latimes.com/2008/dec/19/opinion/oe-stein19
archive.org/download/DavidDukeTv/DoJewsControlTheMediaTheLaTimesSaysYes.flv