Hatena::ブログ(Diary)

aolog

2011-12-04

[][] BoehmGCによる早すぎる解放 08:38  BoehmGCによる早すぎる解放を含むブックマーク

展示の為に、まとまった量のArcのコードを書いてglazeで実行したらsegvが頻発した。

調べてみるとまだ使用中のオブジェクトを解放してしまっていたようである。

glazeは環境フレームをstd::vectorオブジェクトを格納する形で実装していたが、もしかして、

std::vector内は参照不可能と判断されてしまい、collectされてしまうのではないか思い、以下のような実験コードを書いて検証してみた。

#include <stdio.h>
#include <sys/types.h>
#include <vector>
#include <gc.h>
#include <gc_cpp.h>
#include <gc/gc_allocator.h>

class object : public gc_cleanup
{
public:
    object(size_t d) { data = d; };
    ~object() {
        // GCによって回収されるときにプリント
        fprintf(stdout, "destructor called id (%ld)\n", data);
        fflush(stdout);
    };

    size_t data;
};

int main() {
    GC_INIT();

    std::vector<object*> tes = std::vector<object*>();

    object* item;
    size_t i;

    for (i = 0; i < 10000; i++) {
        item = new object(i);
        tes.push_back(item);
    }

    sleep(2);

    return 0;
}
$ g++ gctest.cc -lgc -o gctest
$ ./gctest
...
... 省略
...
destructor called id (8778)
destructor called id (9417)
destructor called id (8910)
destructor called id (8779)
destructor called id (9416)
destructor called id (8909)
destructor called id (8776)
destructor called id (9419)
destructor called id (8908)
destructor called id (8777)
destructor called id (9418)
  • ものの見事に全部GCされてしまっている。

上記現象を調べてみるとBoehmGCはstd::vectorやstd::mapと併用する場合は、

それらの定義時にgc_allocator<>やtraceable_allocator<>などというものを指定する必要があるらしい。

参考:http://osdir.com/ml/programming.garbage-collection.boehmgc/2004-06/msg00014.html

まだあまりうまく理解できていないが、これは参照を知らせるためのものかなにかだろうか??

とりあえず、テストコードを以下のようにしてみた。

#include <stdio.h>
#include <sys/types.h>
#include <vector>
#include <gc.h>
#include <gc_cpp.h>
#include <gc/gc_allocator.h>

class object : public gc_cleanup
{
public:
    object(size_t d) { data = d; };
    ~object() {
        fprintf(stdout, "destructor called id (%ld)\n", data);
        fflush(stdout);
    };

    void print() {
        fprintf(stdout, " %ld", data);
        fflush(stdout);
    }

    size_t data;
};

int main() {
    GC_INIT();

    std::vector<object*, traceable_allocator<object*> > tes =
        std::vector<object*, traceable_allocator<object*> >();

    object* item;
    size_t i;

    for (i = 0; i < 5000; i++) {
        // まず5000個挿入
        item = new object(i);
        tes.push_back(item);
    }

    for (size_t j = 0; j < 2000; j++) {
        // 2000個削除(参照不能にする)
        tes.pop_back();
    }

    for (; i < 10000; i++) {
        // さらに5000個挿入
        item = new object(i);
        tes.push_back(item);
    }

    sleep(2);

    std::vector<object*, traceable_allocator<object*> >::iterator k;
    fprintf(stdout, "(");

    for (k = tes.begin(); k != tes.end(); k++)
    {
        (*k)->print();
    }
    fprintf(stdout, ")\n");

    sleep(2);

    return 0;
}
$ g++ gctest.cc -lgc -o gctest
$ ./gctest
...
... 省略
...
destructor called id (3906)
destructor called id (3907)
destructor called id (3908)
( 0 1 2 3 ...省略... 2997 2998 2999 5000 5001 5002 ...省略... 9997 9998 9999)
  • ちゃんと参照不能としたもの(3000-4999)のみがGCされている。

この結果をもとにglazeの実装も直したらうまく動いた。

2011-11-26

[]問題4.14 19:40 問題4.14を含むブックマーク

  • はてなDiaryの一日の文字数制限なのか、途中できられていたので書き直す。
;;;
;;; util
;;;

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

;;;
;;; environment
;;;

;basic-proc
(define the-empty-environment '())
(define enclosing-environment cdr)
(define first-frame car)

;frame-proc
(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))))

;env-proc
(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 -- EXTEND_ENVIRONMENT " vars vals)
          (error "Too few arguments supplied -- EXTEND_ENVIRONMENT " vars vals))))

(define (env-loop null-proc find-proc name var env)
  (define (scan vars vals)
    (cond ((null? vars) (null-proc env))
          ((eq? var (car vars)) (find-proc vals))
          (else (scan (cdr vars) (cdr vals)))))
  (if (eq? env the-empty-environment)
      (error "Unbound variable. -- " name " " var)
      (let ((frame (first-frame env)))
        (scan (frame-variables frame)
              (frame-values frame)))))

(define (lookup-variable-value var env)
  (define (null-proc env)
    (env-loop null-proc find-proc "LOOKUP_VARIABLE_VALUE" var (enclosing-environment env)))
  (define (find-proc vals) (car vals))
  (env-loop null-proc find-proc "LOOKUP_VARIABLE_VALUE" var env))

(define (set-variable-value! var val env)
  (define (null-proc env)
    (env-loop null-proc find-proc "SET_VARIABLE_VALUE!" var (enclosing-environment env)))
  (define (find-proc vals) (set-car! vals val))
  (env-loop null-proc find-proc "SET_VARIABLE_VALUE!" var env))

(define (define-variable! var val env)
  (define (null-proc env) (add-binding-to-frame! var val (first-frame env)))
  (define (find-proc vals) (set-car! vals val))
  (env-loop null-proc find-proc "DEFINE_VARIABLE!" var env))

(define (make-unbound-variable! var env)
  (define (env-loop env)
    (define (scan prev-vars vars prev-vals vals)
      (cond ((null? vars)
             (env-loop (enclosing-envrionment env)))
            ((eq? var (car vars))
             (set-cdr! prev-vars (cdr vars))
             (set-cdr! prev-vals (cdr vals)))
            (else (scan (cdr prev-vars) (cdr vars)
                        (cdr prev-vals) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable. -- MAKE_UNBOUND_VARIABLE! " var)
        (let ((frame (first-frame env)))
          (if (eq? var (car (frame-variables frame)))
              (begin
                (set-car! frame (cdr (frame-variables frame)))
                (set-cdr! frame (cdr (frame-values frame))))
              (scan (frame-variables frame) (cdr (frame-variables frame))
                    (frame-values frame) (cdr (frame-values frame)))))))
  (env-loop env))


;;;
;;; procedures
;;;

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

(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 'null? (lambda (x) (if (null? x) 'true 'false)))))

(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)
  (apply ;; in underlying scheme
   (primitive-implementation proc) args))


;;;
;;; table
;;;

(define (make-table)
  (let ((local-table (list '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (cdr record)
                  #f))
            #f)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (set-cdr! record value)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable)))))
            (set-cdr! local-table
                      (cons (list key-1
                                  (cons key-2 value))

                            (cdr local-table)))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

(define the-table (make-table))
(define get (the-table 'lookup-proc))
(define put (the-table 'insert-proc!))

;;;
;;; eval
;;;

(define (self-evaluating? exp)
  (cond ((number? exp) #t)
        ((string? exp) #t)
        (else #f)))
(define variable? symbol?)
(define application? pair?)
(define operator car)
(define operands cdr)
(define first-operand car)
(define rest-operands cdr)
(define no-operands? null?)
(define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (cons (aeval (first-operand exps) env)
            (list-of-values (rest-operands exps) env))))

(define (aeval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        (else
         (let ((proc (get 'eval (car exp))))
           (if proc
               (proc exp env)
               (if (application? exp)
                   (aapply (aeval (operator exp) env)
                           (list-of-values (operands exp) env))
                   (error "Unknown expression type -- EVAL " exp)))))))

(define (install-eval-package)
  ;; quote
  (define (text-of-quotation exp env) (cadr exp))

  ;; set!
  (define (assignment-variable exp) (cadr exp))
  (define (assignment-value exp) (caddr exp))
  (define (eval-assignment exp env)
    (set-variable-value! (assignment-variable exp)
                         (aeval (assignment-value exp) env)
                         env))

  ;; unbind!
  (define (unbind-variable exp) (cadr exp))
  (define (eval-unbind exp env)
    (make-unbound-variable! (unbind-variable exp) env))

  ;; define
  (define (make-lambda parameters body) (cons 'lambda (cons parameters body)))
  (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)
                     (cddr exp))))
  (define (eval-definition exp env)
    (define-variable! (definition-variable exp)
                      (aeval (definition-value exp) env)
                      env)
    'ok)

  ;; util
  (define (first-exp seq) (car seq))
  (define (rest-exps seq) (cdr seq))
  (define (last-exp? seq) (null? (cdr seq)))

  ;; eval-if
  (define (if-predicate exp) (cadr exp))
  (define (if-consequent exp) (caddr exp))
  (define (if-alternative exp)
    (if (not (null? (cdddr exp)))
        (cadddr exp)
        #f))
  (define (eval-if exp env)
    (if (true? (aeval (if-predicate exp) env))
        (begin
          (display "true pass\n")
          (aeval (if-consequent exp) env))
        (begin
          (display "false pass\n")
          (aeval (if-alternative exp) env))))

  ;; lambda
  (define (lambda-parameters exp) (cadr exp))
  (define (lambda-body exp) (cddr exp))
  (define (eval-lambda exp env)
    (make-procedure (lambda-parameters exp)
                    (lambda-body exp)
                    env))

  ;; begin
  (define (eval-sequence exps env)
    (cond ((last-exp? exps) (aeval (first-exp exps) env))
          (else (aeval (first-exp exps) env)
                (eval-sequence (rest-exps exps) env))))
  (define (begin-actions exp) (cdr exp))
  (define (eval-begin exp env)
    (eval-sequence (begin-actions exp) env))

  ;; cond
  (define (cond-clauses exp) (cdr exp))
  (define (cond-predicate clause) (car clause))
  (define (cond-actions clause) (cdr clause))
  (define (cond-else-clause? clause) (eq? (cond-predicate clause) 'else))

  (define (make-begin seq) (cons 'begin seq))
  (define (sequence->exp seq)
    (cond ((null? seq) seq)
          ((last-exp? seq) (first-exp seq))
          (else (make-begin seq))))

  (define (expand-clauses clauses)
    (if (null? clauses)
        'false
        (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))
              (if (eq? (cadr first) '=>)
                  (let ((sym (gensym)))
                    (list 'let (list (list sym (cond-predicate first)))
                          (list 'if
                                sym
                                (list (caddr first) sym)
                                (expand-clauses rest))))
                  (make-if (cond-predicate first)
                           (sequence->exp action)
                           (expand-clauses rest)))))))

  (define (cond->if exp)
    (expand-clauses (cond-clauses exp)))

  (define (eval-cond exp env)
    (aeval (cond->if exp) env))

  ;; and
  (define (eval-and-sequence exps env)
    (if (null? exps)
        'true
        (if (true? (aeval (first-exp exps) env))
            (eval-and-sequence (rest-exps exps) env)
            'false)))
  (define (eval-and exp env)
    (eval-and-sequence (cdr exp) env))

  ;; or
  (define (eval-or-sequence exps env)
    (if (null? exps)
        'false
        (if (true? (aeval (first-exp exps) env))
            'true
            (eval-and-sequence (rest-exps exps) env))))
  (define (eval-or exp env)
    (eval-or-sequence (cdr exp) env))

  ;; let
  (define (let->combination exp)
    (let ((second (cadr exp)))
      (let ((named? (symbol? second)))
        (let ((bindings (if named? (caddr exp) second))
              (body (if named? (cdddr exp) (cddr exp))))
          (let ((vars (map car bindings))
                (exps (map cadr bindings)))
            (if named?
                (list 'let bindings
                      (append (list 'define (append (list second) vars))
                              body)
                      (append (list second) vars))
                (append (list (append (list 'lambda vars) (cddr exp))) exps)))))))

  (define (eval-let exp env)
    (aeval (let->combination exp) env))

  ;; let*
  (define (let*->nested-lets exp)
    (let ((bindings (cadr exp)))
      (let binds->lets ((binds bindings))
        (if (null? (cdr binds))
            (append (list 'let (list (car binds))) (cddr exp))
            (list 'let (list (car binds))
                  (binds->lets (cdr binds)))))))

  (define (eval-let* exp env) (aeval (let*->nested-lets exp) env))

  ;; do
  (define (do->named-let exp)
    (let ((binds (cadr exp))
          (predicate (caaddr exp))
          (value (car (cdaddr exp)))
          (body (cdddr exp)))
      (let ((var-inits (map (lambda (bind) (list (car bind) (cadr bind))) binds))
            (updates (map caddr binds))
            (iter-name (gensym)))
        `(let ,iter-name ,var-inits
              (if ,predicate
                  ,value
                  (begin
                    ,@body
                    (,iter-name ,@updates)))))))

  (define (eval-do exp env)
    (aeval (do->named-let exp) env))

  (put 'eval 'quote text-of-quotation)
  (put 'eval 'set! eval-assignment)
  (put 'eval 'unbind! eval-unbind)
  (put 'eval 'define eval-definition)
  (put 'eval 'if eval-if)
  (put 'eval 'lambda eval-lambda)
  (put 'eval 'begin eval-begin)
  (put 'eval 'and eval-and)
  (put 'eval 'or eval-or)

  ;; jast a macro
  (put 'eval 'cond eval-cond)
  (put 'eval 'let eval-let)
  (put 'eval 'let* eval-let*)
  (put 'eval 'do eval-do)
)
(install-eval-package)

;;;
;;; apply
;;;

(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (last-exp? seq) (null? (cdr seq)))
(define (eval-sequence exps env)
    (cond ((last-exp? exps) (aeval (first-exp exps) env))
          (else (aeval (first-exp exps) env)
                (eval-sequence (rest-exps exps) env))))

(define (aapply 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))))

;;;
;;; true? false?
;;;


(define (true? x) (not (eq? x 'false)))
(define (false? x) (eq? x 'false))

;;;
;;; make
;;;

(define (setup-environment)
  (let ((initial-env
         (extend-environment (primitive-procedure-names)
                             (primitive-procedure-objects)
                             ;the-empty-environment
                             '())))
    (define-variable! 'true 'true initial-env)
    (define-variable! 'false 'false initial-env)
    initial-env))

;;;
;;; repl
;;;

(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 (aeval 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)))



;;;
;;; running !!
;;;

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

(driver-loop)

(define (append x y) (if (null? x) y (cons (car x) (append (cdr x) y))))

(append (quote (a b c)) (quote (d e f)))


;;; 4.14
;; 定義版
(define (map fn lis)
  (if (null? lis)
      '()
      (cons (fn (car lis)) (map fn (cdr lis)))))

(map car (quote ((1 2) (3 4))))
;-> (1 3)

;; プリミティブ版
;; 一度Replを止める。

gosh> (define (map2 fn lis)
        (if (null? lis)
            '()
            (cons (fn (car lis)) (map2 fn (cdr lis)))))

gosh> (define primitive-procedures
        (list (list 'car car)
              (list 'cdr cdr)
              (list 'cons cons)
              (list 'null? (lambda (x) (if (null? x) 'true 'false)))
              (list 'map map2)))

gosh> (define the-global-environment (setup-environment))
gosh> (driver-loop)

;;; M-Eval input:
(map car (quote ((1 2) (3 4))))
*** ERROR: invalid application: ((primitive #<subr car>) (1 2))
Stack Trace:
_______________________________________
  0  fn

  1  (aeval input the-global-environment)
        At line 443 of "(stdin)"


;; mapに渡されてくるのはメタschemeのデータなので、内部でメタschemeのapplyをしてやらねばならない。

2011-11-09

[]4章のメタschemeを参考に、C++scheme処理系を作る。 02:35 4章のメタschemeを参考に、C++でscheme処理系を作る。を含むブックマーク

  • 大体3000行程度のC++になった。
    • もっとも単純な機能のschemeとなっている。macroやcall/ccはない。GCはboehmGCを使用した。
    • C++で作るにあたって、一番違ったのはreaderとobjectだった。
    • そこらへんを見ると参考になるかも。
  • githubにおいた

micro-scheme

[]問題2.77 00:31 問題2.77を含むブックマーク

(magnitude z)

ここで

z -> '(complex rectangular 3 4)

apply-genericでcomplex型のmagnitude関数が呼び出される。

その関数はグローバルのmagnitude関数である。

よってグローバルのmagnitude関数にcomplex型の型情報を剥ぎ取った中身がもう一度渡される。

つまり、(magnitude (contents z))

ここで (contents z) -> '(rectangular 3 4)

なので、apply-genericはrectangular型のmagnitude関数を呼び出す。

それは、install-rectangularで定義された内部関数なので、計算が行われる。

apply-genericは2回呼び出される。

一度目はグローバルのmagnitude関数

二度目はinstall-rectangularで定義された内部関数のmagnitude関数

リスト構造をうまく使っている。

[]問題2.78 00:31 問題2.78を含むブックマーク

(define (type-tag datum)
  (cond ((pair? datum)
         (car datum))
        ((number? datum)
         'scheme-number)
        (else (error "Bat tagged datum -- TYPE-TAG" datum))))

(define (contents datum)
  (cond ((pair? datum) (cdr datum))
        ((number? datum) datum)
        (else (error "Bat tagged datum -- CONTENTS" datum))))

(define (attach-tag type-tag contents)
  (if (eq? type-tag 'scheme-number)
      contents
      (cons type-tag contents)))

[]問題2.79 00:31 問題2.79を含むブックマーク

2章最後までskip

[]問題3.1 00:31 問題3.1を含むブックマーク

(define (make-accumulator base)
  (let ((acc base))
    (lambda (addr)
      (begin (set! acc (+ addr acc))
             acc))))

[]問題3.2 00:31 問題3.2を含むブックマーク

(define (make-monitored func)
  (let ((acc 0))
    (lambda args
      (if (eq? (car args) 'how-many-calls?)
          acc
          (begin
            (set! acc (+ acc 1))
            (apply func args))))))

[]問題3.3 00:31 問題3.3を含むブックマーク

(define (make-account balance password)
  (define (withdraw amount)
    (if (>= balance amount)
        (begin (set! balance (- balance amount))
               balance)
        "Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (define (dispatch pw m)
    (begin (unless (eq? pw password) (error "Incorrect password"))
           (cond ((eq? m 'withdraw) withdraw)
                 ((eq? m 'deposit) deposit)
                 (else (error "Unknown request -- MAKE-ACCOUNT" m)))))
  dispatch)

[]問題3.4 00:31 問題3.4を含むブックマーク

(define (call-the-cops)
  (print "通報しますた!"))

(define (make-account balance password)
  (let ((pwmiss 0))
    (define (withdraw amount)
      (if (>= balance amount)
          (begin (set! balance (- balance amount))
                 balance)
          "Insufficient funds"))
    (define (deposit amount)
      (set! balance (+ balance amount))
      balance)
    (define (dispatch pw m)
      (if (eq? pw password)
          (begin
            (set! pwmiss 0)
            (cond ((eq? m 'withdraw) withdraw)
                  ((eq? m 'deposit) deposit)
                  (else (error "Unknown request -- MAKE-ACCOUNT" m))))
          (begin
            (set! pwmiss (+ pwmiss 1))
            (when (> pwmiss 6) (call-the-cops))
            (error "Incorrect password"))))
    dispatch))

[]問題3.5 00:31 問題3.5を含むブックマーク

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

(use srfi-27)
(define (random lim)
  (* (random-real) lim))

(define (random-in-range low high)
  (+ low (random (- high low))))

(define (estimate-integral p xlow xhigh ylow yhigh trials)
  (define (exp) (p (random-in-range xlow xhigh) (random-in-range ylow yhigh)))
  (let ((d (monte-carlo trials exp)))
    (* (* (- xhigh xlow) (- yhigh ylow)) d)))

(define (estimate-pi trials)
  (let ((area (estimate-integral (lambda (x y) (<= (+ (expt (- x 5) 2) (expt (- y 7) 2)) (* 3 3)))
                                 2 8 4 10
                                 trials)))
    (/ area (* 3.0 3.0))))

;(estimate-pi 10000)
;3.1616
;(estimate-pi 1000000)
;3.141172

[]問題3.6 00:31 問題3.6を含むブックマーク

;ここでは、精度は必要ないので線形合同法をストレートに使う。

(define random-init 8)

(define (rand-update x)
  (remainder (+ (* 3 x) 5) 13))

(define rand
  (let ((x random-init))
    (lambda (op)
      (cond ((eq? op 'generate)
             (begin (set! x (rand-update x))
                    x))
            ((eq? op 'reset)
             (lambda (val) (set! x val) x))
            (else (error "please set generate or reset"))))))

[]問題3.7 00:31 問題3.7を含むブックマーク

(define (make-account balance password)
  (define (withdraw amount)
    (if (>= balance amount)
        (begin (set! balance (- balance amount))
               balance)
        "Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (define (dispatch pw m)
    (begin (unless (eq? pw password) (error "Incorrect password"))
           (cond ((eq? m 'withdraw) withdraw)
                 ((eq? m 'deposit) deposit)
                 (else (error "Unknown request -- MAKE-ACCOUNT" m)))))
  dispatch)

(define (make-joint account pass new-pass)
  (define (joint pw m)
    (begin (unless (eq? pw new-pass) (error "Incorrect password"))
           (account pass m)))
  (account pass 'deposit) ;accesible test
  joint)


(define peter-acc (make-account 1000 'open-sesame))
(define paul-acc (make-joint peter-acc 'open-sesame 'rosebut))

;((peter-acc 'open-sesame 'withdraw) 100)
;900
;((paul-acc 'rosebut 'withdraw) 100)
;800
;((peter-acc 'open-sesame 'withdraw) 100)
;700

[]問題3.8 00:31 問題3.8を含むブックマーク

(define f
  (let ((m 0) (n 0))
    (lambda (x)
      (set! m n)
      (set! n x)
      m)))

[]問題3.9 00:31 問題3.9を含むブックマーク

  • 図はめんどいので飛ばす。
  • 再帰版はすべて横並び
  • 反復版はfact-iterが横並び。

[]問題3.10 00:31 問題3.10を含むブックマーク

  • 図はめんどいので飛ばす。
  • 内部環境の箱が縦に並ぶような形になる。

[]問題3.11 00:31 問題3.11を含むブックマーク

  • 局所手続きの部分もbalanceと同じように、別々に保持される。
  • 基本的に共有されない。

[]問題3.12 00:31 問題3.12を含むブックマーク

;; 1: (a b)
;; 2: (a b c d)

[]問題3.13 00:31 問題3.13を含むブックマーク

  • 最後のcdrに格納されるポインタが、トップをさすような構造。
  • (last-pair z)は無限ループを引き起こす。

[]問題3.14 00:31 問題3.14を含むブックマーク

(define (mystery x)
  (define (loop x y)
    (if (null? x)
        y
        (let ((temp (cdr x)))
          (set-cdr! x y)
          (loop temp x))))
  (loop x '()))

;;リストを破壊的に逆転させる?

(mystery '(1 2 3 4 5))
(5 4 3 2 1)
;; ok

(define v '(a b c d))
(define w (mystery v))
;v -> (a)
;w -> (d c b a)

[]問題3.15 00:31 問題3.15を含むブックマーク

  • 図はめんどう。
  • z1はリスト構造が一つしかなく、それにcar部とcdr部が両方接続しているため、set-car!によってポインタを変更すると両方とも変わる。
  • z2はリスト構造が二つあるため、car部が接続しているリストのcarポインタが変更されるだけである。

[]問題3.16 00:31 問題3.16を含むブックマーク

(define (count-pairs x)
  (if (not (pair? x))
      0
      (+ (count-pairs (car x))
         (count-pairs (cdr x))
         1)))

;;3
(define a (cons 1 (cons 2 (cons 3 '()))))
(count-pairs a)
;-> 3

;;4
(define a (cons '() '()))
(define b (cons '() '()))
(define c (cons '() '()))
(set-car! a c)
(set-cdr! a b)
(set-cdr! c b)
(count-pairs a)
;-> 4

;;7
(define a (cons '() '()))
(define b (cons '() '()))
(define c (cons '() '()))
(set-car! a b)
(set-cdr! a b)
(set-car! b c)
(set-cdr! b c)
(count-pairs a)
;-> 7

;;no-return
(define a (cons '() '()))
(define b (cons '() '()))
(define c (cons '() '()))
(set-cdr! a b)
(set-cdr! b c)
(set-cdr! c a)

(count-pairs a)
;-> 無限ループ

[]問題3.17 00:31 問題3.17を含むブックマーク

(define (count-pairs-2 x)
  (define counted-pairs '())
  (define (add-pair! p)
    (set! counted-pairs (cons p counted-pairs)))
  (define (already-counted? p)
    (memq p counted-pairs))
  (define (iter x)
    (if (or (not (pair? x)) (already-counted? x))
        0
        (begin
          (add-pair! x)
          (+ (iter (car x))
             (iter (cdr x))
             1))))
  (iter x))

;;3.16すべての場合でok

[]問題3.18 00:31 問題3.18を含むブックマーク

(define (include-loop? x)
  (define first-point x)
  (define (iter x)
    (if (null? x)
        #f
        (or (eq? first-point x) (iter (cdr x)))))
  (iter (cdr x)))

;;出来たと思ったが、これだと途中から途中へ循環している場合に対応できない。
(define a '(1 2 3))
(set-cdr! (cddr a) (cdr a))
(include-loop? a)
;-> 無限ループ

(define (include-loop? x)
  (define checked '())
  (define (add-checked! a)
    (set! checked (cons a checked)))
  (define (already-checked? a)
    (not (not (memq a checked))))
  (define (iter x)
    (if (null? x)
        #f
        (begin
          (add-checked! x)
          (or (already-checked? x) (iter (cdr x))))))
  (iter (cdr x)))

(include-loop? a)
;-> #t
; ok

[]問題3.19 00:31 問題3.19を含むブックマーク

; listがループしていなければ、絶対に交わることの無い二つのイテレータによって解決する。
; イテーレータxが2進む間にイテレータyは1進む。
(define (include-loop-2? x)
  (define (iter x y toggle)
    (if (not (pair? x))
        #f
        (if (eq? x y)
            #t
            (iter (cdr x) (if toggle (cdr y) y) (not toggle)))))
  (if (not (pair? x))
      (error "Argument of cycle? must be a pair")
      (iter (cdr x) x #t)))

; ループが存在しなければ、絶対に交わることは無いが、ループが存在すれば、必ず交わる。
; しかし、リスト構造によっては、交わるまで時間がかかる。
; xを一つ前のも保存しておいて比べていくようにすれば、最長の時間が半分になる。と思う。

[]問題3.20 00:32 問題3.20を含むブックマーク

  • 図は面倒

[]問題3.21 00:32 問題3.21を含むブックマーク

(define (front-ptr q) (car q))
(define (rear-ptr q) (cdr q))
(define (set-front-ptr! q i) (set-car! q i))
(define (set-rear-ptr! q i) (set-cdr! q i))


(define (empty-queue? q) (null? (front-ptr q)))
(define (make-queue) (cons '() '()))

(define (front-queue q)
  (if (empty-queue? q)
      (error "FRONT called with an empty queue" q)
      (car (front-ptr q))))

(define (insert-queue! queue item)
  (let ((new-pair (cons item '())))
    (cond ((empty-queue? queue)
           (set-front-ptr! queue new-pair)
           (set-rear-ptr! queue new-pair)
           queue)
          (else
           (set-cdr! (rear-ptr queue) new-pair)
           (set-rear-ptr! queue new-pair)
           queue))))

(define (delete-queue! queue)
  (cond ((empty-queue? queue)
         (error "DELETE! called with an empty queue" queue))
        (else
         (set-front-ptr! queue (cdr (front-ptr queue)))
         queue)))

;キューのデータはlistを使い実装されているため、listとして解釈され表示されてしまう。
;キューの構造的に、情報が二重に登録されているように見える。
(define (print-queue q)
  (print (car q)))

[]問題3.22 00:32 問題3.22を含むブックマーク

(define (make-queue)
  (let ((front-ptr '())
        (rear-ptr '()))
    (define (empty?) (null? front-ptr))
    (define (set-front-ptr! item) (set! front-ptr item))
    (define (set-rear-ptr! item) (set! rear-ptr item))
    (define (insert! item)
      (let ((new-pair (cons item '())))
        (if (empty?)
            (begin (set-front-ptr! new-pair)
                   (set-rear-ptr!  new-pair)
                   #f)
            (begin (set-cdr! rear-ptr new-pair)
                   (set-rear-ptr! new-pair)
                   #f))))
    (define (delete!)
      (if (empty?)
          (error "DELETE! called with an empty queue.")
          (begin (set-front-ptr! (cdr front-ptr))
                 #f)))
    (define (front)
      (if (empty?)
          (error "FRONT called with an empty queue")
          (car front-ptr)))

    (define (print-queue)
      (print front-ptr))

    (define (dispatch m)
      (cond ((eq? m 'insert!) insert!)
            ((eq? m 'delete!) delete!)
            ((eq? m 'front) front)
            ((eq? m 'empty?) empty?)
            ((eq? m 'print) print-queue)
            (else (error "Undefined operation -- " m))))

    dispatch))

(define q1 (make-queue))

((q1 'insert!) 1)

(define q1 (make-queue))
((q1 'insert!) 1)
((q1 'insert!) 2)
((q1 'insert!) 3)
((q1 'insert!) 4)
((q1 'insert!) 5)

((q1 'print))
; -> (1 2 3 4 5)

((q1 'delete!))
((q1 'delete!))
((q1 'delete!))
((q1 'print))
; -> (4 5)

((q1 'insert!) 6)
((q1 'print))
; -> (4 5 6)

[]問題3.23 00:32 問題3.23を含むブックマーク

(cons back-pointer (cons item next-pointer))
;この形を一つのqueueオブジェクトとする。
;項目が3個なのでclosureでやる手もあるが、メモリコピーが多発し消費が激しいためlistのポインタを使う。
;schemeはconsを扱うことでメモリ操作が出来るらしい。

(define (make-deque)
  (let ((front-ptr '())
        (rear-ptr '()))

    (define (next ptr) (cddr ptr))
    (define (back ptr) (car ptr))
    (define (item ptr) (cadr ptr))

    (define (empty?) (or (null? front-ptr) (null? rear-ptr)))

    (define (set-front-ptr! item) (set! front-ptr item))
    (define (set-rear-ptr! item) (set! rear-ptr item))

    (define (insert-front! item)
      (let ((new-queue (cons '() (cons item front-ptr))))
        (if (empty?)
            (begin (set-front-ptr! new-queue)
                   (set-rear-ptr!  new-queue)
                   #f)
            (begin (set-car! front-ptr new-queue)
                   (set-front-ptr! new-queue)
                   #f))))

    (define (insert-rear! item)
      (let ((new-queue (cons rear-ptr (cons item '()))))
        (if (empty?)
            (begin (set-front-ptr! new-queue)
                   (set-rear-ptr!  new-queue)
                   #f)
            (begin (set-cdr! (cdr rear-ptr) new-queue)
                   (set-rear-ptr! new-queue)
                   #f))))

    (define (delete-front!)
      (if (empty?)
          (error "DELETE-FRONT! called with an empty queue.")
          (begin (set-front-ptr! (next front-ptr))
                 (unless (empty?) (set-car! front-ptr '())) ;; send delete request to gc.
                 #f)))

    (define (delete-rear!)
      (if (empty?)
          (error "DELETE-REAR! called with an empty queue.")
          (begin (set-rear-ptr! (back rear-ptr))
                 (unless (empty?) (set-cdr! (cdr rear-ptr) '()))  ;; send delete request to gc.
                 #f)))

    (define (front)
      (if (empty?)
          (error "FRONT called with an empty queue")
          (item front-ptr)))

    (define (rear)
      (if (empty?)
          (error "REAR called with an empty queue")
          (item rear-ptr)))

    (define (print-from-top ptr)
      (if (null? ptr)
          #f
          (begin (display " ")
                 (display (item ptr))
                 (print-from-top (next ptr)))))

    (define (print-from-last ptr)
      (if (null? ptr)
          #f
          (begin (display " ")
                 (display (item ptr))
                 (print-from-last (back ptr)))))

    (define (print-queue . from-last)
      (if (empty?)
          (begin (display "DQ()\n") #f)
          (if (null? from-last)
              (begin (display "DQ(")
                     (print-from-top front-ptr)
                     (display " )\n"))
              (begin (display "DQ (from-last) (")
                     (print-from-last rear-ptr)
                     (display " )\n")))))

    (define (dispatch m)
      (cond ((eq? m 'insert-front!) insert-front!)
            ((eq? m 'insert-rear!) insert-rear!)
            ((eq? m 'delete-front!) delete-front!)
            ((eq? m 'delete-rear!) delete-rear!)
            ((eq? m 'front) front)
            ((eq? m 'rear) rear)
            ((eq? m 'empty?) empty?)
            ((eq? m 'print) print-queue)
            (else (error "Undefined operation -- " m))))

    dispatch))


(define dq1 (make-deque))
((dq1 'print))
((dq1 'insert-front!) 1)


(define dq1 (make-deque))
((dq1 'insert-rear!) 1)
((dq1 'insert-rear!) 2)
((dq1 'insert-rear!) 3)
((dq1 'print))
;-> DQ( 1 2 3 )

((dq1 'insert-front!) 0)
((dq1 'insert-front!) -1)
((dq1 'insert-front!) -2)
((dq1 'print))
;-> DQ( -2 -1 0 1 2 3 )

((dq1 'print) #t)
;-> DQ (from-last) ( 3 2 1 0 -1 -2 )

((dq1 'delete-front!))
((dq1 'delete-front!))
((dq1 'print))
;-> DQ( 0 1 2 3 )

((dq1 'delete-rear!))
((dq1 'delete-rear!))
((dq1 'print))
;-> DQ( 0 1 )

((dq1 'delete-front!))
((dq1 'print))
;-> DQ( 1 )

((dq1 'delete-front!))
((dq1 'print))
;-> DQ()

((dq1 'delete-front!))
; *** ERROR: DELETE-FRONT! called with an empty queue.

;ok!

[]問題3.24 00:32 問題3.24を含むブックマーク

(define (make-table same-key?)
  (let ((local-table (list '*table*)))
    (define (assoc2 key records test)
      (cond ((null? records) #f)
            ((test key (caar records)) (car records))
            (else (assoc2 key (cdr records) test))))
    (define (lookup key-1 key-2)
      (let ((subtable (assoc2 key-1 (cdr local-table) same-key?)))
        (if subtable
            (let ((record (assoc2 key-2 (cdr subtable) same-key?)))
              (if record
                  (cdr record)
                  #f))
            #f)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc2 key-1 (cdr local-table) same-key?)))
        (if subtable
            (let ((record (assoc2 key-2 (cdr subtable) same-key?)))
              (if record
                  (set-cdr! record value)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable)))))
            (set-cdr! local-table
                      (cons (list key-1
                                  (cons key2 value))
                            (cdr local-table)))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))


(define (lookup))
(define (insert!))

[]問題3.25 00:32 問題3.25を含むブックマーク

(define (make-table same-key?)
  (let ((local-table (list '*table*)))

    (define (assoc2 key records test)
      (cond ((null? records) #f)
            ((test key (caar records)) (car records))
            (else (assoc2 key (cdr records) test))))

    (define (lookup-iter keys table)
      (if (null? keys)
          (cdr table)
          (let ((subtable (assoc2 (car keys) (cdr table) same-key?)))
            (if subtable
                (lookup-iter (cdr keys) subtable)
                #f))))

    (define (lookup keys)
      (lookup-iter keys local-table))

    (define (compose-table keys value)
      (if (null? (cdr keys))
          (cons (car keys) value)
          (list (car keys) (compose-table (cdr keys) value))))

    (define (insert!-iter keys value table)
      (let ((subtable (assoc2 (car keys) (cdr table) same-key?)))
        (if subtable
            (if (null? (cdr keys)) ;; is this last-key?
                (set-cdr! subtable value)
                (insert!-iter (cdr keys) value subtable))
            (set-cdr! table
                      (cons (compose-table keys value)
                            (cdr table))))))

    (define (insert! keys value)
      (insert!-iter keys value local-table)
      'ok)

    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

(define ot (make-table eq?))
(define get (ot 'lookup-proc))
(define put (ot 'insert-proc!))

(get '(a b c))
; -> #f
(put '(a b c) 'a-b-c-value)
(put '(a d c) 'a-d-c-value)
(put '(c d e f) 'c-d-e-f-value)
(put '(x y z) 'x-y-z-value)

(get '(a b c))
;a-b-c-value
(get '(a d c))
;a-d-c-value
(get '(x y z))
;x-y-z-value

(get '(c d e f))
;c-d-e-f-value

[]問題3.26 00:32 問題3.26を含むブックマーク

(define (make-table)
  (let ((local-table (cons '*table* '())))

    (define (make-tree entry left right) (list entry left right))
    (define (entry tree) (car tree))
    (define (left-branch tree) (cadr tree))
    (define (right-branch tree) (caddr tree))
    (define (key record) (car record))
    (define (value record) (cdr record))
    (define (update! record new-value) (set-cdr! record new-value))

    (define (assoc3 given-key records)
      (if (null? records) #f
          (let ((record (entry records)))
            (cond ((= given-key (key record)) record)
                  ((< given-key (key record)) (assoc3 given-key (left-branch records)))
                  ((> given-key (key record)) (assoc3 given-key (right-branch records)))))))

    (define (adjoin-tree! rec tree)
      (if (null? tree)
          (error "ADJOIN-TREE! called with nil. this is not a tree.")
          (let ((record (entry tree)))
            (cond ((= (key rec) (key record)) (update! record (value rec)))
                  ((< (key rec) (key record))
                   (if (null? (left-branch tree))
                       (set-car! (cdr tree) (make-tree rec '() '()))
                       (adjoin-tree! rec (left-branch tree))))
                  ((> (key rec) (key record))
                   (if (null? (right-branch tree))
                       (set-car! (cddr tree) (make-tree rec '() '()))
                       (adjoin-tree! rec (right-branch tree))))))))

    (define (lookup-iter keys table)
      (if (null? keys)
          (value table)
          (let ((subtable (assoc3 (car keys) (value table))))
            (if subtable
                (lookup-iter (cdr keys) subtable)
                #f))))

    (define (lookup keys)
      (lookup-iter keys local-table))

    (define (compose-table keys value)
      (if (null? (cdr keys))
          (cons (car keys) value)
          (cons (car keys) (make-tree (compose-table (cdr keys) value) '() '()))))

    (define (insert!-iter keys given-value table)
      (let ((subtable (assoc3 (car keys) (value table))))
        (if subtable
            (if (null? (cdr keys)) ;; is this last-key?
                (update! subtable given-value)
                (insert!-iter (cdr keys) given-value subtable))
            (if (null? (value table))
                (set-cdr! table (make-tree (compose-table keys given-value) '() '()))
                (adjoin-tree! (compose-table keys given-value)
                              (value table))))))

    (define (insert! keys value)
      (insert!-iter keys value local-table)
      'ok)

    (define (show)
      local-table)

    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            ((eq? m 'show) show)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

(define tree-table (make-table))
(define get (tree-table 'lookup-proc))
(define put (tree-table 'insert-proc!))

(put '(1 2 3 4) 'v-1-2-3-4)
(put '(1 2 3 5) 'v-1-2-3-5)
(put '(1 2 3 2) 'v-1-2-3-2)
(put '(1 2 3 3) 'v-1-2-3-3)
(put '(1 2 3 123) 'v-1-2-3-123)
(put '(1 2 3 6) 'v-1-2-3-6)
; -> ok
((tree-table 'show))
; -> (*table* (1 (2 (3 (4 . v-1-2-3-4) ((2 . v-1-2-3-2) () ((3 . v-1-2-3-3) () ())) ((5 . v-1-2-3-5) () ((123 . v-1-2-3-123) ((6 . v-1-2-3-6) () ()) ()))) () ()) () ()) () ())
(get '(1 2 3 4))
; -> v-1-2-3-4
(put '(1 2 2) 'v-1-2-2)
; -> ok
(get '(1 2 2))
; -> v-1-2-2
((tree-table 'show))
; -> (*table* (1 (2 (3 (4 . v-1-2-3-4) ((2 . v-1-2-3-2) () ((3 . v-1-2-3-3) () ())) ((5 . v-1-2-3-5) () ((123 . v-1-2-3-123) ((6 . v-1-2-3-6) () ()) ()))) ((2 . v-1-2-2) () ()) ()) () ()) () ())

;; ok!
;; 大変だった。
;; 実用的には定期的に木をつりあわせる演算が必要だろう。

[]問題3.27 00:32 問題3.27を含むブックマーク

(define (fib n)
  (cond ((= n 0) 0)
        ((= n 1) 1)
        (else (+ (fib (- n 1))
                 (fib (- n 2))))))

;(time (fib 35))
; real   3.050
; user   3.010
; sys    0.040
9227465

(define (memorize f)
  (let ((table (make-table)))
    (let ((get (table 'lookup-proc))
          (put (table 'insert-proc!)))
      (lambda (x)
        (let ((previously-computed-result (get (list x))))
          (or previously-computed-result
              (let ((result (f x)))
                (put (list x) result)
                result)))))))

(define memo-fib
  (memorize (lambda (n)
              (cond ((= n 0) 0)
                    ((= n 1) 1)
                    (else (+ (memo-fib (- n 1))
                             (memo-fib (- n 2))))))))

;(time (memo-fib 35))
; real   0.000
; user   0.000
; sys    0.000
9227465

;引数自身以下の計算をすべてそのまま計算しなおすようなアルゴリズムなので、
;メモ化するとすべてそのままルックアップすればすむので。

(define memo-fib
  (memorize fib))

;では働かない。

(define fib
  (memorize fib))

;ならおk。

[]問題3.28 00:32 問題3.28を含むブックマーク

(define a (make-wire))
(define b (make-wire))
(define c (make-wire))
(define d (make-wire))
(define e (make-wire))
(define s (make-wire))

(or-gate a b d)
(and-gate a b c)
(inverter c e)
(and-gate d e s)

(define (half-adder a b s c)
  (let ((d (make-wire)) (e (make-wire)))
    (or-gate a b d)
    (and-gate a b c)
    (inverter c e)
    (and-gate d e s)
    'ok))

(define (full-adder a b c-in sum c-out)
  (let ((s (make-wire))
        (c1 (make-wire))
        (c2 (make-wire)))
    (half-adder b c-in s c1)
    (half-adder a s sum c2)
    (or-gate c1 c2 c-out)
    'ok))

(define (logical-not s)
  (cond ((= s 0) 1)
        ((= s 1) 0)
        (else (error "Invalid signal" s))))
(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-and x y)
  (if (and (number? x) (number? y))
      (if (and (= x 1) (= y 1)) 1 0)
      (error "IN LOGICAL-AND: Invalid signal.")))
(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)
  • 問題
(define (logical-or x y)
  (if (and (number? x) (number? y))
      (if (or (= x 1) (= y 1)) 1 0)
      (error "IN LOGICAL-OR: Invalid signal.")))
(define (or-gate a1 a2 output)
  (define (or-action-procedure)
    (let ((new-value
           (logical-or (get-signal a1) (get-signal a2))))
      (after-delay or-gate-delay
                   (lambda ()
                     (set-signal! output new-value)))))
  (add-action! a1 or-action-procedure)
  (add-action! a2 or-action-procedure))

[]問題3.29 00:32 問題3.29を含むブックマーク

;;意外と思いつかなかった。20分も悩んだ。
(define (or-gate a1 a2 output)
  (let ((a3 (make-wire))
        (a4 (make-wire))
        (o1 (make-wire)))
    (inverter a1 a3)
    (inverter a2 a4)
    (and-gate a3 a4 o1)
    (inverter o1 output)
    'ok))

;;遅延時間は
(+ (* inverter-delay 2) and-gate-delay)
;;になる。

[]問題3.30 00:32 問題3.30を含むブックマーク

(define (ripple-carry-adder ak bk sk c)
  (let ((ck (map (lambda (x) (make-wire)) sk)))
    (let iter (ak bk sk ck)
      (if (null? (cdr ck))
          (full-adder (car ak) (car bk) (car ck) (car sk) c)
          (begin
            (full-adder (car ak) (car bk) (car ck) (car sk) (cadr ck))
            (iter (cdr ak) (cdr bk) (cdr sk) (cdr ck)))))
    (iter ak bk sk ck)
    (set-signal! (car ck) 0)))


;; ripple-carry-adder-delay は
;; (* (+ (* and-gate-delay 4) (* or-gate-delay 3) (* inverter-delay 2)) n)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (call-each procedures)
  (if (null? procedures)
      'done
      (begin
        ((car procedures))
        (call-each (cdr procedures)))))

(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 'get-signal) signal-value)
            ((eq? m 'set-signal!) set-my-signal!)
            ((eq? m 'add-action!) accept-action-procedure!)
            (else (error "Unknown operation -- WIRE" m))))

    dispatch))

(define (get-signal wire) (wire 'get-signal))
(define (set-signal! wire new-value) ((wire 'set-signal!) new-value))
(define (add-action! wire action-procedure) ((wire 'add-action!) action-procedure))

(define (after-delay delay action)
  (add-to-agenda! (+ delay (current-time the-agenda))
                  action
                  the-agenda))

(define (propagate)
  (if (empty-agenda? the-agenda)
      'done
      (let ((first-item (first-agenda-item the-agenda)))
        (first-item)
        (remove-first-agenda-item! the-agenda)
        (propagate))))

(define (probe name wire)
  (add-action! wire
               (lambda ()
                 (display name)
                 (display " ")
                 (display (current-time the-agenda))
                 (display " New-value = ")
                 (display (get-signal wire))
                 (newline))))

(define the-agenda (make-agenda))
(define inverter-delay 2)
(define and-gate-delay 3)
(define or-gate-delay 5)
(define input-1 (make-wire))
(define input-2 (make-wire))
(define sum (make-wire))
(define carry (make-wire))

(probe 'sum sum)
(probe 'carry carry)

(half-adder input-1 input-2 sum carry)
(set-signal! input-1 1)
(propagate)

(set-signal! input-2 1)
(propagate)

[]問題3.31 00:32 問題3.31を含むブックマーク

;wireの実装上、信号が切り替わったときにしか登録したactionは実行されないため、
;もし、ある回路シミュレーターの入力値が変化しなかった場合、出力側が正しくない値だったとしても、actionが実行されず修正されないことが起こりうる。
;よって初めに、回路シミュレーターの入力と出力の値を対応しあった正しい状態に初期化する必要がある。
;(define (accept-action-procedure! proc) (set! action-procedures (cons proc action-procedures))) とした場合
;上記の理由から、inverterのactionが働かず、出力側が初期化されずに間違った値となるため、正しく計算が出来ずsumが変化しない。


(define (make-time-segment time queue) (cons time queue))
(define (segment-time s) (car s))
(define (segment-queue s) (cdr s))

(define (make-agenda) (list 0))
(define (current-time agenda) (car agenda))
(define (set-current-time! agenda time) (set-car! agenda time))
(define (segments agenda) (cdr agenda))
(define (set-segments! agenda segments) (set-cdr! agenda segments))
(define (first-segment agenda) (car (segments agenda)))
(define (rest-segments agenda) (cdr (segments agenda)))

(define (empty-agenda? agenda)
  (null? (segments agenda)))

(define (add-to-agenda! time action agenda)
  (define (belongs-before? segments)
    (or (null? segments)
        (< time (segment-time (car segments)))))
  (define (make-new-time-segment time action)
    (let ((q (make-queue)))
      (insert-queue! q action)
      (make-time-segment time q)))
  (define (add-to-segments! segments)
    (if (= (segment-time (car segments)) time)
        (insert-queue! (segment-queue (car segments))
                       action)
        (let ((rest (cdr segments)))
          (if (belongs-before? rest)
              (set-cdr!
               segments
               (cons (make-new-time-segment time action)
                     (cdr segments)))
              (add-to-segments! rest)))))
  (let ((segments (segments agenda)))
    (if (belongs-before? segments)
        (set-segments!
         agenda
         (cons (make-new-time-segment time action)
               segments))
        (add-to-segments! segments))))

(define (remove-first-agenda-item! agenda)
  (let ((q (segment-queue (first-segment agenda))))
    (delete-queue! q)
    (if (empty-queue? q)
        (set-segments! agenda (rest-segments agenda)))))

(define (first-agenda-item agenda)
  (if (empty-agenda? agenda)
      (error "Agenda is empty -- FIRST-AGENDA-ITEM")
      (let ((first-seg (first-segment agenda)))
        (set-current-time! agenda (segment-time first-seg))
        (front-queue (segment-queue first-seg)))))


(define (make-queue)
  (let ((front-ptr '())
        (rear-ptr '()))
    (define (empty?) (null? front-ptr))
    (define (set-front-ptr! item) (set! front-ptr item))
    (define (set-rear-ptr! item) (set! rear-ptr item))
    (define (insert! item)
      (let ((new-pair (cons item '())))
        (if (empty?)
            (begin (set-front-ptr! new-pair)
                   (set-rear-ptr!  new-pair)
                   #f)
            (begin (set-cdr! rear-ptr new-pair)
                   (set-rear-ptr! new-pair)
                   #f))))
    (define (delete!)
      (if (empty?)
          (error "DELETE! called with an empty queue.")
          (begin (set-front-ptr! (cdr front-ptr))
                 #f)))
    (define (front)
      (if (empty?)
          (error "FRONT called with an empty queue")
          (car front-ptr)))

    (define (print-queue)
      (print front-ptr))

    (define (dispatch m)
      (cond ((eq? m 'insert!) insert!)
            ((eq? m 'delete!) delete!)
            ((eq? m 'front) front)
            ((eq? m 'empty?) empty?)
            ((eq? m 'print) print-queue)
            (else (error "Undefined operation -- " m))))

    dispatch))

(define (insert-queue! queue item)
  ((queue 'insert!) item))

(define (delete-queue! queue)
  ((queue 'delete!)))

(define (empty-queue? queue)
  ((queue 'empty?)))

(define (front-queue queue)
  ((queue 'front)))

[]問題3.32 00:32 問題3.32を含むブックマーク

(define the-agenda (make-agenda))
(define a1 (make-wire))
(define a2 (make-wire))
(define output (make-wire))
(probe 'a1 a1)
(probe 'a2 a2)
(probe 'output output)
(and-gate a1 a2 output)
(set-signal! a1 0)
(set-signal! a2 1)
(propagate)
(set-signal! a1 1) ;; ここで、a1 = 1, a2 = 1, output = 1
(set-signal! a2 0) ;; ここで、a1 = 1, a2 = 0, output = 0
(propagate)


;; 登録されるキューごとに、それが作られた時のinputのsignal状態がクロージャーとして記憶されているため、それが逆順で呼び出されると、
;; 初めにactionが呼び出された時の環境でのoutputの状態が、最終的なoutputの状態として設定されてしまうため。
;;
;; たとえば、and-gateではand-action-procedureの中で、get-signalで回線の状態をとって計算しnew-valueをつくり、after-delayの中でクロージャとして保存している。
(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)
;;
;; ここで、
;; a1が0。a2が1の状態で、
;; (set-signal! a1 1)
;; (set-signal! a2 0)
;; とした場合、まず、
;; (set-signal! a1 1)
;; この式を実行した時点では、a1もa2も1の状態なので、new-valueは1となりこの時点でクロージャが生成される、実行される関数では1がset-signal!される。
;; そしてこの関数が初めに登録される。
;; その後、
;; (set-signal! a2 0)
;; が行われ、new-valueは0である。次の関数はこの0をset-signal!する。この関数が次に登録される。
;; 'queue( (lambda () (set-signal! output 1)) (lambda () (set-signal! output 0)) )
;; ここで、
;; queueの呼び出し順序が逆転した場合、後の環境で作られたクロージャーが先に呼び出されることになる。
;; つまり,(lambda () (set-signal! output 0))が初めに呼び出されてしまう。
;; 後に呼び出されるのは、前の環境(a1=1,b1=1)で作られたクロージャーであり、(lambda () (set-signal! output 1))が呼び出される。
;; a1 = 1, a2 = 0 であるにもかかわらず、outputが1となってしまい、and-gateの意図する動作とは変わってしまう。

[]問題3.33 00:32 問題3.33を含むブックマーク

(define (averager a b c)
  (let ((d (make-connector))
        (e (make-connector)))
    (adder a b d)
    (multiplier d e c)
    (constant 0.5 e)
    'ok))

(define a (make-connector))
(define b (make-connector))
(define c (make-connector))
(averager a b c)
(probe "A" a)
(probe "B" b)
(probe "Average" c)

(set-value! a 3 'user)
(set-value! b 5 'user)
;Probe: Average = 4.0

(forget-value! a 'user)
(forget-value! b 'user)

(set-value! a 3 'user)
(set-value! c 4 'user)
;Probe: B = 5.0

;; こんなやり方は初めて知った。
;; 一つ一つの端点がネットワーク化されて他に情報伝達することによって動く。
;; 制約プログラミング/論理型プログラミングというらしい。
;; かなり感動的だ。プログラミング観がちょっと変わった気がする。

[]問題3.34 00:32 問題3.34を含むブックマーク

(define (squarer a b) (multiplier a a b))
(define a (make-connector))
(define b (make-connector))

(squarer a b)
(probe "A" a)
(probe "B" b)

(set-value! a -3 'user)
;Probe: B = 9

(forget-value! a 'user)
(set-value! b 9 'user)
;Probe: B = 9
;; --> aが表示されない。

;; 計算の双方向性、無方向性が崩れる。aが決定したときにbは算出できるが、bが決定してもaが算出できない。
;; なぜなら、multiplierは m1 m2 productをとり二つの値が存在するとき、もう一つの値が計算できる。
;; このことにより、計算の双方向性を担保しているため、m1 m2に同じものを指定してしまうと、 squarerのbが決定した場合に、aが決定できないからである。
;; multiplierは 少なくとも二つの決定した値が必要である、m1, m2が不定となるとproductからだけでは計算できない。

[]問題3.35 00:32 問題3.35を含むブックマーク

(define (squarer a b)
  (define (process-new-value)
    (if (has-value? b)
        (if (< (get-value b) 0)
            (error "square less than 0 -- SQUARER" (get-value b))
            (set-value! a
                        (sqrt (get-value b))
                        me))
        (if (has-value? a)
            (set-value! b
                        (* (get-value a) (get-value a))
                        me))))
  (define (process-forget-value)
    (forget-value! a me)
    (forget-value! b 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 -- SQUARER" request))))
  (connect a me)
  (connect b me)
  me)

(define a (make-connector))
(define b (make-connector))

(squarer a b)
(probe "A" a)
(probe "B" b)

(set-value! a -3 'user)
;Probe: A = -3
;Probe: B = 9
;done

(forget-value! a 'user)
(set-value! b 9 'user)
;Probe: B = 9
;Probe: A = 3.0
;done

;; Aは-3の可能性もあると思うのだが、、、どうするのだろう。

[]問題3.36 00:32 問題3.36を含むブックマーク

  • 図は面倒
    • 心の中に思い描いた。

[]問題3.37 00:32 問題3.37を含むブックマーク

(define (subtracter a b c) (adder c b a))
(define (divider a b c) (multiplier c b a))

(define (c+ x y)
  (let ((z (make-connector)))
    (adder x y z)
    z))

(define (c- x y)
  (let ((z (make-connector)))
    (subtracter x y z)
    z))

(define (c* x y)
  (let ((z (make-connector)))
    (multiplier x y z)
    z))

(define (c/ x y)
  (let ((z (make-connector)))
    (divider x y z)
    z))

(define (cv x)
  (let ((y (make-connector)))
    (constant x y)
    y))

;;;;;;; test

(define (celsius-fahrenheit-converter x)
  (c+ (c* (c/ (cv 9) (cv 5))
          x)
      (cv 32)))

(define C (make-connector))
(define F (celsius-fahrenheit-converter C))

(probe "Celsius temp" C)
(probe "Fahrenheit temp" F)

(set-value! C 25 'user)
;Probe: Celsius temp = 25
;Probe: Fahrenheit temp = 77
;done

(set-value! F 212 'user)
;*** ERROR: Contradiction (77 212)

(forget-value! C 'user)
;Probe: Celsius temp = ?
;Probe: Fahrenheit temp = ?
;done

(set-value! F 212 'user)
;Probe: Fahrenheit temp = 212
;Probe: Celsius temp = 100
;done

;;ok!!

[]問題3.38 00:32 問題3.38を含むブックマーク

  • 並列性の問題は一時とばす。
  • 後で必ず戻る。
  • 4章までワープ

[]問題4.1 00:32 問題4.1を含むブックマーク

;; 4.1
;L->R
(define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (let ((val (eval (first-operand exps) env)))
        (cons val (list-of-values (rest-operands exps) env)))))

;R->L
(define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (let ((val (list-of-values (rest-operands exps) env)))
        (cons (eval (first-operand exps) env) val))))

[]問題4.2 00:32 問題4.2を含むブックマーク

(define (eval exp env)
  (cond ((self-evaluationg? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((quoted? exp) (text-of-quotation exp))
        ((assignment? exp) (eval-assignment exp env))

        ((call? exp)
         (apply (eval (operator exp) env)
                (list-of-values (operands 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))
        (else
         (error "Unknown expression type -- EVAL" exp))))

(define (call? exp)
  (tagged-list? exp 'call))

[]問題4.3 00:32 問題4.3を含むブックマーク

(define (eval exp env)
  (cond ((self-evaluationg? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        (else
         (let ((proc (get 'eval (car exp))))
           (if proc
               (proc exp env)
               (if (application? exp)
                   (apply (eval (operator exp) env)
                          (list-of-values (operands exp) env))
                   (error "Unknown expression type -- EVAL " exp)))))))

(define (install-eval-package)
  ;; quote
  (define (text-of-quotation exp env) (cadr exp))

  ;; set!
  (define (assignment-variable exp) (cadr exp))
  (define (assignment-value exp) (caddr exp))
  (define (eval-assignment exp env)
    (set-variable-value! (assignment-variable exp)
                         (eval (assignment-value exp) env)
                         env))

  ;; define
  (define (definition-variable exp)
    (if (symbol? (cadr exp))
        (cadr exp)
        (caddr exp)))
  (define (eval-definition exp env)
    (define-variable! (definition-variable exp)
                      (eval (definition-value exp) env)
                      env)
    'ok)

  ;; eval-if
  (define (if-predicate exp) (cadr exp))
  (define (if-consequent exp) (caddr exp))
  (define (if-alternative exp)
    (if (not (null? (cdddr exp)))
        (cadddr exp)
        #f))
  (define (eval-if exp env)
    (if (true? (eval (if-predicate exp) env))
        (eval (if-consequent exp) env)
        (eval (if-alternative exp) env)))

  ;; lambda
  (define (lambda-parameters exp) (cadr exp))
  (define (lambda-body exp) (cddr exp))
  (define (make-lambda parameters body)
    (cons 'lambda (cons parameters body)))
  (define (eval-lambda exp env)
    (make-procedure (lambda-parameters exp)
                    (lambda-body exp)
                    env))

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

  ;; cond
  (define (cond->if exp)
    (expand-clauses (cond-clauses exp)))
  (define (expand-clauses clauses)
    (if (null? clauses)
        'false
        (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))))))
  (define (eval-cond exp env)
    (eval (cond->if exp) env))

  (put 'eval 'quote text-of-quotation)
  (put 'eval 'set! eval-assignment)
  (put 'eval 'define eval-definition)
  (put 'eval 'if eval-if)
  (put 'eval 'lambda eval-lambda)
  (put 'eval 'begin eval-begin)
  (put 'eval 'cond eval-cond))

(define (make-table)
  (let ((local-table (list '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (cdr record)
                  #f))
            #f)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (set-cdr! record value)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable)))))
            (set-cdr! local-table
                      (cons (list key-1
                                  (cons key2 value))

                            (cdr local-table)))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

(define the-table (make-table))
(define get (the-table 'lookup-proc))
(define put (the-table 'insert-proc!))

[]問題4.4 00:32 問題4.4を含むブックマーク

(define (eval-and-sequence exps env)
  (if (null? exps)
      'true
      (if (true? (eval (first-exp exps) env))
          (eval-and-sequence (rest-exps exps) env)
          'false)))
(define (eval-and exp env)
  (eval-and-sequence (cdr exp) env))
(put 'eval 'and eval-and)

(define (eval-or-sequence exps env)
  (if (null? exps)
      'false
      (if (true? (eval (first-exp exps) env))
          'true
          (eval-and-sequence (rest-exps exps) env))))
(define (eval-or exp env)
  (eval-or-sequence (cdr exp) env))
(put 'eval 'or eval-or)

[]問題4.5 00:32 問題4.5を含むブックマーク

(define (cond->if exp)
  (expand-clauses (cond-clauses exp)))
(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))

(define (cond-clauses exp) (cdr exp))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond-else-clause? clause) (eq? (cond-predicate clause) 'else))

(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (last-exp? seq) (null? (rest-exps seq)))
(define (make-begin seq (cons 'begin seq)))
(define (sequence->exp seq)
  (cond ((null? seq) seq)
        ((last-exp? seq) (first-exp seq))
        (else (make-begin seq))))

(define (expand-clauses clauses)
  (if (null? clauses)
      'false
      (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)
                     (let ((action (cond-actions first))
                           (predicate (cond-predicate first)))
                       (if (eq? (car action) '=>)
                           (list (cadr action) predicate)
                           (sequence->exp action)))

                     (expand-clauses rest))))))

;; と書きたいところだが、これだと、 (cond-predicate first) がダブっているため、predicate文に副作用のあるコードだとわかりにくいバグを仕込むことになる。

;; たとえば、
(cond->if '(cond ((x #f) => (lambda (y) (print "(x #f)='" y "' is true !.")))
                 (else '())))

;=> (if (x #f) ((lambda (y) (print "(x #f)='" y "' is true !.")) (x #f)) '())

(define x
  (let ((z #t))
    (lambda (y)
      (let ((buf z))
        (set! z y)
        buf))))

(eval '(if (x #f) ((lambda (y) (print "(x #f)='" y "' is true !.")) (x #f)) '()) '())
;=> (x #f)='#f' is true !.


;; よってこうやる。
(define (expand-clauses clauses)
  (if (null? clauses)
      'false
      (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))
            (if (eq? (cadr first) '=>)

                (let ((sym (gensym)))
                  (list 'let (list (list sym (cond-predicate first)))
                        (list 'if
                              sym
                              (list (caddr first) sym)
                              (expand-clauses rest))))

                (make-if (cond-predicate first)
                         (sequence->exp action)
                         (expand-clauses rest)))))))


;; これで
(cond->if '(cond ((x #f) => (lambda (y) (print "(x #f)='" y "' is true !.")))
                 (else '())))

;=> (let ((G1 (x #f))) (if G1 ((lambda (y) (print "(x #f)='" y "' is true !.")) G1) '()))

(define x
  (let ((z #t))
    (lambda (y)
      (let ((buf z))
        (set! z y)
        buf))))

(eval '(let ((G1 (x #f))) (if G1 ((lambda (y) (print "(x #f)='" y "' is true !.")) G1) '())) '())
;(x #f)='#t' is true !.

;; ok !
;;どちらにせよ (gensym) は必要。これが正解!

[]問題4.6 00:32 問題4.6を含むブックマーク

(define (let->combination exp)
  (let ((bindings (cadr exp)))
    (let ((vars (map car bindings))
          (exps (map cadr bindings)))
      (append (list (append (list 'lambda vars) (cddr exp))) exps))))

(define (eval-let exp env)
  (eval (let->combitation exp) env))

(put 'eval 'let eval-let)

[]問題4.7 00:32 問題4.7を含むブックマーク

(let* ((x 3)
       (y (+ x 2))
       (z (+ x y 5)))
  (* x z))

;=>

(let ((x 3))
  (let ((y (+ x 2)))
    (let ((z (+ x y 5)))
      (* x z))))


(define (let*->nested-lets exp)
  (let ((bindings (cadr exp)))
    (let binds->lets ((binds bindings))
      (if (null? (cdr binds))
          (append (list 'let (list (car binds))) (cddr exp))
          (list 'let (list (car binds))
                (binds->lets (cdr binds)))))))


(define (eval-let* exp env)
  (eval (let*->nested-lets exp) env))

(put 'eval 'let* eval-let*)

;; これだけで十分なはず。

[]問題4.8 00:32 問題4.8を含むブックマーク

(define (fib n)
  (let fib-iter ((a 1)
                 (b 0)
                 (count n))
    (if (= count 0)
        b
        (fib-iter (+ a b) a (- count 1)))))

;; ->

(define (fib n)
  (let ((a 1) (b 0) (count n))
    (define (fib-iter a b count)
      (if (= count 0)
          b
          (fib-iter (+ a b) a (- count 1))))
    (fib-iter a b count)))

;; こんな感じに変換できればいいかな。

(define (let->combination exp)
  (let ((second (cadr exp)))
    (let ((named? (symbol? second)))
      (let ((bindings (if named? (caddr exp) second))
            (body (if named? (cdddr exp) (cddr exp))))
        (let ((vars (map car bindings))
              (exps (map cadr bindings)))
          (if named?
              (list 'let bindings
                    (append (list 'define (append (list second) vars))
                            body)
                    (append (list second) vars))
              (append (list (append (list 'lambda vars) (cddr exp))) exps)))))))

(define (eval-let exp env)
  (eval (let->combitation exp) env))

(put 'eval 'let eval-let)

(let->combination
 '(let fib-iter ((a 1)
                 (b 0)
                 (count n))
    (if (= count 0)
        b
        (fib-iter (+ a b) a (- count 1)))))

;->
;(let ((a 1) (b 0) (count n))
;  (define (fib-iter a b count)
;    (if (= count 0)
;        b
;        (fib-iter (+ a b) a (- count 1))))
;  (fib-iter a b count))

;; ok !!

[]問題4.9 00:32 問題4.9を含むブックマーク

;; doを作ってみる
(do binds (predicate value) body)
;; である。
;; binds部は
((var-name initialize-value update-expression) ... )
;; である。

(do ((var-name1 initialize-value1 update-expression1)
     (var-name2 initialize-value2 update-expression2))
    (predicate value)
  body)

;; ->

(let iter ((var-name1 initialize-value1)
           (var-name2 initialize-value2))
  (if predicate
      value
      (begin
        body
        (iter update-expression1 update-expression2))))

;; となるとよい。
(define (do->named-let exp)
  (let ((binds (cadr exp))
        (predicate (caaddr exp))
        (value (car (cdaddr exp)))
        (body (cdddr exp)))
    (let ((var-inits (map (lambda (bind) (list (car bind) (cadr bind))) binds))
          (updates (map caddr binds))
          (iter-name (gensym)))
      `(let ,iter-name ,var-inits
            (if ,predicate
                ,value
                (begin
                  ,@body
                  (,iter-name ,@updates)))))))

(define (eval-do exp env)
  (eval (do->named-let exp) env))

(put 'eval 'do eval-do)


(do->named-let
 '(do ((var-name1 initialize-value1 update-expression1)
       (var-name2 initialize-value2 update-expression2))
      (predicate value)
    body))

;; ->
;(let G2 ((var-name1 initialize-value1)
;         (var-name2 initialize-value2))
;  (if predicate
;      value
;      (begin
;        body
;        (G2 update-expression1 update-expression2))))

;; ok

(let fib-iter ((a 1)
                 (b 0)
                 (count n))
    (if (= count 0)
        b
        (fib-iter (+ a b) a (- count 1))))

;; -> do化すると、

(do ((a 1 (+ a b)) (b 0 a) (count 5 (- count 1)))
    ((= count 0) b))

;; -> named-let化すると

;(let G6 ((a 1)
;         (b 0)
;         (count 5))
;  (if (= count 0)
;      b
;      (begin
;        (G6 (+ a b) a (- count 1)))))

;; ok!

[]問題4.10 00:32 問題4.10を含むブックマーク

;; しょうもない変更だが、let式を変更する。
(let ((a b)
      (c d)
      (e f)))

;; ->
(let (a b
      c d
      e f))

;; とかけるようにしよう。

(define (let->combination exp)
  (let ((second (cadr exp)))
    (let ((named? (symbol? second)))
      (let ((bindings (if named? (caddr exp) second))
            (body (if named? (cdddr exp) (cddr exp))))
        (let ((vars (let iter ((lst bindings) (acc '()))
                      (if (null? lst)
                          (reverse acc)
                          (iter (cddr lst) (cons (car lst) acc)))))
              (exps (let iter ((lst (cdr bindings)) (acc '()))
                      (if (null? (cdr lst))
                          (reverse (cons (car lst) acc))
                          (iter (cddr lst) (cons (car lst) acc))))))
          (if named?
              (list 'let bindings
                    (append (list 'define (append (list second) vars))
                            body)
                    (append (list second) vars))
              (append (list (append (list 'lambda vars) (cddr exp))) exps)))))))

(let->combination
 '(let (a 0
        b 1
        c 2)
    (+ a b c)))

;; -> ((lambda (a b c) (+ a b c)) 0 1 2)
;; ok

[]問題4.11 00:32 問題4.11を含むブックマーク

(define (make-frame variables values)
  (if (= (length variables) (length values))
      (reverse
       (let make-frame-iter ((vars variables) (vals values))
         (cons (cons (car vars) (cdr vals)) (make-frame-iter (cdr vars) (cdr vals)))))
      (error "variables length and values length are different.")))
(define (frame-variables frame) (map car frame))
(define (frame-values frame) (map cdr frame))
(define (add-binding-to-frame! var val frame)
  (set! frame (cons (cons var val) frame)))

(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan pairs)
      (cond ((null? pairs)
             (env-loop (enclosing-envrionment env)))
            ((eq? var (caar pairs))
             (cdar pairs))
            (else (scan (cdr pairs)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable" var)
        (let ((frame (first-frame env)))
          (scan frame))))
  (env-loop env))

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

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

[]問題4.12 00:32 問題4.12を含むブックマーク

(define (env-loop null-proc find-proc name var env)
  (define (scan vars vals)
    (cond ((null? vars) (null-proc env))
          ((eq? var (car vars)) (find-proc vals))
          (else (scan (cdr vars) (cdr vals)))))
  (if (eq? env the-empty-environment)
      (error "Unbound variable -- " name " " var)
      (let ((frame (first-frame env)))
        (scan (frame-variables frame)
              (frame-values frame)))))

(define (lookup-variable-value var env)
  (define (null-proc env)
    (env-loop null-proc find-proc "LOOKUP_VARIABLE_VALUE" var (enclosing-environment env)))
  (define (find-proc vals) (car vals))
  (env-loop null-proc find-proc "LOOKUP_VARIABLE_VALUE" var env))

(define (set-variable-value! var val env)
  (define (null-proc env)
    (env-loop null-proc find-proc "SET_VARIABLE_VALUE!" var (enclosing-environment env)))
  (define (find-proc vals) (set-car! vals val))
  (env-loop null-proc find-proc "SET_VARIABLE_VALUE!" var env))

(define (define-variable! var val env)
  (define (null-proc env) (add-binding-to-frame! var val (first-frame env)))
  (define (find-proc vals) (set-car! vals val))
  (env-loop null-proc find-proc "DEFINE_VARIABLE!" var env))

[]問題4.13 00:32 問題4.13を含むブックマーク

(define (make-unbound-variable! var env)
  (define (env-loop env)
    (define (scan prev-vars vars prev-vals vals)
      (cond ((null? vars)
             (env-loop (enclosing-envrionment env)))
            ((eq? var (car vars))
             (set-cdr! prev-vars (cdr vars))
             (set-cdr! prev-vals (cdr vals)))
            (else (scan (cdr prev-vars) (cdr vars)
                        (cdr prev-vals) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable. -- MAKE_UNBOUND_VARIABLE! " var)
        (let ((frame (first-frame env)))
          (if (eq? var (car (frame-variables frame)))
              (begin
                (set-car! frame (cdr (frame-variables frame)))
                (set-cdr! frame (cdr (frame-values frame))))
              (scan (frame-variables frame) (cdr (frame-variables frame))
                    (frame-values frame) (cdr (frame-values frame)))))))
  (env-loop env))

;; unboundされる変数名のコンスペア連結を外して消す。
;; frame の先頭にあった場合のみ、frameのcar部とcdr部を変更するので違う処理が必要。
;; listの中にある場合は、そのコンスを飛ばして下のコンスと接続するようにする。
;; 直近の環境に無ければ、上方の環境をたどりながら探していく。

2011-08-20

[]問題2.63 06:43 問題2.63を含むブックマーク

SICP超久しぶり。

思えば学部2-3年のころに一生懸命やっていたな。

ranobaの開発に移ってから、ずっとほったらかしにしていた。

やっぱり難しい。あまり成長してないのか。。。。

なんにしろ、いい加減に終わらせないとね。ぱっぱと飛ばしてこう。

(define (entry tree) (car tree))

(define (left-branch tree)
  (if (> (length tree) 1)
      (cadr tree)
      '()))

(define (right-branch tree)
  (if (> (length tree) 2)
      (caddr tree)
      '())

(define (make-tree entry left right)
  (list entry left right))

(define (element-of-set? x set)
  (cond ((null? set) #f)
        ((= x (entry set)) true)
        ((< x (entry set))
         (element-of-set? x (left-branch set)))
        ((> x (entry set))
         (element-of-set? x (right-branch set)))))

(define (tree->list-1 tree)
  (if (null? tree)
      '()
      (append (tree->list-1 (left-branch tree))
              (cons (entry tree)
                    (tree->list-1 (right-branch tree))))))

(define (tree->list-2 tree)
  (define (copy-to-list tree result-list)
    (if (null? tree)
        result-list
        (copy-to-list (left-branch tree)
                      (cons (entry tree)
                            (copy-to-list  (right-branch tree)
                                           result-list)))))
  (copy-to-list tree '()))


;; a
;; 同じである

;; b
;; 1は再帰的手続きであり、appendを使っているのでステップ数の増加の程度ははO(n^2)である。
;; 2も再帰的手続きであるcopy-to-listが入れ子になっているので、反復的手続きではない)が、ステップ数の増加の程度はO(n)である。
;; 多分。

[]問題2.64 06:43 問題2.64を含むブックマーク

(define (list->tree elements)
  (car (partial-tree elements (length elements))))

(define (partial-tree elts n)
  (if (= n 0)
      (cons '() elts)
      (let ((left-size (quotient (- n 1) 2)))
        (let ((left-result (partial-tree elts left-size)))
          (let ((left-tree (car left-result))
                (non-left-elts (cdr left-result))
                (right-size (- n (+ left-size 1))))
            (let ((this-entry (car non-left-elts))
                  (right-result (partial-tree (cdr non-left-elts)
                                              right-size)))
              (let ((right-tree (car right-result))
                    (remaining-elts (cdr right-result)))
                (cons (make-tree this-entry left-tree right-tree)
                      remaining-elts))))))))


; a
; まず、ターゲットとなる長さを半分にし、それを左側の幹として再帰している。
; その後、残りとして戻って来たものを右側として、全体の長さから、left分引いた値を次の全体の長さとして再帰する。
; どちらにも入らなかったのも、nより大きかったものはremaining-eltsとしてconsのcdr部に入れて返す。
; nが0となるときに、'()が返されるので、もっとも末節に入り込んだとき'()が返されて再帰のネストは終了する。
; 木の構造自体が再帰的なので、それをそのままコードに落とし込んだような形である。

;5 ----- 9 ----- 11
;|       |
;|       | ----- 7
;|
;| ----- 1 ----- 3

;b
; O(n)

[]問題2.65 06:43 問題2.65を含むブックマーク

(define (union-tree tree1 tree2)
  (let ((list1 (tree->list-2 tree1))
        (list2 (tree->list-2 tree2)))
    (list->tree (union-set list1 list2))))

(define (intersection-tree tree1 tree2)
  (let ((list1 (tree->list-2 tree1))
        (list2 (tree->list-2 tree2)))
    (list->tree (intersection-set list1 list2))))

;; なんのひねりもない方法。
;; union-set と intersection-set は適当に実装してください。
;; これでいいのかな???

[]問題2.66 06:43 問題2.66を含むブックマーク

(define (lookup given-key set-of-records)
  (if (null? set-of-records)
      #f
      (let ((record (entry set-of-records)))
        (cond ((= given-key (key record)) record)
              ((< given-key (key record)) (lookup given-key (left-branch set-of-records)))
              ((> given-key (key record)) (lookup given-key (right-branch set-of-records)))))))

[]問題2.67 06:43 問題2.67を含むブックマーク

define (make-leaf symbol weight)
  (list 'leaf symbol weight))

(define (leaf? object)
  (eq? (car object) 'leaf))

(define (symbol-leaf x) (cadr x))

(define (weight-leaf x) (caddr x))

(define (make-code-tree left right)
  (list left
        right
        (append (symbols left) (symbols right))
        (+ (weight left) (weight right))))

(define (left-branch tree) (car tree))
(define (right-branch tree) (cadr tree))

(define (symbols tree)
  (if (leaf? tree)
      (list (symbol-leaf tree))
      (caddr tree)))

(define (weight tree)
  (if (leaf? tree)
      (weight-leaf tree)
      (cadddr tree)))

(define (decode bits tree)
  (define (decode-1 bits current-branch)
    (if (null? bits)
        '()
        (let ((next-branch
                (choose-branch (car bits) current-branch)))
              (if (leaf? next-branch)
                  (cons (symbol-leaf next-branch)
                        (decode-1 (cdr bits) tree))
                  (decode-1 (cdr bits) next-branch)))))
  (decode-1 bits tree))

(define (choose-branch bit branch)
  (cond ((= bit 0) (left-branch branch))
        ((= bit 1) (right-branch branch))
        (else (error "bad bit -- CHOOSE-BRANCH" bit))))


(define (adjoin-set x set)
  (cond ((null? set) (list x))
        ((< (weight x) (weight (car set))) (cons x set))
        (else (cons (car set)
                    (adjoin-set x (cdr set))))))


(define (make-leaf-set pairs)
  (if (null? pairs)
      '()
      (let ((pair (car pairs)))
        (adjoin-set (make-leaf (car pair)
                               (cadr pair))
                    (make-leaf-set (cdr pairs))))))

(define sample-tree
  (make-code-tree (make-leaf 'A 4)
                  (make-code-tree
                   (make-leaf 'B 2)
                   (make-code-tree (make-leaf 'D 1)
                                   (make-leaf 'C 1)))))


(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
;; (A D A B B C A)

[]問題2.68 06:43 問題2.68を含むブックマーク

(define (encode message tree)
  (if (null? message)
      '()
      (append (encode-symbol (car message) tree)
              (encode (cdr message) tree))))


;; rec
(define (encode-symbol message tree)
  (if (leaf? tree)
      '()
      (if (memq message (symbols (left-branch tree)))
          (cons 0 (encode-symbol message (left-branch tree)))
          (cons 1 (encode-symbol message (right-branch tree))))))

;; trec
(define (encode-symbol message tree)
  (define (iter m t bits)
    (if (leaf? t)
        (reverse bits)
        (if (memq m (symbols (left-branch t)))
            (iter m (left-branch t) (cons 0 bits))
            (iter m (right-branch t) (cons 1 bits)))))
  (iter message tree '()))


(let ((msg '(A D A B B C A)))
  (equal? msg (decode (encode msg sample-tree) sample-tree)))

;=> #t
; ok

[]問題2.69 06:43 問題2.69を含むブックマーク

(define (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))

(define (successive-merge leaf-set)
  (if (> (length leaf-set) 1)
      (successive-merge (adjoin-set (make-code-tree (car leaf-set) (cadr leaf-set)) (cddr leaf-set)))
      (car leaf-set)))

(let ((tree (generate-huffman-tree '((a 4) (b 2) (c 1) (d 1)))))
  (decode '(0 1 1 0 0 1 0 1 0 1 1 1 0) tree))

;; -> '(A D A B B C A)
;; -> ok

[]問題2.70 06:43 問題2.70を含むブックマーク

(define rock-1950-tree
  (generate-huffman-tree '((A 2) (NA 16) (BOOM 1) (SHA 3) (GET 2) (YIP 9) (JOB 2) (WAH 1))))

(define song
  '( GET A JOB
     SHA NA NA NA NA NA NA NA NA
     GET A JOB
     SHA NA NA NA NA NA NA NA NA
     WAH YIP YIP YIP YIP YIP YIP YIP YIP YIP
     SHA BOOM ))

(encode song rock-1950-tree)

;; -> (1 1 1 1 1 1 1 0 0 1 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 0 0 1 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 1 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 1 1 0 1 1 0 1 1)
;; -> 84 bit

;; 固定長の最小bitは
;; 8個しか記号がないので、3bitで対応できる。
;; (* 3 (length song)) -> 108 bitである。

;; Huffman符号化木を使うことにより、77.7%に圧縮できている。

[]問題2.71 06:43 問題2.71を含むブックマーク

;;n = 5
'(1 2 4 8 16)

31--15--7--3--1
|    |  |  |-2
|    |  |-4
|    |-8
|-16

;;n = 10
'(1 2 4 8 16 32 64 128 256 512)

1023--511--255--127--63--31--15--7--3--1
 |     |    |    |    |   |   |  |  +-2
 |     |    |    |    |   |   |  +-4
 |     |    |    |    |   |   +-8
 |     |    |    |    |   +-16
 |     |    |    |    +-32
 |     |    |    +-64
 |     |    +-128
 |     +-256
 +-512

;最高頻度 1bit
;最低頻度 (n-1)bit

[]問題2.72 06:43 問題2.72を含むブックマーク

  • スキップします。あとで

[]問題2.73 06:43 問題2.73を含むブックマーク

  • スキップします。あとで

[]問題2.74 06:43 問題2.74を含むブックマーク

;; a
;; それぞれの事業所のファイルには個別の型がついている。
;; placeという手続きによって型名を呼び出せる。

(define (get-record file name)
  ((get 'get-record (place file)) (records file) name))

(define (place obj)
  (car obj))

(define (records file)
  (cadr file))

(define (make-file place-name records)
  (list place-name records))

;; たとえば、tokyo事業所ではファイルはレコードのリストであった。
(define (install-tokyo-package) ;; example
  (define (get-record record name)
    (if (null? record)
        #f
        (if (eq? (get-name (car record)) name)
            (car record)
            (get-record (cdr record) name))))
  (put 'get-record '(tokyo) get-record))


;; b
;; それぞれの事業所のレコードには個別の型がついている。
;; placeという手続きによって型名を呼び出せる。
(define (get-salary record)
  ((get 'get-salary (place record)) (data record)))

;; placeはさっきと同じ

(define (data record)
  (cadr record))

(define (make-record place-name record)
  (list place-name record))

;; たとえば、tokyo支社ではレコードをalistで作っていた。
(define (install-tokyo-package)
  (define (get-salary record-data)
    (cdr (assoc 'salary record-dada))))

;; c
(define (find-employee-record name files)
  (if (null? files)
      #f
      (let ((found (get-record (car files) name)))
        (if found
            found
            (find-employee-record name (cdr files))))))

;;d
;; 事業所が増えるという話か、全然違う会社と合併する話なのかちょっとわからない。

;; 後者として話を進める。
;; 今ある事業所のタイプタグの一段階上にさらに抽象レイヤーを作る。
;; つまり、会社のタイプタグなどを作り、「それぞれの会社のすべての事業所ファイルの集合」への型付けを行う。
;; そしてfind-employee-recordなどの基本手続きをそのレイヤーの上に接続するように変更する。

[]問題2.75 06:43 問題2.75を含むブックマーク

;; なんか普通のオブジェクト指向っぽい感じだ。
(define (make-from-mag-arg r a)
  (define (dispatch op)
    (cond ((eq? op 'real-part) (* r (cos a)))
          ((eq? op 'imag-pert) (* r (sin a)))
          ((eq? op 'magnitude) r)
          ((eq? op 'angle)     a)
          (else (error "Unknown op -- MAKE-FROM-MAG-ARG" op))))
  dispatch)

[]問題2.76 06:43 問題2.76を含むブックマーク

  • 汎用演算
    • 新しい型を追加するとき
      • すべての汎用選択子の定義を変更する必要あり
      • 名前などがかぶらないように注意しないといけない。
    • 新しい演算を追加するとき
      • ふつうに新しく書くだけ。
  • メッセージパッシング
    • 新しい型を追加するとき
      • 外部にテーブルを持たないので、新しいオブジェクト生成関数を追加するだけなので楽。
      • 型の追加に伴い、インターフェースを変更する必要があれば、必要によって書き換える。
    • 新しい演算を追加するとき
      • インターフェースという概念は必須ではない(つまりそれぞれの型が独立した演算名を持っていてよい)ので、任意に必要な型に演算を追加する。
  • 絶えず型が追加される場合、

とかかな

今日はここまで。

2011-02-27

[] jshintでjavascriptコードチェックしながら開発する 18:59  jshintでjavascriptコードチェックしながら開発するを含むブックマーク

最近はjavascriptを書いています。

javascriptとしてはそれなりに大規模になってきました(2万行ぐらい?)。

最近のjavascriptトレンドのやり方は、コードチェッカを通して、信頼性を向上させるのがプロ技らしいです。

僕も早くプロの仲間に入りたいです。

コードチェッカには「JSLint」というのがあるらしいのですが、使ってみればわかりますが、さすがに警告が細かすぎてウザいです。

(「varは関数トップに一つ」とか特に。C言語じゃないんだから・・・。)

そういった部分をある程度柔軟にしたものに「JSHint」というのがあるみたいです。「JSLint」のフォークらしいです。

あまりに堅いスタイルを強要されたくなかったので、僕はこれを使ってみました。

そのまま使えるわけじゃないのでやったことをメモっておきます。

1.JSHintをダウンロードしてくる

http://jshint.com/

左上にDownloadがあるのでそこをクリックして開発マシンにダウンロードします。

jsを開発しているディレクトリに任意のディレクトリを掘ってそこにおいておくと良いでしょう。

2.node.jsインストール

JSHintはただのjsファイルなので、そのままだとブラウザ以外では実行できません。処理系が必要です。

js処理系であれば大体何でも動くと思いますが、

node.jsというのが最近流行ってるみたいなんでそれにします。

# linux Debian
$ sudo apt-get install nodejs
# FreeBSD
$ cd /usr/ports/www/node
$ configure
$ make
$ sudo make install

3.loader.js書く

JSHintそのままですと、javascript文字列を読んでチェックする機能しかありませんので、開発向けじゃありません。

loader.jsというのを作って、ファイルを指定してチェックしてくれるようにしたいと思います。

// loader.js
(function (global) {
  "use strict";

  var fs = require('fs'),
  jshint = require('./jshint.js');

  if (jshint) {
    jshint = jshint.JSHINT;
  } else {
    throw new Error('jshint is not found.');
  }

  var jshint_file = function (file) {
    fs.readFile(file, function (err, data) {
      if (err) throw err;
      var option = {
        browser: true,
        devel:   true,
        debug:   true
      },
      result = jshint(data.toString('utf-8'), option);

      if (!result) {
        jshint.errors.forEach(function (e) {
          if (e) console.log("WORNING!! file: " + file + " line: " + e.line +
                             " character: " + e.character + "\n\t" + e.reason + "\n");
        });
      }

    });
  };

  function main() {

    if (process.argv.length < 3) {
       // No files given. Nothing to do.
      return;
    }

    var files = process.argv.slice(2);

    files.forEach(function(file) {
      jshint_file(file);
    });

  };

  main();

})(this);

これをjshint.jsと同じフォルダに置いて、実行してみます。

# nodeもしくはnodejs(aptでインストールした場合)
# 引数のファイルはいくつでもつなげられる。

$ node loader.js loader.js

-> WORNING!! file: tools/loader.js line: 49 character: 4
           Unnecessary semicolon. # main();の前の行のセミコロンが不要。

うまく動いているようです。

4.実行スクリプトを書く

同じフォルダにcheckerスクリプトを作ります。

#!/usr/local/bin/bash

script_dir=`dirname $0`
target_dir=`pwd`

arg=$*
parg=()
count=0

for item in $arg; do
    parg[$count]=$target_dir"/"$item
    let count=$count+1
done

node $script_dir/loader.js ${parg[@]}

これで違うディレクトリにあるファイルでも

$ tools/checker development.js development2.js development3.js

とかできるようになりました。

5.Makefileを書く

MYSRCS  = \
        development1.js                \
        development2.js                \
        development3.js

.PHONY: all

all:    check comp

check:  $(MYSRCS)
        ./tools/checker $(MYSRCS)

comp:   $(MYSRCS)
        # ソースを結合し、圧縮する。

doc:    $(MYSRCS)
        # コメントからドキュメントを作成。

clean:
        rm main.cmp.js

とかでしょうか。

これでjsが書きあがった後、

$ make check

とすれば、ソースをチェックします。

doc(ドキュメント生成)とかcomp(圧縮)とかありますが、私はこんな風にやっています。

これらはまた時間があれば書こうと思います。

では。