Restoring old functionality

2 files changed, 82 insertions, 1 deletions

diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs
index 666b5b681..f890a8dcf 100644
--- a/src/GF/Shell/PShell.hs
+++ b/src/GF/Shell/PShell.hs
@@ -35,7 +35,7 @@ pCommandLine s = pFirst (chks s) where
 pCommandOpt :: [String] -> (Command, Options, [CommandArg])
 pCommandOpt (w:ws) = let 
   (os, co)     = getOptions "-" ws
-  (comm, args) = pCommand (w:co)
+  (comm, args) = pCommand (abbrevCommand w:co)
   in
   (comm, os, args)
 pCommandOpt s = (CVoid, noOptions, [AError "no parse"])
@@ -45,6 +45,15 @@ pInputString s = case s of
   ('"':_:_) -> [AString (init (tail s))]
   _         -> [AError "illegal string"]
 
+-- command rl can be written remove_language etc.
+
+abbrevCommand :: String -> String
+abbrevCommand = hds . words . map u2sp where
+  u2sp c = if c=='_' then ' ' else c
+  hds s = case s of
+    [w@[_,_]] -> w
+    _ -> map head s
+
 pCommand :: [String] -> (Command, [CommandArg])
 pCommand ws = case ws of
 
@@ -81,6 +90,7 @@ pCommand ws = case ws of
   "ps" : s      -> aString CPutString s
   "st" : s      -> aTerm   CShowTerm s
   "!"  : s      -> aUnit   (CSystemCommand (unwords s))
+  "sc" : s      -> aUnit   (CSystemCommand (unwords s))
   
   "sf" : l : [] -> aUnit (CSetLocalFlag (language l))
   "sf" : []     -> aUnit CSetFlag
diff --git a/src/GF/Shell/TeachYourself.hs b/src/GF/Shell/TeachYourself.hs
new file mode 100644
index 000000000..623bd7b72
--- /dev/null
+++ b/src/GF/Shell/TeachYourself.hs
@@ -0,0 +1,71 @@
+module TeachYourself where
+
+import ShellState
+import API
+import Linear
+import PrGrammar
+
+import Option
+import Arch (myStdGen)
+import Operations
+import UseIO
+
+import Random --- (randoms)  --- bad import for hbc
+import System
+
+-- translation and morphology quiz. AR 10/5/2000 -- 12/4/2002
+
+teachTranslation :: Options -> GFGrammar -> GFGrammar -> IO ()
+teachTranslation opts ig og = do
+  tts <- transTrainList opts ig og infinity
+  let qas = [ (q, mkAnswer as) | (q,as) <- tts]
+  teachDialogue qas "Welcome to GF Translation Quiz."
+
+transTrainList :: 
+  Options -> GFGrammar -> GFGrammar -> Integer -> IO [(String,[String])]
+transTrainList opts ig og number = do
+  ts <- randomTreesIO opts ig (fromInteger number)
+  return $ map mkOne $ ts
+ where
+   cat = firstCatOpts opts ig
+   mkOne t = (norml (linearize ig t),map (norml . linearize og) (homonyms ig cat t))
+
+
+teachMorpho :: Options -> GFGrammar -> IO ()
+teachMorpho opts ig = useIOE () $ do
+  tts <- morphoTrainList opts ig infinity
+  let qas = [ (q, mkAnswer as) | (q,as) <- tts]
+  ioeIO $ teachDialogue qas "Welcome to GF Morphology Quiz."
+
+morphoTrainList :: Options -> GFGrammar -> Integer -> IOE [(String,[String])]
+morphoTrainList opts ig number = do
+  ts   <- ioeIO $ randomTreesIO opts ig (fromInteger number)
+  gen  <- ioeIO $ myStdGen (fromInteger number)
+  mkOnes gen ts
+ where
+   mkOnes gen (t:ts) = do
+     psss    <- ioeErr $ allLinTables gr cnc t
+     let pss = concat $ map snd $ concat psss
+     let (i,gen') = randomR (0, length pss - 1) gen
+     (ps,ss) <- ioeErr $ pss !? i
+     (_,ss0) <- ioeErr $ pss !? 0
+     let bas = concat $ take 1 ss0
+     more <- mkOnes gen' ts
+     return $ (bas +++ ":" +++ unwords (map prt_ ps), return (concat ss)) : more
+   mkOnes gen [] = return []
+ 
+   gr = grammar ig
+   cnc = cncId ig
+
+-- compare answer to the list of right answers, increase score and give feedback 
+mkAnswer :: [String] -> String -> (Integer, String) 
+mkAnswer as s = if (elem (norml s) as) 
+                   then (1,"Yes.") 
+                   else (0,"No, not" +++ s ++ ", but" ++++ unlines as)
+
+norml = unwords . words
+
+--- the maximal number of precompiled quiz problems
+infinity :: Integer
+infinity = 123 
+