public
Last active

*sigh*

  • Download Gist
Main.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55
module Main (main) where
 
import Control.Monad.RWS
import Control.Monad.Writer
import Data.Binary.Builder
import qualified Data.ByteString.Lazy as Lazy
import Data.Hashable
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as Map
-- import Data.Map (Map)
-- import qualified Data.Map as Map
import Data.Word
 
data Node = Node
{ val :: Word8
, next :: Node
}
 
instance Eq Node where
Node a _ == Node b _ = a == b
instance Ord Node where -- for use in Data.Map
Node a _ < Node b _ = a < b
instance Hashable Node where -- for use in Data.HashMap.Lazy
hash (Node a _) = fromIntegral a
 
type M = HashMap Node Word8
-- type M = Map Node Word8
type Encoder = RWST M M Word8 (Writer Builder) ()
 
runEncoder :: Encoder -> [Word8]
runEncoder rwst =
let knot ~(_, _, m) = runRWST rwst m 0
(_, b) = runWriter $ mfix knot
in Lazy.unpack $ toLazyByteString b
 
encodeNode :: Node -> Encoder
encodeNode n = do
pos <- get
put $ pos + 1
m <- ask
tell $ Map.singleton n pos
let valbuilder = singleton $ val n
nextbuilder = singleton $ m Map.! (next n)
lift . tell $ valbuilder <> nextbuilder
 
encodeCycle :: Encoder
encodeCycle =
let n0 = Node 0 n1
n1 = Node 1 n0
in do
encodeNode n0
encodeNode n1
 
main :: IO ()
main = putStrLn . show . runEncoder $ encodeCycle
test.cabal
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
name: test
version: 0.1
build-type: Simple
cabal-version: >= 1.2
 
executable test
hs-source-dirs: src
build-depends: base,
binary,
bytestring,
containers,
hashable,
unordered-containers,
mtl
ghc-options: -Wall
main-is: Main.hs

See related StackOverflow post. As it turns out, unsurprisingly, I'm an even bigger moron than I thought: my Ord instance is broken. It needs to define either >= or compare.

No! It's <= or compare :) Cheers!

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.