Control/Monad/Utils.lhs0000777000076500000240000000217011067622360015025 0ustar dauclairstaff > module Control.Monad.Utils where > import Control.Monad Some variations of monadic bind to simplify monadic computation Since I'm always doing |>>= return . x| I may as well formalize this activity. Oops, it's already called |liftM| and (>>^) is taken by Control.Arrow. *sigh* > (>>|) :: Monad m => m a -> (a -> b) -> m b > (>>|) = flip liftM > infixl 1 >>| A little bit of logic programming using MonadPlus to give us implication: > (|-) :: MonadPlus m => a -> Bool -> m a > a |- p | p = return (let x = a in x) > | otherwise = mzero Here's a couple of monadic parser combinators: > (>>=>) :: Monad m => m a -> m b -> m (a, m b) > mA >>=> mB = mA >>= \a -> return (a, mB) > (>=>>) :: Monad m => m (a, m b) -> (a -> b -> c) -> m c > scan >=>> f = scan >>= \(a, mB) -> mB >>= \b -> return (f a b) They could be used as follows: ] liftLoc :: Scan Location Instead of: ] liftLoc = next >>= \x -> next >>= \y -> return (Loc x y) We do the following: ] liftLoc = next >>=> next >=>> Loc The traditional approach is: ] liftLoc = liftM2 Loc next next But that seems backward to me. You choose your own poison. Data/Mutable.lhs0000777000076500000240000000175311067611050013511 0ustar dauclairstaff > module Data.Mutable where > import Data.BinaryTree Indicates this data structure has the ability to have its parts changed > class Mutable t dir val | t -> dir, t -> val where > mutate :: dir -> val -> t -> t > instance Mutable [a] ListDir a where > mutate _ val (_:t) = val:t > mutate _ val [] = error "Cannot mutate an empty list" > instance Mutable (BinaryTree a) BinDir (BinaryTree a) where > mutate dir branch Leaf = error "Cannot mutate an empty tree" > mutate L branch (Branch val _ r) = Branch val branch r > mutate R branch (Branch val l _) = Branch val l branch > tests :: IO () > tests = do putStrLn $ show (mutate undefined 25 [1..10]) > putStrLn $ show (mutate L (Branch "bar" Leaf Leaf) > (Branch "foo" Leaf Leaf)) Mutation only affects the focussed element in the path, and doesn't even need a typeclass: mutate :: (a -> a) -> Path dir a -> Path dir a mutate f (Path ps x) = Path ps (f x)Data/Transitive.lhs0000777000076500000240000000346711067607440014264 0ustar dauclairstaff > module Data.Transitive where > import Data.BinaryTree Allows us to move from one state to the next in a transitive type > class Transitive t dir | t -> dir where > advance :: dir -> t -> Maybe t > withdraw :: t -> Maybe t > withdraw _ = Nothing > instance Transitive [a] ListDir where > advance _ [] = Nothing > advance _ (h:t) = Just t For those data structures where advancement occurs in only one direction we provide the following helper function > next :: Transitive t dir => t -> Maybe t > next t = advance undefined t > instance Transitive (BinaryTree a) BinDir where > advance _ Leaf = Nothing > advance L (Branch _ l _) = Just l > advance R (Branch _ _ r) = Just r > tests :: IO () > tests = do putStrLn $ show (next [1..10]) > let foo = Branch "foo" (Branch "bar" Leaf Leaf) Leaf > putStrLn $ show (advance L foo) data Path dir a = Path [(dir,a)] a deriving Show class Walkable t dir where go :: dir -> Path dir t -> Maybe (Path dir t) back :: Path dir t -> Maybe (Path dir t) Instance for List: data ListDir = ListFwd deriving (Eq, Show) instance Walkable [a] ListDir where go ListFwd (Path ps x@(_:y)) = Just $ Path ((ListFwd,x):ps) y go _ _ = Nothing back (Path ((ListFwd,(x:_)):ps) xs) = Just $ Path ps (x:xs) back _ = Nothing Instance for binary trees, as above: data Tree a = Branch a (Tree a) (Tree a) | Leaf deriving (Eq, Show) data TreeDir = L | R deriving (Eq, Show) instance Walkable (Tree a) TreeDir where go L (Path ps x@(Branch _ l _)) = Just $ Path ((L, x):ps) l go R (Path ps x@(Branch _ _ r)) = Just $ Path ((R, x):ps) r go _ _ = Nothing back (Path ((L, Branch a _ r):ps) x) = Just $ Path ps (Branch a x r) back (Path ((R, Branch a l _):ps) x) = Just $ Path ps (Branch a l x) back _ = Nothing Data/BinaryTree.lhs0000777000076500000240000000032311064323512014154 0ustar dauclairstaff > module Data.BinaryTree where > data BinaryTree a = Branch a (BinaryTree a) (BinaryTree a) | Leaf > deriving (Eq, Show) > data BinDir = L | R deriving (Eq, Show) > data ListDir = Forward deriving Show Data/Zipper.lhs0000777000076500000240000000703511070025122013361 0ustar dauclairstaff > module Data.Zipper where Here we compromise on simplicity in all respects. We keep the underlying collection abstracted (via polymorphism) and allow progression and regression via constraining classes. > import Control.Arrow > import Data.Transitive > import Data.Mutable > import Data.BinaryTree > import Data.Maybe > import Control.Monad > import Control.Comonad > import Control.Monad.Utils > data Zipper dir a = Zip [(dir, a)] a deriving Show > instance Functor (Zipper dir) where > fmap f (Zip list x) = Zip (map (second f) list) (f x) It's very easy to lift a collection into a zipper, given that the zipper is monadic: one simply calls the monadic lifting/unit/return function. > instance Monad (Zipper dir) where > return x = Zip [] x > Zip _ x >>= fM = fM x > instance (Mutable a dir a, Transitive a dir) > => Transitive (Zipper dir a) dir where > advance dir (Zip hist coll) = advance dir coll >>| > Zip ((dir, coll):hist) > withdraw (Zip [] _) = Nothing > withdraw (Zip ((dir, h):t) dater) = Just $ Zip t (mutate dir dater h) Now, to extract the original data structure > instance Copointed (Zipper dir) where > extract (Zip _ elt) = elt > instance Comonad (Zipper dir) where > extend f z@(Zip [] _) = Zip [] (f z) > extend f z@(Zip ((dir, h):t) c) = let elt = f z > -- Zip ta n = extend' f (Zip t c) elt > Zip ta n = Zip t c =>> f > in Zip ((dir, elt):ta) n > {- > extend' :: (Zipper dir a -> b) -> Zipper dir a -> b -> Zipper dir b > extend' f z@(Zip [] _) _ = Zip [] $ f z > extend' fZa (Zip ((dir, x):hist) c) elt = let y = mutate dir elt x > Zip newhist b = extend' fZa (Zip hist c) y > in Zip ((dir, y):newhist) b > -} > settle :: (Mutable c dir c, Transitive c dir) => Zipper dir c -> c > settle (Zip [] elt) = elt > settle z@(Zip ((dir, h):t) elt) = mutate dir elt h > reset :: (Mutable c dir c, Transitive c dir) => Zipper dir c -> Zipper dir c > reset z@(Zip [] _) = z > reset (Zip ((dir, h):t) elt) = reset (Zip t $ mutate dir elt h) > {- > settleZ :: (Mutable c dir c, Transitive c dir) => Zipper dir c -> Zipper dir c > settleZ z@(Zip [] elt) = z > settleZ (Zip ((dir, branch):t) elt) = Zip ((dir, mutate dir elt branch):t) elt > -} ----- > ztests :: IO () > ztests = do print sample > print example > print (example >>| (nodes . extract . reset)) > print (extend (\(Zip hist list) -> map succ list) > (Zip [(Forward, [2,1]), > (Forward, [1])] [3..10])) > nodes :: BinaryTree String -> [[String]] > nodes Leaf = [[""]] > nodes (Branch x l r) = [[x]] ++ nodes l ++ nodes r > sample :: Maybe (Zipper BinDir (BinaryTree String)) > sample = advance R (return laby) >>= advance R >>= > advance L >>= \ (Zip hist hall) -> > return $ Zip hist (mutate R (Branch "minotaur" Leaf Leaf) hall) > example :: Maybe (Zipper BinDir (BinaryTree String)) > example = sample >>| extend settle > laby = Branch "entrance" (Branch "hall" end end) > (Branch "passage" > Leaf > (Branch "fork" > (Branch "hall" (endo "goal") Leaf) > end)) > where end = Branch "dead end" Leaf Leaf > endo st = Branch st Leaf Leaf