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

12 files changed, 578 insertions, 0 deletions

diff --git a/src-3.0/GF/System/ATKSpeechInput.hs b/src-3.0/GF/System/ATKSpeechInput.hs
new file mode 100644
index 000000000..4b50293af
--- /dev/null
+++ b/src-3.0/GF/System/ATKSpeechInput.hs
@@ -0,0 +1,137 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.ATKSpeechInput
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (non-portable)
+--
+-- > CVS $Date: 2005/05/10 15:04:01 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.2 $
+--
+-- Use ATK and Speech.ATKRec for speech input.
+-----------------------------------------------------------------------------
+
+module GF.System.ATKSpeechInput (recognizeSpeech) where
+
+import GF.Infra.Ident (Ident, prIdent)
+import GF.Infra.Option
+import GF.Conversion.Types (CGrammar)
+import GF.Speech.PrSLF
+
+import Speech.ATKRec
+
+import Control.Monad
+import Data.Maybe
+import Data.IORef
+import System.Environment
+import System.IO
+import System.IO.Unsafe
+
+data ATKLang = ATKLang {
+                        hmmlist :: FilePath,
+                        mmf0 :: FilePath,
+                        mmf1 :: FilePath,
+                        dict :: FilePath,
+                        opts :: [(String,String)]
+                       }
+
+atk_home_error = "The environment variable ATK_HOME is not set. "
+                 ++ "It should contain the path to your copy of ATK."
+
+gf_atk_cfg_error = "The environment variable GF_ATK_CFG is not set. "
+                   ++ "It should contain the path to your GF ATK configuration"
+                   ++ " file. A default version of this file can be found"
+                   ++ " in GF/src/gf_atk.cfg"
+
+getLanguage :: String -> IO ATKLang
+getLanguage l = 
+    case l of 
+           "en_UK" -> do
+                      atk_home <- getEnv_ "ATK_HOME" atk_home_error
+                      let res = atk_home ++ "/Resources"
+                      return $ ATKLang {
+                                 hmmlist = res ++ "/UK_SI_ZMFCC/hmmlistbg",
+                                 mmf0 = res ++ "/UK_SI_ZMFCC/WI4",
+                                 mmf1 = res ++ "/UK_SI_ZMFCC/BGHMM2",
+                                 dict = res ++ "/beep.dct",
+                                 opts = [("TARGETKIND", "MFCC_0_D_A_Z"),
+                                         ("HPARM:CMNDEFAULT", res ++ "/UK_SI_ZMFCC/cepmean")]
+                                       }
+           "sv_SE" -> do
+                      let res = "/home/bjorn/projects/atkswe/numerals-swe/final"
+                      return $ ATKLang {
+                                 hmmlist = res ++ "/hmm_tri/hmmlist",
+                                 mmf0 = res ++ "/hmm_tri/macros",
+                                 mmf1 = res ++ "/hmm_tri/hmmdefs",
+                                 dict = res ++ "/NumeralsSwe.dct",
+                                 opts = [("TARGETKIND", "MFCC_0_D_A")]
+                                        }
+           _ -> fail $ "ATKSpeechInput: language " ++ l ++ " not supported"
+
+-- | Current language for which we have loaded the HMM
+--   and dictionary.
+{-# NOINLINE currentLang #-}
+currentLang :: IORef (Maybe String)
+currentLang = unsafePerformIO $ newIORef Nothing
+
+-- | Initializes the ATK, loading the given language.
+--   ATK must not be initialized when calling this function.
+loadLang :: String -> IO ()
+loadLang lang = 
+    do
+    l <- getLanguage lang
+    config <- getEnv_ "GF_ATK_CFG" gf_atk_cfg_error
+    hPutStrLn stderr $ "Initializing ATK..."
+    initialize (Just config) (opts l)
+    let hmmName = "hmm_" ++ lang
+        dictName = "dict_" ++ lang
+    hPutStrLn stderr $ "Initializing ATK (" ++ lang ++ ")..."
+    loadHMMSet hmmName (hmmlist l) (mmf0 l) (mmf1 l)
+    loadDict dictName (dict l)
+    writeIORef currentLang (Just lang)
+
+initATK :: String -> IO ()
+initATK lang = 
+    do
+    ml <- readIORef currentLang
+    case ml of
+            Nothing -> loadLang lang
+            Just l | l == lang -> return ()
+                   | otherwise -> do
+                                  deinitialize
+                                  loadLang lang
+
+recognizeSpeech :: Ident -- ^ Grammar name
+	        -> String -- ^ Language, e.g. en_UK
+                -> CGrammar -- ^ Context-free grammar for input
+                -> String -- ^ Start category name
+                -> Int -- ^ Number of utterances
+                -> IO [String]
+recognizeSpeech name language cfg start number = 
+    do
+    let slf = slfPrinter name start cfg
+        n = prIdent name
+        hmmName = "hmm_" ++ language
+        dictName = "dict_" ++ language
+        slfName = "gram_" ++ n
+        recName = "rec_" ++ language ++ "_" ++ n
+    writeFile "debug.net" slf
+    initATK language
+    hPutStrLn stderr $ "Loading grammar " ++ n ++ " ..."
+    loadGrammarString slfName slf
+    createRecognizer recName hmmName dictName slfName
+    hPutStrLn stderr $ "Listening in category " ++ start ++ "..."
+    s <- replicateM number (recognize recName)
+    return s
+
+
+getEnv_ :: String    -- ^ Name of environment variable
+        -> String    -- ^ Message to fail with if the variable is not set.
+        -> IO String
+getEnv_ e err = 
+    do
+    env <- getEnvironment
+    case lookup e env of
+                      Just v -> return v
+                      Nothing -> fail err
diff --git a/src-3.0/GF/System/Arch.hs b/src-3.0/GF/System/Arch.hs
new file mode 100644
index 000000000..c0dac3644
--- /dev/null
+++ b/src-3.0/GF/System/Arch.hs
@@ -0,0 +1,90 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Arch
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/10 14:55:01 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- architecture\/compiler dependent definitions for unix\/hbc
+-----------------------------------------------------------------------------
+
+module GF.System.Arch (
+ myStdGen, prCPU, selectLater, modifiedFiles, ModTime, getModTime,getNowTime,
+ welcomeArch, fetchCommand, laterModTime) where
+
+import System.Time
+import System.Random
+import System.CPUTime
+import Control.Monad (filterM)
+import System.Directory
+
+import GF.System.Readline (fetchCommand)
+
+---- import qualified UnicodeF as U --(fudlogueWrite)
+
+-- architecture/compiler dependent definitions for unix/hbc
+
+myStdGen :: Int -> IO StdGen ---
+--- myStdGen _ = newStdGen --- gives always the same result
+myStdGen int0 = do
+  t0  <- getClockTime 
+  cal <- toCalendarTime t0 
+  let int = int0 + ctSec cal + fromInteger (div (ctPicosec cal) 10000000)
+  return $ mkStdGen int
+
+prCPU :: Integer -> IO Integer
+prCPU cpu = do 
+  cpu' <- getCPUTime
+  putStrLn (show ((cpu' - cpu) `div` 1000000000) ++ " msec")
+  return cpu'
+
+welcomeArch :: String
+welcomeArch = "This is the system compiled with ghc."
+
+-- | selects the one with the later modification time of two
+selectLater :: FilePath -> FilePath -> IO FilePath
+selectLater x y = do
+  ex <- doesFileExist x
+  if not ex 
+    then return y --- which may not exist
+    else do
+      ey <- doesFileExist y
+      if not ey 
+        then return x
+        else do 
+          tx <- getModificationTime x
+          ty <- getModificationTime y
+          return $ if tx < ty then y else x
+
+-- | a file is considered modified also if it has not been read yet
+--
+-- new 23\/2\/2004: the environment ofs has just module names
+modifiedFiles :: [(FilePath,ModTime)] -> [FilePath] -> IO [FilePath]
+modifiedFiles ofs fs = do
+  filterM isModified fs
+ where
+  isModified file = case lookup (justModName file) ofs of
+    Just to -> do
+      t <- getModificationTime file
+      return $ to < t
+    _ -> return True
+
+  justModName = 
+    reverse . takeWhile (/='/') . tail . dropWhile (/='.') . reverse
+
+type ModTime = ClockTime
+
+laterModTime :: ModTime -> ModTime -> Bool
+laterModTime = (>)
+
+getModTime :: FilePath -> IO (Maybe ModTime)
+getModTime f = do
+  b <- doesFileExist f
+  if b then (getModificationTime f >>= return . Just) else return Nothing
+
+getNowTime :: IO ModTime
+getNowTime = getClockTime
diff --git a/src-3.0/GF/System/ArchEdit.hs b/src-3.0/GF/System/ArchEdit.hs
new file mode 100644
index 000000000..39b558cef
--- /dev/null
+++ b/src-3.0/GF/System/ArchEdit.hs
@@ -0,0 +1,30 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ArchEdit
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:46:15 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.2 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.System.ArchEdit (
+  fudlogueEdit, fudlogueWrite, fudlogueWriteUni
+ ) where
+
+fudlogueEdit :: a -> b -> IO ()
+fudlogueEdit _ _ = do
+  putStrLn "sorry no fudgets available in Hugs"
+  return ()
+
+fudlogueWrite :: a -> b -> IO ()
+fudlogueWrite _ _ = do
+  putStrLn "sorry no fudgets available in Hugs"
+
+fudlogueWriteUni :: a -> b -> IO ()
+fudlogueWriteUni _ _ = do
+  putStrLn "sorry no fudgets available in Hugs"
diff --git a/src-3.0/GF/System/NoReadline.hs b/src-3.0/GF/System/NoReadline.hs
new file mode 100644
index 000000000..138ba4e28
--- /dev/null
+++ b/src-3.0/GF/System/NoReadline.hs
@@ -0,0 +1,27 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.NoReadline
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/10 15:04:01 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.1 $
+--
+-- Do not use readline.
+-----------------------------------------------------------------------------
+
+module GF.System.NoReadline (fetchCommand) where
+
+import System.IO.Error (try)
+import System.IO (stdout,hFlush)
+
+fetchCommand :: String -> IO (String)
+fetchCommand s = do
+  putStr s
+  hFlush stdout
+  res <- try getLine
+  case res of
+   Left e -> return "q"
+   Right l -> return l
diff --git a/src-3.0/GF/System/NoSignal.hs b/src-3.0/GF/System/NoSignal.hs
new file mode 100644
index 000000000..5d82a431e
--- /dev/null
+++ b/src-3.0/GF/System/NoSignal.hs
@@ -0,0 +1,29 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.NoSignal
+-- Maintainer  : Bjorn Bringert
+-- Stability   : (stability)
+-- Portability : (portability)
+--
+-- > CVS $Date: 2005/11/11 11:12:50 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.1 $
+--
+-- Dummy implementation of signal handling.
+-----------------------------------------------------------------------------
+
+module GF.System.NoSignal where
+
+import Control.Exception (Exception,catch)
+import Prelude hiding (catch)
+
+{-# NOINLINE runInterruptibly #-}
+runInterruptibly :: IO a -> IO (Either Exception a)
+--runInterruptibly = fmap Right
+runInterruptibly a = 
+    p `catch` h
+  where p = a >>= \x -> return $! Right $! x
+        h e = return $ Left e
+
+blockInterrupt :: IO a -> IO a
+blockInterrupt = id
diff --git a/src-3.0/GF/System/NoSpeechInput.hs b/src-3.0/GF/System/NoSpeechInput.hs
new file mode 100644
index 000000000..04197ce92
--- /dev/null
+++ b/src-3.0/GF/System/NoSpeechInput.hs
@@ -0,0 +1,28 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.NoSpeechInput
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/10 15:04:01 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.2 $
+--
+-- Dummy speech input.
+-----------------------------------------------------------------------------
+
+module GF.System.NoSpeechInput (recognizeSpeech) where
+
+import GF.Infra.Ident (Ident)
+import GF.Infra.Option (Options)
+import GF.Conversion.Types (CGrammar)
+
+
+recognizeSpeech :: Ident -- ^ Grammar name
+	        -> String -- ^ Language, e.g. en_UK
+                -> CGrammar -- ^ Context-free grammar for input
+                -> String -- ^ Start category name
+                -> Int -- ^ Number of utterances
+                -> IO [String]
+recognizeSpeech _ _ _ _ _ = fail "No speech input available"
diff --git a/src-3.0/GF/System/Readline.hs b/src-3.0/GF/System/Readline.hs
new file mode 100644
index 000000000..c12493f98
--- /dev/null
+++ b/src-3.0/GF/System/Readline.hs
@@ -0,0 +1,27 @@
+{-# OPTIONS -cpp #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.Readline
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/10 15:04:01 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.2 $
+--
+-- Uses the right readline library to read user input.
+-----------------------------------------------------------------------------
+
+module GF.System.Readline (fetchCommand) where
+
+#ifdef USE_READLINE
+
+import GF.System.UseReadline (fetchCommand)
+
+#else
+
+import GF.System.NoReadline (fetchCommand)
+
+#endif
diff --git a/src-3.0/GF/System/Signal.hs b/src-3.0/GF/System/Signal.hs
new file mode 100644
index 000000000..fe8a12483
--- /dev/null
+++ b/src-3.0/GF/System/Signal.hs
@@ -0,0 +1,27 @@
+{-# OPTIONS -cpp #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.Signal
+-- Maintainer  : Bjorn Bringert
+-- Stability   : (stability)
+-- Portability : (portability)
+--
+-- > CVS $Date: 2005/11/11 11:12:50 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.3 $
+--
+-- Import the right singal handling module.
+-----------------------------------------------------------------------------
+
+module GF.System.Signal (runInterruptibly,blockInterrupt) where
+
+#ifdef USE_INTERRUPT
+
+import GF.System.UseSignal (runInterruptibly,blockInterrupt)
+
+#else
+
+import GF.System.NoSignal (runInterruptibly,blockInterrupt)
+
+#endif
diff --git a/src-3.0/GF/System/SpeechInput.hs b/src-3.0/GF/System/SpeechInput.hs
new file mode 100644
index 000000000..6c2374473
--- /dev/null
+++ b/src-3.0/GF/System/SpeechInput.hs
@@ -0,0 +1,27 @@
+{-# OPTIONS -cpp #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.SpeechInput
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/10 15:04:01 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.2 $
+--
+-- Uses the right speech recognition library for speech input.
+-----------------------------------------------------------------------------
+
+module GF.System.SpeechInput (recognizeSpeech) where
+
+#ifdef USE_ATK
+
+import GF.System.ATKSpeechInput (recognizeSpeech)
+
+#else
+
+import GF.System.NoSpeechInput (recognizeSpeech)
+
+#endif
diff --git a/src-3.0/GF/System/Tracing.hs b/src-3.0/GF/System/Tracing.hs
new file mode 100644
index 000000000..71bacfb75
--- /dev/null
+++ b/src-3.0/GF/System/Tracing.hs
@@ -0,0 +1,73 @@
+{-# OPTIONS -cpp #-}
+
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/26 09:54:11 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.4 $
+--
+-- Tracing utilities for debugging purposes.
+-- If the CPP symbol TRACING is set, then the debugging output is shown.
+-----------------------------------------------------------------------------
+
+
+module GF.System.Tracing
+    (trace, trace2, traceM, traceCall, tracePrt, traceCalcFirst) where
+
+import qualified Debug.Trace as Trace
+
+-- | emit a string inside braces, before(?) calculating the value:
+-- @{str}@
+trace :: String -> a -> a
+
+-- | emit function name and debugging output:
+-- @{fun: out}@
+trace2 :: String -> String -> a -> a
+
+-- | monadic version of 'trace2'
+traceM :: Monad m => String -> String -> m ()
+
+-- | show when a value is starting to be calculated (with a '+'), 
+-- and when it is finished (with a '-')
+traceCall :: String -> String -> (a -> String) -> a -> a
+
+-- | showing the resulting value (filtered through a printing function):
+-- @{fun: value}@
+tracePrt :: String -> (a -> String) -> a -> a
+
+-- | this is equivalent to 'seq' when tracing, but
+-- just skips the first argument otherwise
+traceCalcFirst :: a -> b -> b
+
+#if TRACING
+trace str a = Trace.trace (bold ++ "{" ++ normal ++ str ++ bold ++ "}" ++ normal) a
+trace2 fun str a = trace (bold ++ fgcol 1 ++ fun ++ ": " ++ normal ++ str) a 
+traceM fun str = trace2 fun str (return ())
+traceCall fun start prt val 
+    = trace2 ("+" ++ fun) start $
+      val `seq` trace2 ("-" ++ fun) (prt val) val
+tracePrt mod prt val = val `seq` trace2 mod (prt val) val
+traceCalcFirst = seq
+
+#else
+trace _ = id
+trace2 _ _ = id
+traceM _ _ = return ()
+traceCall _ _ _ = id
+tracePrt _ _ = id
+traceCalcFirst _ = id
+
+#endif
+
+
+escape    = "\ESC"
+highlight = escape ++ "[7m"
+bold      = escape ++ "[1m"
+underline = escape ++ "[4m"
+normal    = escape ++ "[0m"
+fgcol col = escape ++ "[0" ++ show (30+col) ++ "m"
+bgcol col = escape ++ "[0" ++ show (40+col) ++ "m"
diff --git a/src-3.0/GF/System/UseReadline.hs b/src-3.0/GF/System/UseReadline.hs
new file mode 100644
index 000000000..c84b9d7f4
--- /dev/null
+++ b/src-3.0/GF/System/UseReadline.hs
@@ -0,0 +1,25 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.UseReadline
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/10 15:04:01 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.1 $
+--
+-- Use GNU readline
+-----------------------------------------------------------------------------
+
+module GF.System.UseReadline (fetchCommand) where
+
+import System.Console.Readline (readline, addHistory)
+
+fetchCommand :: String -> IO (String)
+fetchCommand s = do
+  res <- readline s
+  case res of
+   Nothing -> return "q"
+   Just s -> do addHistory s
+                return s
diff --git a/src-3.0/GF/System/UseSignal.hs b/src-3.0/GF/System/UseSignal.hs
new file mode 100644
index 000000000..5e6d81237
--- /dev/null
+++ b/src-3.0/GF/System/UseSignal.hs
@@ -0,0 +1,58 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.UseSignal
+-- Maintainer  : Bjorn Bringert
+-- Stability   : (stability)
+-- Portability : (portability)
+--
+-- > CVS $Date: 2005/11/11 11:12:50 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.1 $
+--
+-- Allows SIGINT (Ctrl-C) to interrupt computations.
+-----------------------------------------------------------------------------
+
+module GF.System.UseSignal where
+
+import Control.Concurrent (myThreadId, killThread)
+import Control.Exception (Exception,catch)
+import Prelude hiding (catch)
+import System.IO
+import System.Posix.Signals
+
+{-# NOINLINE runInterruptibly #-}
+
+-- | Run an IO action, and allow it to be interrupted
+--   by a SIGINT to the current process. Returns
+--   an exception if the process did not complete 
+--   normally.
+--   NOTES: 
+--   * This will replace any existing SIGINT
+--     handler during the action. After the computation 
+--     has completed the existing handler will be restored.
+--   * If the IO action is lazy (e.g. using readFile,
+--     unsafeInterleaveIO etc.) the lazy computation will
+--     not be interruptible, as it will be performed
+--     after the signal handler has been removed.
+runInterruptibly :: IO a -> IO (Either Exception a)
+runInterruptibly a = 
+    do t <- myThreadId
+       oldH <- installHandler sigINT (Catch (killThread t)) Nothing
+       x <- p `catch` h
+       installHandler sigINT oldH Nothing
+       return x
+  where p = a >>= \x -> return $! Right $! x
+        h e = return $ Left e
+
+-- | Like 'runInterruptibly', but always returns (), whether
+--   the computation fails or not.
+runInterruptibly_ :: IO () -> IO ()
+runInterruptibly_ = fmap (either (const ()) id) . runInterruptibly
+
+-- | Run an action with SIGINT blocked.
+blockInterrupt :: IO a -> IO a
+blockInterrupt a = 
+    do oldH <- installHandler sigINT Ignore Nothing
+       x <- a
+       installHandler sigINT oldH Nothing
+       return x