Permalink
Browse files

Files for blog entry on incremental attributes.

  • Loading branch information...
1 parent 78170d3 commit a967b3c2890a2436c00d6216508e426e7f29f013 @spl 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.