GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

1 files changed, 129 insertions, 0 deletions

diff --git a/src-3.0/GF/Data/Trie.hs b/src-3.0/GF/Data/Trie.hs
new file mode 100644
index 000000000..9fb5daa27
--- /dev/null
+++ b/src-3.0/GF/Data/Trie.hs
@@ -0,0 +1,129 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Trie
+-- Maintainer  : Markus Forsberg
+-- Stability   : Obsolete
+-- Portability : Haskell 98
+--
+-- > CVS $Date: 2005/04/21 16:22:09 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Data.Trie (
+             tcompile,
+	     collapse,
+             Trie,
+	     trieLookup,
+	     decompose,
+             Attr,
+             atW, atP, atWP
+	    ) where
+
+import GF.Data.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)
+
+collapse :: Trie -> [(String,[(Attr,String)])]
+collapse trie = collapse' trie []
+  where collapse' (Trie (map,(x:xs))) s = if (isEmpty map) then [(reverse s,(x:xs))]
+	                                   else (reverse s,(x:xs)):
+					    concat [ collapse' trie (c:s) | (c,trie) <- flatten map]
+	collapse' (Trie (map,[])) s
+	 = concat [ collapse' trie (c:s) | (c,trie) <- flatten map]
+
+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
+-}