HaskellでLispを書く日記 このページをアンテナに追加 RSSフィード

2007-04-20

予約語をなくす 予約語をなくす - HaskellでLispを書く日記 を含むブックマーク はてなブックマーク - 予約語をなくす - HaskellでLispを書く日記 予約語をなくす - HaskellでLispを書く日記 のブックマークコメント

これまでの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の場合なら第2引数変数部まで評価はしないといったように、関数系(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

次回予定

マクロ機能を作る

トラックバック - http://haskell.g.hatena.ne.jp/haskelisp/20070420

2007-04-13

defineを作る defineを作る - HaskellでLispを書く日記 を含むブックマーク はてなブックマーク - defineを作る - HaskellでLispを書く日記 defineを作る - HaskellでLispを書く日記 のブックマークコメント

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をシンプルにする

トラックバック - http://haskell.g.hatena.ne.jp/haskelisp/20070413

2007-04-09

対話環境を作る 対話環境を作る - HaskellでLispを書く日記 を含むブックマーク はてなブックマーク - 対話環境を作る - HaskellでLispを書く日記 対話環境を作る - HaskellでLispを書く日記 のブックマークコメント

今回は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を作る

トラックバック - http://haskell.g.hatena.ne.jp/haskelisp/20070409

2007-03-28

lambdaを作る lambdaを作る - HaskellでLispを書く日記 を含むブックマーク はてなブックマーク - lambdaを作る - HaskellでLispを書く日記 lambdaを作る - HaskellでLispを書く日記 のブックマークコメント

これまでは組み込み関数を作ってきたけど、今回からはlamda(クロージャ)を導入してユーザ定義の関数を作れるようにする。

クロージャ型を用意する

クロージャ関数の本体と、その関数が定義された時点の環境セットにしたデータ。なので、ここで用意するClosure型も関数本体と環境の2つのスロットを持たせる。関数本体は(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とした)は3つのリスト引数としてとり、1つめの引数リストと2つめの引数リストの各要素を対にして3つめの引数リストに追加する。

例をあげると、3つの引数が(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を作る

トラックバック - http://haskell.g.hatena.ne.jp/haskelisp/20070328

2007-03-17

述語関数を作る 述語関数を作る - HaskellでLispを書く日記 を含むブックマーク はてなブックマーク - 述語関数を作る - HaskellでLispを書く日記 述語関数を作る - HaskellでLispを書く日記 のブックマークコメント

前回はcar,cdr,consのリスト操作関数を作ったので、今回は真か偽を返す述語関数を作る。

具体的には、2つの引数が等しいかを判定するeq?と引数リスト(正確にはConsセル)かどうかを判定するpair?を作る。

なぜこの2つかというと、純LISPの基本関数がcar,cdr,cons,eq,atomの5つだから。eqはそのままschemeeq?と対応するけど、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

今日までの全コード 今日までの全コード - HaskellでLispを書く日記 を含むブックマーク はてなブックマーク - 今日までの全コード - HaskellでLispを書く日記 今日までの全コード - HaskellでLispを書く日記 のブックマークコメント

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

次回予告 次回予告 - HaskellでLispを書く日記 を含むブックマーク はてなブックマーク - 次回予告 - HaskellでLispを書く日記 次回予告 - HaskellでLispを書く日記 のブックマークコメント

lambdaを作る

トラックバック - http://haskell.g.hatena.ne.jp/haskelisp/20070317