module Data.Semiring.Free
(Free(..)
,liftFree
,lowerFree
,runFree)
where
import Data.Semiring
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Numeric.Natural
import Data.Semiring.Newtype
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
newtype Free a = Free
{ getFree :: Map (Seq a) Natural
} deriving (Show, Read, Eq, Ord, Semiring)
instance Ord a => Num (Free a) where
fromInteger = Free . Map.singleton Seq.empty . fromInteger
(+) = (<+>)
(*) = (<.>)
abs = id
signum (Free x) = if Map.null x then zero else one
negate = id
runFree :: Semiring s => (a -> s) -> Free a -> s
runFree f = getAdd #. Map.foldMapWithKey ((rep .# Add) . mulFoldable . fmap f) . getFree
lowerFree :: Semiring s => Free s -> s
lowerFree = runFree id
liftFree :: a -> Free a
liftFree = Free . flip Map.singleton one . pure
instance Foldable Free where
foldMap f (Free xs) = Map.foldMapWithKey (rep . foldMap f) xs
rep :: Monoid m => m -> Natural -> m
rep x = go
where
go 0 = mempty
go 1 = x
go n
| even n = r `mappend` r
| otherwise = x `mappend` r `mappend` r
where
r = go (n `div` 2)