I have a list of sublists:
((a b c) (e f) (z h))
and i want to generate something like this:
((a e z) (a f z) (a e h) (a f h) (b e z) (b e h) ... ) and so on.
I want, given a list of sublist, to generate all possibilities of sublists that contains an element from each of the input's sublists.
How can i get this ouput?
You're describing the cartesian product of a list of lists, here's a possible implementation (works in Racket):
(define (cartesian-product lsts)
(foldr (lambda (lst acc)
(for*/list ((x (in-list lst))
(y (in-list acc)))
(cons x y)))
'(())
lsts))
Now, if you're not using Racket, here's a vanilla implementation using mostly standard procedures; it should work on any Scheme interpreter that defines a fold-right-like procedure:
(define (flatmap f lst)
(apply append (map f lst)))
(define (cartesian-product lsts)
(foldr (lambda (lst acc)
(flatmap (lambda (x)
(map (lambda (y)
(cons x y))
acc))
lst))
'(())
lsts))
Either way, it works as expected:
(cartesian-product '((a b c) (e f) (z h)))
=> '((a e z) (a e h) (a f z) (a f h) (b e z) (b e h)
(b f z) (b f h) (c e z) (c e h) (c f z) (c f h))
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.
How do i do in Racket a function that replaces the element of a list at the position n by e.
(repl-elem '(a b c d e) 2 d)
should return a d c d e
In order to replace the element with index 2 in a list with a new element 'A,
one can do the following:
#lang racket
(define xs (list 1 2 3 4 5))
(append (take xs 2)
(list 'A)
(drop xs (+ 2 1)))
I'll leave it as an exercise to turn this into a function.
To see "the mechanics behind this list-set" one can use 'named let' recursion:
(define (f L n c)
(let loop ((x 1)
(ol '()))
(cond
[(> x (length L))
(reverse ol)]
[(= x n)
(loop (add1 x) (cons c ol))]
[else
(loop (add1 x) (cons (list-ref L (sub1 x)) ol))])))
Testing:
(f '(a b c d e) 2 'd)
Output:
'(a d c d e)
OP can figure out how it is working.
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))))))))
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)