From: Ramakrishnan Muthukrishnan <vu3rdd@gmail.com>
Date: Sun, 6 Nov 2011 06:50:53 +0000 (+0530)
Subject: programs from the text
X-Git-Url: https://git.rkrishnan.org/frontends/flags/statistics?a=commitdiff_plain;h=8a748ae98da99aa8a4ae22f1cd5c056010200f1e;p=sicp.git

programs from the text
---

diff --git a/src/sicp/ch3_1.rkt b/src/sicp/ch3_1.rkt
new file mode 100644
index 0000000..066d1f2
--- /dev/null
+++ b/src/sicp/ch3_1.rkt
@@ -0,0 +1,92 @@
+#lang racket
+
+;; 3.1.1
+(define balance 100)
+
+(define (withdraw amount)
+  (if (>= (- balance amount) 0)
+      (begin
+        (set! balance (- balance amount))
+        balance)
+      (print "insufficient balance")))
+
+(define new-withdraw
+  (let ((balance 100))
+    (lambda (amount)
+      (if (>= (- balance amount) 0)
+          (begin
+            (set! balance (- balance amount))
+            balance)
+          "insufficient funds"))))
+
+(define (make-withdraw balance)
+  (lambda (amount)
+    (if (>= (- balance amount) 0)
+        (begin
+          (set! balance (- balance amount))
+          balance)
+        "insufficent funds")))
+
+(define w1 (make-withdraw 100))
+(define w2 (make-withdraw 200))
+
+(define (make-account balance)
+  (define (withdraw amount)
+    (if (>= (- balance amount) 0)
+        (begin
+          (set! balance (- balance amount))
+          balance)
+        "insufficient funds"))
+  (define (deposit amount)
+    (begin
+      (set! balance (+ balance amount))
+      balance))
+  (define (dispatch m)
+    (cond
+      ((eq? m 'withdraw) (lambda (amount) (withdraw amount)))
+      ((eq? m 'deposit) (lambda (amount) (deposit amount)))
+      (else (error "unknown request -- make-account " m))))
+  dispatch)
+
+;; 3.1.2
+
+(define rand 
+  (let ((x rand-init))
+    (lambda ()
+      (begin
+        (set! x (rand-update x))
+        x))))
+
+;; monte carlo simulation
+
+(define (estimate-pi trials)
+  (sqrt (/ 6 (monte-carlo trials cesaro-test))))
+
+(define (cesaro-test)
+  (= (gcd (rand) (rand)) 1))
+
+(define (monte-carlo trials experiment)
+  (define (iter trials-remaining trials-passed)
+    (cond 
+      ((= trials-remaining 0) (/ trials-passed trials))
+      ((experiment) (iter (- trials-remaining 1) (+ trials-passed 1)))
+      (else (iter (- trials-remaining 1) trials-passed))))
+  (iter trials 0))
+      
+;; using rand-update
+(define (estimate-pi2 trials)
+  (sqrt (/ 6 (random-gcd-trials trials random-init))))
+
+(define (random-gcd-trials trials initial-x)
+  (define (iter trials-remaining trials-passed x)
+    (let ((x1 (rand-update x)))
+      (let ((x2 (rand-update x1)))
+        (cond 
+          ((= trials-ramaining 0) (/ trials-passed trials))
+          ((= (gcd x1 x2) 1) (iter (- trials-remaining 1) 
+                                   (+ trials-passed 1) 
+                                   x2))
+          (else (iter (- trials-remaining 1)
+                      trials-passed
+                      x2))))))
+  (iter trials 0 initial-x))
\ No newline at end of file
diff --git a/src/sicp/ch3_3_5.rkt b/src/sicp/ch3_3_5.rkt
new file mode 100644
index 0000000..e8b7c3d
--- /dev/null
+++ b/src/sicp/ch3_3_5.rkt
@@ -0,0 +1,179 @@
+#lang racket
+
+;; implementation
+(define (celsius-fahrenheit-converter c f)
+  (let ((u (make-connector))
+        (v (make-connector))
+        (w (make-connector))
+        (x (make-connector))
+        (y (make-connector)))
+    (multiplier c w u)
+    (multiplier v x u)
+    (adder v y f)
+    (constant 9 w)
+    (constant 5 x)
+    (constant 32 y)
+    'ok))
+
+(define (adder a1 a2 sum)
+  (define (process-new-value)
+    (cond ((and (has-value? a1) (has-value? a2))
+           (set-value! sum
+                       (+ (get-value a1) (get-value a2))
+                       me))
+          ((and (has-value? a1) (has-value? sum))
+           (set-value! a2
+                       (- (get-value sum) (get-value a1))
+                       me))
+          ((and (has-value? a2) (has-value? sum))
+           (set-value! a1
+                       (- (get-value sum) (get-value a2))
+                       me))))
+  (define (process-forget-value)
+    (forget-value! sum me)
+    (forget-value! a1 me)
+    (forget-value! a2 me)
+    (process-new-value))
+  (define (me request)
+    (cond ((eq? request 'I-have-a-value)  
+           (process-new-value))
+          ((eq? request 'I-lost-my-value) 
+           (process-forget-value))
+          (else 
+           (error "Unknown request -- ADDER" request))))
+  (connect a1 me)
+  (connect a2 me)
+  (connect sum me)
+  me)
+
+(define (multiplier m1 m2 product)
+  (define (process-new-value)
+    (cond ((or (and (has-value? m1) (= (get-value m1) 0))
+               (and (has-value? m2) (= (get-value m2) 0)))
+           (set-value! product 0 me))
+          ((and (has-value? m1) (has-value? m2))
+           (set-value! product
+                       (* (get-value m1) (get-value m2))
+                       me))
+          ((and (has-value? product) (has-value? m1))
+           (set-value! m2
+                       (/ (get-value product) (get-value m1))
+                       me))
+          ((and (has-value? product) (has-value? m2))
+           (set-value! m1
+                       (/ (get-value product) (get-value m2))
+                       me))))
+  (define (process-forget-value)
+    (forget-value! product me)
+    (forget-value! m1 me)
+    (forget-value! m2 me)
+    (process-new-value))
+  (define (me request)
+    (cond ((eq? request 'I-have-a-value)
+           (process-new-value))
+          ((eq? request 'I-lost-my-value)
+           (process-forget-value))
+          (else
+           (error "Unknown request -- MULTIPLIER" request))))
+  (connect m1 me)
+  (connect m2 me)
+  (connect product me)
+  me)
+
+(define (constant value connector)
+  (define (me request)
+    (error "Unknown request -- CONSTANT" request))
+  (connect connector me)
+  (set-value! connector value me)
+  me)
+
+(define (probe name connector)
+  (define (print-probe value)
+    (newline)
+    (display "Probe: ")
+    (display name)
+    (display " = ")
+    (display value))
+  (define (process-new-value)
+    (print-probe (get-value connector)))
+  (define (process-forget-value)
+    (print-probe "?"))
+  (define (me request)
+    (cond ((eq? request 'I-have-a-value)
+           (process-new-value))
+          ((eq? request 'I-lost-my-value)
+           (process-forget-value))
+          (else
+           (error "Unknown request -- PROBE" request))))
+  (connect connector me)
+  me)
+
+(define (inform-about-value constraint)
+  (constraint 'I-have-a-value))
+(define (inform-about-no-value constraint)
+  (constraint 'I-lost-my-value))
+
+(define (make-connector)
+  (let ((value false) (informant #f) (constraints '()))
+    (define (set-my-value newval setter)
+      (cond ((not (has-value? me))
+             (set! value newval)
+             (set! informant setter)
+             (for-each-except setter
+                              inform-about-value
+                              constraints))
+            ((not (= value newval))
+             (error "Contradiction" (list value newval)))
+            (else 'ignored)))
+    (define (forget-my-value retractor)
+      (if (eq? retractor informant)
+          (begin (set! informant false)
+                 (for-each-except retractor
+                                  inform-about-no-value
+                                  constraints))
+          'ignored))
+    (define (connect new-constraint)
+      (when (not (memq new-constraint constraints))
+          (set! constraints 
+                (cons new-constraint constraints)))
+      (when (has-value? me)
+          (inform-about-value new-constraint))
+      'done)
+    (define (me request)
+      (cond ((eq? request 'has-value?)
+             (if informant #t #f))
+            ((eq? request 'value) value)
+            ((eq? request 'set-value!) set-my-value)
+            ((eq? request 'forget) forget-my-value)
+            ((eq? request 'connect) connect)
+            (else (error "Unknown operation -- CONNECTOR"
+                         request))))
+    me))
+
+(define (for-each-except exception procedure list)
+  (define (loop items)
+    (cond ((null? items) 'done)
+          ((eq? (car items) exception) (loop (cdr items)))
+          (else (procedure (car items))
+                (loop (cdr items)))))
+  (loop list))
+
+(define (has-value? connector)
+  (connector 'has-value?))
+(define (get-value connector)
+  (connector 'value))
+(define (set-value! connector new-value informant)
+  ((connector 'set-value!) new-value informant))
+(define (forget-value! connector retractor)
+  ((connector 'forget) retractor))
+(define (connect connector new-constraint)
+  ((connector 'connect) new-constraint))
+
+
+;; celcius to fahrenheit and vice-versa conv
+(define C (make-connector))
+(define F (make-connector))
+(celsius-fahrenheit-converter C F)
+(probe "Celsius temp" C)
+(probe "Fahrenheit temp" F)
+
diff --git a/src/sicp/circuit-simulation.rkt b/src/sicp/circuit-simulation.rkt
new file mode 100644
index 0000000..008ddf1
--- /dev/null
+++ b/src/sicp/circuit-simulation.rkt
@@ -0,0 +1,65 @@
+#lang racket
+
+(define (inverter input output)
+  (define (invert-input)
+    (let ((new-value (logical-not (get-signal input))))
+      (after-delay inverter-delay
+                   (lambda ()
+                     (set-signal! output new-value)))))
+  
+  (add-action! input invert-input)
+  'ok)
+
+(define (logical-not input)
+  (cond ((= input 0) 1)
+        ((= input 1) 0)
+        (else (error "LOGICAL-NOT: invalid input value" input))))
+
+(define (and-gate a1 a2 output)
+  (define (and-action-procedure)
+    (let ((new-value (logical-and (get-signal a1)
+                                  (get-signal a2))))
+      (after-delay and-gate-delay
+                   (lambda ()
+                     (set-signal! output new-value)))))
+  
+  (add-action! a1 and-action-procedure)
+  (add-action! a2 and-action-procedure)
+  'ok)
+
+;; wires
+(define (make-wire)
+  (let ((signal-value 0)
+        (action-procedures '()))
+    (define (set-my-signal! new-value)
+      (if (not (= signal-value new-value))
+          (begin
+            (set! signal-value new-value)
+            (call-each action-procedures))
+          'done))
+    (define (accept-action-procedure! proc)
+      (set! action-procedures (cons proc action-procedures))
+      (proc))
+    (define (dispatch m)
+      (cond ((eq? m 'set-signal!) set-my-signal!)
+            ((eq? m 'get-signal)  signal-value)
+            ((eq? m 'add-action!) accept-action-procedure!)
+            (else (error "Unknown operation -- wire" m))))
+    dispatch))
+
+(define (call-each procedures)
+  (if (null? procedures)
+      'done
+      (begin
+        ((car procedures))
+        (call-each (cdr procedures)))))
+
+(define (get-signal wire)
+  (wire 'get-signal))
+
+(define (set-signal! wire value)
+  ((wire 'set-signal!) value))
+
+(define (add-action! wire proc)
+  ((wire 'add-action!) proc))
+
diff --git a/src/sicp/metacircular.rkt b/src/sicp/metacircular.rkt
new file mode 100644
index 0000000..596d9bb
--- /dev/null
+++ b/src/sicp/metacircular.rkt
@@ -0,0 +1,182 @@
+#lang racket
+
+;; metacircular evaluator
+(define (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)
+         (make-procedure (lambda-parameters exp)
+                         (lambda-body exp)
+                         env))
+        ((begin? exp) (eval-sequence (begin-actions exp) env))
+        ((cond? exp) (eval (cond->if exp) env))
+        ((application? exp)
+         (apply (eval (operator exp) env)
+                (list-of-values (operands exp) env)))
+        (else
+         (error "unknown expression type -- EVAL" exp))))
+
+(define (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
+           (procedure-environment procedure))))
+        (else
+         (error "unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+  (if (no-operands? exps)
+      '()
+      (cons (eval (first-operand exps) env)
+            (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+  (if (true? (eval (if-predicate exp) env))
+      (eval (if-consequent exp) env)
+      (eval (if-alternative exp) env)))
+
+(define (eval-sequence exps env)
+  (cond ((last-exp? exps) 
+         (eval (first-exp exps) env))
+        (else
+         (eval (first-exp exps) env)
+         (eval-sequence (rest-exps exps) env))))
+
+(define (eval-assignment exp env)
+  (set-variable-value! (assignment-variable exp)
+                       (eval (assignment-value exp) env)
+                       env)
+  'ok)
+
+(define (eval-definition exp env)
+  (define-variable! (definition-variable exp)
+                    (eval (definition-value exp) env)
+                    env)
+  'ok)
+
+;; =====
+(define (self-evaluating? expr)
+  (cond [(number? expr) #t]
+        [(string? expr) #t]
+        [else #f]))
+
+(define (variable? expr)
+  (symbol? expr))
+
+;; quotation
+(define (quoted? expr)
+  (tagged-list? expr 'quote))
+
+(define (tagged-list? expr tag)
+  (or (pair? expr) (eq? (car expr) tag)))
+
+(define (text-of-quotation expr)
+  (car (cdr expr)))
+
+;; assignment
+(define (assignment? expr)
+  (tagged-list? expr 'set!))
+
+(define (assignment-variable expr)
+  (car (cdr expr)))
+
+(define (assignment-value expr)
+  (car (cdr (cdr expr))))
+
+;; define
+(define (definition? expr)
+  (tagged-list? expr 'define))
+
+(define (definition-variable expr)
+  (if (symbol? (car (cdr expr))) ;; (define foo 42)
+      (car (cdr expr))
+      ;; (define (foo x) (....))
+      (car (car (cdr expr)))))
+
+(define (definition-value expr)
+  ;; (define foo 42)
+  (if (symbol? (car (cdr expr)))
+      (car (cdr (cdr expr)))
+      ;; (define (foo x) (....))
+      (make-lambda (cdr (car (cdr expr))) ;; gives (x)
+                   (cdr (cdr expr)))))    ;; body
+
+;; lambda
+(define (lambda? expr)
+  (tagged-list? expr 'lambda))
+
+(define (lambda-parameters expr)
+  (car (cdr expr)))
+
+;;(lambda (x) (..)(..)...(..))
+(define (lambda-body expr)
+  (cdr (cdr expr)))
+
+(define (make-lambda params body)
+  (cons 'lambda (cons params body)))
+
+;; if
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate expr) (car (cdr expr)))
+(define (if-consequent expr) (car (cdr (cdr expr))))
+(define (if-alternative expr) 
+  (if (not (null? (cdr (cdr (cdr expr)))))
+      (car (cdr (cdr (cdr expr))))
+      'false))
+
+(define (make-if predicate consequent alternative)
+  (list 'if predicate consequent alternative))
+
+;; begin
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exp seq) (cdr seq))
+
+(define (sequence->exp seq)
+  (cond ((null? seq) seq)
+        ((last-exp? seq) (first-exp seq))
+        (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; procedure application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; expander for `cond' expressions to be transformed into `if' expressions
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+  (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+  (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+  (if (null? clauses)
+      'false                          ; no else clause
+      (let ((first (car clauses))
+            (rest (cdr clauses)))
+        (if (cond-else-clause? first)
+            (if (null? rest)
+                (sequence->exp (cond-actions first))
+                (error "ELSE clause isn't last -- COND->IF"
+                       clauses))
+            (make-if (cond-predicate first)
+                     (sequence->exp (cond-actions first))
+                     (expand-clauses rest))))))
\ No newline at end of file