---------------------------------------------------------------------------------- ---------------------------------------------------------------------------------- -- *** Feature Algebra: basic Haskell module *** -- *** (c) June 2006 by Peter Höfner, Ridha Khedri, Bernhard Möller *** ---------------------------------------------------------------------------------- ---------------------------------------------------------------------------------- module FeatureAlg where ---------------------------------------------------------------------------------- ---------------------------------------------------------------------------------- -- *** main data type, syntax of feature expressions *** ---------------------------------------------------------------------------------- data Feature = Zero | One | Basic BaseFeature | Sum Feature Feature | Product Feature Feature | Excl Feature Feature ---------------------------------------------------------------------------------- type BaseFeature = String type Product = [BaseFeature] -- interpreted as a bag of BaseFeatures type ProdFamily = [Product] -- interpreted as a set of Products ---------------------------------------------------------------------------------- ---------------------------------------------------------------------------------- -- *** features with memoized normal form *** ---------------------------------------------------------------------------------- type MemFeature = (Feature, ProdFamily) ---------------------------------------------------------------------------------- -- *** selectors *** ---------------------------------------------------------------------------------- feat (x,xn) = x norm (x,xn) = xn card (x,xn) = length xn ---------------------------------------------------------------------------------- zero, one :: MemFeature zero = (Zero,[]) one = (One, [[]]) ---------------------------------------------------------------------------------- bf :: String -> MemFeature -- basic features bf s = (Basic s, [[s]]) ---------------------------------------------------------------------------------- -- *** infix notation *** ---------------------------------------------------------------------------------- infixl 5 .+., .-. -- sum, difference infixl 6 .*. -- composition infixl 7 .^., .^<=. -- power, sum of powers ---------------------------------------------------------------------------------- (.+.), (.-.), (.*.) :: MemFeature -> MemFeature -> MemFeature (x,xn) .+. (y,yn) = (Sum x y, sunion xn yn) (x,xn) .-. (y,yn) = (Excl x y, norm_excl xn yn) (x,xn) .*. (y,yn) = (Product x y, mkset [ [bunion bx by] | bx <- xn, by <- yn ]) ---------------------------------------------------------------------------------- (.^.), (.^<=.) :: MemFeature -> Int -> MemFeature mf .^. 0 = one mf .^. (n+1) = mf .*. (mf .^. n) mf .^<=. 0 = one mf .^<=. (n+1) = one .+. mf .*. (mf .^<=. n) ---------------------------------------------------------------------------------- -- *** choice of several optional features *** ---------------------------------------------------------------------------------- opt :: [MemFeature] -> MemFeature opt [] = one opt (mf:mfs) = (mf .+. one) .*. (opt mfs) ---------------------------------------------------------------------------------- -- *** refinement relation *** ---------------------------------------------------------------------------------- ref :: MemFeature -> MemFeature -> Bool ref f1 f2 = -- f1 refines f2, i.e. every bag in f1 enriches some bag in f2 and [ or [ bsub b2 b1 | b2 <- n2 ] | b1 <- n1 ] where n1 = norm f1 n2 = norm f2 ---------------------------------------------------------------------------------- ---------------------------------------------------------------------------------- -- *** additional operations *** ---------------------------------------------------------------------------------- -- *** calculating common basic features of a ProdFamily *** ---------------------------------------------------------------------------------- common :: ProdFamily -> Product common [] = [] common pf = foldl1 binter pf -- binter is bag intersection ---------------------------------------------------------------------------------- -- *** removing common basic features *** ---------------------------------------------------------------------------------- reduce :: ProdFamily -> ProdFamily reduce pf = map (\p -> bdiff p (common pf)) pf -- bdiff is bag difference ---------------------------------------------------------------------------------- -- *** feature exclusion *** ---------------------------------------------------------------------------------- norm_excl:: ProdFamily -> ProdFamily -> ProdFamily norm_excl pf1 pf2 = [ p1 | p1 <- pf1, and [ not (bsub p2 p1) | p2 <- pf2 ] ] ---------------------------------------------------------------------------------- ---------------------------------------------------------------------------------- --- *** printing *** ---------------------------------------------------------------------------------- printfeat :: MemFeature -> IO() printfeat mf = printProdFamily (norm mf) ---------------------------------------------------------------------------------- printProdFamily :: ProdFamily -> IO() printProdFamily pf = putStr (brk pf) ---------------------------------------------------------------------------------- printProduct :: Product -> String printProduct b = sep1 ++ unlines b ---------------------------------------------------------------------------------- brk :: ProdFamily -> String -- break families into lines brk [] = sep1 brk (p:pf) = printProduct p ++ brk pf ---------------------------------------------------------------------------------- sep1 = "---------------------------------------------------------------------\n" sep2 = "=====================================================================\n" ---------------------------------------------------------------------------------- ---------------------------------------------------------------------------------- --- *** printing with commonalities extracted *** ---------------------------------------------------------------------------------- print_struct :: MemFeature -> IO() print_struct mf = putStr ( sep2 ++ " Common Parts \n" ++ printProduct (common bs) ++ sep1 ++ sep2 ++ " Variabilities \n" ++ brk (reduce bs) ) where bs = norm mf ---------------------------------------------------------------------------------- ---------------------------------------------------------------------------------- ---------------------------------------------------------------------------------- -- *** low-level implementation *** ---------------------------------------------------------------------------------- -- *** represent sets as sorted repetition-free lists *** ---------------------------------------------------------------------------------- -- union of a set of sets ---------------------------------------------------------------------------------- mkset :: Ord a => [[a]] -> [a] mkset = sqsort.concat ---------------------------------------------------------------------------------- -- repetition-free quicksort ---------------------------------------------------------------------------------- sqsort [] = [] sqsort (x:xs) = sqsort [y | y <- xs, y < x] ++ [x] ++ sqsort [y | y <- xs, y > x] ---------------------------------------------------------------------------------- -- subset relation on sorted repetition-free lists ---------------------------------------------------------------------------------- ssub [] _ = True ssub _ [] = False ssub (x:xs) (y:ys) = (x == y && ssub xs ys) || (x > y && ssub (x:xs) ys) ---------------------------------------------------------------------------------- -- set union ---------------------------------------------------------------------------------- sunion [] ys = ys sunion xs [] = xs sunion (x:xs) (y:ys) | x < y = x : sunion xs (y:ys) | x == y = x : sunion xs ys | otherwise = y : sunion (x:xs) ys ---------------------------------------------------------------------------------- -- set intersection ---------------------------------------------------------------------------------- sinter [] _ = [] sinter _ [] = [] sinter (x:xs) (y:ys) | x < y = sinter xs (y:ys) | x == y = x : sinter xs ys | otherwise = sinter (x:xs) ys ---------------------------------------------------------------------------------- ---------------------------------------------------------------------------------- -- *** represent bags as sorted lists *** ---------------------------------------------------------------------------------- -- union of a bag of bags ---------------------------------------------------------------------------------- mkbag :: Ord a => [[a]] -> [a] mkbag = bqsort.concat ---------------------------------------------------------------------------------- -- standard quicksort ---------------------------------------------------------------------------------- bqsort [] = [] bqsort (x:xs) = bqsort [y | y <- xs, y <= x] ++ [x] ++ bqsort [y | y <- xs, y > x] ---------------------------------------------------------------------------------- -- subbag relation on sorted lists ---------------------------------------------------------------------------------- bsub [] _ = True bsub _ [] = False bsub (x:xs) (y:ys) = (x == y && bsub xs ys) || (x > y && bsub (x:xs) ys) ---------------------------------------------------------------------------------- -- bag union ---------------------------------------------------------------------------------- bunion [] ys = ys bunion xs [] = xs bunion (x:xs) (y:ys) | x <= y = x : bunion xs (y:ys) | otherwise = y : bunion (x:xs) ys ---------------------------------------------------------------------------------- -- bag intersection ---------------------------------------------------------------------------------- binter [] _ = [] binter _ [] = [] binter (x:xs) (y:ys) | x < y = binter xs (y:ys) | x == y = x : binter xs ys | otherwise = binter (x:xs) ys ---------------------------------------------------------------------------------- -- bag difference ---------------------------------------------------------------------------------- bdiff [] _ = [] bdiff xs [] = xs bdiff (x:xs) (y:ys) | x < y = x : bdiff xs (y:ys) | x == y = bdiff xs ys | otherwise = bdiff (x:xs) ys ----------------------------------------------------------------------------------