pgf-service: add Jordis transfer function for OpenMath LaTeX output

3 files changed, 42 insertions, 3 deletions

diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index b6b67dd4c..996ba5bd7 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -28,6 +28,7 @@ import System.Process
 import System.Exit
 import System.IO
 import System.Directory(removeFile)
+import Fold(fold) -- transfer function for OpenMath LaTeX
 
 logFile :: FilePath
 logFile = "pgf-error.log"
@@ -164,7 +165,7 @@ doTranslate pgf input mcat mfrom mto =
                                                             ("linearizations",showJSON 
                                                                [toJSObject [("to", showJSON to),
                                                                             ("text",showJSON output)]
-                                                                  | (to,output) <- linearizeAndBind pgf mto tree]
+                                                                  | (to,output) <- transferLinearizeAndBind pgf mto tree]
                                                             )]
                                                    | tree <- trees])]
     jsonParseOutput (PGF.ParseIncomplete)= []
@@ -496,6 +497,16 @@ linearizeAndBind pgf mto t = [(la, binds s) | (la,s) <- linearize' pgf mto t]
       u:ws2        -> u : bs ws2
       _            -> []
 
+-- Apply transfer function OpenMath LaTeX
+transferLinearizeAndBind pgf mto t = [(la, binds s) | (la,s) <- unfolded ++ folded, not (null s)]
+ where unfolded = linearize' pgf mto t
+       folded   = linearize' pgf mto (fold t)
+       binds = unwords . bs . words
+       bs ws = case ws of
+         u:"&+":v:ws2 -> bs ((u ++ v):ws2)
+         u:ws2        -> u : bs ws2
+         _            -> []
+
 selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language
 selectLanguage pgf macc = case acceptable of
                             []  -> case PGF.languages pgf of
diff --git a/src/server/gf-server.cabal b/src/server/gf-server.cabal
index f79f81f72..c3cadd84f 100644
--- a/src/server/gf-server.cabal
+++ b/src/server/gf-server.cabal
@@ -16,8 +16,9 @@ flag content
 
 executable pgf-http
   main-is: pgf-http.hs
+  Hs-source-dirs: . transfer
   other-modules: PGFService FastCGIUtils Cache URLEncoding
-                 RunHTTP ServeStaticFile
+                 RunHTTP ServeStaticFile Fold
   ghc-options: -threaded
   if impl(ghc>=7.0)
     ghc-options: -rtsopts
@@ -44,7 +45,8 @@ executable pgf-http
 
 executable pgf-service
   main-is: pgf-fcgi.hs
-  other-modules: PGFService FastCGIUtils Cache URLEncoding
+  Hs-source-dirs: . transfer
+  other-modules: PGFService FastCGIUtils Cache URLEncoding Fold
   ghc-options: -threaded
   if impl(ghc>=7.0)
     ghc-options: -rtsopts
diff --git a/src/server/transfer/Fold.hs b/src/server/transfer/Fold.hs
new file mode 100644
index 000000000..61f0d4b34
--- /dev/null
+++ b/src/server/transfer/Fold.hs
@@ -0,0 +1,26 @@
+module Fold where
+import PGF
+import Data.Map as M (lookup, fromList)
+
+--import Debug.Trace
+
+
+foldable = fromList [(mkCId c, mkCId ("bin_" ++ c)) | c <- ops]
+  where ops = words "plus times and or xor cartesian_product intersect union"
+
+fold :: Tree -> Tree
+fold t =
+  case unApp t of
+    Just (i,[x])  ->
+        case M.lookup i foldable of
+	        Just j -> appFold j x
+	        _      -> mkApp i [fold x]
+    Just (i,xs)   -> mkApp i $ map fold xs
+    _             -> t
+
+appFold :: CId -> Tree -> Tree
+appFold j t = 
+  case unApp t of
+    Just (i,[t,ts]) | isPre i "Cons"  -> mkApp j [fold t, appFold j ts]
+    Just (i,[t,s])  | isPre i "Base"  -> mkApp j [fold t, fold s]
+  where isPre i s = take 4 (show i) == s
\ No newline at end of file