Created
February 9, 2022 08:09
-
-
Save kikkupico/eb161f03879b7faed83e35c1c656149b to your computer and use it in GitHub Desktop.
Custom Tree Monad
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| data Lst t = Nil | Head t (Lst t) | |
| instance Functor Lst where | |
| fmap f Nil = Nil | |
| fmap f (Head x xl) = Head (f x) (fmap f xl) | |
| instance Applicative Lst where | |
| pure x = Head x Nil | |
| Nil <*> _ = Nil | |
| _ <*> Nil = Nil | |
| (Head f fl) <*> (Head x xl) = Head (f x) (fl <*> xl) | |
| instance Monad Lst where | |
| x >>= f = flatMap f x | |
| instance Show a => Show (Lst a) where | |
| show Nil = "" | |
| show (Head x Nil) = show x | |
| show (Head x xs) = show x ++ "," ++ show xs | |
| append :: t -> Lst t -> Lst t | |
| append x Nil = Head x Nil | |
| append y (Head x xl) = Head x (append y xl) | |
| cat :: Lst a -> Lst a -> Lst a | |
| cat Nil xl = xl | |
| cat xl Nil = xl | |
| cat (Head x xl) (Head y yl) = cat (append y (Head x xl)) yl | |
| flatMap :: (a -> Lst b) -> Lst a -> Lst b | |
| flatMap f Nil = Nil | |
| flatMap f (Head x xl) = cat (f x) (flatMap f xl) | |
| data Tree t = Node t (Lst (Tree t)) | |
| instance Functor Tree where | |
| fmap f (Node x xcl) = Node (f x) (fmap (fmap f) xcl) | |
| instance Applicative Tree where | |
| pure x = Node x Nil | |
| (Node f fcl) <*> (Node x xcl) = Node (f x) (fmap (<*>) fcl <*> xcl) | |
| instance Monad Tree where | |
| (Node x xcl) >>= f = Node fx (cat fxcl (fmap (>>= f) xcl)) | |
| where | |
| (Node fx fxcl) = f x | |
| instance Show a => Show (Tree a) where | |
| show x = showNode 0 x | |
| showNode level (Node x xcl) = | |
| concat (replicate level " ") ++ show x ++ "\n" ++ showNodes (level + 1) xcl | |
| where | |
| showNodes _ Nil = "" | |
| showNodes level (Head x Nil) = showNode level x | |
| showNodes level (Head x xs) = showNode level x ++ showNodes level xs | |
| main = do | |
| print $ fmap (* 2) l1 | |
| print $ fmap (+) l3 <*> l1 | |
| print $ cat l1 l2 | |
| print $ l1 >>= mldoub >>= mldoub | |
| print $ fmap (+) t1 <*> t2 | |
| print t1 | |
| print $ t1 >>= mtdoub | |
| print $ t1 >>= mtdoub >>= mtdoub | |
| mldoub x = Head (x * 2) Nil | |
| mtdoub x = Node (x * 2) (Head (Node (x * 4) Nil) Nil) | |
| l1 = Head 7 (Head 17 Nil) | |
| l2 = Head 27 (Head 37 Nil) | |
| l3 = Head 100 Nil | |
| doub = (* 2) | |
| t1 = Node 1 (Head (Node 2 (Head (Node 5 Nil) Nil)) Nil) | |
| t2 = Node 11 (Head (Node 12 (Head (Node 15 Nil) Nil)) Nil) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment