hnock

A Nock interpreter.
git clone git://git.jtobin.io/hnock.git
Log | Files | Refs | README | LICENSE

Eval.hs (3338B)

      1 module Nock.Eval (
      2     nock
      3   , eval
      4   ) where
      5 
      6 import Nock.Language
      7 
      8 data Error = Error Noun
      9   deriving Show
     10 
     11 type Possibly = Either Error
     12 
     13 nock :: Noun -> Possibly Noun
     14 nock = tar
     15 
     16 eval :: Expr -> Possibly Noun
     17 eval expr = case expr of
     18   Noun noun -> return noun
     19   Wut  e    -> wut e
     20   Lus  e    -> lus e
     21   Tis  e    -> tis e
     22   Net  e    -> net e
     23   Hax  e    -> hax e
     24   Tar  e    -> tar e
     25 
     26 wut :: Noun -> Possibly Noun
     27 wut noun = return $ case noun of
     28   Cell {} -> Atom 0
     29   Atom {} -> Atom 1
     30 
     31 lus :: Noun -> Possibly Noun
     32 lus noun = case noun of
     33   Cell {} -> Left (Error noun)
     34   Atom m  -> return (Atom (1 + m))
     35 
     36 tis :: Noun -> Possibly Noun
     37 tis noun = case noun of
     38   Atom {}  -> Left (Error noun)
     39   Cell m n -> return $
     40     if   m == n
     41     then Atom 0
     42     else Atom 1
     43 
     44 net :: Noun -> Possibly Noun
     45 net noun = case noun of
     46   Cell (Atom 1) a          -> return a
     47   Cell (Atom 2) (Cell a _) -> return a
     48   Cell (Atom 3) (Cell _ b) -> return b
     49   Cell (Atom a) b          ->
     50     if   even a
     51     then do
     52       inner <- net (Cell (Atom (a `div` 2)) b)
     53       net (Cell (Atom 2) inner)
     54     else do
     55       inner <- net (Cell (Atom ((a - 1) `div` 2)) b)
     56       net (Cell (Atom 3) inner)
     57 
     58   _ -> Left (Error noun)
     59 
     60 hax :: Noun -> Possibly Noun
     61 hax noun = case noun of
     62   Cell (Atom 1) (Cell a _) -> return a
     63   Cell (Atom a) (Cell b c) ->
     64     if   even a
     65     then do
     66       let e = a `div` 2
     67       inner <- net (Cell (Atom (e + e + 1)) c)
     68       hax (Cell (Atom e) (Cell (Cell b inner) c))
     69     else do
     70       let o = (a - 1) `div` 2
     71       inner <- net (Cell (Atom (o + o)) c)
     72       hax (Cell (Atom o) (Cell (Cell inner b) c))
     73   _ -> Left (Error noun)
     74 
     75 tar :: Noun -> Possibly Noun
     76 tar noun = case noun of
     77   Cell a (Cell (Cell b c) d) -> do
     78     inner0 <- tar (Cell a (Cell b c))
     79     inner1 <- tar (Cell a d)
     80     return (Cell inner0 inner1)
     81 
     82   Cell a (Cell (Atom 0) b) ->
     83     net (Cell b a)
     84 
     85   Cell _ (Cell (Atom 1) b) ->
     86     return b
     87 
     88   Cell a (Cell (Atom 2) (Cell b c)) -> do
     89     inner0 <- tar (Cell a b)
     90     inner1 <- tar (Cell a c)
     91     tar (Cell inner0 inner1)
     92 
     93   Cell a (Cell (Atom 3) b) -> do
     94     tard <- tar (Cell a b)
     95     wut tard
     96 
     97   Cell a (Cell (Atom 4) b) -> do
     98     tard <- tar (Cell a b)
     99     lus tard
    100 
    101   Cell a (Cell (Atom 5) (Cell b c)) -> do
    102     tard0 <- tar (Cell a b)
    103     tard1 <- tar (Cell a c)
    104     tis (Cell tard0 tard1)
    105 
    106   Cell a (Cell (Atom 6) (Cell b (Cell c d))) -> do
    107     tard0 <- tar (Cell a (Cell (Atom 4) (Cell (Atom 4) b)))
    108     tard1 <- tar (Cell (Cell (Atom 2) (Atom 3)) (Cell (Atom 0) tard0))
    109     tard2 <- tar (Cell (Cell c d) (Cell (Atom 0) tard1))
    110     tar (Cell a tard2)
    111 
    112   Cell a (Cell (Atom 7) (Cell b c)) -> do
    113     tard <- tar (Cell a b)
    114     tar (Cell tard c)
    115 
    116   Cell a (Cell (Atom 8) (Cell b c)) -> do
    117     tard <- tar (Cell a b)
    118     tar (Cell (Cell tard a) c)
    119 
    120   Cell a (Cell (Atom 9) (Cell b c)) -> do
    121     tard <- tar (Cell a c)
    122     tar (Cell tard
    123       (Cell (Atom 2) (Cell (Cell (Atom 0) (Atom 1)) (Cell (Atom 0) b))))
    124 
    125   Cell a (Cell (Atom 10) (Cell (Cell b c) d)) -> do
    126     tard0 <- tar (Cell a c)
    127     tard1 <- tar (Cell a d)
    128     hax (Cell b (Cell tard0 tard1))
    129 
    130   Cell a (Cell (Atom 11) (Cell (Cell _ c) d)) -> do
    131     tard0 <- tar (Cell a c)
    132     tard1 <- tar (Cell a d)
    133     tar (Cell (Cell tard0 tard1) (Cell (Atom 0) (Atom 3)))
    134 
    135   Cell a (Cell (Atom 11) (Cell _ c)) ->
    136     tar (Cell a c)
    137 
    138   _ -> Left (Error noun)
    139