LOUDS.hs

{-# LANGUAGE ViewPatterns #-}
import           Data.Sequence       (Seq, ViewL (..), viewl, (<|), (|>))
import qualified Data.Sequence       as Seq
import qualified Data.StringMap      as StringMap
import           Data.StringMap.Base (StringMap (..), deepNorm)
import           Text.Show.Pretty

-- build tree of this shape ('*' means root)
--
--      *
--     /|\
--    a i o
--   /   /|\
--  n   f n u
--        | |\
--        e r t
--
-- [1, 0, 1, 1, 1, 0, 1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0]

louds' :: StringMap a -> [Bool]
louds' sm0 = True: False: go (Seq.singleton sm0) Seq.empty
  where go s0 c0 | Seq.null s0 && Seq.null c0 =
          []

        -- we have children left
        go s0 cx0 | Seq.null s0 && not (Seq.null cx0) =
          go cx0 Seq.empty

        -- the usual branch, emit true
        go (viewl -> Branch _ c n :< sm) cx =
          True : go (n <| sm) (cx |> c)

        -- end of siblings, emit false
        go (viewl -> Empty :< sm) cx =
          False: go sm cx

        -- FIXME: As these are children relations, we should probably emit True:False here
        go (viewl -> Val _ Empty :< sm) cx =
          False : go sm cx

        go (viewl -> Val _ c :< sm) cx =
          True: False: go sm (cx |> c)

example :: StringMap Int
example = deepNorm $ StringMap.fromList
  [ ("an", 2)
  , ("i", 1)
  , ("of", 3)
  , ("one", 4)
  , ("our", 5)
  , ("out", 6)
--  , ("see", 3)
--  , ("ulrich", 4)
--  , ("vogel", 2)
--  , ("zeichen", 2)
--  , ("ziehen", 2)
  ]


main :: IO ()
main = do
  putStrLn $ ppShow $ louds' example