--- /dev/null
+#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
--- /dev/null
+#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)
+
--- /dev/null
+#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))
+
--- /dev/null
+#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
projects / sicp.git / commitdiff