module Monocle.Markup ( Lab (..), markup, unmark, modif, modif', modifLab, choose, getLabel )where import Monocle.Core import Control.Monad.State -- | Labelled arrow data type. data Lab a = MArrow (Mor a) String | MId (Mor a) String | MTensor [Lab a] String | MComposition [Lab a] String | MFunc String [Lab a] FuncT String | MTransform String (Lab a) [Mor a] String deriving (Eq, Ord) instance (Eq a) => Morphism (Lab a) where dom f = markup $ dom $ unmark f cod f = markup $ cod $ unmark f isId f = isId $ unmark f f \. g = markup $ (unmark f) \. (unmark g) f \* g = markup $ (unmark f) \* (unmark g) makeLab f = case f of Arrow _ _ -> MArrow f "" Id _ -> MId f "" Tensor xs -> MTensor (map makeLab xs) "" Composition xs -> MComposition (map makeLab xs) "" Func nm xs t -> MFunc nm (map makeLab xs) t "" Transform nm x xs -> MTransform nm (makeLab x) xs "" -- | Removes labels and returns corresponding 'Mor'. unmark :: (Eq a) => Lab a -> Mor a unmark lf = nrm $ case lf of MArrow f _ -> f MId f _ -> f MTensor xs _ -> Tensor (map unmark xs) MComposition xs _ -> Composition (map unmark xs) MFunc nm xs t _ -> Func nm (map unmark xs) t MTransform nm x xs _ -> Transform nm (unmark x) xs mapLabM prep func lf = case lf of MTensor xs@(_:_) lab -> do prep; xs' <- mapM (mapLabM prep func) xs func $ MTensor xs' lab MComposition xs lab -> do prep; xs' <- mapM (mapLabM prep func) xs func $ MComposition xs' lab MFunc nm xs t lab -> do prep; xs' <- mapM (mapLabM prep func) xs func $ MFunc nm xs' t lab MTransform nm x xs lab -> do prep; x' <- mapLabM prep func x func $ MTransform nm x' xs lab _ -> func lf -- | Returns the label of the given marked morphism. getLabel :: Lab a -> String getLabel lf = case lf of MArrow _ lab -> lab MId _ lab -> lab MTensor _ lab -> lab MComposition _ lab -> lab MFunc _ _ _ lab -> lab MTransform _ _ _ lab -> lab setLabel nlab lf = case lf of MArrow f _ -> MArrow f nlab MId f _ -> MId f nlab MTensor xs _ -> MTensor xs nlab MComposition xs _ -> MComposition xs nlab MFunc nm xs t _ -> MFunc nm xs t nlab MTransform nm x xs _ -> MTransform nm x xs nlab transLab mor inits wlk = evalState ((mapLabM (return ()) wlk) mor) inits calcLab mor inits wlk = execState ((mapLabM (return ()) wlk) mor) inits transLabP mor inits prep wlk = evalState ((mapLabM prep wlk) mor) inits calcLabP mor inits prep wlk = execState ((mapLabM prep wlk) mor) inits -- | Applies operation to the marked subterm of the given morphism. modifLab :: String -> Lab a -> (Lab a -> Lab a) -> Lab a modifLab s lf op = transLab lf () $ \x -> let xlab = getLabel x in if xlab == s then return $ op x else return x -- | Applies operation to the marked subterm of the given morphism. modif' :: (Eq a) => String -> Lab a -> (Mor a -> Mor a) -> Lab a modif' s lf op = transLab lf () $ \x -> let xlab = getLabel x in if xlab == s then return $ setLabel xlab $ makeLab $ nrm $ op $ unmark x else return x -- | @modif s lf op == 'unmark' $ 'modif'' s lf op@ modif :: (Eq a) => String -> Lab a -> (Mor a -> Mor a) -> Mor a modif s lf op = unmark $ modif' s lf op getByLab s f = calcLab f Nothing $ \x -> let xlab = getLabel x in if xlab == s then do ls <- get put $ Just (unmark x) return x else return x labels f = calcLab f [] $ \x -> do ls <- get put $ (getLabel x, unmark x):ls return x -- | Chooses subterm of an associative operation (composition or tensor product). choose :: String -> Int -> Int -> Lab a -> Lab a choose nlab start end f = case f of MTensor xs lab -> let ((xs1, xs2), xs3) = (let (x1, x2) = splitAt end xs in (splitAt (start-1) x1, x2)) in MTensor (xs1 ++ [MTensor xs2 nlab] ++ xs3) lab MComposition xs lab -> let s' = length xs - end; e' = length xs - start + 1 in let ((xs1, xs2), xs3) = (let (x1, x2) = splitAt e' xs in (splitAt s' x1, x2)) in MComposition (xs1 ++ [MComposition xs2 nlab] ++ xs3) lab _ -> error "choose: arrow is not composition or tensor" -- | Returns the given morphism marked up. markup :: Mor a -> Lab a markup f = transLab (makeLab f) 1 $ \x -> case x of MComposition _ _ -> do n <- get; put (n+1) return $ setLabel ("lab:" ++ show n) x MTensor _ _ -> do n <- get; put (n+1) return $ setLabel ("lab:" ++ show n) x MFunc _ _ _ _ -> do n <- get; put (n+1) return $ setLabel ("lab:" ++ show n) x MTransform _ _ _ _ -> do n <- get; put (n+1) return $ setLabel ("lab:" ++ show n) x _ -> return x