How can I transform this list:
'((A B) (A C) (C D) (B D) (D E) (D F))
Into something like
'(A (B (nil)) (C (D ((F (nil)) (E (nil))))))
Or whatever list best represent the tree:
A
/ \
B C
|
D
/ \
E F
Note that as C was the first to claim D as its child, the (B D) didn't add the D as the child of B.
first of all i would clean up the data, removing all the unnecessary pairs (in your case '(B D)), and build the adjacency map:
user> (def data '((A B) (A C) (C D) (B D) (D E) (D F)))
#'user/data
user> (def nodes-map (group-by first
(apply sorted-set-by
#(compare (second %1) (second %2))
data)))
#'user/nodes-map
user> nodes-map
{A [(A B) (A C)], C [(C D)], D [(D E) (D F)]}
i removed the garbage using sorted-set, using the fact that it treats items to be equal using comparator, and keep only the first of them (in this case it considers (C D) and(B D) to be equal)
then i would construct the tree, using recursive function:
user> (defn to-tree [start nodes]
(list start
(if-let [connections (seq (nodes start))]
(map #(to-tree (second %) nodes) connections)
'(nil))))
#'user/to-tree
user> (to-tree 'A nodes-map)
(A ((B (nil)) (C ((D ((E (nil)) (F (nil))))))))
Related
I'm trying to replace an item with another item when given a list. I've gotten to code out a procedure that can do this for a flat list but I was not sure how to implement it when the list is not a flat list.
This is the current code for the replacer:
(define repl
(lambda (exp1 exp2 exp3)
(cond
((null? exp3) exp3)
((equal? (first exp3) exp1) (cons exp2 (repl exp1 exp2 (rest exp3))))
(else (cons (first exp3) (repl exp1 exp2 (rest exp3)))))))
I'm very new to coding in racket so I wasn't sure how I would then be able to apply this when it's not a flat list
A valid test case is the following
(repl 'a 'b '((f a) (f (a)))) => '((f b) (f (b)))
But when I run my current procedure it produces
'((f a) (f (a)))
How would I go about applying my current code to work for non flat lists?
You need to consider a new case in the recursion: what if the current element in the list is another list? in that case, we need to do a deeper recursion, and descend over both the current element and the rest of the list. Otherwise, check if the current element needs to be replaced, or leave it alone. This is what I mean, notice that this is a faster solution when we only want to replace atoms:
(define repl
(lambda (exp1 exp2 exp3)
(cond
; base case: list is empty
((null? exp3) exp3)
; base case: current element is an atom
((not (pair? exp3))
; should we replace current element?
(if (equal? exp3 exp1) exp2 exp3))
; recursive case: current element is a list
(else
; recursively descend over both sublists
(cons (repl exp1 exp2 (first exp3))
(repl exp1 exp2 (rest exp3)))))))
It works as expected, no matter how deeply nested is the element that you want to replace:
(repl 'm 'x '((a (b (c (d e (f (m))) h) i (j) (k (l (m)))) n) o (p)))
=> '((a (b (c (d e (f (x))) h) i (j) (k (l (x)))) n) o (p))
EDIT: Now, if the elements you want to replace are lists themselves, we have to shuffle around the conditions. Below you'll find the implementation, it's more general than my previous solution, but also it's slower. Thanks to #amalloy for suggesting this approach:
(define (repl exp1 exp2 exp3)
(cond ; base case: list is empty
((null? exp3) exp3)
; base case: current element is the one we're looking for
((equal? exp1 exp3) exp2)
; recursive case: current element is a list
((pair? exp3) (cons (repl exp1 exp2 (first exp3))
(repl exp1 exp2 (rest exp3))))
; base case: current element is not the one we're looking for
(else exp3)))
For example:
(repl '(f (g)) 'x '((a (b (c (d e (f (g))) h) i (j) (k (l (m)))))))
=> '((a (b (c (d e x) h) i (j) (k (l (m))))))
try this:
(define replace
(lambda (x y l)
(fold-right (lambda (e acc)
(if (pair? e)
(cons (replace x y e) acc)
(cons (if (eq? e x) y e) acc)))
'()
l)))
This would be trivial in Common Lisp, which has a function subst that does exactly this kind of replacement.
* (subst 'b 'a '((f a) (f (a))))
((F B) (F (B)))
* (subst 'x 'm '((a (b (c (d e (f (m))) h) i (j) (k (l (m)))) n) o (p)))
((A (B (C (D E (F (X))) H) I (J) (K (L (X)))) N) O (P))
* (subst 'x '(f (g)) '((a (b (c (d e (f (g))) h) i (j) (k (l (m)))))) :test #'equal)
((A (B (C (D E X) H) I (J) (K (L (M))))))
Unfortunately, the CL functions that work on trees/non-flat lists never made their way into the Scheme ecosystem. I wrote Racket implementations of many of them a while back; here's the one for subst for posterity's sake:
(define (subst new old tree #:test [test eqv?] #:key [key identity])
(cond
((test old (key tree)) new)
((pair? tree)
(let ([new-car (subst new old (car tree) #:test test #:key key)]
[new-cdr (subst new old (cdr tree) #:test test #:key key)])
(if (and (eqv? (car tree) new-car)
(eqv? (cdr tree) new-cdr))
tree
(cons new-car new-cdr))))
(else tree)))
> (subst 'b 'a '((f a) (f (a))))
'((f b) (f (b)))
> (subst 'x 'm '((a (b (c (d e (f (m))) h) i (j) (k (l (m)))) n) o (p)))
'((a (b (c (d e (f (x))) h) i (j) (k (l (x)))) n) o (p))
> (subst 'x '(f (g)) '((a (b (c (d e (f (g))) h) i (j) (k (l (m)))))) #:test equal?)
'((a (b (c (d e x) h) i (j) (k (l (m))))))
One thing to note about this implementation is that it reuses subtrees that aren't modified, potentially saving a lot of memory when used on big data structures with sparse replacements.
I was going to post this to the codereview stackexchange but I saw that you should only post working code. I asked this question earlier: Reordering parentheses using associative property in Racket
In case you don't check the link basically I want to rearrrange a list of symbols so that this:
'((a + b) + c) -> '(a + (b + c))
or this:
'((a + b) + (c + d)) -> '(a + (b + (c + d)))
This is the code I've written so far:
(define (check? expr)
(display expr)
(newline)
(cond ((null? expr) -1)
((and (atom? (car expr)) (atom? (cadr expr))) 0) ;case 0
((and (atom? (car expr)) (list? (cadr expr))) 1) ;case 1
((and (list? (car expr)) (null? (cdr expr))) (check? (car expr))) ;nested expression for example '((a b))
((and (list? (car expr)) (atom? (cadr expr))) 2) ;case 2
((and (list? (car expr)) (list? (cadr expr))) 3) ;case 3
(else -1)))
(define (rewrite x)
(display (check? x))
(newline)
(cond ((null? x))
((atom? x) x)
((= 0 (check? x)) x) ;case 0 is '(a + b)
((= 1 (check? x)) (cons (car x) (rewrite (cdr x)))) ;case 1 is '(a + (b + c))
((= 2 (check? x)) (rewrite (list (caar x) (cons (cadar x) (cdr x))))) ;case 2 is ((b + c) + a)
((= 3 (check? x)) (rewrite ((list (caar x) (cons (cadar x) (cdr x))))))));case 3 is ((a + b) + (c + d))
;(rewrite '(((d c) b) a))
(rewrite '(a b))
(rewrite '(a (b c)))
(rewrite '((a b) (c d)))
Am I on the right track? If not does anyone have any pointers? Am I creating the lists wrong? If you need any more information let me know or if I should comment the code better also let me know.
In case you don't check the earlier question, this is the answer I got (which was very helpful):
var -> var
(var + var) -> (var + var)
(var + (fip1 + fpip2)) -> (var + (REWRITE (fip1 + fpip2))
((fip1 + fpip2) + var) -> (REWRITE (fip1 + (fip2 + var))
((fip1 + fpip2) + (fip3 + fpip4)) -> (REWRITE (fip1 + (fip2 + (fip3 + fip4))))
The following is the grammar you have defined for your syntax:
var ::= a | b | c | d | e | f | g
fpip ::= var | (fpip + fpip)
As such, we can start by defining predicates that test whether a given expression is valid or not, using the rules set above:
(define (var? e)
(member e '(a b c d e f g)))
(define (fpip? e)
(cond
((var? e) #t)
((or (not (pair? e))
(null? e)
(null? (cdr e))
(null? (cddr e))
(not (null? (cdddr e))))
#f)
(else (and (fpip? (car e))
(equal? (cadr e) '+)
(fpip? (caddr e))))))
Now we can say, for example:
> (fpip? 'a)
#t
> (fpip? '((a + b) + c))
#t
> (fpip? '((+(d + e) + f) + (a + (a + c))))
#f
With that in place, rewrite can be written as the right-associative form of an expression, if the expression is valid fpip, and #f otherwise:
(define (rewrite e)
(if (not (fpip? e))
#f
(rewrite-fpip e)))
Next, we will define rewrite-fpip to be a procedure that accepts and transforms any valid fpip, as follows:
(define (rewrite-fpip e)
(cond
((not (pair? e)) e) ;; var
((not (pair? (car e)))
(list (car e) '+ (rewrite-fpip (caddr e)))) ;; (var + fpip)
(else
(rewrite-fpip ;; (fpip + fpip)
(list (caar e) '+ (list (caddar e) '+ (caddr e)))))))
Thus we can have:
> (rewrite 'a)
'a
> (rewrite '((a + b) + c))
'(a + (b + c))
> (rewrite '((a + b) + (c + d)))
'(a + (b + (c + d)))
> (rewrite '(((d + e) + f) + (a + (a + c))))
'(d + (e + (f + (a + (a + c)))))
That they tell you not to use the flattening in your solution doesn't mean you can't use the flattening in the derivation of your solution.
Writing in an imaginary pattern-matching equational pseudocode (because it is much shorter and visually apparent, i.e. easier to follow),
flatten a = flatten2 a [] ; [] is "an empty list"
flatten2 (a+b) z = flatten2 a (flatten2 b z) ; if it matches (a+b)
flatten2 a [] = a ; if it doesn't, and the 2nd is []
flatten2 a b = a + b ; same, and the 2nd arg is not []
Oh wait, I'm not flattening it here, I am building the normalized sum expressions here!
The only problem with this approach is the needless check for [] repeated over and over when we know it will only ever be true once -- it is we who write this code after all.
Fusing this knowledge in, we get
normalize a = down a ; turn EXPR ::= ATOM | EXPR + EXPR
down (a + b) = up a (down b)
down a = a ; into NormExpr ::= ATOM | ATOM + NormExpr
up (a + b) z = up a (up b z)
up a b = a + b
Now all's left is to code this up in regular Scheme. Scheme also has the advantage that the test can be much simplified to just
(define (is-sum? a+b) (pair? a+b))
edit: The final function from the other answer in the same pseudocode is:
rewrite ((a + b) + c) = rewrite (a + (b + c)) ; rotate right!
rewrite (a + b) = a + rewrite b ; go in, if the first rule didn't match
rewrite a = a ; stop, if the first two didn't match
It rearranges the + nodes' tree structure before starting the work1, whereas the solution in this answer follows the input structure while transforming it. As the result, thanks to the nested recursion the run time stack will only be as deep as the input structure, whereas with rewrite it will always be n levels deep at the deepest point, when the list is fully linearized on the stack (in the second rule), just before the sums are assembled on the way back up.
But the first rule in rewrite is tail recursive, and the second is tail recursive modulo cons, so rewrite can be rewritten in a tail-recursive style as a whole, with few standard modifications. Which is definitely a plus.
On the other hand this new code will have to surgically modify (i.e. mutate) the + nodes (see the Wikipedia article linked above, for details), so you'll have to choose your implementation of this data type accordingly. If you use lists, this means using set-car! and/or set-cdr!; otherwise you can implement them as Racket's #:mutable structures. When the result is built, you could convert it to a regular list with an additional O(n) traversal, if needed.
1 reminiscent of the old gopher trick from John McCarthy, burrowing into the input structure, with reified continuations.
What I am trying to do here is to delete each element that has the same depth as I want. So, for example this test
(del-sublist '(a b c (d) ((e) a)) 2)
should return:
(A B C (D) (A))
Here is my code.
(defun del-sublist (l n)
(if (null l) '()
(let ((el (car l)))
(if (= n 0) nil
(cond
((atom el)
(remove nil (cons el
(del-sublist (cdr l) n))))
((listp el)
(remove nil (cons '()
(cons (del-sublist el (- n 1))
(del-sublist (cdr l) n))))))))))
This code doesn't work for this kinda test:
(del-sublist '(a b c (d (()) e) ((e) a)) 3)
It returns:
(A B C (D E) ((E) A))
When it's supposed to return this:
(A B C (D () E) ((E) A))
This algorithm should delete all the elements of the same depth(or greater) but leave the rest. I just don't know how to return an empty list.
The whole idea of the algorithm is that when you go inside the bracket your depth level increases and when you are on the right level you remove everything in there until you go outside this bracket and your depth level decreases back.
Note that in Lisp () and NIL are exactly the same object.
Maybe something like this:
(defun del-sublist (l n)
(cond ((null l)
())
((and (atom l) (zerop n))
l)
((zerop n)
nil)
(t
(let ((el (first l)))
(cond ((null el)
(del-sublist (rest l) n))
((atom el)
(cons el (del-sublist (rest l) n)))
(t
(cons (del-sublist el (- n 1))
(del-sublist (rest l) n))))))))
Empty list:
CL-USER 107 > (del-sublist '() 0)
NIL
One level:
CL-USER 108 > (del-sublist '(a b c) 0)
NIL
CL-USER 109 > (del-sublist '(a b c) 1)
(A B C)
Two levels:
CL-USER 110 > (del-sublist '(a (b) c) 0)
NIL
CL-USER 111 > (del-sublist '(a (b) c) 1)
(A NIL C)
CL-USER 112 > (del-sublist '(a (b) c) 2)
(A (B) C)
Three levels:
CL-USER 113 > (del-sublist '(a (b (d) e) c) 0)
NIL
CL-USER 114 > (del-sublist '(a (b (d) e) c) 1)
(A NIL C)
CL-USER 115 > (del-sublist '(a (b (d) e) c) 2)
(A (B NIL E) C)
CL-USER 116 > (del-sublist '(a (b (d) e) c) 3)
(A (B (D) E) C)
CL-USER 117 > (del-sublist '(a (b (d) (f) e) c) 3)
(A (B (D) (F) E) C)
CL-USER 118 > (del-sublist '(a (b (d) (f) e) c) 2)
(A (B NIL NIL E) C)
I think that you should do this recursively. As long as n is bigger than 1 (or maybe 0?), just keep every atom and recurse with (1- n) into every list. When n is 1 (or maybe 0?), return the empty list.
I also do not see how your examples could be consistent if the second doesn't return (A B C (D () E) (() A)).
From any given list in lisp, I want to get the two element combinations of the elements of that list without having duplicate combinations ( meaning (a b) = (b a) and one should be removed)
So for example if I have a list that is (a b c d),
I want to get ((a b) (a c) (a d) (b c) (b d) (c d))
(defun combinations (list)
(loop for (a1 . r1) on list
nconc (loop for a2 in r1 collect (list a1 a2))))
CL-USER 172 > (combinations '(a b c d))
((A B) (A C) (A D) (B C) (B D) (C D))
Assuming I'm understanding you correctly, I'd use mapcar and friends.
(defun pair-with (elem lst)
(mapcar (lambda (a) (list elem a)) lst))
(defun unique-pairs (lst)
(mapcon (lambda (rest) (pair-with (car rest) (cdr rest)))
(remove-duplicates lst)))
That should let you
CL-USER> (unique-pairs (list 1 2 3 4 5))
((1 2) (1 3) (1 4) (1 5) (2 3) (2 4) (2 5) (3 4) (3 5) (4 5))
CL-USER> (unique-pairs (list :a :b :c :a :b :d))
((:C :A) (:C :B) (:C :D) (:A :B) (:A :D) (:B :D))
If you're not scared of loop, you can also write the second one slightly more clearly as
(defun unique-pairs (lst)
(loop for (a . rest) on (remove-duplicates lst)
append (pair-with a rest)))
instead. I'm reasonably sure that loops append directive is more efficient than the function of the same name.
Scheme solution:
(define (lol lst)
(let outer ((lhs lst))
(if (null? lhs)
'()
(let inner ((rhs (cdr lhs)))
(if (null? rhs)
(outer (cdr lhs))
(cons (list (car lhs) (car rhs)) (inner (cdr rhs))))))))
And a Common Lisp translation of same:
(defun lol (list)
(labels ((outer (lhs)
(and lhs (labels ((inner (rhs)
(if rhs
(cons (list (car lhs) (car rhs))
(inner (cdr rhs)))
(outer (cdr lhs)))))
(inner (cdr lhs))))))
(outer list)))
Sorry, I'm not a Common Lisper, so I hope this isn't too ugly. :-)
This is similar to Rainer's Joswig answer, in principle, except it doesn't use loops.
(defun combinations (list)
(mapcon (lambda (x) (mapcar (lambda (y) (list (car x) y)) (cdr x))) list))
One thing that confuses me about your example is that (a a) matches your verbal description of the desired result, but in the example of the result you've excluded it.
This is my own initial answer. It might not be completely efficient but it solves the problem.
(remove nil (let ((res))
(dotimes (n (length test-list) res)
(setq res
(append res
(let ((res2) (rest-list (remove (nth n test-list) test-list)))
(dotimes (m (length rest-list) res2)
(setq res2
(append res2
(list (if (< (nth n test-list) (nth m rest-list))
(list (nth n test-list) (nth m rest-list))
nil)))))))))))
If the "if statement" on line 9 is removed, the result will include also duplicates and the result will be
((a b) (a c) (a d) (a a) (b a) (b c) (b d) (b b)
(c a) (c b) (c d) (c c) (d a) (d b) (d c) (d d))
I have a list of functions, a list of elements, and I'd like to apply all the functions on all the elements then append all the resulting lists together. I did it as follow
(defun apply-functions(funcs elements)
(if (null funcs)
nil
(append (mapcar #'(lambda (x) (funcall (car funcs) x)) elements) (apply-functions (rest funcs) elements))))
It works as intended, but I don't like it. Is there a cleaner, more concise way of doing it?. I am new to lisp, and still getting used to the lispish style of doing things.
I don't know if you like loop macro (and I don't want to spoil anyone), but try this:
(defun apply-functions (fs es)
(loop for f in fs appending (mapcar f es)))
This is the same idea as yours, just shorter:
(defun apply-functions (functions elements)
(mapcan #'(lambda (x) (mapcar x elements)) functions))
I would define a function, call-each that returns a new function,
returning the list of calling each function on it's argument:
(defun call-each (fns)
(lambda (arg)
(mapcar (lambda (fn)
(funcall fn arg))
fns)))
(funcall (call-each (list #'third #'second #'first)) '(a b c))
;=> (C B A)
cl has the function mapcan which is basically nconc + mapcar :
(mapcan #'reverse '((a b c)
(e f g)
(h i j)))
;=> (C B A G F E J I H)
(mapcan (call-each (list #'identity #'1+)) '(1 3 5 7 9))
;=> (1 2 3 4 5 6 7 8 9 10)
unfortunately, nconc, which mapcan uses, is destructive:
(let ((data '((a b c)
(d e f)
(g h i))))
;;here be dragons
(list (mapcan #'identity data)
data))
;=> ((A B C D E F G H I) ((A B C D E F G H I) (D E F G H I) (G H I)))
alexandria to the rescue:
(let ((data '((a b c)
(d e f)
(g h i))))
;;safe version
(list (alexandria:mappend #'identity data)
data))
;=> ((A B C D E F G H I) ((A B C) (D E F) (G H I)))
note that using mapcan is more efficient, but unless you know exactly where
your data is coming from, and who owns it, mappend is the way to go.
so you could write:
(defun apply-functions (fs es)
(when fs
(alexandria:mappend (call-each fs) es))
(apply-functions (list #'identity #'1+) '(1 3 5 7 9))
;=> (1 2 3 4 5 6 7 8 9 10)