リハビリがてらにlis.pyをlis.rbに書き直してみたのをlis.hsに書き直してみた

先日のつづき。

気持ちとしては。翌日にもアップしたかったものの。予想以上にはまることになり。とういうかHaskell忘れすぎ。脳のHaskell野の活動が弱くなってます。

一番ハマったのがシンボルにリストと実引数のリストから、辞書を作る式。

ss = [SYMBOL "x", SYMBOL "y", SYMBOL "z"]

と

vs = [1, 2, 3]

から

[("x",1),("y",2),("z",3)]

を作りたかったんですが、最初に書いた式がこう。

[(s, v) | SYMBOL s <- ss, v <- vs]

いま見ると初歩的な間違いすぎて頭かかえたくなります。これを評価するとssとvsの直積を作ってしまいます、当然。

正しくはこうでした。

[(s, v) | (SYMBOL s, v) <- zip ss vs]

これに気付くのに丸一日以上かかったなんて、どんだけ弱ってるんだオレのHaskell野、という気分

以下コード。
いろいろおかしな所がありますが、さらしておきます。
（こちらにも格納：gist:775233 · GitHub）

module Main where

import IO

type Function = [Atom] -> Atom

type Env = [(String, Atom)]

data Atom = INT Integer
          | REAL Double
          | BOOL Bool
          | SYMBOL String
          | LIST [Atom] 
          | PROC Atom Atom
          | FUNCTION Function

toString (INT i)    = show i
toString (REAL r)   = show r
toString (BOOL b)   = show b
toString (SYMBOL s) = s
toString (LIST xs)  = '(':' ':(toString' xs)
                        where 
                          toString' []     = ")"
                          toString' (x:xs) = (toString x) ++ ' ':(toString' xs)
toString (PROC vars exp) = "proc " ++ (toString vars) ++ " " ++ (toString exp)
toString (FUNCTION _) = "function"

lisp_add [INT x,    INT y]    = INT   (x + y)
lisp_add [INT x,    REAL y]   = REAL (fromInteger x + y)
lisp_add [REAL x,   INT y]    = REAL (x + fromInteger y)
lisp_add [REAL x,   REAL y]   = REAL (x + y)

lisp_sub [INT x,  INT y]  = INT   (x - y)
lisp_sub [INT x,  REAL y] = REAL (fromInteger x - y)
lisp_sub [REAL x, INT y]  = REAL (x - fromInteger y)
lisp_sub [REAL x, REAL y] = REAL (x - y)

lisp_mul [INT x,  INT y]  = INT   (x * y)
lisp_mul [INT x,  REAL y] = REAL (fromInteger x * y)
lisp_mul [REAL x, INT y]  = REAL (x * fromInteger y)
lisp_mul [REAL x, REAL y] = REAL (x * y)

lisp_div [INT x,  INT y]  = INT  (x `div` y)
lisp_div [INT x,  REAL y] = REAL (fromInteger x / y)
lisp_div [REAL x, INT y]  = REAL (x / fromInteger y)
lisp_div [REAL x, REAL y] = REAL (x / y)

lisp_not [BOOL x] = BOOL (not x)

lisp_gt  [INT x,    INT y]    = BOOL (x > y)
lisp_gt  [INT x,    REAL y]   = BOOL (fromInteger x > y)
lisp_gt  [REAL x,   INT y]    = BOOL (x > fromInteger y)
lisp_gt  [REAL x,   REAL y]   = BOOL (x > y)
lisp_gt  [BOOL x,   BOOL y]   = BOOL (x > y)
lisp_gt  [SYMBOL x, SYMBOL y] = BOOL (x > y)

lisp_lt  [INT x,    INT y]    = BOOL (x < y)
lisp_lt  [INT x,    REAL y]   = BOOL (fromInteger x < y)
lisp_lt  [REAL x,   INT y]    = BOOL (x < fromInteger y)
lisp_lt  [REAL x,   REAL y]   = BOOL (x < y)
lisp_lt  [SYMBOL x, SYMBOL y] = BOOL (x < y)

lisp_ge  [INT x,    INT y]    = BOOL (x >= y)
lisp_ge  [INT x,    REAL y]   = BOOL (fromInteger x >= y)
lisp_ge  [REAL x,   INT y]    = BOOL (x >= fromInteger y)
lisp_ge  [REAL x,   REAL y]   = BOOL (x >= y)
lisp_ge  [BOOL x,   BOOL y]   = BOOL (x >= y)
lisp_ge  [SYMBOL x, SYMBOL y] = BOOL (x >= y)

lisp_le  [INT x,    INT y]    = BOOL (x <= y)
lisp_le  [INT x,    REAL y]   = BOOL (fromInteger x <= y)
lisp_le  [REAL x,   INT y]    = BOOL (x <= fromInteger y)
lisp_le  [REAL x,   REAL y]   = BOOL (x <= y)
lisp_le  [SYMBOL x, SYMBOL y] = BOOL (x <= y)

lisp_eq  [INT x,    INT y]    = BOOL (x == y)
lisp_eq  [INT x,    REAL y]   = BOOL (fromInteger x == y)
lisp_eq  [REAL x,   INT y]    = BOOL (x == fromInteger y)
lisp_eq  [REAL x,   REAL y]   = BOOL (x == y)
lisp_eq  [SYMBOL x, SYMBOL y] = BOOL (x == y)

lisp_length [LIST x] = INT (toInteger $ length x)

lisp_cons [x, LIST xs] = LIST (x:xs)

lisp_car [LIST (x:xs)] = x

lisp_cdr [LIST (x:xs)] = LIST xs

lisp_append [LIST x, LIST y] = LIST (x ++ y)

lisp_list x = LIST x

lisp_islist [LIST x] = BOOL True
lisp_islist _        = BOOL False

lisp_isnull [LIST []] = BOOL True
lisp_isnull [LIST _]  = BOOL False

lisp_issymbol [SYMBOL _] = BOOL True
lisp_issymbol _          = BOOL False

toAtom fn = FUNCTION fn

global_env :: Env
global_env = [
   ("+",       toAtom lisp_add),
   ("-",       toAtom lisp_sub),
   ("*",       toAtom lisp_mul),
   ("/",       toAtom lisp_div),
   ("not",     toAtom lisp_not),
   (">",       toAtom lisp_gt),
   ("<",       toAtom lisp_lt),
   (">=",      toAtom lisp_ge),
   ("<=",      toAtom lisp_le),
   ("=",       toAtom lisp_eq),
   ("equal?",  toAtom lisp_eq),
   ("length",  toAtom lisp_length),
   ("cons",    toAtom lisp_cons),
   ("car",     toAtom lisp_car),
   ("cdr",     toAtom lisp_cdr),
   ("append",  toAtom lisp_append),
   ("list",    toAtom lisp_list),
   ("list?",   toAtom lisp_islist),
   ("null?",   toAtom lisp_isnull),
   ("symbol?", toAtom lisp_issymbol)
 ]

lisp_if (BOOL True,  _) conseq _   = conseq
lisp_if (BOOL False, _) _      alt = alt

eval (INT i)                                    env = (INT i, env)
eval (REAL r)                                   env = (REAL r, env)
eval (BOOL b)                                   env = (BOOL b, env)
eval (SYMBOL s)                                 env = (case (lookup s env) of Just a -> (a, env))
eval (LIST ((SYMBOL "quote"):a:[]))             env = (a, env)
eval (LIST ((SYMBOL "if"):t:c:a:[]))            env = eval (lisp_if (eval t env) c a) env
eval (LIST ((SYMBOL "set!"):(SYMBOL s):v:[]))   env = case (lookup s env) of 
                                                        Just _ -> let (r, _) = eval v env in (r, (s, r):env)
eval (LIST ((SYMBOL "define"):(SYMBOL s):v:[])) env = let (r, _) = eval v env in (r, (s, r):env)
eval (LIST ((SYMBOL "lambda"):a:e:[]))          env = (PROC a e, env)
eval (LIST ((SYMBOL "begin"):as))               env = foldl (\(_, e) a -> (eval a e)) (LIST [], env) as
eval (LIST as)                                  env =
  case v of
    PROC as exp -> (evalProc as vs exp env, env)
    FUNCTION fn -> (fn vs, env)
    _           -> error $ "ERROR:" ++ (toString v)
  where
    ((v:vs), e) = eval' [] as env
    eval' r []     env = (r, env)
    eval' r (a:as) env = let (v, new_env) = eval a env in eval' (r ++ [v]) as new_env
    evalProc (LIST ss) ps exp env = fst $ eval exp ([(s, p) | (SYMBOL s, p) <- zip ss ps] ++ env)

atom token =
  catch (do { i <- readIO token :: IO Integer; return $ INT i })
        (\_ -> catch (do { r <- readIO token :: IO Double; return $ REAL r})
                     (\_ -> return $ SYMBOL token))

read_from :: [String] -> IO Atom
read_from ts = do
  (result, _) <- read_from' ts
  return result

read_from' :: [String] -> IO (Atom, [String])
read_from' ("(":ts) = read_list [] ts
read_from' (")":ts) = error "unexpected"
read_from' (t:ts)   = do { a <- atom t; return (a, ts) }

read_list :: [Atom] -> [String] -> IO (Atom, [String])
read_list as (")":ts) = return (LIST as, ts)
read_list as ts       = do
  (atom, rest)  <- read_from' ts
  read_list (as ++ [atom]) rest

tokenize s = words $ tokenize_ s
  where
    tokenize_ ""       = ""
    tokenize_ ('(':ss) = ' ':'(':' ':(tokenize_ ss)
    tokenize_ (')':ss) = ' ':')':' ':(tokenize_ ss)
    tokenize_ (s:ss)   = s:(tokenize_ ss)

parse :: String -> IO Atom
parse s = read_from $ tokenize s

repl prompt env = do
  putStr prompt
  hFlush stdout
  atom <- parse =<< getLine
  let (result, new_env) = eval atom env
  putStrLn $ toString result
  repl prompt new_env

main = repl "lis.hs> " global_env

実行結果。

 $ ./lis
 lis.hs> (+ 1 2)
 3
 lis.hs> (- 2 3)
 -1
 lis.hs> (* (+ 3 4) (/ 9 3)) 
 21
 lis.hs> (quote (1 2 3))
 ( 1 2 3 )
 lis.hs> (< 1 2)
 True
 lis.hs> (> 1 2)
 False
 lis.hs> (list 1 2 3)
 ( 1 2 3 )
 lis.hs> (car (quote (1 2 3)))
 1
 lis.hs> (cdr (quote (1 2 3)))
 ( 2 3 )
 lis.hs> (cons 1 (quote (2 3)))
 ( 1 2 3 )
 lis.hs> (define x2 (lambda (x) (* x 2)))
 proc ( x ) ( * x 2 )
 lis.hs> (x2 10)
 20
 lis.hs> (define add (lambda (x y) (+ x y)))
 proc ( x y ) ( + x y )
 lis.hs> (add 1 10)
 11