From 9410c6b1411612658d5262cbfca903fd1927cd55 Mon Sep 17 00:00:00 2001
From: hallgren <hallgren@chalmers.se>
Date: Thu, 24 Oct 2013 17:29:02 +0000
Subject: Functions merge trees into tries in the GF Shell and the PGF web
 service

* In the shell, the new command tt (to_trie) merges a list of trees into a
  trie and prints it in a readable way, where unique subtrees are marked with
  a "*" and alternative subtrees are marked with numbers.
* In the PGF web service, adding the parameter trie=yes to the parse and
  translate commands augments the JSON output with a trie.

Example to try in the shell:

	Phrasebook> p -lang=Eng "your son waits for you" | tt
---
 src/runtime/haskell/PGF.hs | 35 ++++++++++++++++++++++++++++++++++-
 1 file changed, 34 insertions(+), 1 deletion(-)

(limited to 'src/runtime')

diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs
index d0eadd764..1d0d13f97 100644
--- a/src/runtime/haskell/PGF.hs
+++ b/src/runtime/haskell/PGF.hs
@@ -136,7 +136,9 @@ module PGF(
 --         forExample,
 
            -- * Browsing
-           browse
+           browse,
+           -- * Tries
+           ATree(..),Trie(..),toATree,toTrie
           ) where
 
 import PGF.CId
@@ -328,3 +330,34 @@ browse pgf id = fmap (\def -> (def,producers,consumers)) definition
     expIds (EFun id)    ids = id : ids
     expIds (ETyped e _) ids = expIds e ids
     expIds _            ids = ids
+
+-- | A type for plain applicative trees
+data ATree = Other Tree | App CId  [ATree]  deriving Show
+data Trie  = Oth   Tree | Ap  CId [[Trie ]] deriving Show
+-- ^ A type for tries of plain applicative trees
+
+-- | Convert a 'Tree' to an 'ATree'
+toATree :: Tree -> ATree
+toATree e = maybe (Other e) app (unApp e)
+  where
+    app (f,es) = App f (map toATree es)
+
+-- | Combine a list of trees into a trie
+toTrie = combines . map ((:[]) . singleton)
+  where
+    singleton t = case t of
+                    Other e -> Oth e
+                    App f ts -> Ap f [map singleton ts]
+
+    combines [] = []
+    combines (ts:tss) = ts1:combines tss2
+      where
+        (ts1,tss2) = combines2 [] tss ts
+        combines2 ots []        ts1 = (ts1,reverse ots)
+        combines2 ots (ts2:tss) ts1 =
+          maybe (combines2 (ts2:ots) tss ts1) (combines2 ots tss) (combine ts1 ts2)
+
+        combine ts us = mapM combine2 (zip ts us)
+          where
+            combine2 (Ap f ts,Ap g us) | f==g = Just (Ap f (combines (ts++us)))
+            combine2 _ = Nothing
-- 
cgit v1.2.3