CPS.hs (3554B)
1 {-# OPTIONS_GHC -Wall -fno-warn-unused-top-binds #-} 2 3 module Okasaki.Tree.CPS ( 4 TreeF(..) 5 , Tree 6 , lef 7 , lefF 8 , nod 9 , nodF 10 11 , spy 12 13 , put 14 , pet 15 , has 16 , haz 17 , gas 18 , wyt 19 , dep 20 21 , test0 22 , test1 23 , test2 24 , test3 25 , test4 26 ) where 27 28 import Data.Fix hiding (cata, ana, hylo) 29 import Data.Functor.Foldable 30 import Data.Monoid 31 import Okasaki.Orphans () 32 33 newtype TreeF a r = TreeF (forall e. e -> (r -> a -> r -> e) -> e) 34 deriving Functor 35 36 type Tree a = Fix (TreeF a) 37 38 lefF :: TreeF a r 39 lefF = TreeF const 40 41 nodF :: a -> r -> r -> TreeF a r 42 nodF x l r = TreeF (\_ c -> c l x r) 43 44 lef :: Tree a 45 lef = Fix lefF 46 47 nod :: a -> Tree a -> Tree a -> Tree a 48 nod x l r = Fix (nodF x l r) 49 50 non :: Tree a -> Bool 51 non (project -> TreeF c) = c True b where 52 b _ _ _ = False 53 54 -- exercise 2.3 (no unnecessary copying) 55 put :: Ord a => a -> Tree a -> Tree a 56 put x = apo lag where 57 lag (project -> TreeF c) = c a b 58 59 a = nodF x (Left lef) (Left lef) 60 61 b l e r = case compare x e of 62 EQ -> nodF e (Left l) (Left r) 63 LT -> nodF e (Right l) (Left r) 64 GT -> nodF e (Left l) (Right r) 65 66 has :: Ord a => a -> Tree a -> Bool 67 has x = cata alg where 68 alg (TreeF c) = c False b 69 70 b l e r = case compare x e of 71 EQ -> True 72 LT -> l 73 GT -> r 74 75 spy :: Ord a => a -> Tree a -> Last a 76 spy x = cata alg where 77 alg (TreeF c) = c mempty b 78 79 b l e r 80 | x < e = l 81 | otherwise = Last (Just e) <> r 82 83 -- exercise 2.2 (max d + 1 comparisons) 84 haz :: Ord a => a -> Tree a -> Bool 85 haz x t = case getLast (spy x t) of 86 Nothing -> False 87 Just s -> s == x 88 89 -- exercise 2.4 (no unnecessary copying, max d + 1 comparisons) 90 pet :: Ord a => a -> Tree a -> Tree a 91 pet x t = apo lag (Nothing, t) where 92 lag (s, project -> TreeF c) = c (a s) (b s) 93 94 a = \case 95 Nothing -> nodF x (Left lef) (Left lef) 96 Just s 97 | s == x -> lefF 98 | otherwise -> nodF x (Left lef) (Left lef) 99 100 b s l e r 101 | x < e = nodF e (Right (s, l)) (Left r) 102 | otherwise = nodF e (Left l) (Right (Just e, r)) 103 104 -- exercise 2.5a (construct balanced binary trees of depth n) 105 dap :: Ord a => a -> Int -> Tree a 106 dap x n = ana lag (n, lef) where 107 lag (j, t) 108 | j <= 0 = lefF 109 | otherwise = 110 let s = (pred j, t) 111 in nodF x s s 112 113 -- exercise 2.5b (construct mostly-balanced binary trees of size n) 114 sap :: Ord a => a -> Int -> Tree a 115 sap x n = ana lag (n, lef) where 116 lag (j, t) 117 | j <= 0 = lefF 118 | odd j = 119 let s = (j `quot` 2, t) 120 in nodF x s s 121 | otherwise = 122 let l = j `quot` 2 123 r = pred (j `quot` 2) 124 in nodF x (l, t) (r, t) 125 126 gas :: Ord a => [a] -> Tree a 127 gas = cata $ \case 128 Nil -> lef 129 Cons h t -> put h t 130 131 dep :: Integral b => Tree a -> b 132 dep = getSum . cata alg where 133 alg (TreeF c) = c mempty b 134 b l _ r = Sum 1 <> max l r 135 136 wyt :: Integral b => Tree a -> b 137 wyt = getSum . cata alg where 138 alg (TreeF c) = c mempty b 139 b l _ r = Sum 1 <> l <> r 140 141 test0 :: Num a => Tree a 142 test0 = nod 1 lef lef 143 144 -- 1 145 -- | \ 146 -- L L 147 148 test1 :: Num a => Tree a 149 test1 = nod 2 (nod 1 lef lef) (nod 3 lef lef) 150 151 -- 2 152 -- | \ 153 -- 1 3 154 -- | \ | \ 155 -- L L L L 156 157 test2 :: (Ord a, Num a) => Tree a 158 test2 = pet 0 test1 159 160 -- 2 161 -- | \ 162 -- 1 3 163 -- | \ | \ 164 -- 0 L L L 165 -- | \ 166 -- L L 167 168 test3 :: (Ord a, Num a) => Tree a 169 test3 = pet 5 test1 170 171 -- 2 172 -- | \ 173 -- 1 3 174 -- | \ | \ 175 -- L L L 5 176 -- | \ 177 -- L L 178 179 test4 :: (Ord a, Num a) => Tree a 180 test4 = pet 4 test3 181 182 -- 2 183 -- | \ 184 -- 1 3 185 -- | \ | \ 186 -- L L L 5 187 -- | \ 188 -- 4 L 189 -- | \ 190 -- L L 191