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.
Related
Write a function that takes a list and a length as input and returns two lists: (1) The first length elements of the input list, and (2) the remainder of the input list. Hint: Use a helper method with an "accumulator" parameter. I'm stuck guys and could really use some help.
I keep getting error when I try to do (split-list '(a b c d e f g) 7) which is the number equal to length otherwise any number less than than that does what its supposed to do
:
Argument #1 '()' to 'car' has wrong type (empty-list)
(split-list '(a b c d e f g) 0) should return '(() (a b c d e f g))
(split-list '(a b c d e f g) 1) should return '((a) (b c d e f g))
(split-list '(a b c d e f g) 3) should return '((a b c) (d e f g))
(define (split-list lst length)
(define(split-list-head accum length)
(if (= length 0)
(cdr '(accum))
(cons (car accum) (split-list-head (cdr accum)(- length 1)))
)
)
(define(split-list-tail accum length)
(if (= length 0)
(cons (car accum)(cdr accum))
(split-list-tail (cdr accum)(- length 1))
)
)
(if (eq? length 0)
(append(list (list))(list lst))
(append(list(split-list-head lst length)) (list(split-list-tail lst length)))
)
)
Unless you are particularly attached to GNU Scheme, I would consider moving to Dr Racket.
Although it was written for a similar language called Racket, it can be set up to run vanilla Scheme, by putting in a first line #lang scheme
The nice about Dr Racket is that it has a very nice debugger.
My code, with the #lang line at the start, and the erroring line at the bottom:
#lang scheme
(define (split-list lst length)
(define(split-list-head accum length)
(if (= length 0)
(cdr '(accum))
(cons (car accum) (split-list-head (cdr accum)(- length 1)))
)
)
(define(split-list-tail accum length)
(if (= length 0)
(cons (car accum)(cdr accum))
(split-list-tail (cdr accum)(- length 1))
)
)
(if (eq? length 0)
(append(list (list))(list lst))
(append(list(split-list-head lst length)) (list(split-list-tail lst length)))
)
)
(split-list '(a b c d e f g) 7)
If I just run the code, it highlights the error in split-list-tail, where car causes a contract violation. It also shows the call sequence.
That's probably enough to identify the fault, but I can also run the debugger. By clicking on the Debug button I move to the debug mode. By moving the mouse pointer over a parenthesis, and right clicking, I can enable or disable a pause at this point - show by a pink circle. The variables are shown on the right hand side. When I run the code in the debugger, variable accum is empty, hence car accum fails.
My suggestion is that you use pair? or null? to test accum before calling car on it.
Try this. It makes use of three accumulating parameters. A subtraction is also kind of accumulation.
(define (split n xs k)
(define (loop xs n k)
(if
(and (> n 0) (not (null? xs)))
(loop (cdr xs) (- n 1)
(lambda (a b) (k (cons (car xs) a) b)))
(k '() xs)))
(loop xs n k))
Can you see how it is to be called?
Can you explain how it works?
Or a bit shorter,
(define (split n xs k)
(define ((+ f a) b) (f (cons (car a) b)))
(define (loop xs n k)
(if
(and (> n 0) (not (null? xs)))
(loop (cdr xs) (- n 1) (+ k xs))
((k '()) xs)))
(loop xs n k))
Can you find a way how should this function be called? I'll give you a hint, how should this function
(define ((add a) b) (list a b))
be called?
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 want to fix my own function that gives the same result with the default intersection function. I've been trying to write a lisp code which prints same elements in the two lists. My code works for it. But it doesn't work for nested lists. How can I fix this?
(defun printelems (L1 L2)
(cond
((null L1) nil) ((member (first L1) L2) (cons (first L1) (printelems (rest L1) L2)))
(t (printelems (rest L1) L2))))
Expected inputs and outputs
(printelems '(2 3 5 7) '( 2 3)) => It works
=> (2 3)
(printelems '(a b '(c f)) '(a d '(c f) e)) => It doesn't work.
=> (a (c f))
Edit
Using the default intersection function works as intended. How can I use the equal function in my recursive function?
For default intersection,
(intersection '(a b (c f)) '(a d (c f) e) :test 'equal)
((C F) A)
(intersection '(a b (c f)) '(a d c f e) :test 'equal)
(A)
My intersection,
(printelems '(a b (c f)) '(a d c f e))
(A C F)
(printelems '(a b (c f)) '(a d (c f) e) )
(A C F)
My edited code:
(defun flatten (l)
(cond ((null l) nil)
((atom (car l)) (cons (car l) (flatten (cdr l))))
(t (append (flatten (car l)) (flatten (cdr l))))))
(defun printelemsv1(list1 list2)
(cond
((null list1) nil)
(((member (first list1) list2) (cons (first list1) (printelemsv1 (rest list1) list2)))
(t (printelemsv1 (rest list1) list2)))))
(defun printelems (L1 L2)
(printelemsv1 (flatten L1) (flatten L2)))
Common Lisp already has an intersection function. If you want to compare sublists like (C F), you'll want to use equal or equalp as the test argument.
(intersection '(a b '(c f)) '(a d '(c f) e) :test 'equal)
;=> ('(C F) A)
While it doesn't change how intersection works, you probably don't really want quote inside your list. Quote isn't a list creation operator; it's a "return whatever the reader read" operator. The reader can read (a b (c f)) as a list of two symbols and a sublist, so (quote (a b (c f))), usually abbreviated as '(a b (c f)) is fine. E.g.:
(intersection '(a b (c f)) '(a d (c f) e) :test 'equal)
;=> ((C F) A)
It's always helpful when you provide an example of input and the expected output. I assume you mean you have two lists like '(1 (2 3) 4) and '((1) 2 5 6) that the function should produce '(1 2). In this case you can just flatten the two lists before giving them to printelems.
Since I'm not familiar with Common-Lisp itself I will leave you with one example and a link.
(defun flatten (structure)
(cond ((null structure) nil)
((atom structure) (list structure))
(t (mapcan #'flatten structure))))
Flatten a list - Rosetta Code
flatten takes an arbitrary s-expression like a nested list '(1 (2 3) 4) and returns '(1 2 3 4).
So now you just have to write a new function in which you use your printelems as a helper function and give it flattened lists.
(defun printelems.v2 (L1 L2)
(printelems (flatten L1) (flatten L2)))
Take this with a grain of salt, since as said before I'm not familiar with Common-Lisp, so appologies in advance for any potential syntax errors.
I am trying to find depth of each element in a list and simultaneously create a output where flattened output is written with their depth level , so far i came up with following logic -
(define nestingDepth
(lambda (lst1)
(cond ((null? lst1) 1)
((list? (car lst1))
(cons(+ 1(nestingDepth (car lst1)))) (nestingDepth (cdr lst1)))
((null? (cdr lst1)) (cons (1 (cdr lst1))) (nestingDepth (cdr lst1))))))
But this is not printing anything in output. Please update where i am going wrong.
Expected result will look like -
input - '(a (b) c)
output - (1 a 2 b 1 c)
As some other answers have mentioned, it's important to make sure that each case retursn something of the proper type. If the input is the empty list, then the output should be the empty list. If the input is a pair, then you need to handle the car and the cdr of the pair and connect them. If the input is neither the empty list nor a pair, then the result is a list of the depth and the input.
Now, it may be handy to build the result incrementally. You can build from the right to the left, and add each element and its depth using an approach like the following:
(define (depths tree)
(let depths ((tree tree)
(depth 0)
(results '()))
(cond
((null? tree) results)
((pair? tree) (depths (car tree)
(+ 1 depth)
(depths (cdr tree)
depth
results)))
(else (cons depth (cons tree results))))))
> (depths '(a ((b) c ((d))) e))
(1 a 3 b 2 c 4 d 1 e)
Here's one possible solution (I have changed the output format a little to make the solution easier to code). append-map is defined in SRFI 1.
(define (depths x)
(cond ((list? x)
(append-map (lambda (y)
(map (lambda (z)
(cons (car z) (+ (cdr z) 1)))
(depths y)))
x))
(else `((,x . 0)))))
(I write the code as a seasoned Schemer would write it, not as someone would write a homework assignment. If that's your situation, try to understand what my code does, then reformulate it into something homework-acceptable.)
All the previous solutions work well for proper (nested) lists, for those who work for improper lists I am not sure if they are correct.
For example, (depths '(a . b)) yields (1 a 0 b) for Joshua's, and (((a . b) . 0)) for Chris', but I'd say it should be (1 a 1 b).
I'd therefore go for
(define (depths sxp)
(let loop ((sxp sxp) (res null) (level (if (cons? sxp) 1 0)))
(cond
((null? sxp) res)
((pair? sxp) (let ((ca (car sxp)))
(loop ca
(loop (cdr sxp) res level)
(if (pair? ca) (add1 level) level))))
(else (cons level (cons sxp res))))))
and my test cases are:
(check-equal? (depths '(a . b)) '(1 a 1 b))
(check-equal? (depths 'a) '(0 a)) ; 0
(check-equal? (depths '(a)) '(1 a))
(check-equal? (depths '(a a)) '(1 a 1 a))
(check-equal? (depths '(a (b . c) d (e (f (g h . i) . j)))) '(1 a 2 b 2 c 1 d 2 e 3 f 4 g 4 h 4 i 3 j))
(check-equal? (depths '(a (b) c)) '(1 a 2 b 1 c))
(check-equal? (depths '(a ((b) c ((d))) e)) '(1 a 3 b 2 c 4 d 1 e))
(check-equal? (depths '(a (b (c (d e))) f g)) '(1 a 2 b 3 c 4 d 4 e 1 f 1 g))
The base case is wrong (you can't return 1 if you intend to output a list as a result), the way the recursion is being advanced doesn't build a list as output … a complete rewrite is needed; the following solution is portable and should work on any Scheme interpreter, making use only of basic procedures:
(define (nestingDepth lst)
(let depth ((lst lst) (n 1))
(cond ((null? lst) '())
((not (pair? (car lst)))
(cons n
(cons (car lst)
(depth (cdr lst) n))))
(else
(append (depth (car lst) (+ 1 n))
(depth (cdr lst) n))))))
The output is as expected:
(nestingDepth '(a (b (c (d e))) f g))
=> '(1 a 2 b 3 c 4 d 4 e 1 f 1 g)
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))