GAS_copy :: GArrowSkeleton m x (x,x)
GAS_swap :: GArrowSkeleton m (x,y) (y,x)
GAS_merge :: GArrowSkeleton m (x,y) z
- GAS_loopl :: GArrowSkeleton m (x,z) (y,z) -> GArrowSkeleton m x y
- GAS_loopr :: GArrowSkeleton m (z,x) (z,y) -> GArrowSkeleton m x y
+ GAS_loopl :: GArrowSkeleton m (z,x) (z,y) -> GArrowSkeleton m x y
+ GAS_loopr :: GArrowSkeleton m (x,z) (y,z) -> GArrowSkeleton m x y
GAS_misc :: m x y -> GArrowSkeleton m x y
instance Category (GArrowSkeleton m) where
type instance GArrowUnit (GArrowSkeleton m) = ()
type instance GArrowExponent (GArrowSkeleton m) = (->)
-instance GArrowSTKC (GArrowSkeleton m)
+instance GArrowSTKCL (GArrowSkeleton m)
--
-- | Simple structural equality on skeletons. NOTE: two skeletons
-- left-associativity and hope for the best
optimize' (GAS_comp f (GAS_comp g h)) = GAS_comp (GAS_comp f g) h
optimize' (GAS_comp (GAS_comp f (GAS_comp g h)) k) = GAS_comp (GAS_comp (GAS_comp f g) h) k
+
+ optimize' (GAS_comp (GAS_comp GAS_unassoc (GAS_second g)) GAS_assoc) = GAS_second (GAS_second g)
+ optimize' (GAS_comp (GAS_comp (GAS_comp f GAS_unassoc) (GAS_second g)) GAS_assoc) = GAS_comp f (GAS_second (GAS_second g))
+
optimize' (GAS_comp (GAS_comp f g) h) = case optimize_pair g h of
Nothing -> GAS_comp (optimize' (GAS_comp f g)) h'
Just ret' -> GAS_comp f' ret'
optimize_pair GAS_uncancelr (GAS_first f) = Just $ GAS_comp f GAS_uncancelr
optimize_pair GAS_uncancell (GAS_second f) = Just $ GAS_comp f GAS_uncancell
- -- second priority: push GAS_swap leftward... why isn't this working?
+ -- second priority: push GAS_swap leftward
optimize_pair (GAS_second f) GAS_swap = Just $ GAS_comp GAS_swap (GAS_first f)
optimize_pair (GAS_first f) GAS_swap = Just $ GAS_comp GAS_swap (GAS_second f)
optimize_pair GAS_swap GAS_swap = Just $ GAS_id
+ optimize_pair GAS_swap GAS_cancell = Just $ GAS_cancelr
+ optimize_pair GAS_swap GAS_cancelr = Just $ GAS_cancell
optimize_pair (GAS_first f) (GAS_first g) = Just $ GAS_first (GAS_comp f g)
optimize_pair (GAS_second f) (GAS_second g) = Just $ GAS_second (GAS_comp f g)
optimize_pair GAS_assoc GAS_cancell = Just $ GAS_first GAS_cancell
optimize_pair GAS_unassoc GAS_cancelr = Just $ GAS_second GAS_cancelr
+ optimize_pair GAS_assoc (GAS_second GAS_cancell) = Just $ GAS_first GAS_cancelr
+ optimize_pair GAS_unassoc (GAS_first GAS_cancell) = Just $ GAS_cancell
+
+
+ -- FIXME: valid only for central morphisms
+ --optimize_pair (GAS_second f) (GAS_first g) = Just $ GAS_comp (GAS_first g) (GAS_second f)
+ optimize_pair (GAS_first g) (GAS_second f) = Just $ GAS_comp (GAS_second f) (GAS_first g)
optimize_pair _ _ = Nothing