From a4741d681f1fb330686d3e758ee8211da087feb6 Mon Sep 17 00:00:00 2001 From: aarne Date: Mon, 10 Nov 2003 08:48:51 +0000 Subject: [PATCH] Glue modules. --- src/GF/Data/Glue.hs | 19 +++++++ src/GF/Data/Map.hs | 52 ++++++++++++++++++ src/GF/Data/RedBlack.hs | 55 +++++++++++++++++++ src/GF/Data/Trie.hs | 116 ++++++++++++++++++++++++++++++++++++++++ src/GF/Infra/Modules.hs | 9 ++++ 5 files changed, 251 insertions(+) create mode 100644 src/GF/Data/Glue.hs create mode 100644 src/GF/Data/Map.hs create mode 100644 src/GF/Data/RedBlack.hs create mode 100644 src/GF/Data/Trie.hs diff --git a/src/GF/Data/Glue.hs b/src/GF/Data/Glue.hs new file mode 100644 index 000000000..247224075 --- /dev/null +++ b/src/GF/Data/Glue.hs @@ -0,0 +1,19 @@ +module Glue where + +import Trie +import Operations +import List + +-------- AR 8/11/2003, using Markus Forsberg's implementation of Huet's unglue + +tcompileSimple :: [String] -> Trie +tcompileSimple ss = tcompile [(s,[(atWP,s)]) | s <- ss] + +decomposeSimple :: Trie -> String -> Err [String] +decomposeSimple t s = do + let ss = map (decompose t) $ words s + if any null ss + then Bad "unknown word in input" + else return $ concat [intersperse "&+" ws | ws <- ss] + +exTrie = tcompileSimple $ words "ett två tre tjugo trettio hundra tusen" diff --git a/src/GF/Data/Map.hs b/src/GF/Data/Map.hs new file mode 100644 index 000000000..1adc0523a --- /dev/null +++ b/src/GF/Data/Map.hs @@ -0,0 +1,52 @@ +{- + ************************************************************** + * Filename : Map.hs * + * Author : Markus Forsberg * + * markus@cs.chalmers.se * + * Last Modified : 15 December, 2001 * + * Lines : 53 * + ************************************************************** +-} + +module Map + ( + Map, + empty, + (!), -- lookup operator. + (!+), -- lookupMany operator. + (|->), -- insert operator. + (|->+), -- insertMany operator. + (<+>), -- union operator. + flatten -- + ) where + +import RedBlack + +type Map key el = Tree key el + +infixl 6 |-> +infixl 6 |->+ +infixl 5 ! +infixl 5 !+ +infixl 4 <+> + +empty :: Map key el +empty = emptyTree + +(!) :: Ord key => Map key el -> key -> Maybe el +fm ! e = lookupTree e fm + +(!+) :: Ord key => Map key el -> [key] -> [Maybe el] +fm !+ [] = [] +fm !+ (e:es) = (lookupTree e fm): (fm !+ es) + +(|->) :: Ord key => (key,el) -> Map key el -> Map key el +(x,y) |-> fm = insertTree (x,y) fm + +(|->+) :: Ord key => [(key,el)] -> Map key el -> Map key el +[] |->+ fm = fm +((x,y):xs) |->+ fm = xs |->+ (insertTree (x,y) fm) + +(<+>) :: Ord key => Map key el -> Map key el -> Map key el +(<+>) fm1 fm2 = xs |->+ fm2 + where xs = flatten fm1 diff --git a/src/GF/Data/RedBlack.hs b/src/GF/Data/RedBlack.hs new file mode 100644 index 000000000..8a24c07a3 --- /dev/null +++ b/src/GF/Data/RedBlack.hs @@ -0,0 +1,55 @@ +{- + ************************************************************** + * Filename : RedBlack.hs * + * Author : Markus Forsberg * + * markus@cs.chalmers.se * + * Last Modified : 15 December, 2001 * + * Lines : 57 * + ************************************************************** +-} -- Modified version of Osanaki's implementation. + +module RedBlack ( + emptyTree, + Tree, + lookupTree, + insertTree, + flatten + ) where + +data Color = R | B + deriving (Show,Read) + +data Tree key el = E | T Color (Tree key el) (key,el) (Tree key el) + deriving (Show,Read) + +balance :: Color -> Tree a b -> (a,b) -> Tree a b -> Tree a b +balance B (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d) +balance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d) +balance B a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d) +balance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d) +balance color a x b = T color a x b + +emptyTree :: Tree key el +emptyTree = E + +lookupTree :: Ord a => a -> Tree a b -> Maybe b +lookupTree _ E = Nothing +lookupTree x (T _ a (y,z) b) + | x < y = lookupTree x a + | x > y = lookupTree x b + | otherwise = return z + +insertTree :: Ord a => (a,b) -> Tree a b -> Tree a b +insertTree (key,el) tree = T B a y b + where + T _ a y b = ins tree + ins E = T R E (key,el) E + ins (T color a y@(key',el') b) + | key < key' = balance color (ins a) y b + | key > key' = balance color a y (ins b) + | otherwise = T color a (key',el) b + +flatten :: Tree a b -> [(a,b)] +flatten E = [] +flatten (T _ left (key,e) right) + = (flatten left) ++ ((key,e):(flatten right)) diff --git a/src/GF/Data/Trie.hs b/src/GF/Data/Trie.hs new file mode 100644 index 000000000..0a0a4472b --- /dev/null +++ b/src/GF/Data/Trie.hs @@ -0,0 +1,116 @@ +{- + ************************************************************** + * Filename : Trie.hs * + * Author : Markus Forsberg * + * markus@cs.chalmers.se * + * Last Modified : 17 December, 2001 * + * Lines : 51 * + ************************************************************** +-} + +module Trie ( + tcompile, + Trie, + trieLookup, + decompose, + Attr, + atW, atP, atWP + ) where + +import Map + +--- data Attr = W | P | WP deriving Eq +type Attr = Int + +atW, atP, atWP :: Attr +(atW,atP,atWP) = (0,1,2) + +newtype TrieT = TrieT ([(Char,TrieT)],[(Attr,String)]) + +newtype Trie = Trie (Map Char Trie, [(Attr,String)]) + +emptyTrie = TrieT ([],[]) + +optimize :: TrieT -> Trie +optimize (TrieT (xs,res)) = Trie ([(c,optimize t) | (c,t) <- xs] |->+ empty, + res) + +tcompile :: [(String,[(Attr,String)])] -> Trie +tcompile xs = optimize $ build xs emptyTrie + +build :: [(String,[(Attr,String)])] -> TrieT -> TrieT +build [] trie = trie +build (x:xs) trie = build xs (insert x trie) + where + insert ([],ys) (TrieT (xs,res)) = TrieT (xs,ys ++ res) + insert ((s:ss),ys) (TrieT (xs,res)) + = case (span (\(s',_) -> s' /= s) xs) of + (xs,[]) -> TrieT (((s,(insert (ss,ys) emptyTrie)):xs),res) + (xs,(y,trie):zs) -> TrieT (xs ++ ((y,insert (ss,ys) trie):zs),res) + +trieLookup :: Trie -> String -> (String,[(Attr,String)]) +trieLookup trie s = apply trie s s + +apply :: Trie -> String -> String -> (String,[(Attr,String)]) +apply (Trie (_,res)) [] inp = (inp,res) +apply (Trie (map,_)) (s:ss) inp + = case map ! s of + Just trie -> apply trie ss inp + Nothing -> (inp,[]) + +-- Composite analysis (Huet's unglue algorithm) +-- only legaldecompositions are accepted. +-- With legal means that the composite forms are ordered correctly +-- with respect to the attributes W,P and WP. + +-- Composite analysis + +testTrie = tcompile [("flick",[(atP,"P")]),("knopp",[(atW,"W")]),("flaggstångs",[(atWP,"WP")])] + +decompose :: Trie -> String -> [String] +decompose trie sentence = legal trie $ backtrack [(sentence,[])] trie + +-- The function legal checks if the decomposition is in fact a possible one. + +legal :: Trie -> [String] -> [String] +legal _ [] = [] +legal trie input = if (test (map ((map fst).snd.(trieLookup trie)) input)) then input else [] + where + test [] = False + test [xs] = elem atW xs || elem atWP xs + test (xs:xss) = (elem atP xs || elem atWP xs) && test xss + +react :: String -> [String] -> [(String,[String])] -> String -> Trie -> Trie -> [String] +react input output back occ (Trie (arcs,res)) init = + case res of -- Accept = non-empty res. + [] -> continue back + _ -> let pushout = (occ:output) + in case input of + [] -> reverse $ map reverse pushout + _ -> let pushback = ((input,pushout):back) + in continue pushback + where continue cont = case input of + [] -> backtrack cont init + (l:rest) -> case arcs ! l of + Just trie -> + react rest output cont (l:occ) trie init + Nothing -> backtrack cont init + +backtrack :: [(String,[String])] -> Trie -> [String] +backtrack [] _ = [] +backtrack ((input,output):back) trie + = react input output back [] trie trie + +{- +-- The function legal checks if the decomposition is in fact a possible one. +legal :: Trie -> [String] -> [String] +legal _ [] = [] +legal trie input + | test $ + map ((map fst).snd.(trieLookup trie)) input = input + | otherwise = [] + where -- test checks that the Attrs are in the correct order. + test [] = False -- This case should never happen. + test [xs] = elem W xs || elem WP xs + test (xs:xss) = (elem P xs || elem WP xs) && test xss +-} diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs index 569806e60..4b642fd72 100644 --- a/src/GF/Infra/Modules.hs +++ b/src/GF/Infra/Modules.hs @@ -114,9 +114,18 @@ depPathModule m = fors m ++ exts m ++ opens m where fors m = case mtype m of MTTransfer i j -> [i,j] MTConcrete i -> [oSimple i] + MTInstance i -> [oSimple i] _ -> [] exts m = map oSimple $ maybe [] return $ extends m +-- all dependencies +allDepsModule :: Ord i => MGrammar i f a -> Module i f a -> [OpenSpec i] +allDepsModule gr m = iterFix add os0 where + os0 = depPathModule m + add os = [m | o <- os, Just (ModMod n) <- [lookup (openedModule o) mods], + m <- depPathModule n] + mods = modules gr + -- all modules that a module extends, directly or indirectly allExtends :: (Show i,Ord i) => MGrammar i f a -> i -> [i] allExtends gr i = case lookupModule gr i of