prolog 処理系もどき

久しぶりの日記。今日は飲み会で揚げ物ばっかり食べて、しかもそのあとラーメンまで食べるという暴挙にでたのでお腹の調子が大変よくないのですが、今日の昼間に適当に書いた prolog 処理系っぽいものをはっておく。
現状ではパーサとかはまったくないので、コード中で与えられた構文木に対して処理してます。波平はサザエのパパ、サザエはタラオの親、という情報から波平はタラオのグランパ、という推論をさせることができました。おめでとう。お腹痛い。
実装はものすごくナイーブな感じで、あらゆるパターンを全部試してる感じです。現状で扱える値は文字列のみです。リストくらい扱えるといいなと思っているのですが、よくわかりません。そもそも prolog をほとんど知らないので、文法的なものが全然違うかもだし、動作が違う可能性もあります。テストも満足にできません。
それから、なにも知らずに言ってますが、 Haskell だと遅延評価だからカットとかも比較的簡単に実装できるのではないかと思っているのですがどうなんでしょう。

import Data.Maybe
import Data.Char
import Data.List

import System.IO.Unsafe

data Predicate = Pred PredName [([Arg], [SubGoal])]
data SubGoal = Equal Arg Arg
             | SG PredName [Arg] deriving (Eq, Show)
type PredName = String
type Arg = String
type Env = [PVal]
type PVal = String
type Preds = [(PredName, Predicate)]

update :: [(String, String)] -> [Arg] -> [PVal]
update env args = foldl replace args env
    where
      replace :: [Arg] -> (String, PVal) -> [PVal]
      replace args (var,val) = map (\x -> if x==var then val else x) args

search :: PredName -> Env -> Bool
search pname env =
    case lookup pname preds of
      Nothing -> error $ "No such predicate: "++pname
      Just (Pred _ defs) ->
          case defs of
            [] -> True
            _ -> any (checkSubGoals env) defs

checkSubGoals :: [PVal] -> ([Arg], [SubGoal]) -> Bool
checkSubGoals env (args, subgoals) =
    or $ do bfvs <- boundedFVs
            let newbinding = boundedVs ++ zip fvs bfvs
            return $ all (checkSubGoal newbinding) subgoals
    where
      fvs = (nub $ concatMap freeVariables subgoals) \\ args
      boundedFVs = assignToUnassignedArgs fvs
      boundedVs = zip args env
      checkSubGoal newbinding (SG pname sgArgs) =
          search pname $ update newbinding sgArgs
      checkSubGoal newbinding (Equal x y) =
          fromJust $ do eval_x <- if isUpper (head x)
                                  then lookup x newbinding
                                  else return x
                        eval_y <- if isUpper (head y)
                                  then lookup y newbinding
                                  else return y
                        return $ eval_x == eval_y

freeVariables :: SubGoal -> [Arg]
freeVariables (SG _ args) = args
freeVariables (Equal x y) =
    case (isUpper $ head x, isUpper $ head y) of
      (True, True) -> [x,y]
      (True, False) -> [x]
      (False, True) -> [y]
      _ -> []

assignToUnassignedArgs :: [Arg] -> [[PVal]]
assignToUnassignedArgs args =
    let targets = filter (isUpper . head) args
        numOfVar = length targets
    in  do assigns <- assignVal numOfVar
           return $ update (zip targets assigns) args
assignVal 0 = return []
assignVal n = do v <- vals
                 vs <- assignVal (n-1)
                 return $ v:vs

start pname args =
    do cand <- assignToUnassignedArgs args
       if search pname cand then return cand else []

preds :: Preds
preds = [("man", man)
        ,("parent", parent)
        ,("father", father)
        ,("grandFather", grandFather)
        ]
vals :: [String]
vals = ["namihei", "masuo", "tarao", "wakame", "sazae"]

man = Pred "man" [(["X"], [Equal "X" "namihei"])
                 ,(["X"], [Equal "X" "masuo"])
                 ,(["X"], [Equal "X" "tarao"])
                 ]
parent = Pred "parent" [(["X","Y"], [Equal "X" "masuo", Equal "Y" "tarao"])
                       ,(["X","Y"], [Equal "X" "sazae", Equal "Y" "tarao"])
                       ,(["X","Y"], [Equal "X" "namihei", Equal "Y" "wakame"])
                       ,(["X","Y"], [Equal "X" "namihei", Equal "Y" "sazae"])
                       ]
father = Pred "father" [(["X","Y"], [SG "parent" ["X", "Y"], SG "man" ["X"]])]
grandFather = Pred "grandFather" [(["X","Y"], [SG "parent" ["Z","Y"], SG "father" ["X","Z"]])]

実行結果。

*Main> start "father" ["X","Y"]
[["namihei","wakame"],["namihei","sazae"],["masuo","tarao"]]
*Main> start "father" ["namihei","Y"]
[["namihei","wakame"],["namihei","sazae"]]
*Main> start "grandFather" ["X","Y"]
[["namihei","tarao"]]
*Main>