diff --git a/little_book/little_scheme/equal.rkt b/little_book/little_scheme/equal.rkt deleted file mode 100644 index 2187a7d..0000000 --- a/little_book/little_scheme/equal.rkt +++ /dev/null @@ -1,43 +0,0 @@ -#lang racket - -; eq? : takes two non-numeric atom. -; = : for numbers -; eqan?: atom equal -; eqlist?: list equal -; equal? : s-expression equal - -; for real-world scheme: eq? is for reference equal -; while equal? is for value equal. - -(require "base.rkt") - -(define (eqan? a1 a2) - (cond ((and (number? a1) (number? a2)) - (= a1 a2)) - ; one is number while the other is not - ((or (number? a1) (number? a2)) - #f) - (else (eq? a1 a2)))) - - -(define (eqlist? l1 l2) - (cond ((and (null? l1) (null? l2)) #t) - ((or (null? l1) (null? l2)) #f) - ((and (atom? (car l1)) - (atom? (car l2))) - (and (eqan? (car l1) - (car l2)) - (eqlist? (cdr l1) - (cdr l2)))) - ((or (atom? (car l1)) - (atom? (car l2))) #f) - (else (and (eqlist? (car l1) - (car l2)) - (eqlist? (cdr l1) - (cdr l2)))))) - -(define (equal? s1 s2) - (cond ((and (atom? s1) (atom? s2)) - (eqan? s1 s2)) - ((or (atom? s1) (atom? s2)) #f) - (else (eqlist? s1 s2)))) diff --git a/run.rkt b/run.rkt deleted file mode 100644 index faebe23..0000000 --- a/run.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket -(require "exercise1.rkt") -(require "newton.rkt") -(require "counting_change.rkt") - - - diff --git a/src/c3_51.scm b/src/c3_51.scm new file mode 100644 index 0000000..7d3eb4f --- /dev/null +++ b/src/c3_51.scm @@ -0,0 +1,10 @@ +(import (rnrs) + (stream) + (utils)) + +(define x (stream-map println (stream-enumerate-interval 0 10))) + +(newline) +(stream-ref x 5) +(newline) +(stream-ref x 7) diff --git a/src/c3_52.scm b/src/c3_52.scm new file mode 100644 index 0000000..b264289 --- /dev/null +++ b/src/c3_52.scm @@ -0,0 +1,19 @@ +(import (rnrs) + (stream) + (utils)) + +(let ((sum 0)) + (define (accum x) + (set! sum (+ x sum)) + sum) + ; ok, assignment in lazy evaluation is really confusing + (let ((seq (stream-map accum (stream-enumerate-interval 1 20)))) + (define y (stream-filter even? seq)) + (define z (stream-filter (lambda (x) (= (remainder x 5) 0)) + seq)) + (println (stream-ref y 7)) + (newline) + (stream-display z))) + +;; the results is different. when memoize enabled, accum will be +;; called for less times, and resulting in smaller values printed. diff --git a/src/c3_53.scm b/src/c3_53.scm new file mode 100644 index 0000000..ac518fc --- /dev/null +++ b/src/c3_53.scm @@ -0,0 +1,9 @@ +; X0 = 1, Xn+1 = 2Xn + +(import (rnrs) + (stream) + (utils)) + +(define s (cons-stream 1 (stream-add s s))) + +(println (stream-ref s 10)) ; 1024 diff --git a/src/c3_54.scm b/src/c3_54.scm new file mode 100644 index 0000000..a89c2de --- /dev/null +++ b/src/c3_54.scm @@ -0,0 +1,8 @@ +(import (rnrs) + (stream) + (utils)) + +(define factorials (cons-stream 1 + (stream-mult (integers-start-from 2) s))) + +(println (stream-ref factorials 3)) diff --git a/src/c3_55.scm b/src/c3_55.scm new file mode 100644 index 0000000..9477455 --- /dev/null +++ b/src/c3_55.scm @@ -0,0 +1,5 @@ +(import (rnrs) + (stream) + (utils)) + +(stream-display-n (partial-sum integers) 10) diff --git a/src/c3_56.scm b/src/c3_56.scm new file mode 100644 index 0000000..7554487 --- /dev/null +++ b/src/c3_56.scm @@ -0,0 +1,31 @@ +(import (rnrs) + (stream) + (utils)) + +(define (merge s1 s2) + (cond ((stream-null? s1) s2) + ((stream-null? s2) s1) + (else + (let ((s1car (stream-car s1)) + (s2car (stream-car s2))) + (cond ((< s1car s2car) + (cons-stream s1car + (merge (stream-cdr s1) + s2))) + ((> s1car s2car) + (cons-stream s2car + (merge s1 + (stream-cdr s2)))) + (else + (cons-stream s1car + (merge (stream-cdr s1) + (stream-cdr s2))))))))) + +;(stream-display (merge (list-stream 1 2 3) + ;(list-stream 2 3 4))) + +(define S (cons-stream 1 (merge (stream-scale S 2) + (merge (stream-scale S 3) + (stream-scale S 5))))) + +(stream-display-n S 10) diff --git a/src/c3_57.scm b/src/c3_57.scm new file mode 100644 index 0000000..0cc260d --- /dev/null +++ b/src/c3_57.scm @@ -0,0 +1,15 @@ +(import (rnrs) + (stream) + (utils)) + + +(define fibs (cons-stream 0 + (cons-stream 1 + (stream-add (stream-cdr fibs) + fibs)))) + +(stream-ref fibs 7) + +; n additions are performed when optimization provided. +; Think about dynamic programming. (stream-ref fibs n) = (stream-ref fibs n-1) + (stream-ref fibs n-2) +; when no memoize enabled, for each (stream-ref fibs n-1), it will be recalculated. diff --git a/src/c3_58.scm b/src/c3_58.scm new file mode 100644 index 0000000..19a069a --- /dev/null +++ b/src/c3_58.scm @@ -0,0 +1,12 @@ +(import (rnrs) + (stream) + (utils)) + +(define (expand num den radix) + (cons-stream + (quotient (* num radix) den) + (expand (remainder (* num radix) den) den radix))) + +(stream-display-n (expand 1 7 10) 10) +(newline) +(stream-display-n (expand 3 8 10) 5) diff --git a/src/c3_59.scm b/src/c3_59.scm new file mode 100644 index 0000000..d368a1b --- /dev/null +++ b/src/c3_59.scm @@ -0,0 +1,8 @@ +(import (rnrs) + (stream) + (utils)) + +; (stream-display (integrate-series (list-stream 1 2 1))) + +(stream-display-n sine-series 10)(newline) +(stream-display-n cosine-series 10) diff --git a/src/c3_60.scm b/src/c3_60.scm new file mode 100644 index 0000000..90d04c4 --- /dev/null +++ b/src/c3_60.scm @@ -0,0 +1,10 @@ +(import (rnrs) + (stream) + (utils) + (series)) + +(stream-display-n (stream-add (mul-series sine-series sine-series) + (mul-series cosine-series cosine-series)) + 10) +; How did we get the result? +; see https://www.dropbox.com/s/qxnzmwe17kmd09z/2013-09-20%2023.45.44.jpg diff --git a/src/c3_61.scm b/src/c3_61.scm new file mode 100644 index 0000000..0014fe8 --- /dev/null +++ b/src/c3_61.scm @@ -0,0 +1,5 @@ +(import (rnrs) + (stream) + (series)) + +(stream-display-n (invert-unit-series exp-series) 10) diff --git a/src/c3_62.scm b/src/c3_62.scm new file mode 100644 index 0000000..f6b922c --- /dev/null +++ b/src/c3_62.scm @@ -0,0 +1,5 @@ +(import (rnrs) + (stream) + (series)) + +(stream-display-n tan-series 10) diff --git a/src/c3_63_notreally_understand.scm b/src/c3_63_notreally_understand.scm new file mode 100644 index 0000000..fc8685b --- /dev/null +++ b/src/c3_63_notreally_understand.scm @@ -0,0 +1,38 @@ +(import (rnrs) + (stream) + (utils)) + + +;(stream-display-n (partial-sum1 integers) 3) +(println (stream-ref (partial-sum integers) 3)) + + +(partial-sum integers) -> +(cons-stream (stream-car s) + (cons-stream (+ (stream-car (stream-cdr s)) + (stream-car sum)) + (cons-stream (+ (stream-car (stream-cdr (stream-cdr s))) + (stream-car (stream-cdr sum)))))) + ... + +(define (partial-sum s) + (cons-stream (stream-car s) + (stream-add (stream-cdr s) + (partial-sum s)))) +(partial-sum integers) -> + +(cons-stream (stream-car s) + (stream-add (stream-cdr s) + (cons-stream (stream-car s) + (stream-add (stream-cdr s) + (partial-sum s))))) -> +(cons-stream (stream-car s) + (cons-stream (+ (stream-car (stream-cdr s)) + (stream-car (cons-stream (stream-car s) + (stream-add (stream-cdr s) + (partial-sum s))))) + (stream-map + + (stream-cdr (stream-cdr s)) + (stream-cdr (cons-stream (stream-car s) + (stream-add (stream-cdr s) + (partial-sum s))))))) diff --git a/src/c3_64.scm b/src/c3_64.scm new file mode 100644 index 0000000..9196af5 --- /dev/null +++ b/src/c3_64.scm @@ -0,0 +1,28 @@ +(import (rnrs) + (stream) + (utils)) + +(define (sqrt-improve guess x) + (average guess (/ x guess))) + +(define (sqrt-stream x) + (define guesses + (cons-stream 1.0 + (stream-map (lambda (guess) + (sqrt-improve guess x)) + guesses))) + guesses) + + +(define (stream-limit s tolerance) + (let ((v1 (stream-car s)) + (v2 (stream-car (stream-cdr s)))) + (if (< (abs (- v1 v2)) + tolerance) + v1 + (stream-limit (stream-cdr s) tolerance)))) + +(define (mysqrt x tolerance) + (stream-limit (sqrt-stream x) tolerance)) + +(println (mysqrt 4 0.001)) diff --git a/src/c3_65.scm b/src/c3_65.scm new file mode 100644 index 0000000..be8fc49 --- /dev/null +++ b/src/c3_65.scm @@ -0,0 +1,21 @@ +(import (rnrs) + (series) + (stream) + (utils)) + +(define (log2-summands n) + (cons-stream (/ 1.0 n) + (stream-negate (log2-summands (+ n 1))))) + +(define log2-series (log2-summands 1)) + +(println (log 2)) + +(define log2 (partial-sum log2-series)) +(stream-display-n log2 10)(newline) + +(stream-display-n (euler-transform log2) 10)(newline) + +(stream-display-n (accelerated-sequence euler-transform + log2) + 10) diff --git a/src/c3_66.scm b/src/c3_66.scm new file mode 100644 index 0000000..834dfa6 --- /dev/null +++ b/src/c3_66.scm @@ -0,0 +1 @@ +; wtf diff --git a/src/c3_67.scm b/src/c3_67.scm new file mode 100644 index 0000000..533c92e --- /dev/null +++ b/src/c3_67.scm @@ -0,0 +1 @@ +; in stream-of-pairs.scm diff --git a/src/c3_68.scm b/src/c3_68.scm new file mode 100644 index 0000000..5625a12 --- /dev/null +++ b/src/c3_68.scm @@ -0,0 +1,3 @@ +; code is in stream-of-pairs.scm +; infinite recursion occured for the code, since second args of interleave +; is not delayed. diff --git a/src/c3_69.scm b/src/c3_69.scm new file mode 100644 index 0000000..533c92e --- /dev/null +++ b/src/c3_69.scm @@ -0,0 +1 @@ +; in stream-of-pairs.scm diff --git a/src/c3_71.scm b/src/c3_71.scm new file mode 100644 index 0000000..533c92e --- /dev/null +++ b/src/c3_71.scm @@ -0,0 +1 @@ +; in stream-of-pairs.scm diff --git a/src/c3_72.scm b/src/c3_72.scm new file mode 100644 index 0000000..533c92e --- /dev/null +++ b/src/c3_72.scm @@ -0,0 +1 @@ +; in stream-of-pairs.scm diff --git a/src/c3_73.scm b/src/c3_73.scm new file mode 100644 index 0000000..07b08c6 --- /dev/null +++ b/src/c3_73.scm @@ -0,0 +1 @@ +; in stream-signals.scm diff --git a/src/c3_77.scm b/src/c3_77.scm new file mode 100644 index 0000000..ac12b0a --- /dev/null +++ b/src/c3_77.scm @@ -0,0 +1 @@ +; in delayed-integral.scm diff --git a/src/c3_78.scm b/src/c3_78.scm new file mode 100644 index 0000000..ac12b0a --- /dev/null +++ b/src/c3_78.scm @@ -0,0 +1 @@ +; in delayed-integral.scm diff --git a/src/c3_79.scm b/src/c3_79.scm new file mode 100644 index 0000000..ac12b0a --- /dev/null +++ b/src/c3_79.scm @@ -0,0 +1 @@ +; in delayed-integral.scm diff --git a/src/delayed-integral.scm b/src/delayed-integral.scm new file mode 100644 index 0000000..b57d1d0 --- /dev/null +++ b/src/delayed-integral.scm @@ -0,0 +1,59 @@ +(import (rnrs) + (rnrs r5rs) + (stream)) + +(define (solve f y0 dt) + (define y (integral-delayed (delay dy) y0 dt)) + (define dy (stream-map f y)) + y) + +; y = e^x +(display (stream-ref (solve (lambda (y) y) 1 0.001) 1000))(newline) + + +; 3.77 +(define (integral-recur delayed-integrand initial-value dt) + (cons-stream initial-value + (let ((integrand (force delayed-integrand))) + (if (stream-null? integrand) + the-empty-stream + (integral-recur (delay (stream-cdr integrand)) + (+ (* dt (stream-car integrand)) + initial-value) + dt))))) + +(define (solve-use-recur f y0 dt) + (define y(integral-recur (delay dy) y0 dt)) + (define dy (stream-map f y)) + y) + +(stream-ref (solve-use-recur (lambda (y) y) 1 0.001) 1000) + +; 3.78 +(define (solve-2nd a b dt y0 dy0) + (define y (integral-delayed (delay dy) y0 dt)) + (define dy (integral-delayed (delay ddy) dy0 dt)) + (define ddy (stream-add (stream-scale dy a) + (stream-scale y b))) + y) + +; y = e^x, solve value at x = 1000 * 0.001 = 1 +(display (stream-ref (solve-2nd 2 -1 0.001 1 1) 1000))(newline) +; 3.79 + +(define (solve-2nd-general f y0 dy0 dt) + (define y (integral-delayed (delay dy) y0 dt)) + (define dy (integral-delayed (delay ddy) dy0 dt)) + (define ddy (stream-map f dy y)) + y) + +; y = e^x, f(dy,y) = 2*dy - y +(display (stream-ref (solve-2nd-general (lambda (dy y) + (- (* 2 dy) + y)) + 1 + 1 + 0.001) + 1000))(newline) + +; 3.80 unfinished diff --git a/src/euler-transform.scm b/src/euler-transform.scm new file mode 100644 index 0000000..c0d8017 --- /dev/null +++ b/src/euler-transform.scm @@ -0,0 +1,42 @@ +(import (rnrs) + (stream) + (utils)) + +(define (sqrt-improve guess x) + (average guess (/ x guess))) + +(define (sqrt-stream x) + (define guesses + (cons-stream 1.0 + (stream-map (lambda (guess) + (sqrt-improve guess x)) + guesses))) + guesses) + +(define (pi-summands n) + (cons-stream (/ 1.0 n) + (stream-map - (pi-summands (+ n 2))))) + +(define pi-stream + (stream-scale (partial-sum (pi-summands 1)) 4)) + +(define (euler-transform s) + (let ((s0 (stream-ref s 0)) + (s1 (stream-ref s 1)) + (s2 (stream-ref s 2))) + (cons-stream (- s2 (/ (square (- s2 s1)) + (+ s0 (* -2 s1) s2))) + (euler-transform (stream-cdr s))))) + +; (stream-display-n (euler-transform pi-stream) 10) + +(define (make-tableau transform s) + (cons-stream s + (make-tableau transform + (transform s)))) + +(define (accelerated-sequence transform s) + (stream-map stream-car + (make-tableau transform s))) + +(stream-display-n (accelerated-sequence euler-transform pi-stream) 10) diff --git a/src/eval/c4_1.scm b/src/eval/c4_1.scm new file mode 100644 index 0000000..f627634 --- /dev/null +++ b/src/eval/c4_1.scm @@ -0,0 +1,9 @@ + +(define (list-of-values-left-to-right exps env) + (if (null? exps) + '() + (let ((first-value (seck-eval (first-operand exps) env))) + (cons first-value + (list-of-values-left-to-right (rest-operands exps) env))))) + +;; right-to-left is just the same diff --git a/src/eval/c4_10.scm b/src/eval/c4_10.scm new file mode 100644 index 0000000..09a0272 --- /dev/null +++ b/src/eval/c4_10.scm @@ -0,0 +1,2 @@ +; this can be achieved by modifying the variable?, begin? func ... +; and corresponding make func diff --git a/src/eval/c4_11.scm b/src/eval/c4_11.scm new file mode 100644 index 0000000..eee52bf --- /dev/null +++ b/src/eval/c4_11.scm @@ -0,0 +1 @@ +; in eval.scm diff --git a/src/eval/c4_12.scm b/src/eval/c4_12.scm new file mode 100644 index 0000000..834dfa6 --- /dev/null +++ b/src/eval/c4_12.scm @@ -0,0 +1 @@ +; wtf diff --git a/src/eval/c4_13.scm b/src/eval/c4_13.scm new file mode 100644 index 0000000..60b54bc --- /dev/null +++ b/src/eval/c4_13.scm @@ -0,0 +1,8 @@ +; 1. I don't think we really need `make-unbound` +; 2. If we really need it, then it should be a terrible idea to +; provide a feature that can remove the binding from enclosed environment. +; Since that may bring ugly code. For example, if we call a func wrote by +; others, and the func may remove some binding silently, which will cause +; hard to debug bugs. Another case is, if the program provides some interface +; that can insert code by others, than the malicious users can call the unbound +; feature to bring down the whole system. diff --git a/src/eval/c4_14.scm b/src/eval/c4_14.scm new file mode 100644 index 0000000..efc6708 --- /dev/null +++ b/src/eval/c4_14.scm @@ -0,0 +1,19 @@ +; assume map as: (map proc list-of-args) +; if map is made as builtin, when evaluating map, we +; have the primitive map, but when we evaluate the primitive +; map, we are actuallly interpret it in the interpretor environment, +; and in this environment, proc is not defined. +; +; Therefore, builtin is not allowed to take procedure as arguments. +; +; Note, when we eval map, we should make sure list-of-args is really +; a list for the interpretor. Below is a demo +; +(load "eval.scm") +(define (simple-test) + (seck-eval '(define (foo x) + x) + global-env) + (display (seck-eval '(map foo '(1 2 3)) ; make sure (1 2 3) is quoted + global-env)) + ) diff --git a/src/eval/c4_15.scm b/src/eval/c4_15.scm new file mode 100644 index 0000000..698188c --- /dev/null +++ b/src/eval/c4_15.scm @@ -0,0 +1 @@ +; http://blog.csdn.net/zzljlu/article/details/7625514 diff --git a/src/eval/c4_16.scm b/src/eval/c4_16.scm new file mode 100644 index 0000000..10e846d --- /dev/null +++ b/src/eval/c4_16.scm @@ -0,0 +1,10 @@ +; a) in eval.scm +; b) in eval.scm +; c) if put in make-procedure, than scan-out-defines +; is evaluated when procedure defined. But when put +; in procedure-body, scan-out-defines is evaluated when +; procedure evaluated. It's just a matter of whether +; we want the internal definition to be lazy. +; Note when implement scan-out-defines, to pass +; a (quote symbol) to the evaluator, you have to +; pass (quote (quote symbol)), see my explanation in eval.scm diff --git a/src/eval/c4_17.scm b/src/eval/c4_17.scm new file mode 100644 index 0000000..f5ef948 --- /dev/null +++ b/src/eval/c4_17.scm @@ -0,0 +1,6 @@ +; Another wtf question. +; An extra frame is created since let is evaluated to lambda. +; This question seems forgets an important assumption, that is, +; the internal defintion may be interwined with other expressions. +; In this case, what you need to do is just to reorder the internal +; definitions, which will not cause extra frame construction. diff --git a/src/eval/c4_18.scm b/src/eval/c4_18.scm new file mode 100644 index 0000000..1c75435 --- /dev/null +++ b/src/eval/c4_18.scm @@ -0,0 +1,60 @@ +; There is a series problem of the scanned out method shown in the exercise. +(lambda () + (let ((u '*unassigned*) + (v '*unassigned*)) + ; Here, when some-expression is evaluated, if they contain circular dependance + ; like solve has, u/v may be evaluated, in which case an error reported. + (let ((a 'some-expression) + (b 'some-expression)) + (set! u a) + (set! v b)) + 'expressions)) + + +; here shows the case + +(define (solve f y0 dt) + (define y (integral (delay dy) y0 dt)) + (define dy (stream-map f y)) + y) + +; -> + +(define solve + (lambda (f y0 dt) + (let ((y '*assigned*) + (dy '*assigned*)) + (let ((a (integral (delay dy) y0 dt)) + (b (stream-map f y))) + (set! y a) + (set! dy b) + y)))) + +; -> +(define solve + (lambda (f y0 dt) + ((lambda (y dy) + (let ((a (integral (delay dy) y0 dt)) + (b (stream-map f y))) + (set! y a) + (set! dy b) + y)) + '*assigned* + '*assigned*))) +; -> +(define solve + (lambda (f y0 dt) + ((lambda (y dy) + ((lambda (a b) + (set! y a) + (set! dy b) + y) + ; here, procedure args are evaluated, and error reported. + (integral (delay dy) y0 dt) + (stream-map f y)) + '*assigned* + '*assigned*)) + )) + + +; apparently, there is no such problem for the one in the text diff --git a/src/eval/c4_19.scm b/src/eval/c4_19.scm new file mode 100644 index 0000000..c69c391 --- /dev/null +++ b/src/eval/c4_19.scm @@ -0,0 +1,19 @@ +(load "eval.scm") + +; to enable scan-out-defines, try to modify it in eval.scm + +(define (demo) + (seck-eval '(let ((a 1)) + (define (f x) + (define b (+ a x)) + (define a 5) + (+ a b)) + (f 10)) + global-env) + ) +(let ((a 1)) + (define (f x) + (define b (+ a x)) + (define a 5) + (+ a b)) + (f 10)) diff --git a/src/eval/c4_2.scm b/src/eval/c4_2.scm new file mode 100644 index 0000000..d950e75 --- /dev/null +++ b/src/eval/c4_2.scm @@ -0,0 +1,4 @@ +; a) of course not. The precedence of match rule for application? is small +; compared to assignment. So every pair will be matched by application +; +; b) wtf. This question is really weird. diff --git a/src/eval/c4_20.scm b/src/eval/c4_20.scm new file mode 100644 index 0000000..d718902 --- /dev/null +++ b/src/eval/c4_20.scm @@ -0,0 +1,57 @@ +; a) in eval.scm +; b) let's do some evaluation manually + +; for letrec + +(letrec ((even? + (lambda (n) + (if (= n 0) + true + (odd? (- n 1))))) + (odd? + (lambda (n) + (if (= n 0) + false + (even? (- n 1)))))) + ) + +; -> + +(let ((even? '*assigned*) + (odd? '*assigned*)) + (set! even? ...) + (set! odd? ...) + ) +; -> +((lambda (even? odd?) + (set! even? ...) + (set! odd? ...)) + '*assigned* + '*assigned* + ) + +; but for let + +(let ((even? ...) + (odd? ...)) + (even? x)) + +; -> + +((lambda (even? odd?) + (even? x)) + ; here, when evaluating the following lambda procedure, + ; odd?, even? will be looked up in the lambda procedure environment(lexical scoping), + ; therefore, they will not be found. + (lambda (n) + (if (= n 0) + true + (odd? (- n 1)))) + (lambda (n) + (if (= n 0) + false + (even? (- n 1)))) +) + +; so, the internal diff between letrec and let is, letrec keeps the environment +; for argument in the let body. diff --git a/src/eval/c4_21.scm b/src/eval/c4_21.scm new file mode 100644 index 0000000..faa6589 --- /dev/null +++ b/src/eval/c4_21.scm @@ -0,0 +1,44 @@ +(load "eval.scm") + +(define fact-exp '((lambda (n) + ((lambda (fact) + (fact fact n)) + (lambda (ft k) + (if (= k 1) + 1 + (* k (ft ft (- k 1))))))) + 10)) + +; a) +; (println (seck-eval fact-exp global-env)) + + +(define fib-exp '((lambda (n) + ((lambda (fib) + (fib fib 0 1 0) + ) + (lambda (fib a b k) + (if (= k n) + b + (fib fib b (+ a b) (+ 1 k)))) + )) + 10)) + +; (println (seck-eval fib-exp global-env)) + +; b) + +(define f-exp '(define (f x) + ((lambda (even? odd?) + (even? even? odd? x)) + (lambda (ev? od? n) + (if (= n 0) + true + (od? ev? od? (- n 1)))) + (lambda (ev? od? n) + (if (= n 0) + false + (ev? ev? od? (- n 1))))))) + +(seck-eval f-exp global-env) +(println (seck-eval '(f 4) global-env)) diff --git a/src/eval/c4_22.scm b/src/eval/c4_22.scm new file mode 100644 index 0000000..9b3a329 --- /dev/null +++ b/src/eval/c4_22.scm @@ -0,0 +1 @@ +; in eval1.scm diff --git a/src/eval/c4_23.scm b/src/eval/c4_23.scm new file mode 100644 index 0000000..36b4568 --- /dev/null +++ b/src/eval/c4_23.scm @@ -0,0 +1,5 @@ +; I've implemented one analyze-sequence in eval1.scm, +; the text has a version of analyze-sequence(analyze-sequence-text in eval1.scm) +; and analyze-sequence-alyssa has a version of analyze-sequence(analyze-sequence-alyssa). +; Of those, analyze-sequence-text and my version are better. Since they try to expand all the sequence +; during the analysis stage(try to add a print func in loop). diff --git a/src/eval/c4_24.scm b/src/eval/c4_24.scm new file mode 100644 index 0000000..fcdb36e --- /dev/null +++ b/src/eval/c4_24.scm @@ -0,0 +1 @@ +; ... diff --git a/src/eval/c4_3.scm b/src/eval/c4_3.scm new file mode 100644 index 0000000..fab1485 --- /dev/null +++ b/src/eval/c4_3.scm @@ -0,0 +1,18 @@ +; just like this style +(define (init-operation-table) + (put 'quote text-of-quotation) + (put 'set! eval-assignment) + (put 'if eval-if) + ... + ) + +(define (seck-eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + (else + (let ((op (get (car exp)))) + (cond (op (op exp env)) + ((application? exp) + ...) + (else + (error ...))))))) diff --git a/src/eval/c4_4.scm b/src/eval/c4_4.scm new file mode 100644 index 0000000..c791e98 --- /dev/null +++ b/src/eval/c4_4.scm @@ -0,0 +1,13 @@ + +; and as special forms +; the same goes for or +(define (eval-and exp env) + (define (iter exps) + (cond ((null? exp) #t) + ((not (seck-eval (car exp) env)) #f) + (else + (iter (cdr exp) env)))) + (iter (cdr exp))) + + +; see and/or as derived expressions in eval.scm diff --git a/src/eval/c4_5.scm b/src/eval/c4_5.scm new file mode 100644 index 0000000..eee52bf --- /dev/null +++ b/src/eval/c4_5.scm @@ -0,0 +1 @@ +; in eval.scm diff --git a/src/eval/c4_6.scm b/src/eval/c4_6.scm new file mode 100644 index 0000000..eee52bf --- /dev/null +++ b/src/eval/c4_6.scm @@ -0,0 +1 @@ +; in eval.scm diff --git a/src/eval/c4_7.scm b/src/eval/c4_7.scm new file mode 100644 index 0000000..bc26535 --- /dev/null +++ b/src/eval/c4_7.scm @@ -0,0 +1,3 @@ +; in eval.scm +; +; no need to expand let* in terms of non-derived expressions diff --git a/src/eval/c4_8.scm b/src/eval/c4_8.scm new file mode 100644 index 0000000..eee52bf --- /dev/null +++ b/src/eval/c4_8.scm @@ -0,0 +1 @@ +; in eval.scm diff --git a/src/eval/c4_9_unfinished.scm b/src/eval/c4_9_unfinished.scm new file mode 100644 index 0000000..3ec2571 --- /dev/null +++ b/src/eval/c4_9_unfinished.scm @@ -0,0 +1,2 @@ +; in eval.scm +; diff --git a/src/eval/demo.scm b/src/eval/demo.scm new file mode 100644 index 0000000..25e364b --- /dev/null +++ b/src/eval/demo.scm @@ -0,0 +1,4 @@ +(let ((b *unassigned*) (a *unassigned*)) + (set! b (+ a x)) + (set! a 5) + (+ a b c)) diff --git a/src/eval/eval-base.scm b/src/eval/eval-base.scm new file mode 100644 index 0000000..b4d28bf --- /dev/null +++ b/src/eval/eval-base.scm @@ -0,0 +1,456 @@ +(define (assert-eq a b eqproc) + (if (not (eqproc a b)) + (error 'assert-eq a " and " b " is not equal") + #t)) + +(define (typeof v) + (cond ((boolean? v) + 'boolean) + ((number? v) + 'number) + ((string? v) + 'string) + ((symbol? v) + 'symbol) + ((null? v) + 'null) + ((pair? v) + 'pair) + (else + 'unknown))) + +; @(tools) +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + #f)) + +(define (unassigned? value) + (eq? value '*unassigned*)) + +; @(environment) + +(define (make-env base) + (let ((local-env (list (make-dict) base))) + (define (cur-env-var-dict) (car local-env)) + (define (base-env) (cadr local-env)) + + (define (lookup var) + (let ((ret (dict-lookup (cur-env-var-dict) var))) + (let ((found (car ret)) + (value (cadr ret))) + (cond ((and found + (not (unassigned? value))) + value) + (found + (error 'lookup "variabled looked up is unassigned")) + ((empty-env? (base-env)) + (error 'lookup "variable not defined" var)) + (else + (((base-env) 'lookup) var)))))) + + (define (insert! var value) + (dict-insert! (cur-env-var-dict) var value)) + + (define (set! var value) + (if (dict-set! (cur-env-var-dict) var value) + value + (error 'set! "setting an unbound value for " var))) + + (define (dispatch action) + (cond ((eq? action 'lookup) lookup) + ((eq? action 'insert) insert!) + (else + (error 'make-env-dispatch "unknown action" action)))) + dispatch)) + +(define (lookup-variable-value var env) + ((env 'lookup) var)) + +(define (extend-environment vars values base-env) + (let ((new-env (make-env base-env))) + (define (iter vars values) + (cond ((and (null? vars) + (null? values)) + new-env) + ((or (null? vars) + (null? values)) + (error 'extend-environment "procedure arguments not match")) + (else + ((new-env 'insert) (car vars) (car values)) + (iter (cdr vars) (cdr values))))) + (iter vars values))) + +(define (define-variable! var value env) + ((env 'insert) var value)) + +(define (set-variable-value! var value env) + ((env 'insert) var value)) + +(define the-empty-env '()) +(define (empty-env? env) + (null? env)) + +; @(expression) + +(define (first-exp exps) + (car exps)) + +(define (rest-exps exps) + (cdr exps)) + +(define (last-exp? exps) + (and (pair? exps) + (null? (cdr exps)))) + +(define (begin? exp) + (tagged-list? exp 'begin)) + +(define (begin-actions exp) + (cdr exp)) + +; implicit begin +(define (sequence->exp seq) + (cond ((null? seq) seq) + ((last-exp? seq) (first-exp seq)) + (else + (make-begin seq)))) + +(define (sequence->exp-2 predicate actions) + (if (eq? (car actions) '=>) + ; transforms to '(cadr (= a 3)) if predicate is (= a 3) + ; Note predicate will evaluated twice in the conditions! + (list (cadr actions) + predicate) + (sequence->exp actions))) + +(define (make-begin seq) + (cons 'begin seq)) + +; @(self-evaluating) +(define (self-evaluating? exp) + (cond ((number? exp) #t) + ((string? exp) #t) + (else #f))) + +(define (variable? exp) + (symbol? exp)) + + +; @(quote) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +; @(primitives) + +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cons cons) + (list 'null? null?) + (list '+ +) + (list '- -) + (list '* *) + (list '/ /) + (list '> >) + (list '< <) + (list '= =) + (list 'print print) + (list 'map map) + )) + +(define (primitive-procedure-names) + (map car + primitive-procedures)) + +(define (primitive-procedure-objects) + (map (lambda (proc) (list 'primitive (cadr proc))) + primitive-procedures)) + +(define (primitive-proc-impl proc) + (cadr proc)) + +(define primitive-vars + (list (list 'true #t) + (list 'false #f) + )) + +(define (primitive-var-names) + (map car + primitive-vars)) + +(define (primitive-var-values) + (map cadr + primitive-vars)) + +(define (primitive-names) + (append (primitive-procedure-names) + (primitive-var-names))) + +(define (primitive-values) + (append (primitive-procedure-objects) + (primitive-var-values))) + +(define (primitive-procedure? proc) + (tagged-list? proc 'primitive)) + +(define (apply-primitive-procedure proc args) + (apply (primitive-proc-impl proc) args)) + +; @(procedures) + +(define (compound-procedure? proc) + (tagged-list? proc 'procedure)) + +(define (make-procedure params body-seq env) + (list 'procedure + params + body-seq + env)) + +(define (procedure-parameters proc) + (cadr proc)) + +(define (procedure-body proc) + (caddr proc)) + +(define (procedure-env proc) + (cadddr proc)) + +; @(assignment) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-var exp) + (cadr exp)) + +(define (assignment-value exp) + (caddr exp)) + + +; @(defintion) + +(define (make-definition name value) + (list 'define name value)) +(define (definition? exp) + (tagged-list? exp 'define)) + +(define (definition-var exp) + (if (symbol? (cadr exp)) + (cadr exp) + (caadr exp))) + +(define (definition-value exp) + (if (symbol? (cadr exp)) + (caddr exp) + (make-lambda (cdadr exp) + (cddr exp)))) + + +; @(if) + +(define (make-if predicate consequent . args) + (if (null? args) + (list 'if predicate consequent 'false) + (list 'if predicate consequent (car args)))) + +(define (if? exp) + (tagged-list? exp 'if)) + +(define (if-predicate exp) + (cadr exp)) + +(define (if-consequent exp) + (caddr exp)) + +(define (if-alternative exp) + (if (not (null? (cdddr exp))) + (cadddr exp) + 'false)) + + + +; @(cond) +(define (cond? exp) + (tagged-list? exp 'cond)) + +(define (cond-firstmatch matches) + (car matches)) +(define (cond-restmatches matches) + (cdr matches)) +(define (cond-lastmatch matches) + (null? (cdr matches))) +(define (cond-elsematch? match) + (eq? (car match) 'else)) + +(define (cond-match-predicate match) + (car match)) + +(define (cond-match-actions match) + (cdr match)) + +(define (cond->if exp) + (define (expand matches) + (if (null? matches) + 'false + (let ((first (cond-firstmatch matches)) + (rest (cond-restmatches matches))) + (cond ((cond-elsematch? first) ;else + (if (null? rest) + (make-if 'true (sequence->exp (cond-match-actions first))) + (error 'cond "else is not last match"))) + (else ; the other conditions + (make-if (cond-match-predicate first) + (sequence->exp-2 (cond-match-predicate first) + (cond-match-actions first)) + (expand rest))))))) + (expand (cdr exp))) + +; @(and/or) +(define (and? exp) + (tagged-list? exp 'and)) + +(define (or? exp) + (tagged-list? exp 'or)) + +(define (and->if exp) + (define (expand exps) + (if (null? exps) + (make-if 'true 'true) + (make-if (car exps) + (expand (cdr exps)) + 'true))) + (expand (cdr exp))) + +(define (or->if exp) + (define (expand exps) + (if (null? exps) + (make-if 'true 'false) + (make-if (car exps) + 'true + (expand (cdr exps))))) + (expand (cdr exp))) + +; @(lambda) + +(define (lambda? exp) + (tagged-list? exp 'lambda)) + +(define (make-lambda params body-seq) + (cons 'lambda (cons params body-seq))) + +(define (lambda-params exp) + (cadr exp)) + +(define (lambda-body exp) + (cddr exp)) + +; @(let) +(define (let? exp) + (tagged-list? exp 'let)) + +(define (let-bindings exp) + (if (namedlet? exp) + (caddr exp) + (cadr exp) + )) + +(define (let-body exp) + (if (namedlet? exp) + (cdddr exp) + (cddr exp) + )) +(define (let-vars exp) (map car (let-bindings exp))) +; if you define let-values here, there will be +(define (let-vals exp) (map cadr (let-bindings exp))) +(define (namedlet? exp) (symbol? (cadr exp))) +(define (let->name exp) (cadr exp)) + +(define (let->combination exp) + (if (namedlet? exp) + (cons (make-lambda '() + (list (make-definition (let->name exp) + (make-lambda (let-vars exp) + (let-body exp))) + (cons (let->name exp) + (let-vals exp)) + )) + '()) + (let->lambda (let-vars exp) + (let-vals exp) + (let-body exp)))) + +(define (let->lambda vars values body) + (cons (make-lambda vars body) + values)) + +(define (make-let var-bindings body) + (cons 'let + (cons var-bindings + body))) + +(define (letstar? exp) + (tagged-list? exp 'let*)) + +(define (let*->nested-let exp) + (define (wrap-let-body vars values) + (cond ((and (null? vars) + (null? values)) + (make-let '() (let-body exp))) + ((or (null? vars) + (null? values)) + (error 'wrap-let-body "let vars-values length not match")) + (else + (make-let (list (list (car vars) + (car values))) + (list (wrap-let-body (cdr vars) + (cdr values))))) + )) + (wrap-let-body (let-vars exp) + (let-vals exp) ; todo + )) + + +(define (letrec? exp) + (tagged-list? exp 'letrec)) +(define (letrec->let exp) + (make-let + (map (lambda (var) + (list var ''*assigned*)) + (let-vars exp)) + (append (map (lambda (var value) + (list 'set! var value)) + (let-vars exp) + (let-vals exp)) + (let-body exp)))) + +; @(for) + +(define (for? exp) + (tagged-list? exp 'for)) +(define (for-init exp) (cadr exp)) +(define (for-can-continue exp) (caddr exp)) +(define (for-step exp) (cadddr exp)) +(define (for-body exp) (cddddr exp)) + + + +; @(application) +(define application? pair?) +(define (operator exp) (car exp)) +(define (operand exp) (cdr exp)) +(define (first-operand exps) (car exps)) +(define (rest-operands exps) (cdr exps)) + +; @(global env) +(define (setup-environment) + (extend-environment (primitive-names) + (primitive-values) + the-empty-env)) + +(define global-env (setup-environment)) diff --git a/src/eval/eval.scm b/src/eval/eval.scm new file mode 100644 index 0000000..a0a55d3 --- /dev/null +++ b/src/eval/eval.scm @@ -0,0 +1,213 @@ +(load "./utils/dict.scm") +(load "./utils/functional.scm") +(load "./utils/guile.scm") +(load "eval-base.scm") + +(define (seck-eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + ((quoted? exp) (text-of-quotation exp)) + ((assignment? exp) (eval-assignment exp env)) + ((definition? exp) (eval-definition exp env)) + ((if? exp) (eval-if exp env)) + ((lambda? exp) ; evaluated when define procedure + (make-procedure (lambda-params exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence (begin-actions exp) env)) + ((cond? exp) (seck-eval (cond->if exp) env)) + ((and? exp) (seck-eval (and->if exp) env)) + ((or? exp) (seck-eval (or->if exp) env)) + ((let? exp) (seck-eval (let->combination exp) env)) + ((letstar? exp) (seck-eval (let*->nested-let exp) env)) + ((letrec? exp) (seck-eval (letrec->let exp) env)) + ((for? exp) (seck-eval (for->let exp) env)) + ((application? exp) + ; evaluated when call procedure + (seck-apply (seck-eval (operator exp) env) + (list-of-values (operand exp) env))) + (else + (error 'seck-eval "eval failed to recognize expression" exp)))) + +; redefines make-procedure +(define (make-procedure params body-seq env) + (list 'procedure + params + (scan-out-defines body-seq #f) + env)) + +; fetch a list of values, eval them and return results as list +(define (list-of-values exps env) + (if (null? exps) + '() + (cons (seck-eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) +(define (seck-apply procedure arguments) + (cond ((primitive-procedure? procedure) + (apply-primitive-procedure procedure arguments)) + ((compound-procedure? procedure) + (eval-sequence + (procedure-body procedure) + (extend-environment + (procedure-parameters procedure) + arguments + ; Here, we eval the expression in + ; a new env which extends procedure env(the + ; env in which procedure is defined). This + ; ensures lexical scoping. + ; If we evaluate the procedure bodyin + ; the env that seck-apply is called, then + ; it will be dynamic scoping. + (procedure-env procedure)))) + (else + (error + 'seck-apply + "Unknown procedure type" procedure)))) + +(define (eval-if exp env) + (if (seck-eval (if-predicate exp) env) + (seck-eval (if-consequent exp) env) + (seck-eval (if-alternative exp) env))) +(define (eval-definition exp env) + (define-variable! (definition-var exp) + (seck-eval (definition-value exp) env) + env)) +(define (eval-assignment exp env) + (set-variable-value! (assignment-var exp) + (seck-eval (assignment-value exp) env) + env)) + +(define (eval-sequence exps env) + (cond ((null? exps) + (error 'eval-sequence "no expression in code in block")) + ((last-exp? exps) + (seck-eval (first-exp exps) env)) + (else + (seck-eval (first-exp exps) env) + (eval-sequence (rest-exps exps) env)) + )) + +; proc-body is a sequence of expressions to be evaluated +(define (scan-out-defines proc-body do-scan-out) + (let ((definitions (filter definition? proc-body)) + (non-definitions (filter (compose not definition?) + proc-body))) + (if (and do-scan-out + (not (null? definitions))) + (list (make-let (map (lambda (exp) + (list (definition-var exp) + ;; Here, we use '', since + ;; we want to pass a (quote symbol) to the evaluator, + ;; but not a symbol to the evaluator. The outer quote + ;; will be used to protect (quote symbol) in + ;; the naive scheme evaluator. + ''*unassigned*)) + definitions) + (append (map (lambda (exp) + (list 'set! + (definition-var exp) + (definition-value exp))) + definitions) + non-definitions))) + proc-body))) +(define (init-test-env) + (let ((new-env (make-env global-env))) + (seck-eval '(define a 3) new-env) + (seck-eval '(set! a 4) new-env) + new-env)) + +(define test-let-exp '(let ((x 1) + (y 2)) + (+ x y))) +(define test-named-let-exp '(let fib-iter ((a 1) + (b 0) + (count 10)) + (if (= count 0) + b + (fib-iter (+ a b) a (- count 1))))) + +(define (test-eval) + (let ((new-env (init-test-env))) + (assert (= (seck-eval '(+ 1 2) global-env) 3)) + (assert (equal? (seck-eval '(cons 1 2) global-env) (cons 1 2))) + (assert (= (seck-eval 'a new-env) 4)) + (assert (seck-eval '(and (= a 4) (< a 5) (> a 2)) new-env)) + (assert (seck-eval '(or (= a 5) (> a 5) (> a 2)) new-env)) + (seck-eval '(define (op a b) + (if (> a b) + (- a b) + (- b a))) + new-env) + (seck-eval '(define (op2 a b) + (cond ((> a b) + (- a b)) + ((> b a) + (- b a)) + (else + (+ a b)))) + new-env) + (assert (equal? (seck-eval '(op 1 2) new-env) + 1)) + (assert (equal? (seck-eval '(op2 2 2) new-env) + 4)) + (assert (equal? (seck-eval '(let ((a 3) + (b 4)) + (cons a b)) + new-env) + (cons 3 4))) + (assert (equal? (seck-eval '(let* ((x 1) + (y (+ x a)) + (z (+ x y)) + ) + (+ x y z)) + new-env) + 12)) + (assert (equal? (seck-eval '(let fib-iter ((a 1) + (b 0) + (count 10)) + (if (= count 0) + b + (fib-iter (+ a b) + a + (- count 1)))) + new-env) + 55)) + ) + (seck-eval '((lambda () + (define (foo a) a) + (foo 3) + ) + ) + global-env) + 'pass) + + +(define letrec-exp '(letrec ((even? + (lambda (n) + (if (= n 0) + true + (odd? (- n 1))))) + (odd? + (lambda (n) + (if (= n 0) + false + (even? (- n 1)))))) + (even? x))) + +(define (test-letrec) + (seck-eval '(define (f x) + (letrec ((even? + (lambda (n) + (if (= n 0) + true + (odd? (- n 1))))) + (odd? + (lambda (n) + (if (= n 0) + false + (even? (- n 1)))))) + (even? x))) + global-env) + (seck-eval '(f 3) global-env) + ) diff --git a/src/eval/eval1.scm b/src/eval/eval1.scm new file mode 100644 index 0000000..aa72314 --- /dev/null +++ b/src/eval/eval1.scm @@ -0,0 +1,164 @@ +; a more efficient eval +; + +;why analyze can improve performance + ;for eval without analyze + ;(define (foo x) x) + ;everytime, when you want to call foo, (foo x), it will first lookup variable foo, + ;which is binder to a lambda, then you will make a procedure from the lambda, and then evaluate the procedure again. + ;for eval with analyze + ;(define (foo x) x) + ;everytime, when you want to call foo, (foo x), it will also lookup variable foo, which returns an analyzed procedure: proc, + ;and by call proc: (proc env), it directly returns the procedure(without remake it), which improves the performance. + +(load "eval-base.scm") +(define (seck-eval exp env) + ((analyze exp) env)) + +(define (analyze exp) + (cond ((self-evaluating? exp) + (analyze-self-evaluating exp)) + ((quoted? exp) (analyze-quoted exp)) + ((variable? exp) (analyze-variable exp)) + ((assignment? exp) (analyze-assignment exp)) + ((definition? exp) (analyze-definition exp)) + ((if? exp) (analyze-if exp)) + ((lambda? exp) (analyze-lambda exp)) + ((begin? exp) (analyze-sequence (begin-actions exp))) + ((cond? exp) (analyze (cond->if exp))) + ((let? exp) (analyze (let->combination exp))) + ((application? exp) (analyze-application exp)) + (else + (error 'analyze "unknown expression type" exp)))) + +(define (analyze-self-evaluating exp) + (lambda (env) exp)) + +(define (analyze-quoted exp) + (let ((qval (text-of-quotation exp))) + (lambda (env) qval))) + +(define (analyze-quoted exp) + (let ((text (quoted-text exp))) + (lambda (env) + text))) + +(define (analyze-variable exp) + (lambda (env) + (lookup-variable-value exp env))) + +(define (analyze-definition exp) + (let ((var (definition-var exp)) + (vproc (analyze (definition-value exp)))) + (lambda (env) + (define-variable! var (vproc env) env) + 'ok))) + +(define (analyze-if exp) + (let ((pproc (analyze (if-predicate exp))) + (cproc (analyze (if-consequent exp))) + (aproc (analyze (if-alternative exp)))) + (lambda (env) + (if (pproc env) + (cproc env) + (aproc env))))) + +(define (analyze-lambda exp) + (let ((params (lambda-params exp)) + (body-proc (analyze-sequence (lambda-body exp)))) + (lambda (env) (make-procedure params body-proc env)))) + +(define (analyze-sequence exp) + (define (combine proc1 proc2) + (lambda (env) + (proc1 env) + (proc2 env))) + (define (combine-seq-proc seq-proc) + ; (println "combine-seq-proc") + (if (null? (cdr seq-proc)) + (car seq-proc) + (combine (car seq-proc) + (combine-seq-proc (cdr seq-proc))))) + (let ((seq-proc (map analyze exp))) + (if (null? seq-proc) + (error 'analyze-sequence "no expression in code block") + (combine-seq-proc seq-proc)))) + +(define (analyze-sequence-text exps) + (define (sequentially proc1 proc2) + (lambda (env) (proc1 env) (proc2 env))) + (define (loop first-proc rest-procs) + ; (println "loop") + (if (null? rest-procs) + first-proc + (loop (sequentially first-proc (car rest-procs)) + (cdr rest-procs)))) + (let ((procs (map analyze exps))) + (if (null? procs) + (error "Empty sequence -- ANALYZE")) + (loop (car procs) (cdr procs)))) + +(define (analyze-sequence-alyssa exps) + (define (execute-sequence procs env) + (cond ((null? (cdr procs)) + ((car procs) env)) + (else ((car procs) env) + (execute-sequence (cdr procs) env)))) + (let ((procs (map analyze exps))) + (if (null? procs) + (error "Empty sequence -- ANALYZE")) + (lambda (env) (execute-sequence procs env)))) + +(define (analyze-application exp) + (let ((fproc (analyze (operator exp))) + (aprocs (map analyze (operand exp)))) + (lambda (env) + (execute-application (fproc env) + (map (lambda (aproc) + (aproc env)) + aprocs))))) + +(define (execute-application proc args) + (cond ((primitive-procedure? proc) + (apply-primitive-procedure proc args)) + ((compound-procedure? proc) + ((procedure-body proc) + (extend-environment (procedure-parameters proc) + args + (procedure-env proc)))) + (else + (error + 'execute-applicaiton + "unknown procedure type" + proc)))) + +(define (analyze-assignment exp) + (let ((var (assignment-var exp)) + (vproc (analyze (assignment-value exp)))) + (lambda (env) + (set-variable-value! var (vproc env) env)))) + +(define (test-analyze) + (seck-eval '(define (fact n) + (if (= n 1) + 1 + (* (fact (- n 1)) + n))) + global-env) + (println (seck-eval '(fact 3) global-env)) + ) + +(define (test-let) + (seck-eval '(let ((a 1) + (b 2)) + (set! a (* a b)) + (+ a b)) + global-env)) + +(define seq1 '((set! a b) + (cons a b) + (cons a b) + (cons a b) + (cons a b))) + +(define seq2 '((cons a b))) diff --git a/src/eval/run-test.sh b/src/eval/run-test.sh new file mode 100755 index 0000000..c99cd75 --- /dev/null +++ b/src/eval/run-test.sh @@ -0,0 +1,9 @@ +filename=$1 +filetype=${1##*.} +if [ $filetype != "scm" ] +then + filename=$filename.scm +fi +#petite --libdirs lib --script $filename + +csi -q -I lib -s $filename diff --git a/src/eval/scoping.scm b/src/eval/scoping.scm new file mode 100644 index 0000000..9734c47 --- /dev/null +++ b/src/eval/scoping.scm @@ -0,0 +1,18 @@ +(load "eval.scm") + +(define (test-scoping) + ; if it's lexical scoping, it will return 7 + ; but if it's dynamic scoping, it will return 8 + (let ((new-env (make-env global-env))) + (seck-eval '(define a 4) + new-env) + (seck-eval '(define (foo) + (+ a 3)) + new-env) + (seck-eval '(define (bar) + (define a 5) + (foo)) + new-env) + (println (seck-eval '(bar) + new-env)) + )) diff --git a/src/eval/utils/dict.scm b/src/eval/utils/dict.scm new file mode 100644 index 0000000..561ad45 --- /dev/null +++ b/src/eval/utils/dict.scm @@ -0,0 +1,90 @@ +(define (make-dict) + (let ((local-table (list '*table*))) + (define (record-key record) (car record)) + (define (record-value record) (cdr record)) + (define (set-record-value! record value) + (set-cdr! record value)) + (define (make-record k v) (cons k v)) + (define (empty? table) + (null? (cdr table))) + (define (lookup-record k) + (define (iter table-records) + (cond ((null? table-records) + ; not found + (list #f '())) + ((eq? k (record-key (car table-records))) + (list #t (car table-records))) + (else + (iter (cdr table-records))))) + (iter (cdr local-table))) + + ; return (list found record) + (define (lookup k) + (let* ((ret (lookup-record k)) + (found (car ret)) + (record (cadr ret))) + (if found + (list #t (record-value record)) + (list #f '())) + )) + + ; return true when insert a new record, + ; return false when a record is modified + (define (insert! key value) + (let* ((ret (lookup-record key)) + (found (car ret)) + (record (cadr ret))) + (if found + (set-record-value! record value) + (set-cdr! local-table (cons (make-record key value) + (cdr local-table)))) + (not found))) + + ; return true when the record is found and set + ; return false when the record is not found. + ; difference between set! and insert! is that insert! will + ; insert a new record when the record doesn't exist. + (define (set! key value) + (let* ((ret (lookup-record key)) + (found (car ret)) + (record (cadr ret))) + (if found + (set-record-value! record value) + #f))) + + (define (keys) + (map car (cdr local-table))) + + ; randomly return a key + (define (akey) + (record-key (car (cdr local-table)))) + + (define (dispatch action) + (cond ((eq? action 'lookup) lookup) + ((eq? action 'insert) insert!) + ((eq? action 'set) set!) + ((eq? action 'keys) keys) + ((eq? action 'akey) akey) + (else (error 'dict-dispatch "UNKNOWN ACTION" action)))) + dispatch)) + +(define (dict-lookup d key) + ((d 'lookup) key)) + +(define (dict-insert! d key value) + ((d 'insert) key value)) + +(define (dict-set! d key value) + ((d 'set) key value)) + +(define (dict-keys d) + ((d 'keys))) + +(define (dict-display-keys d keys) + (if (not (null? keys)) + (begin + (display (car keys))(display "-")(display (dict-lookup d (car keys)))(newline) + (dict-display-keys d (cdr keys))))) + +(define (dict-display d) + (dict-display-keys d (dict-keys d))) diff --git a/src/eval/utils/functional.scm b/src/eval/utils/functional.scm new file mode 100644 index 0000000..a8e7fde --- /dev/null +++ b/src/eval/utils/functional.scm @@ -0,0 +1 @@ +(define (same x) x) diff --git a/src/eval/utils/guile.scm b/src/eval/utils/guile.scm new file mode 100644 index 0000000..b3a517e --- /dev/null +++ b/src/eval/utils/guile.scm @@ -0,0 +1,18 @@ +(define (assert exp) + (if (not exp) + (error 'assert "expression is not true") + exp) + ) + +(define (print . args) + (define (iter args) + (if (not (null? args)) + (begin + (display (car args))(display " ") + (iter (cdr args)) + ))) + (iter args)) + +(define (println . args) + (apply print args)(newline) + ) diff --git a/src/functional-time.scm b/src/functional-time.scm new file mode 100644 index 0000000..868edfd --- /dev/null +++ b/src/functional-time.scm @@ -0,0 +1,18 @@ +(import (rnrs) + (stream) + (utils)) + +(define (make-simplified-withdraw balance) + (lambda (amount) + (set! balance (- balance amount)) + balance)) + +(define (stream-widthdraw balance amount-stream) + (define balance-stream + (cons-stream balance + (stream-minus balance-stream + amount-stream))) + balance-stream) + +(let ((bs (stream-widthdraw 1000 (list-stream 1 2 3 4)))) + (display (stream-ref bs 4))) diff --git a/src/how-implicit-stream-works.scm b/src/how-implicit-stream-works.scm new file mode 100644 index 0000000..a54f7c0 --- /dev/null +++ b/src/how-implicit-stream-works.scm @@ -0,0 +1,58 @@ +; take partial-sum as example + +(define (partial-sum s) + (define sum (cons-stream (stream-car s) + (stream-add (stream-cdr s) + sum))) + sum) + +(define ones (cons-stream 1 ones)) + +(partial-sum ones) -> + +(partial-sum (cons-stream 1 ones)) -> + +(cons-stream (stream-car (cons-stream 1 ones)) + (stream-add (stream-cdr (cons-stream 1 ones) + sum)) -> + +; intepret first args of stream-add +(cons-stream 1 + (stream-add (cons-stream 1 ones) + sum)) -> + +; interpret second args of stream-add +; use ... to replace the delayed part of sum +(cons-stream 1 + (stream-add (cons-stream 1 ones) + (cons-stream 1 ...))) -> + +(cons-stream 1 + (cons-stream (+ (stream-car (cons-stream 1 ones)) + (stream-car (cons-stream 1 ...))) + (stream-map + + (stream-cdr (cons-stream 1 ones)) + (stream-cdr (cons-stream 1 ...))))) -> + +(cons-stream 1 + (cons-stream 2 + (stream-map + + (cons-stream 1 ones) + (cons-stream 2 ...)))) -> + +(cons-stream 1 + (cons-stream 2 + (cons-stream (+ (stream-car (cons-stream 1 ones)) + (stream-car (cons-stream 2 ...))) + (stream-map + + (stream-cdr (cons-stream 1 ones)) + (stream-cdr (cons-stream 2 ...)))))) -> + +(cons-stream 1 + (cons-stream 2 + (cons-stream 3 + (stream-map + + (cons-stream 1 ones) + (cons-stream 3 ...))))) + +... diff --git a/src/infinite-stream.scm b/src/infinite-stream.scm new file mode 100644 index 0000000..bb259f4 --- /dev/null +++ b/src/infinite-stream.scm @@ -0,0 +1,33 @@ +(import (rnrs) + (stream) + (utils)) + +(define (fibgen a b) + (cons-stream a (fibgen b (+ a b)))) + +;(define fibs (fibgen 0 1)) + +(define (seive s) + (cons-stream + (stream-car s) + (seive (stream-filter + (lambda (v) + (not (divisible? v (stream-car s)))) + (stream-cdr s))))) + +(define primes (seive (integers-start-from 2))) + +(define ones + (cons-stream 1 ones)) + +(define integers + (cons-stream 1 (stream-add ones integers))) + +; think about how to get the equation of geometric progression!!! +(define fibs (cons-stream 0 + (cons-stream 1 + (stream-add (stream-cdr fibs) + fibs)))) + + +(define double (cons-stream 1 (stream-scale double 2))) diff --git a/src/lib/base.scm b/src/lib/r6rs/base.scm similarity index 100% rename from src/lib/base.scm rename to src/lib/r6rs/base.scm diff --git a/src/lib/concurrency.scm b/src/lib/r6rs/chez.scm similarity index 73% rename from src/lib/concurrency.scm rename to src/lib/r6rs/chez.scm index 3867ad4..93c1437 100644 --- a/src/lib/concurrency.scm +++ b/src/lib/r6rs/chez.scm @@ -1,12 +1,23 @@ (library - (concurrency) - (export parallel-execute + (chez) + (export sleepfor + parallel-execute make-semaphore semaphore-acquire - semaphore-release) - + semaphore-release + rand + random-in-range + random-init + random-update + ) (import (chezscheme)) + ; @(utils) + ; sleep for s seconds + (define (sleepfor s) + (sleep (make-time 'time-duration 0 s))) + + ; @(concurrency) (define (parallel-execute . args) (for-each fork-thread args)) @@ -75,4 +86,21 @@ ((eq? msg 'release) (clear! cell)))) self))) + + ; [low high) + (define (random-in-range low high) + (let ((range (- high low))) + (+ low (random range)))) + (define random-init (time-second (current-time))) + (define (random-update x) + (let ((a 40) + (b 2641) + (m 729)) + (modulo (+ (* a x) b) m))) + + (define rand + (let ((x random-init)) + (lambda () + (set! x (rand-update x)) + x))) ) diff --git a/src/lib/coercion.scm b/src/lib/r6rs/coercion.scm similarity index 100% rename from src/lib/coercion.scm rename to src/lib/r6rs/coercion.scm diff --git a/src/lib/complex-polar.scm b/src/lib/r6rs/complex-polar.scm similarity index 100% rename from src/lib/complex-polar.scm rename to src/lib/r6rs/complex-polar.scm diff --git a/src/lib/complex-rectangular.scm b/src/lib/r6rs/complex-rectangular.scm similarity index 100% rename from src/lib/complex-rectangular.scm rename to src/lib/r6rs/complex-rectangular.scm diff --git a/src/lib/complex.scm b/src/lib/r6rs/complex.scm similarity index 100% rename from src/lib/complex.scm rename to src/lib/r6rs/complex.scm diff --git a/src/lib/r6rs/concurrency.scm b/src/lib/r6rs/concurrency.scm new file mode 100644 index 0000000..e69de29 diff --git a/src/lib/constraint.scm b/src/lib/r6rs/constraint.scm similarity index 100% rename from src/lib/constraint.scm rename to src/lib/r6rs/constraint.scm diff --git a/src/lib/deriv.scm b/src/lib/r6rs/deriv.scm similarity index 100% rename from src/lib/deriv.scm rename to src/lib/r6rs/deriv.scm diff --git a/src/lib/dict.scm b/src/lib/r6rs/dict.scm similarity index 87% rename from src/lib/dict.scm rename to src/lib/r6rs/dict.scm index 3465484..de74bbf 100644 --- a/src/lib/dict.scm +++ b/src/lib/r6rs/dict.scm @@ -1,6 +1,8 @@ (library (dict) - (export make-dict) + (export make-dict + dict-lookup + dict-insert!) (import (rnrs) (rnrs mutable-pairs)) (define (make-dict) @@ -36,4 +38,10 @@ ((eq? action 'akey) akey) (else (error 'dict-dispatch "UNKNOWN ACTION" action)))) dispatch)) + + (define (dict-lookup d key) + ((d 'lookup) key)) + + (define (dict-insert! d key value) + ((d 'insert) key value)) ) diff --git a/src/lib/functional.scm b/src/lib/r6rs/functional.scm similarity index 100% rename from src/lib/functional.scm rename to src/lib/r6rs/functional.scm diff --git a/src/lib/generic-arithmetic.scm b/src/lib/r6rs/generic-arithmetic.scm similarity index 99% rename from src/lib/generic-arithmetic.scm rename to src/lib/r6rs/generic-arithmetic.scm index 82f4dbd..17775b7 100644 --- a/src/lib/generic-arithmetic.scm +++ b/src/lib/r6rs/generic-arithmetic.scm @@ -12,7 +12,8 @@ make-complex-from-mag-ang ) - (import (chezscheme) + (import (rnrs) + (rnrs mutable-pairs) (base) (complex) (functional) diff --git a/src/lib/init.scm b/src/lib/r6rs/init.scm similarity index 100% rename from src/lib/init.scm rename to src/lib/r6rs/init.scm diff --git a/src/lib/poly-terms.scm b/src/lib/r6rs/poly-terms.scm similarity index 100% rename from src/lib/poly-terms.scm rename to src/lib/r6rs/poly-terms.scm diff --git a/src/lib/prime.scm b/src/lib/r6rs/prime.scm similarity index 100% rename from src/lib/prime.scm rename to src/lib/r6rs/prime.scm diff --git a/src/lib/queue.scm b/src/lib/r6rs/queue.scm similarity index 96% rename from src/lib/queue.scm rename to src/lib/r6rs/queue.scm index 058890f..db7c4fe 100644 --- a/src/lib/queue.scm +++ b/src/lib/r6rs/queue.scm @@ -6,7 +6,8 @@ delete-queue! front-queue beautiful-display-queue) - (import (chezscheme)) + (import (rnrs) + (rnrs mutable-pairs)) (define (make-queue) (cons '() '())) (define (front-ptr q) (car q)) diff --git a/src/lib/r6rs/rand.scm b/src/lib/r6rs/rand.scm new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/src/lib/r6rs/rand.scm @@ -0,0 +1 @@ + diff --git a/src/lib/r6rs/series.scm b/src/lib/r6rs/series.scm new file mode 100644 index 0000000..ca1cfdd --- /dev/null +++ b/src/lib/r6rs/series.scm @@ -0,0 +1,75 @@ +(library + (series) + (export mul-series + add-series + integrate-series + exp-series + sine-series + cosine-series + invert-unit-series + div-series + tan-series + pi-series + euler-transform + accelerated-sequence) + + + (import (rnrs) + (stream) + (utils)) + + (define (integrate-series s) + (stream-div s + (integers-start-from 1))) + (define sine-series + (cons-stream 0 (integrate-series cosine-series))) + (define cosine-series + (cons-stream 1 (integrate-series (stream-negate sine-series)))) + (define exp-series + (cons-stream 1 (integrate-series exp-series))) + (define (mul-series s1 s2) + (cons-stream (* (stream-car s1) (stream-car s2)) + (stream-add (mul-series (stream-cdr s1) s2) + (stream-scale (stream-cdr s2) (stream-car s1))))) + (define add-series stream-add) + (define minus-series stream-minus) + (define (invert-unit-series s) + (define inverted-series + (cons-stream 1 + (stream-negate + (mul-series (stream-cdr s) + inverted-series)))) + inverted-series) + + (define (div-series s1 s2) + (let ((c2 (stream-car s2))) + (if (= c2 0) + (error div-series "series haszero constant term") + (mul-series (stream-scale s1 (/ 1 c2)) + (invert-unit-series (stream-scale s2 (/ 1 c2))))))) + + (define tan-series + (div-series sine-series cosine-series)) + + (define (euler-transform s) + (let ((s0 (stream-ref s 0)) + (s1 (stream-ref s 1)) + (s2 (stream-ref s 2))) + (cons-stream (- s2 (/ (square (- s2 s1)) + (+ s0 (* -2 s1) s2))) + (euler-transform (stream-cdr s))))) + + (define (make-tableau transform s) + (cons-stream s + (make-tableau transform + (transform s)))) + (define (accelerated-sequence transform s) + (stream-map stream-car + (make-tableau transform s))) + + (define (pi-summands n) + (cons-stream (/ 1.0 n) + (stream-map - (pi-summands (+ n 2))))) + (define pi-series (pi-summands 1)) + + ) diff --git a/src/lib/r6rs/stream.scm b/src/lib/r6rs/stream.scm new file mode 100644 index 0000000..ac2154d --- /dev/null +++ b/src/lib/r6rs/stream.scm @@ -0,0 +1,214 @@ +(library + (stream) + (export cons-stream + list-stream + stream-car + stream-cdr + stream-null? + the-empty-stream + stream-map + stream-filter + stream-enumerate-interval + stream-display + stream-ref + stream-add + stream-minus + stream-scale + integers-start-from + stream-mult + stream-div + partial-sum + integers + stream-display-n + stream-negate + one-zeros + ones + interleave + stream-append + integral + integral-delayed) + + (import (rnrs) + (rnrs r5rs) + (utils)) + + (define (memo-proc proc) + (let ((already-run #f) (result '())) + (lambda () + (if (not already-run) + (begin (set! result (proc)) + (set! already-run #t) + result) + result)))) + + ;(define (force delayed-object) + ;(delayed-object)) + + + (define-syntax cons-stream + (syntax-rules () + ((cons-stream a b) + (cons a (memo-proc (delay b)))))) + + ;(define-syntax delay + ;(syntax-rules () + ;((_ v) (lambda () v)))) + + ;(cons a (lambda () b))))) + + (define-syntax list-stream + (syntax-rules () + [(_) the-empty-stream] + [(_ a b ...) + (cons-stream a + (list-stream b ...))])) + + (define (stream-car stream) (car stream)) + + + (define (stream-cdr stream) (force (cdr stream))) + + (define the-empty-stream '()) + + (define (stream-null? s) + (null? s)) + + ; append s1 to s2, note s1 should not be infinite stream + (define (stream-append s1 s2) + (if (stream-null? s1) + s2 + (cons-stream (stream-car s1) + (stream-append (stream-cdr s1) s2)))) + + ; (define (stream-map proc s) + ;(if (stream-null? s) + ;the-empty-stream + ;(cons-stream (proc (stream-car s)) + ;(stream-map proc (stream-cdr s))))) + + + ; (stream-map proc stream stream ...) + (define (stream-map proc . stream-args) + (if (stream-null? (car stream-args)) + the-empty-stream + (cons-stream (apply proc (map stream-car stream-args)) + (apply stream-map (cons proc (map stream-cdr stream-args)))))) + + ;(define (stream-filter proc s) + ;(cond ((stream-null? s) the-empty-stream) + ;((proc (stream-car s)) + ;(cons-stream (stream-car s) + ;(stream-filter proc (stream-cdr s)))) + ;(else + ;(stream-filter proc (stream-cdr s))))) + + + (define (stream-filter proc . stream-args) + (cond ((stream-null? (car stream-args)) the-empty-stream) + ((apply proc (map stream-car stream-args)) + (cons-stream (map stream-car stream-args) + (apply stream-filter (cons proc (map stream-cdr stream-args))))) + (else + (apply stream-filter (cons proc (map stream-cdr stream-args)))))) + + (define (stream-enumerate-interval low high) + (if (> low high) + the-empty-stream + (cons-stream + low + (stream-enumerate-interval (+ low 1) high)))) + + (define (stream-for-each proc s) + (if (stream-null? s) + the-empty-stream + (begin + (proc (stream-car s)) + (stream-for-each proc (stream-cdr s))))) + + (define (stream-display s) + (if (not (stream-null? s)) + (begin + (display (stream-car s))(display " ") + (stream-display (stream-cdr s))))) + + (define (stream-display-n s n) + (define (iter s i) + (if (< i n) + (begin + (display (stream-car s))(display " ") + (iter (stream-cdr s) (+ i 1))))) + (iter s 0)) + + (define (stream-ref s n) + (define (iter s-remained i) + (if (= i n) + (stream-car s-remained) + (iter (stream-cdr s-remained) (+ i 1)))) + (iter s 0)) + + (define (stream-add s1 s2) + (stream-map + s1 s2)) + + (define (stream-minus s1 s2) + (stream-map - s1 s2)) + + (define (stream-scale s factor) + (stream-map (lambda (x) (* x factor)) s)) + + (define (integers-start-from n) + (cons-stream n (integers-start-from (+ n 1)))) + + (define (stream-mult s1 s2) + (stream-map * s1 s2)) + + (define (stream-div s1 s2) + (stream-map / s1 s2)) + + (define zeros + (cons-stream 0 zeros)) + + (define ones + (cons-stream 1 ones)) + + (define one-zeros (cons-stream 1 zeros)) + + (define negative-ones + (cons-stream -1 negative-ones)) + + (define integers + (cons-stream 1 (stream-add ones integers))) + + ; sum of stream + (define (partial-sum s) + (define sum (cons-stream (stream-car s) + (stream-add (stream-cdr s) + sum))) + sum) + + (define (stream-negate s) + (stream-mult negative-ones + s)) + + ; interleave two streams + (define (interleave s1 s2) + (if (stream-null? s1) + s2 + (cons-stream (stream-car s1) + (interleave s2 + (stream-cdr s1))))) + + (define (integral integrand initial-value dt) + (define int + (cons-stream initial-value + (stream-add (stream-scale integrand dt) + int))) + int) + + (define (integral-delayed delayed-integrand initial-value dt) + (define int + (cons-stream initial-value + (let ((integrand (force delayed-integrand))) + (stream-add (stream-scale integrand dt) + int)))) + int) + ) diff --git a/src/lib/symbolic-algebra.scm b/src/lib/r6rs/symbolic-algebra.scm similarity index 100% rename from src/lib/symbolic-algebra.scm rename to src/lib/r6rs/symbolic-algebra.scm diff --git a/src/lib/table2d.scm b/src/lib/r6rs/table2d.scm similarity index 100% rename from src/lib/table2d.scm rename to src/lib/r6rs/table2d.scm diff --git a/src/lib/utils.scm b/src/lib/r6rs/utils.scm similarity index 62% rename from src/lib/utils.scm rename to src/lib/r6rs/utils.scm index 327ec34..16f87fe 100644 --- a/src/lib/utils.scm +++ b/src/lib/r6rs/utils.scm @@ -2,15 +2,20 @@ (library (utils) (export square + cube set-cadr! set-caddr! inlist? range - random-in-range - sleepfor divides? - println) - (import (chezscheme)) + divisible? + println + average + pythagorean-triple?) + + (import (rnrs) + (rnrs r5rs) + (rnrs mutable-pairs)) (define (set-cadr! lst v) (set-car! (cdr lst) v)) @@ -20,6 +25,9 @@ (define (square x) (* x x)) + (define (cube x) + (* x x x)) + (define (inlist? x lst eqfn) (if (filter (lambda (y) (eqfn x y)) @@ -33,17 +41,21 @@ ((> a b) (cons a (range (- a 1) b))) ((< a b) (cons a (range a (- b 1)))))) - ; [low high) - (define (random-in-range low high) - (let ((range (- high low))) - (+ low (random range)))) - - ; sleep for s seconds - (define (sleepfor s) - (sleep (make-time 'time-duration 0 s))) (define (divides? a b) (= (remainder b a) 0)) + (define (divisible? x y) + (= (remainder x y) 0)) + (define (println v) - (display v)(newline)) + (display v)(newline) + v) + + (define (average a b) + (/ (+ a b) 2.0)) + + (define (pythagorean-triple? i j k) + (= (square k) + (+ (square i) + (square j)))) ) diff --git a/src/lib/stream.scm b/src/lib/stream.scm deleted file mode 100644 index f630b2e..0000000 --- a/src/lib/stream.scm +++ /dev/null @@ -1,90 +0,0 @@ -(library - (stream) - (export cons-stream - list-stream - stream-car - stream-cdr - the-empty-stream - stream-map - stream-filter - stream-enumerate-interval - stream-display) - - (import (rnrs) - (utils)) - - (define (memo-proc proc) - (let ((already-run #f) (result '())) - (lambda () - (if (not already-run) - (begin (set! result (proc)) - (set! already-run #t) - result) - result)))) - - (define (force delayed-object) - (delayed-object)) - - (define-syntax cons-stream - (syntax-rules () - ((cons-stream a b) - (cons a (memo-proc (lambda () b)))))) - - (define-syntax list-stream - (syntax-rules () - [(_) the-empty-stream] - [(_ a b ...) - (cons-stream a - (list-stream b ...))])) - - (define (stream-car stream) (car stream)) - - (define (stream-cdr stream) (force (cdr stream))) - - (define the-empty-stream '()) - - (define (stream-null? s) - (null? s)) - - ; (define (stream-map proc s) - ;(if (stream-null? s) - ;the-empty-stream - ;(cons-stream (proc (stream-car s)) - ;(stream-map proc (stream-cdr s))))) - - - ; (stream-map proc stream stream ...) - (define (stream-map proc . stream-args) - (if (stream-null? (car stream-args)) - the-empty-stream - (cons-stream (apply proc (map stream-car stream-args)) - (apply stream-map (cons proc (map stream-cdr stream-args)))))) - - (define (stream-filter proc s) - (cond ((stream-null? s) the-empty-stream) - ((proc (stream-car s)) - (cons-stream (stream-car s) - (stream-filter proc (stream-cdr s)))) - (else - (stream-filter proc (stream-cdr s))))) - - (define (stream-enumerate-interval low high) - (if (> low high) - the-empty-stream - (cons-stream - low - (stream-enumerate-interval (+ low 1) high)))) - - (define (stream-for-each proc s) - (if (stream-null? s) - the-empty-stream - (begin - (proc (stream-car s)) - (stream-for-each proc (stream-cdr s))))) - - (define (stream-display s) - (if (not (stream-null? s)) - (begin - (println (stream-car s)) - (stream-display (stream-cdr s))))) - ) diff --git a/src/little-schemer/c5.scm b/src/little-schemer/c5.scm new file mode 100644 index 0000000..92028e1 --- /dev/null +++ b/src/little-schemer/c5.scm @@ -0,0 +1,64 @@ +; eq? : takes two non-numeric atom. +; = : for numbers +; eqan?: atom equal +; eqlist?: list equal +; equal? : s-expression equal + +; for real-world scheme: eq? is for reference equal +; while equal? is for value equal. + +(define (atom? s) + (and (not (pair? s)) + (not (null? s)))) + +; equivalent to guile's eq? +(define (eqan? a1 a2) + (cond ((and (number? a1) (number? a2)) + (= a1 a2)) + ; one is number while the other is not + ((or (number? a1) (number? a2)) + #f) + (else (eq? a1 a2)))) + +(define (eqlist? l1 l2) + (cond ((and (null? l1) (null? l2)) #t) + ((or (null? l1) (null? l2)) #f) + (else + (and (myequal? (car l1) + (car l2)) + (eqlist? (cdr l1) + (cdr l2)))))) + +(define (myequal? s1 s2) + (cond ((and (atom? s1) (atom? s2)) + (eqan? s1 s2)) + ((or (atom? s1) (atom? s2)) #f) + (else (eqlist? s1 s2)))) + + +(define rember + (lambda (s l) + (cond ((null? l) '()) + ((myequal? s (car l)) + (cdr l)) + (else + (cons (car l) + (rember s + (cdr l))))))) + +(define insertL* + (lambda (new old l) + (cond ((null? l) '()) + ((myequal? old (car l)) + (cons new old (insertL* new old (cdr l)))) + ((list? (car l)) + (cons (insertL* new old (car l)) + (insertL* new old (cdr l)))) + (else + (cons (car l) + (insertL* new old (cdr l))))))) + +(define (test-insertL*) + (println (insertL* 'a 'b '(a b c)))) + + diff --git a/src/little-schemer/c9.scm b/src/little-schemer/c9.scm new file mode 100644 index 0000000..3051096 --- /dev/null +++ b/src/little-schemer/c9.scm @@ -0,0 +1,77 @@ +(define (atom? x) + (and (not (pair? x)) (not (null? x)))) + +; pair is consisted of two s-expressions +; different from pair? +(define (a-pair? x) + (cond ((atom? x) #f) + ((null? x) #f) + ((null? (cdr x)) #f) + ((null? (cdr (cdr x))) #t) + (else #f))) + +(define looking + (lambda (a lat) + (keep-looking a (pick 1 lat) lat))) + +(define (pick n lat) + (cond ((and (= n 1) + (not (null? lat))) + (car lat)) + ((= n 1) + (error 'pick "lat is null")) + (else + (pick (- n 1) + (cdr lat))))) + +(define (keep-looking a sorn lat) + (cond ((number? sorn) + (keep-looking a (pick sorn lat) lat)) + (else + (eq? a sorn)))) + +; build s1 and s2 into a list +(define (build s1 s2) + (cons s1 (cons s2 '()))) + +(define (first pair) + (car pair)) + +(define (second pair) + (cadr pair)) + +(define (shift pair) + (build (first (first pair)) + (build (second (first pair)) + (second pair)))) + +; pora is a special pair of an atom. The special pair is a pair +; consisted of two special pair or atom. +; Example: +; '((1 2) ((3 4) (5 6))) +; align it +; '(1 (2 (3 (4 (5 6))))) +(define (align pora) + (cond ((atom? pora) pora) + ((a-pair? (first pora)) + (align (shift pora))) + (else (build (first pora) + (align (second pora)))))) + +(define (weight* pora) + (cond ((atom? pora) 1) + (else + (+ (* (weight* (first pora)) 2) + (weight* (second pora)))))) + + +; reverse a pair +(define (revpair p) + (build (second p) (first p))) + +(define (shuffle pora) + (cond ((atom? pora) pora) + ((a-pair? (first pora)) + (shuffle (revpair pora))) + (else (build (first pora) + (shuffle (second pora)))))) diff --git a/src/little-schemer/y-combinator.js b/src/little-schemer/y-combinator.js new file mode 100644 index 0000000..dda530c --- /dev/null +++ b/src/little-schemer/y-combinator.js @@ -0,0 +1,20 @@ +function Y (g) { + return (function (f) { + return f(f); + })(function (f) { + return g(function () { + return f(f).apply(null, arguments); + }); + }); +}; + + +var fib = Y(function (fib_t) { + return function (n) { + if (n == 0) return 0; + if (n == 1) return 1; + return fib(n-1) + fib(n-2); + }; +}); + +console.log(fib(10)); diff --git a/src/little-schemer/y-combinator.scm b/src/little-schemer/y-combinator.scm new file mode 100644 index 0000000..11fb969 --- /dev/null +++ b/src/little-schemer/y-combinator.scm @@ -0,0 +1,370 @@ +; why we have y-combinator + +; ok, some helper function +(define (add1 x) + (+ x 1)) + +(define (eternity x) + (eternity x)) + +; take length as example +; initial length definition +(define length + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + +; how to implement it without use of define +; y-combinator + +; length0 +(lambda (l) + (cond ((null? l) 0) + (else + (add1 (eternity (cdr l)))))) + +; length<=1 +(lambda (l) + (cond ((null? l) 0) + (else + (add1 ((lambda (l) + (cond ((null? l) 0) + (else + (add1 (eternity (cdr l))))))))))) + +; abstract a function: mk-length +; mk-length: makes length from function that looks like length +(define mk-length + (lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l)))))))) + +; then, length0 +((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + eternity) + +; that is +(make-length eternity) + +; then, length<=1 +((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + eternity)) + +; that is +(make-length length0) + +; = +(make-length + (make-length eternity)) + +; length<=2 +((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + eternity))) + +; that is +(make-length + (make-length + (make-length eternity))) + +; make use of mk-length without define + +; length0 +((lambda (mk-length) + (mk-length eternity)) + (lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l)))))))) + +; length<=1 +((lambda (mk-length) + (mk-length + (mk-length eternity))) + (lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l)))))))) + + +; this can also be written as + +((lambda (mk-length) + (mk-length mk-length)) + (lambda (mk-length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 ((mk-length eternity) + (cdr l)))))))) + +; we don't care about the eternity func, +; it can be anything +((lambda (mk-length) + (mk-length mk-length)) + (lambda (mk-length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 ((mk-length mk-length) + (cdr l)))))))) + +; we also want to use our mk-length func defintion. +; then we have +((lambda (mk-length) + (mk-length mk-length)) + (lambda (mk-length) + ; here is our mk-length + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length + (cdr l))))))) + (mk-length mk-length)))) + + +; try to expand it +((lambda (mk-length) + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length + (cdr l))))))) + (mk-length mk-length))) + (lambda (mk-length) + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length + (cdr l))))))) + (mk-length mk-length)))) + +; again... +; Oh, shit! this is a infinite recursion +((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length + (cdr l))))))) + ; infinite recursion here when evaluate this. + ; the problem is that, before we can evaluate the mk-length body + ; wrap in lambda, we will first evaluate it's argument: (mk-length mk-length), + ; which is recursive. therefore we need to make it lazy(evaluate when we really need + ; it) + ((lambda (mk-length) + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length + (cdr l))))))) + (mk-length mk-length))) + (lambda (mk-length) + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length + (cdr l))))))) + (mk-length mk-length))))) + +; make it lazy +(f x) = ((lambda (x) + (f x)) + x) + +((lambda (mk-length) + (mk-length mk-length)) + (lambda (mk-length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 ((lambda (x) + ((mk-length mk-length) x)) + (cdr l)))))))) + +; we want to use our mk-length func defintion +; then we have +((lambda (mk-length) + (mk-length mk-length)) + (lambda (mk-length) + ; here is our mk-length + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 + ; lazy func will be evaluated here. + (length (cdr l))))))) + ; here, the argument will not be evaluate until we call length + (lambda (x) + ((mk-length mk-length) x))))) + +; how about extract mk-length definition, name it le +((lambda (le) + ((lambda (mk-length) + (mk-length mk-length)) + (lambda (mk-length) + (le + (lambda (x) + ((mk-length mk-length) x)))))) + ; mk-length here + (lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l)))))))) + +; we define the part that is not related to length/mk-length as Y +; that is y-combinator +(define Y + (lambda (g) + ((lambda (f) (f f)) + (lambda (f) + (g (lambda (x) ((f f) x))))))) + +(define mk-length + (lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l)))))))) + +(Y mk-length) = length + + +; try to expand it + +(Y mk-length) + +((lambda (le) + ((lambda (mk-length) + (mk-length mk-length)) + (lambda (mk-length) + (le + (lambda (x) + ((mk-length mk-length) x)))))) + (lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l)))))))) + +; expand +((lambda (mk-length) + (mk-length mk-length)) + (lambda (mk-length) + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + (lambda (x) + ((mk-length mk-length) x))))) + +; expand + +((lambda (mk-length) + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + (lambda (x) + ((mk-length mk-length) x)))) + (lambda (mk-length) + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + (lambda (x) + ((mk-length mk-length) x))))) + +; expand + +((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + (lambda (x) + (((lambda (mk-length) + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + (lambda (x) + ((mk-length mk-length) x)))) + (lambda (mk-length) + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + (lambda (x) + ((mk-length mk-length) x))))) + x))) + +; expand + +(lambda (l) + (cond ((null? l) 0) + (else + (add1 ((lambda (x) + (((lambda (mk-length) + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + (lambda (x) + ((mk-length mk-length) x)))) + (lambda (mk-length) + ((lambda (length) + (lambda (l) + (cond ((null? l) 0) + (else + (add1 (length (cdr l))))))) + (lambda (x) + ((mk-length mk-length) x))))) + x)) + (cdr l)))))) + +; that's it. diff --git a/src/modularity-functional.scm b/src/modularity-functional.scm new file mode 100644 index 0000000..bbac37a --- /dev/null +++ b/src/modularity-functional.scm @@ -0,0 +1 @@ +; no rand-init/rand-update for chez-scheme... diff --git a/src/rand.scm b/src/rand.scm new file mode 100644 index 0000000..580f8d8 --- /dev/null +++ b/src/rand.scm @@ -0,0 +1,15 @@ +; rand.scm for mit-scheme +(define random-init (get-universal-time)) +(define (rand-update x) + (let ((a 40) + (b 2641) + (m 729)) + (modulo (+ (* a x) b) m))) + +(define rand + (let ((x random-init)) + (lambda () + (set! x (rand-update x)) + x))) + +(display (rand)) diff --git a/src/run-test.sh b/src/run-test.sh index 9693044..7a3ac38 100755 --- a/src/run-test.sh +++ b/src/run-test.sh @@ -4,4 +4,6 @@ if [ $filetype != "scm" ] then filename=$filename.scm fi -petite --libdirs lib --script $filename +#petite --libdirs lib --script $filename + +csi -q -I lib/r6rs -s $filename diff --git a/src/stream-of-pairs.scm b/src/stream-of-pairs.scm new file mode 100644 index 0000000..d7598db --- /dev/null +++ b/src/stream-of-pairs.scm @@ -0,0 +1,204 @@ +(import (rnrs) + (stream) + (utils) + (prime)) + + +(define (pairs s t) + (let ((s0 (stream-car s)) + (t0 (stream-car t))) + (cons-stream (list s0 t0) + (interleave (stream-map (lambda (ti) + (list s0 ti)) + (stream-cdr t)) + (pairs (stream-cdr s) + (stream-cdr t) + ))))) + +(define int-pairs (pairs integers integers)) + +(define (interleave s1 s2) + (if (stream-null? s1) + s2 + (cons-stream (stream-car s1) + (interleave s2 + (stream-cdr s1))))) + +(stream-ref (stream-filter (lambda (pair) + (prime? (+ (car pair) + (cadr pair)))) + int-pairs) 10) + +; 3.67 +(define (full-pairs s t) + (let ((s0 (stream-car s)) + (t0 (stream-car t))) + (cons-stream (list s0 t0) + (interleave (interleave (stream-map (lambda (ti) + (list s0 ti)) + (stream-cdr t)) + (stream-map (lambda (si) + (list si t0)) + (stream-cdr s))) + (full-pairs (stream-cdr s) + (stream-cdr t)))))) + +(stream-ref (full-pairs integers integers) 20) + +; 3.68 +(define (louis-pairs s t) + (interleave + (stream-map (lambda (x) (list (stream-car s) x)) + t) + (louis-pairs (stream-cdr s) (stream-cdr t)))) + +; (stream-display-n (louis-pairs integers integers) 10) + +; 3.69 +(define (triples s t u) + (cons-stream (list (stream-car s) + (stream-car t) + (stream-car u)) + (interleave (stream-map (lambda (pair) + (cons (stream-car s) pair)) + (stream-cdr (pairs t u))) + (triples (stream-cdr s) + (stream-cdr t) + (stream-cdr u))))) + +(define int-triples (triples integers integers integers)) + +(define pythagorean-triples (stream-filter (lambda (triple) + (let ((i (car triple)) + (j (cadr triple)) + (k (caddr triple))) + (pythagorean-triple? i j k))) + int-triples)) + +(define (weighted-triples s t u weight) + (cons-stream (list (stream-car s) + (stream-car t) + (stream-car u)) + (merge-weighted (stream-map (lambda (pair) + (cons (stream-car s) pair)) + (stream-cdr (pairs t u))) + (triples (stream-cdr s) + (stream-cdr t) + (stream-cdr u) + weight) + weight))) +; (stream-display-n pythagorean-triples 5) + +(define (weighted-pairs s t weight) + (let ((s0 (stream-car s)) + (t0 (stream-car t))) + ; (s0 t0) must be the first, or there'll be problem for + ; the func + (cons-stream (list s0 t0) + (merge-weighted (stream-map (lambda (ti) + (list s0 ti)) + (stream-cdr t)) + (weighted-pairs (stream-cdr s) + (stream-cdr t) + weight) + weight)))) + +(define (merge-weighted s1 s2 weight) + (cond ((stream-null? s1) s2) + ((stream-null? s2) s1) + (else + (let ((s1car (stream-car s1)) + (s2car (stream-car s2))) + ;(display s1car)(display " ") + ;(display s2car)(newline) + (cond ((weight s1car s2car) + (cons-stream s1car + (merge-weighted (stream-cdr s1) + s2 + weight))) + ((weight s2car s1car) + (cons-stream s2car + (merge-weighted s1 + (stream-cdr s2) + weight))) + (else + (cons-stream s1car + (cons-stream s2car + (merge-weighted (stream-cdr s1) + (stream-cdr s2) + weight))))))))) + +; 3.70 a +(define weighted-pairs-by-a (weighted-pairs integers integers (lambda (p1 p2) + (< (+ (car p1) + (cadr p1)) + (+ (car p2) + (cadr p2)))))) + +(stream-ref weighted-pairs-by-a 10) + +; 3.70 b +(define integer-not-divisible-235 (stream-filter (lambda (v) + (not (or (divisible? v 2) + (divisible? v 3) + (divisible? v 5)))) + integers)) + +(define weighted-pairs-by-b (weighted-pairs integer-not-divisible-235 + integer-not-divisible-235 + (lambda (p1 p2) + (define (sum-rule i j) + (+ (* 2 i) + (* 3 j) + (* 5 i j))) + (< (sum-rule (car p1) + (cadr p1)) + (sum-rule (car p2) + (cadr p2)))))) +; (stream-display-n weighted-pairs-by-b 10) + +(define (ramanujan-sum p) + (+ (cube (car p)) + (cube (cadr p)))) +;3.71 +(define ramanujan-weighted-pairs (weighted-pairs integers + integers + (lambda (p1 p2) + (< (ramanujan-sum p1) + (ramanujan-sum p2))))) + + +(define ramanujan-series (stream-filter (lambda (p1 p2) + (= (ramanujan-sum p1) + (ramanujan-sum p2))) + ramanujan-weighted-pairs + (stream-cdr ramanujan-weighted-pairs))) + +(stream-ref (stream-map (lambda (p) + (ramanujan-sum (car p))) + ramanujan-series) + 5) + +; 3.72 +(define (square-sum p) + (+ (square (car p)) + (square (cadr p)))) +(define square-sum-in-3-pairs (weighted-pairs integers + integers + (lambda (p1 p2) + (< (square-sum p1) + (square-sum p2))))) + +(define square-sum-in-3-series (stream-filter (lambda (p1 p2 p3) + (= (square-sum p1) + (square-sum p2) + (square-sum p3))) + square-sum-in-3-pairs + (stream-cdr square-sum-in-3-pairs) + (stream-cdr (stream-cdr square-sum-in-3-pairs)))) + +(stream-display-n (stream-map (lambda (t) + (cons (square-sum (car t)) + t)) + square-sum-in-3-series) + 5) diff --git a/src/stream-signals.scm b/src/stream-signals.scm new file mode 100644 index 0000000..ce5bd41 --- /dev/null +++ b/src/stream-signals.scm @@ -0,0 +1,20 @@ +(import (rnrs) + (stream) + (utils)) + +; 3.73 (not really understand it) + +(define (rc r c dt) + (lambda (I v0) + (stream-add (stream-scale (integral I v0 dt) (/ 1 c)) + (stream-scale I r)) + )) + + +(define RC1 (rc 5 1 0.5)) + +(define constant-current (RC1 ones 0)) + +(stream-display-n constant-current 10) + +; 3.74, 3.75, 3.76 unfinished diff --git a/src/stream.js b/src/stream.js index 8f633e0..ebf1b13 100644 --- a/src/stream.js +++ b/src/stream.js @@ -24,6 +24,9 @@ var cdr = exports.cdr = function (s) { return s.cdr().apply(); }; +var ref = exports.ref = function (s, n) { +}; + var range = exports.range = function (low, high) { if (low > high) { return empty; @@ -34,4 +37,16 @@ var range = exports.range = function (low, high) { } }; -console.log(car(cdr(range(2, 4)))); +function integersStartFrom(n) { + return cons(n, function () { + return integersStartFrom(n + 1); + }); +}; + +function fibgen (a, b) { + return cons(a, function () { + return fibgen(b, a + b); + }); +}; + +var fibs = fibgen(0, 1); diff --git a/src/test.scm b/src/test.scm index f80fa61..239611f 100644 --- a/src/test.scm +++ b/src/test.scm @@ -1,27 +1,6 @@ -(define (make-semaphore n) - (let ((cell (list #f))) - (define (acquire) - (if (test-and-set! cell) - (acquire) - (begin - (cond ((> n 0) - (set! n (- n 1)) - (clear! cell) - #t) - (else - (clear! cell) - (acquire)))))) - (define (release) - (if (test-and-set! cell) - (begin - (clear! cell) - (release)) - (begin - (set! n (+ n 1)) - (clear! cell)))) - (define (self msg) - (cond ((eq? msg 'acquire) acquire) - ((eq? msg 'release) release) - (else - (error 'semaphore-self "UNKNOWN MESSAGE" msg)))) - self)) +(import (rnrs) + (stream) + (utils)) + +(stream-display (stream-append (list-stream 1 2 3) + (list-stream 2 3 4)))