module Control.Isomorphism.Partial.Prim
( idIso
, inverse
, apply
, unapply
, IsoFunctor ((<$>))
, ignore
, (***)
, (|||)
, associate
, commute
, unit
, element
, subset
, iterateIso
, distribute
) where
import Prelude hiding ((.), id)
import Control.Monad (liftM2, (>=>), fmap, mplus)
import Control.Category (Category (id, (.)))
import Data.Bool (Bool, otherwise)
import Data.Either (Either (Left, Right))
import Data.Eq (Eq ((==)))
import Data.Maybe (Maybe (Just, Nothing))
import Control.Isomorphism.Partial.Iso
inverse :: Iso alpha beta -> Iso beta alpha
inverse iso = unsafeMakeIso' name' (isoShowSR iso) (isoShowSL iso) (isoRL iso) (isoLR iso)
where
name' = "inverse(" ++ isoName iso ++ ")"
apply :: Iso alpha beta -> alpha -> Maybe beta
apply = isoLR
unapply :: Iso alpha beta -> beta -> Maybe alpha
unapply = isoRL
idIso :: Iso a a
idIso = unsafeMakeNamedIso "id" Just Just
instance Category Iso where
g . f = unsafeMakeIso' name' (isoShowSL f) (isoShowSR g)
(apply f >=> apply g) (unapply g >=> unapply f)
where
name' = "(" ++ isoName g ++ " . " ++ isoName f ++ ")"
id = idIso
infix 5 <$>
class IsoFunctor f where
(<$>) :: Iso alpha beta -> (f alpha -> f beta)
ignore :: alpha -> Iso alpha ()
ignore x = unsafeMakeNamedIsoR "ignore" f g where
f _ = Just ()
g () = Just x
(***) :: Iso alpha beta -> Iso gamma delta -> Iso (alpha, gamma) (beta, delta)
i *** j = unsafeMakeIso' name (showPair isoShowSL isoShowSL) (showPair isoShowSR isoShowSR) f g
where
f (a, b) = liftM2 (,) (apply i a) (apply j b)
g (c, d) = liftM2 (,) (unapply i c) (unapply j d)
name = "(" ++ isoName i ++ " *** " ++ isoName j ++ ")"
showPair f g =
case (f i, g j) of
(Just si, Just sj) -> Just $ \(x,y) -> showChar '(' . si x . showString ", "
. sj y . showString ")"
_ -> Nothing
(|||) :: Iso alpha gamma -> Iso beta gamma -> Iso (Either alpha beta) gamma
i ||| j = unsafeMakeIso' name showEither (isoShowSR i `mplus` isoShowSR j) f g
where
f (Left x) = apply i x
f (Right x) = apply j x
g y = (Left `fmap` unapply i y) `mplus` (Right `fmap` unapply j y)
name = "(" ++ isoName i ++ " ||| " ++ isoName j ++ ")"
showEither =
case (isoShowSL i, isoShowSL j) of
(Just si, Just sj) -> Just $ \e -> case e of
Left x -> showChar '(' . showString "Left " .
si x . showChar ')'
Right x -> showChar '(' . showString "Right " .
sj x . showChar ')'
_ -> Nothing
associate :: Iso (alpha, (beta, gamma)) ((alpha, beta), gamma)
associate = unsafeMakeIso f g where
f (a, (b, c)) = Just ((a, b), c)
g ((a, b), c) = Just (a, (b, c))
commute :: Iso (alpha, beta) (beta, alpha)
commute = unsafeMakeIso f f where
f (a, b) = Just (b, a)
unit :: Iso alpha (alpha, ())
unit = unsafeMakeNamedIso "unit" f g
where
f a = Just (a, ())
g (a, ()) = Just a
distribute :: Iso (alpha, Either beta gamma) (Either (alpha, beta) (alpha, gamma))
distribute = unsafeMakeIso f g where
f (a, Left b) = Just (Left (a, b))
f (a, Right c) = Just (Right (a, c))
g (Left (a, b)) = Just (a, Left b)
g (Right (a, b)) = Just (a, Right b)
element :: (Show alpha, Eq alpha) => alpha -> Iso () alpha
element x = unsafeMakeNamedIsoR ("element(" ++ show x ++ ")")
(\a -> Just x)
(\b -> if x == b then Just () else Nothing)
subset :: Show alpha => String -> (alpha -> Bool) -> Iso alpha alpha
subset name p = unsafeMakeNamedIsoLR ("subset(" ++ name ++ ")") f f where
f x | p x = Just x
| otherwise = Nothing
iterateIso :: Iso alpha alpha -> Iso alpha alpha
iterateIso step = unsafeMakeIso f g where
f = Just . driver (apply step)
g = Just . driver (unapply step)
driver :: (alpha -> Maybe alpha) -> (alpha -> alpha)
driver step state
= case step state of
Just state' -> driver step state'
Nothing -> state