spl/splonderzoek

Files for blog entry on incremental attributes.

• Loading branch information...
1 parent 78170d3 commit a967b3c2890a2436c00d6216508e426e7f29f013 committed Mar 30, 2009
 @@ -0,0 +1,50 @@ +{- +This is the first source file for the splonderzoek blog entry dated 2008-03-30: + +-} + +module IncrementalAttributes1Synthesized where + +data Tree a s + = Tip s + | Bin a (Tree a s) (Tree a s) s + deriving Show + +data Alg a s + = Alg { stip :: s, sbin :: a -> s -> s -> s } + +result :: Tree a s -> s +result (Tip s) = s +result (Bin _ _ _ s) = s + +tip :: Alg a s -> Tree a s +tip alg = Tip (stip alg) + +bin :: Alg a s -> a -> Tree a s -> Tree a s -> Tree a s +bin alg x lt rt = Bin x lt rt (sbin alg x (result lt) (result rt)) + +empty :: (Ord a) => Alg a s -> Tree a s +empty = tip + +singleton :: (Ord a) => Alg a s -> a -> Tree a s +singleton alg x = bin alg x (tip alg) (tip alg) + +insert :: (Ord a) => Alg a s -> a -> Tree a s -> Tree a s +insert alg x t = + case t of + Tip _ -> + singleton alg x + Bin y lt rt _ -> + case compare x y of + LT -> bin alg y (insert alg x lt) rt + GT -> bin alg y lt (insert alg x rt) + EQ -> bin alg x lt rt + +fromList :: (Ord a) => Alg a s -> [a] -> Tree a s +fromList alg = foldr (insert alg) (empty alg) + +heightAlg :: Alg a Integer +heightAlg = Alg 0 (\_ x y -> 1 + max x y) + +t1 = fromList heightAlg "azbycx" +
 @@ -0,0 +1,58 @@ +{- +This is the second source file for the splonderzoek blog entry dated 2008-03-30: + +-} + +module IncrementalAttributes2Inherited where + +data Tree a i + = Tip i + | Bin a (Tree a i) (Tree a i) i + deriving Show + +data Alg a i + = Alg { itip :: i -> i, ibin :: a -> i -> i } + +result :: Tree a i -> i +result (Tip i) = i +result (Bin _ _ _ i) = i + +tip :: Alg a i -> i -> Tree a i +tip alg i = Tip (itip alg i) + +bin :: Alg a i -> i -> a -> Tree a i -> Tree a i -> Tree a i +bin alg i x lt rt = Bin x (update i lt) (update i rt) i + where + update i' t = + case t of + Tip _ -> + tip alg i' + Bin x lt rt _ -> + let s = ibin alg x i' in + Bin x (update s lt) (update s lt) s + +empty :: (Ord a) => Alg a i -> i -> Tree a i +empty = tip + +singleton :: (Ord a) => Alg a i -> i -> a -> Tree a i +singleton alg i x = bin alg i x (tip alg i) (tip alg i) + +insert :: (Ord a) => Alg a i -> a -> Tree a i -> Tree a i +insert alg x t = + case t of + Tip i -> + singleton alg i x + Bin y lt rt i -> + case compare x y of + LT -> bin alg i y (insert alg x lt) rt + GT -> bin alg i y lt (insert alg x rt) + EQ -> bin alg i x lt rt + +fromList :: (Ord a) => Alg a i -> i -> [a] -> Tree a i +fromList alg i = foldr (insert alg) (empty alg i) + +depthAlg :: Alg a Int +depthAlg = Alg (+1) (const (+1)) + +t1 = fromList depthAlg 0 "azbycx" +
 @@ -0,0 +1,63 @@ +{- +This is the third source file for the splonderzoek blog entry dated 2008-03-30: + +-} + +module IncrementalAttributes3SynthesizedAndInherited where + +data Tree a i s + = Tip i s + | Bin a (Tree a i s) (Tree a i s) i s + deriving Show + +data Alg a i s + = Alg { itip :: i -> i, ibin :: a -> i -> i, + stip :: s, sbin :: a -> s -> s -> s } + +result :: Tree a i s -> (i, s) +result (Tip i s) = (i, s) +result (Bin _ _ _ i s) = (i, s) + +iresult = fst . result +sresult = snd . result + +tip :: Alg a i s -> i -> Tree a i s +tip alg i = Tip (itip alg i) (stip alg) + +bin :: Alg a i s -> i -> a -> Tree a i s -> Tree a i s -> Tree a i s +bin alg i x lt rt = + Bin x (update i lt) (update i rt) i (sbin alg x (sresult lt) (sresult rt)) + where + update i' t = + case t of + Tip _ _ -> + tip alg i' + Bin y ylt yrt _ s -> + let j = ibin alg y i' in + Bin y (update j ylt) (update j yrt) j s + +empty :: (Ord a) => Alg a i s -> i -> Tree a i s +empty = tip + +singleton :: (Ord a) => Alg a i s -> i -> a -> Tree a i s +singleton alg i x = bin alg i x (tip alg i) (tip alg i) + +insert :: (Ord a) => Alg a i s -> a -> Tree a i s -> Tree a i s +insert alg x t = + case t of + Tip i _ -> + singleton alg i x + Bin y lt rt i _ -> + case compare x y of + LT -> bin alg i y (insert alg x lt) rt + GT -> bin alg i y lt (insert alg x rt) + EQ -> bin alg i x lt rt + +fromList :: (Ord a) => Alg a i s -> i -> [a] -> Tree a i s +fromList alg i = foldr (insert alg) (empty alg i) + +depthAndHeightAlg :: Alg a Int Int +depthAndHeightAlg = Alg (+1) (const (+1)) 1 (\_ x y -> 1 + max x y) + +t1 = fromList depthAndHeightAlg 0 "azbycx" +
 @@ -0,0 +1,98 @@ +{- +This is the fourth source file for the splonderzoek blog entry dated 2008-03-30: + +-} + +module IncrementalAttributes4Feedback where + +data Tree a i s + = Tip i s + | Bin a (Tree a i s) (Tree a i s) i s + deriving Show + +data Alg a i s + = Alg { ftip :: i -> s, fbin :: a -> i -> s -> s -> (i, i, s) } + +result :: Tree a i s -> (i, s) +result (Tip i s) = (i, s) +result (Bin _ _ _ i s) = (i, s) + +iresult = fst . result +sresult = snd . result + +tip :: Alg a i s -> i -> Tree a i s +tip alg i = Tip i (ftip alg i) + +bin :: Alg a i s -> i -> a -> Tree a i s -> Tree a i s -> Tree a i s +bin alg i x lt rt = update i (Bin x lt rt undefined undefined) + where + update j t = + case t of + Tip _ _ -> + tip alg j + Bin y ltIN rtIN _ _ -> + let (liIN, riIN, s) = fbin alg y j (sresult ltOUT) (sresult rtOUT) + ltOUT = update liIN ltIN + rtOUT = update riIN rtIN + in Bin y ltOUT rtOUT j s + +empty :: (Ord a) => Alg a i s -> i -> Tree a i s +empty = tip + +singleton :: (Ord a) => Alg a i s -> i -> a -> Tree a i s +singleton alg i x = bin alg i x (tip alg i) (tip alg i) + +insert :: (Ord a) => Alg a i s -> a -> Tree a i s -> Tree a i s +insert alg x t = + case t of + Tip i _ -> + singleton alg i x + Bin y lt rt i _ -> + case compare x y of + LT -> bin alg i y (insert alg x lt) rt + GT -> bin alg i y lt (insert alg x rt) + EQ -> bin alg i x lt rt + +fromList :: (Ord a) => Alg a i s -> i -> [a] -> Tree a i s +fromList alg i = foldr (insert alg) (empty alg i) + +newtype CounterI = CI { cntIn :: Int } deriving Show +data CounterS = CS { sumC :: Int, cntOut :: Int } deriving Show + +counterAlg :: Alg a CounterI CounterS +counterAlg = Alg ft fb + where + ft :: CounterI -> CounterS + ft i = CS { sumC = 1, cntOut = cntIn i } + fb :: a -> CounterI -> CounterS -> CounterS -> (CounterI, CounterI, CounterS) + fb _ i sl sr = + ( i + , CI { cntIn = cntIn i + sumC sl + 1 } + , CS { sumC = sumC sl + sumC sr + 1 + , cntOut = cntIn i + sumC sl } + ) + +t1 = fromList counterAlg (CI { cntIn = 0 }) "azbycx" + +newtype DiffI = DI { avg :: Float } deriving Show +data DiffS = DS { sumD :: Float, len :: Float, res :: Float } deriving Show + +diffAlg :: Alg Float DiffI DiffS +diffAlg = Alg ft fb + where + ft :: DiffI -> DiffS + ft i = DS { sumD = 0, len = 0, res = 0 } + fb :: Float -> DiffI -> DiffS -> DiffS -> (DiffI, DiffI, DiffS) + fb x i sl sr = + ( i + , i + , DS { sumD = x + sumD sl + sumD sr + , len = 1 + len sl + len sr + , res = x - avg i } + ) + +t2 = let val = fromList diffAlg (DI { avg = a }) [1,4,1.5,3.5,2,3,2.5] + s = sresult val + a = sumD s / len s + in val +

0 comments on commit `a967b3c`

Please sign in to comment.