diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2011, Yoshikuni Jujo +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + * Neither the name of the Yoshikuni Jujo nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVEN SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lojsamban.hs b/lojsamban.hs new file mode 100644 --- /dev/null +++ b/lojsamban.hs @@ -0,0 +1,166 @@ +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/lojysamban.cabal b/lojysamban.cabal new file mode 100644 --- /dev/null +++ b/lojysamban.cabal @@ -0,0 +1,23 @@ +build-type: Simple +cabal-version: >= 1.6 + +name: lojysamban +version: 0.0.1 +stability: experimental +author: .iocikun.juj. +maintainer: .iocikun.juj. + +license: BSD3 +license-file: LICENSE + +category: Language +synopsis: Prolog with lojban +description: Prolog with lojban + +source-repository head + type: git + location: git://github.com/YoshikuniJujo/lojsamban.git + +executable lojysamban + main-is: lojsamban.hs + build-depends: base > 3 && < 5, lojbanParser