Browse files

Initial import of NanoProlog

  • Loading branch information...
0 parents commit c78144523d23d7356cd2559bd32d4af740f64bab @norm2782 committed May 22, 2011
Showing with 260 additions and 0 deletions.
  1. +25 −0 LICENSE
  2. +27 −0 Makefile
  3. +29 −0 NanoProlog.cabal
  4. +1 −0 README
  5. +2 −0 Setup.hs
  6. +152 −0 src/Language/Prolog/NanoProlog.hs
  7. +24 −0 src/Language/Prolog/royals.pro
25 LICENSE
@@ -0,0 +1,25 @@
+Copyright (c) 2011, Jurriën Stutterheim, Robert Kreuzer
+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 <organization> 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 EVENT SHALL <COPYRIGHT HOLDER> 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.
+
27 Makefile
@@ -0,0 +1,27 @@
+default:
+ make clean
+ make install
+
+jcu:
+ make && jcu
+
+dist:
+ cabal check
+ cabal configure
+ cabal sdist
+
+install:
+ cabal install -fdevelopment
+
+clean:
+ cabal clean
+
+run:
+ jcu
+
+debug:
+ DEBUG=1 jcu
+
+deps:
+ rm -rf deps
+ mkdir deps && cd deps && git clone https://github.com/snapframework/snap-auth.git && cd snap-auth && cabal install && cd .. && git clone https://github.com/ozataman/snap-extension-mongodb.git && cd snap-extension-mongodb && cabal install && cd ../..
29 NanoProlog.cabal
@@ -0,0 +1,29 @@
+Name: NanoProlog
+Version: 0.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
+ (@Language.prolog.Nanoprolog@) which can be run on its
+ own. It reads a file with definitions, and then prompts
+ for a goal. All possibe solutions are printed, preceded by
+ a tree showing which rules were applied in which order.
+License: BSD3
+license-file: LICENSE
+Author: Jurriën Stutterheim, Doaitse Swierstra
+Maintainer: Jurriën Stutterheim
+Stability: Experimental
+Category: Language
+Build-type: Simple
+Cabal-version: >= 1.6
+
+Source-repository head
+ Type: git
+ Location: https://github.com/norm2782/NanoProlog.git
+
+Executable nano-prolog
+ Hs-source-dirs: src
+ main-is: NanoProlog.hs
+
+ Build-depends:
+ base >= 4 && < 5,
+ uu-parsinglib >= 2.7.1
1 README
@@ -0,0 +1 @@
+NanoProlog README goes here.
2 Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
152 src/Language/Prolog/NanoProlog.hs
@@ -0,0 +1,152 @@
+
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Language.Prolog.NanoProlog (Term(..),Rule((:<-:)),LowerCase,unify,subst,startParse,pRule,pTerm) where
+
+import Data.ListLike.Base (ListLike)
+import Data.List (intercalate)
+import Text.ParserCombinators.UU
+import Text.ParserCombinators.UU.BasicInstances
+import Text.ParserCombinators.UU.Utils
+import System.IO
+
+
+-- * Types
+type UpperCase = String
+type LowerCase = String
+
+data Term = Var UpperCase
+ | Fun LowerCase [Term]
+ deriving (Eq, Ord)
+
+data Rule = Term :<-: [Term]
+ deriving Eq
+
+class Taggable a where
+ tag :: Int -> a -> a
+
+instance Taggable Term where
+ tag n (Var x) = Var (x ++ show n)
+ tag n (Fun x xs) = Fun x (tag n xs)
+
+instance Taggable Rule where
+ tag n (c :<-: cs) = tag n c :<-: tag n cs
+
+instance Taggable a => Taggable [a] where
+ tag n = map (tag n)
+
+type Env = [(UpperCase, Term)]
+
+emptyEnv :: Maybe Env
+emptyEnv = Just []
+
+-- * The Prolog machinery
+data Result = None
+ | Done Env
+ | ApplyRules [(Rule, Result)]
+
+subst :: Env -> Term -> Term
+subst env (Var x) = maybe (Var x) (subst env) (lookup x env)
+subst env (Fun x cs) = Fun x (map (subst env) cs)
+
+unify :: (Term, Term) -> Maybe Env -> Maybe Env
+unify _ Nothing = Nothing
+unify (t, u) env@(Just e) = uni (subst e t) (subst e u)
+ where uni (Var x) y = Just ((x, y): e)
+ uni x (Var y) = Just ((y, x): e)
+ uni (Fun x xs) (Fun y ys)
+ | x == y && length xs == length ys = foldr unify env (zip xs ys)
+ | otherwise = Nothing
+
+solve :: [Rule] -> Maybe Env -> Int -> [Term] -> Result
+solve _ Nothing _ _ = None
+solve _ (Just e) _ [] = Done e
+solve rules e n (t:ts)
+ = ApplyRules [ (rule, solve rules (unify (t, c) e) (n+1) (cs ++ ts))
+ | rule@(c :<-: cs) <- tag n rules
+ ]
+
+-- * Running the Interpreter
+-- ** The main interpreter
+-- | The `main` program prompt for a file with Prolog rules and call the main interpreter loop
+main :: IO ()
+main = do hSetBuffering stdin LineBuffering
+ putStr "File with rules? "
+ fn <- getLine
+ s <- readFile fn
+ let (rules, errors) = startParse (pList pRule) s
+ if Prelude.null errors then do mapM_ print rules
+ loop rules
+ else do putStrLn "No rules parsed"
+ mapM_ print errors
+ main
+
+-- | `loop` ask for a goal, and enuartes all solutions found, each preceded by a trace conatining the rules applied in a tree-like fashion
+loop :: [Rule] -> IO ()
+loop rules = do putStr "goal? "
+ s <- getLine
+ unless (s == "quit") $
+ do let (goal, errors) = startParse pFun s
+ if null errors
+ then printSolutions (print goal) ["0"] (solve rules emptyEnv 0 [goal])
+ else do putStrLn "Some goals were expected:"
+ mapM_ (putStrLn.show) errors
+ loop rules
+
+-- ** Printing the solutions
+-- | `printSolutions` performs a depth-first walk over the `Result` tree, while accumulating the rules that were applied on the path which was traversed from the root to the current node. At a successful leaf tis contains the full proof
+printSolutions :: IO () -> [String] -> Result -> IO ()
+printSolutions prProof _ (Done env) = do prProof
+ putStr "solution: "
+ printEnv env
+ getLine
+ return ()
+printSolutions _ _ None = return ()
+printSolutions prProof (pr:prefixes) (ApplyRules bs)
+ = sequence_ [ printSolutions (prProof >> putStrLn (pr ++ " " ++ show rule)) (extraPrefixes++prefixes) result
+ | (rule@(c :<-: cs), result) <- bs
+ , let extraPrefixes = take (length cs) (map (\i -> pr ++ "." ++ show i) [(1 :: Int) ..])
+ ]
+
+-- | `printEnv` prints a single solution, shwoing only the variables that were introduced in the original goal
+printEnv :: Env -> IO ()
+printEnv bs = putStr (intercalate ", " . filter (not.null) . map showBdg $ bs)
+ where showBdg ( x,t) | isGlobVar x = x ++ " <- "++ showTerm t
+ | otherwise = ""
+ showTerm t@(Var _) = showTerm (subst bs 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
+ show (Var i) = i
+ show (Fun i [] ) = i
+ show (Fun i ts ) = i ++ "(" ++ showCommas ts ++ ")"
+
+instance Show Rule where
+ show (t :<-: [] ) = show t ++ "."
+ show (t :<-: ts ) = show t ++ ":-" ++ showCommas ts ++ "."
+
+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 p inp = parse ((,) <$> p <*> pEnd)
+ $ createStr (LineColPos 0 0 0) inp
+
+pTerm, pVar, pFun :: Parser Term
+pTerm = pVar <|> pFun
+pVar = Var <$> lexeme (pList1 pUpper)
+pFun = Fun <$> pLowerCase <*> (pParens pTerms `opt` [])
+ where pLowerCase :: Parser String
+ pLowerCase = (:) <$> pLower
+ <*> lexeme (pList (pLetter <|> pDigit))
+
+pRule :: Parser Rule
+pRule = (:<-:) <$> pFun <*> (pSymbol ":-" *> pTerms `opt` []) <* pDot
+
+pTerms :: Parser [Term]
+pTerms = pListSep pComma pTerm
24 src/Language/Prolog/royals.pro
@@ -0,0 +1,24 @@
+ma(mien,juul).
+ma(juul,bea).
+ma(bea,alex).
+ma(bea,cons).
+oma(X,Z):-ma(X,Y),ouder(Y,Z).
+
+append(nil,X,X).
+append(cons(A,X), Y, cons(A,Z)):- append(X,Y,Z) .
+
+pa(alex,ale).
+pa(alex,ama).
+pa(alex,ari).
+ma(max,ale).
+ma(max,ama).
+ma(max,ari).
+
+ouder(X,Y) :- pa(X,Y).
+ouder(X,Y) :- ma(X,Y).
+
+voor(X,Y) :- ouder(X,Y).
+voor(X,Y) :- ouder(X,Z), voor(Z,Y).
+
+plus(zero,X,X).
+plus(succ(X), Y, succ(Z)) :- plus(X, Y,Z).

0 comments on commit c781445

Please sign in to comment.