diff --git a/LojbanTools.hs b/LojbanTools.hs new file mode 100644 --- /dev/null +++ b/LojbanTools.hs @@ -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 diff --git a/NotUnif.hs b/NotUnif.hs new file mode 100644 --- /dev/null +++ b/NotUnif.hs @@ -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) diff --git a/Prolog2.hs b/Prolog2.hs new file mode 100644 --- /dev/null +++ b/Prolog2.hs @@ -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 diff --git a/PrologTools.hs b/PrologTools.hs new file mode 100644 --- /dev/null +++ b/PrologTools.hs @@ -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 diff --git a/Unif.hs b/Unif.hs new file mode 100644 --- /dev/null +++ b/Unif.hs @@ -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 diff --git a/lojsamban.hs b/lojsamban.hs deleted file mode 100644 --- a/lojsamban.hs +++ /dev/null @@ -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 diff --git a/lojsamban2.hs b/lojsamban2.hs new file mode 100644 --- /dev/null +++ b/lojsamban2.hs @@ -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 diff --git a/lojysamban.cabal b/lojysamban.cabal --- a/lojysamban.cabal +++ b/lojysamban.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.6 name: lojysamban -version: 0.0.1 +version: 0.0.2 stability: experimental author: .iocikun.juj. maintainer: .iocikun.juj. @@ -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