(sicp50)m4.4〜m4.8

追記

putとgetの引数の順序が逆だった。後で直す。

i

以前書いたput/getのファイルがどこかにいってしまったので書き直した
本当はdolistとかdotimesとかdoとかもつくろうとしたけど、飽きた。

一応まともに動く。

;;; M-Eval input:
(define (mymap proc l)
  (if (null? l)
      nil
      (cons (proc (car l))
            (mymap proc (cdr l)))))


;;; M-Eval value:
ok

;;; M-Eval input:
(mymap (lambda (x) (* x x)) '(1 2 3))

;;; M-Eval value:
(1 4 9)

;;; M-Eval input:
(define x 1)

;;; M-Eval value:
ok

;;; M-Eval input:
(+ x 10)

;;; M-Eval value:
11

;;; M-Eval input:
(if (= 1 1) 1 2)

;;; M-Eval value:
1

;;; M-Eval input:
(define (gcd n m)
  (if (= m 0) n (gcd m (modulo n m))))


;;; M-Eval value:
ok

;;; M-Eval input:
(gcd 30 5)

;;; M-Eval value:
5

;;; M-Eval input:
(define (even? n)
  ((lambda (f g)
     (f f g n))
   (lambda (ev od k)
     (if (= 0 k)
         true
         (od od ev (- k 1))))
   (lambda (od ev k)
     (if (= 0 k)
         false
         (ev ev od (- k 1))))))


;;; M-Eval value:
ok

;;; M-Eval input:
(even? 2)

;;; M-Eval value:
#t

;;; M-Eval input:
(even? 3)

;;; M-Eval value:
#f

;;; M-Eval input:
(define (f n x)
  (cond ((= n x) => (lambda (y) (list y)))
        (else (list n x))))


;;; M-Eval value:
ok

;;; M-Eval input:
(f 2 2)

;;; M-Eval value:
(#t)

;;; M-Eval input:
(f 2 3)

;;; M-Eval value:
(2 3)

;;; M-Eval input:
(and (= 0 (modulo 4 2))
     (= 4 4))


;;; M-Eval value:
#t

;;; M-Eval input:
(and (= 2 2) (= 1 2))


;;; M-Eval value:
#f

;;; M-Eval input:
(or (= 1 2) (= 2 2))

;;; M-Eval value:
#t

;;; M-Eval input:
(let* ((x 10)
        (y (* x x)))
   (* (+ x y)
      x))


;;; M-Eval value:
1100

;;; M-Eval input:
(let fib ((a 0) (b 1) (n 10))
  (if (= n 0) b (fib b (+ a b) (- n 1))))


;;; M-Eval value:
89

;;; M-Eval input:
(let ((i 10))
  (while (> i 0) (print i) (set! i (- i 1))))

10
9
8
7
6
5
4
3
2
1

;;; M-Eval value:
#t

;;; M-Eval input:
(let ((i 4))
 (until (< i 0) (print i) (set! i (- i 1))))

4
3
2
1
0

;;; M-Eval value:
#t

;;; M-Eval input:

put/get

(define-module sicp.put-get
  (export put get))
(select-module sicp.put-get)

(define *parent-table* (make-hash-table 'equal?))

(define (put type op item)
  (if (hash-table-exists? *parent-table* type)
      (let1 ops-table (hash-table-get *parent-table* type)
        (hash-table-put! ops-table op item))
      (begin (hash-table-put! *parent-table* type (make-hash-table 'equal?))
             (put type op item))))


(define (if-enable-get-item h key action)
  (if (hash-table-exists? h key)
      (action (hash-table-get h key))
      #f))

(define (get type op)
  (if-enable-get-item  *parent-table* type
                       (cut if-enable-get-item <> op identity)))
(provide "sicp/put-get")

sicpにあるschemeのsubset

(define-module sicp.scheme-subset
  (use sicp.put-get)
  (export driver-loop))
(select-module sicp.scheme-subset)

 (begin
   (define true #t)
   (define false #f))

(define (@apply procedure arguments)
  ;gaucheのapplyとかぶらないように名前を変更
  (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 (install-eval-package env)
  ;must call this procedure in setup-environment
  (define (define-action! name proc)    (put 'eval name proc))
  (define (eval&transform transformer)
    (lambda (exp env) (eval (transformer exp) env)))

  (define-action! 'quote (lambda (exp env) (text-of-quotation exp)))
  (define-action! 'set! eval-assignment)
  (define-action! 'define eval-definition)
  (define-action! 'if eval-if)
  (define-action! 'and eval-and) ;;ex 4.4 addon
  (define-action! 'or eval-or) ;;ex 4.4 addon
  (define-action! 'lambda (lambda (exp env)
                            (make-procedure (lambda-parameters exp)
                                            (lambda-body exp)
                                            env)))
  (define-action! 'let (eval&transform let->combination))
  (define-action! 'let* (eval&transform let*->nested-let)) ;;ex 4.7 addon
  (define-action! 'while (eval&transform while->named-let)) ;;ex 4.9 addon
  (define-action! 'until (eval&transform until->named-let)) ;;ex 4.9 addon
  (define-action! 'begin (lambda (exp env)
                           (eval-sequence (begin-actions exp) env)))
  (define-action! 'cond (eval&transform cond->if))
  )

(define (exp-type exp) (car exp))

(define (eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((get 'eval (exp-type exp)) => (cut <> exp env))
        ((application? exp)
         (@apply (eval (operator exp) env)
                 (list-of-values (operands exp) env)))
        (else
         (error "Unknown expression type -- EVAL" exp)))
  )

 (define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (cons (eval (first-operand exps) env)
            (list-of-values (rest-operands exps) env))))

;;eval- if and/or
(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))))

;;and or
(define (eval-and exps env)
  (travase-and (cdr exps) env))

(define (eval-or exps env)
  (travase-or (cdr exps) env))

(define (travase-and exps env)
  (cond ((last-exp? exps) (eval (first-exp exps) env))
        ((eval (first-exp exps) env)
         (travase-and (rest-exps exps) env))
        (else false)))

(define (travase-or exps env)
  (cond ((last-exp? exps) (eval (first-exp exps) env))
        ((eval (first-exp exps) env) => identity)
        (else (travase-or (rest-exps exps) env))))
;;

;;assignment/definition
(define (eval-assignment exp env)
  (set-variable-value! (assignment-variable exp)
                       (eval (assignment-value exp) env)
                       env)
  'ok)
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))


(define (eval-definition exp env)
  (define-variable! (definition-variable exp)
                    (eval (definition-value exp) env)
                    env)
  'ok)
(define (definition-variable exp)
  (if (symbol? (cadr exp))
      (cadr exp)
      (caadr exp)))
(define (definition-value exp)
  (if (symbol? (cadr exp))
      (caddr exp)
      (make-lambda (cdadr exp)   ; formal parameters
                   (cddr exp)))) ; body

;;self
(define (self-evaluating? exp)
  (cond ((number? exp) true)
        ((string? exp) true)
        (else false)))

(define (variable? exp) (symbol? exp))

;;quote
(define (text-of-quotation exp) (cadr exp))

;;lambda
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))

(define (make-lambda parameters body)
  (cons 'lambda (cons parameters body)))

;;let
;;ex 4.6~8 addon
(define (decompose-let-head clauses fn)
  (let ((head (car clauses))
        (body (cdr clauses)))
    (let ((vars (map car head))
          (exps (map cadr head)))
      (fn vars exps body))))

(define (let->combination form)
  (if (named-let? form)
      (named-let->combination form)
      (let1 clauses (cdr form)
        (decompose-let-head
         clauses
         (lambda (vars exps body)
           (cons (make-lambda vars body)
                 exps))))))

(define (named-let? form)
  (symbol? (cadr form)))

(define (named-let->combination form)
  (let ((name (cadr form))
        (clauses (cddr form)))
    (decompose-let-head
     clauses
     (lambda (vars exps body)
       (make-begin
        (list (make-define-form name vars body)
              (cons name exps)))))))

(define (make-define-form name args body)
  (list 'define name (make-lambda args body)))

(define (make-let clauses body)
  (cons 'let (list clauses body)))

(define (make-named-let name clauses body)
  (cons 'let (list name clauses body)))

(define (let*->nested-let form)
  (let ((body (cddr form))
        (clauses (cadr form)))
    (fold-right (lambda (exp re)
                  (make-let (list exp) re))
                (make-begin body) clauses)))
;;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))

(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))

;;begin
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps 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))

;;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))

;;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-contain=>-clause? clause)
  (eq? '=> (cadr clause)))

(define (cond-actions clause)
  (if (cond-contain=>-clause? clause)
      (caddr 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)))
        (cond ((cond-else-clause? first)
               (if (null? rest)
                   (sequence->exp (cond-actions first))
                   (error "ELSE clause isn't last -- COND->IF"  clauses)))
              ((cond-contain=>-clause? first) 
               ;ex4.5 addon =>
               (let1 predicate-result (cond-predicate first)
                 (make-if predicate-result
                          (list (cond-actions first) predicate-result)
                          (expand-clauses rest))))
              (else 
               (make-if (cond-predicate first)
                        (sequence->exp (cond-actions first))
                        (expand-clauses rest)))))))

;;while
(define (while->named-let exp)
  (let1 name '_while-loop
    (let ((pred (cadr exp))
          (action (make-begin `(,@(cddr exp) (,name)))))
      (make-named-let name '()
                      (make-if pred action 'true)))))

(define (until->named-let exp)
  (while->named-let `(,(car exp) (not ,(cadr exp)) ,@(cddr exp))))
   

;;bool
(define (true? x)  (not (eq? x false)))
(define (false? x)  (eq? x false))

;;procedure
(define (make-procedure parameters body env)
  (list 'procedure parameters body env))
(define (compound-procedure? p)
  (tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))

;;enviroment
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())

;;frame
(define (make-frame variables values)
  (cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))

(define (add-binding-to-frame! var val frame)
  (set-car! frame (cons var (car frame)))
  (set-cdr! frame (cons val (cdr frame))))

(define (extend-environment vars vals base-env)
  (if (= (length vars) (length vals))
      (cons (make-frame vars vals) base-env)
      (if (< (length vars) (length vals))
          (error "Too many arguments supplied" vars vals)
          (error "Too few arguments supplied" vars vals))))

;;lookup .etc (for variable)
(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (car vals))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))

(define (set-variable-value! var val env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (set-car! vals val))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable -- SET!" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (define (scan vars vals)
      (cond ((null? vars)
             (add-binding-to-frame! var val frame))
            ((eq? var (car vars))
             (set-car! vals val))
            (else (scan (cdr vars) (cdr vals)))))
    (scan (frame-variables frame)
          (frame-values frame))))

;;environment
(define (setup-environment)
  (let ((initial-env
         (extend-environment (primitive-procedure-names)
                             (primitive-procedure-objects)
                             the-empty-environment)))
    (install-eval-package initial-env)
    (define-variable! 'true #t initial-env)
    (define-variable! 'false #f initial-env)
    (define-variable! 'nil '() initial-env)
    initial-env))

(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      false))

(define (primitive-procedure? proc)
  (tagged-list? proc 'primitive))

(define (primitive-implementation proc) (cadr proc))

(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'list list)
        (list 'null? null?)
        (list 'eq? eq?)
        (list 'eqv? eqv?)
        (list 'equal? equal?)
        (list 'not not)
        (list '= =)
        (list '> >)
        (list '>= >=)
        (list '< <)
        (list '<= <=)
        (list '+ +)
        (list '- -)
        (list '* *)
        (list '/ /)
        (list 'print print)
        (list 'modulo modulo)
        (list 'remainder remainder)
        ))
(define (primitive-procedure-names)
  (map car
       primitive-procedures))

(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (cadr proc)))
       primitive-procedures))

(define (apply-primitive-procedure proc args)
;  (print "proc:" (primitive-implementation proc) "  args" args)
;  (apply-in-underlying-scheme
  (apply
   (primitive-implementation proc) args))

;;for convinience
(define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")

(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (let ((output (eval input the-global-environment)))
      (announce-output output-prompt)
      (user-print output)))
  (driver-loop))

(define (prompt-for-input string)
  (newline) (newline) (display string) (newline))

(define (announce-output string)
  (newline) (display string) (newline))

(define (user-print object)
  (if (compound-procedure? object)
      (display (list 'compound-procedure
                     (procedure-parameters object)
                     (procedure-body object)
                     '<procedure-env>))
      (display object)))

;; using
(define the-global-environment (setup-environment))

(provide "sicp/scheme-subset.scm")