├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── RSolve.cabal ├── Setup.hs ├── app └── Main.hs ├── deprecated └── src │ ├── Main.hs │ └── RSolve │ ├── BrMonad.hs │ ├── HM │ ├── Core.hs │ └── Example.hs │ ├── Infr.hs │ ├── Logic.hs │ └── Options │ ├── Core.hs │ └── Example.hs ├── package.yaml ├── src └── RSolve │ ├── HM.hs │ ├── Logic.hs │ ├── MapLike.hs │ ├── MultiState.hs │ ├── PropLogic.hs │ └── Solver.hs ├── stack.yaml └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## 1.0.0.0 2 | - 2019-08-04 3 | - Removed the general solver tentatively(for maintainability and good design). 4 | - Separated the logic formulas from the problem domains. 5 | - Removed the solver for `Options`. 6 | - Re-implemented the solver for `HM`. -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # RSolve 2 | 3 | [![](https://img.shields.io/hackage/v/RSolve.svg)](https://hackage.haskell.org/package/RSolve) 4 | 5 | NOTE: NO LONGER for general logic programming, this package is now dedicated for the simple propositional logic. 6 | 7 | The README is going to get updated. 8 | 9 | ## Propositional Logic 10 | 11 | RSolve uses [disjunctive normal form](https://en.wikipedia.org/wiki/Disjunctive_normal_form) to solve logic problems. 12 | 13 | This disjunctive normal form works naturally with the logic problems where the atom formulas can be generalized to an arbitrary equation in the problem domain by introducing a problem domain specific solver. A vivid 14 | example can be found at `RSolve.HM`, where 15 | I implemented an extended algo-W for [HM unification](https://en.wikipedia.org/wiki/Hindley%E2%80%93Milner_type_system). 16 | 17 | 18 | To take advantage of RSolve, we should implement 2 classes: 19 | 20 | - `AtomF`, which stands for the atom formula. 21 | 22 | - `CtxSolver`, which stands for the way to solve a bunch of atom formulas. 23 | 24 | However we might not need to a solver sometimes: 25 | 26 | ```haskell 27 | data Value = A | B | C | D 28 | deriving (Show, Eq, Ord, Enum) 29 | 30 | data At = At {at_l :: String, at_r :: Value} 31 | deriving (Show, Eq, Ord) 32 | 33 | instance AtomF At where 34 | notA At {at_l = lhs, at_r = rhs} = 35 | let wholeSet = enumFrom (toEnum 0) :: [Value] 36 | contrasts = delete rhs wholeSet 37 | in [At {at_l = lhs, at_r = rhs'} | rhs' <- contrasts] 38 | 39 | infix 6 <==> 40 | s <==> v = Atom $ At s v 41 | 42 | equations = do 43 | assert $ "a" <==> A :||: "a" <==> B 44 | assert $ Not ("a" <==> A) 45 | 46 | main = 47 | let equationGroups = unionEquations equations 48 | in forM equationGroups print 49 | ``` 50 | produces 51 | ```haskell 52 | [At {at_l = "a", at_r = A},At {at_l = "a", at_r = B}] 53 | [At {at_l = "a", at_r = A},At {at_l = "a", at_r = C}] 54 | [At {at_l = "a", at_r = A},At {at_l = "a", at_r = D}] 55 | [At {at_l = "a", at_r = B}] 56 | [At {at_l = "a", at_r = B},At {at_l = "a", at_r = C}] 57 | [At {at_l = "a", at_r = B},At {at_l = "a", at_r = C},At {at_l = "a", at_r = D}] 58 | [At {at_l = "a", at_r = B},At {at_l = "a", at_r = D}] 59 | ``` 60 | 61 | According to the property of the problem domain, we can figure out that 62 | only the 4-th(1-based indexing) equation group 63 | `[At {at_l = "a", at_r = B}]` 64 | will produce a feasible solution because symbol `a` can 65 | only hold one value. 66 | 67 | When do we need a solver? For instance, type checking&inference. 68 | 69 | In this case, we need type checking environments to represent the checking states: 70 | 71 | ```haskell 72 | data TCEnv = TCEnv { 73 | _noms :: M.Map Int T -- nominal type ids 74 | , _tvars :: M.Map Int T -- type variables 75 | , _neqs :: S.Set (T, T) -- negation constraints 76 | } 77 | deriving (Show) 78 | 79 | emptyTCEnv = TCEnv M.empty M.empty S.empty 80 | ``` 81 | 82 | For sure we also need to represent the type: 83 | 84 | ```haskell 85 | data T 86 | = TVar Int 87 | | TFresh String 88 | | T :-> T 89 | | T :* T -- tuple 90 | | TForall (S.Set String) T 91 | | TApp T T -- type application 92 | | TNom Int -- nominal type index 93 | deriving (Eq, Ord) 94 | ``` 95 | 96 | Then the atom formula of HM unification is: 97 | 98 | ```haskell 99 | data Unif 100 | = Unif { 101 | lhs :: T 102 | , rhs :: T 103 | , neq :: Bool -- lhs /= rhs or lhs == rhs? 104 | } 105 | deriving (Eq, Ord) 106 | ``` 107 | 108 | We then need to implement this: 109 | 110 | ```haskell 111 | -- class AtomF a => CtxSolver s a where 112 | -- solve :: a -> MS s () 113 | prune :: T -> MS TCEnv T -- MS: MultiState 114 | instance CtxSolver TCEnv Unif where 115 | solver = ... 116 | ```` 117 | 118 | Finally we got this: 119 | 120 | ```haskell 121 | infixl 6 <=> 122 | a <=> b = Atom $ Unif {lhs=a, rhs=b, neq=False} 123 | solu = do 124 | a <- newTVar 125 | b <- newTVar 126 | c <- newTVar 127 | d <- newTVar 128 | let [eqs] = unionEquations $ 129 | do 130 | assert $ TVar a <=> TForall (S.fromList ["s"]) ((TFresh "s") :-> (TFresh "s" :* TFresh "s")) 131 | assert $ TVar a <=> (TVar b :-> (TVar c :* TVar d)) 132 | assert $ TVar d <=> TNom 1 133 | -- return eqs 134 | forM_ eqs solve 135 | return eqs 136 | a <- prune $ TVar a 137 | b <- prune $ TVar b 138 | c <- prune $ TVar c 139 | return (a, b, c) 140 | 141 | test :: Eq a => String -> a -> a -> IO () 142 | test msg a b 143 | | a == b = return () 144 | | otherwise = print msg 145 | 146 | main = do 147 | forM (unionEquations equations) print 148 | 149 | let (a, b, c):_ = map fst $ runMS solu emptyTCEnv 150 | test "1 failed" (show a) "@t1 -> @t1 * @t1" 151 | test "2 failed" (show b) "@t1" 152 | test "3 failed" (show c) "@t1" 153 | ``` -------------------------------------------------------------------------------- /RSolve.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: e5b30745fe99238706cc93bcd6a0c1fe3d35090d5dc5cabf244120d6d382d56c 8 | 9 | name: RSolve 10 | version: 2.0.0.0 11 | description: A general solver for equations 12 | category: Logic,Unification 13 | homepage: https://github.com/thautwarm/RSolve#readme 14 | bug-reports: https://github.com/thautwarm/RSolve/issues 15 | author: thautwarm 16 | maintainer: twshere@outlook.com 17 | copyright: 2018, 2019 thautwarm 18 | license: MIT 19 | license-file: LICENSE 20 | build-type: Simple 21 | extra-source-files: 22 | README.md 23 | ChangeLog.md 24 | 25 | source-repository head 26 | type: git 27 | location: https://github.com/thautwarm/RSolve 28 | 29 | library 30 | exposed-modules: 31 | RSolve.HM 32 | RSolve.Logic 33 | RSolve.MapLike 34 | RSolve.MultiState 35 | RSolve.PropLogic 36 | RSolve.Solver 37 | other-modules: 38 | Paths_RSolve 39 | hs-source-dirs: 40 | src 41 | build-depends: 42 | base >=4.7 && <5 43 | , containers 44 | , lens 45 | , mtl 46 | default-language: Haskell2010 47 | 48 | executable RSolve-exe 49 | main-is: Main.hs 50 | other-modules: 51 | Paths_RSolve 52 | hs-source-dirs: 53 | app 54 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 55 | build-depends: 56 | RSolve 57 | , base >=4.7 && <5 58 | , containers 59 | , lens 60 | , mtl 61 | default-language: Haskell2010 62 | 63 | test-suite RSolve-test 64 | type: exitcode-stdio-1.0 65 | main-is: Spec.hs 66 | other-modules: 67 | Paths_RSolve 68 | hs-source-dirs: 69 | test 70 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 71 | build-depends: 72 | RSolve 73 | , base >=4.7 && <5 74 | , containers 75 | , lens 76 | , mtl 77 | default-language: Haskell2010 78 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | main = putStrLn "No CLI support yet" -------------------------------------------------------------------------------- /deprecated/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import RSolve.Options.Example 3 | import RSolve.HM.Example 4 | 5 | 6 | main = 7 | putStrLn "HM unification" >> 8 | hmUnificationExample >> 9 | putStrLn "4-option puzzles" >> 10 | optionExample 11 | 12 | 13 | 14 | -- test2 = do 15 | -- a <- store $ sol [A, B, C] 16 | -- b <- store $ sol [B, C, D] 17 | -- c <- store $ sol [C] 18 | -- _ <- solve $ a `eq` b 19 | -- _ <- solve $ b `neq` c 20 | -- _ <- solveNeg -- `Not` condition requires this 21 | -- _ <- solvePred -- unnecessary 22 | -- mapM require [a, b, c] 23 | 24 | -- main = do 25 | -- format ["a", "b", "c"] . nub . L.map fst 26 | -- $ runBr test2 emptyLState 27 | -------------------------------------------------------------------------------- /deprecated/src/RSolve/BrMonad.hs: -------------------------------------------------------------------------------- 1 | module RSolve.BrMonad where 2 | import Control.Monad 3 | import Control.Monad.Fail 4 | import Control.Applicative 5 | 6 | newtype Br s a = Br {runBr :: s -> [(a, s)]} 7 | 8 | instance Functor (Br s) where 9 | fmap = liftM 10 | 11 | instance Applicative (Br s) where 12 | pure = return 13 | (<*>) = ap 14 | 15 | instance MonadFail (Br s) where 16 | fail _ = empty 17 | 18 | instance Monad (Br s) where 19 | m >>= k = 20 | Br $ \s -> 21 | let xs = runBr m s 22 | in join [ runBr (k a) s | (a, s) <- xs] 23 | return a = Br $ \s -> [(a, s)] 24 | 25 | instance Alternative (Br s) where 26 | empty = Br $ const [] 27 | ma <|> mb = Br $ \s -> runBr ma s ++ runBr mb s 28 | 29 | getBy f = Br $ \s -> [(f s, s)] 30 | putBy f = Br $ \s -> [((), f s)] 31 | -------------------------------------------------------------------------------- /deprecated/src/RSolve/HM/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE TupleSections #-} 5 | -- https://github.com/thautwarm/reFining/blob/master/DotNet/reFining/reFining 6 | 7 | module RSolve.HM.Core where 8 | import RSolve.BrMonad 9 | import RSolve.Infr 10 | import RSolve.Logic 11 | import Control.Applicative 12 | import qualified Data.Map as M 13 | 14 | type Id = Int 15 | 16 | data TypeOp = Arrow | Join | Stmt 17 | deriving (Show, Eq, Ord) 18 | 19 | data Prim = Int | Float | Char 20 | deriving (Show, Eq, Ord) 21 | 22 | 23 | data Core where 24 | Prim :: Prim -> Core 25 | 26 | Op :: TypeOp -> Core -> Core -> Core 27 | 28 | Forall :: [Id] -> Core -> Core 29 | 30 | Var :: Id -> Core 31 | deriving (Eq) 32 | 33 | instance Show Core where 34 | show (Prim a) = show a 35 | show (Op Arrow a b) = 36 | "(" ++ show a ++ " -> " ++ show b ++ ")" 37 | show (Op Join a b) = show a ++ ", " ++ show b 38 | show (Op Stmt a b) = show a ++ ";\n" ++ show b 39 | show (Forall xs b) = 40 | let f a b = a ++ " a" ++ show b 41 | in foldl f "forall " xs ++ "." ++ show b 42 | show (Var a) = "a" ++ show a 43 | 44 | free :: M.Map Id Core -> Core -> Core 45 | free m = mkFree 46 | where 47 | mkFree a@(Prim _) = a 48 | mkFree (Op op a b) = Op op (mkFree a) (mkFree b) 49 | mkFree (Forall a b) = Forall a (mkFree b) 50 | mkFree a@(Var id) = 51 | M.findWithDefault a id m 52 | 53 | occurIn :: Addr -> Addr -> Br (LState Core) Bool 54 | occurIn l = contains . Var 55 | where 56 | contains (Prim _) = return False 57 | 58 | contains (Var a) = 59 | if a == l then return True 60 | else tryLoad a >>= \case 61 | Just a -> contains a 62 | _ -> return False 63 | 64 | contains (Op _ a b) = (||) <$> contains a <*> contains b 65 | contains (Forall _ a) = contains a 66 | 67 | instance Reference Core where 68 | mkRef = Var 69 | isRef (Var a) = Just a 70 | isRef _ = Nothing 71 | 72 | 73 | instance Unify Core where 74 | prune v@(Var a) = tryLoad a >>= \case 75 | Just var -> prune var 76 | _ -> return v 77 | 78 | prune a@(Prim _) = return a 79 | 80 | prune (Forall a b) = Forall a <$> prune b 81 | prune (Op op a b) = Op op <$> prune a <*> prune b 82 | 83 | unify (Prim a) (Prim b) = 84 | if a == b then return () 85 | else empty 86 | 87 | unify l@(Var a) r@(Var b) 88 | | a == b = return () 89 | | otherwise = do 90 | recursive <- occurIn a b 91 | if recursive 92 | then error "ill formed definition like a = a -> b" 93 | else update a r 94 | 95 | unify l r@(Var _) = unify r l 96 | 97 | unify (Var id) r = update id r 98 | 99 | -- type operators are not frist class 100 | unify (Op opl l1 l2) (Op opr r1 r2) = 101 | if opl /= opr then empty 102 | else 103 | unify l1 r1 >> unify l2 r2 104 | 105 | unify (Forall freevars poly) r = do 106 | pairs <- mapM freepair freevars 107 | let freemap = M.fromList pairs 108 | let l = free freemap poly 109 | unify l r 110 | where 111 | freepair freevar = (freevar,) <$> mkRef <$> new 112 | 113 | unify l r@(Forall _ _) = unify r l 114 | 115 | 116 | -------------------------------------------------------------------------------- /deprecated/src/RSolve/HM/Example.hs: -------------------------------------------------------------------------------- 1 | module RSolve.HM.Example where 2 | import RSolve.HM.Core 3 | import RSolve.BrMonad 4 | import RSolve.Infr 5 | import RSolve.Logic 6 | import Control.Monad 7 | 8 | test = do 9 | let i = Prim Int 10 | let f = Prim Float 11 | let arrow = Op Arrow i f 12 | 13 | -- u means undecided 14 | u1 <- new 15 | u2 <- new 16 | u3 <- new 17 | u4 <- new 18 | 19 | -- u1 -> u2 where u1, u2 is not generic 20 | let arrow_var = Op Arrow (Var u1) (Var u2) 21 | 22 | -- int -> int 23 | let arrow_inst1 = Op Arrow i i 24 | 25 | -- float -> float 26 | let arrow_inst2 = Op Arrow f f 27 | 28 | 29 | let arrow_match = Op Arrow (Var u4) (Var u4) 30 | 31 | -- a generic function 32 | let arrow_generic = Forall [u3] $ Op Arrow (Var u3) (Var u3) 33 | 34 | _ <- solve $ Unify arrow arrow_var 35 | _ <- solve $ Unify arrow_inst1 arrow_match 36 | _ <- solve $ Unify arrow_generic arrow_inst1 37 | _ <- solve $ Unify arrow_generic arrow_inst2 38 | _ <- solveNeg 39 | 40 | mapM require [Var u1, Var u2, arrow_inst1, arrow_inst2, arrow_generic, arrow_match] 41 | 42 | format :: [(String, Core)] -> IO () 43 | format [] = do 44 | putStrLn "=================" 45 | format ((a, b):xs) = do 46 | _ <- putStrLn $ a ++ " : " ++ show b 47 | format xs 48 | formayMany fields lst = 49 | forM_ [zip fields items | items <- lst] format 50 | 51 | 52 | hmUnificationExample = do 53 | let fields = ["u1", "u2", "arrow_inst1", "arrow_inst2", "arrow_generic", "arrow_match"] 54 | formayMany fields . map fst $ runBr test emptyLState 55 | -------------------------------------------------------------------------------- /deprecated/src/RSolve/Infr.hs: -------------------------------------------------------------------------------- 1 | module RSolve.Infr where 2 | import RSolve.BrMonad 3 | import Control.Applicative 4 | import qualified Data.Set as S 5 | import qualified Data.Map as M 6 | import qualified Data.List as L 7 | 8 | type Addr = Int 9 | class Eq a => Reference a where 10 | -- reference can be stored in Map 11 | isRef :: a -> Maybe Addr 12 | mkRef :: Addr -> a 13 | 14 | class Reference a => Unify a where 15 | prune :: a -> Br (LState a) a 16 | unify :: a -> a -> Br (LState a) () 17 | complement :: a -> a -> Br (LState a) () 18 | complement a b = 19 | if a == b then return () 20 | else empty 21 | 22 | class EnumSet a where 23 | toEnumerable :: Br (LState a) () 24 | 25 | 26 | data Allocator a = 27 | Allocator { storage :: M.Map Addr a 28 | , addr :: Addr } 29 | deriving (Show) 30 | 31 | 32 | data LState a = 33 | LState { allocator :: Allocator a 34 | , negPairs :: [(a, a)] 35 | , constrains :: [Br (LState a) Bool] } 36 | 37 | allocator' st (LState _ negs cs) = LState st negs cs 38 | negPairs' negs (LState st _ cs) = LState st negs cs 39 | constrains' cs (LState st negs _) = LState st negs cs 40 | 41 | 42 | inc :: Reference a => Allocator a -> (Addr, Allocator a) 43 | inc (Allocator s c) = (c, Allocator s $ c + 1) 44 | 45 | alloc :: Reference a => a -> Allocator a -> (Addr, Allocator a) 46 | alloc a (Allocator s c) = (c, Allocator (M.insert c a s) (c + 1)) 47 | 48 | renew :: Reference a => Addr -> a -> Allocator a -> Allocator a 49 | renew addr obj r@(Allocator s c) = 50 | case isRef obj of 51 | Just addr' | addr' == addr -> r -- avoid recursive definition 52 | _ -> Allocator (M.insert addr obj s) c 53 | 54 | store :: (Reference a, Eq a) => a -> Br (LState a) a 55 | store a = do 56 | st <- getBy allocator 57 | let (n, st') = alloc a st 58 | _ <- putBy $ allocator' st' 59 | return $ mkRef n 60 | 61 | 62 | -- update state 63 | update :: Reference a => Addr -> a -> Br (LState a) () 64 | update addr obj = getBy allocator >>= putBy . allocator' . renew addr obj 65 | 66 | 67 | load :: Addr -> Br (LState a) a 68 | load addr = 69 | ((M.! addr) . storage) <$> getBy allocator 70 | 71 | 72 | tryLoad :: Addr -> Br (LState a) (Maybe a) 73 | tryLoad addr = 74 | (M.lookup addr . storage) <$> getBy allocator 75 | 76 | 77 | -- for the system which take leverage of generics 78 | new :: Reference a => Br (LState a) Addr 79 | new = do 80 | st <- getBy allocator 81 | let (addr', st') = inc st 82 | _ <- putBy $ allocator' st' 83 | return addr' 84 | 85 | negUnify :: Reference a => a -> a -> Br (LState a) () 86 | negUnify a b = do 87 | negs <- getBy negPairs 88 | if check negs then 89 | putBy $ negPairs' ((a, b) : negs) 90 | else return () 91 | where 92 | check [] = True 93 | check ((a', b'):xs) 94 | | (a', b') == (a, b) || (a', b') == (b, a) = False 95 | | otherwise = check xs 96 | 97 | 98 | emptyAllocator = Allocator M.empty 0 99 | emptyLState = LState emptyAllocator [] [] -------------------------------------------------------------------------------- /deprecated/src/RSolve/Logic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | module RSolve.Logic where 3 | import RSolve.BrMonad 4 | import RSolve.Infr 5 | import Data.List (nub) 6 | import Control.Applicative 7 | 8 | data Cond a where 9 | Unify :: Unify a => a -> a -> Cond a 10 | Not :: Cond a -> Cond a 11 | Pred :: Br (LState a) Bool -> Cond a 12 | 13 | Or :: Cond a -> Cond a -> Cond a 14 | And :: Cond a -> Cond a -> Cond a 15 | Imply :: Cond a -> Cond a -> Cond a 16 | 17 | solve :: Cond a -> Br (LState a) () 18 | solve (Unify l r) = do 19 | l <- prune l 20 | r <- prune r 21 | unify l r 22 | 23 | solve (Or l r) = 24 | solve l <|> solve (And (Not l) r) 25 | 26 | solve (And l r) = 27 | solve l >> solve r 28 | 29 | solve (Imply l r) = 30 | solve (Not l) <|> solve r 31 | 32 | solve (Pred c) = do 33 | cs <- getBy constrains 34 | putBy $ constrains' (c:cs) 35 | 36 | solve (Not emmm) = 37 | case emmm of 38 | Pred c -> solve $ Pred (not <$> c) 39 | Not emmm -> solve emmm 40 | Or l r -> solve $ And (Not l)(Not r) 41 | And l r -> solve $ Or (Not l)(Not r) 42 | Imply l r -> solve $ And l (Not r) 43 | Unify l r -> do 44 | l <- prune l 45 | r <- prune r 46 | negUnify l r 47 | 48 | solveNeg :: Unify a => Br (LState a) () 49 | solveNeg = do 50 | negs <- getBy negPairs 51 | negs <- pruneTuples negs 52 | solveNeg' $ nub (negs) 53 | where 54 | pruneTuples [] = return [] 55 | pruneTuples ((a, b):xs) = do 56 | a <- prune a 57 | b <- prune b 58 | xs' <- pruneTuples xs 59 | let 60 | process (Just a) (Just b) = x:xs 61 | where 62 | mkRef2 a b = (mkRef a, mkRef b) 63 | x = if a > b then mkRef2 a b else mkRef2 b a 64 | process _ _ = (a, b):xs' 65 | return $ process (isRef a) (isRef b) 66 | solveNeg' [] = return () 67 | solveNeg' ((a,b):xs) = 68 | (a `complement` b) >> solveNeg' xs 69 | 70 | solvePred :: EnumSet a => Br (LState a) () 71 | solvePred = do 72 | _ <- toEnumerable 73 | cs <- getBy constrains 74 | checkPredicate cs 75 | where 76 | checkPredicate [] = return () 77 | checkPredicate (x:xs) = do 78 | x <- x 79 | if x then checkPredicate xs 80 | else empty 81 | 82 | require :: Unify a => a -> Br (LState a) a 83 | require a = do 84 | a <- prune a 85 | case isRef a of 86 | Just a -> load a 87 | _ -> return a 88 | 89 | 90 | -------------------------------------------------------------------------------- /deprecated/src/RSolve/Options/Core.hs: -------------------------------------------------------------------------------- 1 | module RSolve.Options.Core where 2 | import RSolve.BrMonad 3 | import RSolve.Infr 4 | import RSolve.Logic 5 | import Control.Monad 6 | import Control.Applicative 7 | import Prelude hiding (not, or, and) 8 | import qualified Data.Set as S 9 | import qualified Data.Map as M 10 | import qualified Data.List as L 11 | 12 | data Option = A | B | C | D 13 | deriving (Eq, Show, Ord, Enum) 14 | 15 | data Term = Var Int | Sol (S.Set Option) 16 | deriving (Eq, Show) 17 | 18 | pruneSol :: Term -> Br (LState Term) (Int, Maybe (S.Set Option)) 19 | pruneSol (Var addr) = do 20 | t <- load addr 21 | case t of 22 | Var addr' -> do 23 | r @ (addrLast, _) <- pruneSol t 24 | update addr (Var addrLast) >> return r 25 | Sol lxs -> 26 | return (addr, Just lxs) 27 | -- if S.null lxs then error "emmm" 28 | -- else return (addr, Just lxs) 29 | 30 | pruneSol r @ (Sol xs) = 31 | store r >>= \(Var addr) -> 32 | return (addr, Just xs) 33 | 34 | instance Reference Term where 35 | isRef (Var addr) = Just addr 36 | isRef _ = Nothing 37 | mkRef a = Var a 38 | 39 | 40 | 41 | instance Unify Term where 42 | prune a = pruneSol a >>= return . Var . fst 43 | unify l r = 44 | pruneSol l >>= \(lFrom, lxsm) -> 45 | pruneSol r >>= \(rFrom, rxsm) -> 46 | case (lxsm, rxsm) of 47 | (Nothing, _) -> update lFrom (Var rFrom) 48 | (Just lxs, _) | S.null lxs -> empty 49 | (_, Just rxs) | S.null rxs -> empty 50 | (Just _, Nothing ) -> unify r l 51 | (Just lxs, Just rxs) -> 52 | let xs = S.intersection lxs rxs in 53 | if S.null xs 54 | then empty 55 | else do 56 | new <- store $ Sol xs 57 | update lFrom new >> update rFrom new 58 | 59 | complement l r = do 60 | (l, Just lxs) <- pruneSol l 61 | (r, Just rxs) <- pruneSol r 62 | case (S.size lxs, S.size rxs) of 63 | (1, 1) | lxs == rxs -> empty 64 | (1, 1) | lxs /= rxs -> return () 65 | (nl, nr) | nl < nr -> complement (Var r) (Var l) 66 | (nl, nr) | nl >= nr -> do 67 | let 68 | x:xs = L.map f . S.toList $ rxs 69 | f :: Option -> Br (LState Term) () 70 | f re = 71 | let lnew_set = S.delete re lxs 72 | in 73 | if S.null lnew_set 74 | then empty 75 | else do 76 | lnew <- store . Sol $ lnew_set 77 | rnew <- store . Sol . S.singleton $ re 78 | update l lnew >> update r rnew 79 | L.foldl (<|>) x xs 80 | 81 | instance EnumSet Term where 82 | toEnumerable = do 83 | st <- getBy $ storage . allocator 84 | M.foldlWithKey f (return ()) st 85 | where 86 | f :: Br (LState Term) () -> Addr -> Term -> Br (LState Term) () 87 | f a k b = 88 | case b of 89 | Var _ -> a 90 | Sol set -> 91 | let 92 | lst = S.toList set 93 | g :: [Option] -> Br (LState Term) () 94 | g [] = error "unexpected" 95 | g (x:xs) = do 96 | x <- store . Sol . S.singleton $ x 97 | let s = update k x 98 | case xs of 99 | [] -> s 100 | _ -> s <|> g xs 101 | in a >> g lst 102 | 103 | -------------------------------------------------------------------------------- /deprecated/src/RSolve/Options/Example.hs: -------------------------------------------------------------------------------- 1 | module RSolve.Options.Example where 2 | import RSolve.Options.Core 3 | import RSolve.BrMonad 4 | import RSolve.Infr 5 | import RSolve.Logic 6 | import Control.Monad 7 | import Prelude hiding (not, or, and) 8 | import qualified Data.Set as S 9 | import qualified Data.Map as M 10 | import qualified Data.List as L 11 | 12 | nub = L.nub 13 | sol = Sol . S.fromList 14 | total = [A, B, C, D] 15 | toSol a = do 16 | (_, Just b) <- pruneSol a 17 | if S.size b /= 1 then error $ show b 18 | else return $ S.elemAt 0 b 19 | eq a b = Unify a b 20 | neq a b = Not $ a `eq` b 21 | not = Not 22 | and = And 23 | or = Or 24 | (|-) a b = Imply a b 25 | 26 | (==>) :: Option -> (Cond Term) -> Term -> (Cond Term) 27 | (==>) a b c = c `eq` sol [a] `and` b 28 | 29 | (|||) :: (Term -> (Cond Term)) -> (Term -> Cond Term) -> (Term -> Cond Term) 30 | a ||| b = \t -> a t `or` b t 31 | 32 | for :: Term -> (Term -> Cond Term) -> Br (LState Term) () 33 | for a f = solve $ f a 34 | 35 | infixr 7 `eq`, `neq` 36 | infixr 5 `or` 37 | infixr 6 `and`, |- 38 | infixr 4 ==> 39 | infixr 3 ||| 40 | 41 | test = do 42 | _1 <- store $ sol total 43 | _2 <- store $ sol total 44 | _3 <- store $ sol total 45 | _4 <- store $ sol total 46 | _5 <- store $ sol total 47 | _6 <- store $ sol total 48 | _7 <- store $ sol total 49 | _8 <- store $ sol total 50 | _9 <- store $ sol total 51 | _10 <- store $ sol total 52 | _ <- for _2 $ 53 | A ==> _5 `eq` sol [C] ||| 54 | B ==> _5 `eq` sol [D] ||| 55 | C ==> _5 `eq` sol [A] ||| 56 | D ==> _5 `eq` sol [B] 57 | _ <- for _3 $ 58 | let 59 | diff3 :: [Term] -> Term -> Cond Term 60 | diff3 lst a = 61 | let conds = [a `neq` e | e <- L.delete a lst] 62 | in case conds of 63 | [] -> error "emmm" 64 | x:xs -> L.foldl and x xs 65 | f = diff3 [_3, _6, _2, _4] 66 | in A ==> f _3 ||| 67 | B ==> f _6 ||| 68 | C ==> f _2 ||| 69 | D ==> f _4 70 | _ <- for _4 $ 71 | A ==> _1 `eq` _5 ||| 72 | B ==> _2 `eq` _7 ||| 73 | C ==> _1 `eq` _9 ||| 74 | D ==> _6 `eq` _10 75 | _ <- for _5 $ 76 | A ==> _5 `eq` _8 ||| 77 | B ==> _5 `eq` _4 ||| 78 | C ==> _5 `eq` _9 ||| 79 | D ==> _5 `eq` _7 80 | _ <- for _6 $ 81 | A ==> _2 `eq` _8 `and` _4 `eq` _8 ||| 82 | B ==> _1 `eq` _8 `and` _6 `eq` _8 ||| 83 | C ==> _3 `eq` _8 `and` _10 `eq` _8 ||| 84 | D ==> _5 `eq` _8 `and` _9 `eq` _8 85 | let 86 | solution = do 87 | mapM toSol [_1, _2, _3, _4, _5, _6, _7, _8, _9, _10] 88 | count :: Br (LState Term) (M.Map Option Int) 89 | count = do 90 | solution <- solution 91 | return . countImpl $ solution 92 | where 93 | countImpl :: [Option] -> M.Map Option Int 94 | countImpl [] = M.empty 95 | countImpl (x:xs) = M.alter f x $ countImpl xs 96 | f Nothing = Just 1 97 | f (Just a) = Just $ a + 1 98 | msearch cond = do 99 | count <- count 100 | return $ M.foldlWithKey f [] count 101 | where 102 | f [] k v = [(k, v)] 103 | f r@((k', v'):_) k v = 104 | case compare v v' of 105 | a | a == cond -> [(k, v)] 106 | EQ -> (k, v) : r 107 | _ -> r 108 | msearchNSuite :: (Int -> Int -> Bool) -> Option -> Br (LState Term) (Maybe Int) 109 | msearchNSuite cond opt = do 110 | count <- count 111 | case M.lookup opt count of 112 | Nothing -> do 113 | 114 | return (Just 0) 115 | Just n -> 116 | let 117 | f Nothing k v = Nothing 118 | f r@(Just a) k v = 119 | if cond v n then Nothing 120 | else r 121 | in return $ M.foldlWithKey f (Just n) count 122 | _ <- for _7 $ 123 | let minIs a = 124 | let m = do 125 | lst <- msearch LT 126 | return $ L.all (\(k, v) -> k == a) lst 127 | in Pred m 128 | in A ==> minIs C ||| 129 | B ==> minIs B ||| 130 | C ==> minIs A ||| 131 | D ==> minIs D 132 | _ <- for _8 $ 133 | let 134 | notAdjacent a b = do 135 | a <- toSol a 136 | b <- toSol b 137 | let sep = (fromEnum a - fromEnum b) 138 | return $ abs(sep) > 1 139 | in A ==> Pred (notAdjacent _1 _7) ||| 140 | B ==> Pred (notAdjacent _1 _5) ||| 141 | C ==> Pred (notAdjacent _1 _2) ||| 142 | D ==> Pred (notAdjacent _1 _10) 143 | _ <- for _9 $ 144 | let 145 | f x = 146 | let a = _1 `eq` _6 in 147 | let b = x `eq` _5 in 148 | not a `and` b `or` not b `and` a 149 | in A ==> f _6 ||| 150 | B ==> f _10 ||| 151 | C ==> f _2 ||| 152 | D ==> f _9 153 | _ <- for _10 $ 154 | let 155 | by a = 156 | Pred m 157 | where m = do 158 | (_, minCount):_ <- msearch LT 159 | (_, maxCount):_ <- msearch GT 160 | return $ maxCount - minCount == a 161 | in A ==> by 3 ||| 162 | B ==> by 2 ||| 163 | C ==> by 4 ||| 164 | D ==> by 1 165 | _ <- solveNeg 166 | _ <- solvePred 167 | mapM require [_1, _2, _3, _4, _5, _6, _7, _8, _9, _10] 168 | 169 | format :: [String] -> [[Term]] -> IO () 170 | format names xs = 171 | let 172 | formatCell :: (String, Term) -> IO() 173 | formatCell (a, b) = putStrLn $ show a ++ " : " ++ show b 174 | formatLine :: [(String, Term)] -> IO() 175 | formatLine xs = do 176 | _ <- putStrLn "====" 177 | forM_ xs formatCell 178 | formatLines xs = 179 | forM_ xs $ \line -> formatLine $ L.zip names line 180 | in formatLines xs 181 | 182 | 183 | 184 | optionExample = do 185 | format [show i | i <- [1..10]] . nub . L.map fst 186 | $ runBr test emptyLState -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: RSolve 2 | version: 1.0.0.0 3 | github: "thautwarm/RSolve" 4 | license: MIT 5 | author: "thautwarm" 6 | maintainer: "twshere@outlook.com" 7 | copyright: "2018, 2019 thautwarm" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: A general solver for equations 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | - mtl 25 | - containers 26 | - lens 27 | library: 28 | source-dirs: 29 | - src 30 | 31 | executables: 32 | RSolve-exe: 33 | main: Main.hs 34 | source-dirs: app 35 | ghc-options: 36 | - -threaded 37 | - -rtsopts 38 | - -with-rtsopts=-N 39 | dependencies: 40 | - RSolve 41 | - base >=4.7 && <5 42 | 43 | tests: 44 | RSolve-test: 45 | main: Spec.hs 46 | source-dirs: test 47 | ghc-options: 48 | - -threaded 49 | - -rtsopts 50 | - -with-rtsopts=-N 51 | dependencies: 52 | - RSolve 53 | - base >=4.7 && <5 -------------------------------------------------------------------------------- /src/RSolve/HM.hs: -------------------------------------------------------------------------------- 1 | -- | HM unification implementations based on propositional logics, 2 | -- based on nominal type system. 3 | -- Author: Taine Zhao(thautwarm) 4 | -- Date: 2019-08-04 5 | -- License: MIT 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE NamedFieldPuns #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TupleSections #-} 10 | {-# LANGUAGE ViewPatterns #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | 13 | module RSolve.HM 14 | where 15 | import RSolve.Logic 16 | import RSolve.Solver 17 | import RSolve.MultiState 18 | import Control.Lens (Lens', view, over, makeLenses) 19 | import Control.Applicative 20 | import Control.Monad 21 | import Debug.Trace 22 | 23 | import qualified Data.List as L 24 | import qualified Data.Map as M 25 | import qualified Data.Set as S 26 | 27 | type Fix a = a -> a 28 | 29 | infixl 6 :->, :* 30 | 31 | data T 32 | = TVar Int 33 | | TFresh String 34 | | T :-> T 35 | | T :* T -- tuple 36 | | TForall (S.Set String) T 37 | | TApp T T -- type application 38 | | TNom Int -- nominal type index 39 | deriving (Eq, Ord) 40 | 41 | deConsTOp :: T -> Maybe (T -> T -> T, T, T) 42 | deConsTOp = \case 43 | a :-> b -> Just ((:->), a, b) 44 | a :* b -> Just ((:*), a, b) 45 | TApp a b -> Just (TApp, a, b) 46 | _ -> Nothing 47 | 48 | instance Show T where 49 | show = \case 50 | TVar idx -> "@" ++ show idx 51 | TFresh s -> s 52 | a :-> b -> showNest a ++ " -> " ++ show b 53 | a :* b -> showNest a ++ " * " ++ show b 54 | TForall l t -> "forall " ++ (unwords $ S.toList l) ++ ". " ++ show t 55 | TApp t1 t2 -> show t1 ++ " " ++ showNest t2 56 | TNom i -> "@t" ++ show i 57 | where 58 | showNest s 59 | | isNest s = "(" ++ show s ++ ")" 60 | | otherwise = show s 61 | isNest s = case s of 62 | TApp _ _ -> True 63 | TForall _ s -> isNest s 64 | _ :-> _ -> True 65 | _ :* _ -> True 66 | _ -> False 67 | 68 | data Unif 69 | = Unif { 70 | lhs :: T 71 | , rhs :: T 72 | , neq :: Bool 73 | } 74 | deriving (Eq, Ord) 75 | 76 | instance Show Unif where 77 | show Unif {lhs, rhs, neq} = 78 | let op = if neq then " /= " else " == " 79 | in show lhs ++ op ++ show rhs 80 | 81 | instance AtomF Unif where 82 | notA a@Unif {neq} = [a {neq = not neq}] 83 | 84 | data TCEnv = TCEnv { 85 | _noms :: M.Map Int T -- nominal type ids 86 | , _tvars :: M.Map Int T -- type variables 87 | , _neqs :: S.Set (T, T) -- negation constraints 88 | } 89 | deriving (Show) 90 | 91 | emptyTCEnv = TCEnv M.empty M.empty S.empty 92 | 93 | makeLenses ''TCEnv 94 | 95 | newTVar :: MS TCEnv Int 96 | newTVar = do 97 | i <- getsMS $ M.size . view tvars 98 | modifyMS $ over tvars $ M.insert i (TVar i) 99 | return i 100 | 101 | newTNom :: MS TCEnv Int 102 | newTNom = do 103 | i <- getsMS $ M.size . view noms 104 | modifyMS $ over noms $ M.insert i (TNom i) 105 | return i 106 | 107 | loadTVar :: Int -> MS TCEnv T 108 | loadTVar i = getsMS $ (M.! i) . view tvars 109 | 110 | occurIn :: Int -> T -> MS TCEnv Bool 111 | occurIn l = contains 112 | where 113 | contains (deConsTOp -> Just (_, a, b)) = (||) <$> contains a <*> contains b 114 | contains (TNom _) = return False 115 | contains (TForall _ a) = contains a 116 | contains (TFresh _) = return False 117 | contains (TVar a) 118 | | a == l = return True 119 | | otherwise = do 120 | tvar <- loadTVar a 121 | case tvar of 122 | TVar a' | a' == a -> return False 123 | _ -> contains tvar 124 | 125 | free :: M.Map String T -> T -> T 126 | free m = mkFree 127 | where 128 | mkFree (deConsTOp -> Just (op, a, b)) = op (mkFree a) (mkFree b) 129 | mkFree a@(TNom i) = a 130 | mkFree (TForall n t) = TForall n $ flip free t $ M.withoutKeys m n 131 | mkFree a@(TVar _) = a 132 | mkFree a@(TFresh id) = M.findWithDefault a id m 133 | 134 | prune :: T -> MS TCEnv T 135 | prune = \case 136 | (deConsTOp -> Just (op, a, b)) -> op <$> prune a <*> prune b 137 | a@(TNom i) -> return a 138 | TVar i -> 139 | loadTVar i >>= \case 140 | a@(TVar i') | i' == i -> return a 141 | a -> do 142 | t <- prune a 143 | update i t 144 | return t 145 | 146 | a@(TFresh _) -> return a 147 | TForall a b -> TForall a <$> prune b 148 | 149 | update :: Int -> T -> MS TCEnv () 150 | update i t = modifyMS $ over tvars $ M.insert i t 151 | 152 | addNEq :: (T, T) -> MS TCEnv () 153 | addNEq t = modifyMS $ over neqs (S.insert t) 154 | 155 | unify :: Fix (Unif -> MS TCEnv ()) 156 | unify self Unif {lhs, rhs, neq=True} = addNEq (lhs, rhs) 157 | 158 | unify self Unif {lhs=TNom a, rhs=TNom b} 159 | | a == b = return () 160 | | otherwise = empty 161 | 162 | unify self Unif {lhs=TVar a, rhs = TVar b} = do 163 | recursive <- occurIn a (TVar b) 164 | if recursive 165 | then error "ill formed definition like a = a -> b" 166 | else update a (TVar b) 167 | 168 | unify self Unif {lhs=TVar id, rhs, neq} = update id rhs 169 | 170 | unify self a@Unif {lhs, rhs=rhs@(TVar _)} = self a {lhs=rhs, rhs=lhs} 171 | 172 | -- type operators are not frist class 173 | unify self Unif {lhs=l1 :-> l2, rhs= r1 :-> r2} = 174 | self Unif {lhs=l1, rhs=r1, neq=False} >> 175 | self Unif {lhs=l2, rhs=r2, neq=False} 176 | 177 | unify self Unif {lhs=l1 :* l2, rhs= r1 :* r2} = 178 | self Unif {lhs=l1, rhs=r1, neq=False} >> 179 | self Unif {lhs=l2, rhs=r2, neq=False} 180 | 181 | -- TODO: type aliases? 182 | unify self Unif {lhs=TApp l1 l2, rhs= TApp r1 r2} = 183 | self Unif {lhs=l1, rhs=r1, neq=False} >> 184 | self Unif {lhs=l2, rhs=r2, neq=False} 185 | 186 | unify self Unif {lhs=TForall freevars poly, rhs} = do 187 | pairs <- mapM freepair $ S.toList freevars 188 | let freemap = M.fromList pairs 189 | let l = free freemap poly 190 | self Unif {lhs=l, rhs=rhs, neq=False} 191 | where freepair freevar = (freevar,) . TVar <$> newTVar 192 | 193 | unify self a@Unif {lhs, rhs=rhs@(TForall _ _)} = 194 | self a {lhs=rhs, rhs=lhs} 195 | 196 | instance CtxSolver TCEnv Unif where 197 | solve = 198 | let frec = unify (pruneUnif >=> frec) 199 | in pruneUnif >=> frec 200 | where 201 | pruneUnif a@Unif {neq=True} = return a 202 | pruneUnif a@Unif {lhs, rhs} = do 203 | lhs <- prune lhs 204 | rhs <- prune rhs 205 | return $ a {lhs=lhs , rhs=rhs} 206 | 207 | 208 | 209 | -------------------------------------------------------------------------------- /src/RSolve/Logic.hs: -------------------------------------------------------------------------------- 1 | module RSolve.Logic where 2 | 3 | -- atom formula 4 | class (Show a, Ord a) => AtomF a where 5 | -- | Specifies how to handle the negations. 6 | -- For the finite and enumerable solutions, 7 | -- we can return its supplmentary set. 8 | notA :: a -> [a] -------------------------------------------------------------------------------- /src/RSolve/MapLike.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | 6 | module RSolve.MapLike where 7 | import Data.Maybe 8 | import Data.Kind 9 | import Prelude hiding (lookup, insert) 10 | import qualified Data.Map as M 11 | import qualified Data.List as L 12 | import qualified Data.Set as S 13 | 14 | class MapLike m k v | m -> k, m -> v where 15 | lookup :: k -> m -> Maybe v 16 | (!) :: m -> k -> v 17 | m ! k = fromJust (lookup k m) 18 | insert :: k -> v -> m -> m 19 | adjust :: (v -> v) -> k -> m -> m 20 | member :: k -> m -> Bool 21 | update :: (v -> Maybe v) -> k -> m -> m 22 | 23 | 24 | instance Ord k => MapLike (M.Map k v) k v where 25 | lookup = M.lookup 26 | (!) = (M.!) 27 | insert = M.insert 28 | adjust = M.adjust 29 | member = M.member 30 | update = M.update 31 | 32 | instance Eq k => MapLike [(k, v)] k v where 33 | lookup = L.lookup 34 | insert k v = \case 35 | [] -> [(k, v)] 36 | (k', v'):xs | k' == k -> (k, v):xs 37 | x:xs -> x:insert k v xs 38 | adjust f k = \case 39 | [] -> [] 40 | (k', v):xs | k' == k -> (k', f v):xs 41 | x:xs -> x:adjust f k xs 42 | k `member` m = case lookup k m of 43 | Just _ -> True 44 | Nothing -> False 45 | update f k = \case 46 | [] -> [] 47 | hd@(k', v):xs | k == k' -> 48 | case f v of 49 | Just v' -> (k, v'):tl 50 | Nothing -> hd:tl 51 | where tl = update f k xs -------------------------------------------------------------------------------- /src/RSolve/MultiState.hs: -------------------------------------------------------------------------------- 1 | -- | state monads extended to have branches 2 | -- Author: Taine Zhao(thautwarm) 3 | -- Date: 2018-12 4 | -- License: MIT 5 | module RSolve.MultiState where 6 | import Control.Monad 7 | import Control.Monad.Fail 8 | import Control.Applicative 9 | 10 | newtype MS s a = MS {runMS :: s -> [(a, s)]} 11 | 12 | instance Functor (MS s) where 13 | fmap = liftM 14 | 15 | instance Applicative (MS s) where 16 | pure = return 17 | (<*>) = ap 18 | 19 | instance MonadFail (MS s) where 20 | fail _ = empty 21 | 22 | instance Monad (MS s) where 23 | m >>= k = 24 | MS $ \s -> 25 | let xs = runMS m s 26 | in join [runMS (k a) s' | (a, s') <- xs] 27 | return a = MS $ \s -> [(a, s)] 28 | 29 | instance Alternative (MS s) where 30 | empty = MS $ const [] 31 | ma <|> mb = MS $ \s -> runMS ma s ++ runMS mb s 32 | 33 | getMS :: MS s s 34 | getMS = MS $ \s -> [(s, s)] 35 | 36 | putMS :: s -> MS s () 37 | putMS s = MS $ const [((), s)] 38 | 39 | getsMS :: (s -> a) -> MS s a 40 | getsMS f = MS $ \s -> [(f s, s)] 41 | 42 | modifyMS :: (s -> s) -> MS s () 43 | modifyMS f = MS $ \s -> [((), f s)] -------------------------------------------------------------------------------- /src/RSolve/PropLogic.hs: -------------------------------------------------------------------------------- 1 | -- | Propositional logic infrastructures 2 | -- Author: Taine Zhao(thautwarm) 3 | -- Date: 2019-08-03 4 | -- License: MIT 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE DeriveFunctor #-} 7 | 8 | module RSolve.PropLogic 9 | (AtomF(..), WFF(..), NF(..), assertNF, normal, assert, unionEquations) 10 | where 11 | 12 | import RSolve.Logic 13 | import RSolve.MultiState 14 | import Control.Applicative ((<|>)) 15 | import qualified Data.Set as S 16 | 17 | infixl 5 :&&, :&&: 18 | infixl 3 :||, :||:, :=>: 19 | 20 | data WFF a 21 | -- | Atom formula, should be specified by the problem 22 | = Atom a 23 | | Not (WFF a) 24 | -- | And 25 | | WFF a :&&: WFF a 26 | -- | Or 27 | | WFF a :||: WFF a 28 | -- | Implication 29 | | WFF a :=>: WFF a 30 | deriving (Functor, Eq, Ord) 31 | 32 | -- | normalized WWF, where '[NF a]' the disjunctive normal form. 33 | data NF a 34 | = AtomN a 35 | | NF a :&& NF a 36 | | NF a :|| NF a 37 | deriving (Functor, Eq, Ord) 38 | 39 | normal :: AtomF a => WFF a -> NF a 40 | normal = \case 41 | Atom a -> AtomN a 42 | p1 :&&: p2 -> normal p1 :&& normal p2 43 | p1 :||: p2 -> normal p1 :|| normal (Not p1 :&&: p2) 44 | Not (Atom a) -> 45 | case map AtomN $ notA a of 46 | hd:tl -> foldl (:||) hd tl 47 | [] -> error $ "Supplementary set of " ++ show a ++ " is empty!" 48 | Not (Not p) -> normal p 49 | Not (p1 :&&: p2) -> normal (Not p1) :|| normal (Not p2) 50 | Not (p1 :||: p2) -> normal (Not p1) :&& normal (Not p2) 51 | Not (p1 :=>: p2) -> normal (Not p1 :||: p2) 52 | 53 | assertNF :: AtomF a => NF a -> MS (S.Set a) () 54 | assertNF = \case 55 | AtomN a -> modifyMS (S.insert a) 56 | p1 :&& p2 -> assertNF p1 >> assertNF p2 57 | p1 :|| p2 -> assertNF p1 <|> assertNF p2 58 | 59 | 60 | -- | Use a propositinal logic formula to build logic equations 61 | -- incrementally. 62 | assert :: AtomF a => WFF a -> MS (S.Set a) () 63 | assert = assertNF . normal 64 | 65 | -- | Produced a list of disjunctions of conjunctive clauses. 66 | unionEquations :: AtomF a => MS (S.Set a) () -> [[a]] 67 | unionEquations m = 68 | -- get states 69 | let sts = map snd $ runMS m S.empty 70 | -- unique states 71 | in map S.toList . S.toList . S.fromList $ sts 72 | 73 | -------------------------------------------------------------------------------- /src/RSolve/Solver.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | module RSolve.Solver where 3 | import RSolve.Logic 4 | import RSolve.MultiState 5 | 6 | class AtomF a => CtxSolver s a where 7 | -- | Give a atom formula and solve it 8 | solve :: a -> MS s () -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-13.12 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | # extra-deps: [] 41 | 42 | # Override default flag values for local packages and extra-deps 43 | # flags: {} 44 | 45 | # Extra package databases containing global packages 46 | # extra-package-dbs: [] 47 | 48 | # Control whether we use the GHC we find on the path 49 | # system-ghc: true 50 | # 51 | # Require a specific version of stack, using version ranges 52 | # require-stack-version: -any # Default 53 | # require-stack-version: ">=1.9" 54 | # 55 | # Override the architecture used by stack, especially useful on Windows 56 | # arch: i386 57 | # arch: x86_64 58 | # 59 | # Extra directories used by stack for building 60 | # extra-include-dirs: [/path/to/dir] 61 | # extra-lib-dirs: [/path/to/dir] 62 | # 63 | # Allow a newer minor version of GHC than the snapshot specifies 64 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | -- import RSolve.Options.Example 2 | -- import RSolve.HM.Example 3 | 4 | 5 | -- test1 = 6 | -- putStrLn "HM unification" >> 7 | -- hmUnificationExample >> 8 | -- putStrLn "4-option puzzles" >> 9 | -- optionExample 10 | 11 | -- main = print 233 12 | 13 | 14 | -- test2 = do 15 | -- a <- store $ sol [A, B, C] 16 | -- b <- store $ sol [B, C, D] 17 | -- c <- store $ sol [C] 18 | -- _ <- solve $ a `eq` b 19 | -- _ <- solve $ b `neq` c 20 | -- _ <- solveNeg -- `Not` condition requires this 21 | -- _ <- solvePred -- unnecessary 22 | -- mapM require [a, b, c] 23 | 24 | -- main = do 25 | -- format ["a", "b", "c"] . nub . L.map fst 26 | -- $ runBr test2 emptyLState 27 | 28 | import RSolve.HM 29 | import RSolve.PropLogic 30 | import RSolve.MultiState 31 | import RSolve.Solver 32 | import Control.Monad 33 | 34 | import qualified Data.Set as S 35 | 36 | import Data.List (delete) 37 | import Control.Monad 38 | 39 | data Value = A | B | C | D 40 | deriving (Show, Eq, Ord, Enum) 41 | 42 | data At = At {at_l :: String, at_r :: Value} 43 | deriving (Show, Eq, Ord) 44 | 45 | instance AtomF At where 46 | notA At {at_l = lhs, at_r = rhs} = 47 | let wholeSet = enumFrom (toEnum 0) :: [Value] 48 | contrasts = delete rhs wholeSet 49 | in [At {at_l = lhs, at_r = rhs'} | rhs' <- contrasts] 50 | 51 | infix 6 <==> 52 | s <==> v = Atom $ At s v 53 | equations = do 54 | assert $ "a" <==> A :||: "a" <==> B 55 | assert $ "b" <==> C :||: "b" <==> D 56 | assert $ Not ("a" <==> A) 57 | assert $ Not ("a" <==> B :=>: "b" <==> C) 58 | 59 | 60 | infixl 6 <=> 61 | a <=> b = Atom $ Unif {lhs=a, rhs=b, neq=False} 62 | solu = do 63 | a <- newTVar 64 | b <- newTVar 65 | c <- newTVar 66 | d <- newTVar 67 | let [eqs] = unionEquations $ 68 | do 69 | assert $ TVar a <=> TForall (S.fromList ["s"]) ((TFresh "s") :-> (TFresh "s" :* TFresh "s")) 70 | assert $ TVar a <=> (TVar b :-> (TVar c :* TVar d)) 71 | assert $ TVar d <=> TNom 1 72 | forM_ eqs solve 73 | a <- prune $ TVar a 74 | b <- prune $ TVar b 75 | c <- prune $ TVar c 76 | return (a, b, c) 77 | 78 | test :: Eq a => String -> a -> a -> IO () 79 | test msg a b 80 | | a == b = return () 81 | | otherwise = print msg 82 | 83 | main = do 84 | forM (unionEquations equations) $ \xs -> 85 | case xs of 86 | [a, b] -> print xs 87 | _ -> return () 88 | 89 | let (a, b, c):_ = map fst $ runMS solu emptyTCEnv 90 | test "1 failed" (show a) "@t1 -> @t1 * @t1" 91 | test "2 failed" (show b) "@t1" 92 | test "3 failed" (show c) "@t1" --------------------------------------------------------------------------------