I'm trying to write a procedure that takes 2 streams and that puts together their pairs and then interleaves them. Right now it's not producing the correct output. Here's the code I have:
(define (interleave-pairs s t)
(cons-stream (cons (stream-car s) (stream-car t))
(cons-stream
(stream-map (lambda (x) (cons (stream-car s) x))
(stream-cdr t))
(interleave-pairs t (stream-cdr s)))))
To obtain the values I wrote a procedure:
(define (take n s)
(if (= n 0)
'()
(cons (stream-car s) (take (- n 1) (stream-cdr s)))))
And this is for the stream of integers:
(define integers (cons-stream 1 (add-streams ones integers)))
So when I call
(take 6 (pairs integers integers))
I'm getting:
((1 . 1)
((1 . 2) . #<promise>)
(1 . 2)
((1 . 3) . #<promise>)
(2 . 2)
((2 . 3) . #<promise>))
Whereas I want (1 1) (1 1) (1 2) (1 3) (2 2) (2 3)
The base case in your procedure is missing (what happens if one of the streams ends before the other?). The procedure is rather simple, just take one pair of elements (one from each stream) and then interleave them, no need to use stream-map here:
(define (pairs s1 s2)
(if (stream-null? s1)
s2
(stream-cons (list (stream-car s1) (stream-car s2))
(pairs s2 (stream-cdr s1)))))
Related
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.
How to define a procedure return all pairs of elements in an infinite stream s?
s = {1,2,3,4,5,6,...}
=> {(2,1), (3,2), (3,1), (4,3), (4,2), (4,1), ......}
Here is my code, however it didn't work like a stream, it keep running infinitely and ran out of memory.
(define (stream-pairs s)
(define (iter s save)
(stream-append (stream-map (lambda (x) (stream-cons (stream-first s) x))
save)
(iter (stream-rest s) (stream-cons save (stream-first s)))))
(iter s empty-stream))
(define A (stream-cons 1 (scale-stream 2 A)))
(define C (stream-pairs A))
A = {1,2,4,8,16,......}
Turns out, Racket's stream-append does not delay its last (at least) argument, so iter calls stream-append which calls iter ... thus the loop.
One way is to reimplement the stream-append fused with the stream-map as used here, as a simple recursive function. That way the tail will be properly under the guard of the delaying stream-cons.
Another is to take a stream-rest1 of a fake stream-cons:
(require racket/stream)
(define (stream-pairs s)
(define (iter s save)
(stream-append (stream-map (lambda (x) (list (stream-first s) x))
save) ;^^^^
(stream-rest
(stream-cons 'fake ;<<-----------------
(iter (stream-rest s)
(stream-cons (stream-first s) save))))))
(iter s empty-stream))
(define A (stream-cons 1 (stream-map add1 A))) ; easier to follow
(define C (stream-pairs A))
Also, there was another error in your code where stream-cons was used instead of plain list, to pair up the elements of save with a current element of the input stream. Now we have
> (for ((i (in-range 0 12))) (display (stream-ref C i)))
(2 1)(3 2)(3 1)(4 3)(4 2)(4 1)(5 4)(5 3)(5 2)(5 1)(6 5)(6 4)
1 cf.,
> (stream-rest (stream-cons 1 (/ 1 0)))
#<stream>
Since the question specified that the given stream is infinite:
(define (stream-pairs strm)
(stream-cons (cons (stream-first strm)
(stream-first (stream-rest strm)))
(stream-pairs (stream-rest (stream-rest strm)))))
(If the stream is not infinite, you need to add an emptiness guard to the front of the function.)
Note: If you're using SRFI 41 streams instead of Racket streams, change define to define-stream.
I'm unclear as what you mean by 'pairs of a stream', but assuming you want something like this:
> (stream-subset-pairs (in-naturals) 5)
'((0 . 1) (1 . 2) (2 . 3) (3 . 4))
With that as the expected output, here is a solution:
(define (stream-subset-pairs stream i)
(define subset ; collect all elements up to i by iterating over the list and all #'s in sequence
(for/list ([element stream]
[position (in-naturals)]
#:break (= position i)) ; break when we have reached the # of elements we want to collect
element))
(let-values ([(ignore result) ; wrapper because we want for/fold to produce one result (last-element is just a state variable)
(for/fold ([last-element null]
[result empty])
([element subset]) ; iterate through the subset
(values element (if (null? last-element) ; if we are on the first loop
result ; ignore it
(cons (last-element element) result))))]) ; else add a pair of the last result and this result
result))
(define (all-sublists buffer n)
(cond ((= n 0) n)
((all-sublists (append buffer (list (list n)) (map (lambda (x) (append (list n) x)) buffer)) (- n 1)))))
the result looks like this:
(all-sublists '((3) (2) (2 3) (1) (1 3) (1 2) (1 2 3)) 0)
when there is only one list around n:
(define (all-sublists buffer n)
(cond ((= n 0) n)
((all-sublists (append buffer (list n) (map (lambda (x) (append (list n) x)) buffer)) (- n 1)))))
the results get a dotted pair:
(all-sublists '(3 2 (2 . 3) 1 (1 . 3) (1 . 2) (1 2 . 3)) 0)
Is not that you have "to surround n with list twice to get the proper result", the truth is that there are several problems with your code, for starters: the last condition of a cond should start with an else, and you're using append incorrectly. If I understood correctly, you just want the powerset of a list:
(define (powerset aL)
(if (empty? aL)
'(())
(let ((rst (powerset (rest aL))))
(append (map (lambda (x) (cons (first aL) x))
rst)
rst))))
Like this:
(powerset '(1 2 3))
=> '((1 2 3) (1 2) (1 3) (1) (2 3) (2) (3) ())
Trying to produce an output of pairs that would look like (1 1) (1 2) (1 3) (2 2) (2 3) (3 3), if taking the first 6 elements of a stream. (The first 6 have 3 columns and it should print the pairs beginning with 1 and then 2 and then 3.) The code I have is:
(define (pairs s t)
(cons-stream (cons (stream-car s) (stream-car t))
(cons-stream
(stream-map (lambda (x) (cons (stream-car s) x))
(stream-cdr t))
(pairs (stream-cdr t) (stream-cdr s)))))
And if I run
(take 6 (pairs integers integers))
where take and integers are defined as follows:
(define (take n s)
(if (= n 0)
'()
(cons (stream-car s) (take (- n 1) (stream-cdr s)))))
(define integers (cons-stream 1 (add-streams ones integers)))
The result I get is:
((1 . 1)
((1 . 2) . #<promise>)
(2 . 2)
((2 . 3) . #<promise>)
(3 . 3)
((3 . 4) . #<promise>))
In Scheme,
(define (interleaved-pairs xs ys . args)
(let ((x (stream-car xs))
(ac (if (null? args) () (car args))))
(stream-append
(stream-map stream-car (list->stream (reverse ac)))
(stream-cons (list x (stream-car ys))
(interleaved-pairs
(stream-cdr xs)
(stream-cdr ys)
(cons
(stream-map (lambda(y)(list x y)) (stream-cdr ys))
(map stream-cdr ac)))))))
This should produce results in the order you wanted: (1 1) (1 2) (2 2) (1 3) (2 3) (3 3) (1 4) ....
You tagged this as racket also. As far as I can see in the Racket documentation, it has stream-first in place of stream-car, etc. For some reason it doesn't seem to have list->stream, which can be defined quite straightforwardly with the apply and stream functions.
Here it is in a shorter notation.
ipairs xs ys = g xs ys [] where
g (x:xs) (y:ys) ac = map head (reverse ac) ++ (x,y) :
g xs ys (map ((,) x) ys : map tail ac)
A k-ary necklace of length n is an ordered list of length n whose items are drawn from an alphabet of length k, which is the lexicographically first list in a sort of all lists sharing an ordering under rotation.
Example:
(1 2 3) and (1 3 2) are the necklaces of length 3 from the alphabet {1 2 3}.
More info:
http://en.wikipedia.org/wiki/Necklace_(combinatorics)
I'd like to generate these in Scheme (or a Lisp of your choice). I've found some papers...
Savage - A New Algorithm for Generating Necklaces
Sawada - Generating Bracelets in Constant Amortized Time
Sawada - Generating Necklaces with Forbidden Substrings
...but the code presented in them is opaque to me. Mainly because they don't seem to be passing in either the alphabet or the length (n) desired. The scheme procedure I'm looking for is of the form (necklaces n '(a b c...)).
I can generate these easy enough by first generating k^n lists and then filtering out the rotations. But it's terribly memory-inefficient...
Thanks!
The FKM algorithm for generating necklaces. PLT Scheme. Not so hot on the performance. It'll take anything as an alphabet and maps the internal numbers onto whatever you provided. Seems to be correct; no guarantees. I was lazy when translating the loops, so you get this weird mix of for loops and escape continuations.
(require srfi/43)
(define (gennecklaces n alphabet)
(let* ([necklaces '()]
[alphavec (list->vector alphabet)]
[convert-necklace
(lambda (vec)
(map (lambda (x) (vector-ref alphavec x)) (cdr (vector->list vec))))]
[helper
(lambda (n k)
(let ([a (make-vector (+ n 1) 0)]
[i n])
(set! necklaces (cons (convert-necklace a) necklaces))
(let/ec done
(for ([X (in-naturals)])
(vector-set! a i (add1 (vector-ref a i)))
(for ([j (in-range 1 (add1 (- n i)))])
(vector-set! a (+ j i)
(vector-ref a j)))
(when (= 0 (modulo n i))
(set! necklaces (cons (convert-necklace a) necklaces)))
(set! i n)
(let/ec done
(for ([X (in-naturals)])
(unless (= (vector-ref a i)
(- k 1))
(done))
(set! i (- i 1))))
(when (= i 0)
(done))))))])
(helper n (length alphabet))
necklaces))
I would do a two step process. First, find each combination of n elements from the alphabet. Then, for each combination, pick the lowest value, and generate all permutations of the remaining items.
Edit: Here is some code. It assumes that the input list is already sorted and that it contains no duplicates.
(define (choose n l)
(let ((len (length l)))
(cond ((= n 0) '(()))
((> n len) '())
((= n len) (list l))
(else (append (map (lambda (x) (cons (car l) x))
(choose (- n 1) (cdr l)))
(choose n (cdr l)))))))
(define (filter pred l)
(cond ((null? l) '())
((pred (car l)) (cons (car l) (filter pred (cdr l))))
(else (filter pred (cdr l)))))
(define (permute l)
(cond ((null? l) '(()))
(else (apply append
(map (lambda (x)
(let ((rest (filter (lambda (y) (not (= x y))) l)))
(map (lambda (subperm) (cons x subperm))
(permute rest))))
l)))))
(define (necklaces n l)
(apply
append
(map
(lambda (combination)
(map (lambda (permutation)
(cons (car combination) permutation))
(permute (cdr combination))))
(choose n l))))
(display (choose 1 '(1 2 3 4 5))) (newline)
(display (choose 2 '(1 2 3 4 5))) (newline)
(display (permute '(1 2))) (newline)
(display (permute '(1 2 3))) (newline)
(display (necklaces 3 '(1 2 3 4))) (newline)
(display (necklaces 2 '(1 2 3 4))) (newline)
Example: (1 2 3) and (1 3 2) are the necklaces of length 3 from the alphabet {1 2 3}.
You forgot (1 1 1) (1 1 2) (1 1 3) (1 2 2) (1 3 3) (2 2 2) (2 2 3) (2 3 3) (3 3 3). Necklaces can contain duplicates.
If you were only looking for necklaces of length N, drawn from an alphabet of size N, that contain no duplicates, then it's pretty easy: there will be (N-1)! necklaces, and each necklace will be of the form (1 :: perm) where perm is any permutation of {2 .. N}. For example, the necklaces of {1 .. 4} would be (1 2 3 4) (1 2 4 3) (1 3 2 4) (1 3 4 2) (1 4 2 3) (1 4 3 2). Extending this method to deal with no-duplicates necklaces of length K < N is left as an exercise for the reader.
But if you want to find real necklaces, which may contain duplicate elements, then it's not so simple.
As a first idea, you can do the obvious, but inefficient: step through all combinations and check if they are a necklace, i.e. if they are the lexically smallest rotation of the elements (formal definition on p 5 in above paper). This would be like the way you proposed, but you would throw away all non-necklaces as soon as they are generated.
Other than that, I think that you will have to understand this article (http://citeseer.ist.psu.edu/old/wang90new.html):
T. Wang and C. Savage, "A new algorithm for generating necklaces," Report
TR-90-20, Department of Computer Science, North Carolina State University
(1990).
It is not too hard, you can break it down by implementing the tau and sigma functions as described and then applying them in the order outlined in the article.