Basic prolog interpreter

prolog.hs

module Main where

import Control.Monad.State
import Data.Char
import Data.List
import Data.Maybe
import qualified Data.Map as M

type Exprs = [Expr]
type Database = Exprs
type Predicate = String

data Expr = Fact Predicate [Type]
          | Rule Predicate [Type] [Expr]

data Type = S String 
          | Var String
    deriving (Show, Eq, Ord)

instance Show Expr where
    show (Fact p atoms) = 
        p ++ "(" ++ (intercalate ", " $ map show atoms) ++ ")"

type Frame = M.Map Type Type
type PatternState = (Frame, [Bool])

addFact :: Database -> Expr -> Database
addFact db fact = db ++ [fact]

addFacts :: Database -> Exprs -> Database
addFacts db [] = db
addFacts db (f:fs) = addFacts (addFact db f) fs

match :: [Type] -> [Type] -> State PatternState Bool
match [] [] = do
    (_, bs) <- get
    return $ and bs

match (t:ts) (x:xs) = do
    (state, bs) <- get
    case t of
        b@(Var _) -> updateState b bs state x
        el -> case x of 
                b1@(Var _) -> updateState b1 bs state t
                el1 -> put (state, (el1 == el):bs)
    match ts xs
  where
    updateState b bs state el = 
        case M.lookup b state of
            (Just v) -> put (state, (v == el):bs)
            Nothing  -> put (M.insert b el state, bs)

match [] xs = return False
match ts [] = return False 

queryForArgs :: Database -> Predicate -> [[Type]]
queryForArgs db predicate = do
    let facts = filter fun db
    map (\(Fact _ args) -> args) facts
  where
    fun (Fact p _) = p == predicate
    fun _ = False

unify :: Database -> Predicate -> [Type] -> Frame -> [Frame]
unify db p m frame = do
    arg <- queryForArgs db p 
    let (r, (newframe, _)) = runState (match m arg) (frame, [])
    guard r
    return newframe

solve :: Database -> Exprs -> State [Frame] [Frame]
solve _ [] = do
    frames <- get
    return frames

solve db (f@(Fact p pattern):facts) = do
    frames <- get
    put . concat $ map (unify db p pattern) frames
    solve db facts

pretty :: [Frame] -> String
pretty res = do
    let ls = concat $ map M.toList res
    unlines $ map (\(Var n, S s) -> (cap n) ++ " = " ++ s) ls
  where
    cap = map toUpper

factize db exprs = concat $ map (stRule db) exprs

stRule db f@(Fact pr fargs) = do
    let x = filter fun db
    if null x 
        then [f]
        else do 
            let (Rule _ rargs exps) = head x
            map (fix (zip rargs fargs)) exps 
  where
    fun (Fact _ _) = False
    fun (Rule p _ _ ) = p == pr
    fix l (Fact p args) = 
        Fact p $ map (\k -> fromMaybe k (lookup k l)) args


main :: IO ()
main = do
    let db = addFacts [] [Fact "male"  [S "gabriele"],
                          Fact "female"  [S "maria"],
                          Fact "mother" [S "giulia", S "gabriele"],
                          Fact "mother" [S "giulia", S "maria"],
                          Rule "son" [Var "x", Var "y"] 
                                      [Fact "male" [Var "x"],
                                       Fact "mother" [Var "y", Var "x"]]]

    let res = execState (solve db $ factize db [Fact "male"  [Var "y"],
                                                Fact "mother" [Var "x", Var "y"]]) 
                        [M.empty]
    let res2 = execState (solve db $ factize db [Fact "son" [Var "x", Var "y"]]) 
                        [M.empty]                    
    putStr $ pretty res2