関数呼び出しを木構造で表示
SICPで関数の呼出を木構造で表示する問題がでてきたけど、これを手で書くのは大変。というわけで、Schemeでマクロを使って、呼出の木を自動で表示するのを作りました.slibのtraceと大体同じです。場合によっては、traceよりも見やすくなると思います.木で表示する部分はHaskellのdrawTreeを参考に作りました.
gaucheで動くことは確認しました.r5rs以外の手続きは, formatしか使っていないので、他の処理系でもそれさえあれば動くと思います.
定義マクロ
- tree-trace-on proc : procの追跡をonにする
- tree-trace-off proc : procの追跡をoffにする
- tree-trace (proc arg ...) : procの追跡を一時的にonにした状態でprocを呼ぶ.
サンプル
gosh> (define (fibonacci n) (if (< n 2) n (+ (fibonacci (- n 1)) (fibonacci (- n 2))))) fibonacci gosh> (tree-trace (fibonacci 5)) (fibonacci 5) = 5 | +-(fibonacci 4) = 3 | | | +-(fibonacci 3) = 2 | | | | | +-(fibonacci 2) = 1 | | | | | | | +-(fibonacci 1) = 1 | | | | | | | `-(fibonacci 0) = 0 | | | | | `-(fibonacci 1) = 1 | | | `-(fibonacci 2) = 1 | | | +-(fibonacci 1) = 1 | | | `-(fibonacci 0) = 0 | `-(fibonacci 3) = 2 | +-(fibonacci 2) = 1 | | | +-(fibonacci 1) = 1 | | | `-(fibonacci 0) = 0 | `-(fibonacci 1) = 1 5 gosh> (define (sub x y) (- x y)) sub gosh> (define (mult x y) (* x y)) mult gosh> (define (fact n) (if (= n 0) 1 (mult n (fact (sub n 1))))) fact gosh> (tree-trace-on sub) #<closure #<identifier user#alt-proc>> gosh> (tree-trace-on mult) #<closure #<identifier user#alt-proc>> gosh> (tree-trace-on fact) #<closure #<identifier user#alt-proc>> gosh> (fact 5) (fact 5) = 120 | +-(sub 5 1) = 4 | +-(fact 4) = 24 | | | +-(sub 4 1) = 3 | | | +-(fact 3) = 6 | | | | | +-(sub 3 1) = 2 | | | | | +-(fact 2) = 2 | | | | | | | +-(sub 2 1) = 1 | | | | | | | +-(fact 1) = 1 | | | | | | | | | +-(sub 1 1) = 0 | | | | | | | | | +-(fact 0) = 1 | | | | | | | | | `-(mult 1 1) = 1 | | | | | | | `-(mult 2 1) = 2 | | | | | `-(mult 3 2) = 6 | | | `-(mult 4 6) = 24 | `-(mult 5 24) = 120 120
ソース
;; Stack for tree (define tree-trace:node-stack '()) (define (tree-trace:push! x) (set! tree-trace:node-stack (cons x tree-trace:node-stack))) (define (tree-trace:top) (car tree-trace:node-stack)) (define (tree-trace:pop!) (define t (tree-trace:top)) (set! tree-trace:node-stack (cdr tree-trace:node-stack)) t) (define (tree-trace:null?) (null? tree-trace:node-stack)) ;; alist key: alternative procedure val: original procedure (define tree-trace:proc-alist '()) (define (tree-trace:add-trace-entry alt-proc orig-proc) (set! tree-trace:proc-alist (cons (cons alt-proc orig-proc) tree-trace:proc-alist))) (define (tree-trace:remove-trace-entry alt-proc) (let loop ((l tree-trace:proc-alist)) (cond ((null? l) (error "It does not traced")) ((eq? alt-proc (caar l)) (cdar l)) (else (loop (cdr l)))))) ;; tree (define (tree-trace:make-tree label nodes) (cons label nodes)) (define (tree-trace:add-child! tree child) (set-cdr! tree (append (cdr tree) (list child)))) (define (tree-trace:get-label tree) (car tree)) (define (tree-trace:set-label! tree label) (set-car! tree label)) ;; utility (define (tree-trace:print . args) (for-each display args) (newline)) (define (tree-trace:string-join l . args) (define delim (if (null? args) "" (car args))) (define s (make-string 0)) (if (not (null? l)) (begin (set! s (format "~a" (car l))) (for-each (lambda (t) (set! s (string-append s (format "~a~a" delim t)))) (cdr l)))) s) ;; make string of procedure call (define (tree-trace:proc-call-string f args) (string-append "(" (tree-trace:string-join (map (lambda (x) (format "~a" x)) (cons f args)) " ") ")")) ;; trace procedure (define-syntax tree-trace-on (syntax-rules () ((_ proc) (begin (if (not (and (symbol? 'proc) (procedure? proc))) (error "It's not a procedure's variable.")) (let* ((orig-proc proc) (alt-proc (lambda args (tree-trace:push! (tree-trace:make-tree (tree-trace:proc-call-string 'proc args) '())) (let* ((v (apply orig-proc args)) (t (tree-trace:pop!)) (pre-label (tree-trace:get-label t))) (tree-trace:set-label! t (format "~a = ~a" pre-label v)) (if (tree-trace:null?) (tree-trace:print-tree t) (tree-trace:add-child! (tree-trace:top) t)) v)))) (tree-trace:add-trace-entry alt-proc orig-proc) (set! proc alt-proc)))))) ;; untrace procedure (define-syntax tree-trace-off (syntax-rules () ((_ proc) (begin (if (not (and (symbol? 'f) (procedure? proc))) (error "It's not a procedure's variable.")) (set! proc (tree-trace:remove-trace-entry proc)))))) ;; call & trace procedure (define-syntax tree-trace (syntax-rules () ((_ (f arg ...)) (begin (tree-trace-on f) (let ((v (f arg ...))) (tree-trace-off f) v))))) (define (tree-trace:shift first rest l) (cond ((null? l) '()) ((null? (cdr l)) (list (string-append first (car l)))) (else (cons (string-append first (car l)) (map (lambda (t) (string-append rest t)) (cdr l)))))) (define (tree-trace:print-tree tree) (for-each tree-trace:print (tree-trace:tree->strings tree))) (define (tree-trace:tree->strings tree) (cons (car tree) (tree-trace:forest->strings (cdr tree)))) (define (tree-trace:forest->strings l) (cond ((null? l) '()) ((null? (cdr l)) (cons "|" (tree-trace:shift "`-" " " (tree-trace:tree->strings (car l))))) (else (cons "|" (append (tree-trace:shift "+-" "| " (tree-trace:tree->strings (car l))) (tree-trace:forest->strings (cdr l)))))))
