hnock

commit b8142c562fff754fb1c7145ac5ddc05f57e971a6
parent 4d2d660b56563e11fc9d990ec6f3eff474afb0a8
Author: Jared Tobin <jared@jtobin.ca>
Date:   Fri, 13 Jul 2018 08:12:08 +1200

Fix fas typo, etc.

Diffstat:
M
Nock.hs
 | 
78
++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------------

1 file changed, 54 insertions(+), 24 deletions(-)
diff --git a/Nock.hs b/Nock.hs
@@ -1,8 +1,8 @@
 {-# OPTIONS_GHC -Wall #-}
 
 data Noun =
-    Atom Int
-  | Cell Noun Noun
+    Atom !Int
+  | Cell !Noun !Noun
   deriving Eq
 
 instance Show Noun where
@@ -11,33 +11,33 @@ instance Show Noun where
     Cell m n -> mconcat ["[", show m, " ", show n, "]"]
 
 data ExprF a =
-    Lit a
-  | Wut a
-  | Lus a
-  | Tis a
-  | Fas a
-  | Tar a
+    Noun !a
+  | Wut !a
+  | Lus !a
+  | Tis !a
+  | Fas !a
+  | Tar !a
   deriving Eq
 
 instance Show a => Show (ExprF a) where
   show op = case op of
-    Lit n -> show n
-    Wut n -> mconcat ["?", show n]
-    Lus n -> mconcat ["+", show n]
-    Tis n -> mconcat ["=", show n]
-    Fas n -> mconcat ["/", show n]
-    Tar n -> mconcat ["*", show n]
+    Noun n -> show n
+    Wut n  -> mconcat ["?", show n]
+    Lus n  -> mconcat ["+", show n]
+    Tis n  -> mconcat ["=", show n]
+    Fas n  -> mconcat ["/", show n]
+    Tar n  -> mconcat ["*", show n]
 
 type Expr = ExprF Noun
 
 nock :: Expr -> Noun
 nock expr = case expr of
-  Lit noun -> noun
-  Wut noun -> wut noun
-  Lus noun -> lus noun
-  Tis noun -> tis noun
-  Fas noun -> fas noun
-  Tar noun -> tar noun
+  Noun noun -> noun
+  Wut  noun -> wut noun
+  Lus  noun -> lus noun
+  Tis  noun -> tis noun
+  Fas  noun -> fas noun
+  Tar  noun -> tar noun
 
 -- production rules
 
@@ -79,10 +79,10 @@ fas noun = case noun of
       _ ->
         if    even a
         then
-          let inner = fas (Cell (Atom (a `rem` 2)) n)
+          let inner = Cell (Atom (a `div` 2)) n
           in  fas (Cell (Atom 2) (fas inner))
         else
-          let inner = fas (Cell (Atom ((a - 1) `rem` 2)) n)
+          let inner = Cell (Atom ((a - 1) `div` 2)) n
           in  fas (Cell (Atom 3) (fas inner))
 
 
@@ -178,7 +178,7 @@ tar10 a _ c d =
           (Cell (Cell (Atom 0) (Atom 3))
             d))))
 
--- test expressions
+-- test expressions -----------------------------------------------------------
 
 -- /[3 [[4 5] [6 14 15]]]
 -- should be [6 [14 15]]
@@ -191,7 +191,6 @@ test0 =
 
 -- *[[[4 5] [6 14 15]] [0 7]]
 -- should be [14 15]
--- FIXME blows the stack at present
 test1 :: Expr
 test1 =
   Tar
@@ -225,3 +224,34 @@ test4 =
     (Cell (Cell (Atom 132) (Atom 19))
       (Cell (Atom 4)
         (Cell (Atom 0) (Atom 3))))
+
+-- /[7 [[4 5] [6 14 15]]]
+-- should be [14 15]
+test5 :: Expr
+test5 =
+  Fas
+    (Cell (Atom 7)
+      (Cell (Cell (Atom 4) (Atom 5))
+        (Cell (Atom 6) (Cell (Atom 14) (Atom 15)))))
+
+-- *[77 [2 [1 42] [1 1 153 218]]]
+-- should be [153 218]
+test6 :: Expr
+test6 =
+  Tar
+    (Cell (Atom 77)
+      (Cell (Atom 2)
+        (Cell (Cell (Atom 1) (Atom 42))
+          (Cell (Atom 1)
+            (Cell (Atom 1)
+              (Cell (Atom 153) (Atom 218)))))))
+
+main :: IO ()
+main = do
+  print (nock test0)
+  print (nock test1)
+  print (nock test2)
+  print (nock test3)
+  print (nock test4)
+  print (nock test5)
+  print (nock test6)