packages feed

lojysamban 0.0.1 → 0.0.2

raw patch · 8 files changed

+538/−168 lines, 8 files

Files

+ LojbanTools.hs view
@@ -0,0 +1,45 @@+module LojbanTools (+	getSentences,+	headTerms,+	bridiTail,+	selbri,+	tailTerms,+	snd3+) where++import Language.Lojban.Parser hiding (LA, Brivla, KOhA, GOhA, NA, LerfuString)+import qualified Language.Lojban.Parser as P+import System.Environment+import Data.Maybe+import Data.Either+import Data.List++getSentences :: Sentence -> [Sentence]+getSentences (IText_1 _ _ _ _ (Just t)) = getSentences t+getSentences (StatementI s1 ss) = s1 : catMaybes (map (\(_, _, s) -> s) ss)+getSentences tbt@(TermsBridiTail _ _ _ _) = [tbt]+getSentences o = error $ show o++headTerms :: Sentence -> [Sumti]+headTerms (TermsBridiTail ts _ _ _) = ts+headTerms _ = []++bridiTail :: Sentence -> Sentence+bridiTail (TermsBridiTail _ _ _ bt) = bt+bridiTail o = o++selbri :: Sentence -> Selbri+selbri (Selbri s) = s+selbri (SelbriTailTerms s _ _ _) = s+selbri t = error $ show t -- P.Brivla ([], "", []) []++tailTerms :: Sentence -> [Sumti]+tailTerms (SelbriTailTerms _ ts _ _) = ts+tailTerms _ = []++readSumtiTail :: SumtiTail -> String+readSumtiTail (SelbriRelativeClauses (P.Brivla (_, n, _) _) _) = n+readSumtiTail st = show st++snd3 :: (a, b, c) -> b+snd3 (_, y, _) = y
+ NotUnif.hs view
@@ -0,0 +1,81 @@+module NotUnif (+	checkAll,+	checkNot,+	deleteFromNot,+	notUnification+) where++import Unif+import Control.Applicative+import Data.Maybe++-- checkAll :: [([Term], Maybe Term)] -> [Maybe [(Term, Term)]] -> Bool+checkAll r [] = True+checkAll r (Nothing : nots) = checkAll r nots+checkAll r (Just [] : nots) = checkAll r nots+checkAll r (Just n : nots) =+	checkNot r (deleteFromNot r n) && checkAll r nots++-- deleteFromNot :: [([Term], Maybe Term)] -> [(Term, Term)] -> [(Term, Term)]+deleteFromNot _ [] = []+deleteFromNot r ((t@(Var _ _), u@(Var _ _)) : ps)+	| null $ filter ((t `elem`) . fst) r = deleteFromNot r ps+	| null $ filter ((u `elem`) . fst) r = deleteFromNot r ps+	| otherwise = (t, u) : deleteFromNot r ps+deleteFromNot r ((t, u) : ps) = (t, u) : deleteFromNot r ps++-- checkNot :: [([Term], Maybe Term)] -> [(Term, Term)] -> Bool+checkNot _ [] = False+checkNot r ((t@(Var _ _), u@(Var _ _)) : ps)+	= null (filter ((\vs -> t `elem` vs && u `elem` vs) . fst) r) ||+--		null (filter ((t `elem`) .fst) r) ||+--		null (filter ((u `elem`) .fst) r) ||+		checkNot r ps+checkNot r ((t@(Var _ _), u) : ps)+	= snd (head $ filter ((t `elem`) . fst) r) /= Just u || checkNot r ps++-- notUnification :: +notUnification ts us = simplify <$> notUnifies ts us++-- notUnify :: Term -> Term -> Maybe (Maybe (Term, Term))+notUnify t u | t == u = Nothing+notUnify t@(Con _) u@(Con _) = Just Nothing+notUnify t u = Just $ Just (t, u)++-- notUnifies :: [Term] -> [Term] -> Maybe [(Term, Term)]+notUnifies [] [] = Nothing+notUnifies [t] [u] = maybeToList <$> notUnify t u+notUnifies (t : ts) (u : us) = case notUnify t u of+	Nothing -> notUnifies ts us+	Just Nothing -> Just []+	Just (Just p) -> case notUnifies ts us of+		Nothing -> Just [p]+		Just [] -> Just []+		Just ps -> Just $ p : ps+notUnifies _ _ = Just []++-- simplify :: [(Term, Term)] -> [(Term, Term)]+simplify :: (Eq sc, Eq s) =>+	[(Term sc s, Term sc s)] -> [(Term sc s, Term sc s)]+simplify = checkSame . map (uncurry order)++-- checkSame :: [(Term, Term)] -> [(Term, Term)]+checkSame :: (Eq sc, Eq s) =>+	[(Term sc s, Term sc s)] -> [(Term sc s, Term sc s)]+checkSame [] = []+checkSame (p : ps) = catMaybes (map (isSame p) ps) ++ p : checkSame ps++-- isSame :: (Term, Term) -> (Term, Term) -> Maybe (Term, Term)+isSame :: Eq a => (a, a) -> (a, a) -> Maybe (a, a)+isSame (x, y) (z, w)+	| x == z = Just (y, w)+	| y == w = Just (x, z)+	| x == w = Just (y, z)+	| y == z = Just (x, w)+	| otherwise = Nothing++-- order :: Term -> Term -> (Term, Term)+order (Con _) (Con _) = error "not occur"+order t@(Var _ _) u@(Con _) = (t, u)+order t@(Con _) u@(Var _ _) = (u, t)+order t u = (t, u)
+ Prolog2.hs view
@@ -0,0 +1,31 @@+module Prolog2 (+	ask,+	Fact,+--	Unify(..),+	Rule(..),+	Term(..),+	TwoD(..),+	Result+) where++import PrologTools+import Unif+import Data.Maybe++ask :: (TwoD sc, Eq sc, Eq s) =>+	sc -> Result sc s -> Fact sc s -> [Rule sc s] -> [Result sc s]+ask sc ret q rs =+	concat $ zipWith (\sc r -> askrule sc ret q r rs) (iterate next $ down sc) rs++askrule :: (TwoD sc, Eq sc, Eq s) =>+	sc -> Result sc s -> Fact sc s -> Rule sc s -> [Rule sc s] -> [Result sc s]+askrule sc ret q r@(Rule fact _ facts notFacts) rs =+	filter (flip checkAll nots) ret'+	where+	ret' = foldl (\rets (sc', f) -> rets >>= \r -> ask sc' r f rs) r0 $ zip (iterate next sc0) $+		map (const . ($ sc0)) facts+	sc0 = down sc+	r0 = case (q sc) `unification` (fact sc0) of+		Nothing -> []+		Just r0' -> maybeToList $ ret `merge` r0'+	nots = concat $ map ((flip (notAsk sc0) rs) . const . ($sc0)) notFacts
+ PrologTools.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module PrologTools (+	TwoD(..),+	Fact,+	NotFact,+	Rule(..),+	notAsk,+	checkAll+) where++import Unif+import NotUnif+import Control.Applicative++class TwoD td where+	next :: td -> td+	down :: td -> td++type Fact sc s = sc -> [Term sc s]+type NotFact sc s = Fact sc s+data Unify sc s+	= Unify (Term sc s) (Term sc s)+	| NotUnify (Term sc s) (Term sc s)+	deriving Show+data Rule sc s = Rule (Fact sc s) [Unify sc s] [Fact sc s] [NotFact sc s]++notAsk :: (TwoD sc, Eq sc, Eq s) => sc ->+	Fact sc s -> [Rule sc s] -> [Maybe [(Term sc s, Term sc s)]]+notAsk sc q rs = zipWith (\sc r -> notAskRule sc q r rs) (iterate next $ down sc) rs++notAskRule :: (TwoD sc, Eq sc, Eq s) => sc ->+	Fact sc s -> Rule sc s -> [Rule sc s] -> Maybe [(Term sc s, Term sc s)]+notAskRule sc q r@(Rule fact unify facts notFacts) rs = liftA concat $+	case match of+		Nothing -> Just []+		Just _ ->+			liftA2 (:) start $ maybeOut $ concat $+				map ((flip (notAsk sc) rs) . const . ($ sc)) facts+	where+	start = notUnification (q sc) $ fact sc+	match = unification [head $ q sc] [head $ fact sc]++maybeOut :: [Maybe a] -> Maybe [a]+maybeOut [] = Just []+maybeOut (Nothing : xs) = Nothing+maybeOut (Just x : xs) = maybe Nothing (Just . (x :)) $ maybeOut xs
+ Unif.hs view
@@ -0,0 +1,180 @@+module Unif (+	unification,+	merge,+	Term(..),+	checkSimple2,+	simplify2All,+	Result+) where++import Control.Applicative+import Data.List hiding (deleteBy)+import Data.Maybe++data Term sc s = Con s | Var sc s deriving (Eq, Show)++type Result sc s = [([Term sc s], Maybe (Term sc s))]++merge :: (Eq sc, Eq s) => Result sc s -> Result sc s -> Maybe (Result sc s)+merge [] uss = Just $ simplify2All uss+merge (tsv@(ts, v1) : tss) uss = case us of+	[] -> merge tss $ tsv : uss+	(us, v2) : rest -> case mergeValue v1 v2 of+		Nothing -> Nothing+		Just v	| not $ allEqual $ v2 : map snd rest -> Nothing+			| otherwise -> merge tss $+				(foldr union (union ts us) $ map fst rest, v) : uss'+	where+	us = filterElems ts uss+	uss' = deleteElems' ts uss++allEqual :: Eq a => [a] -> Bool+allEqual [x] = True+allEqual (x : y : xs) = x == y && allEqual (y : xs)++mergeValue :: Eq a => Maybe a -> Maybe a -> Maybe (Maybe a)+mergeValue x@(Just _) y@(Just _)+	| x == y = Just x+	| otherwise = Nothing+mergeValue x@(Just _) _ = Just x+mergeValue _ y = Just y++unification :: (Eq sc, Eq s) => [Term sc s] -> [Term sc s] -> Maybe (Result sc s)+unification ts us = simplify2All <$> (simplify =<< unifies ts us)+-- unification ts us = (simplify =<< unifies ts us)++-- unify :: Term -> Term -> Maybe (Maybe (Term, Term))+unify t u | t == u = Just Nothing+unify t@(Con _) u@(Con _) = Nothing+unify t u = Just $ Just (t, u)++-- unifies :: [Term] -> [Term] -> Maybe [(Term, Term)]+unifies [] [] = Just []+unifies (t : ts) (u : us) = case unify t u of+	Nothing -> Nothing+	Just Nothing -> unifies ts us+	Just (Just p) -> (p :) <$> unifies ts us+unifies _ _ = Nothing++-- before form is bellow+-- [(X, A), (A, Y), (B, Z), (hoge, B)] -- no (hoge, hage) or (B, B)+-- (Var _, Var _), (Con _, Var _), (Var _, Con _)+-- simplified form is bellow+-- [([X, A, Y], Nothing), ([Z, B], Just hoge)]++-- test data+-- a, b, x, y, hoge :: Term+a = Var "" "A"+b = Var "" "B"+x = Var "" "X"+y = Var "" "Y"+z = Var "" "Z"+hoge = Con "hoge"+-- before :: [(Term, Term)]+before = [(x, a), (a, y), (b, z), (hoge, b)]++simplify2All :: (Eq sc, Eq s) => Result sc s -> Result sc s+simplify2All ps+	| checkSimple2 ps = ps+	| otherwise = simplify2All $ simplify2 ps++checkSimple2 :: (Eq sc, Eq s) => Result sc s -> Bool+checkSimple2 = notDup' . map snd++notDup' :: Eq a => [Maybe a] -> Bool+notDup' [] = True+notDup' (Nothing : xs) = notDup' xs+notDup' (Just x : xs)+	| x `elem` (catMaybes xs) = False+	| otherwise = notDup' xs++notDup :: Eq a => [a] -> Bool+notDup [] = True+notDup (x : xs)+	| x `elem` xs = False+	| otherwise = notDup xs++simplify2 [] = []+simplify2 ((ts, v@(Just _)) : ps) = (maybe ts (ts ++) ts', v) : simplify2 ps'+	where+	ts' = lookupSnd v ps+	ps' = deleteSnd v ps+simplify2 (p : ps) = p : simplify2 ps++lookupSnd :: Eq b => b -> [(a, b)] -> Maybe a+lookupSnd x = lookup x . map (\(y, z) -> (z, y))++deleteSnd :: Eq b => b -> [(a, b)] -> [(a, b)]+deleteSnd x = filter ((/= x) . snd)++-- simplify :: [(Term, Term)] -> Maybe [([Term], Maybe Term)]+simplify [] = Just []+simplify ((Con _, Con _) : _) = error "bad before data"+simplify ((t@(Var _ _), u@(Var _ _)) : ps) = case simplify ps of+	Nothing -> Nothing+	Just ps' -> case (lookupElem t ps', lookupElem u ps') of+		(Just (ts, Just v1), Just (us, Just v2))+			| v1 == v2 -> Just $ (union ts us, Just v1) :+				deleteElem t (deleteElem u ps')+			| otherwise -> Nothing+		(Just (ts, Just v1), Just (us, _)) ->+			Just $ (union ts us, Just v1) :+				deleteElem t (deleteElem u ps')+		(Just (ts, _), Just (us, v2)) ->+			Just $ (union ts us, v2) :+				deleteElem t (deleteElem u ps')+		(Just (ts, v1), _) -> Just $ (u : ts, v1) : deleteElem t ps'+		(_, Just (us, v2)) -> Just $ (t : us, v2) : deleteElem u ps'+		(_, _) -> Just $ ([t, u], Nothing) : ps'+simplify ((t@(Var _ _), u) : ps) = case simplify ps of+	Nothing -> Nothing+	Just ps' -> case lookupElem t ps' of+		Just (ts, Just v1)+			| u == v1 -> Just ps'+			| otherwise -> Nothing+		Just (ts, _) -> Just $ (ts, Just u) : deleteElem t ps'+		_ -> Just $ ([t], Just u) : ps'+simplify ((t, u) : ps) = case simplify ps of+	Nothing -> Nothing+	Just ps' -> case lookupElem u ps' of+		Just (us, Just v2)+			| t == v2 -> Just ps'+			| otherwise -> Nothing+		Just (us, _) -> Just $ (us, Just t) : deleteElem u ps'+		_ -> Just $ ([u], Just t) : ps'++deleteElems :: Eq a => [a] -> [([a], b)] -> [([a], b)]+deleteElems = deleteBy $ \x y -> not $ null $ intersect x y++deleteElems' :: Eq a => [a] -> [([a], b)] -> [([a], b)]+deleteElems' xs = filter $ \ys -> null $ intersect xs $ fst ys++deleteBy :: (a -> b -> Bool) -> a -> [(b, c)] -> [(b, c)]+deleteBy _ _ [] = []+deleteBy p x ((y, z) : ps)+	| p x y = ps+	| otherwise = (y, z) : deleteBy p x ps++deleteElem :: Eq a => a -> [([a], b)] -> [([a], b)]+deleteElem _ [] = []+deleteElem x ((xs, y) : ps)+	| x `elem` xs = ps+	| otherwise = (xs, y) : deleteElem x ps++filterElems :: Eq a => [a] -> [([a], b)] -> [([a], b)]+filterElems xs = filter (\ys -> not $ null $ intersect xs $ fst ys)++lookupElems :: Eq a => [a] -> [([a], b)] -> Maybe ([a], b)+lookupElems = lookupBy $ \x y -> not $ null $ intersect x y++lookupBy :: (a -> b -> Bool) -> a -> [(b, c)] -> Maybe (b, c)+lookupBy _ _ [] = Nothing+lookupBy p x ((y, z) :ps)+	| p x y = Just (y, z)+	| otherwise = lookupBy p x ps++lookupElem :: Eq a => a -> [([a], b)] -> Maybe ([a], b)+lookupElem _ [] = Nothing+lookupElem x ((xs, y) : ps)+	| x `elem` xs = Just (xs, y)+	| otherwise = lookupElem x ps
− lojsamban.hs 
@@ -1,166 +0,0 @@-import PrologLike-import Language.Lojban.Parser hiding (LA, Brivla, KOhA, GOhA, NA, LerfuString)-import qualified Language.Lojban.Parser as P-import System.Environment-import Data.Maybe-import Data.Either-import Data.List--main :: IO ()-main = do-	[fn] <- getArgs-	src <- readFile fn-	let Right p = parse src-	let facts = map readSentence $ getSentences p---	print facts-	q <- (readSentence . either (error "bad") id . parse) `fmap` getLine-	putStrLn $ case ask q facts of-		Just r -> case answerMa r of-			Just ma -> ma-			Nothing -> case answerRelfuString r of-				Just rs -> rs-				Nothing -> "go'i"-		Nothing -> "nago'i"---	maybe (return ()) putStrLn $ answerRelfuString $ ask q facts---	putStrLn $ if ask q facts then "go'i" else "nago'i"---	putStrLn $ show $ ask q facts---	print q--answerRelfuString :: [[(Term, Term)]] -> Maybe String-answerRelfuString ps-	| null answers = Nothing-	| otherwise = Just $ intercalate " .ija " answers-	where-	answers = map answerRelfuString1 ps--answerRelfuString1 :: [(Term, Term)] -> String-answerRelfuString1 ps = "tu'e " ++ intercalate " .ije " (map showDU rsps) ++ " tu'u"-	where-	rsps = filter isRSPair ps--showDU :: (Term, Term) -> String-showDU (LerfuString ls, LA n) = ls ++ " du la " ++ n-showDU (LerfuString ls, LO n) = ls ++ " du lo " ++ n--isRSPair :: (Term, Term) -> Bool-isRSPair (LerfuString _, _) = True-isRSPair _ = False--answerMa :: [[(Term, Term)]] -> Maybe String-answerMa ps-	| null answers = Nothing-	| otherwise = Just $ intercalate " .a " answers-	where-	answers = catMaybes $ map answerMa1 ps--answerMa1 :: [(Term, Term)] -> Maybe String-answerMa1 ps = case lookup (VKOhA "ma") ps of-	Nothing -> Nothing-	Just (LA n) -> Just $ "la " ++ n-	Just (LO n) -> Just $ "lo " ++ n--getSentences :: Sentence -> [Sentence]-getSentences (IText_1 _ _ _ _ (Just t)) = getSentences t-getSentences (StatementI s1 ss) = s1 : catMaybes (map (\(_, _, s) -> s) ss)-getSentences o = error $ show o--headTerms :: Sentence -> [Sumti]-headTerms (TermsBridiTail ts _ _ _) = ts-headTerms _ = []--bridiTail :: Sentence -> Sentence-bridiTail (TermsBridiTail _ _ _ bt) = bt-bridiTail o = o--selbri :: Sentence -> Selbri-selbri (SelbriTailTerms s _ _ _) = s-selbri _ = P.Brivla ([], "", []) []--tailTerms :: Sentence -> [Sumti]-tailTerms (SelbriTailTerms _ ts _ _) = ts-tailTerms _ = []--function :: Selbri -> Function-function (P.Brivla (_, n, _) _) = Brivla n-function (P.GOhA (_, n, _) _ _) = GOhA n-function (P.NA (_, "na", _) _ s) = NA $ function s--readLALO :: Sumti -> Term-readLALO (P.LA (_, "la", _) _ _ ns _) = LA $ concat $ map ((++ ".") . snd3) ns-readLALO (P.LALE (_, "lo", _) _ st _ _) = LO $ readSumtiTail st-readLALO (P.KOhA (_, k@"ma", _) _) = VKOhA k-readLALO (P.KOhA (_, k@"da", _) _) = VKOhA k-readLALO (P.KOhA (_, k@"de", _) _) = VKOhA k-readLALO (P.KOhA (_, k@"di", _) _) = VKOhA k-readLALO (P.KOhA (_, k@"do", _) _) = VKOhA k-readLALO (P.KOhA (_, k, _) _) = KOhA k-readLALO (P.LerfuString s _ _) = LerfuString $ concatMap snd3 s--readSumtiTail :: SumtiTail -> String-readSumtiTail (SelbriRelativeClauses (P.Brivla (_, n, _) _) _) = n-readSumtiTail st = show st--readSentence :: Sentence -> FactRule-readSentence s@(TermsBridiTail _ _ _ _) = Fact f $ h ++ t-	where-	h = map readLALO $ headTerms s-	f = function $ selbri $ bridiTail s-	t = map readLALO $ tailTerms $ bridiTail s-readSentence (IJoikJek s [r]) = Rule (readSentence s) (getRule r)--getRule (_, Jek _ _ (_, "ja", _) (Just (_, "nai", _)), _, Just t) = readTUhE t--readTUhE (TUhE _ _ _ t _ _) = map readSentence $ getSentences t--checkKOhA :: FactRule -> FactRule -> [(Term, Term)]-checkKOhA (Fact _ ts1) (Fact _ ts2) = zip ts1 ts2--{--findFacts :: FactRule -> [FactRule] -> [FactRule]-findFacts (Fact f0 _) fs = filter (isFactFor f0) fs--isFactFor :: Function -> FactRule -> Bool-isFactFor f0 (Fact f1 _) = f0 == f1-isFactFor _ _ = False--ask :: FactRule -> [FactRule] -> Bool-ask (Fact (NA f) ts) facts = not $ ask (Fact f ts) facts-ask (Fact (GOhA "du") ts) _ = ts !! 0 == ts !! 1-ask q@(Fact f ts) facts-	| q `elem` facts = True-	| otherwise = case findRule q facts of-		Nothing -> False-		Just r -> and $ map (flip ask facts) $ apply ts r--findRule :: FactRule -> [FactRule] -> Maybe FactRule-findRule (Fact f _) rs = let ret = filter (isRuleFor f) rs in-	if null ret then Nothing else Just $ head ret--isRuleFor :: Function -> FactRule -> Bool-isRuleFor f0 (Rule (Fact f1 _) _) = f0 == f1-isRuleFor _ _ = False--apply :: [Term] -> FactRule -> [FactRule]-apply ts2 (Rule (Fact _ ts1) fs) = map (changeFactTerms ts1 ts2) fs--changeFactTerms :: [Term] -> [Term] -> FactRule -> FactRule-changeFactTerms ts1 ts2 (Fact f ts) = Fact f $ changeTerms ts1 ts2 ts--changeTerms :: [Term] -> [Term] -> [Term] -> [Term]-changeTerms [] _ ts = ts-changeTerms _ [] ts = ts-changeTerms (t1 : ts1) (t2 : ts2) ts =-	changeTerms ts1 ts2 $ changeTerm t1 t2 ts--changeTerm :: Term -> Term -> [Term] -> [Term]-changeTerm _ _ [] = []-changeTerm t1 t2 (t : ts)-	| t == t1 = t2 : changeTerm t1 t2 ts-	| otherwise = t : changeTerm t1 t2 ts--sampleRule = Rule (Fact (Brivla "pendo") [KOhA "da", KOhA "de"])-	[Fact (Brivla "nelci") [KOhA "da", KOhA "de"]]--}--snd3 :: (a, b, c) -> b-snd3 (_, y, _) = y
+ lojsamban2.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}++module Main where++import LojbanTools+import Prolog2+import Language.Lojban.Parser hiding (LA, Brivla, KOhA, GOhA, NA, LerfuString)+import qualified Language.Lojban.Parser as P+import System.Environment+import Data.Maybe+import Data.Either+import Data.List+import Control.Monad+import Control.Arrow+import Control.Applicative++main :: IO ()+main = do+	[fn] <- getArgs+	src <- readFile fn+	let	Right p = parse src+		rules = map readSentence $ getSentences p+	Left q <- (readSentenceFact . either (error "bad") id . parse)+		`fmap` getLine+	let	answer = ask [] [] q rules+--	print (rules :: [Rule String Atom])+--	print (q [] :: [Term Scope Atom])+	let	answer2_1 = unwords $ intersperse ".ija" $ map unwords $ filter ((> 2) . length) $+			map ((\ret -> intersperse ".ije" ret) . map showPair . filter (not . isMA . fst) . regularization . onlyTopVars) answer+		answer2 = unwords $ intersperse ".ija" $ map unwords $ filter ((> 2) . length) $+			map ((\ret -> "tu'e" : intersperse ".ije" ret ++ ["tu'u"]) . map showPair . filter (not . isMA . fst) . regularization . onlyTopVars) answer+	putStr $ case answer of+		[] -> "nago'i\n"+		_ -> case intersperse ".a" $ catMaybes $ (flip map) (map maValue answer) $ (showAtom <$>) of+			[] -> if null answer2 then "go'i\n" else ""+			m -> unwords m ++ "\n"+	if null answer2 then return () else+		if length answer == 1 then putStrLn answer2_1 else putStrLn answer2+--	putStr $ unlines $ map show $ filter (not . isMA . fst) $ map regularization $ map (show . regularization . onlyTopVars) answer+--	putStrLn $ showAnswerAll answer++showAtom :: Atom -> String+showAtom (LA n) = "la " ++ n+showAtom (LO n) = "lo " ++ n++maValue :: Result Scope Atom -> Maybe Atom+maValue r = case filter (not . null . fst) $ map (first $ filter isMA) r of+	[] -> Nothing+	((_, tv) : _) -> (\(Con v) -> v) <$> tv++isMA :: Term Scope Atom -> Bool+isMA (Var [_] (KOhA "ma")) = True+isMA _ = False++showAnswerAll a = if null a then "nago'i" else+	intercalate " .a " $ map showAnswer $ map (lookupMA . onlyTop) a++showPair :: (Term Scope Atom, Term Scope Atom) -> String+showPair (Var _ (KOhA k), Con (LO n)) = k ++ " du lo " ++ n+showPair (Var _ (LerfuString l), Con (LO n)) = l ++ " du lo " ++ n+showPair (Var _ (KOhA k), Con (LA n)) = k ++ " du la " ++ n+showPair (Var _ (LerfuString l), Con (LA n)) = l ++ " du la " ++ n++regularization :: Result sc s -> [(Term sc s, Term sc s)]+regularization [] = []+regularization ((_, Nothing) : rest) = regularization rest+regularization ((vars, Just val) : rest) = map (, val) vars ++ regularization rest++onlyTopVars :: Result Scope s -> Result Scope s+onlyTopVars = filter (not . null . fst) . map (first $ filter isTopVar)++isTopVar :: Term Scope s -> Bool+isTopVar (Var [_] _) = True+isTopVar _ = False++lookupMA = map snd . filter ((Var "top" (KOhA "ma") `elem`) . fst)++showAnswer as = if null as then "go'i" else showLA $ head as++showLA (Just (Con (LA n))) = "la " ++ n+showLA (Just (Con (LO n))) = "lo " ++ n++onlyTop = filter (not . null . fst) .+	map (\(vars, val) -> (filter isTop vars, val))++isTop :: Term String s -> Bool+isTop (Var "top" _) = True+isTop _ = False++data Atom+	= LA String+	| LO String+	| KOhA String+	| Brivla String+	| GOhA String+	| LerfuString String+	deriving (Show, Eq)++type Scope = [Int]++instance TwoD [Int] where+	next (n : ns) = n + 1 : ns+	down ns = 0 : ns++readSumti :: Scope -> Sumti -> Term Scope Atom+readSumti sc (P.LA (_, "la", _) _ _ ns _) = Con $ LA $ concat $ map snd3 ns+readSumti sc (P.LALE (_, "lo", _) _ st _ _) = Con $ LO $ readSumtiTail st+readSumti sc (P.KOhA (_, k, _) _) = Var sc $ KOhA k+readSumti sc (P.LerfuString s _ _) = Var sc $ LerfuString $ concatMap snd3 s++readSumtiTail :: SumtiTail -> String+readSumtiTail (SelbriRelativeClauses (P.Brivla (_, n, _) _) _) = n+readSumtiTail st = show st++readSelbriAtom (P.GOhA (_, n, _) _ _) = GOhA n++readSelbri :: Selbri -> Either (Term Scope Atom) (Term Scope Atom)+readSelbri (P.Brivla (_, n, _) _) = Left $ Con $ Brivla n+readSelbri (P.GOhA (_, n, _) _ _) = Left $ Con $ GOhA n+readSelbri (P.NA (_, "na", _) _ s) = Right $ Con $ readSelbriAtom s++readSentenceFact :: Sentence -> Either (Fact Scope Atom) (Fact Scope Atom)+readSentenceFact s@(TermsBridiTail _ _ _ _) =+	either (\lf -> Left $ \sc -> lf : (h sc ++ t sc))+		(\rf -> Right $ \sc -> rf : (h sc ++ t sc)) f+	where+	h sc = map (readSumti sc) $ headTerms s+	f = readSelbri $ selbri $ bridiTail s+	t sc = map (readSumti sc) $ tailTerms $ bridiTail s+readSentenceFact (TopText _ _ _ _ (Just s) _) = readSentenceFact s+readSentenceFact o = error $ show o++readSentence :: Sentence -> Rule Scope Atom+readSentence s@(TermsBridiTail _ _ _ _) = Rule (\sc -> f : h sc ++ t sc) [] [] []+	where+	h sc = map (readSumti sc) $ headTerms s+	Left f = readSelbri $ selbri $ bridiTail s+	t sc = map (readSumti sc) $ tailTerms $ bridiTail s+readSentence (IJoikJek s [r]) = Rule f [] (getRule r) (getNotRule r)+	where+	Left f = readSentenceFact s++getRule (_, Jek _ _ (_, "ja", _) (Just (_, "nai", _)), _, Just t) =+	lefts $ readTUhE t+getNotRule (_, Jek _ _ (_, "ja", _) (Just (_, "nai", _)), _, Just t) =+	rights $ readTUhE t++readTUhE (TUhE _ _ _ t _ _) = map readSentenceFact $ getSentences t
lojysamban.cabal view
@@ -2,7 +2,7 @@ cabal-version:		>= 1.6  name:			lojysamban-version:		0.0.1+version:		0.0.2 stability:		experimental author:			.iocikun.juj. <PAF01143@nifty.ne.jp> maintainer:		.iocikun.juj. <PAF01143@nifty.ne.jp>@@ -19,5 +19,6 @@     location:		git://github.com/YoshikuniJujo/lojsamban.git  executable		lojysamban-    main-is:		lojsamban.hs+    main-is:		lojsamban2.hs+    other-modules:	LojbanTools, Prolog2, PrologTools, NotUnif, Unif     build-depends:	base > 3 && < 5, lojbanParser