HaskellでLispを書く日記

■ 述語関数を作る

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