From 8a748ae98da99aa8a4ae22f1cd5c056010200f1e Mon Sep 17 00:00:00 2001 From: Ramakrishnan Muthukrishnan Date: Sun, 6 Nov 2011 12:20:53 +0530 Subject: [PATCH] programs from the text --- src/sicp/ch3_1.rkt | 92 ++++++++++++++++ src/sicp/ch3_3_5.rkt | 179 +++++++++++++++++++++++++++++++ src/sicp/circuit-simulation.rkt | 65 ++++++++++++ src/sicp/metacircular.rkt | 182 ++++++++++++++++++++++++++++++++ 4 files changed, 518 insertions(+) create mode 100644 src/sicp/ch3_1.rkt create mode 100644 src/sicp/ch3_3_5.rkt create mode 100644 src/sicp/circuit-simulation.rkt create mode 100644 src/sicp/metacircular.rkt 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 -- 2.37.2