Various fixes and improvements.

pkg/hair/lib/Data/Noun/Atom.hs

@@ -13,6 +13,7 @@ import GHC.Int
 import Data.Bits
 import Test.QuickCheck.Arbitrary
 import Test.QuickCheck.Gen
+import Text.Printf
 
 --------------------------------------------------------------------------------
 
@@ -61,6 +62,10 @@ instance IsAtom Natural where
   toAtom              = MkAtom
   fromAtom (MkAtom a) = a
 
+instance IsAtom Word where
+  toAtom   = fromIntegral
+  fromAtom = fromIntegral
+
 instance IsAtom Int where
   toAtom   = fromIntegral
   fromAtom = fromIntegral
@@ -125,3 +130,23 @@ bitIdx idx buf = testBit buf idx
 
 bitConcat :: Atom -> Atom -> Atom
 bitConcat x y = x .|. shiftL y (bitWidth x)
+
+
+-- Bit Buffers -----------------------------------------------------------------
+
+data Buf = Buf !Int !Atom
+
+instance Show Buf where
+  show (Buf sz bits) = "0b"
+                    <> replicate (sz - bitWidth bits) '0'
+                    <> printf "%b (%d bits)" (toInteger bits) sz
+
+instance Semigroup Buf where
+  Buf xSz xBuf <> Buf ySz yBuf = Buf (xSz+ySz) (xBuf .|. shiftL yBuf xSz)
+
+instance Monoid Buf where
+  mempty = Buf 0 0
+
+instance IsAtom Buf where
+  toAtom (Buf _ bits) = bits
+  fromAtom bits = Buf (bitWidth bits) bits

pkg/hair/lib/Data/Noun/Jam.hs

@@ -19,23 +19,23 @@ import Test.QuickCheck
 
 -- Length-Encoded Atoms --------------------------------------------------------
 
-mat :: Atom -> (Int, Atom)
-mat 0   = (1, 1)
-mat atm = (bufWid, buffer)
+mat :: Atom -> Buf
+mat 0   = Buf 1 1
+mat atm = Buf bufWid buffer
   where
     atmWid = bitWidth atm
     preWid = bitWidth (toAtom atmWid)
     bufWid = preWid + preWid + atmWid
     prefix = shiftL 1 preWid
-    extras = takeBits (preWid-1) $ toAtom atmWid
+    extras = takeBits (preWid-1) (toAtom atmWid)
     suffix = xor extras (shiftL atm (preWid-1))
     buffer = bitConcat prefix suffix
 
-rub :: Cursor -> Maybe (Int, Atom)
+rub :: Cursor -> Maybe Buf
 rub slc@(Cursor idx buf) =
   leadingZeros slc >>= \case
-    0      -> pure (1, 0)
-    prefix -> pure (sz, val)
+    0      -> pure (Buf 1 0)
+    prefix -> pure (Buf sz val)
       where
         widIdx = idx + 1 + prefix
         width  = fromSlice (Slice widIdx (prefix - 1) buf)
@@ -48,29 +48,29 @@ rub slc@(Cursor idx buf) =
 -- Noun Serialization ----------------------------------------------------------
 
 jam :: Noun -> Atom
-jam = view _2 . go 0 mempty
+jam = toAtom . fst . go 0 mempty
   where
     insertNoun :: Noun -> Int -> Map Noun Int -> Map Noun Int
     insertNoun n i tbl = lookup n tbl
                        & maybe tbl (const $ insertMap n i tbl)
 
-    go :: Int -> Map Noun Int -> Noun -> (Int, Atom, Map Noun Int)
-    go idx oldTbl noun =
-      let tbl = insertNoun noun idx oldTbl in
+    go :: Int -> Map Noun Int -> Noun -> (Buf, Map Noun Int)
+    go off oldTbl noun =
+      let tbl = insertNoun noun off oldTbl in
       case (Nothing :: Maybe Int, noun) of
-          (Just ref, Atom atm) | bitWidth atm <= bitWidth (toAtom ref) ->
-              (1+sz, shiftL res 1, tbl)
-                where (sz, res) = mat atm
-          (Just ref, _) ->
-              (2+sz, xor 3 (shiftL res 2), tbl)
-                where (sz, res) = mat (toAtom ref)
-          (Nothing, Atom atm) ->
-              (1+sz, shiftL res 1, tbl)
-                where (sz, res) = mat atm
-          (Nothing, Cell lef rit) ->
-            (2+lSz+rSz, xor 1 (shiftL (bitConcat lRes rRes) 2), rTbl)
-              where (lSz, lRes, lTbl) = go (idx+2)   tbl  lef
-                    (rSz, rRes, rTbl) = go (idx+lSz) lTbl rit
+        (Just ref, Atom atm) | bitWidth atm <= bitWidth (toAtom ref) ->
+          (Buf (1+sz) (shiftL res 1), tbl)
+            where Buf sz res = mat atm
+        (Just ref, _) ->
+          (Buf (2+sz) (xor 3 (shiftL res 2)), tbl)
+            where Buf sz res = mat (toAtom ref)
+        (Nothing, Atom atm) ->
+          (Buf (1+sz) (shiftL res 1), tbl)
+            where Buf sz res = mat atm
+        (Nothing, Cell lef rit) ->
+          (Buf (2+lSz+rSz) (xor 1 (shiftL (bitConcat lRes rRes) 2)), rTbl)
+            where (Buf lSz lRes, lTbl) = go (off+2)   tbl  lef
+                  (Buf rSz rRes, rTbl) = go (off+lSz) lTbl rit
 
 
 leadingZeros :: Cursor -> Maybe Int
@@ -85,14 +85,14 @@ cue buf = view _2 <$> go mempty 0
     go :: Map Int Noun -> Int -> Maybe (Int, Noun, Map Int Noun)
     go tbl i =
       case (bitIdx i buf, bitIdx (i+1) buf) of
-        (False, _     ) -> do (wid,at) <- rub (Cursor (i+1) buf)
+        (False, _     ) -> do Buf wid at <- rub (Cursor (i+1) buf)
                               let r = toNoun at
                               pure (wid+1, r, insertMap i r tbl)
         (True,  False ) -> do (lSz,lef,tbl) <- go tbl (i+2)
                               (rSz,rit,tbl) <- go tbl (i+2+fromIntegral lSz)
                               let r = Cell lef rit
                               pure (2+lSz+rSz, r, insertMap i r tbl)
-        (True,  True  ) -> do (wid,at) <- rub (Cursor (i+2) buf)
+        (True,  True  ) -> do Buf wid at <- rub (Cursor (i+2) buf)
                               r <- lookup (fromIntegral at) tbl
                               pure (2+wid, r, tbl)
 
@@ -116,47 +116,8 @@ prop_jamCue n = Just n == cue (jam n)
 prop_matRub :: Atom -> Bool
 prop_matRub atm = matSz==rubSz && rubRes==atm
   where
-    (matSz, matBuf) = mat atm
-    (rubSz, rubRes) = fromMaybe (0,0) (rub $ Cursor 0 matBuf)
+    Buf matSz matBuf = mat atm
+    Buf rubSz rubRes = fromMaybe mempty (rub $ Cursor 0 matBuf)
 
 main :: IO ()
 main = $(defaultMainGenerator)
-
---    ?:  =(0 a)
---      [1 1]
---    =+  b=(met 0 a)
---    =+  c=(met 0 b)
---    :-  (add (add c c) b)
---    (cat 0 (bex c) (mix (end 0 (dec c) b) (lsh 0 (dec c) a)))
-
---    |=  a/@
---    ^-  {p/@ q/@}
---    ?:  =(0 a)
---      [1 1]
---    =+  b=(met 0 a)
---    =+  c=(met 0 b)
---    :-  (add (add c c) b)
---    (cat 0 (bex c) )
-
---  ++  jam
---    |=  a/*
---    ^-  @
---    =+  b=0
---    =+  m=`(map * @)`~
---    =<  q
---    |-  ^-  {p/@ q/@ r/(map * @)}
---    =+  c=(~(get by m) a)
---    ?~  c
---      =>  .(m (~(put by m) a b))
---      ?:  ?=(@ a)
---        =+  d=(mat a)
---        [(add 1 p.d) (lsh 0 1 q.d) m]
---      =>  .(b (add 2 b))
---      =+  d=$(a -.a)
---      =+  e=$(a +.a, b (add b p.d), m r.d)
---      [(add 2 (add p.d p.e)) (mix 1 (lsh 0 2 (cat 0 q.d q.e))) r.e]
---    ?:  ?&(?=(@ a) (lte (met 0 a) (met 0 u.c)))
---      =+  d=(mat a)
---      [(add 1 p.d) (lsh 0 1 q.d) m]
---    =+  d=(mat u.c)
---    [(add 2 p.d) (mix 3 (lsh 0 2 q.d)) m]

pkg/hair/lib/Data/Noun/Zip.hs

@@ -4,27 +4,37 @@
 
 module Data.Noun.Zip where
 
-import ClassyPrelude
+import ClassyPrelude hiding (zip, unzip)
 
+import Control.Lens
+import Text.Printf
 import Control.Applicative
-import Control.Monad
 import Data.Noun
 import Data.Noun.Atom
+import Data.Noun.Jam
 import Data.Bits
 import GHC.Generics
 import Test.QuickCheck.Arbitrary
 import Test.QuickCheck.Gen
-import Debug.Trace
 
 import Data.List     (intercalate)
 import Data.Typeable (Typeable)
 
-import Control.Monad.State.Strict
+import Control.Monad.State.Strict hiding (forM_)
+import Control.Monad.Trans.Maybe
+
+import qualified Data.Vector as V
+import qualified Data.List   as L
+
+import Test.Tasty
+import Test.Tasty.TH
+import Test.Tasty.QuickCheck as QC
+import Test.QuickCheck
 
 
 -- External Types --------------------------------------------------------------
 
-newtype Zip = Zip [ZipNode]
+newtype Zip = Zip (Vector ZipNode)
   deriving newtype (Eq, Ord, Show)
 
 
@@ -35,18 +45,37 @@ data ZipNode
     | ZipCell !Word !Word
   deriving (Eq, Ord, Show)
 
-type ZipM a = State ([ZipNode], Word, Map Noun Word) a
-
 
 --------------------------------------------------------------------------------
 
+tag :: Bool -> Buf -> Buf
+tag bit buf = (if bit then Buf 1 1 else Buf 1 0) <> buf
+
+jamZipNode :: ZipNode -> Buf
+jamZipNode (ZipAtom a)   = tag False (mat a)
+jamZipNode (ZipCell l r) = tag True (mat (toAtom l) <> mat (toAtom r))
+
+jamZip :: Zip -> Buf
+jamZip (Zip vec) = fold (length : nodes)
+  where
+    length = mat (toAtom (V.length vec))
+    nodes  = jamZipNode <$> V.toList vec
+
+cueZip :: Buf -> Maybe Zip
+cueZip = undefined
+
+
+-- Zip -------------------------------------------------------------------------
+
+type ZipM a = State ([ZipNode], Word, Map Noun Word) a
+
 zip :: Noun -> Zip
 zip = \n -> evalState (go n >> end) ([], 0, mempty)
   where
     end :: ZipM Zip
     end = do
       (acc, _, _) <- get
-      pure (Zip $ reverse acc)
+      pure (Zip $ V.fromList $ reverse acc)
 
     ins :: Noun -> ZipNode -> ZipM Word
     ins noun node = do
@@ -62,5 +91,46 @@ zip = \n -> evalState (go n >> end) ([], 0, mempty)
         (Nothing, Atom atm) -> ins noun (ZipAtom atm)
         (Nothing, Cell l r) -> (ZipCell <$> go l <*> go r) >>= ins noun
 
+
+-- Unzip -----------------------------------------------------------------------
+
+type UnZipM a = MaybeT (State (Word, Map Word Noun)) a
+
 unzip :: Zip -> Maybe Noun
-unzip = undefined
+unzip (Zip vec) | V.length vec == 0 = Nothing
+unzip (Zip vec) =
+    L.last <$> cvt (V.toList vec)
+  where
+    cvt :: [ZipNode] -> Maybe [Noun]
+    cvt nodes = evalState (runMaybeT $ go nodes) (0, mempty)
+
+    ins :: Noun -> UnZipM Noun
+    ins noun = do
+      modify $ \(nex, tbl) -> (nex+1, insertMap nex noun tbl)
+      pure noun
+
+    find :: Word -> UnZipM Noun
+    find idx = do
+      (nex, tbl) <- get
+      lookup idx tbl & \case
+        Nothing  -> error "bad zip"
+        Just res -> pure res
+
+    go :: [ZipNode] -> UnZipM [Noun]
+    go = mapM $ \case ZipAtom a   -> ins (Atom a)
+                      ZipCell l r -> ins =<< Cell <$> find l <*> find r
+
+
+-- Tests -----------------------------------------------------------------------
+
+compareSize :: Noun -> (Int, Int)
+compareSize n = (jamSz, zipSz)
+  where
+    Buf jamSz _ =  fromAtom (jam n)
+    Buf zipSz _ =  jamZip (zip n)
+
+prop_zipUnzip :: Noun -> Bool
+prop_zipUnzip n = Just n == unzip (zip n)
+
+main :: IO ()
+main = $(defaultMainGenerator)

pkg/hair/package.yaml

@@ -51,6 +51,7 @@ dependencies:
   - text
   - these
   - time
+  - transformers
   - unordered-containers
   - vector