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>