Pair combinations in scheme - scheme

I'm trying to find the various combinations that can be made with a list of N pairs in scheme. Here is where I'm at thus far:
(define (pair-combinations list-of-pairs)
(if (null? list-of-pairs)
nil
(let ((first (caar list-of-pairs))
(second (cadar list-of-pairs))
(rest (pair-combinations (cdr list-of-pairs))))
(append
(list (cons first rest))
(list (cons second rest))
))))
Now, I'm not sure if the logic is correct, but what I notice immediately is the telescoping of parentheticals. For example:
(define p1 '( (1 2) (3 4) (5 6) ))
(pair-combinations p1)
((1 (3 (5) (6)) (4 (5) (6))) (2 (3 (5) (6)) (4 (5) (6))))
Obviously this is from the repetition of the list (... within the append calls, so the result looks something like (list 1 (list 2 (list 3 .... Is there a way to do something like the above in a single function? If so, where am I going wrong, and how would it be properly done?
The answer that I'm looking to get would be:
((1 3 5) (1 3 6) (1 4 5) (1 4 6) (2 3 5) (2 3 6) (2 4 5) (2 4 6))
That is, the possible ways to choose one element from N pairs.

Here is one way to think about this problem. If the input is the empty list, then the result is (). If the input is a list containing a single list, then the result is just the result of mapping list over that list, i.e., (combinations '((1 2 3))) --> ((1) (2) (3)).
Otherwise the result can be formed by taking the first list in the input, and prepending each item from that list to all of the combinations found for the rest of the lists in the input. That is, (combinations '((1 2) (3 4))) can be found by prepending each element of (1 2) to each of the combinations in (combinations '((3 4))), which are ((3) (4)).
It seems natural to express this in two procedures. First, a combinations procedure:
(define (combinations xss)
(cond ((null? xss) '())
((null? (cdr xss))
(map list (car xss)))
(else
(prepend-each (car xss)
(combinations (cdr xss))))))
Now a prepend-each procedure is needed:
(define (prepend-each xs yss)
(apply append
(map (lambda (x)
(map (lambda (ys)
(cons x ys))
yss))
xs)))
Here the procedure prepend-each takes a list xs and a list of lists yss and returns the result of prepending each x in xs to the lists in yss. The inner map takes each list ys in yss and conses an x from xs onto it. Since the inner mapping produces a list of lists, and the outer mapping then produces a list of lists of lists, append is used to join the results before returning.
combinations.rkt> (combinations '((1 2) (3 4) (5 6)))
'((1 3 5) (1 3 6) (1 4 5) (1 4 6) (2 3 5) (2 3 6) (2 4 5) (2 4 6))
Now that a working approach has been found, this could be converted into a single procedure:
(define (combinations-2 xss)
(cond ((null? xss) '())
((null? (cdr xss))
(map list (car xss)))
(else
(apply append
(map (lambda (x)
(map (lambda (ys)
(cons x ys))
(combinations-2 (cdr xss))))
(car xss))))))
But, I would not do that since the first version in two procedures seems more clear.
It might be helpful to look just at the results of prepend-each with and without using append:
combinations.rkt> (prepend-each '(1 2) '((3 4) (5 6)))
'((1 3 4) (1 5 6) (2 3 4) (2 5 6))
Without using append:
(define (prepend-each-no-append xs yss)
(map (lambda (x)
(map (lambda (ys)
(cons x ys))
yss))
xs))
combinations.rkt> (prepend-each-no-append '(1 2) '((3 4) (5 6)))
'(((1 3 4) (1 5 6)) ((2 3 4) (2 5 6)))
It can be seen that 1 is prepended to each list in ((3 4) (5 6)) to create a list of lists, and then 2 is prepended to each list in ((3 4) (5 6)) to create a list of lists. These results are contained in another list, since the 1 and 2 come from the outer mapping over (1 2). This is why append is used to join the results.
Some Final Refinements
Note that prepend-each returns an empty list when yss is empty, but that a list containing the elements of xs distributed among as many lists is returned when yss contains a single empty list:
combinations.rkt> (prepend-each '(1 2 3) '(()))
'((1) (2) (3))
This is the same result that we want when the input to combinations contains a single list. We can modify combinations to have a single base case: when the input is '(), then the result is (()). This will allow prepend-each to do the work previously done by (map list (car xss)), making combinations a bit more concise; the prepend-each procedure is unchanged, but I include it below for completeness anyway:
(define (combinations xss)
(if (null? xss) '(())
(prepend-each (car xss)
(combinations (cdr xss)))))
(define (prepend-each xs yss)
(apply append
(map (lambda (x)
(map (lambda (ys)
(cons x ys))
yss))
xs)))
Having made combinations more concise, I might be tempted to go ahead and write this as one procedure, after all:
(define (combinations xss)
(if (null? xss) '(())
(apply append
(map (lambda (x)
(map (lambda (ys)
(cons x ys))
(combinations (cdr xss))))
(car xss)))))

Related

Scheme recursive

Deos anyone know, how I can make this funktion recursive by inserting the function somewhere? I am not allowed to use implemented functions for lists except append, make-pair(list) and reverse.
(: split-list ((list-of %a) -> (tuple-of (list-of %a) (list-of %a))))
(check-expect (split-list (list 1 2)) (make-tuple (list 1) (list 2)))
(check-expect (split-list (list 1 2 3 4)) (make-tuple (list 1 3) (list 2 4)))
(check-expect (split-list (list 1 2 3)) (make-tuple (list 1 3) (list 2)))
(check-expect (split-list (list 1 2 3 4 5)) (make-tuple (list 1 3 5) (list 2 4)))
(check-expect (split-list (list 1 2 3 4 5 6)) (make-tuple (list 1 3 5) (list 2 4 6)))
(define split-list
(lambda (x)
(match x
(empty empty)
((make-pair a empty) (make-tuple a empty))
((make-pair a (make-pair b empty)) (make-tuple (list a) (list b)))
((make-pair a (make-pair b c)) (make-tuple (list a (first c)) (list b (first(rest c))))))))
Code for make-tuple:
(define-record-procedures-parametric tuple tuple-of
make-tuple
tuple?
(first-tuple
rest-tuple))
Here's a way you can fix it using match and a named let, seen below as loop.
(define (split xs)
(let loop ((xs xs) ;; the list, initialized with our input
(l empty) ;; "left" accumulator, initialized with an empty list
(r empty)) ;; "right" accumulator, initialized with an empty list
(match xs
((list a b rest ...) ;; at least two elements
(loop rest
(cons a l)
(cons b r)))
((cons a empty) ;; one element
(loop empty
(cons a l)
r))
(else ;; zero elements
(list (reverse l)
(reverse r))))))
Above we use a loop to build up left and right lists then we use reverse to return the final answer. We can avoid having to reverse the answer if we build the answer in reverse order! The technique used here is called continuation passing style.
(define (split xs (then list))
(match xs
((list a b rest ...) ;; at least two elements
(split rest
(λ (l r)
(then (cons a l)
(cons b r)))))
((cons a empty) ;; only one element
(then (list a) empty))
(else ;; zero elements
(then empty empty))))
Both implementations perform to specification.
(split '())
;; => '(() ())
(split '(1))
;; => '((1) ())
(split '(1 2 3 4 5 6 7))
;; => '((1 3 5 7) (2 4 6))
Grouping the result in a list is an intuitive default, but it's probable that you plan to do something with the separate parts anyway
(define my-list '(1 2 3 4 5 6 7))
(let* ((result (split my-list)) ;; split the list into parts
(l (car result)) ;; get the "left" part
(r (cadr result))) ;; get the "right" part
(printf "odds: ~a, evens: ~a~n" l r))
;; odds: (1 3 5 7), evens: (2 4 6)
Above, continuation passing style gives us unique control over the returned result. The continuation is configurable at the call site, using a second parameter.
(split '(1 2 3 4 5 6 7) list) ;; same as default
;; '((1 3 5 7) (2 4 6))
(split '(1 2 3 4 5 6 7) cons)
;; '((1 3 5 7) 2 4 6)
(split '(1 2 3 4 5 6 7)
(λ (l r)
(printf "odds: ~a, evens: ~a~n" l r)))
;; odds: (1 3 5 7), evens: (2 4 6)
(split '(1 2 3 4 5 6 7)
(curry printf "odds: ~a, evens: ~a~n"))
;; odds: (1 3 5 7), evens: (2 4 6)
Oscar's answer using an auxiliary helper function or the first implementation in this post using loop are practical and idiomatic programs. Continuation passing style is a nice academic exercise, but I only demonstrated it here because it shows how to step around two complex tasks:
building up an output list without having to reverse it
returning multiple values
I don't have access to the definitions of make-pair and make-tuple that you're using. I can think of a recursive algorithm in terms of Scheme lists, it should be easy to adapt this to your requirements, just use make-tuple in place of list, make-pair in place of cons and make the necessary adjustments:
(define (split lst l1 l2)
(cond ((empty? lst) ; end of list with even number of elements
(list (reverse l1) (reverse l2))) ; return solution
((empty? (rest lst)) ; end of list with odd number of elements
(list (reverse (cons (first lst) l1)) (reverse l2))) ; return solution
(else ; advance two elements at a time, build two separate lists
(split (rest (rest lst)) (cons (first lst) l1) (cons (second lst) l2)))))
(define (split-list lst)
; call helper procedure with initial values
(split lst '() '()))
For example:
(split-list '(1 2))
=> '((1) (2))
(split-list '(1 2 3 4))
=> '((1 3) (2 4))
(split-list '(1 2 3))
=> '((1 3) (2))
(split-list '(1 2 3 4 5))
=> '((1 3 5) (2 4))
(split-list '(1 2 3 4 5 6))
=> '((1 3 5) (2 4 6))
split is kind of a de-interleave function. In many other languages, split names functions which create sublists/subsequences of a list/sequence which preserve the actual order. That is why I don't like to name this function split, because it changes the order of elements in some way.
Tail-call-rescursive solution
(define de-interleave (l (acc '(() ())))
(cond ((null? l) (map reverse acc)) ; reverse each inner list
((= (length l) 1)
(de-interleave '() (list (cons (first l) (first acc))
(second acc))))
(else
(de-interleave (cddr l) (list (cons (first l) (first acc))
(cons (second l) (second acc)))))))
You seem to be using the module deinprogramm/DMdA-vanilla.
The simplest way is to match the current state of the list and call it again with the rest:
(define split-list
(lambda (x)
(match x
;the result should always be a tuple
(empty (make-tuple empty empty))
((list a) (make-tuple (list a) empty))
((list a b) (make-tuple (list a) (list b)))
;call split-list with the remaining elements, then insert the first two elements to each list in the tuple
((make-pair a (make-pair b c))
((lambda (t)
(make-tuple (make-pair a (first-tuple t))
(make-pair b (rest-tuple t))))
(split-list c))))))

How to find partitions of a list in Scheme

Say there is any given list in Scheme. This list is ‘(2 3 4)
I want to find all possible partitions of this list. This means a partition where a list is separated into two subsets such that every element of the list must be in one or the other subsets but not both, and no element can be left out of a split.
So, given the list ‘(2 3 4), I want to find all such possible partitions. These partitions would be the following: {2, 3} and {4}, {2, 4} and {3}, and the final possible partition being {3, 4} and {2}.
I want to be able to recursively find all partitions given a list in Scheme, but I have no ideas on how to do so. Code or psuedocode will help me if anyone can provide it for me!
I do believe I will have to use lambda for my recursive function.
I discuss several different types of partitions at my blog, though not this specific one. As an example, consider that an integer partition is the set of all sets of positive integers that sum to the given integer. For instance, the partitions of 4 is the set of sets ((1 1 1 1) (1 1 2) (1 3) (2 2) (4)).
The process is building the partitions is recursive. There is a single partition of 0, the empty set (). There is a single partition of 1, the set (1). There are two partitions of 2, the sets (1 1) and (2). There are three partitions of 3, the sets (1 1 1), (1 2) and (3). There are five partitions of 4, the sets (1 1 1 1), (1 1 2), (1 3), (2 2), and (4). There are seven partitions of 5, the sets (1 1 1 1 1), (1 1 1 2), (1 2 2), (1 1 3), (1 4), (2 3) and (5). And so on. In each case, the next-larger set of partitions is determined by adding each integer x less than or equal to the desired integer n to all the sets formed by the partition of n − x, eliminating any duplicates. Here's how I implement that:
Petite Chez Scheme Version 8.4
Copyright (c) 1985-2011 Cadence Research Systems
> (define (set-cons x xs)
(if (member x xs) xs
(cons x xs)))
> (define (parts n)
(if (zero? n) (list (list))
(let x-loop ((x 1) (xs (list)))
(if (= x n) (cons (list n) xs)
(let y-loop ((yss (parts (- n x))) (xs xs))
(if (null? yss) (x-loop (+ x 1) xs)
(y-loop (cdr yss)
(set-cons (sort < (cons x (car yss)))
xs))))))))
> (parts 6)
((6) (3 3) (2 2 2) (2 4) (1 1 4) (1 1 2 2) (1 1 1 1 2)
(1 1 1 1 1 1) (1 1 1 3) (1 2 3) (1 5))
I'm not going to solve your homework for you, but your solution will be similar to the one given above. You need to state your algorithm in recursive fashion, then write code to implement that algorithm. Your recursion is going to be something like this: For each item in the set, add the item to each partition of the remaining items of the set, eliminating duplicates.
That will get you started. If you have specific questions, come back here for additional help.
EDIT: Here is my solution. I'll let you figure out how it works.
(define range (case-lambda ; start, start+step, ..., start+step<stop
((stop) (range 0 stop (if (negative? stop) -1 1)))
((start stop) (range start stop (if (< start stop) 1 -1)))
((start stop step) (let ((le? (if (negative? step) >= <=)))
(let loop ((x start) (xs (list)))
(if (le? stop x) (reverse xs) (loop (+ x step) (cons x xs))))))
(else (error 'range "unrecognized arguments"))))
(define (sum xs) (apply + xs)) ; sum of elements of xs
(define digits (case-lambda ; list of base-b digits of n
((n) (digits n 10))
((n b) (do ((n n (quotient n b))
(ds (list) (cons (modulo n b) ds)))
((zero? n) ds)))))
(define (part k xs) ; k'th lexicographical left-partition of xs
(let loop ((ds (reverse (digits k 2))) (xs xs) (ys (list)))
(if (null? ds) (reverse ys)
(if (zero? (car ds))
(loop (cdr ds) (cdr xs) ys)
(loop (cdr ds) (cdr xs) (cons (car xs) ys))))))
(define (max-lcm xs) ; max lcm of part-sums of 2-partitions of xs
(let ((len (length xs)) (tot (sum xs)))
(apply max (map (lambda (s) (lcm s (- tot s)))
(map sum (map (lambda (k) (part k xs))
(range (expt 2 (- len 1)))))))))
(display (max-lcm '(2 3 4))) (newline) ; 20
(display (max-lcm '(2 3 4 6))) (newline) ; 56
You can find all 2-partitions of a list using the built-in combinations procedure. The idea is, for every element of a (len-k)-combination, there will be an element in the k-combination that complements it, producing a pair of lists whose union is the original list and intersection is the empty list.
For example:
(define (2-partitions lst)
(define (combine left right)
(map (lambda (x y) (list x y)) left right))
(let loop ((m (sub1 (length lst)))
(n 1))
(cond
((< m n) '())
((= m n)
(let* ((l (combinations lst m))
(half (/ (length l) 2)))
(combine (take l half)
(reverse (drop l half)))))
(else
(append
(combine (combinations lst m)
(reverse (combinations lst n)))
(loop (sub1 m) (add1 n)))))))
then you can build the partitions as:
(2-partitions '(2 3 4))
=> '(((2 3) (4))
((2 4) (3))
((3 4) (2)))
(2-partitions '(4 6 7 9))
=> '(((4 6 7) (9))
((4 6 9) (7))
((4 7 9) (6))
((6 7 9) (4))
((4 6) (7 9))
((4 7) (6 9))
((6 7) (4 9)))
Furthermore, you can find the max lcm of the partitions:
(define (max-lcm lst)
(define (local-lcm arg)
(lcm (apply + (car arg))
(apply + (cadr arg))))
(apply max (map local-lcm (2-partitions lst))))
For example:
(max-lcm '(2 3 4))
=> 20
(max-lcm '(4 6 7 9))
=> 165
To partition a list is straightforward recursive non-deterministic programming.
Given an element, we put it either into one bag, or the other.
The very first element will go into the first bag, without loss of generality.
The very last element must go into an empty bag only, if such is present at that time. Since we start by putting the first element into the first bag, it can only be the second:
(define (two-parts xs)
(if (or (null? xs) (null? (cdr xs)))
(list xs '())
(let go ((acc (list (list (car xs)) '())) ; the two bags
(xs (cdr xs)) ; the rest of list
(i (- (length xs) 1)) ; and its length
(z '()))
(if (= i 1) ; the last element in the list is reached:
(if (null? (cadr acc)) ; the 2nd bag is empty:
(cons (list (car acc) (list (car xs))) ; add only to the empty 2nd
z) ; otherwise,
(cons (list (cons (car xs) (car acc)) (cadr acc)) ; two solutions,
(cons (list (car acc) (cons (car xs) (cadr acc))) ; adding to
z))) ; either of the two bags;
(go (list (cons (car xs) (car acc)) (cadr acc)) ; all solutions after
(cdr xs) ; adding to the 1st bag
(- i 1) ; and then,
(go (list (car acc) (cons (car xs) (cadr acc))) ; all solutions
(cdr xs) ; after adding
(- i 1) ; to the 2nd instead
z))))))
And that's that!
In writing this I was helped by following this earlier related answer of mine.
Testing:
(two-parts (list 1 2 3))
; => '(((2 1) (3)) ((3 1) (2)) ((1) (3 2)))
(two-parts (list 1 2 3 4))
; => '(((3 2 1) (4))
; ((4 2 1) (3))
; ((2 1) (4 3))
; ((4 3 1) (2))
; ((3 1) (4 2))
; ((4 1) (3 2))
; ((1) (4 3 2)))
It is possible to reverse the parts before returning, or course; I wanted to keep the code short and clean, without the extraneous details.
edit: The code makes use of a technique by Richard Bird, of replacing (append (g A) (g B)) with (g' A (g' B z)) where (append (g A) y) = (g' A y) and the initial value for z is an empty list.
Another possibility is for the nested call to go to be put behind lambda (as the OP indeed suspected) and activated when the outer call to go finishes its job, making the whole function tail recursive, essentially in CPS style.

contract violation expected: number?-Scheme

I am new to racket and scheme and I am attempting to map the combination of a list to the plus funtion which take each combination of the list and add them together like follows:
;The returned combinations
((1 3) (2 3) (1 4) (2 4) (3 4) (1 5) (2 5) (3 5) (4 5) (1 6) (2 6) (3 6) (4 6) (5 6) (1 2) (2 2) (3 2) (4 2) (5 2) (6 2))
; expected results
((2) (5) (5).....)
Unfortunately I am receiving the contract violation expected error from the following code:
;list of numbers
(define l(list 1 2 3 4 5 6 2))
(define (plus l)
(+(car l)(cdr l)))
(map (plus(combinations l 2)))
There are a couple of additional issues with your code, besides the error pointed out by #DanD. This should fix them:
(define lst (list 1 2 3 4 5 6 2))
(define (plus lst)
(list (+ (car lst) (cadr lst))))
(map plus (combinations lst 2))
It's not a good idea to call a variable l, at first sight I thought it was a 1. Better call it lst (not list, please - that's a built-in procedure)
In the expected output, weren't you supposed to produce a list of lists? add a call to list to plus
You're not passing plus in the way that map expects it
Do notice the proper way to indent and format your code, it'll help you in finding bugs
You want (cadr l). Not (cdr l) in your plus function:
(define (plus l)
(+ (car l) (cadr l)))
Where x is (cons 1 (cons 2 '())):
(car x) => 1
(cdr x) => (cons 2 '())
(cadr x) == (car (cdr x)) => 2

Output Elements in List That Are Not Incommon

I've created a function that should return the elements that the two lists do not have in common. Currently, they are outputting exactly what is passed into it. Any suggestions on how to fix this?
(define (findDifference lst1 lst2)
(if (null? lst1) lst2
(cons (car lst1) (findDifference (cdr lst1) lst2))))
(findDifference '(2 3 4 (2 3) 2 (4 5)) '(2 4 (4 5))
Current Output: (2 3 4 (2 3) 2 (4 5) 2 4 (4 5))
Desired Output: (3 (2 3))
You're asking for the symmetric difference of two lists. Try this:
(define (diff list1 list2)
(union (complement list1 list2)
(complement list2 list1)))
Using the following helper procedures:
(define (union list1 list2)
(cond ((null? list1) list2)
((member (car list1) list2) (union (cdr list1) list2))
(else (cons (car list1) (union (cdr list1) list2)))))
(define (complement list1 list2)
(cond ((null? list1) '())
((member (car list1) list2) (complement (cdr list1) list2))
(else (cons (car list1) (complement (cdr list1) list2)))))
Also notice that if you're using Racket you can simply use the built-in set-symmetric-difference procedure for the same effect. For example:
(diff '(2 3 4 (2 3) 2 (4 5)) '(2 4 (4 5)))
=> '(3 (2 3))
Since it seems like homework and I do not want to spoil the fun, here is the brute force algorithm, with some bits left out. If you are really stuck I will give you the full source.
(define (sym-diff xs ys)
;; Since we have the helper function we can determine all the elements that are in the first list,
;; but not in the second list.
;; Then we can pass this intermediate result to the second call to sym-diff-helper.
;;This will return us all the elements that are in the second list but not the first.
(let ((in-first-not-second ...))
(sym-diff-helper ys xs in-first-not-second)))
;; This function will return all the elements from the first list that are not in the second list!
(define (sym-diff-helper xs ys acc)
(cond
;; If the first list is empty we have checked it.
(...
acc)
;; If the first list is not empty yet, check if the first element
;; is in the second list.
;; If so, discard it and continue with the rest of the list.
((member ... ...)
(sym-diff-helper ... ... ...)
;; If the first element of the first list is not in the second list,
;; add it to the accumulator and continue with the rest of the list.
(else
(sym-diff-helper ... ... ...)))
(sym-diff-helper '(1 2 3) '(2 3 4) '())
;; == (1)
(sym-diff-helper '(1 2 (3 4) 5) '(2 3 4) '())
;; == (5 (3 4) 1)
(sym-diff '(2 3 4 (2 3) 2 (4 5)) '(2 4 (4 5)))
;; == ((2 3) 3)
Note that I have chosen to use member. There are a few other search functions but they were not well suited in this case. Hence, I left it there. More info on the search functions can be found here: http://docs.racket-lang.org/reference/pairs.html#%28part..List.Searching%29

How to write SUM function in Scheme?

How to write a function in scheme that sums the numbers in embedded lists?
i.e. ((1) (2 3) (4) (5 6))
I wrote this to sum the regular list:
(define (sum list)
(if (null? list)
0
(+ (car list) (sum (cdr list)))))
but I'm not sure how to do the embedded one.
You have 3 cases:
(define (my-sum lst)
(cond
; 1. the list is empty, so finish of by adding 0
([empty? lst] 0)
; 2. the first element is a list, so recurse down on the sublist, then do the rest
([list? (car lst)] (+ (my-sum (car lst)) (my-sum (cdr lst))))
; 3. add the first element to the sum, then do the rest
(else (+ (car lst) (my-sum (cdr lst))))))
so you were just missing the middle case.
This will work regardless of the nesting depth:
(my-sum '((1) (2 3) (4) (5 6)))
=> 21
(my-sum '((1) (2 3) (4) (5 6 (7 8 (9)))))
=> 45
Please note that you should not use the names "sum" and "list" in order not to shadow the build-in procedures.
Here is the simplest answer.
(define (sum list-of-lists)
(apply + (apply append list-of-lists)))
and the 'proof':
> (sum '((1) (2 3) (4) (5 6)))
21
In a more functional way
; this sums the elements of a not-embedded list
(define (sum-list* l)
(foldl + 0 l))
; this sums the elements of an embedded list
(define (sum-embedded-list* el)
(foldl + 0 (map sum-list* el)))
It covers the case of a list so formed: ((a1...an) (b1...bn)...), where ai and bj are atoms.
Foldl and map are two important functions in scheme (and other languages). If you don't know how to use them you should learn. Take a look here

Resources