HaskellでLispを書く日記

■ 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を作る