├── .github └── workflows │ └── ci.yml ├── .gitignore ├── Akarui.cabal ├── Akarui ├── FOL │ ├── BinT.hs │ ├── Clausal.hs │ ├── Domain.hs │ ├── FOL.hs │ ├── Formula.hs │ ├── FormulaSet.hs │ ├── KnowledgeBase.hs │ ├── LiteralSign.hs │ ├── MarkovLogic.hs │ ├── Predicate.hs │ ├── PrettyPrint.hs │ ├── QuanT.hs │ ├── RuleType.hs │ ├── SetClause.hs │ ├── Symbols.hs │ ├── Term.hs │ └── WalkSAT.hs ├── Fmt.hs ├── MVL │ ├── Fuzzy.hs │ ├── Fuzzy2.hs │ ├── FuzzyLogic.hs │ ├── FuzzySet.hs │ └── Truth.hs ├── Network.hs ├── Parser │ ├── Bool.hs │ ├── Core.hs │ ├── FOL.hs │ ├── FuzzySet.hs │ ├── LogicOps.hs │ ├── NamedFuzzy.hs │ ├── Numbers.hs │ ├── Probability.hs │ └── Term.hs ├── ShowTxt.hs ├── Text.hs └── Utils.hs ├── CODE_OF_CONDUCT.md ├── LICENSE.md ├── README.md ├── Setup.hs └── tests ├── FOLSpec.hs ├── PredicateSpec.hs ├── Properties.hs ├── TermSpec.hs └── TextGen.hs /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | push: 4 | branches: 5 | - main 6 | - develop 7 | pull_request: 8 | types: 9 | - opened 10 | - synchronize 11 | 12 | jobs: 13 | build: 14 | runs-on: ubuntu-latest 15 | strategy: 16 | matrix: 17 | cabal: ["3.4"] 18 | ghc: ["8.10.4"] 19 | env: 20 | CONFIG: "--enable-tests" 21 | # CONFIG: "--enable-tests --enable-benchmarks" 22 | steps: 23 | - uses: actions/checkout@v2 24 | - uses: actions/setup-haskell@v1 25 | with: 26 | ghc-version: ${{ matrix.ghc }} 27 | cabal-version: ${{ matrix.cabal }} 28 | - run: cabal v2-update $CONFIG 29 | - run: cabal v2-build $CONFIG 30 | - run: cabal v2-test $CONFIG 31 | # - run: cabal v2-haddock $CONFIG 32 | # - run: cabal v2-sdist 33 | 34 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist* 2 | .cabal-sandbox 3 | cabal.sandbox.config 4 | cabal.project.local 5 | cabal.project.local~ 6 | .ghc* 7 | 8 | -------------------------------------------------------------------------------- /Akarui.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: Akarui 3 | version: 0.2.0.0 4 | synopsis: Hybrid logic + probabilistic machine learning library 5 | license: Apache-2.0 6 | license-file: LICENSE.md 7 | author: Philippe Desjardins-Proulx 8 | maintainer: Philippe Desjardins-Proulx 9 | category: AI, Machine Learning, Logic, Statistics 10 | build-type: Simple 11 | description: 12 | A research library for ideas at the frontier of logic, probability, and fuzziness. 13 | 14 | library 15 | default-language: Haskell2010 16 | ghc-options: -O2 -Wall -fno-warn-orphans 17 | default-extensions: 18 | OverloadedStrings 19 | Strict 20 | StrictData 21 | exposed-modules: 22 | Akarui.Fmt 23 | Akarui.ShowTxt 24 | Akarui.Network 25 | Akarui.FOL.Formula 26 | Akarui.FOL.FOL 27 | Akarui.FOL.Predicate 28 | Akarui.FOL.Term 29 | Akarui.FOL.Symbols 30 | Akarui.FOL.BinT 31 | Akarui.FOL.QuanT 32 | Akarui.FOL.PrettyPrint 33 | Akarui.FOL.FormulaSet 34 | Akarui.FOL.MarkovLogic 35 | Akarui.FOL.WalkSAT 36 | Akarui.MVL.Truth 37 | Akarui.MVL.Fuzzy 38 | Akarui.MVL.Fuzzy2 39 | Akarui.MVL.FuzzySet 40 | Akarui.MVL.FuzzyLogic 41 | Akarui.Parser.Core 42 | Akarui.Parser.FOL 43 | Akarui.Parser.Term 44 | Akarui.Parser.FuzzySet 45 | Akarui.Parser.LogicOps 46 | Akarui.Parser.Probability 47 | Akarui.Parser.Numbers 48 | Akarui.Parser.Bool 49 | other-modules: 50 | Akarui.Text 51 | Akarui.Utils 52 | build-depends: 53 | base >= 4.12 && < 4.15, 54 | containers, 55 | parsec >= 3.1.2, 56 | text, 57 | transformers, 58 | random, 59 | accelerate == 1.3.0.0 60 | 61 | test-suite tests 62 | default-language: Haskell2010 63 | -- Supress orphan warnings to allow 'Arbitrary' instance def: 64 | ghc-options: -Wall -fno-warn-orphans 65 | hs-source-dirs: tests 66 | type: exitcode-stdio-1.0 67 | main-is: Properties.hs 68 | other-modules: 69 | FOLSpec 70 | TermSpec 71 | PredicateSpec 72 | TextGen 73 | build-depends: 74 | base >= 4.12 && < 4.15, 75 | containers, 76 | QuickCheck >= 2.7, 77 | test-framework-quickcheck2, 78 | text, 79 | Akarui, 80 | random 81 | 82 | source-repository head 83 | type: git 84 | location: git://github.com/PhDP/Akarui.git 85 | -------------------------------------------------------------------------------- /Akarui/FOL/BinT.hs: -------------------------------------------------------------------------------- 1 | module Akarui.FOL.BinT where 2 | 3 | import Akarui.ShowTxt 4 | 5 | -- | Supported binary connectives (in order of precedence). 6 | data BinT = 7 | -- | Conjunction. Returns true only if both sides are true. 8 | And 9 | -- | Disjunction. Returns true if at least one operand is true. 10 | | Or 11 | -- | Implication is... messed up. It returns true except if the 12 | -- left operand is true and the right one is false, e.g. True implies False 13 | -- is the only situation where implication returns false. 14 | | Implies 15 | -- | Exclusive disjunction. Returns true if one and only one operand is true. 16 | | Xor 17 | -- | Equivalence. Returns true is both operand have the same value, i.e. both 18 | -- true or both are false. 19 | | Iff 20 | deriving (Eq, Ord, Show) 21 | 22 | instance ShowTxt BinT where 23 | showTxt And = "And" 24 | showTxt Or = "Or" 25 | showTxt Implies = "Implies" 26 | showTxt Xor = "Xor" 27 | showTxt Iff = "Iff" 28 | -------------------------------------------------------------------------------- /Akarui/FOL/Clausal.hs: -------------------------------------------------------------------------------- 1 | -- | Defines a type class for clausal forms. 2 | module Akarui.FOL.Clausal where 3 | 4 | -- class (KnowledgeBase c) => Clause c where 5 | class Clausal c where 6 | -- | Number of positive literals in the clause. 7 | numPositive :: c -> Int 8 | 9 | -- | Number of negative literals in the clause. 10 | numNegative :: c -> Int 11 | 12 | -- | Number of literals in the clause 13 | numLiterals :: c -> Int 14 | numLiterals x = numPositive x + numNegative x 15 | 16 | -- | Returns true for empty clauses. 17 | isEmpty :: c -> Bool 18 | isEmpty x = numLiterals x == 0 19 | 20 | -- | A definite clause has only one positive literal. 21 | isDefinite :: c -> Bool 22 | isDefinite x = numPositive x == 1 23 | 24 | -- | A fact has only one positive literal and no negative literals. 25 | isFact :: c -> Bool 26 | isFact x = numPositive x == 1 && numNegative x == 0 27 | 28 | -- | A rule has one positive literal and one or more negative literals. 29 | isRule :: c -> Bool 30 | isRule x = numPositive x == 1 && numNegative x > 0 31 | 32 | -- | A query has no positive literals and one or more negative literals. 33 | isQuery :: c -> Bool 34 | isQuery x = numPositive x == 0 && numNegative x > 0 35 | 36 | -- | Horn clauses have 0 or 1 positive literals. 37 | isHorn :: c -> Bool 38 | isHorn x = numPositive x < 2 39 | -------------------------------------------------------------------------------- /Akarui/FOL/Domain.hs: -------------------------------------------------------------------------------- 1 | -- | Domain of terms. 2 | module Akarui.FOL.Domain where 3 | 4 | import Data.Set (Set) 5 | import Akarui.Parser 6 | import Text.Parsec 7 | import Text.Parsec.String (Parser) 8 | import qualified Data.Set as Set 9 | 10 | -- | Domain of variables and constants. 11 | data Domain = 12 | Any 13 | | Interval Double Double 14 | | Finite (Set String) 15 | 16 | -- | Parse a clause (a disjunction of positive and negative literals). 17 | -- 18 | -- @ 19 | -- dom1={1, 2, 3, 4} 20 | -- person = { Elaine, George, Jerry, Cosmo, Newman } 21 | -- @ 22 | parseDomain :: String -> Either ParseError (String, Set String) 23 | parseDomain = parse (contents parseDs) "" 24 | 25 | 26 | parseDs :: Parser (String, Set String) 27 | parseDs = do 28 | n <- identifier 29 | reservedOp "=" 30 | reservedOp "{" 31 | elems <- commaSep identifier 32 | reservedOp "}" 33 | return (n, Set.fromList elems) 34 | -------------------------------------------------------------------------------- /Akarui/FOL/FOL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 2 | 3 | -- | Type and functions for first-order predicate logic. 4 | module Akarui.FOL.FOL where 5 | 6 | import qualified Data.Map as Map 7 | import Data.Map (Map) 8 | import qualified Data.Set as Set 9 | import Data.Set (Set) 10 | import Data.List (foldl') 11 | import qualified Data.Text as T 12 | import Akarui.ShowTxt 13 | import Akarui.FOL.Formula 14 | import Akarui.FOL.Predicate (Predicate (Predicate)) 15 | import Akarui.FOL.Symbols (symbolic) 16 | import qualified Akarui.FOL.Predicate as Pred 17 | import Akarui.FOL.Term (Term (Constant, Variable, Function)) 18 | import qualified Akarui.FOL.Term as Term 19 | import Akarui.FOL.PrettyPrint 20 | import Akarui.FOL.BinT 21 | import Akarui.FOL.QuanT 22 | 23 | -- | A first-order logic formula is simply a formula of predicates. 24 | type FOL = Formula Predicate 25 | 26 | -- | Special "Truth", "Top", "True" predicate. 27 | top :: FOL 28 | top = Atom $ Predicate "Top" [] 29 | 30 | -- | Special "False", "Bot", "Bottom" predicate. 31 | bot :: FOL 32 | bot = Atom $ Predicate "Bot" [] 33 | 34 | instance Show FOL where 35 | show = T.unpack . prettyPrintFm symbolic 36 | 37 | instance ShowTxt FOL where 38 | showTxt = prettyPrintFm symbolic 39 | 40 | instance PrettyPrint FOL where 41 | prettyPrint = prettyPrintFm 42 | 43 | -- | Extracts predicates from a list of formulas. If a formula is not an atom, 44 | -- it will be ignored. 45 | toPredicates :: [FOL] -> [Predicate] 46 | toPredicates = foldl' (\acc f -> case f of Atom p -> p : acc; _ -> acc) [] 47 | 48 | -- | Tests if the formula is 'grounded', i.e. if it has no variables. 49 | ground :: FOL -> Bool 50 | ground f = case f of 51 | Atom (Predicate _ ts) -> all Term.ground ts 52 | BinOp _ x y -> ground x || ground y 53 | Quantifier _ _ x -> ground x 54 | _ -> False 55 | 56 | -- | Gathers all the variables in a first-order logic formula. 57 | variables :: FOL -> Set T.Text 58 | variables = gat Set.empty 59 | where 60 | -- Gathers variables from terms 61 | gatT s term = case term of 62 | Function _ ts -> foldl' gatT Set.empty ts 63 | Variable v -> Set.insert v s 64 | Constant _ -> Set.empty 65 | -- Gathers variables from formula 66 | gat s fm = case fm of 67 | Atom (Predicate _ ts) -> foldl' gatT Set.empty ts 68 | Not x -> Set.union (gatE x) s 69 | BinOp _ x y -> Set.unions [gatE x, gatE y, s] 70 | Quantifier _ _ x -> Set.union (gatE x) s 71 | -- Gathers with an empty set 72 | gatE = gat Set.empty 73 | 74 | -- | Test for the presence of a predicate in the formula. 75 | hasPred :: Predicate -> FOL -> Bool 76 | hasPred p f = case f of 77 | Atom p' -> p == p' 78 | BinOp _ x y -> hasPred p x || hasPred p y 79 | Quantifier _ _ x -> hasPred p x 80 | _ -> False 81 | 82 | -- | Test for the presence of a predicate in the formula using only the name 83 | -- of the predicate. 84 | hasPredName :: FOL -> T.Text -> Bool 85 | hasPredName f n = case f of 86 | Atom (Predicate n' _) -> n == n' 87 | BinOp _ x y -> hasPredName x n || hasPredName y n 88 | Quantifier _ _ x -> hasPredName x n 89 | _ -> False 90 | 91 | -- | Returns true if the formula has functions. This is often used in algorithms 92 | -- where we must ensure all functions have been resolved to an object. 93 | hasFun :: FOL -> Bool 94 | hasFun f = case f of 95 | Atom (Predicate _ ts) -> any (\trm -> (Term.numFuns trm :: Int) > 0) ts 96 | BinOp _ x y -> hasFun x || hasFun y 97 | Quantifier _ _ x -> hasFun x 98 | _ -> False 99 | 100 | -- | Substitute a term in the formula. 101 | substitute :: Term -> Term -> FOL -> FOL 102 | substitute old new f = case f of 103 | Atom (Predicate n ts) 104 | -> Atom $ Predicate n $ map (Term.substitute old new) ts 105 | Not x -> Not $ substitute old new x 106 | BinOp b x y -> BinOp b (substitute old new x) (substitute old new y) 107 | Quantifier q v x -> Quantifier q v (substitute old new x) 108 | 109 | -- | Shows the internal structure of the first-order logic formula. This is 110 | -- mostly useful for testing and making sure the formula has the correct 111 | -- structure. 112 | showFOLStruct :: FOL -> T.Text 113 | showFOLStruct f = case f of 114 | Atom a -> Pred.showStruct a 115 | Not x -> T.concat ["Not (", showFOLStruct x, ")"] 116 | BinOp b x y -> T.concat [showTxt b, " (", showFOLStruct x, ") (", showFOLStruct y, ")"] 117 | Quantifier q v x -> T.concat [showTxt q, " ", v, "(", showFOLStruct x, ")"] 118 | 119 | -- | Resolves universal Quantifiers, substituting the variables in the 'ForAll' 120 | -- for a given term (a constant, generally). 121 | resolveForAll :: T.Text -> Term -> FOL -> FOL 122 | resolveForAll v t f = case f of 123 | Not x -> Not $ resolveForAll v t x 124 | BinOp b x y -> BinOp b (resolveForAll v t x) (resolveForAll v t y) 125 | Quantifier ForAll v' x -> 126 | if v == v' then substitute (Variable v) t x 127 | else Quantifier ForAll v' (resolveForAll v t x) 128 | Quantifier Exists v' x -> Quantifier Exists v' (resolveForAll v t x) 129 | _ -> f 130 | 131 | -- | Takes a formula, a map between functions and constants, and a list of 132 | -- constants to produce a set of groundings. 133 | -- 134 | -- Reference: 135 | -- P Domingos and D Lowd, Markov Logic: An Interface Layer for Artificial 136 | -- Intelligence, 2009, Morgan & Claypool. p. 14. 137 | groundings :: [Term] -> FOL -> Set FOL 138 | groundings cs f = loopV 139 | where 140 | groundSub v f' = case f' of 141 | Atom p -> 142 | if Pred.hasVar v p then 143 | let as = map (\c -> Atom $ Pred.substitute (Variable v) c p) cs in 144 | foldr1 (BinOp Or) as 145 | else 146 | f' 147 | Not x -> Not $ groundSub v x 148 | BinOp b x y -> BinOp b (groundSub v x) (groundSub v y) 149 | Quantifier q v' x -> Quantifier q v' (groundSub v' x) 150 | 151 | existsVar f' = case f' of 152 | Not x -> Not $ existsVar x 153 | BinOp b x y -> BinOp b (existsVar x) (existsVar y) 154 | Quantifier Exists v x -> existsVar $ groundSub v x 155 | Quantifier ForAll v x -> Quantifier ForAll v $ existsVar x 156 | _ -> f' 157 | 158 | f0 = existsVar f 159 | g0 = Set.fromList [f0] 160 | vs = uniquanVars f0 161 | 162 | loopV = Set.foldr' loopG g0 vs 163 | loopG v g = Set.foldr (\x a -> Set.union a (Set.fromList x)) Set.empty (gr v g) 164 | where 165 | gr v' = 166 | Set.map (\fm -> map (\c -> simplify $ resolveForAll v' c fm) cs) 167 | 168 | -- | Returns all possible valuations of a set of formula. 169 | allAss :: Set FOL -> [Map Predicate Bool] 170 | allAss fs = if null as then [] else ms (head as) (tail as) 171 | where 172 | as = Set.toList $ Set.foldr Set.union Set.empty $ Set.map atoms fs 173 | ms atm s = 174 | if null s then 175 | [Map.fromList [(atm, True)], Map.fromList [(atm, False)]] 176 | else 177 | map (Map.insert atm True) (ms (head s) (tail s)) ++ 178 | map (Map.insert atm False) (ms (head s) (tail s)) 179 | 180 | -- | The unary negation operator. 181 | lneg :: FOL -> FOL 182 | lneg (Not y) = y 183 | lneg x 184 | | x == top = bot 185 | | x == bot = top 186 | | otherwise = Not x 187 | 188 | -- | The 'and' (conjunction) binary operator. 189 | land :: FOL -> FOL -> FOL 190 | land x y 191 | | x == top && y == top = top 192 | | x == bot || y == bot = bot 193 | | x == top = y 194 | | y == top = x 195 | | otherwise = BinOp And x y 196 | 197 | -- | The 'or' (inclusive disjunction) binary operator. 198 | lor :: FOL -> FOL -> FOL 199 | lor x y 200 | | x == top || y == top = top 201 | | x == bot = y 202 | | y == bot = x 203 | | otherwise = BinOp Or x y 204 | 205 | -- | The 'exclusive or' (exclusive disjunction) binary operator. 206 | lxor :: FOL -> FOL -> FOL 207 | lxor x y 208 | | y == bot = x 209 | | x == bot = y 210 | | y == top = lneg x 211 | | x == top = lneg y 212 | | otherwise = BinOp Xor x y 213 | 214 | -- | The 'implies' (implication) binary operator. 215 | limplies :: FOL -> FOL -> FOL 216 | limplies x y 217 | | x == top = y 218 | | x == bot = top 219 | | y == bot = lneg x 220 | | y == top = top 221 | | otherwise = BinOp Implies x y 222 | 223 | -- | The 'if and only if' (equivalence) binary operator. 224 | liff :: FOL -> FOL -> FOL 225 | liff x y 226 | | x == top = y 227 | | x == bot && y == bot = top 228 | | x == bot = lneg y 229 | | y == bot = lneg x 230 | | y == top = x 231 | | otherwise = BinOp Iff x y 232 | 233 | -- | Dispatch binary operators to their resolution function. 234 | binOperator :: BinT -> FOL -> FOL -> FOL 235 | binOperator b = case b of 236 | And -> land 237 | Or -> lor 238 | Xor -> lxor 239 | Implies -> limplies 240 | Iff -> liff 241 | 242 | -- | Simplify using Harris' algorithm. 243 | simplify :: FOL -> FOL 244 | simplify f = case f of 245 | Not x -> lneg $ sim1 $ simplify x 246 | BinOp b x y -> binOperator b (sim1 $ simplify x) (sim1 $ simplify y) 247 | Quantifier q v x -> Quantifier q v $ sim1 $ simplify x 248 | _ -> f 249 | where 250 | sim1 f' = case f' of 251 | Not x -> lneg $ sim1 x 252 | BinOp b x y -> binOperator b (sim1 x) (sim1 y) 253 | Quantifier q v x -> Quantifier q v $ sim1 x 254 | _ -> f' 255 | 256 | -- | Evaluates a formula given an assignment to atoms. If the assignment is 257 | -- incomplete, eval with evaluate as much as possible but might not reduce 258 | -- formula to top/bot. This function completely ignores Quantifiers. For 259 | -- functions that rely on Quantifiers, see the Sphinx.FOL first-order logic 260 | -- module. 261 | eval :: Map Predicate Bool -> FOL -> FOL 262 | eval ass = simplify . eval' 263 | where 264 | eval' f' = case f' of 265 | Atom a -> case Map.lookup a ass of 266 | Just True -> top 267 | Just False -> bot 268 | Nothing -> f' 269 | Not x -> lneg $ eval' x 270 | BinOp b x y -> BinOp b (eval' x) (eval' y) 271 | Quantifier _ _ x -> eval' x 272 | 273 | -- | Given an assignment to atoms, test whethers the formula evaluates to 'True' 274 | -- This functions ignores Quantifiers (if present, and they should not be there). 275 | satisfy :: Map Predicate Bool -> FOL -> Bool 276 | satisfy ass f = eval ass f == top 277 | 278 | -- | Given an assignment to atoms, test whethers the formula fails to evaluate 279 | -- to true. That is: unsatisfiable means it evaluates to bot or failed to 280 | -- evaluate to top/bot. 281 | unsatisfiable :: Map Predicate Bool -> FOL -> Bool 282 | unsatisfiable ass f = eval ass f /= top 283 | 284 | -- | Takes a formula, a list of assignments, and returns how many were true, 285 | -- false, or undefined (could not be reduced to either top or bot). 286 | numTrueFalse :: (Integral n) => FOL -> [Map Predicate Bool] -> (n, n, n) 287 | numTrueFalse f = 288 | foldl' 289 | (\(t, b, u) ass -> 290 | let v = eval ass f in 291 | if v == top then (t + 1, b, u) 292 | else if v == bot then (t, b + 1, u) 293 | else (t, b, u + 1)) 294 | (0, 0, 0) 295 | -------------------------------------------------------------------------------- /Akarui/FOL/Formula.hs: -------------------------------------------------------------------------------- 1 | -- | A generic formula used for various logics, most notably propositional logic 2 | -- and first-order logic (Sphinx.FOL module). The structure mostly follows 3 | -- Harrison (2009), however, binary connectives ('and', 'or', ...) are 4 | -- aggregated into a BinOp type. 5 | -- 6 | -- Reference: 7 | -- John Harrison, Handbook of Practical Logic and Automated Reasoning. 8 | -- Cambridge University Press, 2009. 9 | module Akarui.FOL.Formula where 10 | 11 | import System.Random 12 | import qualified Data.Map as Map 13 | import Data.Map (Map) 14 | import qualified Data.Set as Set 15 | import Data.Set (Set) 16 | import Data.List (nub) 17 | import Data.Monoid ((<>)) 18 | import Akarui.FOL.Symbols 19 | import qualified Akarui.Text as FT 20 | import qualified Data.Text as T 21 | import Akarui.FOL.BinT 22 | import Akarui.FOL.QuanT 23 | import Akarui.FOL.PrettyPrint 24 | 25 | -- | A formula with generic atoms. Propositional logic can easily be described 26 | -- with Formula String, and first-order logic is defined in module Akarui.FOL as 27 | -- Formula (Predicate t). 28 | data Formula a = 29 | -- | Generic atoms. 30 | Atom a 31 | -- | The unary negation type. 32 | | Not (Formula a) 33 | -- | Binary connectives. 34 | | BinOp BinT (Formula a) (Formula a) 35 | -- | Quantifier apply to a string (following Harrison 2009). 36 | | Quantifier QuanT T.Text (Formula a) -- Following Harris' here, but it might be smarter to put Quantifiers in FOL only. 37 | 38 | instance Eq a => Eq (Formula a) where 39 | Atom a0 == Atom a1 = a0 == a1 40 | Not x0 == Not x1 = x0 == x1 41 | BinOp b0 x0 y0 == BinOp b1 x1 y1 = 42 | b0 == b1 && x0 == x1 && y0 == y1 43 | Quantifier q0 v0 x0 == Quantifier q1 v1 x1 = 44 | q0 == q1 && v0 == v1 && x0 == x1 45 | _ == _ = False 46 | 47 | instance Ord a => Ord (Formula a) where 48 | Atom a0 `compare` Atom a1 = a0 `compare` a1 49 | Atom _ `compare` _ = GT 50 | _ `compare` Atom _ = LT 51 | Not f0 `compare` Not f1 = f0 `compare` f1 52 | Not _ `compare` _ = GT 53 | _ `compare` Not _ = LT 54 | BinOp b0 f00 f01 `compare` BinOp b1 f10 f11 = 55 | (b0 `compare` b1) <> (f00 `compare` f10) <> (f01 `compare` f11) 56 | BinOp{} `compare` Quantifier{} = GT 57 | Quantifier{} `compare` BinOp{} = LT 58 | Quantifier q0 v0 f0 `compare` Quantifier q1 v1 f1 = 59 | (q0 `compare` q1) <> (v0 `compare` v1) <> (f1 `compare` f0) 60 | 61 | -- | Prints the formula given a set of symbols ('Sphinx.Symbols.Symbols'). 62 | -- This function is built to support printing in symbolic, LaTeX, and ASCII 63 | -- formats. 64 | prettyPrintFm :: (PrettyPrint a) => Symbols -> Formula a -> T.Text 65 | prettyPrintFm s = FT.rmQuotes . buildStr (0 :: Int) 66 | where 67 | -- For negation and Quantifiers, add spaces after words but not symbols: 68 | notSpace = if T.toLower (symNot s) == "not" then " " else "" 69 | qualSpace = if T.toLower (symForall s) == "forall" then " " else "" 70 | suffixNot = symNot s == "'" 71 | 72 | -- Format prefixes: 73 | showNot b pr sym p = 74 | FT.surrIf b $ T.concat $ if suffixNot then [txt, sym] else [sym, notSpace, txt] 75 | where txt = buildStr (pr + 1) p 76 | 77 | -- Format infix operators: 78 | showInfix b pr sym p q = 79 | FT.surrIf b $ T.concat [buildStr (pr + 1) p, " ", sym, " ", buildStr pr q] 80 | 81 | -- Recursive function to build the string: 82 | buildStr pr fm = case fm of 83 | Atom a -> prettyPrint s a 84 | Not x -> showNot (pr > 12) 11 (symNot s) x 85 | BinOp And x y -> showInfix (pr > 10) 10 (symAnd s) x y 86 | BinOp Or x y -> showInfix (pr > 8) 8 (symOr s) x y 87 | BinOp Implies x y -> showInfix (pr > 6) 6 (symImplies s) x y 88 | BinOp Xor x y -> showInfix (pr > 4) 4 (symXor s) x y 89 | BinOp Iff x y -> showInfix (pr > 2) 2 (symIff s) x y 90 | Quantifier ForAll v x -> T.concat [symForall s, qualSpace, v, " ", buildStr pr x] 91 | Quantifier Exists v x -> T.concat [symExists s, qualSpace, v, " ", buildStr pr x] 92 | Quantifier Unique v x -> T.concat [symExists s, "!", qualSpace, v, " ", buildStr pr x] 93 | 94 | -- | Count the number of atoms (Top & Bottom are considered atoms). 95 | numAtoms :: Formula a -> Int 96 | numAtoms f = case f of 97 | Not x -> numAtoms x 98 | BinOp _ x y -> numAtoms x + numAtoms y 99 | Quantifier _ _ x -> numAtoms x 100 | _ -> 1 101 | 102 | -- | Gathers all atoms in the formula. 103 | atoms :: (Ord a) => Formula a -> Set a 104 | atoms = gat Set.empty 105 | where 106 | gat s fm = case fm of 107 | Atom z -> Set.insert z s 108 | Not x -> Set.union (atoms x) s 109 | BinOp _ x y -> Set.unions [atoms x, atoms y, s] 110 | Quantifier _ _ x -> Set.union (atoms x) s 111 | 112 | -- | Gathers all atoms in the formula in a list for atoms that do not support 113 | -- the Ord type class. 114 | atomsLs :: (Eq a) => Formula a -> [a] 115 | atomsLs = nub . gat 116 | where 117 | gat = gat' [] 118 | gat' l fm = case fm of 119 | Atom z -> z : l 120 | Not x -> l ++ gat x 121 | BinOp _ x y -> l ++ gat x ++ gat y 122 | Quantifier _ _ x -> l ++ gat x 123 | 124 | -- | Returns true if the formula has quantifiers 125 | hasQuan :: Formula a -> Bool 126 | hasQuan f = case f of 127 | Not x -> hasQuan x 128 | BinOp _ x y -> hasQuan x || hasQuan y 129 | Quantifier{} -> True 130 | _ -> False 131 | 132 | -- | Gathers the variables inside some type of quantifier. 133 | quanVars :: QuanT -> Formula a -> Set T.Text 134 | quanVars q = gat' 135 | where 136 | gat' = gat Set.empty 137 | gat s f' = case f' of 138 | Not x -> Set.union s (gat' x) 139 | BinOp _ x y -> Set.unions [s, gat' x, gat' y] 140 | Quantifier q' v x -> 141 | if q == q' then Set.union (Set.insert v s) (gat' x) 142 | else Set.union s (gat' x) 143 | _ -> Set.empty 144 | 145 | -- | Returns existentially quantified variables. 146 | exiquanVars :: Formula a -> Set T.Text 147 | exiquanVars = quanVars Exists 148 | 149 | -- | Returns universally quantifier variables. 150 | uniquanVars :: Formula a -> Set T.Text 151 | uniquanVars = quanVars ForAll 152 | 153 | -- | Randomly assigns all element of the set to either True or False with equal 154 | -- probability. It's a fair ass. 155 | randomFairAss :: (Ord a) => StdGen -> Set a -> Map a Bool 156 | randomFairAss g s = Map.fromList $ zip (Set.toList s) rs 157 | where rs = take (Set.size s) $ randoms g :: [Bool] 158 | 159 | -- | Gathers and assigns all atoms to a boolean given a seed value. 160 | randomFairAssF :: (Ord a) => StdGen -> Formula a -> Map a Bool 161 | randomFairAssF g f = randomFairAss g $ atoms f 162 | 163 | -- | Removes implications, equivalences, and exclusive disjunctions. 164 | coreOp :: Formula a -> Formula a 165 | coreOp f = case f of 166 | Not x -> Not $ coreOp x 167 | BinOp And x y -> BinOp And (coreOp x) (coreOp y) 168 | BinOp Or x y -> BinOp Or (coreOp x) (coreOp y) 169 | BinOp Xor x y -> BinOp Or (BinOp And (coreOp x) (Not $ coreOp y)) (BinOp And (Not $ coreOp x) (coreOp y)) 170 | BinOp Implies x y -> BinOp Or (Not $ coreOp x) (coreOp y) 171 | BinOp Iff x y -> BinOp Or (BinOp And (coreOp x) (coreOp y)) (BinOp And (Not $ coreOp x) (Not $ coreOp y)) 172 | Quantifier q v x -> Quantifier q v (coreOp x) 173 | _ -> f 174 | 175 | -- | Normal form. 176 | nnf :: Formula a -> Formula a 177 | nnf f = case coreOp f of 178 | BinOp And x y -> BinOp And (nnf x) (nnf y) 179 | BinOp Or x y -> BinOp Or (nnf x) (nnf y) 180 | Not (Not x) -> nnf x 181 | Not (BinOp And x y) -> BinOp Or (nnf (Not x)) (nnf (Not y)) 182 | Not (BinOp Or x y) -> BinOp And (nnf (Not x)) (nnf (Not y)) 183 | _ -> f 184 | -------------------------------------------------------------------------------- /Akarui/FOL/FormulaSet.hs: -------------------------------------------------------------------------------- 1 | -- | A knowledge base is a set of formulas. See MarkovLogic.hs for probabilistic 2 | -- knowledge bases. 3 | module Akarui.FOL.FormulaSet where 4 | 5 | import qualified Data.Set as Set 6 | import Data.Set (Set) 7 | import Data.Map (Map) 8 | import Akarui.FOL.Formula 9 | import Akarui.FOL.FOL 10 | import Akarui.FOL.Predicate 11 | import Akarui.FOL.Term 12 | import Akarui.Parser.FOL 13 | 14 | ---- | Pretty print a knowledge base. 15 | --showKB :: (Show a) => Set (Formula a) -> String 16 | --showKB = Set.foldr' (\k acc -> show k ++ "\n" ++ acc) "" 17 | 18 | -- | Gathers all atoms from a set of formulas. 19 | allAtoms :: (Ord a) => Set (Formula a) -> Set a 20 | allAtoms = Set.foldl' (\acc f -> Set.union acc (atoms f)) Set.empty 21 | 22 | -- | Get all groundings from a first-order logic knowledge base. 23 | allGroundings :: [Term] -> Set FOL -> Set FOL 24 | allGroundings ts = 25 | Set.foldr' (\gs acc -> Set.union (groundings ts gs) acc) Set.empty 26 | 27 | -- | Gathers all the predicates of a markov logic network in a set. 28 | allPredicates :: Set FOL -> Set Predicate 29 | allPredicates = Set.foldr' (\k acc -> Set.union (atoms k) acc) Set.empty 30 | 31 | -- | Tests if a valuation satisfied a set of formulas. 32 | satisfiesAll :: Map Predicate Bool -> Set FOL -> Bool 33 | satisfiesAll ass = Set.foldl' (\t f -> t && satisfy ass f) True 34 | 35 | -- | Filters the formula that are satisfied by a valuation. 36 | filterSatisfied :: Map Predicate Bool -> Set FOL -> Set FOL 37 | filterSatisfied ass = Set.filter (satisfy ass) 38 | 39 | -- | Filters the formula that are not satisfied by a valuation. 40 | filterUnsatisfied :: Map Predicate Bool -> Set FOL -> Set FOL 41 | filterUnsatisfied ass = Set.filter (unsatisfiable ass) 42 | 43 | -- | Number of satisfied formulas for a given valuation. 44 | numSatisfied :: Map Predicate Bool -> Set FOL -> Int 45 | numSatisfied ass = Set.foldl' (\n f -> n + if satisfy ass f then 1 else 0) 0 46 | 47 | -- | All valuations that are true for a set of formulas. 48 | trueValuations :: Set FOL -> [Map Predicate Bool] 49 | trueValuations fs = filter (`satisfiesAll` fs) (allAss fs) 50 | 51 | -- | Builds a knowledge base from a list of strings. If the parser fails 52 | -- to parse a formula, it is ignored. 53 | fromStrings :: [String] -> Set FOL 54 | fromStrings = foldr 55 | (\k acc -> 56 | case parseFOL k of 57 | Left _ -> acc 58 | Right f -> Set.insert f acc) 59 | Set.empty 60 | -------------------------------------------------------------------------------- /Akarui/FOL/KnowledgeBase.hs: -------------------------------------------------------------------------------- 1 | -- | A knowledge base is a set of formulas. Will replace KB. 2 | module Akarui.FOL.KnowledgeBase where 3 | 4 | import qualified Data.Set as Set 5 | import Data.Set (Set) 6 | import qualified Data.Map as Map 7 | import Data.Map (Map) 8 | import Akarui.FOL.Formula (allAss, satisfy) 9 | import Akarui.FOL.FOL 10 | --import Akarui.Predicate 11 | import Akarui.FOL.RuleType 12 | import Akarui.FOL.Domain 13 | import Akarui.Utils (allKeys) 14 | 15 | -- | A knowledge base is a set of formulas. 16 | data KnowledgeBase = KnowledgeBase 17 | -- | All formulas with their types. 18 | { formulas :: Map (FOL String) RuleType 19 | -- | Set of domains used in the knowledge base. 20 | , domains :: Set (Domain) 21 | -- | Maps the predicate (by name) to their domain. 22 | , predicates :: Map String [Domain] 23 | } 24 | 25 | -- | Checks by brute force if a knowledgebase entails a formula. 26 | (|=) :: KnowledgeBase -> FOL String -> Bool 27 | (|=) k f = all (\a -> not (allKeys (satisfy a) (formulas k)) || satisfy a f) ass 28 | where 29 | ass = allAss $ Set.insert f $ Map.keysSet $ formulas k 30 | -------------------------------------------------------------------------------- /Akarui/FOL/LiteralSign.hs: -------------------------------------------------------------------------------- 1 | -- | Defines a type class for clausal forms. 2 | module Akarui.FOL.LiteralSign where 3 | 4 | import Akarui.ShowTxt 5 | import Akarui.FOL.Symbols 6 | import Akarui.FOL.PrettyPrint 7 | 8 | data LiteralSign = Positive | Negative 9 | deriving (Eq, Ord, Show, Read) 10 | 11 | instance ShowTxt LiteralSign where 12 | showTxt Positive = "Positive" 13 | showTxt Negative = "Negative" 14 | 15 | instance PrettyPrint LiteralSign where 16 | prettyPrint _ Positive = "" 17 | prettyPrint s Negative = symNot s 18 | -------------------------------------------------------------------------------- /Akarui/FOL/MarkovLogic.hs: -------------------------------------------------------------------------------- 1 | -- | Types and algorithms for Markov logic networks. The module has quite a 2 | -- few 'fromStrings' methods that take strings and parse them into data 3 | -- structure to make it easier to play with Markov logic in the repl. 4 | -- 5 | -- For Markov logic, data is often represented with a Set (Predicate a, Bool). 6 | -- This is prefered to Map since it simplifies queries such as 7 | -- "P(Cancer(Bob) | !Cancer(Bob))", where a map would not allow these two 8 | -- different predicate -> value mappings. 9 | module Akarui.FOL.MarkovLogic 10 | ( MLN(..) 11 | , tell 12 | , allPredicates 13 | , allGroundings 14 | , allWGroundings 15 | , fromStrings 16 | , groundNetwork 17 | , factors 18 | , ask 19 | , marginal 20 | , joint 21 | , conditional 22 | , constructNetwork 23 | ) where 24 | 25 | import qualified Data.Text as T 26 | import qualified Data.Map as Map 27 | import Data.Map (Map) 28 | import qualified Data.Set as Set 29 | import Data.Set (Set) 30 | import Data.List (partition) 31 | import Control.Applicative ((<|>)) 32 | import qualified Akarui.FOL.FOL as FOL 33 | import Akarui.FOL.FOL (FOL) 34 | import qualified Akarui.FOL.Formula as F 35 | import Akarui.FOL.Predicate 36 | import Akarui.FOL.Term 37 | import Akarui.FOL.Symbols 38 | import Akarui.Network 39 | import Akarui.ShowTxt 40 | import qualified Akarui.FOL.FormulaSet as FS 41 | import Akarui.Parser.Probability 42 | import Akarui.Parser.FOL 43 | 44 | -- | A Markov logic network is a set of first-order logical formulas associated 45 | -- with a weight. 46 | 47 | data MLN = MLN { network :: Map FOL Double } 48 | 49 | instance Show MLN where 50 | show = T.unpack . fmtMLN 51 | 52 | instance ShowTxt MLN where 53 | showTxt = fmtMLN 54 | 55 | -- | Prints a Markov logic network. 56 | fmtMLN :: MLN -> T.Text 57 | fmtMLN (MLN m) = 58 | Map.foldrWithKey 59 | (\k v acc -> T.concat [fmtWFormula symbolic k v, "\n", acc]) "" m 60 | 61 | -- | Prints a weighted formula. 62 | fmtWFormula :: Symbols -> FOL -> Double -> T.Text 63 | fmtWFormula s f w = T.concat [F.prettyPrintFm s f, ", ", T.pack $ show w, "."] 64 | 65 | -- | Adds a formula to the markov logic network using the parser. If the parser 66 | -- fails, the function returns the MLN unmodified. 67 | tell :: String -> MLN -> MLN 68 | tell s mln@(MLN m) = case parseWFOL s of 69 | Left _ -> mln 70 | Right (f, w) -> MLN $ Map.insert f w m 71 | 72 | -- | Gathers all the predicates of a markov logic network in a set. 73 | allPredicates :: MLN -> Set Predicate 74 | allPredicates (MLN m) = 75 | Map.foldrWithKey (\k _ acc -> Set.union (F.atoms k) acc) Set.empty m 76 | 77 | -- | Get all groundings from a Markov logic network. 78 | allGroundings :: [Term] -> MLN -> Set FOL 79 | allGroundings ts (MLN m) = FS.allGroundings ts $ Map.keysSet m 80 | 81 | -- | Get all groundings from a Markov logic network, keeping the weights 82 | -- assigned to the original formula in the Markov logic network. 83 | allWGroundings :: [Term] -> MLN -> MLN 84 | allWGroundings ts (MLN m) = 85 | MLN $ Map.foldrWithKey 86 | (\k v a -> Set.foldr' (\k' a' -> Map.insert k' v a') a (FOL.groundings ts k)) 87 | Map.empty 88 | m 89 | 90 | -- | Builds a ground network for Markov logic. 91 | groundNetwork :: [Term] -> MLN -> UNetwork Predicate 92 | groundNetwork ts (MLN m) = Set.foldr' (\p acc -> Map.insert p (mb p) acc) Map.empty ps 93 | where 94 | -- All groundings from all formulas in the knowledge base: 95 | gs = Set.foldr' (\g acc -> Set.union (FOL.groundings ts g) acc) Set.empty (Map.keysSet m) 96 | -- All the predicates 97 | ps = FS.allPredicates gs 98 | -- The Markov blanket of predicate 'p', that is: all its neighbours. 99 | mb p = Set.delete p $ FS.allPredicates $ Set.filter (FOL.hasPred p) gs 100 | 101 | -- | Returns all the factors in the MLN. Instead of mappings sets of predicates 102 | -- to weights, this function maps them to the formula (the MLN provides the 103 | -- weight). 104 | factors :: [Term] -> MLN -> Map (Set Predicate) FOL 105 | factors ts (MLN m) = fs 106 | where 107 | -- All groundings mapped to their original formula 108 | gs = Set.foldr' (\k a -> Set.foldr' (`Map.insert` k) a (FOL.groundings ts k)) Map.empty (Map.keysSet m) 109 | -- Separate the formula in sets of predicates: 110 | fs = Map.foldrWithKey (\k v a -> Map.insert (F.atoms k) v a) Map.empty gs 111 | 112 | -- | All possible assignments to the predicates in the network. 113 | allAss :: 114 | [Term] -> 115 | MLN -> 116 | [Map Predicate Bool] 117 | allAss ts mln = FOL.allAss $ allGroundings ts mln 118 | 119 | -- | Helper function to facilitate answering conditional & joint probability 120 | -- queries from the console. See 'Sphinx.Parser.parseCondQuery' and 121 | -- 'Sphinx.Parser.parseJointQuery' to understand what kind of strings can 122 | -- be parsed. 123 | ask 124 | :: MLN -- ^ A Markov logic network. 125 | -> [T.Text] -- ^ A list of constants to ground the Markov logic network. 126 | -> String -- ^ A query to be parsed by 'Sphinx.Parser.parseCondQuery' or 'Sphinx.Parser.parseJointQuery'. 127 | -> Maybe Double -- ^ Either a double in [0.0, 1.0] or Nothing if the parsers fail. 128 | ask mln terms query = pq <|> pj 129 | where 130 | ts = map Constant terms 131 | pq = case parseCondQuery query of 132 | Left _ -> Nothing; Right (q, c) -> Just $ conditional mln ts q c 133 | pj = case parseJointQuery query of 134 | Left _ -> Nothing; Right q -> Just $ joint mln ts q 135 | 136 | -- | Direct method of computing joint probabilities for Markov logic (does not 137 | -- scale!). 138 | partitionAss 139 | :: Set (Predicate, Bool) -- ^ The joint query. 140 | -> [Map Predicate Bool] -- ^ All possiblement assignments. 141 | -> ([Map Predicate Bool], [Map Predicate Bool]) -- ^ A probability in [0.0, 1.0] 142 | partitionAss query = partition valid 143 | where 144 | -- Check if an assignment fits the query: 145 | valid ass = Set.foldr' (\(k, v) acc -> acc && case Map.lookup k ass of Just b -> v == b; _ -> False) True query 146 | 147 | -- | Direct method of computing joint probabilities for Markov logic (does not 148 | -- scale!). 149 | joint 150 | :: MLN -- ^ The Markov logic network. 151 | -> [Term] -- ^ List of constants to ground the Markov logic network. 152 | -> Set (Predicate, Bool) -- ^ An set of assignments. The reason... 153 | -> Double -- ^ A probability in [0.0, 1.0] 154 | joint mln ts query = vq / z 155 | where 156 | vq = sum $ map evalNet toEval 157 | vo = sum $ map evalNet others 158 | z = vq + vo 159 | -- All possible assignments 160 | allass = allAss ts fs 161 | -- Assignments to evaluate: 162 | (toEval, others) = partitionAss query allass 163 | -- The formula (the factors) to evaluate 164 | fs = allWGroundings ts mln 165 | -- Value of the network for a given assignment. 166 | evalNet ass' = exp $ Map.foldrWithKey (\f w a -> val f w ass' + a) 0.0 (network fs) 167 | -- Values of a factor 168 | val f w ass' = let v = FOL.eval ass' f in 169 | if v == FOL.top then w 170 | else if v == FOL.bot then 0.0 171 | else error ("Eval failed for " ++ show v ++ " given " ++ show ass') 172 | 173 | -- | Direct method of computing marginal probabilities for Markov logic (does 174 | -- not scale!). 175 | marginal 176 | :: MLN -- ^ The Markov logic network. 177 | -> [Term] -- ^ List of constants to ground the Markov logic network. 178 | -> Predicate-- ^ An assignment to all predicates in the Markov logic network. 179 | -> Bool -- ^ Truth value of the predicate. 180 | -> Double -- ^ A probability in [0.0, 1.0]Alicia Malone 181 | marginal mln ts p b = joint mln ts $ Set.fromList [(p, b)] 182 | 183 | -- | Direct method of computing conditional probabilities for Markov logic (does 184 | -- not scale!). 185 | conditional 186 | :: MLN -- ^ The Markov logic network. 187 | -> [Term] -- ^ List of constants to ground the Markov logic network. 188 | -> Set (Predicate, Bool) -- ^ An set of assignments for the query. 189 | -> Set (Predicate, Bool) -- ^ Conditions. 190 | -> Double -- ^ A probability in [0.0, 1.0] 191 | conditional mln ts query cond = vnum / vden 192 | where 193 | vnum = sum $ map evalNet numerator 194 | vden = sum $ map evalNet denom 195 | -- All possible assignments 196 | allass = allAss ts fs 197 | -- Assignments to evaluate: 198 | (numerator, _) = partitionAss (Set.union query cond) allass 199 | (denom, _ ) = partitionAss cond allass 200 | -- The formula (the factors) to evaluate 201 | fs = allWGroundings ts mln 202 | -- Value of the network for a given assignment. 203 | evalNet ass' = exp $ Map.foldrWithKey (\f w a -> val f w ass' + a) 0.0 (network fs) 204 | -- Values of a factor 205 | val f w ass' = let v = FOL.eval ass' f in 206 | if v == FOL.top then w 207 | else if v == FOL.bot then 0.0 208 | else error ("Eval failed for " ++ show v ++ " given " ++ show ass') 209 | 210 | -- | Algorithm to construct a network for Markov logic network inference. 211 | -- 212 | -- Reference: 213 | -- P Domingos and D Lowd, Markov Logic: An Interface Layer for Artificial 214 | -- Intelligence, 2009, Morgan & Claypool. p. 26. 215 | constructNetwork :: Set Predicate -> [Predicate] -> [Term] -> MLN -> UNetwork Predicate 216 | constructNetwork query evidence ts (MLN m) = Set.foldr' (\p acc -> Map.insert p (mb p) acc) Map.empty ps 217 | where 218 | -- All groundings from all formulas in the knowledge base: 219 | gs = Set.foldr' (\g acc -> Set.union (FOL.groundings ts g) acc) Set.empty (Map.keysSet m) 220 | -- Predicates in the network 221 | ps = step query query 222 | -- The Markov blanket of predicate 'p', that is: all its neighbours. 223 | mb p = Set.delete p $ FS.allPredicates $ Set.filter (FOL.hasPred p) gs 224 | -- One step of the algorithm 225 | step f g 226 | | Set.null f = g 227 | | Set.findMin f `elem` evidence = step (Set.deleteMin f) g 228 | | otherwise = 229 | let mbq = mb $ Set.findMin f in 230 | step 231 | (Set.union (Set.deleteMin f) (Set.intersection mbq g)) 232 | (Set.union g mbq) 233 | 234 | -- | Builds a weighted knowledge base from a list of strings. If 235 | -- 'Sphinx.Parser.parseWFOL' fails to parse a formula, it is ignored. 236 | fromStrings 237 | :: [String] -- ^ A set of string, each of which is a first-order logic formula with a weight. Is being parsed by 'Sphinx.Parser.parseWFOL'. 238 | -> MLN -- ^ A Markov logic network. 239 | fromStrings s = MLN $ foldr 240 | (\k acc -> 241 | case parseWFOL k of 242 | Left _ -> acc 243 | Right (f, w) -> Map.insert f w acc) 244 | Map.empty 245 | s 246 | -------------------------------------------------------------------------------- /Akarui/FOL/Predicate.hs: -------------------------------------------------------------------------------- 1 | -- | Type and functions for predicates: the atoms of first-order logic. 2 | module Akarui.FOL.Predicate where 3 | 4 | import qualified Akarui.Text as FT 5 | import Akarui.FOL.Term (Term) 6 | import qualified Akarui.FOL.Term as Term 7 | import qualified Data.Text as T 8 | import Data.List (foldl') 9 | import Data.Set (Set) 10 | import qualified Data.Set as Set 11 | import Akarui.ShowTxt 12 | import Akarui.FOL.PrettyPrint 13 | import Akarui.FOL.Symbols 14 | 15 | -- | Predicates are atoms (thus they evaluate to true/false) mapping a list 16 | -- of terms (objects) to a truth value. 17 | data Predicate = 18 | -- | Builds a predicate with a string and a list of terms. 19 | Predicate T.Text [Term] 20 | 21 | -- | True (Top) predicate. 22 | topPredicate :: Predicate 23 | topPredicate = Predicate "Top" [] 24 | 25 | -- | False (Bottom, Bot) predicate. 26 | botPredicate :: Predicate 27 | botPredicate = Predicate "Bot" [] 28 | 29 | instance Eq Predicate where 30 | (Predicate n0 ts0) == (Predicate n1 ts1) = 31 | n0 == n1 && length ts0 == length ts1 && all (uncurry (==)) (zip ts0 ts1) 32 | 33 | instance Ord Predicate where 34 | (Predicate n0 ts0) `compare` (Predicate n1 ts1) = Term.compareFun n0 ts0 n1 ts1 35 | 36 | instance Show Predicate where 37 | show = T.unpack . showTxt 38 | 39 | instance ShowTxt Predicate where 40 | showTxt = fmtPredicate False 41 | 42 | instance PrettyPrint Predicate where 43 | prettyPrint s p 44 | | p == topPredicate = symTop s 45 | | p == botPredicate = symBottom s 46 | | otherwise = fmtPredicate False p 47 | 48 | -- | Format predicates. 49 | fmtPredicate 50 | :: Bool -- ^ If true, will always show parens even for predicates without arguments. 51 | -> Predicate -- ^ The predicate to format. 52 | -> T.Text -- ^ Resulting text. 53 | fmtPredicate parens (Predicate n ts) = 54 | T.concat [n, if null ts then noterms else T.concat ["(", terms, ")"]] 55 | where terms = FT.mkString $ map showTxt ts 56 | noterms = if parens then "()" else "" 57 | 58 | -- | Gathers the constants in a predicate. 59 | constants :: Predicate -> Set T.Text 60 | constants (Predicate _ ts) = 61 | foldl' (\a t -> Set.union (Term.constants t) a) Set.empty ts 62 | 63 | -- | Shows the internal structure of the predicate. 64 | showStruct :: Predicate -> T.Text 65 | showStruct (Predicate n ts) = 66 | T.concat ["Predicate ", n, " [", if null ts then "" else terms, "]"] 67 | where terms = FT.mkString (map Term.showStruct ts) 68 | 69 | -- | Tests if the term is 'grounded', i.e. if it has no variables. 70 | ground :: Predicate -> Bool 71 | ground (Predicate _ ts) = all Term.ground ts 72 | 73 | -- | Tests if the predicate has a certain variable. 74 | hasVar :: T.Text -> Predicate -> Bool 75 | hasVar v (Predicate _ ts) = any (Term.hasVar v) ts 76 | 77 | -- | Replace a term with another. 78 | substitute :: Term -> Term -> Predicate -> Predicate 79 | substitute t0 t1 (Predicate n ts) = Predicate n $ map (Term.substitute t0 t1) ts 80 | -------------------------------------------------------------------------------- /Akarui/FOL/PrettyPrint.hs: -------------------------------------------------------------------------------- 1 | module Akarui.FOL.PrettyPrint 2 | ( PrettyPrint(..) 3 | ) where 4 | 5 | import qualified Data.Text as T 6 | import Akarui.FOL.Symbols 7 | 8 | class PrettyPrint t where 9 | prettyPrint :: Symbols -> t -> T.Text 10 | -------------------------------------------------------------------------------- /Akarui/FOL/QuanT.hs: -------------------------------------------------------------------------------- 1 | module Akarui.FOL.QuanT where 2 | 3 | import Akarui.ShowTxt 4 | 5 | -- | Supported quantifiers for predicate logics. 6 | data QuanT = 7 | -- | Univeral quantifier. 8 | ForAll 9 | -- | Existential quantifier. 10 | | Exists 11 | -- | Unique quantifier. 12 | | Unique 13 | deriving (Eq, Ord, Show) 14 | 15 | instance ShowTxt QuanT where 16 | showTxt ForAll = "ForAll" 17 | showTxt Exists = "Exists" 18 | showTxt Unique = "Unique" 19 | -------------------------------------------------------------------------------- /Akarui/FOL/RuleType.hs: -------------------------------------------------------------------------------- 1 | -- | A knowledge base is a set of formulas. Will replace KB. 2 | module Akarui.FOL.RuleType where 3 | 4 | -- | Supported types of logic formulas. 5 | data RuleType = 6 | -- | Probabilistic rule, those with a weight (not always a probability). 7 | Probabilistic Double 8 | -- | Hard rules, those expected to be true all the time. 9 | | Hard 10 | -- | Unknown rule type. 11 | | Unknown 12 | 13 | instance Show RuleType where 14 | show (Probabilistic p) = " ," ++ show p ++ "." 15 | show Hard = "." 16 | show Unknown = "?" 17 | -------------------------------------------------------------------------------- /Akarui/FOL/SetClause.hs: -------------------------------------------------------------------------------- 1 | -- | Type and functions for first-order predicate logic. 2 | module Akarui.FOL.SetClause where 3 | 4 | import qualified Data.Set as Set 5 | import Data.Set (Set) 6 | import Data.List (foldl') 7 | import Akarui.FOL.Clausal 8 | import Akarui.FOL.Formula 9 | import Akarui.FOL.LiteralSign 10 | import Akarui.Utils (sfoldr1') 11 | import Akarui.FOL.Parser 12 | import Akarui.FOL.Predicate 13 | import Akarui.FOL.ParseProbability 14 | import Text.Parsec 15 | import Text.Parsec.String (Parser) 16 | 17 | -- | A clause is a disjunction of positive and negative prediates. 18 | data SetClause t = SetClause (Set t) (Set t) 19 | 20 | -- | Transforms into a more human-readable formula. 21 | toFormula :: (Ord t) => SetClause t -> Formula t 22 | toFormula (SetClause ps ns) 23 | | Set.null ps = sfoldr1' (BinOp Or) $ Set.map (Not . Atom) ns 24 | | Set.null ns = sfoldr1' (BinOp Or) $ Set.map Atom ps 25 | | otherwise = 26 | BinOp Implies 27 | (sfoldr1' (BinOp And) $ Set.map Atom ns) 28 | (sfoldr1' (BinOp Or) $ Set.map Atom ps) 29 | 30 | -- TODO:: 'find' and 'member' should be in a type class. 31 | 32 | -- | Returns either the sign of the literal if found, or Nothing. 33 | find :: (Ord t) => t -> SetClause t -> Maybe LiteralSign 34 | find e (SetClause ps ns) 35 | | Set.member e ps = Just Positive 36 | | Set.member e ns = Just Negative 37 | | otherwise = Nothing 38 | 39 | -- | Checks if a literal is in the clause. 40 | member :: (Ord t) => t -> SetClause t -> Bool 41 | member e (SetClause ps ns) = Set.member e ps || Set.member e ns 42 | 43 | instance Clausal (SetClause t) where 44 | numPositive (SetClause ps _) = Set.size ps 45 | numNegative (SetClause _ ns) = Set.size ns 46 | 47 | -- | Parse a clause (a disjunction of positive and negative literals). 48 | -- 49 | -- @ 50 | -- !Women(p) or Vegetarian(p) 51 | -- @ 52 | parseClause :: String -> Either ParseError (SetClause (Predicate String)) 53 | parseClause = parse (contents parseCl) "" 54 | 55 | -- | Parse a weighted clause (a disjunction of positive and negative literals). 56 | -- 57 | -- @ 58 | -- 1.5 !Women(p) or Vegetarian(p) 59 | -- !Women(p) or Vegetarian(p) 1.5 60 | -- @ 61 | parseWClause :: String -> Either ParseError (SetClause (Predicate String), Double) 62 | parseWClause = parse (contents parseWeightedClause) "" 63 | 64 | 65 | parseCl :: Parser (SetClause (Predicate String)) 66 | parseCl = do 67 | optional $ reservedOp "(" 68 | ls <- parsePredTruth `sepBy` (symbol "v" <|> symbol "or" <|> symbol "∨" <|> symbol "|") 69 | optional $ reservedOp ")" 70 | let ps = foldl' (\a (p, b) -> if b then Set.insert p a else a) Set.empty ls 71 | ns = foldl' (\a (p, b) -> if not b then Set.insert p a else a) Set.empty ls in 72 | return $ SetClause ps ns 73 | 74 | -- Parse a weight and then a first-order logic formula 75 | parseLeftWC :: Parser (SetClause (Predicate String), Double) 76 | parseLeftWC = do 77 | n <- float 78 | c <- parseCl 79 | return (c, n) 80 | 81 | -- Parse a first-order logic formula and then a weight 82 | parseRightWC :: Parser (SetClause (Predicate String), Double) 83 | parseRightWC = do 84 | c <- parseCl 85 | n <- float 86 | return (c, n) 87 | 88 | parseWeightedClause :: Parser (SetClause (Predicate String), Double) 89 | parseWeightedClause = try parseLeftWC <|> parseRightWC 90 | -------------------------------------------------------------------------------- /Akarui/FOL/Symbols.hs: -------------------------------------------------------------------------------- 1 | -- | Different sets of symbols used to print logic formulas. 2 | module Akarui.FOL.Symbols where 3 | 4 | import qualified Data.Text as T 5 | 6 | -- | Sets of symbols to print logic formulas. 7 | data Symbols = Symbols 8 | { symAnd :: T.Text 9 | , symOr :: T.Text 10 | , symXor :: T.Text 11 | , symImplies :: T.Text 12 | , symIff :: T.Text 13 | , symNot :: T.Text 14 | , symTop :: T.Text 15 | , symBottom :: T.Text 16 | , symForall :: T.Text 17 | , symExists :: T.Text 18 | , symNotEqual :: T.Text 19 | } deriving (Show) 20 | 21 | human, long, shouting, semisymbolic, symbolic, laTeX, ascii, setnotation :: Symbols 22 | 23 | -- | A standard mix of symbols and strings. 24 | human = Symbols "and" "or" "xor" "=>" "iff" "!" "true" "false" "Forall" 25 | "Exists" "!=" 26 | 27 | -- | A representation using standard set notation. 28 | setnotation = Symbols "∩" "∪" "⊕" "⊃" "↔" "'" "true" "false" "Forall" 29 | "Exists" "!=" 30 | 31 | -- | A representation using words instead of symbols (blasphemy!). 32 | long = Symbols "and" "or" "xor" "implies" "iff" "not" "true" "false" "Forall" 33 | "Exists" "!=" 34 | 35 | -- | USING WORDS INSTEAD OF SYMBOLS AND BEING LOUD ABOUT IT! 36 | shouting = Symbols "AND" "OR" "XOR" "IMPLIES" "IFF" "NOT" "TRUE" "FALSE" 37 | "FORALL" "EXISTS" "!=" 38 | 39 | -- | Mostly symbolc representation, except for true and false (top and bottom). 40 | semisymbolic = Symbols "∧" "∨" "⊕" "⇒" "⇔" "¬" "T" "F" "∀" "∃" "!=" 41 | 42 | -- | Purely symbolic representation. 43 | symbolic = Symbols "∧" "∨" "⊕" "⇒" "⇔" "¬" "⊤" "⊥" "∀" "∃" "!=" 44 | 45 | -- | LaTeX codes for logic symbols. 46 | laTeX = Symbols "\\land" "\\lor" "\\oplus" "\\Rightarrow" "\\iff" "\\lnot" "T" 47 | "F" "\\forall" "\\exists" "\\neq" 48 | 49 | -- | An ASCII representation inspired by Harris' automated reasoning book. 50 | ascii = Symbols "/\\" "\\/" "(+)" "=>" "<=>" "~" "true" "false" "for all" 51 | "exists" "!=" 52 | -------------------------------------------------------------------------------- /Akarui/FOL/Term.hs: -------------------------------------------------------------------------------- 1 | -- | Type and functions for terms: the objects of first-order logic. 2 | module Akarui.FOL.Term where 3 | 4 | import Data.Set (Set) 5 | import qualified Data.Set as Set 6 | import Data.List (foldl') 7 | import qualified Data.Text as T 8 | import Data.Monoid ((<>), mconcat) 9 | import qualified Akarui.Text as FT 10 | import Akarui.ShowTxt 11 | 12 | -- | A term represents an object. Terms are not atoms, they are found in 13 | -- predicates in first-order logic. 14 | -- 15 | -- Warning: for Term String, several algorithms assume the string of variables 16 | -- start with a lowercase character, while constants start with an uppercase 17 | -- character. For example, the parser uses the case of the first character to 18 | -- distinguish variables from constants. 19 | data Term = 20 | -- | Variables range over objects. For example the variable x might be a 21 | -- number, t could be a city, etc. 22 | Variable T.Text 23 | -- | Constants represent actual objects: the number 0, Kyoto, Quebec City, 24 | -- Aristotle could all be constants. 25 | | Constant T.Text 26 | -- | Functions map objects to objects. The function 'Add' maps numbers to 27 | -- a number, the function "CapitalOf" maps a city to a country, etc. 28 | | Function T.Text [Term] 29 | 30 | instance Eq Term where 31 | (Variable t0) == (Variable t1) = t0 == t1 32 | (Constant t0) == (Constant t1) = t0 == t1 33 | (Function n0 ts0) == 34 | (Function n1 ts1) = n0 == n1 && all (uncurry (==)) (zip ts0 ts1) 35 | _ == _ = False 36 | 37 | instance Ord Term where 38 | (Constant t0) `compare` (Constant t1) = t0 `compare` t1 39 | (Constant t0) `compare` (Variable t1) = t0 `compare` t1 40 | (Constant _) `compare` (Function _ _) = LT 41 | (Variable t0) `compare` (Variable t1) = t0 `compare` t1 42 | (Variable t0) `compare` (Constant t1) = t0 `compare` t1 43 | (Variable _) `compare` (Function _ _) = LT 44 | (Function n0 ts0) `compare` (Function n1 ts1) = compareFun n0 ts0 n1 ts1 45 | (Function _ _) `compare` _ = GT 46 | 47 | instance Show Term where 48 | show = T.unpack . showTxt 49 | -- show = T.unpack . FT.rmQuotes . textTerm 50 | 51 | instance ShowTxt Term where 52 | showTxt t = case t of 53 | Variable x -> x 54 | Constant x -> x 55 | Function n ts -> T.concat [n, "(", if null ts then "" else terms, ")"] 56 | where terms = FT.mkString $ map showTxt ts 57 | 58 | -- | Returns the number of variables in the term. 59 | numVars :: (Num n) => Term -> n 60 | numVars t = case t of 61 | Variable _ -> 1 62 | Constant _ -> 0 63 | Function _ ts -> foldl' (\acc trm -> acc + numVars trm) 0 ts 64 | 65 | -- | Returns the number of constants in the term. 66 | numCons :: (Num n) => Term -> n 67 | numCons t = case t of 68 | Variable _ -> 0 69 | Constant _ -> 1 70 | Function _ ts -> foldl' (\acc trm -> acc + numCons trm) 0 ts 71 | 72 | -- | Returns the number of functions in the term. 73 | numFuns :: (Num n) => Term -> n 74 | numFuns t = case t of 75 | Variable _ -> 0 76 | Constant _ -> 0 77 | Function _ ts -> 1 + foldl' (\acc trm -> acc + numFuns trm) 0 ts 78 | 79 | -- | Substitute a term for another. 80 | substitute :: Term -> Term -> Term -> Term 81 | substitute old new (Function n ts) = 82 | if old == Function n ts then new 83 | else Function n $ map (substitute old new) ts 84 | substitute old new t0 = if t0 == old then new else t0 85 | 86 | -- | Shows the internal structure of the term. This is particularly useful 87 | -- to distinguish variables from constants in Term String, where otherwise 88 | -- it would be impossible to tell them apart. 89 | showStruct :: Term -> T.Text 90 | showStruct t = case t of 91 | Variable x -> T.concat ["Variable (", x, ")"] 92 | Constant x -> T.concat ["Constant (", x, ")"] 93 | Function n ts -> 94 | T.concat ["Function ", n, " [", if null ts then "" else terms, "]"] 95 | where terms = FT.mkString (map showStruct ts) 96 | 97 | -- | Get all the constants from a term. 98 | constants :: Term -> Set T.Text 99 | constants = gat 100 | where 101 | gat = gather Set.empty 102 | gather s t' = case t' of 103 | Variable _ -> s 104 | Constant t'' -> Set.insert t'' s 105 | Function _ ts -> foldl' (\a t'' -> Set.union (gat t'') a) s ts 106 | 107 | -- | Tests if the term is 'grounded', i.e. if it has no variables. 108 | ground :: Term -> Bool 109 | ground t = case t of 110 | Variable _ -> False 111 | Constant _ -> True 112 | Function _ ts -> all ground ts 113 | 114 | -- | Tests if the term has a specific variable. 115 | hasVar :: T.Text -> Term -> Bool 116 | hasVar v t = case t of 117 | Variable x -> v == x 118 | Constant _ -> False 119 | Function _ ts -> any (hasVar v) ts 120 | 121 | -- | Used to compare names and arguments for functions and predicate. First 122 | -- look at the name, then the number of arguments, and finally for functions 123 | -- with the same name and argument, look at the first term that differ. 124 | compareFun :: T.Text -> [Term] -> T.Text -> [Term] -> Ordering 125 | compareFun n0 ts0 n1 ts1 = 126 | (n0 `compare` n1) 127 | <> (length ts0 `compare` length ts1) 128 | <> mconcat (zipWith compare ts0 ts1) 129 | -------------------------------------------------------------------------------- /Akarui/FOL/WalkSAT.hs: -------------------------------------------------------------------------------- 1 | -- | WalkSat algorithms to find the most likely assignments to atoms. 2 | module Akarui.FOL.WalkSAT 3 | ( walkSAT 4 | , maxWalkSAT 5 | ) where 6 | 7 | import Data.Map (Map) 8 | import qualified Data.Map as Map 9 | import Data.Set (Set) 10 | import Data.List (foldl') 11 | import qualified Data.Set as Set 12 | import System.Random 13 | import Akarui.FOL.Formula 14 | import Akarui.FOL.Predicate 15 | import Akarui.FOL.FOL 16 | import Akarui.FOL.FormulaSet 17 | 18 | -- | The WalkSAT algorithm as descripted in Russell and Norvig 19 | -- /Artificial Intelligence 3rd edition/, p 263. 20 | walkSAT 21 | :: Set FOL -- ^ A set of clauses. 22 | -> Double -- ^ Probability of flipping. 23 | -> Int -- ^ Max number of flips before giving up. 24 | -> Int -- ^ Seed for the random number generator. 25 | -> Maybe (Map Predicate Bool) -- ^ A (possible) assignment to atoms that satisfies the formula. 26 | walkSAT fs p mf seed = step (mkStdGen seed) m0 mf 27 | where 28 | -- All the atoms in the set of formulas: 29 | a = allAtoms fs 30 | -- Initial model: 31 | m0 = randomFairAss (mkStdGen seed) a 32 | 33 | step _ _ 0 = Nothing 34 | step g m n 35 | | satisfiesAll m fs = Just m 36 | | otherwise = step g''' m' (n - 1) 37 | where 38 | -- Unsatisfied formulas: 39 | unsatisfied = Set.toList $ filterUnsatisfied m fs 40 | 41 | -- Pick a clause randomly among the unsatisfied clauses: 42 | (idx0, g') = randomR (0, length unsatisfied - 1) g :: (Int, StdGen) 43 | u = unsatisfied !! idx0 44 | 45 | -- Pick a random atom in the unsatisfied clause: 46 | atoms' = atomsLs u 47 | (idx1, g'') = randomR (0, length atoms' - 1) g' :: (Int, StdGen) 48 | a' = atoms' !! idx1 49 | 50 | -- Number of satisfied clauses when flipping each atom in the unsatisfied clause: 51 | bestFlip = 52 | fst $ 53 | foldl' 54 | (\(best, c) x -> 55 | let c' = count x in if c' > c then (x, c') else (best, c)) 56 | (head atoms', count $ head atoms') 57 | (tail atoms') 58 | where count x = numSatisfied (Map.adjust not x m) fs 59 | 60 | -- Whether a random atom is flipped or the one with the lowest deltaCost flips. 61 | (flipTest, g''') = random g'' :: (Double, StdGen) 62 | flips = flipTest < p 63 | 64 | toFlip = if flips then a' else bestFlip 65 | 66 | m' = Map.adjust not toFlip m 67 | 68 | -- | The MaxWalkSAT algorithm with a max number of tries (mt), max number 69 | -- of flips (mt), a target cost, a probability of flipping, and a markov 70 | -- logic network of clauses. 71 | -- 72 | -- Reference: 73 | -- P Domingos and D Lowd, Markov Logic: An Interface Layer for Artificial 74 | -- Intelligence, 2009, Morgan & Claypool. p. 24. 75 | maxWalkSAT 76 | :: Int -- ^ Number of tries. 77 | -> Int -- ^ Max number of flips. 78 | -> Double -- ^ Target cost (sum of the failing formulas). 79 | -> Double -- ^ Probability of flipping. 80 | -> Int -- ^ Seed. 81 | -> Map FOL Double -- ^ Probabilistic knowledge base. 82 | -> Maybe (Map Predicate Bool) -- ^ The answer (or not). 83 | maxWalkSAT mt mf target p seed fs = step (mkStdGen seed) mt 84 | where 85 | -- Set of atoms (predicates) in the MLN: 86 | vars = Set.unions $ map atoms (Map.keys fs) 87 | 88 | -- A single step. Returns a Maybe type with Nothing if no assignment with 89 | -- a cost lower than the target has been found. 90 | step _ 0 = Nothing 91 | step r n = 92 | let 93 | (seed0, r') = random r :: (Int, StdGen) 94 | (seed1, _) = random r' :: (Int, StdGen) 95 | in 96 | case flipStep r (randomFairAss (mkStdGen seed0) vars) mf of 97 | Just ass -> Just ass 98 | Nothing -> step (mkStdGen seed1) (n - 1) -- Try again... 99 | 100 | -- The 'flips' steps take a rng, a solution, and the number of flips left: 101 | flipStep _ _ 0 = Nothing 102 | flipStep r s n = if cost <= target then Just s else flipStep r''' s' (n - 1) 103 | where 104 | -- List of unsatisfied formula under soln: 105 | unsatisfied = Map.filterWithKey (\k _ -> unsatisfiable s k) fs 106 | -- Sum of weights of unsatisfied clauses in soln 107 | cost = Map.foldr (+) 0.0 unsatisfied 108 | 109 | -- Pick a clause randomly among the unsatisfied clauses: 110 | (idx0, r') = randomR (0, Map.size unsatisfied - 1) r :: (Int, StdGen) 111 | (c, _) = Map.elemAt idx0 unsatisfied 112 | 113 | -- Maps deltaCosts to atoms in the selected clause c: 114 | da = Map.fromList $ map (\a -> (deltaCost cost s a, a)) (atomsLs c) 115 | 116 | -- Whether a random atom is flipped or the one with the lowest deltaCost flips. 117 | (flipTest, r'') = random r' :: (Double, StdGen) 118 | flips = flipTest < p 119 | 120 | -- Pick an atom randomly in the randomly selected clause: 121 | (idx1, r''') = randomR (0, Map.size da - 1) r'' :: (Int, StdGen) 122 | a' = snd $ if flips then Map.elemAt idx1 da else Map.findMin da 123 | 124 | -- Solution with vf flipped 125 | s' = Map.adjust not a' s 126 | 127 | -- Cost of flipping atom v 128 | deltaCost cost s v = cost' - cost 129 | where 130 | unsatisfied' = Map.filterWithKey 131 | (\k _ -> unsatisfiable (Map.adjust not v s) k) fs 132 | cost' = Map.foldr (+) 0.0 unsatisfied' 133 | -------------------------------------------------------------------------------- /Akarui/Fmt.hs: -------------------------------------------------------------------------------- 1 | -- | Functions to print some common data stuctures in a specific format. This 2 | -- is mostly convenient for playing with Sphinx in the console. 3 | module Akarui.Fmt where 4 | 5 | import qualified Data.Text as T 6 | import Data.Map (Map) 7 | import qualified Data.Map as Map 8 | import Data.Set (Set) 9 | import qualified Data.Set as Set 10 | import Akarui.Text 11 | import Akarui.ShowTxt 12 | 13 | -- | Formats a set in the standard format (not a 'fromList'). 14 | fmtSet :: (ShowTxt k, Ord k) => Set k -> T.Text 15 | fmtSet s = addBrackets $ T.drop 2 $ Set.foldl' (\acc k -> T.concat [acc, ", ", showTxt k]) "" s 16 | 17 | -- | Formats a map. 18 | fmtMap :: (ShowTxt k, ShowTxt v, Ord k) => Map k v -> T.Text 19 | fmtMap = Map.foldrWithKey' (\k v acc -> T.concat [showTxt k, " -> ", showTxt v, "\n", acc]) "" 20 | 21 | -- | Formats a map of sets to something 22 | fmtMapOfSet :: (ShowTxt k, ShowTxt v, Ord k) => Map (Set k) v -> T.Text 23 | fmtMapOfSet = Map.foldrWithKey' (\k v acc -> T.concat [fmtSet k, " -> ", showTxt v, "\n", acc]) "" 24 | 25 | -- | Formats a map of sets (often used to represent undirected networks). 26 | fmtMapSet :: (ShowTxt k0, ShowTxt k1, Ord k0, Ord k1) => Map k0 (Set k1) -> T.Text 27 | fmtMapSet = Map.foldrWithKey' (\k v acc -> T.concat [showTxt k, " -> ", fmtSet v, "\n", acc]) "" 28 | 29 | -- | Formats a map of maps (often used to represent networks.) 30 | fmtMapMap :: (Show k0, Show k1, Show v, Ord k0, Ord k1) => Map k0 (Map k1 v) -> String 31 | fmtMapMap = Map.foldrWithKey' vertices "" 32 | where 33 | vertices k v acc = show k ++ " -> " ++ edges v ++ "\n" ++ acc 34 | edges = Map.foldrWithKey' (\k v acc -> "(" ++ show k ++ ", " ++ show v ++ "), " ++ acc) "" 35 | -------------------------------------------------------------------------------- /Akarui/MVL/Fuzzy.hs: -------------------------------------------------------------------------------- 1 | module Akarui.MVL.Fuzzy 2 | ( Fuzzy() 3 | , mkFuzzy 4 | , invNeg 5 | , toDouble 6 | , isFalse 7 | , isTrue 8 | , nonZero 9 | , fuzzyFalse 10 | , fuzzyTrue 11 | ) where 12 | 13 | import Akarui.MVL.Truth 14 | 15 | data Fuzzy = Fuzzy Double 16 | deriving (Eq, Ord, Show) 17 | 18 | instance Truth Fuzzy where 19 | order _ = 1 20 | 21 | isFalse (Fuzzy x) = x == 0 22 | 23 | isTrue (Fuzzy x) = x == 1 24 | 25 | -- | Builds a fuzzy value, ensuring it is in the [0, 1] range. 26 | mkFuzzy :: Double -> Fuzzy 27 | mkFuzzy = Fuzzy . unit 28 | 29 | -- | Involutive negation. 30 | invNeg :: Fuzzy -> Fuzzy 31 | invNeg (Fuzzy x) = Fuzzy $ 1 - x 32 | 33 | toDouble :: Fuzzy -> Double 34 | toDouble (Fuzzy x) = x 35 | 36 | nonZero :: Fuzzy -> Bool 37 | nonZero (Fuzzy x) = x /= 0 38 | 39 | fuzzyFalse :: Fuzzy 40 | fuzzyFalse = Fuzzy 0 41 | 42 | fuzzyTrue :: Fuzzy 43 | fuzzyTrue = Fuzzy 1 44 | 45 | {-# INLINE unit #-} 46 | unit :: Double -> Double 47 | unit x 48 | | x < 0 = 0 49 | | x > 1 = 1 50 | | otherwise = x 51 | -------------------------------------------------------------------------------- /Akarui/MVL/Fuzzy2.hs: -------------------------------------------------------------------------------- 1 | -- | Module for type-2 fuzzy logic, where the fuzziness itself is fuzzy. 2 | module Akarui.MVL.Fuzzy2 3 | ( Fuzzy2() 4 | , mkFuzzyInterval 5 | , uncertainty 6 | ) where 7 | 8 | import Akarui.MVL.Truth 9 | import Akarui.MVL.Fuzzy 10 | 11 | data Fuzzy2 = 12 | FuzzyInterval Fuzzy Fuzzy 13 | -- | FuzzyFun (Fuzzy -> Fuzzy) 14 | 15 | instance Truth Fuzzy2 where 16 | order _ = 2 17 | 18 | isFalse (FuzzyInterval x y) = isFalse x && isFalse y 19 | 20 | isTrue (FuzzyInterval x y) = isTrue x && isTrue y 21 | 22 | mkFuzzyInterval :: Double -> Double -> Fuzzy2 23 | mkFuzzyInterval x y = if x > y then mkFuzzyInterval y x else FuzzyInterval (mkFuzzy x) (mkFuzzy y) 24 | 25 | uncertainty :: Fuzzy -> Fuzzy2 -> Fuzzy 26 | uncertainty x (FuzzyInterval a b) = if a <= x && x <= b then fuzzyTrue else fuzzyFalse 27 | -------------------------------------------------------------------------------- /Akarui/MVL/FuzzyLogic.hs: -------------------------------------------------------------------------------- 1 | -- | Type and functions for fuzzy logic. 2 | module Akarui.MVL.FuzzyLogic where 3 | -------------------------------------------------------------------------------- /Akarui/MVL/FuzzySet.hs: -------------------------------------------------------------------------------- 1 | -- | Module for discrete fuzzy sets. 2 | module Akarui.MVL.FuzzySet 3 | ( FuzzySet(..) 4 | , fromSet 5 | , subsetOf 6 | , elementOf 7 | , size 8 | , cardinality 9 | , support 10 | , supportSize 11 | , singleton 12 | , union 13 | , intersection 14 | , complement 15 | , remove0s 16 | ) where 17 | 18 | import qualified Data.Map.Strict as Map 19 | import Data.Map (Map) 20 | import qualified Data.Set as Set 21 | import Data.Set (Set) 22 | import qualified Data.Text as T 23 | import Akarui.ShowTxt 24 | import Akarui.Utils 25 | import Akarui.FOL.PrettyPrint 26 | import Akarui.MVL.Fuzzy 27 | 28 | -- | A discrete fuzzy set. 29 | data FuzzySet a = MapFS (Map a Fuzzy) 30 | 31 | instance (ShowTxt a) => Show (FuzzySet a) where 32 | show = T.unpack . showByElem 33 | 34 | instance (ShowTxt a) => ShowTxt (FuzzySet a) where 35 | showTxt = showByElem 36 | 37 | instance (ShowTxt a) => PrettyPrint (FuzzySet a) where 38 | prettyPrint _ = showByElem 39 | 40 | elementOf :: (Ord a) => a -> FuzzySet a -> Fuzzy 41 | elementOf e (MapFS m) = case Map.lookup e m of Just d -> d; _ -> mkFuzzy 0 42 | 43 | -- | Number of elements in the fuzzyset. 44 | size :: (Ord a) => FuzzySet a -> Int 45 | size (MapFS m) = Map.size m 46 | 47 | cardinality :: (Ord a) => FuzzySet a -> Double 48 | cardinality (MapFS m) = Map.foldr (\f acc -> acc + toDouble f) 0 m 49 | 50 | -- | Converts a normal set into a fuzzyset with degree 1.0 for all elements. 51 | fromSet :: (Ord a) => Set a -> FuzzySet a 52 | fromSet s = MapFS $ Set.foldr' (\k acc -> Map.insert k fuzzyTrue acc) Map.empty s 53 | 54 | -- | A set f0 is a subset of f1 if, for all elements, degree(e0) < degree(e1). 55 | subsetOf :: (Ord a) => FuzzySet a -> FuzzySet a -> Bool 56 | subsetOf (MapFS m0) (MapFS m1) = allKeyVal sub m0 57 | where sub k v = case Map.lookup k m1 of Just v1 -> v < v1; Nothing -> False 58 | 59 | -- | The set of members with a degree greater than 0. 60 | support :: (Ord a) => FuzzySet a -> Set a 61 | support (MapFS m) = Map.keysSet $ Map.filter nonZero m 62 | 63 | -- | Number of elements with a degree greater than 0. 64 | supportSize :: (Ord a) => FuzzySet a -> Int 65 | supportSize = Set.size . support 66 | 67 | -- | Removes elements with a degree of 0. -- size $ removes0 === support 68 | remove0s :: (Ord a) => FuzzySet a -> FuzzySet a 69 | remove0s (MapFS m) = MapFS $ Map.filter isFalse m 70 | 71 | -- | Tests whether the fuzzy set is a singleton (has a support of 1). 72 | singleton :: (Ord a) => FuzzySet a -> Bool 73 | singleton f = Set.size (support f) == 1 74 | 75 | -- | Union of two fuzzy sets (taking the max value). 76 | union :: (Ord a) => FuzzySet a -> FuzzySet a -> FuzzySet a 77 | union (MapFS m0) (MapFS m1) = MapFS $ Map.unionWith max m0 m1 78 | 79 | -- | Intersection of two fuzzy sets (taking the min value). 80 | intersection :: (Ord a) => FuzzySet a -> FuzzySet a -> FuzzySet a 81 | intersection (MapFS m0) (MapFS m1) = MapFS $ Map.intersectionWith min m0 m1 82 | 83 | -- | The complement of a fuzzy set. 84 | complement :: (Ord a) => FuzzySet a -> FuzzySet a 85 | complement (MapFS m) = MapFS $ Map.map invNeg m 86 | 87 | showByElem :: (ShowTxt a) => FuzzySet a -> T.Text 88 | showByElem (MapFS m) = T.concat ["{", txt, "}"] 89 | where elems = Map.toList m 90 | txt = T.intercalate ", " $ map (\(k, v) -> T.concat [showTxt k, "/", T.pack $ show v]) elems 91 | -------------------------------------------------------------------------------- /Akarui/MVL/Truth.hs: -------------------------------------------------------------------------------- 1 | module Akarui.MVL.Truth 2 | ( Truth(..) 3 | ) where 4 | 5 | class Truth a where 6 | order :: a -> Int 7 | 8 | isFalse :: a -> Bool 9 | 10 | isTrue :: a -> Bool 11 | 12 | isNuanced :: a -> Bool 13 | isNuanced t = not (isFalse t) && not (isTrue t) 14 | 15 | instance Truth Bool where 16 | order _ = 0 17 | 18 | isFalse x = not x 19 | 20 | isTrue x = x 21 | 22 | isNuanced _ = False 23 | -------------------------------------------------------------------------------- /Akarui/Network.hs: -------------------------------------------------------------------------------- 1 | -- | A weighted directed network represented as an 'forest', a map of maps. 2 | module Akarui.Network where 3 | 4 | import Data.Map (Map) 5 | import qualified Data.Map as Map 6 | import Data.Set (Set) 7 | import qualified Data.Set as Set 8 | import Data.Maybe 9 | 10 | -- | A network maps some keys to other keys with an edge (the value 'v'). 11 | type Network k v = Map k (Map k v) 12 | 13 | -- | An undirected network maps keys to sets of keys. 14 | type UNetwork k = Map k (Set k) 15 | 16 | -- | Second order lookup function. 17 | lookup2 :: (Ord k0, Ord k1) => k0 -> k1 -> Map k0 (Map k1 v) -> Maybe v 18 | lookup2 key0 key1 m = Map.lookup key0 m >>= Map.lookup key1 19 | 20 | -- | Get the value from the edge between two vertices. 21 | getVal :: (Ord k) => k -> k -> Network k v -> Maybe v 22 | getVal = lookup2 23 | 24 | -- | Tests for the presence of a vertex. 25 | hasVertex :: (Ord k) => k -> Network k v -> Bool 26 | hasVertex = Map.member 27 | 28 | -- | Tests for the presence of a list of vertices. 29 | hasVertices :: (Ord k) => [k] -> Network k v -> Bool 30 | hasVertices vs m = all (`hasVertex` m) vs 31 | 32 | -- | Tests for the presence of an edge. 33 | hasEdge :: (Ord k) => (k, k) -> Network k v -> Bool 34 | hasEdge (t, h) n = 35 | case Map.lookup t n of 36 | Nothing -> False 37 | Just m -> Map.member h m 38 | 39 | -- | Tests for the presense of a list of edges. 40 | hasEdges :: (Ord k) => [(k, k)] -> Network k v -> Bool 41 | hasEdges es n = all (`hasEdge` n) es 42 | 43 | -- | Returns the outgoing edges for a given vertex. 44 | outEdges :: (Ord k) => k -> Network k v -> Map k v 45 | outEdges v n = fromMaybe Map.empty $ Map.lookup v n 46 | 47 | -- | Returns the set of outgoing edges for a given vertex. 48 | outEdgesSet :: (Ord k) => k -> Network k v -> Set k 49 | outEdgesSet v n = Map.keysSet $ outEdges v n 50 | 51 | -- | Returns the ingoing edges for a given vertex. 52 | inEdges :: (Ord k) => k -> Network k v -> Map k v 53 | inEdges v n = Map.foldrWithKey addEdges Map.empty n 54 | where 55 | addEdges k _ a = 56 | case getVal k v n of 57 | Nothing -> a 58 | Just x -> Map.insert k x a 59 | 60 | -- | Returns the set of ingoing edges for a given vertex. 61 | inEdgesSet :: (Ord k) => k -> Network k v -> Set k 62 | inEdgesSet v n = Set.fold addKeys Set.empty $ Map.keysSet n 63 | where 64 | addKeys k a = 65 | case getVal k v n of 66 | Nothing -> a 67 | Just _ -> Set.insert k a 68 | 69 | -- | Returns the set of vertices that can be reached from 'v0' (not 70 | -- necessarily adjacent). 71 | connectsTo :: (Ord k) => k -> Network k v -> Set k 72 | connectsTo v0 n 73 | | Map.member v0 n = conn v0 $ Set.fromList [v0] 74 | | otherwise = Set.empty 75 | where 76 | -- Recursive function to explore the network from 'v' given a set of 77 | -- visited ('vis') vertices. 78 | conn v vis = 79 | Set.fold (\k acc -> 80 | if Set.member k acc then acc 81 | else conn k $ Set.insert k acc) 82 | vis $ outEdgesSet v n 83 | 84 | -- | Returns the set of vertices that cannot be reached from 'v'. 85 | notConnected :: (Ord k) => k -> Network k v -> Set k 86 | notConnected v n = Set.difference (Map.keysSet n) (connectsTo v n) 87 | 88 | -- | Returns true if there is a path between the vertex and all other vertices 89 | -- in the network. 90 | connected :: (Ord k) => k -> Network k v -> Bool 91 | connected v n = connectsTo v n == Map.keysSet n 92 | 93 | -- | Returns true if there is a path between all pairs of vertices. 94 | stronglyConnected :: (Ord k) => Network k v -> Bool 95 | stronglyConnected n = all (`connected` n) $ Map.keys n 96 | -------------------------------------------------------------------------------- /Akarui/Parser/Bool.hs: -------------------------------------------------------------------------------- 1 | module Akarui.Parser.Bool 2 | ( parseBool 3 | , getBool 4 | , getTop 5 | , getBot 6 | ) where 7 | 8 | import Text.Parsec 9 | import Text.Parsec.String (Parser) 10 | import Akarui.Parser.Core 11 | 12 | parseBool :: String -> Either ParseError Bool 13 | parseBool = parse (contents getBool) "" 14 | 15 | getBool, getTop, getBot :: Parser Bool 16 | getBool = try getTop <|> getBot 17 | getTop = reservedOps ["True", "TRUE", "true", "Top", "T", "⊤"] >> return True 18 | getBot = reservedOps ["False", "FALSE", "false", "F", "Bottom", "Bot", "⊥"] >> return False 19 | -------------------------------------------------------------------------------- /Akarui/Parser/Core.hs: -------------------------------------------------------------------------------- 1 | -- | Parsers for first-order logic and other important structures (e.g. Markov 2 | -- logic networks). 3 | module Akarui.Parser.Core where 4 | 5 | import Data.Functor.Identity 6 | import Text.Parsec 7 | import Text.Parsec.String (Parser) 8 | import qualified Text.Parsec.Token as Tok 9 | 10 | langDef :: Tok.LanguageDef () 11 | langDef = Tok.LanguageDef { 12 | Tok.commentStart = "/*" 13 | , Tok.commentEnd = "*/" 14 | , Tok.commentLine = "//" 15 | , Tok.nestedComments = False 16 | , Tok.identStart = alphaNum 17 | , Tok.identLetter = alphaNum <|> oneOf "_'" 18 | , Tok.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~" 19 | , Tok.opLetter = oneOf ":#$%&*+./<=>?@\\^|-" 20 | , Tok.reservedNames = [] 21 | , Tok.reservedOpNames = [] 22 | , Tok.caseSensitive = True 23 | } 24 | 25 | lexer :: Tok.TokenParser () 26 | lexer = Tok.makeTokenParser langDef 27 | 28 | parens :: Parser a -> Parser a 29 | parens = Tok.parens lexer 30 | 31 | reservedOp :: String -> Parser () 32 | --reserved = Tok.reserved lexer 33 | reservedOp = Tok.reservedOp lexer 34 | 35 | symbol :: String -> Parser String 36 | symbol = Tok.symbol lexer 37 | 38 | identifier :: ParsecT String () Identity String 39 | identifier = Tok.identifier lexer 40 | 41 | commaSep :: ParsecT String () Identity a -> ParsecT String () Identity [a] 42 | commaSep = Tok.commaSep lexer 43 | 44 | reservedOps :: [String] -> ParsecT String () Identity () 45 | reservedOps names = foldr1 (\x acc -> try x <|> acc) $ map reservedOp names 46 | 47 | contents :: Parser a -> Parser a 48 | contents p = do 49 | Tok.whiteSpace lexer 50 | r <- p 51 | eof 52 | return r 53 | -------------------------------------------------------------------------------- /Akarui/Parser/FOL.hs: -------------------------------------------------------------------------------- 1 | -- | Type and functions for first-order predicate logic. 2 | module Akarui.Parser.FOL where 3 | 4 | import qualified Data.Text as T 5 | import Text.Parsec 6 | import Text.Parsec.String (Parser) 7 | import qualified Text.Parsec.Expr as Ex 8 | import Akarui.FOL.Formula 9 | import Akarui.FOL.FOL 10 | import Akarui.Parser.LogicOps 11 | import Akarui.Parser.Core 12 | import Akarui.Parser.Numbers 13 | import Akarui.Parser.Term as Term 14 | import Akarui.FOL.Predicate 15 | import Akarui.FOL.QuanT 16 | 17 | -- | Parser for weighted first-order logic. Parses a double following by 18 | -- a formula (or a formula followed by a double). 19 | -- 20 | -- The /smoking/ example for Markov logic: 21 | -- 22 | -- @ 23 | -- parseWFOL \"∀x∀y∀z Friend(x, y) ∧ Friend(y, z) ⇒ Friend(x, z) 0.7\" 24 | -- parseWFOL \"∀x Smoking(x) ⇒ Cancer(x) 1.5\" 25 | -- parseWFOL \"1.1 ∀x∀y Friend(x, y) ∧ Smoking(x) ⇒ Smoking(y)\" 26 | -- @ 27 | parseWFOL :: String -> Either ParseError (FOL, Double) 28 | parseWFOL = parse (contents parseWeighted) "" 29 | 30 | -- | Parser for first-order logic. The parser will read a string and output 31 | -- an either type with (hopefully) the formula on the right. 32 | -- 33 | -- This parser makes the assumption that variables start with a lowercase 34 | -- character, while constants start with an uppercase character. 35 | -- 36 | -- Some examples of valid strings for the parser: 37 | -- 38 | -- @ 39 | -- parseFOL \"ForAll x, y PositiveInteger(y) => GreaterThan(Add(x, y), x)\" 40 | -- parseFOL \"A.x,y: Integer(x) and PositiveInteger(y) => GreaterThan(Add(x, y), x)\" 41 | -- parseFOL \"∀ x Add(x, 0) = x\" 42 | -- @ 43 | parseFOL :: String -> Either ParseError FOL 44 | parseFOL = parse (contents parseFOLAll) "" 45 | 46 | parseFOLAll, parseSentence, parseTop, parseBot, parseAtoms, parsePred, parsePredLike, parseIdentity, parseNIdentity, parseQuan, parseNQuan, parseNegation :: Parser FOL 47 | parseFOLAll = try parseNQuan<|> try parseQuan <|> parseSentence 48 | 49 | parseSentence = Ex.buildExpressionParser logicTbl parseAtoms 50 | 51 | parseTop = reservedOps ["True", "TRUE", "true", "T", "⊤"] >> return top 52 | 53 | parseBot = reservedOps ["False", "FALSE", "false", "F", "⊥"] >> return bot 54 | 55 | parseNQuan = do 56 | nots <- many1 parseNot 57 | (q, vs, a) <- parseQuanForm 58 | return $ foldr (\_ acc -> Not acc) (foldr (Quantifier q) a vs) nots 59 | 60 | parseQuan = do 61 | (q, vs, a) <- parseQuanForm 62 | return $ foldr (Quantifier q) a vs 63 | 64 | parseNegation = do 65 | n <- parseNot 66 | a <- parseAtoms 67 | return $ n a 68 | 69 | parsePredLike = try parseIdentity <|> try parseNIdentity <|> parsePred 70 | 71 | parseAtoms = 72 | try parsePredLike 73 | <|> parseNegation 74 | <|> parseTop 75 | <|> parseBot 76 | <|> parens parseFOLAll 77 | 78 | parsePred = do 79 | args <- Term.parseFunForm 80 | return $ Atom $ uncurry Predicate args 81 | 82 | parseIdentity = do 83 | left <- Term.parseTerm 84 | reservedOps ["=", "=="] 85 | right <- Term.parseTerm 86 | return $ Atom $ Predicate "Identity" [left, right] 87 | 88 | parseNIdentity = do 89 | left <- Term.parseTerm 90 | reservedOps ["!=", "/=", "\\neq"] 91 | right <- Term.parseTerm 92 | return $ Not $ Atom $ Predicate "Identity" [left, right] 93 | 94 | parseNot :: Parser (FOL -> FOL) 95 | parseNot = reservedOps ["Not", "NOT", "not", "~", "!", "¬"] >> return Not 96 | 97 | parseExists, parseForAll :: Parser QuanT 98 | parseExists = reservedOps ["E.", "Exists", "exists", "∃"] >> return Exists 99 | parseForAll = reservedOps ["A.", "ForAll", "Forall", "forall", "∀"] >> return ForAll 100 | 101 | -- Parse a weight and then a first-order logic formula 102 | parseLeftW :: Parser (FOL, Double) 103 | parseLeftW = do 104 | n <- getDouble 105 | f <- parseFOLAll 106 | return (f, n) 107 | 108 | -- Parse a first-order logic formula and then a weight 109 | parseRightW :: Parser (FOL, Double) 110 | parseRightW = do 111 | f <- parseFOLAll 112 | n <- getDouble 113 | return (f, n) 114 | 115 | parseWeighted :: Parser (FOL, Double) 116 | parseWeighted = try parseLeftW <|> parseRightW 117 | 118 | parseQuanForm :: Parser (QuanT, [T.Text], FOL) 119 | parseQuanForm = do 120 | q <- parseExists <|> parseForAll -- many1 121 | v <- commaSep identifier 122 | optional $ reservedOp ":" 123 | a <- parseFOLAll 124 | return (q, map T.pack v, a) 125 | -------------------------------------------------------------------------------- /Akarui/Parser/FuzzySet.hs: -------------------------------------------------------------------------------- 1 | -- | Akarui.Fuzzy is a fun functional set of functions for fuzzy logic 2 | module Akarui.Parser.FuzzySet 3 | ( parseFuzzySet 4 | , getFuzzy 5 | , getFuzzyElement 6 | ) where 7 | 8 | import qualified Data.Map as Map 9 | import Data.List (foldl') 10 | import qualified Data.Text as T 11 | import Text.Parsec 12 | import Text.Parsec.String (Parser) 13 | import Akarui.Parser.Core 14 | import Akarui.Parser.Numbers 15 | import Akarui.MVL.FuzzySet 16 | import Akarui.MVL.Fuzzy 17 | 18 | -- | Parse a fuzzy set. 19 | parseFuzzySet :: String -> Either ParseError (FuzzySet T.Text) 20 | parseFuzzySet = parse (contents getFuzzy) "" 21 | 22 | getFuzzy :: Parser (FuzzySet T.Text) 23 | getFuzzy = do 24 | reservedOp "{" 25 | elems <- commaSep getFuzzyElement 26 | reservedOp "}" 27 | return $ MapFS $ foldl' (\m e -> Map.insert (T.pack $ fst e) (mkFuzzy $ snd e) m) Map.empty elems 28 | 29 | getFuzzyElement :: Parser (String, Double) 30 | getFuzzyElement = do 31 | n <- identifier 32 | reservedOp "/" 33 | degree <- getDouble 34 | return (n, degree) 35 | -------------------------------------------------------------------------------- /Akarui/Parser/LogicOps.hs: -------------------------------------------------------------------------------- 1 | -- | Type and functions for first-order predicate logic. 2 | module Akarui.Parser.LogicOps ( 3 | logicTbl 4 | ) where 5 | 6 | import Data.Functor.Identity 7 | import qualified Text.Parsec.Expr as Ex 8 | import Akarui.Parser.Core 9 | import Akarui.FOL.Formula 10 | import Akarui.FOL.BinT 11 | 12 | -- | Operators for logic formulas. Order of precedence: and, or, implies, xor, equivalence. 13 | logicTbl :: Ex.OperatorTable String () Identity (Formula a) 14 | logicTbl = 15 | [ [binary ["And", "and", "AND", "∧"] (BinOp And) Ex.AssocRight] 16 | , [binary ["Or", "or", "OR", "∨", "v"] (BinOp Or) Ex.AssocRight] 17 | , [binary ["Implies", "implies", "IMPLIES", "⇒", "=>"] (BinOp Implies) Ex.AssocRight] 18 | , [binary ["Xor", "xor", "XOR", "⊕"] (BinOp Xor) Ex.AssocRight] 19 | , [binary ["Iff", "iff", "IFF", "⇔", "<=>"] (BinOp Iff) Ex.AssocRight] ] 20 | where binary ns fun = Ex.Infix (do { reservedOps ns; return fun }) 21 | -------------------------------------------------------------------------------- /Akarui/Parser/NamedFuzzy.hs: -------------------------------------------------------------------------------- 1 | -- | Akarui.Fuzzy is a fun functional set of functions for fuzzy logic 2 | module Akarui.Parser.NamedFuzzy 3 | ( parseNamedFuzzy 4 | ) where 5 | 6 | import qualified Data.Text as T 7 | import Text.Parsec 8 | import Text.Parsec.String (Parser) 9 | import Akarui.Parser.Core 10 | import Akarui.Parser.FuzzySet 11 | import Akarui.MVL.NamedFuzzy 12 | 13 | -- | Parse a fuzzy set. 14 | parseNamedFuzzy :: String -> Either ParseError NamedFuzzy 15 | parseNamedFuzzy = parse (contents getNamedFuzzy) "" 16 | 17 | getNamedFuzzy :: Parser NamedFuzzy 18 | getNamedFuzzy = do 19 | n <- identifier 20 | reservedOp "=" 21 | reservedOp "{" 22 | fs <- getFuzzy 23 | reservedOp "}" 24 | return $ NamedFuzzy (T.pack n) fs 25 | -------------------------------------------------------------------------------- /Akarui/Parser/Numbers.hs: -------------------------------------------------------------------------------- 1 | module Akarui.Parser.Numbers 2 | ( parseDouble 3 | , getDouble 4 | ) where 5 | 6 | import Text.Parsec 7 | import Text.Parsec.String (Parser) 8 | import Akarui.Parser.Core 9 | import qualified Text.Parsec.Token as Tok 10 | 11 | parseDouble :: String -> Either ParseError Double 12 | parseDouble = parse (contents getDouble) "" 13 | 14 | getDouble, ndouble, pdouble, int :: Parser Double 15 | 16 | getDouble = try ndouble <|> try pdouble <|> int 17 | 18 | int = do 19 | i <- Tok.integer lexer 20 | return $ fromIntegral i 21 | 22 | ndouble = do 23 | reservedOp "-" 24 | f <- Tok.float lexer 25 | return (-f) 26 | 27 | pdouble = do 28 | optional $ reservedOp "+" 29 | Tok.float lexer 30 | -------------------------------------------------------------------------------- /Akarui/Parser/Probability.hs: -------------------------------------------------------------------------------- 1 | -- | Parser to handle joint and conditional queries. 2 | module Akarui.Parser.Probability ( 3 | parseEvidenceLines, 4 | parseEvidenceList, 5 | parsePredicateAss, 6 | parsePredicate, 7 | parseJointQuery, 8 | parseCondQuery 9 | ) where 10 | 11 | import Text.Parsec 12 | import Text.Parsec.String (Parser) 13 | import qualified Data.Set as Set 14 | import Data.Set (Set) 15 | import Akarui.Parser.Core 16 | import Akarui.Parser.FOL 17 | import Akarui.Parser.Bool 18 | import Akarui.FOL.Formula 19 | import Akarui.FOL.Predicate 20 | 21 | -- | Parser for conditional queries of the form 22 | -- P(f0 = v0, f1 = v1 | f2 = v2, f3 = v3, ...), where f, f0, f1, f2 are 23 | -- first-order logic predicates and v0, v1, v3 are optional boolean values 24 | -- (True, False, T, F). The parser is fairly flexible (see examples), allowing 25 | -- you to omit the assignment (in which case it is assumed to be true) and 26 | -- use various symbols for joint probabilities. 27 | -- 28 | -- For truth values, this parser accepts T TRUE True true ⊤ F False FALSE false ⊥. 29 | -- 30 | -- For introducing the truth value after a variable (e.g. Smoking(Bob) = True), the parser 31 | -- accepts == = := is ->. It is entirely optional as a variable without assignment 32 | -- is assumed to be true so 33 | -- 34 | -- @ 35 | -- Smoking(Bob) -> T 36 | -- Smoking(Bob) 37 | -- @ 38 | -- 39 | -- are equivalent. Also, it's possible to introduce negation with the ~ or ! suffix, so 40 | -- 41 | -- @ 42 | -- Smoking(Bob) = ⊥ 43 | -- !Smoking(Bob) 44 | -- @ 45 | -- 46 | -- are also equivalent. 47 | -- 48 | -- For separating variables in joint probabilities, the parser accetps , ; and ∩. 49 | -- For introducing conditioned variables, either use the traditional |, LaTeX' \mid, 50 | -- or the word /given/. 51 | -- 52 | -- Full examples: 53 | -- 54 | -- @ 55 | -- parseCondQuery \"P(Predators(Wolf, Rabbit) | SameLocation(Wolf, Rabbit), Juicy(Rabbit))\" 56 | -- parseCondQuery \"P(!Predators(Rabbit, Wolf) | EatLettuce(Rabbit) ∩ EatLettuce(Wolf) = False)\" 57 | -- parseCondQuery \"Probability(Smoking(Bob) given Smoking(Anna) -> true, Friend(Anna, Bob) is false)\" 58 | -- @ 59 | parseCondQuery :: String -> Either ParseError (Set (Predicate, Bool), Set (Predicate, Bool)) 60 | parseCondQuery = parse (contents parseQ) "" 61 | 62 | -- | Parser for joint probabilitye queries of the form 63 | -- P(f0 = v0, f1 = v1, ...), where f0, f1 et al. are first-order logic 64 | -- predicates formulas, and v0, v1, ...are optional boolean values (True, 65 | -- False, T, F). This parser uses the same syntax as 'parseCondQuery', without 66 | -- the conditional variables. 67 | -- 68 | -- @ 69 | -- parseJointQuery \"Probability(FluInfection(Dan) ∩ StarLord(Dan) ∩ ElvisLivesIn(Sherbrooke))\" 70 | -- parseJointQuery \"P(Cancer(Charlotte), Cancer(Anna))\" 71 | -- @ 72 | parseJointQuery :: String -> Either ParseError (Set (Predicate, Bool)) 73 | parseJointQuery = parse (contents parseJ) "" 74 | 75 | -- | Parser for predicates. 76 | -- 77 | -- @ 78 | -- Predators(Wolf, Rabbit) 79 | -- GreaterThan(Add(1, x), 0) 80 | -- @ 81 | parsePredicate :: String -> Either ParseError Predicate 82 | parsePredicate = parse (contents parsePredOnly) "" 83 | 84 | -- | Parser for predicates assigned to a truth value. If a truth value is not 85 | -- included, the parser assumes it is true. 86 | -- 87 | -- For truth values, this parser accepts T TRUE True true ⊤ F False FALSE false ⊥. 88 | -- 89 | -- For introducing the truth value after a variable (e.g. Smoking(Bob) = True), the parser 90 | -- accepts == = := is ->. It's also possible to prefix the predicate with either 91 | -- ! or ~ for negations. 92 | -- 93 | -- @ 94 | -- Predators(Rabbit, Wolf) = False 95 | -- !Predators(Rabbit, Wolf) 96 | -- GreaterThan(Add(1, x), 0) 97 | -- Equals(2, 2) is true 98 | -- Foo(bar, baz) == F 99 | -- @ 100 | parsePredicateAss :: String -> Either ParseError (Predicate, Bool) 101 | parsePredicateAss = parse (contents parsePredTruth) "" 102 | 103 | -- | Parse a list of evidence (predicate with optional truth value, see 104 | -- 'parsePredicateAss') separated by one of , ; and ∩. 105 | -- 106 | -- @ 107 | -- Predators(Wolf, Rabbit) = False, GreaterThan(Add(1, x), 0) 108 | -- A() ∩ B() ∩ C() ∩ !D() 109 | -- Equals(2, 2) is true 110 | -- Foo(bar, baz) == F, Grrr() 111 | -- @ 112 | parseEvidenceList :: String -> Either ParseError [(Predicate, Bool)] 113 | parseEvidenceList = parse (contents parseEviList) "" 114 | 115 | -- | Parse a list of evidence separated by spaces (or newline characters). 116 | -- uses the same syntax as 'parseEvidenceList', except only spaces and newline 117 | -- characters can separate the predicates. 118 | parseEvidenceLines :: String -> Either ParseError [(Predicate, Bool)] 119 | parseEvidenceLines = parse (contents parseEviLines) "" 120 | 121 | parseEviList :: Parser [(Predicate, Bool)] 122 | parseEviList = parsePredTruth `sepBy` (symbol "," <|> symbol ";" <|> symbol "and" <|> symbol "∩") 123 | 124 | parseEviLines :: Parser [(Predicate, Bool)] 125 | parseEviLines = many1 parsePredTruth 126 | 127 | parsePredTruth :: Parser (Predicate, Bool) 128 | parsePredTruth = 129 | try parseNegPred 130 | <|> try parsePredAss 131 | <|> do { p <- parsePredOnly; return (p, True) } 132 | 133 | parseNegPred :: Parser (Predicate, Bool) 134 | parseNegPred = do 135 | reservedOps ["!", "~"] 136 | p <- parsePredOnly 137 | return (p, False) 138 | 139 | parsePredOnly :: Parser Predicate 140 | parsePredOnly = do 141 | f <- parsePred 142 | return $ case f of Atom p -> p; _ -> Predicate "" [] 143 | 144 | parsePredAss :: Parser (Predicate, Bool) 145 | parsePredAss = do 146 | p <- parsePredOnly 147 | reservedOps ["->", "=", "==", ":=", "is"] 148 | t <- getTop <|> getBot 149 | return (p, t) 150 | 151 | parseJ :: Parser (Set (Predicate, Bool)) 152 | parseJ = do 153 | reservedOps ["P(", "p(", "Probability(", "probability("] 154 | query <- parseEviList 155 | reservedOp ")" 156 | return $ Set.fromList query 157 | 158 | -- Parse conditionals P(f1 | f2 -> true, f3 -> False, f4 -> T). 159 | parseQ :: Parser (Set (Predicate, Bool), Set (Predicate, Bool)) 160 | parseQ = do 161 | reservedOps ["P(", "p(", "Probability(", "probability("] 162 | query <- parseEviList 163 | reservedOps ["|", "\\mid", "given"] 164 | conds <- parseEviList 165 | reservedOp ")" 166 | return (Set.fromList query, Set.fromList conds) 167 | -------------------------------------------------------------------------------- /Akarui/Parser/Term.hs: -------------------------------------------------------------------------------- 1 | -- | Parsers for first-order logic and other important structures (e.g. Markov 2 | -- logic networks). 3 | module Akarui.Parser.Term ( 4 | parseFunForm, 5 | parseTerm 6 | ) where 7 | 8 | import Data.Char (isLower) 9 | import qualified Data.Text as T 10 | import Text.Parsec 11 | import Text.Parsec.String (Parser) 12 | import Akarui.Parser.Core 13 | import Akarui.FOL.Term 14 | 15 | -- | Parse function-like objects of the form Name(args0, args1, args2, ...). 16 | parseFunForm :: Parser (T.Text, [Term]) 17 | parseFunForm = do 18 | n <- identifier 19 | reservedOp "(" 20 | ts <- commaSep parseTerm 21 | reservedOp ")" 22 | return (T.pack n, ts) 23 | 24 | -- | Parse basic terms. 25 | parseTerm, parseVarCon, parseFunction :: Parser Term 26 | parseTerm = try parseFunction <|> parseVarCon 27 | 28 | parseFunction = do 29 | args <- parseFunForm 30 | return $ uncurry Function args 31 | 32 | parseVarCon = do 33 | n <- identifier 34 | return $ (if isLower $ head n then Variable else Constant) (T.pack n) 35 | -------------------------------------------------------------------------------- /Akarui/ShowTxt.hs: -------------------------------------------------------------------------------- 1 | module Akarui.ShowTxt 2 | ( ShowTxt(..) 3 | ) where 4 | 5 | import qualified Data.Text as T 6 | 7 | class (Show t) => ShowTxt t where 8 | showTxt :: t -> T.Text 9 | showTxt = T.pack . show 10 | -------------------------------------------------------------------------------- /Akarui/Text.hs: -------------------------------------------------------------------------------- 1 | -- | Useful (and private) functions to handle text. 2 | module Akarui.Text where 3 | 4 | import qualified Data.Text as T 5 | 6 | -- | Removes quotation marks from a string. 7 | rmQuotes :: T.Text -> T.Text 8 | rmQuotes = T.filter (/= '\"') 9 | 10 | -- | Builds a string with ", " between all elements. 11 | mkString :: [T.Text] -> T.Text 12 | mkString = foldr1 (\x acc -> T.concat [x, ", ", acc]) 13 | 14 | -- | Surrounds the string if b is true (used to print formulas). 15 | surrIf :: Bool -> T.Text -> T.Text 16 | surrIf b txt = if b then T.concat ["(", txt, ")"] else txt 17 | 18 | -- | Adds brackets arround a string. 19 | addBrackets :: T.Text -> T.Text 20 | addBrackets s = T.concat ["{", s, "}"] 21 | -------------------------------------------------------------------------------- /Akarui/Utils.hs: -------------------------------------------------------------------------------- 1 | -- | Useful functions with no place to call home (can you hear the violins?). 2 | module Akarui.Utils where 3 | 4 | import qualified Data.Map as Map 5 | import Data.Map (Map) 6 | import qualified Data.Set as Set 7 | import Data.Set (Set) 8 | 9 | -- | Checks whether 'c' is between 'l' and 'r' (including those). 10 | between :: (Ord a) => a -> a -> a -> Bool 11 | between l c r = if l <= c then c <= r else False 12 | 13 | -- | Max value in a map. 14 | maxVal :: (Ord k, Ord v) => Map k v -> v 15 | maxVal m = Map.foldr max f m 16 | where (_, f) = Map.findMax m 17 | 18 | -- | Max value in a map. 19 | minVal :: (Ord k, Ord v) => Map k v -> v 20 | minVal m = Map.foldr min f m 21 | where (_, f) = Map.findMin m 22 | 23 | -- | Converts a Map k v to a Map v (Set k) 24 | reverseMap :: (Ord k, Ord v) => Map k v -> Map v (Set k) 25 | reverseMap = Map.foldrWithKey (\k v acc -> Map.insert v (inSet k v acc) acc) Map.empty 26 | where 27 | -- If the key is absent, add a new set, otherwise insert in the set. 28 | inSet k v m = case Map.lookup v m of 29 | Just s -> Set.insert k s 30 | Nothing -> Set.fromList [k] 31 | 32 | -- | 'any' with a Map's keys. 33 | anyKey :: (Ord k) => (k -> Bool) -> Map k v -> Bool 34 | anyKey p = Map.foldrWithKey (\key _ acc -> acc || p key) False 35 | 36 | -- | 'all' with a Map's keys. 37 | allKeys :: (Ord k) => (k -> Bool) -> Map k v -> Bool 38 | allKeys p = Map.foldrWithKey (\key _ acc -> acc && p key) True 39 | 40 | -- | 'any' with a Map's keys and values 41 | anyKeyVal :: (Ord k) => (k -> v -> Bool) -> Map k v -> Bool 42 | anyKeyVal p = Map.foldrWithKey (\key val acc -> acc || p key val) False 43 | 44 | -- | 'all' with a Map's keys. 45 | allKeyVal :: (Ord k) => (k -> v -> Bool) -> Map k v -> Bool 46 | allKeyVal p = Map.foldrWithKey (\key val acc -> acc && p key val) True 47 | 48 | -- | Builds a set of tuple from a map. 49 | mapToSet :: (Ord k, Ord v) => Map k v -> Set (k, v) 50 | mapToSet = Map.foldrWithKey (\k v acc -> Set.insert (k, v) acc) Set.empty 51 | 52 | -- | Strict left set fold without an initial value (it's the min of the set). 53 | sfoldl1' :: (Ord a) => (a -> a -> a) -> Set a -> a 54 | sfoldl1' f s = Set.foldl' f first rest 55 | where 56 | first = Set.findMin s 57 | rest = Set.delete first s 58 | 59 | -- | Strict right set fold without an initial value (it's the max of the set). 60 | sfoldr1' :: (Ord a) => (a -> a -> a) -> Set a -> a 61 | sfoldr1' f s = Set.foldr' f first rest 62 | where 63 | first = Set.findMax s 64 | rest = Set.delete first s 65 | 66 | -- | Surrounds a list. 67 | surround :: a -> [a] -> [a] 68 | surround e ls = (e : ls) ++ [e] 69 | 70 | -- | Drops the last two items of a list. 71 | dropLst2 :: [a] -> [a] 72 | dropLst2 = init . init 73 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | In the interest of fostering an open and welcoming environment, we as contributors and maintainers 6 | pledge to making participation in our project and our community a harassment-free experience for 7 | everyone, regardless of age, body size, disability, ethnicity, gender identity and expression, 8 | level of experience, nationality, personal appearance, race, religion, or sexual identity and 9 | orientation. 10 | 11 | ## Our Standards 12 | 13 | Examples of behavior that contributes to creating a positive environment include: 14 | 15 | * Using welcoming and inclusive language 16 | * Being respectful of differing viewpoints and experiences 17 | * Gracefully accepting constructive criticism 18 | * Focusing on what is best for the community 19 | * Showing empathy towards other community members 20 | 21 | Examples of unacceptable behavior by participants include: 22 | 23 | * The use of sexualized language or imagery and unwelcome sexual attention or advances 24 | * Trolling, insulting/derogatory comments, and personal or political attacks 25 | * Public or private harassment 26 | * Publishing others' private information, such as a physical or electronic address, without explicit permission 27 | * Other conduct which could reasonably be considered inappropriate in a professional setting 28 | 29 | ## Our Responsibilities 30 | 31 | Project maintainers are responsible for clarifying the standards of acceptable behavior and are 32 | expected to take appropriate and fair corrective action in response to any instances of 33 | unacceptable behavior. 34 | 35 | Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, 36 | code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct, or 37 | to ban temporarily or permanently any contributor for other behaviors that they deem inappropriate, 38 | threatening, offensive, or harmful. 39 | 40 | ## Scope 41 | 42 | This Code of Conduct applies both within project spaces and in public spaces when an individual is 43 | representing the project or its community. Examples of representing a project or community include 44 | using an official project e-mail address, posting via an official social media account, or acting 45 | as an appointed representative at an online or offline event. Representation of a project may be 46 | further defined and clarified by project maintainers. 47 | 48 | ## Enforcement 49 | 50 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by contacting 51 | the project team at philippe.d.proulx@gmail.com. The project team will review and investigate all 52 | complaints, and will respond in a way that it deems appropriate to the circumstances. The project 53 | team is obligated to maintain confidentiality with regard to the reporter of an incident. Further 54 | details of specific enforcement policies may be posted separately. 55 | 56 | Project maintainers who do not follow or enforce the Code of Conduct in good faith may face 57 | temporary or permanent repercussions as determined by other members of the project's leadership. 58 | 59 | ## Attribution 60 | 61 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, available 62 | at [http://contributor-covenant.org/version/1/4][version] 63 | 64 | [homepage]: http://contributor-covenant.org 65 | [version]: http://contributor-covenant.org/version/1/4/ 66 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, and 10 | distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by the copyright 13 | owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all other entities 16 | that control, are controlled by, or are under common control with that entity. 17 | For the purposes of this definition, "control" means (i) the power, direct or 18 | indirect, to cause the direction or management of such entity, whether by 19 | contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the 20 | outstanding shares, or (iii) beneficial ownership of such entity. 21 | 22 | "You" (or "Your") shall mean an individual or Legal Entity exercising 23 | permissions granted by this License. 24 | 25 | "Source" form shall mean the preferred form for making modifications, including 26 | but not limited to software source code, documentation source, and configuration 27 | files. 28 | 29 | "Object" form shall mean any form resulting from mechanical transformation or 30 | translation of a Source form, including but not limited to compiled object code, 31 | generated documentation, and conversions to other media types. 32 | 33 | "Work" shall mean the work of authorship, whether in Source or Object form, made 34 | available under the License, as indicated by a copyright notice that is included 35 | in or attached to the work (an example is provided in the Appendix below). 36 | 37 | "Derivative Works" shall mean any work, whether in Source or Object form, that 38 | is based on (or derived from) the Work and for which the editorial revisions, 39 | annotations, elaborations, or other modifications represent, as a whole, an 40 | original work of authorship. For the purposes of this License, Derivative Works 41 | shall not include works that remain separable from, or merely link (or bind by 42 | name) to the interfaces of, the Work and Derivative Works thereof. 43 | 44 | "Contribution" shall mean any work of authorship, including the original version 45 | of the Work and any modifications or additions to that Work or Derivative Works 46 | thereof, that is intentionally submitted to Licensor for inclusion in the Work 47 | by the copyright owner or by an individual or Legal Entity authorized to submit 48 | on behalf of the copyright owner. For the purposes of this definition, 49 | "submitted" means any form of electronic, verbal, or written communication sent 50 | to the Licensor or its representatives, including but not limited to 51 | communication on electronic mailing lists, source code control systems, and 52 | issue tracking systems that are managed by, or on behalf of, the Licensor for 53 | the purpose of discussing and improving the Work, but excluding communication 54 | that is conspicuously marked or otherwise designated in writing by the copyright 55 | owner as "Not a Contribution." 56 | 57 | "Contributor" shall mean Licensor and any individual or Legal Entity on behalf 58 | of whom a Contribution has been received by Licensor and subsequently 59 | incorporated within the Work. 60 | 61 | 2. Grant of Copyright License. 62 | 63 | Subject to the terms and conditions of this License, each Contributor hereby 64 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, 65 | irrevocable copyright license to reproduce, prepare Derivative Works of, 66 | publicly display, publicly perform, sublicense, and distribute the Work and such 67 | Derivative Works in Source or Object form. 68 | 69 | 3. Grant of Patent License. 70 | 71 | Subject to the terms and conditions of this License, each Contributor hereby 72 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, 73 | irrevocable (except as stated in this section) patent license to make, have 74 | made, use, offer to sell, sell, import, and otherwise transfer the Work, where 75 | such license applies only to those patent claims licensable by such Contributor 76 | that are necessarily infringed by their Contribution(s) alone or by combination 77 | of their Contribution(s) with the Work to which such Contribution(s) was 78 | submitted. If You institute patent litigation against any entity (including a 79 | cross-claim or counterclaim in a lawsuit) alleging that the Work or a 80 | Contribution incorporated within the Work constitutes direct or contributory 81 | patent infringement, then any patent licenses granted to You under this License 82 | for that Work shall terminate as of the date such litigation is filed. 83 | 84 | 4. Redistribution. 85 | 86 | You may reproduce and distribute copies of the Work or Derivative Works thereof 87 | in any medium, with or without modifications, and in Source or Object form, 88 | provided that You meet the following conditions: 89 | 90 | You must give any other recipients of the Work or Derivative Works a copy of 91 | this License; and 92 | You must cause any modified files to carry prominent notices stating that You 93 | changed the files; and 94 | You must retain, in the Source form of any Derivative Works that You distribute, 95 | all copyright, patent, trademark, and attribution notices from the Source form 96 | of the Work, excluding those notices that do not pertain to any part of the 97 | Derivative Works; and 98 | If the Work includes a "NOTICE" text file as part of its distribution, then any 99 | Derivative Works that You distribute must include a readable copy of the 100 | attribution notices contained within such NOTICE file, excluding those notices 101 | that do not pertain to any part of the Derivative Works, in at least one of the 102 | following places: within a NOTICE text file distributed as part of the 103 | Derivative Works; within the Source form or documentation, if provided along 104 | with the Derivative Works; or, within a display generated by the Derivative 105 | Works, if and wherever such third-party notices normally appear. The contents of 106 | the NOTICE file are for informational purposes only and do not modify the 107 | License. You may add Your own attribution notices within Derivative Works that 108 | You distribute, alongside or as an addendum to the NOTICE text from the Work, 109 | provided that such additional attribution notices cannot be construed as 110 | modifying the License. 111 | You may add Your own copyright statement to Your modifications and may provide 112 | additional or different license terms and conditions for use, reproduction, or 113 | distribution of Your modifications, or for any such Derivative Works as a whole, 114 | provided Your use, reproduction, and distribution of the Work otherwise complies 115 | with the conditions stated in this License. 116 | 117 | 5. Submission of Contributions. 118 | 119 | Unless You explicitly state otherwise, any Contribution intentionally submitted 120 | for inclusion in the Work by You to the Licensor shall be under the terms and 121 | conditions of this License, without any additional terms or conditions. 122 | Notwithstanding the above, nothing herein shall supersede or modify the terms of 123 | any separate license agreement you may have executed with Licensor regarding 124 | such Contributions. 125 | 126 | 6. Trademarks. 127 | 128 | This License does not grant permission to use the trade names, trademarks, 129 | service marks, or product names of the Licensor, except as required for 130 | reasonable and customary use in describing the origin of the Work and 131 | reproducing the content of the NOTICE file. 132 | 133 | 7. Disclaimer of Warranty. 134 | 135 | Unless required by applicable law or agreed to in writing, Licensor provides the 136 | Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, 137 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, 138 | including, without limitation, any warranties or conditions of TITLE, 139 | NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are 140 | solely responsible for determining the appropriateness of using or 141 | redistributing the Work and assume any risks associated with Your exercise of 142 | permissions under this License. 143 | 144 | 8. Limitation of Liability. 145 | 146 | In no event and under no legal theory, whether in tort (including negligence), 147 | contract, or otherwise, unless required by applicable law (such as deliberate 148 | and grossly negligent acts) or agreed to in writing, shall any Contributor be 149 | liable to You for damages, including any direct, indirect, special, incidental, 150 | or consequential damages of any character arising as a result of this License or 151 | out of the use or inability to use the Work (including but not limited to 152 | damages for loss of goodwill, work stoppage, computer failure or malfunction, or 153 | any and all other commercial damages or losses), even if such Contributor has 154 | been advised of the possibility of such damages. 155 | 156 | 9. Accepting Warranty or Additional Liability. 157 | 158 | While redistributing the Work or Derivative Works thereof, You may choose to 159 | offer, and charge a fee for, acceptance of support, warranty, indemnity, or 160 | other liability obligations and/or rights consistent with this License. However, 161 | in accepting such obligations, You may act only on Your own behalf and on Your 162 | sole responsibility, not on behalf of any other Contributor, and only if You 163 | agree to indemnify, defend, and hold each Contributor harmless for any liability 164 | incurred by, or claims asserted against, such Contributor by reason of your 165 | accepting any such warranty or additional liability. 166 | 167 | END OF TERMS AND CONDITIONS 168 | 169 | APPENDIX: How to apply the Apache License to your work 170 | 171 | To apply the Apache License to your work, attach the following boilerplate 172 | notice, with the fields enclosed by brackets "[]" replaced with your own 173 | identifying information. (Don't include the brackets!) The text should be 174 | enclosed in the appropriate comment syntax for the file format. We also 175 | recommend that a file or class name and description of purpose be included on 176 | the same "printed page" as the copyright notice for easier identification within 177 | third-party archives. 178 | 179 | —- Exceptions to the Apache 2.0 License: —- 180 | 181 | In addition, if you combine or link compiled forms of this Software with 182 | software that is licensed under the GPLv2 (“Combined Software”) and if a court 183 | of competent jurisdiction determines that the patent provision (Section 3), the 184 | indemnity provision (Section 9) or other Section of the License conflicts with 185 | the conditions of the GPLv2, you may retroactively and prospectively choose to 186 | deem waived or otherwise exclude such Section(s) of the License, but only in 187 | their entirety and only with respect to the Combined Software. 188 | 189 | —- end —- 190 | 191 | ©2019-2020 Philippe Desjardins-Proulx 192 | 193 | Licensed under the Apache License, Version 2.0 (the "License"); 194 | you may not use this file except in compliance with the License. 195 | You may obtain a copy of the License at 196 | 197 | http://www.apache.org/licenses/LICENSE-2.0 198 | 199 | Unless required by applicable law or agreed to in writing, software 200 | distributed under the License is distributed on an "AS IS" BASIS, 201 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 202 | See the License for the specific language governing permissions and 203 | limitations under the License. 204 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 |

2 | logo 3 |

4 | 5 | Akarui is a fun functional library for experimenting with different reasoning systems (read the doc 6 | carefully: some stuff is experimental, some is fast, some is slow). 7 | 8 | Development is done on the 'develop' branch. 9 | 10 | ## Building 11 | [![Build Status](https://travis-ci.org/PhDP/Akarui.svg?branch=master)](https://travis-ci.org/PhDP/Akarui) 12 | 13 | Using Cabal, ghc's package manager, you can build the library with: 14 | 15 | $ cabal new-update 16 | $ cabal new-install --lib 17 | $ cabal new-configure --enable-tests 18 | $ cabal new-build 19 | $ cabal new-test 20 | 21 | After the library is compiled, simply type 22 | 23 | $ cabal new-repl 24 | 25 | ...to have access to the library in an interactive console. 26 | 27 | The code is fully documented, type 28 | 29 | $ cabal new-haddock 30 | 31 | to generate a local copy of the documentation. 32 | 33 | ## License 34 | 35 | The code is released under the permissive [Apache v2](http://www.apache.org/licenses/LICENSE-2.0) 36 | license, [along with an exception to ensure GPLv2 compatibility](https://lwn.net/Articles/701155/) 37 | see **LICENSE.md**. 38 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | import Distribution.Simple 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /tests/FOLSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module FOLSpec where 4 | 5 | import qualified Data.Text as T 6 | import Test.QuickCheck 7 | import Control.Monad 8 | import Akarui.FOL.Formula 9 | import Akarui.FOL.FOL 10 | import Akarui.FOL.Symbols 11 | import Akarui.FOL.BinT 12 | import Akarui.Parser.FOL 13 | import PredicateSpec 14 | 15 | genAtom :: Gen FOL 16 | genAtom = do 17 | p <- genPredicate 18 | return $ Atom p 19 | 20 | -- Missing: existential and universal Quantifiers: 21 | instance Arbitrary FOL where 22 | arbitrary = sized fol' 23 | where 24 | fol' 0 = elements [top, bot] 25 | fol' n = 26 | oneof 27 | [ elements [top, bot] 28 | , genAtom 29 | , liftM Not sub 30 | , liftM2 (BinOp And) sub sub 31 | , liftM2 (BinOp Or) sub sub 32 | , liftM2 (BinOp Implies) sub sub 33 | , liftM2 (BinOp Xor) sub sub 34 | , liftM2 (BinOp Iff) sub sub] 35 | where sub = fol' (n `div` 2) 36 | 37 | instance Arbitrary Symbols where 38 | arbitrary = elements [long, shouting, symbolic, semisymbolic] 39 | 40 | -- Tests if printing a formula and parsing the result yields back the original formula. 41 | prop_parsing_back :: Symbols -> FOL -> Bool 42 | prop_parsing_back s f = case parseFOL (T.unpack $ prettyPrintFm s f) of 43 | Left _ -> False 44 | Right f' -> f == f' 45 | 46 | -- Make sure Ord and Eq fit together. 47 | prop_fol_ord :: FOL -> FOL -> Bool 48 | prop_fol_ord f0 f1 = case f0 `compare` f1 of 49 | EQ -> f0 == f1 50 | _ -> f0 /= f1 51 | 52 | -- Equal to self. 53 | prop_fol_self_eq :: FOL -> Bool 54 | prop_fol_self_eq f = f `compare` f == EQ && f == f 55 | -------------------------------------------------------------------------------- /tests/PredicateSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module PredicateSpec where 4 | 5 | import Test.QuickCheck 6 | import Akarui.FOL.Predicate 7 | import TextGen 8 | import TermSpec 9 | import qualified Data.Text as T 10 | 11 | genPredicate :: Gen Predicate 12 | genPredicate = do 13 | name <- genPascalString 14 | args <- genTerms 15 | return $ Predicate (T.pack name) args 16 | 17 | instance Arbitrary Predicate where 18 | arbitrary = genPredicate 19 | 20 | prop_predicate_eq_itself :: Predicate -> Bool 21 | prop_predicate_eq_itself p0 = p0 == p0 22 | 23 | prop_predicate_cmp_itself :: Predicate -> Bool 24 | prop_predicate_cmp_itself p0 = p0 `compare` p0 == EQ 25 | 26 | -- Make sure Ord and Eq fit together. 27 | prop_predicate_ord :: Predicate -> Predicate -> Bool 28 | prop_predicate_ord p0 p1 = case p0 `compare` p1 of 29 | EQ -> p0 == p1 30 | _ -> p0 /= p1 31 | -------------------------------------------------------------------------------- /tests/Properties.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck 2 | import Test.QuickCheck.Test (isSuccess) 3 | import Control.Monad 4 | import System.Exit (exitFailure) 5 | import PredicateSpec 6 | import FOLSpec 7 | 8 | main :: IO () 9 | main = do 10 | let 11 | tests = 12 | [ quickCheckResult prop_predicate_eq_itself 13 | , quickCheckResult prop_predicate_cmp_itself 14 | , quickCheckResult prop_predicate_ord 15 | -- , quickCheckResult prop_parsing_back -- Will be reinstated once I figure out how to handle top/bot printing. 16 | , quickCheckResult prop_fol_ord 17 | , quickCheckResult prop_fol_self_eq 18 | ] 19 | success <- fmap (all isSuccess) . sequence $ tests 20 | unless success exitFailure 21 | -------------------------------------------------------------------------------- /tests/TermSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module TermSpec where 4 | 5 | import Data.Text as T 6 | import Test.QuickCheck 7 | import Akarui.FOL.Term 8 | import TextGen 9 | 10 | instance Arbitrary Term where 11 | arbitrary = oneof [genVar, genConst, genFun] 12 | 13 | genTerms :: Gen [Term] 14 | genTerms = sized $ \n -> do 15 | size <- choose (0, n `mod` 6) -- Huge lists of arguments make the test result hard to read / interpret. 16 | vectorOf size arbitrary 17 | 18 | genVar :: Gen Term 19 | genVar = do 20 | name <- genCamelString 21 | return $ Variable $ T.pack name 22 | 23 | genConst :: Gen Term 24 | genConst = do 25 | name <- genPascalString 26 | return $ Constant $ T.pack name 27 | 28 | genFun :: Gen Term 29 | genFun = do 30 | name <- genPascalString 31 | args <- genTerms 32 | return $ Function (T.pack name) args 33 | -------------------------------------------------------------------------------- /tests/TextGen.hs: -------------------------------------------------------------------------------- 1 | module TextGen where 2 | 3 | import Test.QuickCheck 4 | import Data.Char (isLower, isUpper) 5 | 6 | genLowerChar, genUpperChar :: Gen Char 7 | genLowerChar = elements ['a'..'z'] 8 | genUpperChar = elements ['A'..'Z'] 9 | 10 | -- A lower or upper-case character. 11 | genPascalChar :: Gen Char 12 | genPascalChar = oneof [genLowerChar, genUpperChar] 13 | 14 | -- A string of upper and lower-case characters. 15 | genLetterString :: Gen String 16 | genLetterString = listOf genPascalChar 17 | 18 | -- Generetate non-null strings with a restriction on the first letter. 19 | genStringFst :: (Char -> Bool) -> Gen String 20 | genStringFst f = suchThat genLetterString (\s -> not (null s) && f (head s)) 21 | 22 | -- A string in Pascal format. 23 | genPascalString :: Gen String 24 | genPascalString = genStringFst isUpper 25 | 26 | -- A string in camel format. 27 | genCamelString :: Gen String 28 | genCamelString = genStringFst isLower 29 | --------------------------------------------------------------------------------