├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── simple-prolog.cabal └── src ├── Main.hs ├── Prolog ├── Interpreter.hs └── Parse.hs ├── demo1.pl └── demo2.pl /.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore emacs backup files: 2 | *~ 3 | *.hi 4 | *.o 5 | \#*\# 6 | dist 7 | *.hers 8 | .cabal-sandbox 9 | cabal.sandbox.config 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Tikhon Jelvis 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Tikhon Jelvis nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This is just a simple Prolog interpreter. The goal is to write concise, elegant code rather than aiming for performance or feature completeness. 2 | 3 | I'll probably write up a detailed explanation of the code works later. 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /simple-prolog.cabal: -------------------------------------------------------------------------------- 1 | -- Initial simple-prolog.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: simple-prolog 5 | version: 0.1.0.0 6 | synopsis: A simple Prolog interpreter aimed at education rather than practical use. 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Tikhon Jelvis 11 | maintainer: Tikhon Jelvis 12 | -- copyright: 13 | category: Language 14 | build-type: Simple 15 | extra-source-files: README.md 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: Prolog.Interpreter, Prolog.Parse 20 | 21 | build-depends: base >=4 && <5, parsec >=3 22 | hs-source-dirs: src 23 | default-language: Haskell2010 24 | 25 | executable simple-prolog 26 | main-is: Main.hs 27 | -- other-modules: 28 | -- other-extensions: 29 | build-depends: simple-prolog, base >=4 && <5, parsec >= 3 30 | hs-source-dirs: src 31 | default-language: Haskell2010 -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad (foldM, when) 4 | 5 | import Control.Applicative ((<$), (<$>), (<*)) 6 | import Data.List (intercalate) 7 | 8 | import qualified System.Environment as Env 9 | import System.IO (hFlush, stdout) 10 | 11 | import Text.ParserCombinators.Parsec (ParseError, parse) 12 | 13 | import Prolog.Interpreter 14 | import Prolog.Parse 15 | 16 | type Parsed = Either ParseError 17 | 18 | showResult :: Predicate -> [MGU] -> [String] 19 | showResult _ [] = ["No"] 20 | showResult q res = showMgu . filter (contains (Pred q) . Var . fst) . simplify . reverse <$> res 21 | where showMgu [] = "Yes" 22 | showMgu mgu = intercalate " " $ map showBinding mgu 23 | showBinding (n,v) = showName n ++ " = " ++ showVal v 24 | showName (Name 0 n) = n 25 | showName (Name i n) = n ++ "_" ++ show i 26 | showVal (Atom atom) = atom 27 | showVal (Var n) = showName n 28 | showVal (Pred p) = showPred p 29 | showPred list@(Predicate _ "cons" _) = "[" ++ showList list ++ "]" 30 | showPred (Predicate _ n b) = n ++ "(" ++ intercalate ", " (showVal <$> b) ++ ")" 31 | showList (Predicate _ _ [a, b]) = showVal a ++ rest b 32 | where rest (Pred pr@(Predicate _ "cons" _)) = ", " ++ showList pr 33 | rest (Atom "nil") = "" 34 | rest term = "|" ++ showVal term 35 | 36 | repl :: String -> (String -> IO ()) -> IO () 37 | repl prompt action = putStr prompt >> hFlush stdout >> getLine >>= go 38 | where go "quit" = return () 39 | go inp = action inp >> repl prompt action 40 | 41 | main :: IO () 42 | main = do args <- Env.getArgs 43 | case args of 44 | [] -> putStrLn "Please specify a file to run." 45 | [file] -> run file 46 | _ -> putStrLn "Please only specify one file!" 47 | 48 | run :: FilePath -> IO () 49 | run file = do source <- readFile file 50 | let program = parse rules file source 51 | repl "?- " $ go . extractQuery program 52 | where go (Left err) = putStrLn $ "Error: " ++ show err 53 | go (Right (prog, q)) = printResults q $ resolve q prog 54 | 55 | extractQuery :: Parsed [Rule] -> String -> Parsed ([Rule], Predicate) 56 | extractQuery program input = do source <- program 57 | queries <- parse query "" input 58 | let (q,r) = disjoin queries 59 | return (r:source, q) 60 | 61 | printResults :: Predicate -> [MGU] -> IO () 62 | printResults q a = go $ showResult q a 63 | where go [] = return () 64 | go (r:rs) = putStr r >> hFlush stdout >> getLine >>= \ l -> when (';' `elem` l) $ go rs 65 | -------------------------------------------------------------------------------- /src/Prolog/Interpreter.hs: -------------------------------------------------------------------------------- 1 | module Prolog.Interpreter (simplify, disjoin, subst, contains, resolve, 2 | Term(..), Name(..), Rule(..), Predicate(..), MGU) where 3 | 4 | import Control.Applicative ((<$>), (<*>)) 5 | import Control.Monad (foldM, join) 6 | import Data.List (find, nub) 7 | import Data.Maybe (isJust, fromMaybe, mapMaybe) 8 | 9 | data Term = Atom String 10 | | Var Name 11 | | Pred Predicate deriving (Show, Eq) 12 | 13 | data Name = Name Int String deriving (Show, Eq) 14 | 15 | data Rule = Rule Predicate [Predicate] deriving (Show, Eq) 16 | 17 | data Predicate = Predicate Bool String [Term] deriving (Show, Eq) 18 | 19 | type MGU = [(Name, Term)] 20 | 21 | merge :: MGU -> MGU -> MGU 22 | merge m₁ m₂ = m₁ ++ [(v, subst m₁ t) | (v, t) <- m₂, Var v /= t] 23 | 24 | freshen :: Rule -> Rule 25 | freshen (Rule hd body) = Rule (freshenPred hd) $ freshenPred <$> body 26 | where freshenPred (Predicate a n args) = Predicate a n $ freshenTerm <$> args 27 | freshenTerm (Var (Name i n)) = Var $ Name (i + 1) n 28 | freshenTerm (Pred p) = Pred $ freshenPred p 29 | freshenTerm term = term 30 | 31 | substPred :: MGU -> Predicate -> Predicate 32 | substPred mgu (Predicate a n b) = Predicate a n $ subst mgu <$> b 33 | 34 | subst :: MGU -> Term -> Term 35 | subst mgu var@(Var name) = fromMaybe var $ lookup name mgu 36 | subst mgu (Pred p) = Pred $ substPred mgu p 37 | subst _ atom = atom 38 | 39 | unify :: Predicate -> Predicate -> Maybe MGU 40 | unify (Predicate _ name1 body1) (Predicate _ name2 body2) 41 | | name1 /= name2 || length body1 /= length body2 = Nothing 42 | | otherwise = foldM combine [] $ zip body1 body2 43 | where combine mgu (left, right) = go mgu (subst mgu left) (subst mgu right) 44 | go mgu (Var l) r | not (r `contains` Var l) = Just $ (l, r) : mgu 45 | go mgu l (Var r) | not (l `contains` Var r) = Just $ (r, l) : mgu 46 | go mgu (Pred l) (Pred r) = merge <$> unify l r <*> Just mgu 47 | go mgu l r = if l == r then Just mgu else Nothing 48 | 49 | contains :: Term -> Term -> Bool 50 | contains v1@Var{} v2@Var{} = v1 == v2 51 | contains (Pred (Predicate _ _ p)) n = or $ (`contains` n) <$> p 52 | contains _ _ = False 53 | 54 | resolve :: Predicate -> [Rule] -> [MGU] 55 | resolve goal rules = mapMaybe match (freshen <$> rules) >>= exec 56 | where match rule@(Rule hd _) = (,) rule <$> unify goal hd 57 | exec ((Rule _ body), mgu) = map go $ foldM append mgu body 58 | go mgu = map (\ (name, term) -> (name, subst mgu term)) mgu 59 | append mgu p@(Predicate True _ _) = 60 | merge mgu <$> resolve (substPred mgu p) (freshen <$> rules) 61 | append mgu p = 62 | if null . resolve (substPred mgu p) $ freshen <$> rules then [mgu] else [] 63 | 64 | disjoin :: [Predicate] -> (Predicate, Rule) 65 | disjoin preds = (goal, Rule goal $ preds) 66 | where goal = Predicate True "*" . nub $ preds >>= \ (Predicate _ _ t) -> t 67 | 68 | simplify :: MGU -> MGU 69 | simplify mgu = foldr (\ (v, t) mgu' -> (v, subst mgu t) : mgu') [] mgu 70 | -------------------------------------------------------------------------------- /src/Prolog/Parse.hs: -------------------------------------------------------------------------------- 1 | module Prolog.Parse (rules, query) where 2 | 3 | import Control.Applicative (liftA2, (*>), (<$), (<$>), (<*), 4 | (<*>)) 5 | import Control.Monad (void) 6 | 7 | import Text.ParserCombinators.Parsec 8 | 9 | import Prolog.Interpreter 10 | 11 | comment :: Parser () 12 | comment = () <$ (char '%' *> many (noneOf "\n") *> char '\n') "comment" 13 | 14 | whitespace :: Parser () 15 | whitespace = skipMany (void space <|> comment) "whitespace" 16 | 17 | idChar :: Parser Char 18 | idChar = letter <|> digit <|> char '_' 19 | 20 | name :: Parser String 21 | name = liftA2 (:) lower (many idChar) <* whitespace 22 | 23 | atom :: Parser Term 24 | atom = Atom <$> (name <|> many1 digit) "atom" 25 | 26 | variable :: Parser Term 27 | variable = Var . Name 0 <$> liftA2 (:) upper (many idChar) <* whitespace "variable" 28 | 29 | args :: Parser [Term] 30 | args = char '(' *> term `sepBy` (char ',' <* whitespace) <* char ')' <* whitespace 31 | 32 | predicate :: Parser Predicate 33 | predicate = negated <|> normal True 34 | where normal active = try (list active) 35 | <|> Predicate active <$> name <*> args "predicate" 36 | negated = (string "~" <|> string "\\+") *> whitespace *> (normal False) 37 | list active = do char '[' *> whitespace 38 | cars <- term `sepBy1` (char ',' *> whitespace) 39 | cdr <- rest <* whitespace 40 | let end = Predicate active "cons" [last cars, cdr] 41 | return . foldr (cons active) end $ init cars 42 | rest = whitespace *> char '|' *> whitespace *> term <* char ']' 43 | <|> Atom "nil" <$ char ']' 44 | cons active term rest = Predicate active "cons" [term, Pred rest] 45 | 46 | term :: Parser Term 47 | term = try (Pred <$> predicate) <|> atom <|> variable "term" 48 | 49 | rule :: Parser [Rule] 50 | rule = do hd <- predicate 51 | bodies <- end <|> string ":-" *> whitespace *> (body `sepBy` (char ';' *> whitespace)) <* end 52 | return $ Rule hd <$> bodies 53 | where end = [[]] <$ char '.' <* whitespace 54 | body = predicate `sepBy` (char ',' <* whitespace) 55 | 56 | rules :: Parser [Rule] 57 | rules = whitespace *> (concat <$> many1 rule) 58 | 59 | query :: Parser [Predicate] 60 | query = whitespace *> predicate `sepBy` (char ',' *> whitespace) <* char '.' "query" 61 | -------------------------------------------------------------------------------- /src/demo1.pl: -------------------------------------------------------------------------------- 1 | % Examples from my first few slides: 2 | likes(alice, pear). 3 | likes(alice, orange). 4 | female(alice). 5 | likes(bob, pear). 6 | likes(bob, banana). 7 | male(bob). 8 | 9 | % Load this and try running the examples, like: 10 | % ?- likes(alice, pear). 11 | 12 | % then go to demo2.pl 13 | -------------------------------------------------------------------------------- /src/demo2.pl: -------------------------------------------------------------------------------- 1 | % More examples from my first few slides: 2 | likes(alice, pear). 3 | likes(alice, orange). 4 | female(alice). 5 | likes(bob, pear). 6 | likes(bob, banana). 7 | male(bob). 8 | 9 | % Added a few more facts: 10 | likes(charles, X) :- fruit(X). 11 | likes(dan, X) :- fruit(X), yellow(X). 12 | 13 | likes(eve, X) :- fruit(X); vegetable(X). 14 | 15 | fruit(pear). 16 | fruit(orange). 17 | fruit(banana). 18 | 19 | yellow(banana). 20 | 21 | % Enough with fruits! Now to talk about numbers in numbers.pl. --------------------------------------------------------------------------------