I'm trying to find an implementation which flattens a lazy list of lazy lists using interleave and lz-lst-accumulate which are procedures that I wrote. This is the code so far:
(define lz-lst-accumulate
(lambda (op initial lz)
(if (empty? lz)
initial
(op (head lz)
(lambda() (lz-lst-accumulate op initial (tail lz)))))))
(define interleave
(lambda (lz1 lz2)
(if (empty? lz1)
(lz2)
(cons (head lz1)
(interleave (lz2) (lambda() (tail lz1)))))))
(define all-div-from-flattened
(lambda (lower)
(lz-lst-accumulate interleave '() (all-div-from lower))))
(define take
(lambda (lz-lst n)
(if (= n 0)
(list)
(cons (car lz-lst)
(take (tail lz-lst) (sub1 n))))))
(define head
(lambda (lz)
(car lz)))
(define tail
(lambda (lz-lst)
((cdr lz-lst))))
(define lz-lst-map
(lambda (f lz)
(if (empty? lz)
lz
(cons (f (head lz))
(lambda () (lz-lst-map f (tail lz)))))))
; Signature: all-div-from (low)
; Type: [Number -> Lazy-list]
; Purpose: return a lazy-list of lazy-lists. The nested lazy-lists
; correspond to the integers greater than lower in an
; increasing order. Each nested lazy-list is the list of
; all integers divisible by i for some i>=lower.
; Pre-conditions: low is an integer
; Tests: > (define lz3 (all-div-from 7))
; > (take lz3 3)
; '((7 . #<procedure>) (8 . #<procedure>) (9 . #<procedure>))
; > (take (head lz3) 3)
; '(7 14 21)
; > (take (head (tail lz3)) 3)
; '(8 16 24)
(define all-div-from
(lambda(lower)
(cons (lz-lst-map (lambda(x) (* x lower)) (div-from 1 1))
(lambda() (all-div-from (add1 lower))))))
; Signature: div-from (low int)
; Type: [[Number*Number]-> Lazy-list]
; Purpose: return the lazy-list of all integers that
; are larger than low and divisible by int
; Pre-conditions: int > low
; Tests: > (define lz1 (div-from 5 12))
; > (take lz1 3)
; '(12 24 36)
; > (define lz2 (div-from 7 10))
; > (take lz2 4)
; '(10 20 30 40)
(define div-from
(lambda (lower int)
(lz-lst-filter (lambda(x) (> x (- lower 1)))
(lz-lst-map (lambda(x) (* x int)) (integers-from 1)))))
(define integers-from
(lambda (n) (cons n
(lambda () (integers-from (+ 1 n))))))
(define lz-lst-filter
(lambda (p lz)
(cond ((empty? lz) lz)
((p (head lz))
(cons (head lz)
(lambda () (lz-lst-filter p (tail lz)))))
(else (lz-lst-filter p (tail lz))))))
The procedure all-div-from receives a lower bound low and returns a lazy-list of lazy-lists. Each lazy list in it is made by div-from which receives a lower bound low and an integer int > low, and
returns the lazy-list of all integers that are larger than low and divisible by int.
An example of input and the correct output:
> (take (all-div-from-flattened 7) 10)
'(7 8 14 9 21 16 28 10 35 24)
But when I try this line in the interpreter:
> (take (all-div-from-flattened 3) 3)
it gets into an infinite loop.
My implementation must use lz-lst-accumulate, interleave and all-div-from-flattend procedures.
Any suggestions on how to make it work?
Your interleave does not produce a lazy list; it produces an ordinary list: it uses cons with two arguments, with the second argument not wrapped in a lambda. So the cons forces the 2nd argument through, causing the run-away evaluation:
(define interleave
(lambda (lz1 dlz2) ; "delayed" lz2
(if (empty? lz1)
(dlz2)
(cons (head lz1)
; here:
(interleave (dlz2) (lambda () (tail lz1)))))))
(define lz-lst-accumulate
(lambda (op initial lz)
(if (empty? lz)
initial
(op (head lz)
(lambda () (lz-lst-accumulate op initial (tail lz)))))))
(all-div-from lower) produces correct output, ( (lower . <proc1>) . <proc2> ), but the call to (lz-lst-accumulate interleave '() (all-div-from lower)) reduces as
(interleave [lower . <proc1>]
(lambda () (lz-lst-accumulate interleave '() (<proc2>))))
and that reduces as
(cons lower
(interleave (lz-lst-accumulate interleave '() (<proc2>))
(lambda () (<proc1>))))
while it has to reduce as
(cons lower
(lambda () (interleave ....)))
to produce a lazy list.
The obvious (now) solution is to add that missing lambda:
(define interleave
(lambda (lz1 lz2)
(if (empty? lz1)
(lz2)
(cons (head lz1)
(lambda () (interleave (lz2) (lambda() (tail lz1))))))))
Now it runs correctly:
(take (all-div-from-flattened 7) 10)
;Value 12: (7 8 14 9 21 16 28 10 35 24)
You could much simplify your code by introducing
(define integers-from-by
(lambda (n d) (cons n
(lambda () (integers-from (+ n d) d)))))
then,
;(define div-from
; (lambda (lower int)
; (lz-lst-filter (lambda(x) (> x (- lower 1)))
; (lz-lst-map (lambda(x) (* x int)) (integers-from 1)))))
(define mults-from-of ; n in [int, 2*int ..], n >= lower
(lambda (lower int)
(let ((x (* (quotient (+ lower (- int 1)) int) int)))
(integers-from-by x int))))
You could also have
(define mults-above-of ; n in [int, 2*int ..], n > lower
(lambda (lower int)
(let ((x (* (+ (quotient lower int) 1) int)))
(integers-from-by x int))))
Next,
; (define all-div-from
; (lambda(lower)
; (cons (lz-lst-map (lambda(x) (* x lower)) (div-from 1 1))
; (lambda() (all-div-from (add1 lower))))))
(define all-mults-from
(lambda (lower)
(lz-lst-map (lambda (n) (mults-from-of n n))
; or just (integers-from-by n n)
(integers-from-by lower 1))))
If you change your interleave to combine the streams in order, and switch to mults-above-of in the all-mults-from definition, then (lz-lst-accumulate interleave-ordered '() (all-mults-from-above 2)) will define the lazy list of all composite numbers, in order, by means of counting up as in the sieve of Eratosthenes.
From this, it's just one more step to getting yourself your own lazy unbounded incremental sieve of Eratosthenes (search for "SiCp" on that page).
Another remark: take should be tweaked to not force an extra element of a stream. More here.
Related
I defined a simple lazy list of all integers from zero:
(define integers-from
(lambda (n)
(cons n
(lambda () (integers-from (+ 1 n))))))
(define lz (integers-from 0))
I also coded an accumaltor that gets a lazy list as a parameter
(define lz-lst-accumulate
(lambda (op initial lz)
(if (null? lz)
initial
(cons (op (head lz) initial)
(lambda () (lz-lst-accumulate op (op initial (head lz)) (tail lz)))))))
Does this accumaltor answer the format of lazy lists?
Here is a simple test of the accumulator:
(define acc (lz-lst-accumulate * 1 lz))
(take acc 4)
=> '(1 2 6 24)
take is a helper function that creates a list from the first n elements of a lazy list:
(define head car)
(define tail
(lambda (lz-lst)
((cdr lz-lst)) ))
(define take
(lambda (lz-lst n)
(if (= n 0)
(list)
(cons (car lz-lst)
(take (tail lz-lst) (sub1 n)))) ))
In your lz-lst-accumulate you calculate once (op (head lz) initial) and then also (op initial (head lz)). This is inconsistent; both should be the same and actually calculated only once, since it's the same value:
(define lz-lst-accumulate
(lambda (op initial lz)
(if (lz-lst-empty? lz)
initial
(let ((val (op (head lz) initial)))
(cons val
(lambda () (lz-lst-accumulate op val (tail lz))))))))
It works in your example with numbers only because you use the type-symmetrical operation *. With cons it wouldn't work.
Other than that it's OK. lz-lst-accumulate is usually known as left fold (scanl in Haskell, actually, since you produce the progression of "accumulated" values, foldl f z xs = last (scanl f z xs)).
re: your version of take, it is forcing one too many elements of a stream. Better make it
(define take
(lambda (lz n)
(if (or (<= n 0) (lz-lst-empty? lz))
(list)
(if (= n 1)
(list (car lz)) ; already forced
(cons (car lz)
(take (tail lz) (sub1 n)))))))
so that it only forces as many elements as it has to produce, and not one more (which might be e.g. divergent, like (/ 1 0), invalidating the whole calculation for no reason).
That way, the counter-example in SRFI 41 (of (take 4 (stream-map 1/ (ints-from-by 4 -1)))) will just work (it calculates (1/4 1/3 1/2 1/1) without forcing 1/0, which the usual version of take, like the one you're using, would do).
how to implement this function
if get two list (a b c), (d e)
and return list (a+d b+d c+d a+e b+e c+e)
list element is all integer and result list's element order is free
I tried this like
(define (addlist L1 L2)
(define l1 (length L1))
(define l2 (length L2))
(let ((result '()))
(for ((i (in-range l1)))
(for ((j (in-range l2)))
(append result (list (+ (list-ref L1 i) (list-ref L2 j))))))))
but it return error because result is '()
I don't know how to solve this problem please help me
A data-transformational approach:
(a b c ...) (x y ...)
1. ==> ( ((a x) (b x) (c x) ...) ((a y) (b y) (c y) ...) ...)
2. ==> ( (a x) (b x) (c x) ... (a y) (b y) (c y) ... ...)
3. ==> ( (a+x) (b+x) ... )
(define (addlist L1 L2)
(map (lambda (r) (apply + r)) ; 3. sum the pairs up
(reduce append '() ; 2. concatenate the lists
(map (lambda (e2) ; 1. pair-up the elements
(map (lambda (e1)
(list e1 e2)) ; combine two elements with `list`
L1))
L2))))
testing (in MIT-Scheme):
(addlist '(1 2 3) '(10 20))
;Value 23: (11 12 13 21 22 23)
Can you simplify this so there's no separate step #3?
We can further separate out the different bits and pieces in play here, as
(define (bind L f) (join (map f L)))
(define (join L) (reduce append '() L))
(define yield list)
then,
(bind '(1 2 3) (lambda (x) (bind '(10 20) (lambda (y) (yield (+ x y))))))
;Value 13: (11 21 12 22 13 23)
(bind '(10 20) (lambda (x) (bind '(1 2 3) (lambda (y) (yield (+ x y))))))
;Value 14: (11 12 13 21 22 23)
Here you go:
(define (addlist L1 L2)
(for*/list ((i (in-list L1)) (j (in-list L2)))
(+ i j)))
> (addlist '(1 2 3) '(10 20))
'(11 21 12 22 13 23)
The trick is to use for/list (or for*/list in case of nested fors) , which will automatically do the append for you. Also, note that you can just iterate over the lists, no need to work with indexes.
To get the result "the other way round", invert L1 and L2:
(define (addlist L1 L2)
(for*/list ((i (in-list L2)) (j (in-list L1)))
(+ i j)))
> (addlist '(1 2 3) '(10 20))
'(11 12 13 21 22 23)
In scheme, it's not recommended using function like set! or append!.
because it cause data changed or Variable, not as Funcitonal Programming Style.
should like this:
(define (add-one-list val lst)
(if (null? lst) '()
(cons (list val (car lst)) (add-one-list val (cdr lst)))))
(define (add-list lst0 lst1)
(if (null? lst0) '()
(append (add-one-list (car lst0) lst1)
(add-list (cdr lst0) lst1))))
first understanding function add-one-list, it recursively call itself, and every time build val and fist element of lst to a list, and CONS/accumulate it as final answer.
add-list function just like add-one-list.
(define (addlist L1 L2)
(flatmap (lambda (x) (map (lambda (y) (+ x y)) L1)) L2))
(define (flatmap f L)
(if (null? L)
'()
(append (f (car L)) (flatmap f (cdr L)))))
1 ]=> (addlist '(1 2 3) '(10 20))
;Value 2: (11 12 13 21 22 23)
Going with Will and Procras on this one. If you're going to use scheme, might as well use idiomatic scheme.
Using for to build a list is a bit weird to me. (list comprehensions would fit better) For is usually used to induce sequential side effects. That and RSR5 does not define a for/list or for*/list.
Flatmap is a fairly common functional paradigm where you use append instead of cons to build a list to avoid nested and empty sublists
It doesn't work because functions like append don't mutate the containers. You could fix your problem with a mutating function like append!. Usually functions that mutate have a ! in their name like set! etc.
But it's possible to achieve that without doing mutation. You'd have to change your algorithm to send the result to your next iteration. Like this:
(let loop ((result '()))
(loop (append result '(1)))
As you can see, when loop will get called, result will be:
'()
'(1)
'(1 1)
'(1 1 1)
....
Following this logic you should be able to change your algorithm to use this method instead of for loop. You'll have to pass some more parameters to know when you have to exit and return result.
I'll try to add a more complete answer later today.
Here's an implementation of append! I just wrote:
(define (append! lst1 lst2)
(if (null? (cdr lst1))
(set-cdr! lst1 lst2)
(append! (cdr lst1) lst2)))
Here is my code:
(define (squares 1st)
(let loop([1st 1st] [acc 0])
(if (null? 1st)
acc
(loop (rest 1st) (* (first 1st) (first 1st) acc)))))
My test is:
(test (sum-squares '(1 2 3)) => 14 )
and it's failed.
The function input is a list of number [1 2 3] for example, and I need to square each number and sum them all together, output - number.
The test will return #t, if the correct answer was typed in.
This is rather similar to your previous question, but with a twist: here we add, instead of multiplying. And each element gets squared before adding it:
(define (sum-squares lst)
(if (empty? lst)
0
(+ (* (first lst) (first lst))
(sum-squares (rest lst)))))
As before, the procedure can also be written using tail recursion:
(define (sum-squares lst)
(let loop ([lst lst] [acc 0])
(if (empty? lst)
acc
(loop (rest lst) (+ (* (first lst) (first lst)) acc)))))
You must realize that both solutions share the same structure, what changes is:
We use + to combine the answers, instead of *
We square the current element (first lst) before adding it
The base case for adding a list is 0 (it was 1 for multiplication)
As a final comment, in a real application you shouldn't use explicit recursion, instead we would use higher-order procedures for composing our solution:
(define (square x)
(* x x))
(define (sum-squares lst)
(apply + (map square lst)))
Or even shorter, as a one-liner (but it's useful to have a square procedure around, so I prefer the previous solution):
(define (sum-squares lst)
(apply + (map (lambda (x) (* x x)) lst)))
Of course, any of the above solutions works as expected:
(sum-squares '())
=> 0
(sum-squares '(1 2 3))
=> 14
A more functional way would be to combine simple functions (sum and square) with high-order functions (map):
(define (square x) (* x x))
(define (sum lst) (foldl + 0 lst))
(define (sum-squares lst)
(sum (map square lst)))
I like Benesh's answer, just modifying it slightly so you don't have to traverse the list twice. (One fold vs a map and fold)
(define (square x) (* x x))
(define (square-y-and-addto-x x y) (+ x (square y)))
(define (sum-squares lst) (foldl square-y-and-addto-x 0 lst))
Or you can just define map-reduce
(define (map-reduce map-f reduce-f nil-value lst)
(if (null? lst)
nil-value
(map-reduce map-f reduce-f (reduce-f nil-value (map-f (car lst))))))
(define (sum-squares lst) (map-reduce square + 0 lst))
racket#> (define (f xs) (foldl (lambda (x b) (+ (* x x) b)) 0 xs))
racket#> (f '(1 2 3))
14
Without the use of loops or lamdas, cond can be used to solve this problem as follows ( printf is added just to make my exercises distinct. This is an exercise from SICP : exercise 1.3):
;; Takes three numbers and returns the sum of squares of two larger number
;; a,b,c -> int
;; returns -> int
(define (sum_sqr_two_large a b c)
(cond
((and (< a b) (< a c)) (sum-of-squares b c))
((and (< b c) (< b a)) (sum-of-squares a c))
((and (< c a) (< c b)) (sum-of-squares a b))
)
)
;; Sum of squares of numbers given
;; a,b -> int
;; returns -> int
(define (sum-of-squares a b)
(printf "ex. 1.3: ~a \n" (+ (square a)(square b)))
)
;; square of any integer
;; a -> int
;; returns -> int
(define (square a)
(* a a)
)
;; Sample invocation
(sum_sqr_two_large 1 2 6)
I don't fully understand what the append-map command does in racket, nor do I understand how to use it and I'm having a pretty hard time finding some decently understandable documentation online for it. Could someone possibly demonstrate what exactly the command does and how it works?
The append-map procedure is useful for creating a single list out of a list of sublists after applying a procedure to each sublist. In other words, this code:
(append-map proc lst)
... Is semantically equivalent to this:
(apply append (map proc lst))
... Or this:
(append* (map proc lst))
The applying-append-to-a-list-of-sublists idiom is sometimes known as flattening a list of sublists. Let's look at some examples, this one is right here in the documentation:
(append-map vector->list '(#(1) #(2 3) #(4)))
'(1 2 3 4)
For a more interesting example, take a look at this code from Rosetta Code for finding all permutations of a list:
(define (insert l n e)
(if (= 0 n)
(cons e l)
(cons (car l)
(insert (cdr l) (- n 1) e))))
(define (seq start end)
(if (= start end)
(list end)
(cons start (seq (+ start 1) end))))
(define (permute l)
(if (null? l)
'(())
(apply append (map (lambda (p)
(map (lambda (n)
(insert p n (car l)))
(seq 0 (length p))))
(permute (cdr l))))))
The last procedure can be expressed more concisely by using append-map:
(define (permute l)
(if (null? l)
'(())
(append-map (lambda (p)
(map (lambda (n)
(insert p n (car l)))
(seq 0 (length p))))
(permute (cdr l)))))
Either way, the result is as expected:
(permute '(1 2 3))
=> '((1 2 3) (2 1 3) (2 3 1) (1 3 2) (3 1 2) (3 2 1))
In Common Lisp, the function is named "mapcan" and it is sometimes used to combine filtering with mapping:
* (mapcan (lambda (n) (if (oddp n) (list (* n n)) '()))
'(0 1 2 3 4 5 6 7))
(1 9 25 49)
In Racket that would be:
> (append-map (lambda (n) (if (odd? n) (list (* n n)) '()))
(range 8))
'(1 9 25 49)
But it's better to do it this way:
> (filter-map (lambda (n) (and (odd? n) (* n n))) (range 8))
'(1 9 25 49)
I hacked together several code snippets from various sources and created a crude implementation of a Wolfram Blog article at http://bit.ly/HWdUqK - for those that are mathematically inclined, it is very interesting!
Not surprisingly, given that I'm still a novice at Racket, the code takes too much time to calculate the results (>90 min versus 49 seconds for the author) and eats up a lot of memory. I suspect it is all about the definition (expListY) which needs to be reworked.
Although I have it working in DrRacket, I am also having problems byte-compiling the source, and still working on it
(Error message: +: expects type <number> as 1st argument, given: #f; other arguments were: 1 -1)
Anybody want to take a stab at improving the performance and efficiency? I apologize for the unintelligible code and lack of better code comments.
PS: Should I be cutting and pasting the code directly here?
Probably similar to soegaard's solution, except this one rolls its own "parser", so it's self contained. It produces the complete 100-year listing in a bit under 6 seconds on my machine. There's a bunch of tricks that this code uses, but it's not really something that would be called "optimized" in any serious way: I'm sure that it can be made much faster with some memoization, care for maximizing tree sharing etc etc. But for such a small domain it's not worth the effort... (Same goes for the quality of this code...)
BTW#1, more than parsing, the original solution(s) use eval which does not make things faster... For things like this it's usually better to write the "evaluator" manually. BTW#2, this doesn't mean that Racket is faster than Mathematica -- I'm sure that the solution in that post makes it grind redundant cpu cycles too, and a similar solution would be faster.
#lang racket
(define (tuples list n)
(let loop ([n n])
(if (zero? n)
'(())
(for*/list ([y (in-list (loop (sub1 n)))] [x (in-list list)])
(cons x y)))))
(define precedence
(let ([t (make-hasheq)])
(for ([ops '((#f) (+ -) (* /) (||))] [n (in-naturals)])
(for ([op ops]) (hash-set! t op n)))
t))
(define (do op x y)
(case op
[(+) (+ x y)] [(-) (- x y)] [(*) (* x y)] [(/) (/ x y)]
[(||) (+ (* 10 x) y)]))
(define (run ops nums)
(unless (= (add1 (length ops)) (length nums)) (error "poof"))
(let loop ([nums (cddr nums)]
[ops (cdr ops)]
[numstack (list (cadr nums) (car nums))]
[opstack (list (car ops))])
(if (and (null? ops) (null? opstack))
(car numstack)
(let ([op (and (pair? ops) (car ops))]
[topop (and (pair? opstack) (car opstack))])
(if (> (hash-ref precedence op)
(hash-ref precedence topop))
(loop (cdr nums)
(cdr ops)
(cons (car nums) numstack)
(cons op opstack))
(loop nums
ops
(cons (do topop (cadr numstack) (car numstack))
(cddr numstack))
(cdr opstack)))))))
(define (expr ops* nums*)
(define ops (map symbol->string ops*))
(define nums (map number->string nums*))
(string-append* (cons (car nums) (append-map list ops (cdr nums)))))
(define nums (for/list ([i (in-range 10 0 -1)]) i))
(define year1 2012)
(define nyears 100)
(define year2 (+ year1 nyears))
(define years (make-vector nyears '()))
(for ([ops (in-list (tuples '(+ - * / ||) 9))])
(define r (run ops nums))
(when (and (integer? r) (<= year1 r) (< r year2))
(vector-set! years (- r year1)
(cons ops (vector-ref years (- r year1))))))
(for ([solutions (in-vector years)] [year (in-range year1 year2)])
(if (pair? solutions)
(printf "~a = ~a~a\n"
year (expr (car solutions) nums)
(if (null? (cdr solutions))
""
(format " (~a more)" (length (cdr solutions)))))
(printf "~a: no combination!\n" year)))
Below is my implementation. I tweaked and optimized a thing or two in your code, in my laptop it takes around 35 minutes to finish (certainly an improvement!) I found that the evaluation of expressions is the real performance killer - if it weren't for the calls to the procedure to-expression, the program would finish in under a minute.
I guess that in programming languages that natively use infix notation the evaluation would be much faster, but in Scheme the cost for parsing and then evaluating a string with an infix expression is just too much.
Maybe someone can point out a suitable replacement for the soegaard/infix package? or alternatively, a way to directly evaluate an infix expression list that takes into account operator precedence, say '(1 + 3 - 4 & 7) - where & stands for number concatenation and has the highest precedence (for example: 4 & 7 = 47), and the other arithmetic operators (+, -, *, /) follow the usual precedence rules.
#lang at-exp racket
(require (planet soegaard/infix)
(planet soegaard/infix/parser))
(define (product lst1 lst2)
(for*/list ([x (in-list lst1)]
[y (in-list lst2)])
(cons x y)))
(define (tuples lst n)
(if (zero? n)
'(())
(product lst (tuples lst (sub1 n)))))
(define (riffle numbers ops)
(if (null? ops)
(list (car numbers))
(cons (car numbers)
(cons (car ops)
(riffle (cdr numbers)
(cdr ops))))))
(define (expression-string numbers optuple)
(apply string-append
(riffle numbers optuple)))
(define (to-expression exp-str)
(eval
(parse-expression
#'here (open-input-string exp-str))))
(define (make-all-combinations numbers ops)
(let loop ((opts (tuples ops (sub1 (length numbers))))
(acc '()))
(if (null? opts)
acc
(let ((exp-str (expression-string numbers (car opts))))
(loop (cdr opts)
(cons (cons exp-str (to-expression exp-str)) acc))))))
(define (show-n-expressions all-combinations years)
(for-each (lambda (year)
(for-each (lambda (comb)
(when (= (cdr comb) year)
(printf "~s ~a~n" year (car comb))))
all-combinations)
(printf "~n"))
years))
Use it like this for replicating the results in the original blog post:
(define numbers '("10" "9" "8" "7" "6" "5" "4" "3" "2" "1"))
(define ops '("" "+" "-" "*" "/"))
; beware: this takes around 35 minutes to finish in my laptop
(define all-combinations (make-all-combinations numbers ops))
(show-n-expressions all-combinations
(build-list 5 (lambda (n) (+ n 2012))))
UPDATE :
I snarfed Eli Barzilay's expression evaluator and plugged it into my solution, now the pre-calculation of all combinations is done in around 5 seconds! The show-n-expressions procedure still needs some work to avoid iterating over the whole list of combinations each time, but that's left as an exercise for the reader. What matters is that now brute-forcing the values for all the possible expression combinations is blazing fast.
#lang racket
(define (tuples lst n)
(if (zero? n)
'(())
(for*/list ((y (in-list (tuples lst (sub1 n))))
(x (in-list lst)))
(cons x y))))
(define (riffle numbers ops)
(if (null? ops)
(list (car numbers))
(cons (car numbers)
(cons (car ops)
(riffle (cdr numbers)
(cdr ops))))))
(define (expression-string numbers optuple)
(string-append*
(map (lambda (x)
(cond ((eq? x '&) "")
((symbol? x) (symbol->string x))
((number? x) (number->string x))))
(riffle numbers optuple))))
(define eval-ops
(let ((precedence (make-hasheq
'((& . 3) (/ . 2) (* . 2)
(- . 1) (+ . 1) (#f . 0))))
(apply-op (lambda (op x y)
(case op
((+) (+ x y)) ((-) (- x y))
((*) (* x y)) ((/) (/ x y))
((&) (+ (* 10 x) y))))))
(lambda (nums ops)
(let loop ((nums (cddr nums))
(ops (cdr ops))
(numstack (list (cadr nums) (car nums)))
(opstack (list (car ops))))
(if (and (null? ops) (null? opstack))
(car numstack)
(let ((op (and (pair? ops) (car ops)))
(topop (and (pair? opstack) (car opstack))))
(if (> (hash-ref precedence op)
(hash-ref precedence topop))
(loop (cdr nums)
(cdr ops)
(cons (car nums) numstack)
(cons op opstack))
(loop nums
ops
(cons (apply-op topop (cadr numstack) (car numstack))
(cddr numstack))
(cdr opstack)))))))))
(define (make-all-combinations numbers ops)
(foldl (lambda (optuple tail)
(cons (cons (eval-ops numbers optuple) optuple) tail))
empty (tuples ops (sub1 (length numbers)))))
(define (show-n-expressions all-combinations numbers years)
(for-each (lambda (year)
(for-each (lambda (comb)
(when (= (car comb) year)
(printf "~s ~a~n"
year
(expression-string numbers (cdr comb)))))
all-combinations)
(printf "~n"))
years))
Use it like this:
(define numbers '(10 9 8 7 6 5 4 3 2 1))
(define ops '(& + - * /))
; this is very fast now!
(define all-combinations (make-all-combinations numbers ops))
(show-n-expressions all-combinations numbers
(build-list 5 (lambda (n) (+ n 2012))))
As Óscar points out, the problem is that soegaard/infix is slow for this type of problem.
I found a standard shunting-yard parser for infix expressions on GitHub and wrote the following program in Racket:
#lang racket
(require "infix-calc.scm")
(define operators '("*" "/" "+" "-" ""))
(time
(for*/list ([o1 (in-list operators)]
[o2 (in-list operators)]
[o3 (in-list operators)]
[o4 (in-list operators)]
[o5 (in-list operators)]
[o6 (in-list operators)]
[o7 (in-list operators)]
[o8 (in-list operators)]
[o9 (in-list operators)]
[expr (in-value
(apply string-append
(list "1" o1 "2" o2 "3" o3 "4" o4 "5" o5 "6" o6 "7" o7 "8" o8 "9" o9 "10")))]
#:when (= (first (calc expr)) 2012))
expr))
After a little less than 3 minutes the results are:
Welcome to DrRacket, version 5.2.900.2--2012-03-29(8c22c6c/a) [3m].
Language: racket; memory limit: 128 MB.
cpu time: 144768 real time: 148818 gc time: 25252
'("1*2*3+4*567*8/9-10"
"1*2+34*56+7+89+10"
"1*23+45*6*7+89+10"
"1+2+3/4*5*67*8+9-10"
"1+2+3+4*567*8/9-10"
"1+2+34*56+7+8+9*10"
"1+23+45*6*7+8+9*10"
"1-2+345*6-7*8+9-10"
"12*34*5+6+7*8-9*10"
"12*34*5+6-7-8-9-10"
"1234+5-6+789-10")
The infix parser was written by Andrew Levenson.
The parser and the above code can be found here:
https://github.com/soegaard/Scheme-Infix-Calculator
this isn't a complete answer, but i think it's an alternative to the library Óscar López is asking for. unfortunately it's in clojure, but hopefully it's clear enough...
(def default-priorities
{'+ 1, '- 1, '* 2, '/ 2, '& 3})
(defn- extend-tree [tree priorities operator value]
(if (seq? tree)
(let [[op left right] tree
[old new] (map priorities [op operator])]
(if (> new old)
(list op left (extend-tree right priorities operator value))
(list operator tree value)))
(list operator tree value)))
(defn priority-tree
([operators values] (priority-tree operators values default-priorities))
([operators values priorities] (priority-tree operators values priorities nil))
([operators values priorities tree]
(if-let [operators (seq operators)]
(if tree
(recur
(rest operators) (rest values) priorities
(extend-tree tree priorities (first operators) (first values)))
(let [[v1 v2 & values] values]
(recur (rest operators) values priorities (list (first operators) v1 v2))))
tree)))
; [] [+ & *] [1 2 3 4] 1+23*4
; [+ 1 2] [& *] [3 4] - initial tree
; [+ 1 [& 2 3]] [*] [4] - binds more strongly than + so replace right-most node
; [+ 1 [* [& 2 3] 4]] [] [] - descend until do not bind more tightly, and extend
(println (priority-tree ['+ '& '*] [1 2 3 4])) ; 1+23*4
(println (priority-tree ['& '- '* '+ '&] [1 2 3 4 5 6])) ; 12 - 3*4 + 56
the output is:
(+ 1 (* (& 2 3) 4))
(+ (- (& 1 2) (* 3 4)) (& 5 6))
[update] adding the following
(defn & [a b] (+ b (* 10 a)))
(defn all-combinations [tokens length]
(if (> length 0)
(for [token tokens
smaller (all-combinations tokens (dec length))]
(cons token smaller))
[[]]))
(defn all-expressions [operators digits]
(map #(priority-tree % digits)
(all-combinations operators (dec (count digits)))))
(defn all-solutions [target operators digits]
(doseq [expression
(filter #(= (eval %) target)
(all-expressions operators digits))]
(println expression)))
(all-solutions 2012 ['+ '- '* '/ '&] (range 10 0 -1))
solves the problem, but it's slow - 28 minutes to complete. this is on a nice, fairly recent laptop (i7-2640M).
(+ (- (+ 10 (* 9 (& 8 7))) (& 6 5)) (* 4 (& (& 3 2) 1)))
(+ (- (+ (+ (* (* 10 9) 8) 7) 6) 5) (* 4 (& (& 3 2) 1)))
(- (- (+ (- (& 10 9) (* 8 7)) (* (& (& 6 5) 4) 3)) 2) 1)
(i only printed 2012 - see code above - but it would have evaluated the entire sequence).
so, unfortunately, this doesn't really answer the question, since it's no faster than Óscar López's code. i guess the next step would be to put some smarts into the evaluation and so save some time. but what?
[update 2] after reading the other posts here i replaced eval with
(defn my-eval [expr]
(if (seq? expr)
(let [[op left right] expr]
(case op
+ (+ (my-eval left) (my-eval right))
- (- (my-eval left) (my-eval right))
* (* (my-eval left) (my-eval right))
/ (/ (my-eval left) (my-eval right))
& (& (my-eval left) (my-eval right))))
expr))
and the running time drops to 45 secs. still not great, but it's a very inefficient parse/evaluation.
[update 3] for completeness, the following is an implementation of the shunting-yard algorithm (a simple one that is always left-associative) and the associated eval, butit only reduces the time to 35s.
(defn shunting-yard
([operators values] (shunting-yard operators values default-priorities))
([operators values priorities]
(let [[value & values] values]
(shunting-yard operators values priorities nil (list value))))
([operators values priorities stack-ops stack-vals]
; (println operators values stack-ops stack-vals)
(if-let [[new & short-operators] operators]
(let [[value & short-values] values]
(if-let [[old & short-stack-ops] stack-ops]
(if (> (priorities new) (priorities old))
(recur short-operators short-values priorities (cons new stack-ops) (cons value stack-vals))
(recur operators values priorities short-stack-ops (cons old stack-vals)))
(recur short-operators short-values priorities (list new) (cons value stack-vals))))
(concat (reverse stack-vals) stack-ops))))
(defn stack-eval
([stack] (stack-eval (rest stack) (list (first stack))))
([stack values]
(if-let [[op & stack] stack]
(let [[right left & tail] values]
(case op
+ (recur stack (cons (+ left right) tail))
- (recur stack (cons (- left right) tail))
* (recur stack (cons (* left right) tail))
/ (recur stack (cons (/ left right) tail))
& (recur stack (cons (& left right) tail))
(recur stack (cons op values))))
(first values))))
Interesting! I had to try it, it's in Python, hope you don't mind. It runs in about 28 seconds, PyPy 1.8, Core 2 Duo 1.4
from __future__ import division
from math import log
from operator import add, sub, mul
div = lambda a, b: float(a) / float(b)
years = set(range(2012, 2113))
none = lambda a, b: a * 10 ** (int(log(b, 10)) + 1) + b
priority = {none: 3, mul: 2, div: 2, add: 1, sub: 1}
symbols = {none: '', mul: '*', div: '/', add: '+', sub: '-', None: ''}
def evaluate(numbers, operators):
ns, ops = [], []
for n, op in zip(numbers, operators):
while ops and (op is None or priority[ops[-1]] >= priority[op]):
last_n = ns.pop()
last_op = ops.pop()
n = last_op(last_n, n)
ns.append(n)
ops.append(op)
return n
def display(numbers, operators):
return ''.join([
i for n, op in zip(numbers, operators) for i in (str(n), symbols[op])])
def expressions(years):
numbers = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1
operators = none, add, sub, mul, div
pools = [operators] * (len(numbers) - 1) + [[None]]
result = [[]]
for pool in pools:
result = [x + [y] for x in result for y in pool]
for ops in result:
expression = evaluate(numbers, ops)
if expression in years:
yield '%d = %s' % (expression, display(numbers, ops))
for year in sorted(expressions(years)):
print year