{-# LANGUAGE GeneralizedNewtypeDeriving #-}
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
{-# INLINE fromInteger #-}
(+) = (<+>)
{-# INLINE (+) #-}
(*) = (<.>)
{-# INLINE (*) #-}
abs = id
{-# INLINE abs #-}
signum (Free x) = if Map.null x then zero else one
{-# INLINE signum #-}
negate = id
{-# INLINE negate #-}
runFree :: Semiring s => (a -> s) -> Free a -> s
runFree f = getAdd #. Map.foldMapWithKey ((rep .# Add) . mulFoldable . fmap f) . getFree
{-# INLINE runFree #-}
lowerFree :: Semiring s => Free s -> s
lowerFree = runFree id
{-# INLINE lowerFree #-}
liftFree :: a -> Free a
liftFree = Free . flip Map.singleton one . pure
{-# INLINE liftFree #-}
instance Foldable Free where
foldMap f (Free xs) = Map.foldMapWithKey (rep . foldMap f) xs
{-# INLINE foldMap #-}
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)
{-# INLINE rep #-}