228 lines
6.2 KiB
Haskell
228 lines
6.2 KiB
Haskell
|
|
-- (c) MP-I (1998/9-2006/7) and CP (2005/6-2022/23)
|
|
|
|
module LTree where
|
|
|
|
import Cp
|
|
import Data.Monoid
|
|
import Control.Applicative
|
|
import List
|
|
|
|
-- (1) Datatype definition -----------------------------------------------------
|
|
|
|
data LTree a = Leaf a | Fork (LTree a, LTree a) deriving (Show, Eq, Ord)
|
|
|
|
inLTree :: Either a (LTree a, LTree a) -> LTree a
|
|
inLTree = either Leaf Fork
|
|
|
|
outLTree :: LTree a -> Either a (LTree a,LTree a)
|
|
outLTree (Leaf a) = i1 a
|
|
outLTree (Fork (t1,t2)) = i2 (t1,t2)
|
|
|
|
baseLTree g f = g -|- f >< f
|
|
|
|
-- (2) Ana + cata + hylo -------------------------------------------------------
|
|
|
|
recLTree f = baseLTree id f -- that is: id -|- (f >< f)
|
|
|
|
cataLTree g = g . (recLTree (cataLTree g)) . outLTree
|
|
|
|
anaLTree f = inLTree . (recLTree (anaLTree f) ) . f
|
|
|
|
hyloLTree f g = cataLTree f . anaLTree g
|
|
|
|
-- (3) Map ---------------------------------------------------------------------
|
|
|
|
instance Functor LTree
|
|
where fmap f = cataLTree ( inLTree . baseLTree f id )
|
|
|
|
-- (4) Examples ----------------------------------------------------------------
|
|
|
|
-- (4.0) Inversion (mirror) ----------------------------------------------------
|
|
|
|
mirrorLTree = cataLTree (inLTree . (id -|- swap))
|
|
|
|
-- (4.1) Count and depth -------------------------------------------------------
|
|
|
|
countLTree = cataLTree (either one add)
|
|
|
|
depth = cataLTree (either one (succ.umax))
|
|
|
|
-- (4.2) Serialization ---------------------------------------------------------
|
|
|
|
tips = cataLTree (either singl conc)
|
|
|
|
-- (4.3) Double factorial ------------------------------------------------------
|
|
|
|
dfac 0 = 1
|
|
dfac n = hyloLTree (either id mul) dfacd (1,n)
|
|
|
|
dfacd(n,m) | n==m = i1 n
|
|
| otherwise = i2 ((n,k),(k+1,m))
|
|
where k = div (n+m) 2
|
|
|
|
-- (4.4) Double square function ------------------------------------------------
|
|
|
|
dsq 0 = 0
|
|
dsq n = (cataLTree (either id add) . fmap (\n->2*n-1) . (anaLTree dfacd)) (1,n)
|
|
|
|
{--
|
|
dsq 0 = 0
|
|
dsq n = (hyloLTree (either id add) (fdfacd nthodd)) (1,n)
|
|
where nthodd n = 2*n - 1
|
|
fdfacd f (n,m) | n==m = i1 (f n)
|
|
| otherwise = i2 ((n,k),(k+1,m))
|
|
where k = div (n+m) 2
|
|
--}
|
|
|
|
-- (4.5) Fibonacci -------------------------------------------------------------
|
|
|
|
fib = hyloLTree (either one add) fibd
|
|
|
|
-- where
|
|
|
|
fibd n | n < 2 = i1 ()
|
|
| otherwise = i2 (n-1,n-2)
|
|
|
|
-- (4.6) Merge sort ------------------------------------------------------------
|
|
|
|
mSort :: Ord a => [a] -> [a]
|
|
mSort [] = []
|
|
mSort l = hyloLTree (either singl merge) lsplit l
|
|
|
|
--where
|
|
|
|
-- singl x = [x]
|
|
|
|
merge (l,[]) = l
|
|
merge ([],r) = r
|
|
merge (x:xs,y:ys) | x < y = x : merge(xs,y:ys)
|
|
| otherwise = y : merge(x:xs,ys)
|
|
|
|
lsplit [x] = i1 x
|
|
lsplit l = i2 (sep l) where
|
|
sep [] = ([],[])
|
|
sep (h:t) = let (l,r) = sep t in (h:r,l) -- a List cata
|
|
|
|
{-- pointwise version:
|
|
|
|
mSort :: Ord a => [a] -> [a]
|
|
mSort [] = []
|
|
mSort [x] = [x]
|
|
mSort l = let (l1,l2) = sep l
|
|
in merge(mSort l1, mSort l2)
|
|
--}
|
|
|
|
-- (4.7) Double map (unordered lists) ------------------------------------------
|
|
|
|
dmap :: (b -> a) -> [b] -> [a]
|
|
dmap f [] = []
|
|
dmap f x = (hyloLTree (either (singl.f) conc) lsplit) x
|
|
|
|
-- (4.8) Double map (keeps the order) ------------------------------------------
|
|
|
|
dmap1 :: (b -> a) -> [b] -> [a]
|
|
dmap1 f [] = []
|
|
dmap1 f x = (hyloLTree (either (singl.f) conc) divide) x
|
|
where divide [x] = i1 x
|
|
divide l = i2 (split (take m) (drop m) l) where m = div (length l) 2
|
|
|
|
-- (4.8) Combinations ----------------------------------------------------------
|
|
|
|
comb = hyloLTree (either id add) divide
|
|
where divide(n,k) = if k `elem` [0,n] then i1 1 else i2((n-1,k),(n-1,k-1))
|
|
|
|
{-- pointwise: comb (n,k) = if k `elem` [0,n] then 1 else comb(n-1,k)+comb(n-1,k-1) --}
|
|
|
|
-- (5) Monads ------------------------------------------------------------------
|
|
|
|
instance Monad LTree where
|
|
return = Leaf
|
|
t >>= g = (mu . fmap g) t
|
|
|
|
mu :: LTree (LTree a) -> LTree a
|
|
mu = cataLTree (either id Fork)
|
|
|
|
instance Strong LTree
|
|
|
|
{-- fmap :: (Monad m) => (t -> a) -> m t -> m a
|
|
fmap f t = do { a <- t ; return (f a) }
|
|
--}
|
|
|
|
mcataLTree g = k where
|
|
k (Leaf a) = return(g1 a)
|
|
k (Fork(x,y)) = do { a <- k x; b <- k y; return(g2(a,b)) }
|
|
g1 = g . i1
|
|
g2 = g . i2
|
|
|
|
-- (6) Going polytipic -------------------------------------------------------
|
|
|
|
-- natural transformation from base functor to monoid
|
|
tnat :: Monoid c => (a -> c) -> Either a (c, c) -> c
|
|
tnat f = either f (uncurry mappend)
|
|
|
|
-- monoid reduction
|
|
|
|
monLTree f = cataLTree (tnat f)
|
|
|
|
-- alternative to (4.2) serialization ----------------------------------------
|
|
|
|
tips' = monLTree singl
|
|
|
|
-- alternative to (4.1) counting ---------------------------------------------
|
|
|
|
countLTree' = monLTree (const (Sum 1))
|
|
|
|
-- distributive law ----------------------------------------------------------
|
|
|
|
dlLTree :: Strong f => LTree (f a) -> f (LTree a)
|
|
dlLTree = cataLTree (either (fmap Leaf) (fmap Fork .dstr))
|
|
|
|
-- (7) Zipper ----------------------------------------------------------------
|
|
|
|
data Deriv a = Dr Bool (LTree a)
|
|
|
|
type Zipper a = [ Deriv a ]
|
|
|
|
plug :: Zipper a -> LTree a -> LTree a
|
|
plug [] t = t
|
|
plug ((Dr False l):z) t = Fork (plug z t,l)
|
|
plug ((Dr True r):z) t = Fork (r,plug z t)
|
|
|
|
-- (8) Advanced --------------------------------------------------------------
|
|
|
|
instance Applicative LTree where
|
|
pure = return
|
|
(<*>) = aap
|
|
|
|
-- (9) Spine representation --------------------------------------------------
|
|
|
|
roll = inLTree.(id -|- roll>< id).beta.(id><outList')
|
|
|
|
spinecata g = g . (id -|- (spinecata g)>< id).spineOut
|
|
|
|
spineOut = beta.(id><outList')
|
|
|
|
outList' [] = i1()
|
|
outList' x = i2(last x, blast x)
|
|
|
|
blast = reverse . tail . reverse
|
|
|
|
inList' = either nil snoc
|
|
|
|
snoc(a,x)= x++[a]
|
|
|
|
unroll = (id><inList').alpha.(id -|- unroll>< id).outLTree
|
|
|
|
alpha :: Either a ((a, t), t1) -> (a, Either () (t1, t))
|
|
alpha(Left a) = (a,Left())
|
|
alpha(Right ((a,ts),t)) = (a,Right(t,ts))
|
|
|
|
beta :: (a, Either () (t1, t)) -> Either a ((a, t), t1)
|
|
beta(a,Left()) = Left a
|
|
beta(a,Right(t,ts)) = Right ((a,ts),t)
|
|
|
|
height = cataLTree (either id (uncurry ht)) where ht a b = 1 + (max a b)
|
|
|
|
---------------------------- end of library ----------------------------------
|
|
|