lojban 0.1 → 0.2
raw patch · 10 files changed
+321/−29 lines, 10 filesdep +directorydep +markov-chaindep +randomsetup-changed
Dependencies added: directory, markov-chain, random
Files
- Language/Lojban/CLL.hs +2/−0
- Language/Lojban/Camxes/Parse.hs +61/−0
- Language/Lojban/Jbobau.hs +89/−0
- Language/Lojban/Jbovlaste.hs +8/−6
- Language/Lojban/Lujvo.hs +31/−7
- Language/Lojban/Mlismu.hs +80/−0
- Language/Lojban/Util.hs +12/−2
- Setup.hs +2/−0
- Utils.hs +33/−11
- lojban.cabal +3/−3
Language/Lojban/CLL.hs view
@@ -11,6 +11,8 @@ import Network.HTTP import Text.HTML.TagSoup +-- | Queries the CLL page on jbotcan.org using Google.+cll :: String -> IO (Maybe [(String,String)]) cll query = do (code,body) <- curlGetString url [CurlUserAgent "Mozilla"] if code == CurlOK
+ Language/Lojban/Camxes/Parse.hs view
@@ -0,0 +1,61 @@+module Language.Lojban.Camxes.Parse + (parse+ ,LojbanTree+ ,Expr+ ,Type+ ,Value) where++import Data.Char+import Data.List+import Data.Tree+import Text.ParserCombinators.Parsec hiding (parse)+import qualified Text.ParserCombinators.Parsec as P+import Control.Monad.Reader++sample = " text=( text1=( paragraphs=( paragraph=( statement=( statement1=( statement2=( statement3=( sentence=( terms=( terms1=( terms2=( term=( term1=( sumti=( sumti1=( sumti2=( sumti3=( sumti4=( sumti5=( sumti6=( KOhAClause=( KOhAPre=( KOhA=( CMAVO=( KOhA=( mi ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) bridiTail=( bridiTail1=( bridiTail2=( bridiTail3=( selbri=( selbri1=( selbri2=( selbri3=( selbri4=( selbri5=( selbri6=( tanruUnit=( tanruUnit1=( tanruUnit2=( BRIVLAClause=( BRIVLAPre=( BRIVLA=( BRIVLA=( gismu=( dansu ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) "++parse :: String -> Either ParseError LojbanTree+parse = P.parse expr ""++expr = do skipMany space+ sym <- symbol+ char '='+ char '('+ inner <- try innerExprs <|> fmap return lojbanic+ char ')'+ skipMany space+ return $ Node (Left sym) inner++innerExprs :: Parser [LojbanTree]+innerExprs = many1 (do e <- expr; skipMany space; return e)++lojbanic :: Parser LojbanTree+lojbanic = do skipMany space+ string <- many1 (letter <|> digit <|> oneOf "'")+ skipMany space+ return $ Node (Right (map toLower string)) []++symbol :: Parser Type+symbol = fmap (map toLower) $ many1 (letter <|> digit)++type LojbanTree = Tree Expr+type Expr = Either Type Value+type Type = String+type Value = String++prettyPrint :: LojbanTree -> String+prettyPrint tree = runReader (go tree) "" where+ go (Node (Right value) []) = out value+ go (Node (Left value) []) = out value+ go (Node (Left label) (x:xs)) + | isTree x = do indent <- ask+ inner <- local (' ':) $ mapM go (x:xs)+ return $ "\n" ++ indent ++ "(" ++ label ++ "" ++ concat inner ++ ")"+ | otherwise = do indent <- ask+ in' <- go x+ return $ "\n" ++ indent ++ "(" ++ label ++ " " ++ in' ++ ")"++isTree (Node (Left _) (_:_)) = True+isTree _ = False++out = return
+ Language/Lojban/Jbobau.hs view
@@ -0,0 +1,89 @@+module Language.Lojban.Jbobau+ (newJbobau+ ,jbobauLine+ ,Jbobau)+ where++import Control.Concurrent+import Control.Monad+import Data.Char+import Data.List+import Data.MarkovChain+import Language.Lojban.Util+import System.Directory+import System.IO+import System.IO.Strict (readFile)+import System.Random+import System.Process++-- | Creates a new jbobau handle.+newJbobau :: FilePath -> IO (Either String Jbobau)+newJbobau path = do+ does <- doesFileExist path+ if does+ then connectJbobau path+ else return $ Left "Couldn't find jbobau training data."++connectJbobau :: FilePath -> IO (Either String Jbobau)+connectJbobau path = do+ pipe <- catch (Right `fmap` runInteractiveCommand "java -jar ~/camxes.jar -t")+ (const $ return $ Left "Broken pipe.")+ case pipe of+ Left e -> return $ Left e+ Right (inp,out,err,_) -> do+ hSetBuffering inp LineBuffering+ file <- System.IO.Strict.readFile path+ rg <- newStdGen+ let words' = intercalate ["\n"] $ map words $ lines file++ lines' = lines $ unwords $ run 3 words' 0 rg+ var <- newMVar (Jbobau_ inp out err lines')+ hGetLine out+ return $ Right $ Jbobau var++-- | Returns a random, grammatical, lojbanic sentence.+jbobauLine :: Jbobau -> IO String+jbobauLine (Jbobau jbobau) = do+ jbobau' <- takeMVar jbobau+ (line,lines) <- findM jbobau' (jboLines jbobau')+ putMVar jbobau jbobau' { jboLines = lines }+ return (clean line)+ where+ findM jbobau' (line:lines) = do+ if length (words line) >= 4+ then do line <- validLojban jbobau' line+ if length (words line) >= 4+ then do line <- jbofihe line+ case line of+ Just line -> return (line,lines)+ Nothing -> findM jbobau' lines+ else findM jbobau' lines+ else findM jbobau' lines++jbofihe :: String -> IO (Maybe String)+jbofihe line = do+ out <- grammar line+ case out of+ Right ("",good) | good /= [] -> return $ Just (extract good)+ _ -> return $ Nothing+ where extract = map toLower . unwords . words . filter good+ good c = isLetter c || c == '\'' || c == ' '++validLojban :: Jbobau_ -> String -> IO String+validLojban jbobau line = do+ let stdin = jboIn jbobau+ stdout = jboOut jbobau+ hPutStrLn stdin line+ hGetLine stdout++newtype Jbobau = Jbobau (MVar Jbobau_)++data Jbobau_ = Jbobau_+ { jboIn :: Handle+ , jboOut :: Handle+ , jboErr :: Handle+ , jboLines :: [String]+ }++clean = unwords . words . filter good where+ good c = c /= '.' && c /= '-'
Language/Lojban/Jbovlaste.hs view
@@ -27,6 +27,7 @@ ) where +import Utils import qualified System.IO.Strict as StrictIO import Text.XML.Light.Input import Text.XML.Light.Types@@ -53,12 +54,13 @@ -- | Find valsi(s) by definition substring. defSub :: JboDB -> String -> [JboValsi] defSub db s = filterValsi db match where- match e = isInfixOf s (valsiDef e) + match = any ((==lower s) . lower) . splitBy (not . isLetter) . valsiDef+-- match = isInfixOf s . valsiDef -- | Find valsi(s) by definition wild card string. defWildCard :: JboDB -> String -> [JboValsi] defWildCard db s = filterValsi db match where- match e = isNothing $ wildcard s (valsiDef e) + match = isNothing . wildcard s . valsiDef -- | Filter valsi(s) by a predicate. filterValsi :: JboDB -> (JboValsi -> Bool) -> [JboValsi]@@ -106,7 +108,7 @@ elemToValsi :: Element -> [Element] -> Map String JboValsi -> JboValsi elemToValsi e es m | type' == "gismu" = makeGismu e es- | type' == "fu'ivla" = makeGismu e es+ | type' == "fu'ivla" = makeFu'ivla e es | type' == "cmavo cluster" = makeCmavo True e es | type' == "cmavo" = makeCmavo False e es | type' == "lujvo" = makeLujvo e es m@@ -134,7 +136,7 @@ selrafsi :: String -> Map String JboValsi -> Maybe JboValsi selrafsi s = fmap snd . find sel . M.assocs where sel (w,v) = case valsiType v of- GismuType -> isPrefixOf s w || any (==s) rafsis+ GismuType -> (isPrefixOf s w && length s >= 4) || any (==s) rafsis CmavoType -> any (==s) rafsis _ -> False where rafsis = valsiRafsis v@@ -253,6 +255,7 @@ notes = list "" (" Notes: "++) instance Eq JboValsi where (==) = (==) `on` valsiWord+instance Ord JboValsi where compare = compare `on` valsiType -- | Get the selrafsis of a lujvo. lujvoSelrafsis :: JboValsi -> [JboValsi]@@ -276,7 +279,6 @@ speech s = "\"" ++ s ++ "\"" commas = intercalate ", " . filter (not . null) slashes = intercalate "/" . filter (not . null)-list nil cons v = if v == [] then nil else cons v name n = QName n Nothing Nothing attr = findAttr . name-trim = unwords . words+lower = map toLower
Language/Lojban/Lujvo.hs view
@@ -1,9 +1,10 @@ module Language.Lojban.Lujvo (rafsis,fixClusters) where -import Prelude hiding ((^),(*),(/),(+))-import Text.ParserCombinators.Parsec hiding (notFollowedBy) import Control.Monad import Control.Applicative ((<$>))+import Data.Maybe+import Prelude hiding ((^),(*),(/),(+))+import Text.ParserCombinators.Parsec hiding (notFollowedBy) data Rafsi = ShortRafsi [Char] | Rafsi4Let [Char] | Rafsi5Let [Char] instance Show Rafsi where@@ -11,31 +12,52 @@ show (Rafsi4Let e) = e show (Rafsi5Let e) = e +-- | Fix clusters in lojbanic words, consonants, vowels, hyphens, etc. Might not be accurate sometimes. fixClusters :: String -> String fixClusters xs = go xs [] where+ go stream acc | stream == xs && isJust broken = go rest (acc++cmavo++[hyphen])+ where broken = breakCmavo stream+ Just (cmavo,hyphen,rest) = broken go (x:y:xs) acc | validCluster (x:y:[]) = go (y:xs) (acc++[x]) | otherwise = go (y:xs) (acc++[x]++"y") go [x] acc = go [] (acc++[x]) go [] acc = acc +breakCmavo :: String -> Maybe (String,Char,String)+breakCmavo stream = either (const Nothing) Just $ parse break "" stream where+ break = do cmavo' <- cmavo+ rest <- ccv!> (lujvoRest / gismu / cmavo)+ let hyphen = if head rest == 'r' then 'n' else 'r' + return (cmavo',hyphen,rest)+ where lujvoRest = (concat . map show) `fmap` lujvo+ validCluster :: [Char] -> Bool validCluster = either (const False) (const True) . parse cluster "" -cluster = do diphthong / (do consonant / vowel; consonant / vowel)+cluster = diphthong + / vt & string "'"+ / string "'" & vt + / (ct / vowel) & (ct / vt)+ / ct & string "y"+ / string "y" & ct +-- | The rafsis of a lujvo. (Empty list for invalid parse.) rafsis :: String -> [String] rafsis s = case parse lujvo "" s of Right rs -> map show rs Left _ -> [] -lujvo = ((rafsi5 <!anyChar / rafsi3 / rafsi4)+) <!anyChar+cmavo = ct & (diphthong / vt & h & vt / vt)+lujvo = (do r1 <- raf; rs <- (raf+); return (r1:rs)) <!anyChar+ where raf = rafsi5 <!anyChar / rafsi3 / rafsi4 rafsi3 = ShortRafsi <$> ((cvc / ccv / cvv) <!y <!(anyChar >> y)) rafsi4 = Rafsi4Let <$> (ct & (vt & ct / ct & vt) & ct <&anyChar <&!(y?))-rafsi5 = do (Rafsi4Let ls) <- rafsi4; v <- vowel; return $ Rafsi5Let (ls++v)+rafsi5 = do (Rafsi4Let ls) <- rafsi4; v <- vt; return $ Rafsi5Let (ls++v)+gismu = do (Rafsi4Let ls) <- rafsi4; v <- vt; return (ls++v) cvc = ct & vt & ct <&anyChar <&!(y?)-ccv = ct & ct & vt <&!(((r / n) <& consonant)?)-cvv = ct & (diphthong / vt & h & vt) <&!(((r / n) <& consonant)?)+ccv = ct & ct & vt <&!(((r / n) <& ct)?)+cvv = ct & (diphthong / vt & h & vt) <&!(((r / n) <& ct)?) ct = consonant vt = vowel syllabic = l / m / n / r@@ -77,6 +99,8 @@ oneOf' p = oneOf p >>= return . (:[]) (+) p = many1 (try p) (*) p = many (try p)+(!>) a a1 = (do r <- try a; unexpected $ show r) <|> a1+infixr 3 !> (<!) a a1 = do r <- a; ((try a1 >>= unexpected . show) <|> return r) infixl 2 <! (/) a a1 = (try a <|> a1)
+ Language/Lojban/Mlismu.hs view
@@ -0,0 +1,80 @@+module Language.Lojban.Mlismu + (newMlismu+ ,isValidFatci+ ,addFatci+ ,readFatci+ ,randomBridi+ ,randomBridiRel+ ,Mlismu)+ where++import Data.Maybe+import Data.Char+import Language.Lojban.Util+import System.Directory+import System.IO+import System.Process+import Utils++-- | Create a new mlismu handle.+newMlismu :: FilePath -> IO (Either String Mlismu)+newMlismu path = do+ is <- doesFileExist path+ if is+ then do db <- openFile path AppendMode+ hSetBuffering db LineBuffering+ return $ Right $ Mlismu path db+ else return $ Left $ "\"" ++ path ++ "\" does not exist"++-- | Is a fatci valid?+isValidFatci :: String -> IO Bool+isValidFatci text = do+ validLojban <- isValidLojban text+ if validLojban+ then isJust `fmap` mlismuBridi (Right text) Nothing 1+ else return False++mlismuBridi :: (Either FilePath String) -> Maybe String -> Int -> IO (Maybe [String])+mlismuBridi path selbri lines' = do+ out <- run ("mlismu -n " ++ show lines' ++ " -f " ++ path' ++ selbri') input+ case out of+ Right (_,good@(_:_)) + | Just good' /= selbri -> return $ Just $ lines $ good + where good' = list "" (head . lines) good+ _ -> return Nothing+ where selbri' = maybe "" (" "++) selbri+ path' = either id (const "/dev/stdin") path+ input = either (const "") (++"\n") path++-- | Return a random bridi for a (maybe) given selbri.+randomBridi :: Mlismu -> Maybe String -> IO (Maybe String)+randomBridi mli bridi = start `fmap` mlismuBridi (Left $ mliFile mli) bridi 1+ where start = (>>= list Nothing (Just . head))++-- | Try to return a random bridi for one of the given selbri.+randomBridiRel :: Mlismu -> [String] -> IO (Maybe String)+randomBridiRel mli bridis = findM bridis where+ findM [] = randomBridi mli Nothing+ findM (x:xs) = do+ randomBridi mli (Just x) >>= maybe (findM xs) (return . Just)++-- | Add a new fatci.+addFatci :: Mlismu -> String -> IO Bool+addFatci mli fatci = do+ is <- isValidFatci fatci+ if is+ then do hPutStrLn (mliDB mli) fatci+ return True+ else return False++-- | Add any valid fatci from a set of utterances.+readFatci :: Mlismu -> String -> IO ()+readFatci mli = mapM_ (addFatci mli) . splitBridis++splitBridis :: String -> [String]+splitBridis = map unwords . splitBy ((=="i") . filter isLetter) . words++data Mlismu = Mlismu+ { mliFile :: FilePath+ , mliDB :: Handle+ }
Language/Lojban/Util.hs view
@@ -13,7 +13,8 @@ ,translate ,wordType ,lujvoAndRate- ,selma'oInfo)+ ,selma'oInfo+ ,isValidLojban) where import Utils@@ -68,7 +69,8 @@ filterSelma'o :: JboDB -> String -> [JboValsi] filterSelma'o db s = filterValsi db selma'o where selma'o v = valsiType v == CmavoType && fmap format (valsiSelma'o v) == Just (format s)- where format = filter isLetter . lower+ where format | any isDigit s = lower+ | otherwise = filter isLetter . lower -- | Shows the grammar of a lojban utterance using jbofihe. grammar :: String -- ^ The lojban utterance@@ -113,6 +115,14 @@ where format = flip (subRegex r1) "\n" . flip (subRegex r) "\\1 \\2" r = mkRegex "([^\n])\n([^\n])" r1 = mkRegex "\n\n"++-- | Just checks with jbofihe if some lojban is grammatically valid.+isValidLojban :: String -> IO Bool+isValidLojban line = do+ out <- grammar line+ case out of+ Right (_,"") -> return $ False+ _ -> return $ True lojbanic = filter good where good c = isLetter c || c == '\'' || c == ' '
Setup.hs view
@@ -1,2 +1,4 @@ import Distribution.Simple++main :: IO () main = defaultMain
Utils.hs view
@@ -1,28 +1,50 @@ module Utils (list ,run- ,trim)+ ,trim+ ,splitBy) where +import Prelude hiding (catch)+import Control.Exception+import Control.Concurrent import System.Process import System.IO import System.Exit-import qualified System.IO.Strict as StrictIO list :: Eq a => b -> ([a] -> b) -> [a] -> b list nil cons v = if v == [] then nil else cons v run :: String -> String -> IO (Either String (String,String)) run cmd input = do- Right (inp,out,err,pid) <- catch (Right `fmap` runInteractiveCommand cmd)- (const $ return $ Left "Broken pipe")- catch (do hPutStr inp input; hClose inp- output <- StrictIO.hGetContents out- errput <- StrictIO.hGetContents err- e <- catch (waitForProcess pid)- (const $ return ExitSuccess)- return $ Right (errput,output))- (const $ return $ Left "Broken pipe")+ pipe <- catch (Right `fmap` runInteractiveCommand ("ulimit -t 1 && " ++ cmd))+ (const $ return $ Left "Broken pipe")+ case pipe of+ Right (inp,out,err,pid) -> do+ catch (do hSetBuffering inp NoBuffering+ hPutStr inp input + hClose inp+ errv <- newEmptyMVar+ outv <- newEmptyMVar+ output <- hGetContents out+ errput <- hGetContents err+ forkIO $ evaluate (length output) >> putMVar outv ()+ forkIO $ evaluate (length errput) >> putMVar errv ()+ takeMVar errv+ takeMVar outv+ e <- catch (waitForProcess pid)+ (const $ return ExitSuccess)+ return $ Right (errput,output))+ (const $ return $ Left "Broken pipe")+ _ -> return $ Left "Unable to launch process" trim :: String -> String trim = unwords . words++splitBy :: (a -> Bool) -> [a] -> [[a]]+splitBy f = go [] where+ go ac xs = case break f xs of+ ([],[]) -> reverse ac+ ([],ys) -> go ac (skip ys)+ (xs,ys) -> go (xs:ac) (skip ys)+ skip = dropWhile f
lojban.cabal view
@@ -1,5 +1,5 @@ name: lojban-version: 0.1+version: 0.2 synopsis: Useful utilities for the Lojban language description: Some utilities such as querying Jbovlaste XML exports for gismu, gloss, rafsi, etc. and @@ -14,8 +14,8 @@ build-type: Simple library- build-depends: base,xml,strict,parsec,process,regex-compat,containers,tagsoup,HTTP,curl- exposed-modules: Language.Lojban.Jbovlaste,Language.Lojban.Lujvo,Language.Lojban.Util,Language.Lojban.CLL+ build-depends: base,xml,strict,parsec,process,regex-compat,containers,tagsoup,HTTP,curl,random,directory,markov-chain+ exposed-modules: Language.Lojban.Jbovlaste,Language.Lojban.Lujvo,Language.Lojban.Util,Language.Lojban.CLL,Language.Lojban.Jbobau,Language.Lojban.Mlismu,Language.Lojban.Camxes.Parse other-modules: WildCard, Utils ghc-options: -O2