RoseBush.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE FlexibleInstances #-}

module Data.Char.CEDICT.Reader.RoseBush
  ( readyToSerialize
  ) where

import Data.Char.CEDICT.Reader.ListRebuild

import Control.Arrow
import Data.Maybe
import Data.List
import Data.Ord


readyToSerialize ::
  DictList -> ([(Int, [(Char, Int)])], [[(String, String)]])
readyToSerialize             =  packForConversion . map lenBush . part


data (Ord k) => RoseBush k v
  = Bud k v
  | Blossom k v [RoseBush k v] 
  | Petals k [RoseBush k v]

key rose =
  case rose of
    Bud k _                 ->  k
    Blossom k _ _           ->  k
    Petals k _              ->  k

instance (Ord k, Show k, Show v) => Show (RoseBush k v) where
  show bush                  =  show' 0 show bush
instance (Show v) => Show (RoseBush Char v) where
  show bush                  =  show' 0 passChar  bush
   where
    passChar c               =  [c]

show' ::
  (Ord k, Show k, Show v) => Int -> (k -> String) -> RoseBush k v -> String
show' i kHandler bush =
  case bush of
    Bud k v                 ->  ws $ unwords [kHandler k, ":", show v]
    Blossom k v roses ->
      (ws $ unwords [kHandler k, ":", show v]) ++ (recurse roses)
    Petals k roses  ->
      (ws $ kHandler k) ++ (recurse roses)
 where
  ws                         =  ((replicate i ' ') ++) . (++ "\n")
  recurse                    =  concat . map (show' (i + 2) kHandler)


part []                      =  []
part (([ ], v):rest)         =  part rest         
part ((k:s, v):rest)         =  leader : (part outer)
 where
  (inner, outer)             =  part' k rest
  leader =
    if null s then
      if null inner then
        Bud k v 
      else
        Blossom k v $ part $ pop inner
    else
      Petals k $ part $ (s, v):(pop inner)

part' k                      =  partition ((== k) . head . fst) . nonNulls 
pop                          =  nonNulls . map (first tail) 
nonNulls                     =  filter $ not . null . fst


lenBush rose =
  case rose of
    Bud k v                 ->  Bud k (Just v, len) 
    Blossom k v roses       ->  Blossom k (Just v, len) $ lenBush' roses
    Petals k roses          ->  Blossom k (Nothing, len) $ lenBush' roses
 where
  len                        =  lenSubList rose

lenBush'                     =  map $ lenBush

linearize lists keys         =  (1 * lists) + (2 * keys)

serialize roses              =  top : recurse
 where
  top                        =  serialize' (1, length roses) roses
  recurse                    =  concatMap serialize $ pullUp roses
  pullUp []                  =  []
  pullUp (h:t) =
    case h of
      Blossom _ _ roses     ->  roses : (pullUp t)
      Bud _ _               ->  pullUp t
      Petals _ _            ->  pullUp t
  serialize' _ []            =  []
  serialize' o (h:t) =
    case h of
      Blossom k (v, o') _   ->  (Bud k (v, o)) : (serialize' (sumX o o') t)
      Bud k (v, _)          ->  h : (serialize' o t)
      Petals _ _            ->  serialize' o t


packForConversion roses      =  (searchList, pinDefList)
 where
  seared                     =  serialize roses
  searchList                 =  map (length &&& (map pullO)) seared
  pinDefList                 =  concatMap (c' . (vals &&& spacers)) seared
   where
    spacers                  =  flip replicate [] . length
    vals                     =  map pullV
    c'                       =  ([] :) . uncurry (++)
  pullO (Bud k (_, o))       =  (k, uncurry linearize $ o)
  pullO (Blossom k (_, o) _) =  (k, uncurry linearize $ o)
  pullV rose =
    case rose of
      Bud k (Just v, _)     ->  v
      Blossom k (Just v, _) _ -> v
      _                     ->  []


lenSubList                  ::  (Ord k) => RoseBush k v -> (Int, Int)
lenSubList rose =
  case rose of
    Bud _ _                 ->  (0, 0)
    Blossom _ _ roses       ->  recurse roses
    Petals _ roses          ->  recurse roses

recurse roses = foldl sumX (1, length roses) (map lenSubList roses)

sumX (a, b) (a', b')         =  (a + a', b + b')

samples                      =  sort
  [ "modes"
  , "cats"
  , "ca"
  , "a"
  , "letters"
  , "latrine"
  , "moses"
  , "mosey"
  , "axiom"
  ]