XPost: comp.lang.scheme

Raffael Cavallaro wrote:

Hi, perhaps someone can help me translate my Python version?

(defun fib (x)
(do ((a 0 b) ;; do loop variable a is initially 0, then b
(b 1 (+ a b)) ;;loop variable b is initially 1 then a + b
(i 1 (1+ i))) ;;loop index incremented by 1 each go round
((> i x) a))) ;;termination condition - when index passes x stop
;; and return a

(defun fib-evens (limit)
"find the sum of all the even fibonacci numbers less than 1 million"
(loop for i from 1 ;;loop index starts at 1 implicitly incremented by 1
as current = (fib i) ;;compute fib of the current index
while (< current limit) ;;stop if index exceeds limit
when (evenp current) sum current)) ;;sum all the even fibs and
return this sum

CL-USER> (time (fib-evens 1000000)) ;; time the sum of all the even
fibs less than a million
Evaluation took:
0.0 seconds of real time
8.e-6 seconds of user run time ;;; took about one
onehundredthousandth of a second
1.e-6 seconds of system run time
0 page faults and
0 bytes consed.
1089154 ;; here's your answer

Gauche Scheme

(define (sum-even-fibs limit)
(loop (a 1 b 1 sum 0)
(:till (>= a limit))
(if (even? a) (inc! sum a))
(sset! a b b (+ a b))))

(sum-even-fibs 999999)
===>
1089154

Given:

(define-syntax sset!-aux
(syntax-rules ()
[(sset!-aux (var val more ...) (pairs ...))
(sset!-aux (more ...) (pairs ... (var val)))]
[(sset!-aux () ((var val) ...))
(set!-values (var ...) (values val ...))]))
(define-syntax sset!
(syntax-rules ()
[(sset! x ...) (sset!-aux (x ...) ())]))

(define-syntax loop-aux
(syntax-rules (:till :=)
[(loop-aux (var val more ...) (good ...) stuff ...)
(loop-aux (more ...) (good ... (var val)) stuff ...)]
[(loop-aux (var) (good ...) stuff ...)
(loop-aux () (good ... (var '())) stuff ...)]
[(loop-aux lets goodlets (stuff ... (:till what result)) (seen ...) go)
(loop-aux lets goodlets (stuff ...)
((if what result (begin seen ...))) go)]
[(loop-aux () (pairs ... (k v)) (stuff ... (:till what)) (seen ...) go)
(loop-aux () (pairs ... (k v)) (stuff ... (:till what k)) (seen ...) go)]
[(loop-aux lets goodlets (stuff ... (:till what)) (seen ...) go)
(loop-aux lets goodlets (stuff ...) ((unless what seen ...)) go)]
[(loop-aux lets goodlets (stuff ... (x := z)) (seen ...) go)
(loop-aux lets goodlets (stuff ...) ((let ((x z)) seen ...)) go)]
[(loop-aux lets goodlets (stuff ... last) (seen ...) go)
(loop-aux lets goodlets (stuff ...) (last seen ...) go)]
[(loop-aux lets goodlets () (seen ...) go)
(let* goodlets
(let go ()
seen ...)) ]))

(define-syntax loop
(syntax-rules ()
[(loop lets things ...)
(loop-aux lets () (things ...) ((go)) go)]))

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)