So imagine i have a list '(+ (* (x) (5)) (2))
How would i make a procedure that changes the x to whichever parameter i give and then evaluates
the function inside the list?
((calculate expression x))
I had some ideas but didn't get it to work.
These are the helprocedures i made:
(define (atom? x)
(not (pair? x)))
(define (deep-map f l)
(cond
((null? l) '())
((atom? l) (f l))
(else
(cons (deep-map f (car l))
(deep-map f (cdr l))))))
(define (deep-change e1 e2 l)
(deep-map (lambda (x) (if (eq? x e1) e2 x)) l))
(define (go-through-list list)
(if (null? list)
'()
((car list) (go-through-list (cdr list)))))
Here is the main code:
(define (calculate expression x)
(let ((expressie (deep-change 'x x expression)))
(('+ (deep-change '+ (+) expression)))
(('- (deep-change '- (-) expression)))
(('* (deep-change '* (*) expression)))
(('/ (deep-change '/ (/) expression)))
(go-through-list expression)))
I managed to change the x in to to parameter i give but have problems with the * and + inside the list.
(define (replace x y tree)
(cond ((null? tree) tree)
((not (or (pair? tree) (list? tree))) (if (eq? x tree) y tree))
(else (cons (replace x y (car tree))
(replace x y (cdr tree))))))
And then you can simply (replace 'x 42 expr).
Assuming the tree is then valid scheme code. You can simply eval it.
If you're trying to replace multiple variables, it might be wise write a replace-multiple function that will handle arbitrary number of variables so that you can do something like this
(replace-multiple '(x y z) '(1 2 3) expr)
Implementing this function is basically calling replace multiple times.
e.g.
(replace 'x 1 (replace 'y 2 (replace 'z 3 expr)))
So you might want to use recursion there.
If your scheme has the fold operator (provided by srfi-1), use it because it essentially achieves the above.
It would probably look something like this:
(define (replace-multiple xs ys tree)
(fold replace tree xs ys))
This could be an interesting question; consider this clarification:
Evaluate list representing expression with free variable without using eval
What is a way to develop a function to evaluate a Scheme expression built from
the four arithmetic operations, numbers, and a free variable x, without using eval?
The function is given a list representing the expression and a value for x.
Example: (calculate '(+ (* x 5) 2) 3) => 17
Development is presented as a sequence of elaborations of the calculate function;
each define has a Signature comment on the same line, informally describing
argument/result types; function and following example(s) can be copy-pasted into a REPL.
Note: not all errors are detected; there is a compact version without comments at the end.
Getting started: write a function which works for the given example:
(define (calculate-0 expression-in-x value-for-x) ;; '(+ (* x 5) 2) Number -> Number
(if (equal? expression-in-x '(+ (* x 5) 2))
(+ (* value-for-x 5) 2)
(error #f "wrong expression" expression-in-x)))
(calculate-0 '(+ (* x 5) 2) 3) ;=> 17
Real function will have to extract pieces of expression
a simple example with all elements is '(+ x 1):
(define (calculate-1 expression value) ;; '(+ x <n>) Number -> Number
(let ([procedure (car expression)]
[argument-1 (cadr expression)]
[argument-2 (caddr expression)])
(if (and (eq? procedure '+)
(eq? argument-1 'x)
(number? argument-2))
(+ value argument-2)
(error #f "expression" expression))))
(calculate-1 '(+ x 1) 2) ;=> 3
+ in Scheme accepts any number of arguments, so replace if with map/cond:
(define (calculate-2 expression value) ;; '(+ x|<n> ...) Number -> Number
(let ([arguments (cdr expression)])
(let ([arguments
(map (lambda (argument)
(cond ;; (compare with (if ...) in calculate-1)
[(eq? argument 'x) value ]
[(number? argument) argument ]
[else (error #f "argument" argument)]))
arguments)])
(apply + arguments))))
(calculate-2 '(+ 1 x) 2) ;=> 3
(calculate-2 '(+ x 1 x) 3) ;=> 7
(calculate-2 '(+) 99) ;=> 0
Get all four operations working:
(define (calculate-3 expression value) ;; '(op x|<n> ...) Number -> Number
(let ([procedure (car expression)]
[arguments (cdr expression)])
(let ([arguments ;; (same as calculate-2)
(map (lambda (argument)
(cond
[(eq? argument 'x) value ]
[(number? argument) argument ]
[else (error #f "argument" argument)]))
arguments)])
(apply (case procedure
[(+) + ]
[(-) - ]
[(*) * ]
[(/) / ]
[else (error #f "procedure" procedure)])
arguments))))
(calculate-3 '(* x 5) 3) ;=> 15
Allowing nested sub-forms needs just one small change:
(define (calculate-4 expression value) ;; '(op x|<n>|Expr ...) Number -> Number
(let ([procedure (car expression)]
[arguments (cdr expression)])
(let ([arguments
(map (lambda (argument)
(cond
[(eq? argument 'x) value ]
[(number? argument) argument ]
[(pair? argument) ;; (<- only change)
(calculate-4 argument value) ] ;;
[else (error #f "argument" argument)]))
arguments)])
(apply (case procedure
[(+) + ]
[(-) - ]
[(*) * ]
[(/) / ]
[else (error #f "procedure" procedure)])
arguments))))
(calculate-4 '(+ (* x 5) 2) 3) ;=> 17
So there it is: try calculate-4 with the original example in the REPL:
$ scheme
> (calculate-4 '(+ (* x 5) 2) 3)
17
> ; works with all Scheme Numbers:
(calculate-4 '(+ (* x 15/3) 2+2i) 3.0)
17.0+2.0i
>
Not so fast ... expression is a list with the form of a Scheme expression using four
operations, Numbers, and x. But the question doesn't require value to be a Number: procedures are
first-class values in Scheme
(expression could be '(+ (x 3) 2) with value (lambda (n) (* n 5)) ):
(define (calculate-5 expression value) ;; '(x|op x|<n>|Expr ...) Number|Lambda -> Value
(let ([procedure (car expression)]
[arguments (cdr expression)])
(let ([arguments
(map (lambda (argument)
(cond
[(eq? argument 'x) value ]
[(number? argument) argument ]
[(pair? argument) (calculate-5 argument value) ]
[else (error #f "argument" argument)]))
arguments)])
(let ([procedure
(cond ;; (compare with argument cond above)
[(eq? procedure 'x) value ]
[(pair? procedure) (calculate-5 procedure value)]
[else (case procedure
[(+) + ]
[(-) - ]
[(*) * ]
[(/) / ]
[else (error #f "procedure" procedure)]) ]) ])
(apply procedure arguments)))))
(calculate-5 '(+ (x 3) 2) (lambda (n) (* n 5))) ;=> 17
(And so, finally, our calculate function is "Hello World!" capable :)
$ scheme
> ;(copy-paste calculate-5 here)
> (calculate-5 '(x) (lambda _ 'Hello!))
Hello!
>
Compact version (returns #f on error):
(define (calculate expr value)
(call/cc (lambda (error)
(let* ([proc (car expr)]
[args (map (lambda (arg) (cond
[(eq? arg 'x) value]
[(number? arg) arg]
[(pair? arg)
(or (calculate arg value) (error #f))]
[else (error #f)]))
(cdr expr))]
[proc (cond
[(eq? proc 'x) value ]
[(pair? proc) (calculate proc value)]
[else (case proc [(+) +] [(-) -] [(*) *] [(/) /]
[else (error #f)])])])
(apply proc args)))))
I am new to Lisp Scheme .
I am trying to write Caesar cipher program using the Lisp Scheme on DrRacket IDE.
I am getting the following
paragraph: undefined;
cannot reference undefined identifier
My code is as follow
;; ENVIRONMENT
;; contains "ctv", "vtc",and "reduce" definitions
(load "include.ss")
;; contains a test document consisting of three paragraphs.
(load "document.ss")
;; contains a test-dictionary, which has a much smaller dictionary for testing
;; the dictionary is needed for spell checking
(load "test-dictionary.ss")
(load "dictionary.ss") ;; the real thing with 45,000 words
;; -----------------------------------------------------
;; HELPER FUNCTIONS
;; returns a function to "spin" arg "letter" by "val"
(define spin
(lambda (val)
(lambda (letter)
(vtl(modulo (+ val (ltv letter)) 26)))))
;; returns a function to spin current letter to value of 'e'
(define spin_to_e
(lambda (pos)
(+ (- 26 pos) 4)
))
;;counts how many of a target letter are in a word. (count_letter 'x) returns a func that counts x in a list. ((count_letter 'x) '(list)) counts x in list
(define count_letter
(lambda (ltr)
(lambda (lis)
(if (null? lis)
0
(if (equal? (car lis) ltr)
(+ 1 ((count_letter ltr) (cdr lis)))
(+ 0 ((count_letter ltr) (cdr lis)))))
)))
;;counts how many elements in a list == #t
(define count_true
(lambda (l)
(reduce + (map (lambda (x) (if (equal? x #t) 1 0)) l) 0) )) ;;HERE'S MY USE OF REDUCE. Count's how many #t's are in a list
;;show me the truth
(define containstrue?
(lambda (l)
(if (null? l)
#f
(if (equal? (car l) #t)
#t
(containstrue? (cdr l))))
))
(define (sortappend l piece) ;;adds one by one, putting element at the head if >= current head
(if (null? l) (append '() l)
(if (>= piece (car l))
(cons piece l)
(append l (list piece)))))
(define find_index ;;finds target element, returns its "index" from 0 26
(lambda (l t)
(if (null? l) 0
(if (equal? t (car l))
0
(+ 1 (find_index (cdr l) t)) ))
))
;; *** CODE FOR ANY HELPER FUNCTION GOES HERE ***
;; -----------------------------------------------------
;; SPELL CHECKER FUNCTION
;;check a word's spell correctness
;;INPUT:a word(a global variable "dictionary" is included in the file "test-dictionary.ss", and can be used directly here)
;;OUTPUT:true(#t) or false(#f)
(define spell-checker
(lambda (w)
(if (member w dictionary) #t #f)
;; DONE
))
;; -----------------------------------------------------
;; ENCODING FUNCTIONS
;;(define (multiplyBy n) (lambda (x) (* n x)))
;;((multiplyBy 5) 2) ^^how to ret a function
;;generate an Caesar Cipher single word encoders
;;INPUT:a number "n"
;;OUTPUT:a function, whose input=a word, output=encoded word
(define encode-n
(lambda (n);;"n" is the distance, eg. n=3: a->d,b->e,...z->c
(lambda (w);;"w" is the word to be encoded
(map (spin n) w) ;;performs helper func 'spin' on every letter in given word w
)))
;;encode a document
;;INPUT: a document "d" and a "encoder"
;;OUTPUT: an encoded document using a provided encoder
(define encode-d;;this encoder is supposed to be the output of "encode-n"
(lambda (d encoder)
(if (null? d) '() ;;catches recursive base case, returns empty list
(append (cons(map encoder (car d)) '()) (encode-d (cdr d) encoder) )) ;;encode first para, concat w/ recursive call on rest
))
;; -----------------------------------------------------
;; DECODE FUNCTION GENERATORS
;; 2 generators should be implemented, and each of them returns a decoder
;;generate a decoder using brute-force-version spell-checker
;;INPUT:an encoded paragraph "p"
;;OUTPUT:a decoder, whose input=a word, output=decoded word
(define Gen-Decoder-A
(lambda (p)
(define return_decoder
(lambda (i)
(encode-n i)
))
(define valid_wordcounts
(map count_true
(list
(map spell-checker (map (encode-n 0) p))
(map spell-checker (map (encode-n 1) p))
(map spell-checker (map (encode-n 2) p))
(map spell-checker (map (encode-n 3) p))
(map spell-checker (map (encode-n 4) p))
(map spell-checker (map (encode-n 5) p))
(map spell-checker (map (encode-n 6) p))
(map spell-checker (map (encode-n 7) p))
(map spell-checker (map (encode-n 8) p))
(map spell-checker (map (encode-n 9) p))
(map spell-checker (map (encode-n 10) p))
(map spell-checker (map (encode-n 11) p))
(map spell-checker (map (encode-n 12) p))
(map spell-checker (map (encode-n 13) p))
(map spell-checker (map (encode-n 14) p))
(map spell-checker (map (encode-n 15) p))
(map spell-checker (map (encode-n 16) p))
(map spell-checker (map (encode-n 17) p))
(map spell-checker (map (encode-n 18) p))
(map spell-checker (map (encode-n 19) p))
(map spell-checker (map (encode-n 20) p))
(map spell-checker (map (encode-n 21) p))
(map spell-checker (map (encode-n 22) p))
(map spell-checker (map (encode-n 23) p))
(map spell-checker (map (encode-n 24) p))
(map spell-checker (map (encode-n 25) p)))))
(return_decoder
(find_index valid_wordcounts (apply max valid_wordcounts)))
))
;;generate a decoder using frequency analysis
;;INPUT:same as above ;;sample of a doc, so a para
;;OUTPUT:same as above
(define Gen-Decoder-B
(lambda (p)
(define return_decoder
(lambda (i)
(encode-n i)
))
(define lettercounts
(list
(reduce + (map (count_letter 'a)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'b)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'c)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'd)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'e)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'f)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'g)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'h)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'i)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'j)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'k)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'l)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'm)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'n)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'o)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'p)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'q)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'r)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 's)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 't)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'u)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'v)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'w)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'x)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'y)(reduce append (list p) '())) 0)
(reduce + (map (count_letter 'z)(reduce append (list p) '())) 0)))
(return_decoder (spin_to_e (find_index lettercounts (apply max lettercounts))))
))
;; -----------------------------------------------------
;; CODE-BREAKER FUNCTION
;;a codebreaker
;;INPUT: an encoded document(of course by a Caesar's Cipher), a decoder(generated by functions above)
;;OUTPUT: a decoded document
(define Code-Breaker
(lambda (d decoder)
(if (null? d) '() ;;catches recursive base case, returns empty list
(append (cons(map decoder (car d)) '()) (Code-Breaker (cdr d) decoder)) ) ;;encode first para, concat w/ recursive call on rest
))
;; -----------------------------------------------------
;; EXAMPLE APPLICATIONS OF FUNCTIONS
(spell-checker '(h e l l o))
(define add5 (encode-n 5))
(encode-d document add5)
;(define decoderSP1 (Gen-Decoder-A paragraph))
(define decoderFA1 (Gen-Decoder-B paragraph))
(Code-Breaker document decoderSP1)
The IDE shows the error at the second last line of the code
(define decoderFA1 (Gen-Decoder-B paragraph)).
The error is due to paragraph .
Help me fix this error. Thanks in advance for helping
I have the necessary external files , but those only contain the list
You are using DrRacket to write a Scheme program. Since DrRacket can be used with many languages, you need to choose R5RS Scheme as your language:
1. In the lower left corner of DrRacket, click the drop down menu.
2. Click "Choose Language..."
3. Choose R5RS Scheme.
Also remember to copy the files "include.ss", "document.ss", "test-dictionary.ss" and "dictionary.ss" into the same directory as your own source file.
PS: Is it this project?
https://github.com/T-G-P/CaeserDawg/blob/master/proj2.pdf
I got it print sub (A 3333) (A 4444), but I can't figure out to print out both
sub (A 3333) (A 4444)
add (R 0) (R 1)
(define tree '("S" ( ("-"("A" 3333 )("A" 4444))) ("W" (("+" ("R" 0) ("R" 1))))))
(define (OperandNode on)
(display on))
(define (TwoOperandNode x)
(car x)
(if(equal? (car x) "-")
((display "sub")
(OperandNode (cadr x))
(OperandNode (caddr x)))))
(TwoOperandNode (caadr tree))
(define (WhileNode h)
(car h)
(if(equal? (car h) "+")
((display "add")
(WhileNode (cadr h))
(WhileNode (caddr h)))))
(WhileNode (caaadr tree))
You know that for the following form:
(+ 1 2)
The parts are evaluated, eg. + gets evaluated ta procedure #<procedure:+> and the numbers get evaluated to themselves. Then Scheme applies it and gets the result 3. Now look at what you have done in WhileNode:
((display "add") (WhileNode (cadr h)) (WhileNode (caddr h))) ; ==
(#<void> ...) ; throws error
So the parts get evaluated here to. However the problem is that the expression in operator position, (display "add"), returns #<void>. It doesn't know how to continue from this. In Java the same code would look like this:
System.out.println("add")(WhileNode(cadr(h)), WhileNode(caddr(h)));
In Scheme its perfectly natural to have expressions in operator position, but it must evaluate to a procedure:
(define (abs-proc x)
(if (positive? x)
values
-))
((abs-proc -5) -5) ; ==
(- -5) ; ==
; ==> 5
((abs-proc 3) 3) ; ==
(values 3) ; ==
; ==> 3
This seems straightforward, but I can't seem to find a solution. I want to replace an item within a list of a list with something, but if that item appears multiple times then you randomly replace one of them, but not both. I want to do this in ISL+.
I created the function flatten which appends all sublists :
(check-expect (flatten '((a b) (c) (d e f g) (h i j)))
(list 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j))
(define (flatten lol)
(foldr append empty lol))
I also made rewrite, which replaces the value at index n with whatever you choose
(check-expect (rewrite '(x x x - x x x x) 3 'x)
(list 'x 'x 'x 'x 'x 'x 'x 'x))
(define (rewrite ls n val)
(cond
[(empty? ls) (error "error")]
[(= n 0) (cons val (rest ls))]
[else (cons (first ls) (rewrite (rest ls) (sub1 n) val))]))
The problem is I don't know how to apply this to a list of list and I also don't know how to randomly replace one of items if it occurs more than once. This is what I have for the final product, but it's probably not the way to go:
(define (fullreplace b)
(local [
;makes a list of nested lists of each index the element occurs
;problem is that it makes a list of nested lists so I can't use flatten either
(define (position ls ele n)
(cond [(empty? ls) 0]
[(equal? ele (first ls)) (list n (position (rest ls) ele (add1 n))) ]
[else (position (rest ls) ele (+ 1 n))]))]
;lol-full? checks if the item occurs in the list of lists at all
(if (lol-full? b) b (rewrite (flatten b)
(position (flatten b) '- 0)
"item replaced"))))
;just used for testing
(define lol2 (list
(list 2 2 2 2)
(list 4 '- 4 '-)
(list '- 8 8 8)
(list 16 '- '- 16)))
(fullreplace lol2) may return this or where any of the other '- are located:
(list
(list 2 2 2 2)
(list 4 '- 4 2)
(list '- 8 8 8)
(list 16 '- '- 16))
I've been working on this awhile so any new insight would go a long way. Thank you
The "random" part is what makes this problem pathological. If you could just replace the first occurrence, it would be easy. But to replace a random occurence, you must first know how many occurrences there are. So before you go replacing stuff, you have to go a-counting:
(define (count/recursive val tree)
(cond ((equal? val tree)
1)
(else (foldl (λ (next-value total)
(cond ((equal? val next-value)
(add1 total))
((list? next-value)
(+ total (count/recursive val next-value)))
(else total))) 0 tree))))
Then you need a function that can replace the nth occurrence of a value:
(define (replace/recursive val replace-with n tree)
(cond ((equal? val tree)
replace-with)
(else
(cdr
(foldl (λ (next-value total/output-tree)
(local ((define total (car total/output-tree))
(define output-tree (cdr total/output-tree)))
(cond ((equal? next-value val)
(cons (add1 total)
(cons (if (= total n) replace-with next-value) output-tree)))
((list? next-value)
(cons (+ total (count/recursive val next-value))
(cons (replace/recursive val replace-with (- n total) next-value)
output-tree)))
(else (cons total (cons next-value output-tree)))))) (cons 0 empty) tree)))))
Finally, you use random to pick the instance you will replace, using count/recursive to limit how high of a number random picks:
(define original '((x x (x y x) a b (((c x z x) x) y x x))))
(replace/recursive 'x '- (random (count/recursive 'x original)) original)
How to replace all occurences of a value with another value:
(define (replace-all needle new-value haystack)
(cond ((equal? needle haystack) new-value)
((pair? haystack)
(cons (replace-all needle new-value (car haystack))
(replace-all needle new-value (cdr haystack))))
(else haystack)))
The only thing to change is to check if the first part constituted a change. If it did you don't do the replace on the other half. Use equal? to compare structure.
It's not random. It will replace the first occurence it finds either by doing car before cdr or cdr before car.
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