Schemeでライブラリを定義するぞ
Schemeのr7rsにはライブラリを定義する構文がある。
例↓
(define-library (niyarin test)
(import (scheme base))
(export foo1 foo2)
(begin
(define (foo1 a) (+ a 1 ))
(define (foo2 a) (- a 1))))
Schemeのライブラリ名は、ライブラリを一意に判別するため、識別子と正の整数のリストを使う。
define-libraryでは、外側の環境へアクセスできないので、使いたい機能をimportする必要があり、また外側の環境で使う場合どの識別子を見られるようにするのかexportで指定する必要がある。
あとは、begin内にlibrary本体を記述すれば最低限使えるようになると思う。
define-library内では、例が使われたものの他にinclude include-ci include-library-declarations cond-expandが使える。
作ったライブラリを使うには、もちろんimportするだけでよい。
ただし、ライブラリ自体は現在の環境から見えるようにする必要があるので、外側のファイルに書いた場合なんかは、include、loadなどする必要がある。
(import (niyarin test) (scheme write)) (display (foo1 1));2
無事使えた。
以上。
dynamic-wind。
dynamic-windについてまとめた。
dynamic-windのつかいかた
(dynamic-wind before thunk after)
- 引数はすべてthunk(引数0の手続き)。
- before、thunk、afterの順に実行する。
- ただし、真ん中のthunkで継続を取り出して外側から呼び出した場合や中から外側の継続を呼び出した場合は特別な動きをする。
- 外側から継続を呼び出した場合、呼び出す前にbefore、後にafterを呼ぶ。
- 内側から外側の継続を呼び出した場合その継続が呼ばれる前にafterを呼ぶ。(もちろんbeforeはその前に呼ばれている)
実行例
(define cont #f) (dynamic-wind (lambda () (display 1)) (lambda () (display (call/cc (lambda (c) (set! cont c) 2)))) (lambda () (display 3)(newline))) (cont 0)
結果
123 103
やること。
beforeで1を表示、afterで3と表示して改行
真ん中のthunkで、継続を取り出してその結果を標準出力する。
そして外側から継続を呼ぶ。
raiseとraise-continuableとwith-exception-handler。
Scheme(R7RS)の例外の発生とハンドラについてまとめた。
with-exception-handerで例外ハンドラを登録し、raise、raise-continuableで例外を発生させる。
raiseとraise-continuableの違いは、handlerを呼び出した後での処理に違いがある。
with-exception-handler
(with-exception-handler handler thunk )
- thunk内で例外が発生するとhandlerが実行される。
- handlerは1引数の手続き。
- thunkは名前の通り引数なし手続き。
raise-continuable
(raise-continuable obj)
- 例外を発生させ、objをhandlerに渡す。
- handlerが実行し終えると、例外を発生させた場所に戻る。返り値はhandlerの結果。
- 一度handlerを呼び出して戻ってきても、再度例外を発生させれば同じhandlerが立ち上がる。
raise
(raise obj)
- 例外を発生させ、objをhandlerに渡す。
- handlerが実行し終えると、二度目の別の例外が発生する。
- 二度目の例外を補足するhandlerへ渡る値は規定されていない
- 二度目の例外のhandlerは、一つ外側のwith-exception-handerで登録されたhandlerが呼び出される
SRFI1 Constructorsを眺めたぞ。
srfi1のリストを生成するやつら。
以下は、てきとーにドキュメント眺めてまとめたもの。
cons,list,make-list,list-copyらはr7rsに含まれているので無視する。
xcons
第二引数をcar部に、第一引数をcdr部にconsセルを生成する。
例
(xcons 1 2) ;(2 . 1)
cons*
引数の最後が末尾cdr部になるリストを生成する。
(cons* a1 a2 … an-1 an) => (a1 a2 … an-1 . an)
例
(cons* 1 2 3 4) ;(1 2 3 . 4)
list-tabulate
0〜n-1のそれぞれに、初期化関数を適用したリストを返す。
例
(list-tabulate 5 (lambda (n) (* n n ) ) ) ;(0 1 4 9 16)
circular-list
与えた引数を繰り返す循環リストを生成する。
例
(circular-list 1 2 3 4) ;#0=(1 2 3 4 . #0#)
iota
個数、初期値、増加値を指定して、数値のリストを生成する。
例(個数5 初期値 0 増加値 1の場合)
(iota 5 0 1) (0 1 2 3 4)
Whitespaceを使ったぞ。
Whitespaceは、esolangの一つで、[space]、[tab]、改行だけでスタックマシン的な命令を表現する言語。
チュートリアル。
これが割とあっさりしてるので、動作確認用に書いたコードをメモとして貼ることにする。
[space]はS、[tab]はT、改行はLとして表記する。
stdinで数字を読んで、stdoutで出力する。
数字をechoするだけ。
SSSL SL STL TTTTTTL STL L L
SSSLで、0をstackにpushする。
SLSで、stackトップを複製する。つまりstackの中身は、[0,0]。
TLTTで、数値を標準入力で読み込んで、stackトップの値のアドレスに入れる。stackトップをpopする。
TTTで、stackからアドレスを取り出して、そのアドレスにあるヒープのデータをstackにpushする。
TLSTでstackトップの値を数値として標準出力する。stackトップをpopする。
LLLでプログラム終了。
3+2をして標準出力する
SSSTTL SSSTSL TSSSTL STL L L
SSSTTL、3をstackにpush。
SSSTSL、2をstackにpush。
TSSS、stackから2つ取り出し、加算結果をstackに積む。
TLST、stackから1つ取り出し、数値として標準出力する。
LLLでプログラム終了
long jump
L SL STTSSSSTL SSSL TL STL SSSTTSSSSTL SSSTL TL STL L L
LSLSTTSSSSTL、ラベルaにジャンプする。(STTSSSST=‘a’)
SSSL、0をstackにpush。(実行されない)
TLSTL、標準出力(実行されない)
LSSSTTSSSSTL、ラベルaを定義する。
SSSTL、1をstackにpush。
TLST、標準出力。
LLL、プログラム終了。
サブルーチン
L SL STTSSSSTL L SSSTTSSSTSL SSSTL TL STL TL L SSSTTSSSSTL L STSTTSSSTSL L L
LSLSTTSSSSTL、ラベル'a'にロングジャンプ。
LSSSTTSSSTSL、ラベル'b'を定義
SSSTL、1をstackに積む
TLST、数値として標準出力
LTL、サブルーチンを抜けてreturnする。
LSSSTTSSSSTL、ラベル'a'を定義。
LSTSTTSSSTSL、サブルーチンとしてラベル'b'にジャンプ
LLL、プログラム終了。
入力した値が0ならば'y'をそれ以外なら'x'を標準出力する
条件分岐。
SSSL SL STL TTTTTL TSSTTSSSSTL SSSTTTTSSSL TL SSL SL STTSSSTSL L SSSTTSSSSTL SSSTTTTSSTL TL SSL SSSTTSSSTSL L L L
SSSL、0をstackに積む
SLS、stackトップを複製
TLTT、標準入力結果をstackトップが示すアドレスに入れる。
TTT、stackトップが示すアドレスのデータをstackトップにpushする。
LTSSTTSSSSTL、stackトップの値が0ならばラベル'a'に飛ぶ。
SSSTTTTSSSL、120(‘x’)をstackに積む。
TLSS、stackトップをcharとして出力する。
LSLSTTSSSTSL、ラベル'b'に飛ぶ。
LSSSTTSSSSTL、ラベル'a'を定義する。
SSSTTTTSSTL、121(‘y’)をstackに積む。
TLSS、stackトップをcharとして出力する。
LSSSTTSSSTSL、ラベルbを定義する。
LLLプログラム終了
GraphVizを使ったぞ。
GraphVizは、dot言語でグラフを記述してpdfやpngとかで出力できる。
GraphViz for discrete math studentsというページでdotのサンプルを確認した。
僕の場合、重み付き有向グラフの描画をできれば良いのでこれだけでよかった。
<雑なdotサンプル>
digraph {
a -> b[label="0.1",weight="0.1"];
b -> c[label="0.2",weight="0.2"];
c -> a[label="0.3",weight="0.3"];
}
weightは、重みをいれたらいいのは分かるが、ラベルとして表示されるわけではなかった。
グラフ描画をいいかんじにしてくれるというくらいの認識。
↓manはこう言ってました。
weight=n where n is the integer cost of the edge.
Values greater than 1 tend to shorten the edge.
Weight 0 flat edges are ignored for ordering nodes.
おしまい。
雑に型推論するものを書いたぞ。
方程式を導出してそれを解くということをしただけ。
サポートする構文、組み込み関数
構文
ifとfunとlambda(1つ以上の引数関数の糖衣構文として)
(if bool a a) (fun x body) (lambda (x1 x2 ... ) body)
組み込み関数
succ + zero? の3つだけ。
例
関数適用 (zero? (+ 1 2)) ;boolean 整数をいれて、2加えて返す関数 (fun a (succ (succ a))) ;integer -> integer 多相型 (fun a a) ;T4 -> T4 ifの型推論 (lambda (a b)(if a 1 b)) ;boolean -> integer -> integer 合成関数 (lambda (a b)(fun x (a (b x)))) ;(T10 -> T11) -> (T9 -> T10) -> T9 -> T11
雑なソースコード
;----------------------------------------------------- ; ; data ; ;----------------------------------------------------- (define builtin-functions '((succ . (function . (integer . integer))) (+ . (function . (integer . (function . (integer . integer))))) (zero? . (function . (integer . boolean))))) ;----------------------------------------------------- ; ; curry ; ;----------------------------------------------------- (define (lmd-to-curry-fun code) (let ((param (cadr code)) (body (caddr code))) (let loop ((p param)) (if (null? p) body `(fun ,(car p) ,(loop (cdr p))))))) (define (curry-apply code) (let loop ((args (reverse (cdr code)))) (if (null? (cdr args)) `(,(car code) ,(car args)) `(,(loop (cdr args)) ,(car args))))) (define (test-convert code) (if (pair? code) (case (car code) ((lambda) (let ((body (test-convert (caddr code)))) (lmd-to-curry-fun `(lambda ,(cadr code) ,body)))) ((fun) (let ((body (test-convert (caddr code)))) `(fun ,(cadr code) ,body))) ((if) (let ((test (test-convert (cadr code))) (true (test-convert (caddr code))) (false (test-convert (cadddr code)))) `(if ,test ,true ,false))) (else (let ((args (map test-convert (cdr code))) (f (test-convert (car code)))) (curry-apply (cons f args))))) code)) ;----------------------------------------------------- ; ; type inference ; ;----------------------------------------------------- (define extract #f) (let ((type-vars 0)) (define (publish-type-vars) (set! type-vars (+ type-vars 1)) (cons 'type-var type-vars)) (define (catch-type env sym) (cond ((assv sym env) => cdr) (else (display "ERROR::unbound variable ")(display sym)(display " env=")(display env)(newline)))) (set! extract (lambda (env code) (cond ((integer? code) '(() . integer)) ((boolean? code) '(() . boolean)) ((symbol? code) (cons '() (catch-type env code))) ((eqv? (car code) 'if) (let* ((et1 (extract env (cadr code))) (et2 (extract env (caddr code))) (et3 (extract env (cadddr code)))) (let ((e4 (append (car et1) (car et2) (car et3) (list (cons (cdr et1) 'boolean) (cons (cdr et2) (cdr et3)))))) (cons e4 (cdr et2))))) ((eqv? (car code) 'fun) (let ((t (publish-type-vars))) (let ((et0 (extract (cons (cons (cadr code) t) env) (caddr code)))) (cons (car et0) (cons 'function (cons t (cdr et0))))))) (else (let* ((et1 (extract env (car code))) (et2 (extract env (cadr code)))) (let ((t (publish-type-vars))) (let ((e3 (append (car et1) (car et2) (list (cons (cdr et1) (cons 'function (cons (cdr et2) t))))))) (cons e3 t))))) )))) (define (expand obj env) (cond ((type-var? obj) => (lambda (id) (let loop ((p env)) (cond ((null? p) obj) ((eqv? id (caar p))(cdar p)) (else (loop (cdr p))))))) (else obj))) (define (expand-rec obj env) (cond ((symbol? obj) obj) ((type-var? obj) (let ((expanded-obj (expand obj env))) (if (and (type-var? expanded-obj) (eqv? (type-var? expanded-obj)(type-var? obj))) expanded-obj (expand-rec expanded-obj env)))) ((eqv? (car obj) 'function) `(function . (,(expand-rec (cadr obj) env) . ,(expand-rec (cddr obj) env)))) (else obj))) (define (unify e equations) (cond ((null? equations) e) ((null? (car equations)) (unify e (cdr equations))) (else (let ((left (expand (caar equations) e)) (right (expand (cdar equations) e))) (cond ((equal? left right) (unify e (cdr equations))) ((and (not (type-var? right)) (type-var? left) ) => (lambda (id) (unify (cons (cons id right) e) (cdr equations)))) ((and (not (type-var? left)) (type-var? right)) => (lambda (id) (unify (cons (cons id left) e) (cdr equations)))) ((and (pair? left)(pair? right) (eqv? (car left) 'function) (eqv? (car right) 'function)) (unify e `(,(cons (cadr left)(cadr right)) ,(cons (cddr left)(cddr right)) . ,(cdr equations)))) (else (display "TYPE ERROR")(newline))))))) (define (type-var? o) (and (pair? o)(eqv? (car o) 'type-var)(cdr o))) (define (type->string obj) (cond ((symbol? obj) (symbol->string obj)) ((eqv? (car obj) 'type-var) (string-append "T" (number->string (cdr obj)))) ((eqv? (car obj) 'function) (let ((arg (if (and (pair? (cadr obj)) (not (type-var? (cadr obj)))) (string-append "(" (type->string (cadr obj)) ")") (type->string (cadr obj)))) (body (type->string (cddr obj)))) (string-append arg " -> " body ))))) ;----------------------------------------------------- ; ; REPL ; ;----------------------------------------------------- (define (eqshow eqs) (let loop ((l eqs)) (cond ((null? l) '()) ((null? (car l)) (loop (cdr l))) (else (display "::::: ")(display (caar l))(display " = ")(display (cdar l))(newline)(loop (cdr l)))))) (let type-check-loop () (let* ((input (test-convert (read))) (analyzed-input (extract builtin-functions input)) (kai (unify '() (car analyzed-input))) (ret (expand-rec (cdr analyzed-input) kai))) (display (type->string ret))(newline) (type-check-loop)))
