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

{-
  Can de-duplication be orthogonal to serialization?
-}

module Data.Noun.Zip where

import ClassyPrelude

import Control.Applicative
import Control.Monad
import Data.Noun
import Data.Noun.Atom
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


-- External Types --------------------------------------------------------------

newtype Zip = Zip [ZipNode]
  deriving newtype (Eq, Ord, Show)


-- Internal Types --------------------------------------------------------------

data ZipNode
    = ZipAtom !Atom
    | ZipCell !Word !Word
  deriving (Eq, Ord, Show)

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)

    ins :: Noun -> ZipNode -> ZipM Word
    ins noun node = do
      (acc, nex, tbl) <- get
      put (node:acc, nex+1, insertMap noun nex tbl)
      pure nex

    go :: Noun -> ZipM Word
    go noun = do
      (acc, nex, tbl) <- get
      case (lookup noun tbl, noun) of
        (Just w,  _)        -> pure w
        (Nothing, Atom atm) -> ins noun (ZipAtom atm)
        (Nothing, Cell l r) -> (ZipCell <$> go l <*> go r) >>= ins noun

unzip :: Zip -> Maybe Noun
unzip = undefined