Permalink
Browse files

Merge branch 'master' of github.com:norm2782/NanoProlog

Conflicts:
	src/Language/Prolog/NanoProlog/NanoProlog.hs
  • Loading branch information...
2 parents 3be82a0 + 3e9ee1a commit 58c6259ad8c19a7d2eb56ae8826bad77776799e5 @doaitse doaitse committed May 30, 2011
Showing with 21 additions and 18 deletions.
  1. +1 −1 NanoProlog.cabal
  2. +1 −2 src/Language/Prolog/NanoProlog/Interpreter.hs
  3. +19 −15 src/Language/Prolog/NanoProlog/NanoProlog.hs
View
@@ -1,5 +1,5 @@
Name: NanoProlog
-Version: 0.2
+Version: 0.2.1
Synopsis: Very small interpreter for a Prolog-like language
Description: This package was developed to demonstrate the ideas behind
the Prolog language. It contains a very small interpreter
@@ -44,8 +44,7 @@ loop rules = do putStrLn "goal? "
printSolutions :: Result -> IO ()
printSolutions result = sequence_
[ do sequence_ [ putStrLn (prefix ++ " " ++ show (subst env pr))
- | (prefix, pr@(p :<-: pp)) <- reverse proof
--- , length pp >0
+ | (prefix, pr) <- reverse proof
]
putStr "substitution: "
putStrLn (show' env)
@@ -4,7 +4,8 @@
{-# LANGUAGE FlexibleInstances #-}
module Language.Prolog.NanoProlog.NanoProlog (
- LowerCase
+ Env
+ , LowerCase
, Result(..)
, Rule((:<-:))
, Subst(..)
@@ -81,7 +82,7 @@ instance Subst Term where
instance Subst Rule where
subst env (c :<-: cs) = subst env c :<-: subst env cs
-unify :: (Term, Term) -> Maybe Env-> Maybe Env
+unify :: (Term, Term) -> Maybe Env -> Maybe Env
unify _ Nothing = Nothing
unify (t, u) env@(Just m) = uni (subst m t) (subst m u)
where uni (Var x) y = Just (M.insert x y m)
@@ -104,27 +105,27 @@ solve rules e ((tg,t):ts) = ApplyRules
-- root to the current node. At a successful leaf this contains the
-- full proof.
enumerateDepthFirst :: Proofs -> Result -> [(Proofs, Env)]
-enumerateDepthFirst proofs (Done env) = [(proofs, env)]
-enumerateDepthFirst proofs (ApplyRules bs) =
- [ s | (tag, rule@(c :<-: cs), subTree) <- bs
- , s <- enumerateDepthFirst ((tag, rule):proofs) subTree
+enumerateDepthFirst proofs (Done env) = [(proofs, env)]
+enumerateDepthFirst proofs (ApplyRules bs) =
+ [ s | (tag', rule, subTree) <- bs
+ , s <- enumerateDepthFirst ((tag', rule):proofs) subTree
]
{-
-- | `enumerateBreadthFirst` is still undefined, and is left as an
-- exercise to the JCU students
-enumerateBreadthFirst :: Proofs -> [String] -> Result -> [(Proofs, Env)]
+enumerateBreadthFirst :: Proofs -> Result -> [(Proofs, Env)]
-}
-- | `printEnv` prints a single solution, showing only the variables
-- that were introduced in the original goal
show' :: Env -> String
show' env = intercalate ", " . filter (not.null) . map showBdg $ M.assocs env
- where showBdg (x, t) | isGlobVar x = x ++ " <- " ++ showTerm t
- | otherwise = ""
- showTerm t@(Var _) = showTerm (subst env t)
- showTerm (Fun f []) = f
- showTerm (Fun f ts) = f ++ "(" ++ intercalate ", " (map showTerm ts) ++ ")"
+ where showBdg (x, t) | isGlobVar x = x ++ " <- " ++ showTerm t
+ | otherwise = ""
+ showTerm t@(Var _) = showTerm (subst env t)
+ showTerm (Fun f []) = f
+ showTerm (Fun f ts) = f ++ "(" ++ intercalate ", " (map showTerm ts) ++ ")"
isGlobVar x = head x `elem` ['A'..'Z'] && last x `notElem` ['0'..'9']
instance Show Term where
@@ -140,14 +141,17 @@ showCommas :: Show a => [a] -> String
showCommas l = intercalate ", " (map show l)
-- ** Parsing Rules and Terms
-startParse :: (ListLike s b, Show b) => P (Str b s LineColPos) a -> s
- -> (a, [Error LineColPos])
+startParse :: (ListLike s b, Show b) => P (Str b s LineColPos) a -> s
+ -> (a, [Error LineColPos])
startParse p inp = parse ((,) <$> p <*> pEnd)
$ createStr (LineColPos 0 0 0) inp
+pSepDot :: Parser String -> Parser [String]
+pSepDot p = (:) <$> p <*> pFoldr list_alg ((:) <$> pDot <*> p)
+
pTerm, pVar, pFun :: Parser Term
pTerm = pVar <|> pFun
-pVar = Var <$> lexeme (pList1 pUpper)
+pVar = Var <$> lexeme ((++) <$> pList1 pUpper <*> (concat <$> pSepDot (pList1 pDigit) <|> pure []))
pFun = Fun <$> pLowerCase <*> (pParens pTerms `opt` [])
where pLowerCase :: Parser String
pLowerCase = (:) <$> pLower <*> lexeme (pList (pLetter <|> pDigit))

0 comments on commit 58c6259

Please sign in to comment.