Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

haskell implementation

minus read
  • Loading branch information...
commit df4fd5711b96f1f788eed2e56a2899716890bfca 1 parent 6ad5da3
Bjarte Johansen authored March 15, 2013

Showing 1 changed file with 70 additions and 0 deletions. Show diff stats Hide diff stats

  1. 70  src/sigmatism/hs/sigmatism.hs
70  src/sigmatism/hs/sigmatism.hs
... ...
@@ -0,0 +1,70 @@
  1
+module Sigmatism
  2
+(   eval
  3
+  , read
  4
+) where
  5
+
  6
+data Expr = Symbol String
  7
+          | Cons {car :: Expr, cdr :: Expr}
  8
+          | Nil
  9
+          | T
  10
+          deriving(Show, Eq)
  11
+
  12
+eq :: Expr -> Expr -> Expr
  13
+eq Nil Nil = T
  14
+eq (Symbol a) (Symbol b) = if (a == b) then T else Nil
  15
+eq _ _ = Nil
  16
+
  17
+assoc :: Expr -> Expr -> Expr
  18
+assoc a (Cons f s) =
  19
+  if T == eq a (car f) then
  20
+    cdr f
  21
+  else
  22
+    assoc a s
  23
+
  24
+atom (Symbol _) = T
  25
+atom Nil = T
  26
+atom _ = Nil
  27
+
  28
+evcon :: Expr -> Expr -> Expr
  29
+evcon (Cons f s) a =
  30
+  if T == eval (car f) a then
  31
+    eval ((car.cdr) f) a
  32
+  else
  33
+    evcon s a
  34
+
  35
+pair :: Expr -> Expr -> Expr
  36
+pair Nil Nil = Nil
  37
+pair (Cons f r) (Cons h t) =
  38
+  Cons (Cons f (Cons h Nil)) (pair r t)
  39
+
  40
+evlis :: Expr -> Expr -> Expr
  41
+evlis Nil _ = Nil
  42
+evlis (Cons f r) a = Cons (eval f a) (evlis r a)
  43
+
  44
+append :: Expr -> Expr -> Expr
  45
+append Nil y = y
  46
+append (Cons f r) y = Cons f (append r y)
  47
+
  48
+eval :: Expr -> Expr -> Expr
  49
+eval (Symbol s) ns = assoc (Symbol s) ns
  50
+eval (Cons (Symbol s) snd) a
  51
+  | s == "quote" = car snd
  52
+  | s == "atom"  = atom $ eval (car snd) a
  53
+  | s == "eq"    = eq (eval (car snd) a) (eval ((car.cdr) snd) a)
  54
+  | s == "car"   = car $ eval (car snd) a
  55
+  | s == "cdr"   = cdr $ eval (car snd) a
  56
+  | s == "cons"  = (Cons (eval (car snd) a) (eval ((car.cdr) snd) a))
  57
+  | s == "cond"  = evcon snd a
  58
+  | otherwise = eval (Cons (assoc (Symbol s) a) snd) a
  59
+eval (Cons (Cons (Symbol "label") rest) snd) a =
  60
+  let label = (Cons (car rest) (Cons (Cons (Symbol "label") rest) Nil))
  61
+      ns    = (Cons label a)
  62
+      expr  = ((car.cdr) rest)
  63
+  in
  64
+   eval expr ns
  65
+eval (Cons (Cons (Symbol "lambda") rest) snd) a =
  66
+  let expr  = ((car.cdr) rest)
  67
+      pairs = pair (car rest) $ evlis snd a
  68
+      ns    = append pairs a
  69
+  in
  70
+   eval expr ns

0 notes on commit df4fd57

Please sign in to comment.
Something went wrong with that request. Please try again.