mirror of
https://github.com/coot/free-category.git
synced 2024-09-11 14:17:30 +03:00
Removed CatL
Other presentations have better performance, not need to explode the API.
This commit is contained in:
parent
d58d6b30f1
commit
6786025a6f
@ -83,29 +83,6 @@ main = defaultMain
|
||||
(fromListM (arrCat . Add) ints)
|
||||
]
|
||||
|
||||
, bgroup "CatL"
|
||||
[ bench "right right" $
|
||||
whnf
|
||||
(\c -> foldCatL interpret c 0)
|
||||
(fromListR (arrCatL . Add) ints)
|
||||
, bench "right left" $
|
||||
whnf
|
||||
(\c -> foldCatL interpret c 0)
|
||||
(fromListRL (arrCatL . Add) ints)
|
||||
, bench "left left" $
|
||||
whnf
|
||||
(\c -> foldCatL interpret c 0)
|
||||
(fromListL (arrCatL . Add) ints)
|
||||
, bench "left right" $
|
||||
whnf
|
||||
(\c -> foldCatL interpret c 0)
|
||||
(fromListLR (arrCatL . Add) ints)
|
||||
, bench "alternate" $
|
||||
whnf
|
||||
(\c -> foldCatL interpret c 0)
|
||||
(fromListM (arrCatL . Add) ints)
|
||||
]
|
||||
|
||||
, bgroup "ListTr"
|
||||
[ bench "right right" $
|
||||
whnf
|
||||
|
@ -28,12 +28,6 @@ module Control.Category.Free
|
||||
, arrCat
|
||||
, foldCat
|
||||
|
||||
-- * Free category
|
||||
, CatL (IdL)
|
||||
, arrCatL
|
||||
, mapCatL
|
||||
, foldCatL
|
||||
|
||||
-- * Free category (CPS style)
|
||||
, C (..)
|
||||
, toC
|
||||
@ -79,6 +73,11 @@ import Control.Category.Free.Internal
|
||||
import Unsafe.Coerce (unsafeCoerce)
|
||||
|
||||
|
||||
--
|
||||
-- Free categories based on real time queues; Ideas after E.Kmett's guanxi
|
||||
-- project.
|
||||
--
|
||||
|
||||
-- | Optimised version of a free category.
|
||||
--
|
||||
-- @('.')@ has @O\(1\)@ complexity, folding is @O\(n\)@ where @n@ is the number
|
||||
@ -220,108 +219,6 @@ instance FreeAlgebra2 Cat where
|
||||
codom2 = proof
|
||||
forget2 = proof
|
||||
|
||||
--
|
||||
-- Free categories based on real time queues; Ideas after E.Kmett's guanxi
|
||||
-- project.
|
||||
--
|
||||
|
||||
-- | Category for which morphism composition has @O\(1\)@ complexity and fold
|
||||
-- is linear in the number of transitions.
|
||||
--
|
||||
-- It has a good behaviour for morhisms build with 'foldl' (right to left).
|
||||
--
|
||||
data CatL (f :: k -> k -> *) a b where
|
||||
IdL :: CatL f a a
|
||||
CatL :: forall f a b c.
|
||||
f b c
|
||||
-> Queue (CatL f) a b
|
||||
-> CatL f a c
|
||||
|
||||
-- | Smart constructor for embeding spanning transitions into 'Cat', the same
|
||||
-- as @'liftFree2' \@'Cat'@. It is like 'arr' for 'Arrows'.
|
||||
--
|
||||
arrCatL :: forall (f :: k -> k -> *) a b.
|
||||
f a b
|
||||
-> CatL f a b
|
||||
arrCatL fab = CatL fab emptyQ
|
||||
{-# INLINE arrCatL #-}
|
||||
|
||||
-- | Smart constructor 'mapCatL' for morphisms of @'Cat' f@ category.
|
||||
--
|
||||
mapCatL :: forall (f :: k -> k -> *) a b c.
|
||||
f b c
|
||||
-> CatL f a b
|
||||
-> CatL f a c
|
||||
mapCatL fbc cab = arrCatL fbc . cab
|
||||
|
||||
-- | Right fold of 'Cat' into a category, the same as @'foldNatFree2' \@'Cat'@.
|
||||
--
|
||||
-- /complexity/: @O\(n\) where @n@ is number of transition embedded in 'Cat'.
|
||||
foldCatL :: forall f c a b.
|
||||
Category c
|
||||
=> (forall x y. f x y -> c x y)
|
||||
-> CatL f a b
|
||||
-> c a b
|
||||
foldCatL _nat IdL = id
|
||||
foldCatL nat (CatL tr q) =
|
||||
case q of
|
||||
NilQ -> nat tr
|
||||
ConsQ IdL q' -> nat tr . foldNatQ (foldCatL nat) q'
|
||||
ConsQ c q' -> nat tr . foldCatL nat c . foldNatQ (foldCatL nat) q'
|
||||
{-# INLINE foldCatL #-}
|
||||
|
||||
-- | /complexity/ of composition @('.')@: @O\(1\)@ (worst case)
|
||||
instance Category (CatL f) where
|
||||
id = IdL
|
||||
|
||||
CatL f q . h = CatL f (q `snoc` h)
|
||||
IdL . f = f
|
||||
{-# INLINE (.) #-}
|
||||
|
||||
type instance AlgebraType0 CatL f = ()
|
||||
type instance AlgebraType CatL c = Category c
|
||||
|
||||
-- | /complexity/ of 'foldNatFree2': @O\(n\)@ where @n@ is number of
|
||||
-- transitions embeded in 'Cat'.
|
||||
--
|
||||
instance FreeAlgebra2 CatL where
|
||||
liftFree2 = arrCatL
|
||||
|
||||
foldNatFree2 = foldCatL
|
||||
|
||||
codom2 = proof
|
||||
forget2 = proof
|
||||
|
||||
instance Arrow f => Arrow (CatL f) where
|
||||
arr = arrCatL . arr
|
||||
{-# INLINE arr #-}
|
||||
|
||||
CatL tr q *** CatL tr' q' = CatL (tr *** tr') (zipWithQ (***) q q')
|
||||
CatL tr q *** IdL = CatL (tr *** arr id) (zipWithQ (***) q NilQ)
|
||||
IdL *** CatL tr' q' = CatL (arr id *** tr') (zipWithQ (***) NilQ q')
|
||||
IdL *** IdL = CatL (arr id *** arr id) NilQ
|
||||
{-# INLINE (***) #-}
|
||||
|
||||
instance ArrowZero f => ArrowZero (CatL f) where
|
||||
zeroArrow = arrCatL zeroArrow
|
||||
|
||||
instance ArrowChoice f => ArrowChoice (CatL f) where
|
||||
CatL fxb cax +++ CatL fyb cay
|
||||
= CatL (fxb +++ fyb) (zipWithQ (+++) cax cay)
|
||||
CatL fxb cax +++ IdL = CatL (fxb +++ arr id) (zipWithQ (+++) cax NilQ)
|
||||
IdL +++ (CatL fxb cax) = CatL (arr id +++ fxb) (zipWithQ (+++) NilQ cax)
|
||||
IdL +++ IdL = IdL
|
||||
{-# INLINE (+++) #-}
|
||||
|
||||
instance Semigroup (CatL f o o) where
|
||||
f <> g = f . g
|
||||
|
||||
instance Monoid (CatL f o o) where
|
||||
mempty = IdL
|
||||
#if __GLASGOW_HASKELL__ < 804
|
||||
mappend = (<>)
|
||||
#endif
|
||||
|
||||
--
|
||||
-- CPS style free categories
|
||||
--
|
||||
|
@ -29,7 +29,6 @@ tests :: TestTree
|
||||
tests =
|
||||
testGroup "Control.Category.Free"
|
||||
[ testProperty "Cat" prop_Cat
|
||||
, testProperty "CatL" prop_CatL
|
||||
, testProperty "C" prop_C
|
||||
]
|
||||
|
||||
@ -185,9 +184,9 @@ instance Arbitrary ArbListTr where
|
||||
|
||||
|
||||
--
|
||||
-- test 'Cat', 'CatL' and 'C' treating 'ListTr' as a model to compare to.
|
||||
-- test 'Cat' and 'C' treating 'ListTr' as a model to compare to.
|
||||
--
|
||||
prop_Cat, prop_CatL, prop_C
|
||||
prop_Cat, prop_C
|
||||
:: Blind ArbListTr -> Bool
|
||||
|
||||
|
||||
@ -205,20 +204,6 @@ prop_Cat (Blind (ArbListTr listTr SNatural _)) =
|
||||
foldNatFree2 interpretTr listTr 0
|
||||
|
||||
|
||||
prop_CatL (Blind (ArbListTr listTr SInt _)) =
|
||||
foldNatFree2 interpretTr (hoistFreeH2 @_ @CatL listTr) 0
|
||||
==
|
||||
foldNatFree2 interpretTr listTr 0
|
||||
prop_CatL (Blind (ArbListTr listTr SInteger _)) =
|
||||
foldNatFree2 interpretTr (hoistFreeH2 @_ @CatL listTr) 0
|
||||
==
|
||||
foldNatFree2 interpretTr listTr 0
|
||||
prop_CatL (Blind (ArbListTr listTr SNatural _)) =
|
||||
foldNatFree2 interpretTr (hoistFreeH2 @_ @CatL listTr) 0
|
||||
==
|
||||
foldNatFree2 interpretTr listTr 0
|
||||
|
||||
|
||||
prop_C (Blind (ArbListTr listTr SInt _)) =
|
||||
foldNatFree2 interpretTr (hoistFreeH2 @_ @C listTr) 0
|
||||
==
|
||||
|
Loading…
Reference in New Issue
Block a user