2007-04-20
■ 予約語をなくす 
これまでのevalは"if"や"lambda"等の定数とのパターンマッチングをして処理を分岐させていたため、これらはある意味予約語のようになっていた。
今回はこれをやめて、ifやlambdaも単なる変数であって、その変数の中に条件分岐をする処理や関数を作る処理といった値が入っているだけ、という状態にする。
変数に値が入っているだけなので入れものである変数の名前は何でもよくて、予約語のような特別扱いのものはなくなる、と。
Syntax型を追加
前に組み込み関数を作ったときに関数を格納するSubr型を作ったことに倣って、関数を格納するSyntax型を追加する。
なんでSyntaxにしたかというと、gaucheでifを評価したら#<syntax if>と表示されたから。
Subrのときは、シンプルにS式からS式を求める関数だったが、evalはStateモナド化しているので、Syntax型に入れる関数もStateモナドを返す関数になる。
ついでにSyntax型の時用のshowも定義しておく。
data Sexp = Nil | Symbol String | Cons Sexp Sexp | Subr (Sexp->Sexp) | Closure Sexp Sexp
| Syntax (Sexp->Control.Monad.State.State Sexp Sexp)
show (Syntax _) = "#<syntax>"
環境に各syntaxを登録
これまでevalに入っていた各処理をそれぞれのシンボルに対応づけて環境envに登録する。書き方のスタイルは変わるけどやっていることはevalの時と同じ。
env = define "quote" (Syntax (\(Cons a _) -> return a)) $ define "lambda" (Syntax (\body -> gets $ Closure body)) $ define "if" (Syntax (\(Cons a (Cons b (Cons c _))) -> eval a >>= \p->if p/=false then eval b else eval c)) $ define "define" (Syntax (\(Cons (Symbol var) (Cons exp _)) -> eval exp >>= modify . define var >> return (Symbol var))) $ define "env" (Syntax (\_ -> get)) $ define "car" ...
evalを書き直し
個別処理が環境envの方に移ったので、evalの側では関数部funを評価してシンボルから実際に行うべき処理を取り出してそれを実行するという統一的な扱いが出来るようになる。
evalは3種類のデータ型に対応した3行だけになった。すっきりしてちょっと満足。
eval (Nil) = return Nil eval (Symbol str) = gets $ assoc str eval (Cons fun arg) = eval fun >>= flip preApply arg
preApply
例えば、ifの場合なら事前にthen部とelse部の両方を評価してしまったら意味がないし、defineの場合なら第２引数の変数部まで評価はしないといったように、関数系(Subr,Closure)と文法系(Syntax)の違いは、事前に引数を評価するかどうかということ。
これまでは引数を全て評価してからapplyを呼び出していたが、引数の評価の有無をコントロールするために、applyの呼び出しの前にpreApplyの呼び出しをかますことにする。
パターンマッチでSyntax型だったら評価前の引数をそのまま渡すようにして(1行目)、それ以外の型(=SubrとClosure)だったらevalsで各引数を評価してからapplyを呼び出す(2行目)ようにする。
Syntax型の方はどの引数を評価するかは各処理が自分で選ぶ、と。
preApply (Syntax fun) arg = fun arg preApply fun arg = evals arg >>= return . apply fun
テスト
まずdefineの機能を変数dに格納し、dを使ってdefineにはlambdaの機能を、lambdaにはdefineの機能をわりあてる。
それを使ってifという名前のnull?に相当する関数を定義する。
C:\haskell>runghc lisp.hs
>(define d define)
d
>(d define lambda)
define
>(d lambda d)
lambda
>(lambda if
(define (x)
(eq? () x)))
if
>(if ())
#t
>(if define)
#f
今日までの全コード
import Text.ParserCombinators.Parsec
import Control.Monad.State
data Sexp = Nil | Symbol String | Cons Sexp Sexp | Subr (Sexp->Sexp) | Closure Sexp Sexp
| Syntax (Sexp->Control.Monad.State.State Sexp Sexp)
instance Eq Sexp where
(==) Nil Nil = True
(==) (Symbol a) (Symbol b) = a==b
(==) (Cons a as) (Cons b bs) = a==b && as==bs
(==) _ _ = False
instance Show Sexp where
show (Nil) = "()"
show (Symbol a) = a
show (Cons a b) = "(" ++ show a ++ showCdr b ++ ")"
show (Subr _) = "#<subr>"
show (Syntax _) = "#<syntax>"
show (Closure a _) = "#<closure " ++ show a ++ ">"
showCdr (Nil) = ""
showCdr (Cons a b) = " " ++ show a ++ showCdr b
showCdr a = " . " ++ show a
instance Read Sexp where
readsPrec _ s = case parse sexpParser "" s of Right a -> [(a,"")]
partParser = spaces >>
( do { eof; return (Nil,"") }
<|> do { exp <- sexpParser; rest <- getInput; return (exp,rest) })
sexpParser = spaces >>
( do { string "("; listParser }
<|> do { string "'"; a<-sexpParser; return (Cons (Symbol "quote") (Cons a Nil)) }
<|> do { a<-many1 $ noneOf "'() \t\r\n"; return (Symbol a) } )
listParser = spaces >>
( do { string ")"; return Nil }
<|> do { string "."; a<-sexpParser; listParser; return a }
<|> do { a<-sexpParser; b<-listParser; return (Cons a b) } )
true = Symbol "#t"
false = Symbol "#f"
eval (Nil) = return Nil
eval (Symbol str) = gets $ assoc str
eval (Cons fun arg) = eval fun >>= flip preApply arg
evals (Cons a as) = do { b<-eval a; bs<-evals as; return $ Cons b bs }
evals a = eval a
preApply (Syntax fun) arg = fun arg
preApply fun arg = evals arg >>= return . apply fun
apply (Subr fun) arg = fun arg
apply (Closure (Cons var (Cons body _)) env) arg = evalState (eval body) (zipl var arg env)
apply f a = error $ "error in apply: " ++ show (Cons f a)
assoc s (Cons (Cons (Symbol k) v) e) = if s==k then v else assoc s e
assoc s _ = error $ "unbound variable: " ++ show s
zipl Nil _ e = e
zipl (Cons k ks) (Cons v vs) e = zipl ks vs $ zipl k v e
zipl k v e = Cons (Cons k v) e
define var (Closure body env) _ = let newenv = Cons (Cons (Symbol var) (Closure body newenv)) env in newenv
define var val env = Cons (Cons (Symbol var) val) env
env =
define "quote" (Syntax (\(Cons a _) -> return a)) $
define "lambda" (Syntax (\body -> gets $ Closure body)) $
define "if" (Syntax (\(Cons a (Cons b (Cons c _))) -> eval a >>= \p->if p/=false then eval b else eval c)) $
define "define" (Syntax (\(Cons (Symbol var) (Cons exp _)) -> eval exp >>= modify . define var >> return (Symbol var))) $
define "env" (Syntax (\_ -> get)) $
define "car" (Subr (\(Cons (Cons a _) _) -> a)) $
define "cdr" (Subr (\(Cons (Cons _ a) _) -> a)) $
define "cons" (Subr (\(Cons a (Cons b _)) -> Cons a b)) $
define "eq?" (Subr (\(Cons a (Cons b _)) -> if a==b then true else false)) $
define "pair?" (Subr (\(Cons a _) -> case a of Cons _ _ -> true; _ -> false )) $
define "apply" (Subr (\(Cons a (Cons b _)) -> apply a b)) $
define "eval" (Subr (\(Cons a (Cons b _)) -> evalState (eval a) b)) $
read "((#t . #t) (#f . #f))"
evalLoop str env = putStr ">" >> case parse partParser "" str of
Left err -> print err
Right (_,"") -> return ()
Right (exp,rest) -> case runState (eval exp) env of (a,s) -> print a >> evalLoop rest s
main = do
stdin<-getContents
evalLoop stdin env
次回予定
マクロ機能を作る
2007-04-13
■ defineを作る 
defineを作るからには、単に評価結果を返すだけではなく、変化した環境を次の評価を行う際に利用できるようにしなければならない。いろいろ考えたが、今回はStateモナドを使うことにした。
evalをStateモナド化する
これまでのevalは評価するS式と環境の2つを引数としてとる関数としていたが、今回はStateモナド化するので、環境の方はモナド側の機構を利用して扱うことになり、引数としては評価するS式1つだけになる。
evalの返値はモナドでなければならないので、単にNilを返していたところはreturn Nilに書き換える(1行目)。
環境の値を使いたいときはgetまたはgetsを使って状態を取り出す。2行目では、getsを使いassocの2番目の引数に環境を与えている。getsの返値はすでにモナドなのでreturnは使わずにそのまま返せばよい。
3行目のquoteの処理はNilの時と同じでreturnでモナド化して値を返す。
4行目のlambdaの処理は2行目と同じでgetsを使ってClosure型の2つめのフィールドに環境を埋め込んでいる。getsは関数だけじゃなくてデータコンストラクタに対しても使えるようだ。（または単にカリー化されて関数になってるだけなのかも。）
5行目のifの処理では、条件分岐をするためにまず第1引数pの真偽値を求めなければならない。いままではif式の中に埋め込んで書けていたけど、今やevalの返値はモナドなのでそのままifには与えられない。いったんdo構文の<-を使ってモナド内の値を取り出して、それをifに与えるようにしている。モナドを使うと今まで関数的に書けていたところが手続き型っぽい書き方にさせられてしまうところがなんか悲しい。一方thenまたはelseでもevalを呼び出しているが、このときは返値がモナドである恩恵をうけてreturn等はなしでいい。
6行目の通常の関数呼び出しの処理も、これまで部分式で良かった関数部と引数部の評価を個別に<-を使って値を取り出して、それをapplyに渡す。applyはevalと違ってモナド化しないので返値はreturnを使ってモナドにして返す。
書き始める前は、evalのとる引数がひとつ減ってコードがすっきるするかな、と思っていたが、returnやらdo構文とかが必要になってきてそれほどでもなかった…。
eval (Nil) = return Nil
eval (Symbol s) = gets $ assoc s
eval (Cons (Symbol "quote") (Cons a _)) = return a
eval (Cons (Symbol "lambda") body) = gets (Closure body)
eval (Cons (Symbol "if") (Cons p (Cons t (Cons e _)))) = do {b<-eval p;if b /= false then eval t else eval e}
eval (Cons fun arg) = do { a<-eval fun; b<-evals arg; return $ apply a b }
evalsもStateモナド化する。
リスト内の各S式を評価するevalsも同じeval兄弟（？）ということでモナド化する。
Cons型のデータの内部フィールドはSexp型の値が入るのであって、モナド型の値を入れるわけにはいかないので、これまでと同じように<-を使ってモナドをはずしてからCons型に入れる。で、返す値はモナドじゃないといけないので、returnでモナド化する。必要なことだとわかってはいるがなんか不毛だ…。
evals (Cons a b) = do { aa<-eval a; bb<-evals b; return $ Cons aa bb }
evals a = eval a
Stateモナド化したevalの呼び出し
Stateモナド化した関数は、runStateを使って呼び出す。runStateの第1引数が実際の処理を行う関数（今回はeval）で、第2引数が初期値として与える状態（今回は環境）。呼び出した結果は返値と状態のタプルになっている。
なので、evalLoopでは、返ってきたタプルの各値を(a,s)とのパターンマッチで取り出して、まず返値aの方をprintして、状態sの方を次のevalLoopを呼び出すときの環境として使うようにする。
evalLoop str env = ... Right (exp,rest) -> case runState (eval exp) env of (a,s) -> print a >> evalLoop s rest
apply中のevalの呼び出し
applyの中でも、仮引数変数と引数との組合せを追加した新たな環境を使ってevalを呼び出す処理があったので、ここも書き換える。こちらではevalの結果だけが欲しいので、runStateではなくevalStateを使う。
apply (Closure (Cons var (Cons body _)) env) arg = evalState (eval body) (zipl var arg env)
eval中にdefineの処理を作る
今までの部分は単に同じ処理を別のやり方に書き換えてきただけ。しかし、これで準備が整ったので実際のdefineに対応する部分を作る。
defineの時はリストの2番目に変数名、3番目にバインドする式が来るので、それぞれvarとexpで取り出す。そして、expを評価して値valを求め、modifyを使って状態を変更する。これまでの環境にvarとvalを対にしたものを加えたものを新たな環境とするのだから、前に作ったdefine（Haskell上で定義した関数の方）が流用できる。
最後にdefine自体の返値として定義された変数名のシンボルを返す。（Schemeの流儀に倣って変数名を返すようにしたけど、どうして値の方じゃなくて変数名なんだろう。値の方を返すようにしていれば、さらにその値を使って別のdefineが呼び出せるのに。）
eval (Cons (Symbol "define") (Cons (Symbol var) (Cons exp _))) = do { val<-eval exp; modify $ define var val; return $ Symbol var }
再帰関数を定義できるようにする
ダイナミックスコープを採用していれば、ここまでの内容で再帰関数も作れるんだけど、今回はレキシカルスコープのlispを作ろうとしているのでこのままでは再帰関数が作れない。
なぜなら、クロージャを適用（=apply）するときにはそのクロージャが持っている環境を使って評価をさせようとしているのにもかかわらず、クロージャの持つ環境は(lambda …)を評価した時点の環境を格納しているので、その環境にはまだ再帰関数名とクロージャ自分自身の対応関係が含まれていないから。
そこで今回はdefineの処理のうち引数がClosure型だったときだけは別扱いとして、Closure内の環境を再帰関数名とクロージャ自分自身の対応関係を追加した環境に入れ替えるようにすることにした。
そうはいっても、今から作ろうとしている自分自身を含んだ新しい環境を、自分自身のフィールド値として与えなければいけないのは、鶏と卵の関係のようでどうすればいいのか結構悩んだ。
しかし、さすが遅延評価。letで用意した変数newenvに値を入れるその式中にnewenvを使うことが出来る。これはいい。Schemeでやってるような、いったん未定義の変数を導入してからset!であとで書き換えるといったことをやらなくてもいいわけだ。
define var (Closure body env) _ = let newenv = Cons (Cons (Symbol var) (Closure body newenv)) env in newenv
テスト
ここまでくれば結構まともなテストが出来る。
まずは普通に変数に値をバインドしてみる。xを評価するとちゃんと(a b c)が入っている。
次に関数null?を定義してみる。xの中身は(a b c)なのでnullではないから偽である#fが返り、()を与えると真である#tが返っている。
最後に、再帰を使うappendを定義してみる。また、上で定義したnull?も使っている。(a b c)に(a b c)を連結して(a b c a b c)を返しておりちゃんと動いているようだ。
C:\haskell>runghc lisp.hs
>(define x '(a b c))
x
>x
(a b c)
>(define null?
(lambda (x)
(eq? () x)))
null?
>(null? x)
#f
>(null? ())
#t
>(define append
(lambda (x y)
(if (null? x)
y
(cons (car x) (append (cdr x) y)))))
append
>(append x x)
(a b c a b c)
今日までの全コード
import Text.ParserCombinators.Parsec
import Control.Monad.State
data Sexp = Nil | Symbol String | Cons Sexp Sexp | Subr (Sexp->Sexp) | Closure Sexp Sexp
instance Eq Sexp where
(==) Nil Nil = True
(==) (Symbol a) (Symbol b) = a==b
(==) (Cons a as) (Cons b bs) = a==b && as==bs
(==) _ _ = False
instance Show Sexp where
show (Nil) = "()"
show (Symbol a) = a
show (Cons a b) = "(" ++ show a ++ showCdr b ++ ")"
show (Subr _) = "#<subr>"
show (Closure a _) = "#<closure " ++ show a ++ ">"
showCdr (Nil) = ""
showCdr (Cons a b) = " " ++ show a ++ showCdr b
showCdr a = " . " ++ show a
instance Read Sexp where
readsPrec _ s = case parse sexpParser "" s of Right a -> [(a,"")]
partParser = spaces >>
( do { eof; return (Nil,"") }
<|> do { exp <- sexpParser; rest <- getInput; return (exp,rest) })
sexpParser = spaces >>
( do { string "("; listParser }
<|> do { string "'"; a<-sexpParser; return (Cons (Symbol "quote") (Cons a Nil)) }
<|> do { a<-many1 $ noneOf "'() \t\r\n"; return (Symbol a) } )
listParser = spaces >>
( do { string ")"; return Nil }
<|> do { string "."; a<-sexpParser; listParser; return a }
<|> do { a<-sexpParser; b<-listParser; return (Cons a b) } )
true = Symbol "#t"
false = Symbol "#f"
eval (Nil) = return Nil
eval (Symbol s) = gets $ assoc s
eval (Cons (Symbol "define") (Cons (Symbol var) (Cons exp _))) = do { val<-eval exp; modify $ define var val; return $ Symbol var }
eval (Cons (Symbol "env") _) = get
eval (Cons (Symbol "quote") (Cons a _)) = return a
eval (Cons (Symbol "lambda") body) = gets (Closure body)
eval (Cons (Symbol "if") (Cons p (Cons t (Cons e _)))) = do {b<-eval p;if b /= false then eval t else eval e}
eval (Cons fun arg) = do { a<-eval fun; b<-evals arg; return $ apply a b }
evals (Cons a b) = do { aa<-eval a; bb<-evals b; return $ Cons aa bb }
evals a = eval a
apply (Subr fun) arg = fun arg
apply (Closure (Cons var (Cons body _)) env) arg = evalState (eval body) (zipl var arg env)
apply f a = error $ "error in apply: " ++ show (Cons f a)
assoc s (Cons (Cons (Symbol k) v) e) = if s==k then v else assoc s e
assoc s _ = error $ "unbound variable: " ++ show s
zipl Nil _ e = e
zipl (Cons k ks) (Cons v vs) e = zipl ks vs $ zipl k v e
zipl k v e = Cons (Cons k v) e
define var (Closure body env) _ = let newenv = Cons (Cons (Symbol var) (Closure body newenv)) env in newenv
define var val env = Cons (Cons (Symbol var) val) env
env =
define "car" (Subr (\(Cons (Cons a _) _)->a)) $
define "cdr" (Subr (\(Cons (Cons _ a) _)->a)) $
define "cons" (Subr (\(Cons a (Cons b _))->Cons a b)) $
define "eq?" (Subr (\(Cons a (Cons b _))->if a==b then true else false)) $
define "pair?" (Subr (\(Cons a _)->case a of Cons _ _ -> true; _ -> false )) $
read "((#t . #t) (#f . #f))"
evalLoop str env = putStr ">" >> case parse partParser "" str of
Left err -> print err
Right (_,"") -> return ()
Right (exp,rest) -> case runState (eval exp) env of (a,s) -> print a >> evalLoop rest s
main = do
stdin<-getContents
evalLoop stdin env
次回予定
evalをシンプルにする
2007-04-09
■ 対話環境を作る 
今回はdefineの処理を作ろうと思っていたのだが，考えてみたらdefineが意味を持つためには，
(define x '(a b c))
(car x)
のように，defineを行う式の入力と，defineされた変数を使う式の入力の両方が順番に処理される仕組みを作らなければならない。
今までは常に1つのS式を評価することしかやっていなかったので，まずは順番に入力された複数のS式を順番に評価していくことを出来るようにする。
具体的には，今までのghci等を利用する形を離れて，自前で標準入力からユーザの入力を受け取って処理するようにする。
partParser
複数のS式が入力にあたえられるので，最初のS式を取り出して評価した後で，その続きの部分から次のS式を読み込む必要がある。そこで，ここでは入力文字列の頭から取り出せたS式と，その時点での残りの入力文字列をセットにして返すパーサpartParserを新たに用意する。
また入力文字列の最後まで到達している場合はさらにsexpParserを呼び出すとパースエラーになってしまうので決めうちで(Nil,"")を返すようにする。
partParser = spaces >>
( do { eof; return (Nil,"") }
<|> do { exp <- sexpParser; rest <- getInput; return (exp,rest) })
evalLoop
入力された複数のS式を順番に評価していくevalLoopを作る。
受け取る引数は入力文字列であるstrと評価をするときに使う環境env。
まず，パースエラー時はLeft型の値が返ってくるので，エラーを表示して終了する。
次に，入力を最後まで呼んでしまった場合は，残りの入力が""になっているので，何もしないで終了する。
それ以外の通常の場合は，取り出せたS式と残りの文字列がセットで返ってくるので，それぞれexpとrestで受けて，expを評価して結果を表示し，次の入力のプロンプト">"を表示し，残りの文字列restを引数にしてevalLoopを再帰呼び出しする。
evalLoop str env = case parse partParser "" str of
Left err -> print err
Right (_,"") -> return ()
Right (exp,rest) -> do
print $ eval exp env
putStr ">"
evalLoop rest env
main
今回はmainも標準入力から入力を受け取るように書き換える。
まずプロンプト">"を表示し，標準入力をstdinに入れた後で上記evalLoopをstdinを引数にして呼び出す。
main = do putStr ">" stdin<-getContents evalLoop stdin env
テスト
というわけで，今回はghciではなくてrunghcを使ってテストをする。
実行すると">"というプロンプトが出るので，その後に式を入力してEnterを押すと，それに対応する評価結果が次の行に表示されている。
また，最後の例のように，閉じかっこが来るまでは入力を受け続け，閉じかっこが入力された時に評価結果を表示している。
こういうことが出来るのがHaskellはいいなあ。
C:\haskell>runghc lisp.hs >'(a b c) (a b c) >(cdr '(a b c)) (b c) >(cons 'a 'b) (a . b) >(cons 'a 'b ) (a . b) >^Z C:\haskell>runghc lisp.hs
今日までの全コード
import Text.ParserCombinators.Parsec
data Sexp = Nil | Symbol String | Cons Sexp Sexp | Subr (Sexp->Sexp)
| Closure Sexp Sexp
instance Eq Sexp where
(==) Nil Nil = True
(==) (Symbol a) (Symbol b) = a==b
(==) (Cons a as) (Cons b bs) = a==b && as==bs
(==) _ _ = False
instance Show Sexp where
show (Nil) = "()"
show (Symbol a) = a
show (Cons a b) = "(" ++ show a ++ showCdr b ++ ")"
show (Subr _) = "#<subr>"
show (Closure a _) = "#<closure " ++ show a ++ ">"
showCdr (Nil) = ""
showCdr (Cons a b) = " " ++ show a ++ showCdr b
showCdr a = " . " ++ show a
instance Read Sexp where
readsPrec _ s = case parse sexpParser "" s of Right a -> [(a,"")]
partParser = spaces >>
( do { eof; return (Nil,"") }
<|> do { exp <- sexpParser; rest <- getInput; return (exp,rest) })
sexpParser = spaces >>
( do { string "("; listParser }
<|> do { string "'"; a<-sexpParser; return (Cons (Symbol "quote") (Cons a Nil)) }
<|> do { a<-many1 $ noneOf "'() \t\r\n"; return (Symbol a) } )
listParser = spaces >>
( do { string ")"; return Nil }
<|> do { string "."; a<-sexpParser; listParser; return a }
<|> do { a<-sexpParser; b<-listParser; return (Cons a b) } )
true = Symbol "#t"
false = Symbol "#f"
eval (Nil) env = Nil
eval (Symbol s) env = assoc s env
eval (Cons (Symbol "quote") (Cons a _)) _ = a
eval (Cons (Symbol "lambda") body) env = Closure body env
eval (Cons (Symbol "if") (Cons p (Cons t (Cons e _)))) env = if eval p env /= false then eval t env else eval e env
eval (Cons fun arg) env = apply (eval fun env) (evals arg env)
evals (Cons a b) env = Cons (eval a env) (evals b env)
evals a env = eval a env
apply (Subr fun) arg = fun arg
apply (Closure (Cons var (Cons body _)) env) arg = eval body $ zipl var arg env
apply f a = error $ "error in apply: " ++ show (Cons f a)
assoc s (Cons (Cons (Symbol k) v) e) = if s==k then v else assoc s e
assoc s _ = error $ "unbound variable: " ++ show s
zipl Nil _ e = e
zipl (Cons k ks) (Cons v vs) e = zipl ks vs $ zipl k v e
zipl k v e = Cons (Cons k v) e
define key val env = Cons (Cons (Symbol key) val) env
env =
define "car" (Subr (\(Cons (Cons a _) _)->a)) $
define "cdr" (Subr (\(Cons (Cons _ a) _)->a)) $
define "cons" (Subr (\(Cons a (Cons b _))->Cons a b)) $
define "eq?" (Subr (\(Cons a (Cons b _))->if a==b then true else false)) $
define "pair?" (Subr (\(Cons a _)->case a of Cons _ _ -> true; _ -> false )) $
read "((#t . #t) (#f . #f))"
evalLoop str env = case parse partParser "" str of
Left err -> print err
Right (_,"") -> return ()
Right (exp,rest) -> do
print $ eval exp env
putStr ">"
evalLoop rest env
main = do
putStr ">"
stdin<-getContents
evalLoop stdin env
次回予定
こんどこそdefineを作る
2007-03-28
■ lambdaを作る 
これまでは組み込みの関数を作ってきたけど、今回からはlamda（クロージャ）を導入してユーザ定義の関数を作れるようにする。
クロージャ型を用意する
クロージャは関数の本体と、その関数が定義された時点の環境をセットにしたデータ。なので、ここで用意するClosure型も関数本体と環境の２つのスロットを持たせる。関数本体は(lambda …)の中に書かれたS式だし、環境も今回はS式で作っているので、Closure型のとる値は2つのSexp型になる。
ついでにshowも定義して値の確認も出来るようにしておく。普通のSchemeではこんなことはしてないけど、個人的な趣味により#<closure …>の中に定義時のlambda式の中身を表示することにした。簡単に関数のソースコード（？）がみられると便利かな、と。
data Sexp = Nil | Symbol String | Cons Sexp Sexp | Subr (Sexp->Sexp)
| Closure Sexp Sexp
show (Clusure a _) = "#<closure " ++ show a ++ ">"
evalをlambdaに対応させる
ここでは(lambda …)で表されたS式を評価してクロージャを作成する処理をつくる。クロージャを呼び出して処理をするところではないので注意。
とはいってもここでは大したことはしない。lambdaの引数である関数本体とその時点での環境をセットにしてClosure型のデータにまとめておくだけ。
eval (Cons (Symbol "lambda") body) env = Closure body env
関数ziplを作る
クロージャを作るところが出来たので、今度はクロージャを実行するところに行きたいところだが、ここでそのために使う下請け関数をひとつ作っておく。
zipl関数（本当は関数名をzipにしたかったんだけどすでに同名の関数があるので、ここではリスト用のzipということでziplとした）は３つのリストを引数としてとり、１つめの引数のリストと２つめの引数のリストの各要素を対にして３つめの引数のリストに追加する。
例をあげると、３つの引数が(x y z),(a b c),()であったとすると、( (x . a) (y . b) (z . c) )を返す処理を行う。
また、(x . y),(a b c),()の場合は、((x . a)(y . (b c)))を返す（この性質はlambdaで可変長引数関数を定義するのに使える）。
zipe Nil _ e = e zipe (Cons k ks) (Cons v vs) e = zipe ks vs $ zipe k v e zipe k v e = Cons (Cons k v) e
applyをClosureに対応させる
上記の補助関数を使って、クロージャの中身を実行する処理を作る。定義する場所はevalではなく、組み込み関数を作るときに用意したapplyになる。（evalの時点では、組み込み関数でもクロージャ関数でも「関数適用をする」という同じ扱いになっており、実際の関数適用であるapplyのところで、組み込み関数かクロージャ関数かで分岐することになる。）
具体的処理としては、まずクロージャ型のデータからパターンマッチによって引数変数部と環境を、var,envとして取り出す。またクロージャを呼び出すときにあたえられた引数値をargとして受け取り、varとargのそれぞれの要素を対にしてクロージャが持っていた環境envに追加する（この処理に上記のziplを使う）。こうして作った新しい環境を使ってクロージャの処理本体であるbodyを評価すれば、body中の引数変数には呼び出し時の引数値が入っていることになる、という寸法。
apply (Closure (Cons var (Cons body _)) env) arg = eval body $ zipl var arg env
テスト
現時点では(Scheme側に)defineの機能がないので、せっかくlambdaを作っても大したテストができない…。
とりあえず、(lambda…)自体の評価と、(lambda…)式を直接埋め込んで関数を実行するテストをしておく。
本来ならcadrと名前をつけるような処理にしているので、(a b c)に対してbを返しているのでOK。
Main> lisp "(lambda (x) (car (cdr x)))" #<closure ((x) (car (cdr x)))> Main> lisp "((lambda (x) (car (cdr x))) '(a b c))" b
今日までの全コード
import Text.ParserCombinators.Parsec
data Sexp = Nil | Symbol String | Cons Sexp Sexp | Subr (Sexp->Sexp)
| Closure Sexp Sexp
instance Eq Sexp where
(==) Nil Nil = True
(==) (Symbol a) (Symbol b) = a==b
(==) (Cons a as) (Cons b bs) = a==b && as==bs
(==) _ _ = False
instance Show Sexp where
show (Nil) = "()"
show (Symbol a) = a
show (Cons a b) = "(" ++ show a ++ showCdr b ++ ")"
show (Subr _) = "#<subr>"
show (Closure a _) = "#<closure " ++ show a ++ ">"
showCdr (Nil) = ""
showCdr (Cons a b) = " " ++ show a ++ showCdr b
showCdr a = " . " ++ show a
instance Read Sexp where
readsPrec _ s = case parse sexpParser "" s of Right a -> [(a,"")]
sexpParser = spaces >>
( do { string "("; listParser }
<|> do { string "'"; a<-sexpParser; return (Cons (Symbol "quote") (Cons a Nil)) }
<|> do { a<-many1 $ noneOf "'( )"; return (Symbol a) } )
listParser = spaces >>
( do { string ")"; return Nil }
<|> do { string "."; a<-sexpParser; listParser; return a }
<|> do { a<-sexpParser; b<-listParser; return (Cons a b) } )
true = Symbol "#t"
false = Symbol "#f"
eval (Nil) env = Nil
eval (Symbol s) env = assoc s env
eval (Cons (Symbol "quote") (Cons a _)) _ = a
eval (Cons (Symbol "lambda") body) env = Closure body env
eval (Cons (Symbol "if") (Cons p (Cons t (Cons e _)))) env = if eval p env /= false then eval t env else eval e env
eval (Cons fun arg) env = apply (eval fun env) (evals arg env)
evals (Cons a b) env = Cons (eval a env) (evals b env)
evals a env = eval a env
apply (Subr fun) arg = fun arg
apply (Closure (Cons var (Cons body _)) env) arg = eval body $ zipl var arg env
assoc s (Cons (Cons (Symbol k) v) e) = if s==k then v else assoc s e
assoc s _ = error $ "unbound variable: " ++ show s
zipl Nil _ e = e
zipl (Cons k ks) (Cons v vs) e = zipl ks vs $ zipl k v e
zipl k v e = Cons (Cons k v) e
define key val env = Cons (Cons (Symbol key) val) env
env =
define "car" (Subr (\(Cons (Cons a _) _)->a)) $
define "cdr" (Subr (\(Cons (Cons _ a) _)->a)) $
define "cons" (Subr (\(Cons a (Cons b _))->Cons a b)) $
define "eq?" (Subr (\(Cons a (Cons b _))->if a==b then true else false)) $
define "pair?" (Subr (\(Cons a _)->case a of Cons _ _ -> true; _ -> false )) $
read "((x . (a b c)) (y . a) (#t . #t) (#f . #f))"
lisp str = print $ eval (read str) env
main = do
lisp "(lambda (x) (car (cdr x)))"
lisp "((lambda (x) (car (cdr x))) '(a b c))"
次回予定
defineを作る
2007-03-17
■ 述語関数を作る 
前回はcar,cdr,consのリスト操作関数を作ったので、今回は真か偽を返す述語関数を作る。
具体的には、2つの引数が等しいかを判定するeq?と引数がリスト（正確にはConsセル）かどうかを判定するpair?を作る。
なぜこの2つかというと、純LISPの基本関数がcar,cdr,cons,eq,atomの5つだから。eqはそのままschemeのeq?と対応するけど、atomの方はschemeだとアトムかどうかを判定するかわりにリストかどうかを判定するpair?になる。まあ、真偽が逆転するだけで出来ることは同じだろう、と。
とにかくこれが出来れば胸を張って純LISPと同じレベルまで来ましたといえるんじゃないだろうか。
真偽値の定義
実体はただのシンボルで代用なんだけど、trueとfalseを定義しておく。
これってHaskell的には別の型を起こした方がいいのかな…。でもshowとかをまた別に書く事になるわりには書くこと同じだしなあ。今回はいいや。
true = Symbol "#t" false = Symbol "#f"
eq?を環境に追加
組み込み関数なので前回と同じように、シンボルを環境に追加しつつ無名関数として実体も定義する。
eq?の場合はパターンマッチで取り出した2の引数aとbに対して、Eqクラス（同じeqで紛らわしいな）のインスタンスとするために定義した(==)をそのまま使える。
等しかったら上で定義したtrueを、等しくなかったらfalseを返す。
define "eq?" (Subr (\(Cons a (Cons b _))->if a==b then true else false)) $
pair?を環境に追加
次はリストかどうかを判定するpair?。あたえられた引数をCons _ _とパターンマッチさせればCons型かどうかがわかる。マッチすればtrueを返し、そうでなければfalseを返す。
define "pair?" (Subr (\(Cons a _)->case a of Cons _ _ -> true; _ -> false )) $
テスト
今回はxが(a b c)、つまりリスト、yがa、つまりアトムになっている。
なので、pair?についてはxが真、yが偽になっていて予定通り。ちなみにNilもCons型ではないので偽になる。
eq?については、(a b c)とaは当然等しくないが、(a b c)のcarをとったものはaなのでちゃんと等しいと判定している。
Main> lisp "x" (a b c) Main> lisp "y" a Main> lisp "(pair? x)" #t Main> lisp "(pair? y)" #f Main> lisp "(pair? ())" #f Main> lisp "(eq? x y)" #f Main> lisp "(eq? (car x) y)" #t
■ 今日までの全コード 
import Text.ParserCombinators.Parsec
data Sexp = Nil | Symbol String | Cons Sexp Sexp | Subr (Sexp->Sexp)
instance Eq Sexp where
(==) Nil Nil = True
(==) (Symbol a) (Symbol b) = a==b
(==) (Cons a as) (Cons b bs) = a==b && as==bs
(==) _ _ = False
instance Show Sexp where
show (Nil) = "()"
show (Symbol a) = a
show (Cons a b) = "(" ++ show a ++ showCdr b ++ ")"
show (Subr _) = "#<subr>"
showCdr (Nil) = ""
showCdr (Cons a b) = " " ++ show a ++ showCdr b
showCdr a = " . " ++ show a
instance Read Sexp where
readsPrec _ s = case parse sexpParser "" s of Right a -> [(a,"")]
sexpParser = spaces >>
( do { string "("; listParser }
<|> do { string "'"; a<-sexpParser; return (Cons (Symbol "quote") (Cons a Nil)) }
<|> do { a<-many1 $ noneOf "'( )"; return (Symbol a) } )
listParser = spaces >>
( do { string ")"; return Nil }
<|> do { string "."; a<-sexpParser; listParser; return a }
<|> do { a<-sexpParser; b<-listParser; return (Cons a b) } )
true = Symbol "#t"
false = Symbol "#f"
eval (Nil) env = Nil
eval (Symbol s) env = assoc s env
eval (Cons (Symbol "quote") (Cons a _)) _ = a
eval (Cons (Symbol "if") (Cons p (Cons t (Cons e _)))) env = if eval p env /= false then eval t env else eval e env
eval (Cons fun arg) env = apply (eval fun env) (evals arg env)
evals (Cons a b) env = Cons (eval a env) (evals b env)
evals a env = eval a env
apply (Subr fun) arg = fun arg
assoc s (Cons (Cons (Symbol k) v) e) = if s==k then v else assoc s e
assoc s _ = error $ "unbound variable: " ++ show s
define key val env = Cons (Cons (Symbol key) val) env
env =
define "car" (Subr (\(Cons (Cons a _) _)->a)) $
define "cdr" (Subr (\(Cons (Cons _ a) _)->a)) $
define "cons" (Subr (\(Cons a (Cons b _))->Cons a b)) $
define "eq?" (Subr (\(Cons a (Cons b _))->if a==b then true else false)) $
define "pair?" (Subr (\(Cons a _)->case a of Cons _ _ -> true; _ -> false )) $
read "((x . (a b c)) (y . a) (#t . #t) (#f . #f))"
lisp str = print $ eval (read str) env
main = do
lisp "(pair? x)"
lisp "(pair? y)"
lisp "(pair? ())"
lisp "(eq? x y)"
lisp "(eq? (car x) y)"
■ 次回予告 
lambdaを作る