diff --git a/HaskHOL-Deductive.cabal b/HaskHOL-Deductive.cabal new file mode 100644 index 0000000..921a00a --- /dev/null +++ b/HaskHOL-Deductive.cabal @@ -0,0 +1,78 @@ +name: haskhol-deductive +version: 0.1.0 +synopsis: HaskHOL libraries for higher level deductive reasoning. +description: More details can be found at the following page: + http://haskhol.org. +license: BSD3 +license-file: LICENSE +author: Evan Austin +maintainer: Evan Austin +category: Theorem Provers +cabal-version: >=1.18 +build-type: Simple +stability: experimental +homepage: http://haskhol.org + +library + default-language: Haskell2010 + default-extensions: ConstraintKinds, DeriveDataTypeable, OverloadedStrings, + QuasiQuotes, TemplateHaskell, TypeFamilies + build-depends: base >= 4.7 + , template-haskell >= 2.9 + , pretty >= 1.1 + , haskhol-core >= 1.1 + + exposed-modules: + HaskHOL.Deductive + HaskHOL.Lib.Equal + HaskHOL.Lib.Bool + HaskHOL.Lib.DRule + HaskHOL.Lib.Tactics + HaskHOL.Lib.Itab + HaskHOL.Lib.Simp + HaskHOL.Lib.Theorems + HaskHOL.Lib.IndDefs + HaskHOL.Lib.Classic + HaskHOL.Lib.Trivia + HaskHOL.Lib.Canon + HaskHOL.Lib.Meson + HaskHOL.Lib.Quot + HaskHOL.Lib.Misc + HaskHOL.Lib.TypeQuant + + exposed: True + buildable: True + hs-source-dirs: src + + other-modules: + HaskHOL.Lib.Bool.Base + HaskHOL.Lib.Bool.Context + HaskHOL.Lib.Theorems.Base + HaskHOL.Lib.Theorems.Context + HaskHOL.Lib.IndDefs.Base + HaskHOL.Lib.IndDefs.Context + HaskHOL.Lib.Classic.A + HaskHOL.Lib.Classic.A.Base + HaskHOL.Lib.Classic.A.Context + HaskHOL.Lib.Classic.B + HaskHOL.Lib.Classic.B.Base + HaskHOL.Lib.Classic.B.Context + HaskHOL.Lib.Classic.C + HaskHOL.Lib.Classic.C.Base + HaskHOL.Lib.Classic.C.Context + HaskHOL.Lib.Classic.Base + HaskHOL.Lib.Classic.Context + HaskHOL.Lib.Trivia.A + HaskHOL.Lib.Trivia.A.Base + HaskHOL.Lib.Trivia.A.Context + HaskHOL.Lib.Trivia.Base + HaskHOL.Lib.Trivia.Context + HaskHOL.Lib.TypeQuant.Context + + ghc-prof-options: -prof -fprof-auto + ghc-options: -Wall -O2 + +source-repository head + type: git + location: git://github.com/ecaustin/haskhol-deductive.git + diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..2ed8770 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2013, University of Kansas +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/HaskHOL/Deductive.hs b/src/HaskHOL/Deductive.hs new file mode 100644 index 0000000..391746a --- /dev/null +++ b/src/HaskHOL/Deductive.hs @@ -0,0 +1,82 @@ +{-| + Module: HaskHOL.Deductive + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown + + This module is the one to import for users looking to include the entirety of + the deductive reasoning engine of the HaskHOL proof system. It re-exports all + of the deductive sub-modules; additionally, it exports aliases to a theory + context, quasi-quoter, and compile-time proof methods for users who are + working only with these libraries. +-} +module HaskHOL.Deductive + ( -- * Theory Context + -- $ThryCtxt + DeductiveType + , DeductiveCtxt + , ctxtDeductive + , deductive + -- * Re-exported Modules + , module HaskHOL.Lib.Equal + , module HaskHOL.Lib.Bool + , module HaskHOL.Lib.DRule + , module HaskHOL.Lib.Tactics + , module HaskHOL.Lib.Itab + , module HaskHOL.Lib.Simp + , module HaskHOL.Lib.Theorems + , module HaskHOL.Lib.IndDefs + , module HaskHOL.Lib.Classic + , module HaskHOL.Lib.Trivia + , module HaskHOL.Lib.Canon + , module HaskHOL.Lib.Meson + , module HaskHOL.Lib.Quot + , module HaskHOL.Lib.Misc + , module HaskHOL.Lib.TypeQuant + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Equal +import HaskHOL.Lib.Bool +import HaskHOL.Lib.DRule +import HaskHOL.Lib.Tactics +import HaskHOL.Lib.Itab +import HaskHOL.Lib.Simp +import HaskHOL.Lib.Theorems +import HaskHOL.Lib.IndDefs +import HaskHOL.Lib.Classic +import HaskHOL.Lib.Trivia +import HaskHOL.Lib.Canon +import HaskHOL.Lib.Meson +import HaskHOL.Lib.Quot +import HaskHOL.Lib.Misc +import HaskHOL.Lib.TypeQuant + +import HaskHOL.Lib.TypeQuant.Context + +{- $ThryCtxt + See 'extendCtxt' in the "HaskHOL.Core.Ext" module for more information. +-} + +{-| + The theory context type for the deductive libraries. + An alias to 'TypeQuantType'. +-} +type DeductiveType = TypeQuantType +type DeductiveCtxt a = TypeQuantCtxt a + +{-| + The theory context for the deductive libraries. + An alias to 'ctxtTypeQuant'. +-} +{-# NOINLINE ctxtDeductive #-} +ctxtDeductive :: TheoryPath DeductiveType +ctxtDeductive = ctxtTypeQuant + +-- | The quasi-quoter for the deductive libraries. An alias to 'typeQuant'. +deductive :: QuasiQuoter +deductive = typeQuant diff --git a/src/HaskHOL/Lib/Bool.hs b/src/HaskHOL/Lib/Bool.hs new file mode 100644 index 0000000..e249b0a --- /dev/null +++ b/src/HaskHOL/Lib/Bool.hs @@ -0,0 +1,1197 @@ +{-# LANGUAGE PatternSynonyms #-} +{-| + Module: HaskHOL.Lib.Bool + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown + + This module implements the boolean logic library for HaskHOL. Computations + and protected values that are sealed against the boolean theory context are + guarded with the 'BoolCtxt' type constraint. +-} +module HaskHOL.Lib.Bool + ( -- * Theory Context + -- $ThryCtxt + BoolType + , BoolCtxt + -- * General, Derived Rules + , rulePINST + , rulePROVE_HYP + -- * Derived Rules for Truth + , defT + , thmTRUTH + , ruleEQT_ELIM + , ruleEQT_INTRO + -- * Derived Rules for Conjunction + , defAND + , ruleCONJ + , ruleCONJUNCT1 + , ruleCONJUNCT2 + , ruleCONJ_PAIR + , ruleCONJUNCTS + -- * Derived Rules for Implication + , defIMP + , ruleMP + , ruleDISCH + , ruleDISCH_ALL + , ruleUNDISCH + , ruleUNDISCH_ALL + , ruleIMP_ANTISYM + , ruleADD_ASSUM + , ruleEQ_IMP + , ruleIMP_TRANS + -- * Derived Syntax and Rules for Universal Quantification + , defFORALL + , ruleSPEC + , ruleSPECL + , ruleSPEC_VAR + , ruleSPEC_ALL + , ruleISPEC + , ruleISPECL + , ruleGEN + , ruleGENL + , ruleGEN_ALL + -- * Derived Syntax and Rules for Existential Quantification + , defEXISTS + , ruleEXISTS + , ruleSIMPLE_EXISTS + , ruleCHOOSE + , ruleSIMPLE_CHOOSE + -- * Derived Rules for Disjunction + , defOR + , ruleDISJ1 + , ruleDISJ2 + , ruleDISJ_CASES + , ruleSIMPLE_DISJ_CASES + -- * Derived Rules for Negation and Falsity + , defFALSE + , def_FALSITY_ + , defNOT + , ruleNOT_ELIM + , ruleNOT_INTRO + , ruleEQF_INTRO + , ruleEQF_ELIM + , ruleCONTR + -- * Derived Rules for Unique Existence + , defEXISTS_UNIQUE + , ruleEXISTENCE + -- * Additional Definitions for Type Quantification + , defTY_FORALL + , defTY_EXISTS + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Equal + +import HaskHOL.Lib.Bool.Context + +{- $ThryCtxt + See 'templateTypes', 'extendCtxt', and 'templateProvers' in the + "HaskHOL.Core.Ext" module for more information about these types and values. +-} + + +--allows easy instantiation for pro forma theorems + +{-|@ + + [(ty1, tv1), ..., (tyn, tvn)] [(t1, x1), ..., (tn, xn)] A |- t +-------------------------------------------------------------------- + A[ty1, ..., tyn\/tv1, ..., tvn][t1, ..., tn\/x1, ..., xn] + |- t[ty1, ..., tyn\/tv1, ..., tvn][t1, ..., tn\/x1, ..., xn] +@ + + Fails with 'Nothing' if the provided term substitution environment is + ill-formed. +-} +rulePINST :: HOLTypeEnv -> HOLTermEnv -> HOLThm -> Maybe HOLThm +rulePINST tyenv tmenv thm = + primINST (map (first (inst tyenv)) tmenv) $ + primINST_TYPE tyenv thm + +--derived deductive rules + +{-|@ + A1 |- t1 A2 |- t2 +------------------------ + (A1 U A2) - t1 |- t2 +@ + + Never fails. +-} +rulePROVE_HYP :: HOLThm -> HOLThm -> HOLThm +rulePROVE_HYP athm@(Thm _ a) bthm@(Thm bs _) + | any (aConv a) bs = + fromRight $ primEQ_MP (primDEDUCT_ANTISYM athm bthm) athm + | otherwise = bthm +rulePROVE_HYP _ _ = error "rulePROVE_HYP: exhaustive warning." + +-- derived rules for truth +-- | @T = (\ p:bool . p) = (\ p:bool . p)@ +defT :: BoolCtxt thry => HOL cls thry HOLThm +defT = cacheProof "defT" ctxtBool $ getBasicDefinition "T" + +-- | @|- T@ +thmTRUTH :: BoolCtxt thry => HOL cls thry HOLThm +thmTRUTH = cacheProof "thmTRUTH" ctxtBool $ + do tm <- toHTm [str| \p:bool. p |] + tdef <- defT + liftO . liftM1 primEQ_MP (ruleSYM tdef) $ primREFL tm + +{-|@ + A |- t \<=\> T +---------------- + A |- t +@ + + Throws a 'HOLException' if the conclusion of the provided theorem is not of + the form @tm \<=\> T@. +-} +ruleEQT_ELIM :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm +ruleEQT_ELIM thm = + do truth <- thmTRUTH + liftEither "ruleEQT_ELIM" $ + liftM1 primEQ_MP (ruleSYM thm) truth + + +{-|@ + A |- t +-------------- + A |- t \<=\> T +@ + + Never fails. +-} +ruleEQT_INTRO :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm +ruleEQT_INTRO thm@(Thm _ c) = + do t <- serve [bool| t:bool |] + pth <- ruleEQT_INTRO_pth + let pth' = fromJust $ primINST [(t, c)] pth + liftO $ primEQ_MP pth' thm + where ruleEQT_INTRO_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleEQT_INTRO_pth = cacheProof "ruleEQT_INTRO" ctxtBool $ + do t <- toHTm "t:bool" + truth <- thmTRUTH + let th1 = fromRight $ primASSUME t + let th2@(Thm _ tm) = primDEDUCT_ANTISYM th1 truth + th3 <- ruleEQT_ELIM #<< primASSUME tm + return $! primDEDUCT_ANTISYM th3 th2 +ruleEQT_INTRO _ = error "exhaustive warning." + +-- derived rules for conjunction +-- | @(\/\\) = \\ p q . (\\ f:bool->bool->bool . f p q) = (\\ f . f T T)@ +defAND :: BoolCtxt thry => HOL cls thry HOLThm +defAND = cacheProof "defAND" ctxtBool $ getBasicDefinition "/\\" + +{-|@ + A1 |- t1 A2 |- t2 +------------------------ + A1 U A2 |- t1 \/\\ t2 +@ + + Never fails. +-} +ruleCONJ :: BoolCtxt thry => HOLThm -> HOLThm -> HOL cls thry HOLThm +ruleCONJ thm1@(Thm _ t1) thm2@(Thm _ t2) = + do p <- serve [bool| p:bool |] + q <- serve [bool| q:bool |] + pth <- ruleCONJ_pth + return . rulePROVE_HYP thm2 . rulePROVE_HYP thm1 . fromJust $ + primINST [(p, t1), (q, t2)] pth + where ruleCONJ_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleCONJ_pth = cacheProof "ruleCONJ_pth" ctxtBool $ + do f <- toHTm "f:bool->bool->bool" + p <- toHTm "p:bool" + q <- toHTm "q:bool" + dAnd <- defAND + eqpthm <- ruleEQT_INTRO #<< primASSUME p + eqqthm <- ruleEQT_INTRO #<< primASSUME q + let th1 = fromRight $ primABS f =<< + liftM1 primMK_COMB (ruleAP_TERM f eqpthm) eqqthm + th2 <- ruleBETA #<< liftM1 ruleAP_THM (ruleAP_THM dAnd p) q + liftO $ liftM1 primEQ_MP (ruleSYM th2) th1 +ruleCONJ _ _ = error "ruleCONJ: exhaustive warning." + +{-|@ + A |- t1 \/\\ t2 +--------------- + A |- t1 +@ + + Throws a 'HOLException' if the conclusion of the provided theorem is not a + conjunction. +-} +ruleCONJUNCT1 :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm + -> HOL cls thry HOLThm +ruleCONJUNCT1 pthm = + do p <- serve [bool| P:bool |] + q <- serve [bool| Q:bool |] + pth <- ruleCONJUNCT1_pth + thm <- toHThm pthm + case destConj $ concl thm of + Just (l, r) -> + return . rulePROVE_HYP thm . fromJust $ + primINST [(p, l), (q, r)] pth + _ -> fail "ruleCONJUNCT1: conclusion not a conjunction." + where ruleCONJUNCT1_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleCONJUNCT1_pth = cacheProof "ruleCONJUNCT1_pth" ctxtBool $ + do p <- toHTm "P:bool" + q <- toHTm "Q:bool" + pAndQ <- toHTm [str| P /\ Q |] + sel1 <- toHTm [str| \(p:bool) (q:bool). p |] + dAnd <- defAND + thm1 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM dAnd p + thm2 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM thm1 q + let thm3 = fromRight $ primEQ_MP thm2 =<< primASSUME pAndQ + ruleEQT_ELIM =<< ruleBETA #<< ruleAP_THM thm3 sel1 + +{-|@ + A |- t1 \/\\ t2 +--------------- + A |- t2 +@ + + Throws a 'HOLException' if the conclusion of the provided theorem is not a + conjunction. +-} +ruleCONJUNCT2 :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm + -> HOL cls thry HOLThm +ruleCONJUNCT2 = ruleCONJUNCT2' <=< toHThm + where ruleCONJUNCT2' :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm + ruleCONJUNCT2' thm = + do p <- serve [bool| P:bool |] + q <- serve [bool| Q:bool |] + pth <- ruleCONJUNCT2_pth + case destConj $ concl thm of + Just (l, r) -> + return . rulePROVE_HYP thm . fromJust $ + primINST [(p, l), (q, r)] pth + _ -> fail "ruleCONJUNCT2: conclusion not a conjunction." + + ruleCONJUNCT2_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleCONJUNCT2_pth = cacheProof "ruleCONJUNCT2_pth" ctxtBool $ + do p <- toHTm "P:bool" + q <- toHTm "Q:bool" + pAndQ <- toHTm [str| P /\ Q |] + sel2 <- toHTm [str| \(p:bool) (q:bool). q |] + dAnd <- defAND + thm1 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM dAnd p + thm2 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM thm1 q + let thm3 = fromRight $ primEQ_MP thm2 =<< primASSUME pAndQ + ruleEQT_ELIM =<< ruleBETA #<< ruleAP_THM thm3 sel2 + +{-|@ + A |- t1 \/\\ t2 +---------------------- + (A |- t1, A |- t2) +@ + + Throws a 'HOLException' if the conclusion of the theorem is not a conjunction. +-} +ruleCONJ_PAIR :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm + -> HOL cls thry (HOLThm, HOLThm) +ruleCONJ_PAIR pthm = + (do thm <- toHThm pthm + th1 <- ruleCONJUNCT1 thm + th2 <- ruleCONJUNCT2 thm + return (th1, th2)) + "ruleCONJ_PAIR" + +{-|@ + A |- t1 \/\\ t2 \/\\ ... \/\\ tn +----------------------------------- + [A |- t1, A |- t2, ..., A |- tn] +@ + + Never fails, but may have no effect. +-} +ruleCONJUNCTS :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm + -> HOL cls thry [HOLThm] +ruleCONJUNCTS = stripListM ruleCONJ_PAIR <=< toHThm + +--derived rules for implication +-- | @(==>) = \\ p q . p \/\\ q \<=\> p@ +defIMP :: BoolCtxt thry => HOL cls thry HOLThm +defIMP = cacheProof "defIMP" ctxtBool $ getBasicDefinition "==>" + +{-|@ + A1 |- t1 ==> t2 A2 |- t1 +---------------------------- + A1 U A2 |- t2 +@ + + Throws a 'HOLException' in the following cases: + + * Conclusion of first provided theorem is not an implication. + + * The antecedent of the implication is not alpha-equivalent to the conclusion + of the second provided theorem. +-} +ruleMP :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm -> HOLThm + -> HOL cls thry HOLThm +ruleMP th = liftM1 ruleMP' (toHThm th) + where ruleMP' :: BoolCtxt thry => HOLThm -> HOLThm -> HOL cls thry HOLThm + ruleMP' ithm@(Thm _ imp) thm@(Thm _ t1) = + noteHOL "ruleMP" $ + do p <- serve [bool| p:bool |] + q <- serve [bool| q:bool |] + pth <- ruleMP_pth + case destImp imp of + Just (ant, con) + | ant `aConv` t1 -> + return . rulePROVE_HYP thm . rulePROVE_HYP ithm . + fromJust $ primINST [(p, ant), (q, con)] pth + | otherwise -> fail "theorems do not agree." + _ -> fail "not an implication." + ruleMP' _ _ = error "ruleMP: exhaustive warning." + + ruleMP_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleMP_pth = cacheProof "ruleMP_pth" ctxtBool $ + do p <- toHTm "p:bool" + q <- toHTm "q:bool" + pImpQ <- toHTm "p ==> q" + dImp <- defIMP + let th1 = fromRight $ liftM1 ruleAP_THM (ruleAP_THM dImp p) q + th2 <- ruleBETA th1 + th3 <- fromRightM $ ruleSYM =<< primEQ_MP th2 =<< + primASSUME pImpQ + ruleCONJUNCT2 #<< primEQ_MP th3 =<< primASSUME p + +{-|@ + u A |- t +-------------------- + A - u |- u ==> t +@ + + Throws a 'HOLException' if the provided term is not a proposition. +-} +ruleDISCH :: (BoolCtxt thry, HOLTermRep tm cls thry) => tm -> HOLThm + -> HOL cls thry HOLThm +ruleDISCH tm = liftM1 ruleDISCH' (toHTm tm) + where ruleDISCH' :: BoolCtxt thry => HOLTerm -> HOLThm -> HOL cls thry HOLThm + ruleDISCH' a thm@(Thm _ t) = + (do p <- serve [bool| p:bool |] + q <- serve [bool| q:bool |] + pth <- ruleDISCH_pth + th1 <- ruleCONJ (fromRight $ primASSUME a) thm + th2 <- ruleCONJUNCT1 #<< primASSUME (concl th1) + let pth' = fromJust $ primINST [(p, a), (q, t)] pth + liftO . primEQ_MP pth' $ primDEDUCT_ANTISYM th1 th2) + "ruleDISCH" + ruleDISCH' _ _ = error "ruleDISCH: exhaustive warning." + + ruleDISCH_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleDISCH_pth = cacheProof "ruleDISCH_pth" ctxtBool $ + do p <- toHTm "p:bool" + q <- toHTm "q:bool" + dImp <- defIMP + liftM (fromRight . ruleSYM) $ + ruleBETA #<< liftM1 ruleAP_THM (ruleAP_THM dImp p) q + +{-|@ + A1, ..., An |- t +---------------------------- + |- A1 ==> ... ==> An ==> t +@ + + Never fails, but may have no effect. +-} +ruleDISCH_ALL :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm +ruleDISCH_ALL thm@(Thm a _) + | null a = return thm + | otherwise = + (ruleDISCH_ALL =<< ruleDISCH (head a) thm) <|> return thm +ruleDISCH_ALL _ = error "ruleDISCH_ALL: exhaustive warning." + + +{-|@ + A |- t1 ==> t2 +---------------- + A, t1 |- t2 +@ + + Throws a 'HOLException' if the conclusion of the provided theorem is not an + implication. +-} +ruleUNDISCH :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm +ruleUNDISCH thm@(Thm _ imp) = + (let tm = fromJust $ rand =<< rator imp in + ruleMP thm #<< primASSUME tm) "ruleUNDISCH" +ruleUNDISCH _ = error "ruleUNDISCH: exhaustive warning." + +{-|@ + A |- t1 ==> ... ==> tn ==> t +------------------------------ + A, t1, ..., tn |- t +@ + + Never fails, but may have no effect. +-} +ruleUNDISCH_ALL :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm +ruleUNDISCH_ALL th@(Thm _ c) + | isImp c = ruleUNDISCH_ALL =<< ruleUNDISCH th + | otherwise = return th +ruleUNDISCH_ALL _ = error "ruleUNDISCH_ALL: exhaustive warning." + +{-|@ + A1 |- t1 ==> t2 A2 |- t2 ==> t1 +------------------------------------- + A1 U A2 |- t1 \<=\> t2 +@ + + Throws a 'HOLException' if the conclusions of the provided theorems are not + complimentary implications. +-} +ruleIMP_ANTISYM :: BoolCtxt thry => HOLThm -> HOLThm -> HOL cls thry HOLThm +ruleIMP_ANTISYM thm1 thm2 = + (do th1 <- ruleUNDISCH thm1 + th2 <- ruleUNDISCH thm2 + return $! primDEDUCT_ANTISYM th2 th1) + "ruleIMP_ANTISYM" + +{-|@ + s A |- t +-------------- + A U s |- t +@ + + Throws a 'HOLException' if the provided term is not a proposition. +-} +ruleADD_ASSUM :: BoolCtxt thry => HOLTerm -> HOLThm -> HOL cls thry HOLThm +ruleADD_ASSUM tm thm = + (do th <- ruleDISCH tm thm + ruleMP th #<< primASSUME tm) + "ruleADD_ASSUM" + +{-|@ + A |- t1 \<=\> t2 +----------------------------------- + (A |- t1 ==> t2, A |- t2 ==> t1) +@ + + Throws a 'HOLException' if the conclusion of the theorem is not biconditional. +-} +ruleEQ_IMP :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm + -> HOL cls thry (HOLThm, HOLThm) +ruleEQ_IMP pthm = + (do p <- serve [bool| p:bool |] + q <- serve [bool| q:bool |] + pth1 <- ruleEQ_IMP_pth1 + pth2 <- ruleEQ_IMP_pth2 + thm <- toHThm pthm + let (l, r) = fromJust . destEq $ concl thm + (pth1', pth2') = fromJust $ pairMapM (primINST [(p, l), (q, r)]) + (pth1, pth2) + thm1 <- ruleMP pth1' thm + thm2 <- ruleMP pth2' thm + return (thm1, thm2)) + "ruleEQ_IMP" + where ruleEQ_IMP_pth1 :: BoolCtxt thry => HOL cls thry HOLThm + ruleEQ_IMP_pth1 = cacheProof "ruleEQ_IMP_pth1" ctxtBool $ + do peq <- toHTm "p <=> q" + let (p, _) = fromJust $ destEq peq + peqthm = fromRight $ primASSUME peq + ruleDISCH peq =<< ruleDISCH p #<< + primEQ_MP peqthm =<< primASSUME p + + ruleEQ_IMP_pth2 :: BoolCtxt thry => HOL cls thry HOLThm + ruleEQ_IMP_pth2 = cacheProof "ruleEQ_IMP_pth2" ctxtBool $ + do peq <- toHTm "p <=> q" + let (_, q) = fromJust $ destEq peq + peqthm = fromRight $ primASSUME peq + ruleDISCH peq =<< ruleDISCH q #<< + liftM1 primEQ_MP (ruleSYM peqthm) =<< primASSUME q + +{-|@ + A1 |- t1 ==> t2 A2 |- t2 ==> t3 +----------------------------------- + A1 U A2 |- t1 ==> t3 +@ + + Throws a 'HOLException' in the following cases: + + * The conclusions of the theorems are not implications. + + * The implications are not transitive. +-} +ruleIMP_TRANS :: BoolCtxt thry => HOLThm -> HOLThm -> HOL cls thry HOLThm +ruleIMP_TRANS thm1@(Thm _ imp1) thm2@(Thm _ imp2) = noteHOL "ruleIMP_TRANS" $ + do p <- serve [bool| p:bool |] + q <- serve [bool| q:bool |] + r <- serve [bool| r:bool |] + pth <- ruleIMP_TRANS_pth + case (destImp imp1, destImp imp2) of + (Just (x, y), Just (y', z)) + | y /= y' -> fail "implications are not transitive." + | otherwise -> + let pth' = fromJust $ + primINST [(p, x), (q, y), (r, z)] pth in + ruleMP (ruleMP pth' thm1) thm2 + _ -> fail "conclusions are not implications." + where ruleIMP_TRANS_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleIMP_TRANS_pth = cacheProof "ruleIMP_TRANS_pth" ctxtBool $ + do pq <- toHTm "p ==> q" + qr <- toHTm "q ==> r" + p <- toHTm "p:bool" + let qrth = fromRight $ primASSUME qr + pqth = fromRight $ primASSUME pq + mpth <- ruleMP qrth =<< ruleMP pqth #<< primASSUME p + foldrM ruleDISCH mpth [pq, qr, p] +ruleIMP_TRANS _ _ = error "ruleIMP_TRANS: exhaustive warning." + + +-- derived rules for forall +-- | @(!) = \\ P:A->bool . P = \\ x . T@ +defFORALL :: BoolCtxt thry => HOL cls thry HOLThm +defFORALL = cacheProof "defFORALL" ctxtBool $ getBasicDefinition "!" + +{-|@ + u A |- !x. t +---------------- + A |- t[u\/x] +@ + + Throws a 'HOLException' in the following cases: + + * Conclusion of the provided theorem is not universally quantified. + + * The type of the bound variable does not agree with the type of the provided + term. +-} +ruleSPEC :: (BoolCtxt thry, HOLTermRep tm cls thry, HOLThmRep thm cls thry) => + tm -> thm -> HOL cls thry HOLThm +ruleSPEC t = liftM1 ruleSPEC' (toHTm t) <=< toHThm + where ruleSPEC' :: BoolCtxt thry => HOLTerm -> HOLThm -> HOL cls thry HOLThm + ruleSPEC' tm thm@(Thm _ ab) = noteHOL "ruleSPEC" $ + do p <- serve [bool| P:A->bool |] + x <- serve [bool| x:A |] + pth <- ruleSPEC_pth + (ab', bvty) <- liftMaybe "conclusion not quantified." $ + do ab' <- rand ab + bvty <- liftM snd $ destVar =<< bndvar ab' + return (ab', bvty) + let pth' = fromJust $ + rulePINST [(tyA, bvty)] [(p, ab'), (x, tm)] pth + (ruleCONV convBETA =<< ruleMP pth' thm) "types do not agree." + ruleSPEC' _ _ = error "ruleSPEC: exhaustive warning." + + ruleSPEC_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleSPEC_pth = cacheProof "ruleSPEC_pth" ctxtBool $ + do p <- toHTm "P:A->bool" + x <- toHTm "x:A" + forallP <- toHTm "(!)(P:A->bool)" + dForall <- defFORALL + let th1 = fromRight $ ruleAP_THM dForall p + th2 <- ruleCONV convBETA #<< + primEQ_MP th1 =<< primASSUME forallP + th3 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM th2 x + ruleDISCH_ALL =<< ruleEQT_ELIM th3 + + +{-|@ + [u1, ..., un] A |- !x1 ... xn. t +--------------------------------------- + A |- t[u1, ..., un\/x1, ..., xn] +@ + + Iteratively applies 'ruleSPEC' using a provided list of specialization terms, + failing accordingly. +-} +ruleSPECL :: (BoolCtxt thry, HOLTermRep tm cls thry, HOLThmRep thm cls thry) + => [tm] -> thm -> HOL cls thry HOLThm +ruleSPECL tms pthm = noteHOL "ruleSPECL" $ + do thm <- toHThm pthm + foldlM (flip ruleSPEC) thm =<< mapM toHTm tms + +{-|@ + A |- !x. t +-------------------- + (x', A |- t[x'\/x]) +@ + + Applies 'ruleSPEC' using a 'variant' of the bound term, failing accordingly. +-} +ruleSPEC_VAR :: BoolCtxt thry => HOLThm -> HOL cls thry (HOLTerm, HOLThm) +ruleSPEC_VAR thm@(Thm _ x) = + (let v = fromJust $ bndvar =<< rand x + bv = variant (thmFrees thm) v in + do thm' <- ruleSPEC bv thm + return (bv, thm')) + "ruleSPEC_VAR: conclusion not quantified." +ruleSPEC_VAR _ = error "ruleSPEC_VAR: exhaustive warning." + +{-|@ + A |- !x1 ... xn. t +---------------------------------- + A |- t[x1', ..., xn'\/x1, ..., xn] +@ + + Never fails, but may have no effect. +-} +ruleSPEC_ALL :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm + -> HOL cls thry HOLThm +ruleSPEC_ALL thm = + do thm'@(Thm _ x) <- toHThm thm + if isForall x + then do (_, thm'') <- ruleSPEC_VAR thm' + ruleSPEC_ALL thm'' + else return thm' + +{-|@ + t:ty' A |- !x:ty.tm +--------------------------- + A[ty'\/ty] |- tm[t\/x] +@ + + A type instantiating version of 'ruleSPEC'. + Throws a 'HOLException' in the following cases: + + * The conclusion of the provided therem is not universally quantified. + + * A matching instantiation for the provided term and the bound term cannot be + found. +-} +ruleISPEC :: (BoolCtxt thry, HOLTermRep tm cls thry, + HOLThmRep thm cls thry) => tm -> thm + -> HOL cls thry HOLThm +ruleISPEC ptm pthm = noteHOL "ruleISPEC" $ + do thm@(Thm _ x) <- toHThm pthm + tm <- toHTm ptm + case destForall x of + Just (Var _ ty, _) -> + do tyenv <- liftMaybe "can't instantiate theorem." $ + typeMatch ty (typeOf tm) ([], [], []) + ruleSPEC tm (primINST_TYPE_FULL tyenv thm) + "type variable(s) free in assumption list." + _ -> fail "theorem not universally quantified." + +{-|@ + [t1:ty1', ..., tn:tyn'] A |- !x1:ty1 ... xn:tyn.t +----------------------------------------------------- + A[ty1', ..., tyn'\/ty1, ..., tyn] + |- t[t1, ..., tn\/x1, ..., xn] +@ + + Throws a 'HOLException' in the following cases: + + * The provided instantiation list is too long. + + * A satisfying instantiation cannot be found. +-} +ruleISPECL :: (BoolCtxt thry, HOLTermRep tm cls thry, HOLThmRep thm cls thry) + => [tm] -> thm -> HOL cls thry HOLThm +ruleISPECL [] thm = toHThm thm +ruleISPECL ptms pthm = noteHOL "ruleISPECL" $ + do tms <- mapM toHTm ptms + thm@(Thm _ x) <- toHThm pthm + let (vs, _) = stripForall x + (avs, _) <- liftMaybe "instantiation list too long." $ + chopList (length tms) vs + tyenv <- liftMaybe "can't instantiate theorem." $ + foldr2M tyFun ([], [], []) avs $ map typeOf tms + ruleSPECL tms (primINST_TYPE_FULL tyenv thm) + "type variable(s) free in assumption list." + where tyFun :: HOLTerm -> HOLType -> SubstTrip -> Maybe SubstTrip + tyFun (Var _ ty1) ty2 acc = typeMatch ty1 ty2 acc + tyFun _ _ _ = Nothing + +{-|@ + x A |- t +------------ + A |- !x. t +@ + + Throws a 'HOLException' in the following cases: + + * The provided term is not a variable. + + * The provided term is free in the assumption list of the provided theorem. +-} +ruleGEN :: (BoolCtxt thry, HOLTermRep tm cls thry, HOLThmRep thm cls thry) => tm + -> thm -> HOL cls thry HOLThm +ruleGEN tm thm = liftM1 ruleGEN' (toHTm tm) =<< toHThm thm + where ruleGEN' :: BoolCtxt thry => HOLTerm -> HOLThm -> HOL cls thry HOLThm + ruleGEN' x@(Var _ tyx) th = noteHOL "ruleGEN" $ + do qth <- liftM (primINST_TYPE [(tyA, tyx)]) $ ruleGEN_pth + let ptm = fromJust $ rand =<< rand (concl qth) + th1 <- ruleEQT_INTRO th + th2 <- liftO (primABS x th1) + "term free in the assumption list." + let phi = fromJust . lHand $ concl th2 + qth' = fromJust $ primINST [(ptm, phi)] qth + liftO $ primEQ_MP qth' th2 + ruleGEN' _ _ = fail "ruleGEN: term not a variable" + + ruleGEN_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleGEN_pth = cacheProof "ruleGEN_pth" ctxtBool $ + do p <- toHTm "P:A->bool" + dForall <- defFORALL + th <- ruleCONV (convRAND convBETA) #<< ruleAP_THM dForall p + liftO $ ruleSYM th + + +{-|@ + [x1, ..., xn] A |- t +-------------------------- + A |- !x1 ... xn. t +@ + + Throws a 'HOLException' in the following cases: + + * Any of the provided terms are not a variable. + + * Any of the provided terms are free in the assumption list. +-} +ruleGENL :: (BoolCtxt thry, HOLTermRep tm cls thry, HOLThmRep thm cls thry) => + [tm] -> thm -> HOL cls thry HOLThm +ruleGENL tms th = noteHOL "ruleGENL" $ + liftM1 (foldrM ruleGEN) (toHThm th) tms + +{-|@ + A |- t +-------------------- + A |- !x1 ... xn. t +@ + + Never fails, but may have no effect. +-} +ruleGEN_ALL :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm + -> HOL cls thry HOLThm +ruleGEN_ALL thm = + do thm'@(Thm asl c) <- toHThm thm + let vars = frees c \\ catFrees asl in + ruleGENL vars thm' + + +-- derived rules for exists +-- | @(?) = \\ P:A->bool . ! q . (! x . P x ==> q) ==> q@ +defEXISTS :: BoolCtxt thry => HOL cls thry HOLThm +defEXISTS = cacheProof "defEXISTS" ctxtBool $ getBasicDefinition "?" + +{-|@ + (?x. p) u A |- p[u\/x] +--------------------------- + A |- ?x. p +@ + + Throws a 'HOLException' in the following cases: + + * The first provided term is not existentially quantified. + + * The second provided term is not the witness that matches the conclusion of + the provided theorem. +-} +ruleEXISTS :: BoolCtxt thry => HOLTerm -> HOLTerm -> HOLThm + -> HOL cls thry HOLThm +ruleEXISTS (Comb _ ab) stm thm = + (do p <- serve [bool| P:A->bool |] + x <- serve [bool| x:A |] + pth <- ruleEXISTS_pth + th1 <- runConv convBETA #<< mkComb ab stm + let pth' = fromJust $ + rulePINST [(tyA, typeOf stm)] [(p, ab), (x, stm)] pth + th2 = fromRight $ liftM1 primEQ_MP (ruleSYM th1) thm + return $ rulePROVE_HYP th2 pth') + "ruleEXISTS: witness does not match provided theorem." + where ruleEXISTS_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleEXISTS_pth = cacheProof "ruleEXISTS_pth" ctxtBool $ + do p <- toHTm "P:A->bool" + pX <- toHTm "(P:A->bool) x" + fx <- toHTm "!x:A. P x ==> Q" + dExists <- defEXISTS + th1 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM dExists p + th2 <- ruleSPEC "x:A" #<< primASSUME fx + th3 <- ruleDISCH fx =<< ruleMP th2 #<< primASSUME pX + th4 <- ruleGEN "Q:bool" th3 + liftO $ liftM1 primEQ_MP (ruleSYM th1) th4 +ruleEXISTS _ _ _ = fail "ruleEXISTS: conclusion not existentially quantified." + +{-|@ + u A |- p +------------- + A |- ?u. p +@ + + Throws a 'HOLException' if the provided term is not a variable. +-} +ruleSIMPLE_EXISTS :: BoolCtxt thry => HOLTerm -> HOLThm -> HOL cls thry HOLThm +ruleSIMPLE_EXISTS v thm@(Thm _ p) = + (do v' <- mkExists v p + ruleEXISTS v' v thm) "ruleSIMPLE_EXISTS" +ruleSIMPLE_EXISTS _ _ = error "ruleSIMPLE_EXISTS: exhaustive warning." + + +{-|@ + v A1 |- ?x. s A2 |- t +------------------------------- + A1 U (A2 - s[v\/x]) |- t +@ + + Throws a 'HOLException' in the following cases: + + * The provided term is not a variable of appropriate type. + + * The conclusion of the first provided theorem is not existentially quantified + with a bound variable of same type as the provided term. + + * The provided term would be free in any part of the resultant theorem. +-} +ruleCHOOSE :: BoolCtxt thry => HOLTerm -> HOLThm -> HOLThm + -> HOL cls thry HOLThm +ruleCHOOSE v@(Var _ vty) thm1 thm2 = noteHOL "ruleCHOOSE" $ + do p <- serve [bool| P:A->bool |] + q <- serve [bool| Q:bool |] + pth <- ruleCHOOSE_pth + case rand $ concl thm1 of + Just ab@(Abs bv bod) -> + (let cmb = fromRight $ mkComb ab v + pat = fromJust $ varSubst [(bv, v)] bod in + do thm3 <- ruleCONV convBETA #<< primASSUME cmb + thm4 <- ruleGEN v =<< ruleDISCH cmb =<< + ruleMP (ruleDISCH pat thm2) thm3 + let thm5 = fromJust $ rulePINST [(tyA, vty)] + [(p, ab), (q, concl thm2)] pth + ruleMP (ruleMP thm5 thm4) thm1) + "provided term is free in resultant theorem." + _ -> fail "conclustion not existentially quantified." + where ruleCHOOSE_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleCHOOSE_pth = cacheProof "ruleCHOOSE_pth" ctxtBool $ + do p <- toHTm "P:A->bool" + dExists <- defEXISTS + th1 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM dExists p + (th2, _) <- ruleEQ_IMP th1 + th3 <- ruleSPEC "Q:bool" =<< ruleUNDISCH th2 + ruleDISCH_ALL =<< ruleDISCH "(?) (P:A->bool)" =<< + ruleUNDISCH th3 +ruleCHOOSE _ _ _ = fail "ruleCHOOSE: provided term not a variable." + +{-|@ + v [a1, ..., an] |- t +--------------------------- + [?v. a1 ... an] |- t +@ + + Throws a 'HOLException' in the following cases: + + * The provided term is not a variable. + + * The provided term is free in the conclusion of the provided theorem. +-} +ruleSIMPLE_CHOOSE :: BoolCtxt thry => HOLTerm -> HOLThm -> HOL cls thry HOLThm +ruleSIMPLE_CHOOSE v thm@(Thm a c) + | v `freeIn` c = fail "ruleSIMPLE_CHOOSE: provided term free in conclusion." + | otherwise = noteHOL "ruleSIMPLE_CHOOSE" $ + do v' <- mkExists v (head a) "provided term not a variable." + ruleCHOOSE v (fromRight $ primASSUME v') thm +ruleSIMPLE_CHOOSE _ _ = error "ruleSIMPLE_CHOOSE: exhaustive warning." + + +-- derived rules for disjunction +-- | @(\\\/) = \\ p q . ! r . (p ==> r) ==> (q ==> r) ==> r@ +defOR :: BoolCtxt thry => HOL cls thry HOLThm +defOR = cacheProof "defOR" ctxtBool $ getBasicDefinition "\\/" + +{-|@ + t2 A |- t1 +---------------- + A |- t1 \\/ t2 +@ + + Throws a 'HOLException' if the provided term is not a proposition. +-} +ruleDISJ1 :: BoolCtxt thry => HOLThm -> HOLTerm -> HOL cls thry HOLThm +ruleDISJ1 th tm = + (do p <- serve [bool| P:bool |] + q <- serve [bool| Q:bool |] + pth <- ruleDISJ1_pth + liftO . liftM (rulePROVE_HYP th) $ + primINST [(p, concl th), (q, tm)] pth) + "ruleDISJ1" + where ruleDISJ1_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleDISJ1_pth = cacheProof "ruleDISJ1_pth" ctxtBool $ + do p <- toHTm "P:bool" + q <- toHTm "Q:bool" + pit <- toHTm "P ==> t" + dOr <- defOR + th1 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM dOr p + th2 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM th1 q + th3 <- ruleMP (fromRight $ primASSUME pit) #<< primASSUME p + th4 <- ruleGEN "t:bool" =<< ruleDISCH pit =<< + ruleDISCH "Q ==> t" th3 + liftO $ liftM1 primEQ_MP (ruleSYM th2) th4 + +{-|@ + t1 A |- t2 +---------------- + A |- t1 \\/ t2 +@ + + Throws a 'HOLException' if the provided term is not a proposition. +-} +ruleDISJ2 :: BoolCtxt thry => HOLTerm -> HOLThm -> HOL cls thry HOLThm +ruleDISJ2 tm th = + (do p <- serve [bool| P:bool |] + q <- serve [bool| Q:bool |] + pth <- ruleDISJ2_pth + liftO . liftM (rulePROVE_HYP th) $ + primINST [(p, tm), (q, concl th)] pth) + "ruleDISJ2" + where ruleDISJ2_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleDISJ2_pth = cacheProof "ruleDISJ2_pth" ctxtBool $ + do p <- toHTm "P:bool" + q <- toHTm "Q:bool" + qit <- toHTm "Q ==> t" + dOr <- defOR + th1 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM dOr p + th2 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM th1 q + th3 <- ruleMP (fromRight $ primASSUME qit) #<< primASSUME q + th4 <- ruleGEN "t:bool" =<< ruleDISCH "P ==> t" =<< + ruleDISCH qit th3 + liftO $ liftM1 primEQ_MP (ruleSYM th2) th4 + + +{-|@ + A |- t1 \\/ t2 A1 |- t A2 |- t +--------------------------------------------- + A U (A1 - t1) U (A2 - t2) |- t +@ + + Throws a 'HOLException' in the following cases: + + * The conclusion of the first provided theorem is not a disjunction. + + * The conclusions of the last two provided theorems are not alpha-equivalent. +-} +ruleDISJ_CASES :: BoolCtxt thry => HOLThm -> HOLThm -> HOLThm + -> HOL cls thry HOLThm +ruleDISJ_CASES th0 th1@(Thm _ c1) th2@(Thm _ c2) + | not $ c1 `aConv` c2 = fail "ruleDISJ_CASES: conclusions not equivalent." + | otherwise = + do p <- serve [bool| P:bool |] + q <- serve [bool| Q:bool |] + r <- serve [bool| R:bool |] + pth <- ruleDISJ_CASES_pth + (l0, r0) <- liftMaybe "ruleDISJ_CASES: conclusion not a disjunction." $ + destDisj $ concl th0 + dth1 <- ruleDISCH r0 th2 + dth2 <- ruleDISCH l0 th1 + liftO . liftM (rulePROVE_HYP dth1 . rulePROVE_HYP dth2 . + rulePROVE_HYP th0) $ primINST [(p, l0), (q, r0), (r, c1)] pth + where ruleDISJ_CASES_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleDISJ_CASES_pth = cacheProof "ruleDISJ_CASES_pth" ctxtBool $ + do p <- toHTm "P:bool" + q <- toHTm "Q:bool" + pOrQ <- toHTm [str| P \/ Q |] + dOr <- defOR + thm1 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM dOr p + thm2 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM thm1 q + thm3 <- ruleSPEC "R:bool" #<< primEQ_MP thm2 =<< primASSUME pOrQ + ruleUNDISCH =<< ruleUNDISCH thm3 +ruleDISJ_CASES _ _ _ = error "ruleDISJ_CASES: exhaustive warning." + + +{-|@ + [p1, ..., pn] |- r [q1, ..., qn] |- r +-------------------------------------------------- + (p1 \\/ q1) U [p2, ..., pn] U [q2, ..., qn] |- r +@ + + Throws a 'HOLException' when the conclusions of the provided theorems are + not alpha-equivalent. +-} +ruleSIMPLE_DISJ_CASES :: BoolCtxt thry => HOLThm -> HOLThm + -> HOL cls thry HOLThm +ruleSIMPLE_DISJ_CASES th1@(Thm l _) th2@(Thm r _) = + (do tm <- mkDisj (head l) (head r) + ruleDISJ_CASES (fromRight $ primASSUME tm) th1 th2) + "ruleSIMPLE_DISJ_CASES" +ruleSIMPLE_DISJ_CASES _ _ = error "ruleSIMPLE_DISJ_CASE: exhaustive warning." + + +-- derived rules for negation +-- | @F = ! p:bool . p@ +defFALSE :: BoolCtxt thry => HOL cls thry HOLThm +defFALSE = cacheProof "defFALSE" ctxtBool $ getBasicDefinition "F" + +-- | @_FALSITY_ = F@ +def_FALSITY_ :: BoolCtxt thry => HOL cls thry HOLThm +def_FALSITY_ = cacheProof "def_FALSITY_" ctxtBool $ + getBasicDefinition "_FALSITY_" + +-- | @(~) = \\ p . p ==> F@ +defNOT :: BoolCtxt thry => HOL cls thry HOLThm +defNOT = cacheProof "defNOT" ctxtBool $ getBasicDefinition "~" + +{-|@ + A |- ~t +-------------- + A |- t ==> F +@ + + Throws a 'HOLException' if the conclusion of the provided theorem is not a + negated term. +-} +ruleNOT_ELIM :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm +ruleNOT_ELIM th@(Thm _ tm) = + (do p <- serve [bool| P:bool |] + pth <- ruleNOT_ELIM_pth + let tm' = fromJust $ rand tm + pth' = fromJust $ primINST [(p, tm')] pth + liftO $ primEQ_MP pth' th) + "ruleNOT_ELIM" + where ruleNOT_ELIM_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleNOT_ELIM_pth = cacheProof "ruleNOT_ELIM_pth" ctxtBool $ + do dnot <- defNOT + p <- toHTm "P:bool" + ruleCONV (convRAND convBETA) #<< ruleAP_THM dnot p +ruleNOT_ELIM _ = error "ruleNOT_ELIM: exhaustive warning." + +{-|@ + A |- t ==> F +-------------- + A |- ~t +@ + + Throws a 'HOLException' if the conclusion of the provided theorem is not of + the form @tm ==> F@. +-} +ruleNOT_INTRO :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm +ruleNOT_INTRO th@(Thm _ tm) = + (do p <- serve [bool| P:bool |] + pth <- ruleNOT_INTRO_pth + let tm' = fromJust $ rand =<< rator tm + pth' = fromJust $ primINST [(p, tm')] pth + liftO $ primEQ_MP pth' th) + "ruleNOT_INTO" + where ruleNOT_INTRO_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleNOT_INTRO_pth = cacheProof "ruleNOT_INTRO_pth" ctxtBool $ + do dnot <- defNOT + p <- toHTm "P:bool" + th1 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM dnot p + liftO $ ruleSYM th1 +ruleNOT_INTRO _ = error "ruleNOT_INTRO: exhaustive warning." + + +{-|@ + A |- ~t +--------------- + A |- t \<=\> F +@ + + Throws a 'HOLException' if the conclusion of the provided theorem is not a + negation. +-} +ruleEQF_INTRO :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm +ruleEQF_INTRO th = + (do p <- serve [bool| P:bool |] + pth <- ruleEQF_INTRO_pth + let tm = fromJust . rand $ concl th + pth' = fromJust $ primINST [(p, tm)] pth + ruleMP pth' th) + "ruleEQF_INTRO" + where ruleEQF_INTRO_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleEQF_INTRO_pth = cacheProof "ruleEQF_INTRO_pth" ctxtBool $ + do notP <- toHTm "~P" + f <- toHTm "F" + dFalse <- defFALSE + th1 <- ruleNOT_ELIM #<< primASSUME notP + th2 <- ruleDISCH f =<< ruleSPEC "P:bool" #<< + primEQ_MP dFalse =<< primASSUME f + ruleDISCH_ALL =<< ruleIMP_ANTISYM th1 th2 + +{-|@ + A |- t \<=\> F +--------------- + A |- ~t +@ + + Throws a 'HOLException' if the conclusion of the provided theorem is not of + the form @tm \<=\> F@. +-} +ruleEQF_ELIM :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm +ruleEQF_ELIM th = + (do p <- serve [bool| P:bool |] + pth <- ruleEQF_ELIM_pth + let tm = fromJust $ rand =<< rator (concl th) + pth' = fromJust $ primINST [(p, tm)] pth + ruleMP pth' th) + "ruleEQF_ELIM" + where ruleEQF_ELIM_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleEQF_ELIM_pth = cacheProof "ruleEQF_ELIM_pth" ctxtBool $ + do p <- toHTm "P:bool" + pEqF <- toHTm "P = F" + dFalse <- defFALSE + let th1 = fromRight $ primEQ_MP dFalse =<< + liftM1 primEQ_MP (primASSUME pEqF) =<< primASSUME p + ruleDISCH_ALL =<< ruleNOT_INTRO =<< ruleDISCH p =<< + ruleSPEC "F" th1 + +{-|@ + t A |- F +------------- + A |- t +@ + + Throws a 'HOLException' in the following cases: + + * The provided term is not a proposition. + + * The conclusion of the provided theorem is not @F@. +-} +ruleCONTR :: BoolCtxt thry => HOLTerm -> HOLThm -> HOL cls thry HOLThm +ruleCONTR tm th = noteHOL "ruleCONTR" $ + do f <- serve [bool| F |] + if concl th /= f + then fail "conclusion of theorem not false." + else do p <- serve [bool| P:bool |] + pth <- ruleCONTR_pth + liftO . liftM (rulePROVE_HYP th) $ primINST [(p, tm)] pth + where ruleCONTR_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleCONTR_pth = cacheProof "ruleCONTR_pth" ctxtBool $ + do f <- toHTm "F" + dFalse <- defFALSE + ruleSPEC "P:bool" #<< primEQ_MP dFalse #<< primASSUME f + +{-|@ + A |- ?!x. p +--------------- + A |- ?x. p +@ + + Throws a 'HOLException' when the conclusion of the provided theorem is not + unique-existentially quantified. +-} +ruleEXISTENCE :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm +ruleEXISTENCE th = + (do p <- serve [bool| P:A->bool |] + pth <- ruleEXISTENCE_pth + let ab = fromJust . rand $ concl th + ty = snd . fromJust $ destVar =<< bndvar ab + pth' = fromJust $ rulePINST [(tyA, ty)] [(p, ab)] pth + ruleMP pth' th) + "ruleEXISTENCE" + where ruleEXISTENCE_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleEXISTENCE_pth = cacheProof "ruleEXISTENCE_pth" ctxtBool $ + do p <- toHTm "P:A->bool" + dEU <- defEXISTS_UNIQUE + th1 <- ruleCONV (convRAND convBETA) #<< ruleAP_THM dEU p + th2 <- ruleUNDISCH =<< liftM fst (ruleEQ_IMP th1) + ruleDISCH_ALL =<< ruleCONJUNCT1 th2 + +-- Other definitions +-- | @(?!) = \\ P:A->bool . ((?) P) /\ (! x y . P x /\ P y ==> x = y)@ +defEXISTS_UNIQUE :: BoolCtxt thry => HOL cls thry HOLThm +defEXISTS_UNIQUE = cacheProof "defEXISTS_UNIQUE" ctxtBool $ + getBasicDefinition "?!" + +-- | @(!!) = \ P : (% 'A . bool). P = (\\ 'A . T)@ +defTY_FORALL :: BoolCtxt thry => HOL cls thry HOLThm +defTY_FORALL = cacheProof "defTY_FORALL" ctxtBool $ getBasicDefinition "!!" + +-- | @(??) = \ P : (% 'A . bool). ~(P = (\\ 'A . F))@ +defTY_EXISTS :: BoolCtxt thry => HOL cls thry HOLThm +defTY_EXISTS = cacheProof "defTY_EXISTS" ctxtBool $ getBasicDefinition "??" diff --git a/src/HaskHOL/Lib/Bool/Base.hs b/src/HaskHOL/Lib/Bool/Base.hs new file mode 100644 index 0000000..5a9704f --- /dev/null +++ b/src/HaskHOL/Lib/Bool/Base.hs @@ -0,0 +1,63 @@ +{-| + Module: HaskHOL.Lib.Bool.Base + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown + + This module defines the theory context extensions for the Boolean logic + library, including parser extensions and term definitions. +-} +module HaskHOL.Lib.Bool.Base where + +import HaskHOL.Core + +defT' :: HOL Theory thry HOLThm +defT' = newBasicDefinition "T" + [str| T = ((\ p:bool . p) = (\ p:bool . p)) |] + +defAND' :: HOL Theory thry HOLThm +defAND' = newBasicDefinition "/\\" + [str| (/\) = \ p q . (\ f:bool->bool->bool . f p q) = (\ f . f T T) |] + +defIMP' :: HOL Theory thry HOLThm +defIMP' = newBasicDefinition "==>" + [str| (==>) = \ p q . p /\ q <=> p |] + +defFORALL' :: HOL Theory thry HOLThm +defFORALL' = newBasicDefinition "!" + [str| (!) = \ P:A->bool . P = \ x . T |] + +defEXISTS' :: HOL Theory thry HOLThm +defEXISTS' = newBasicDefinition "?" + [str| (?) = \ P:A->bool . ! q . (! x . P x ==> q) ==> q |] + +defOR' :: HOL Theory thry HOLThm +defOR' = newBasicDefinition "\\/" + [str| (\/) = \ p q . ! r . (p ==> r) ==> (q ==> r) ==> r |] + +defFALSE' :: HOL Theory thry HOLThm +defFALSE' = newBasicDefinition "F" + [str| F = ! p:bool . p |] + +def_FALSITY_' :: HOL Theory thry HOLThm +def_FALSITY_' = newBasicDefinition "_FALSITY_" + [str| _FALSITY_ = F |] + +defNOT' :: HOL Theory thry HOLThm +defNOT' = newBasicDefinition "~" + [str| (~) = \ p . p ==> F |] + +defEXISTS_UNIQUE' :: HOL Theory thry HOLThm +defEXISTS_UNIQUE' = newBasicDefinition "?!" + [str| (?!) = \ P:A->bool. ((?) P) /\ (!x y. P x /\ P y ==> x = y) |] + +defTY_FORALL' :: HOL Theory thry HOLThm +defTY_FORALL' = newBasicDefinition "!!" + [str| (!!) = \ P : (% 'A. bool). P = (\\ 'A. T) |] + +defTY_EXISTS' :: HOL Theory thry HOLThm +defTY_EXISTS' = newBasicDefinition "??" + [str| (??) = \ P : (% 'A. bool). ~(P = (\\ 'A . F)) |] diff --git a/src/HaskHOL/Lib/Bool/Context.hs b/src/HaskHOL/Lib/Bool/Context.hs new file mode 100644 index 0000000..5312e32 --- /dev/null +++ b/src/HaskHOL/Lib/Bool/Context.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, UndecidableInstances #-} +{-| + Module: HaskHOL.Lib.Bool.Context + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown + + This module extends the 'ctxtBase' context with the 'loadBoolLib' computation. + It exports the theory context, quasi-quoter, and compile-time proof methods + for the Boolean logic library. +-} +module HaskHOL.Lib.Bool.Context + ( BoolType + , BoolThry + , BoolCtxt + , ctxtBool + , bool + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Bool.Base + +extendTheory ctxtBase "Bool" $ + do parseAsPrefix "~" + mapM_ parseAsInfix [ ("==>", (4, "right")) + , ("\\/", (6, "right")) + , ("/\\", (8, "right")) + , ("<=>", (2, "right")) ] + mapM_ parseAsBinder ["!", "?", "?!"] + mapM_ parseAsTyBinder ["!!", "??"] + overrideInterface "<=>" [str| (=):bool->bool->bool |] + sequence_ [ defT' + , defAND' + , defIMP' + , defFORALL' + , defEXISTS' + , defOR' + , defFALSE' + , def_FALSITY_' + , defNOT' + , defEXISTS_UNIQUE' + , defTY_FORALL' + , defTY_EXISTS' + ] + +templateProvers 'ctxtBool + +-- have to manually write this, for now +type family BoolCtxt a :: Constraint where + BoolCtxt a = (BaseCtxt a, BoolContext a ~ 'True) + +type instance PolyTheory BoolType b = BoolCtxt b diff --git a/src/HaskHOL/Lib/Canon.hs b/src/HaskHOL/Lib/Canon.hs new file mode 100644 index 0000000..e4556b7 --- /dev/null +++ b/src/HaskHOL/Lib/Canon.hs @@ -0,0 +1,1016 @@ +{-# LANGUAGE ImplicitParams, PatternSynonyms, ScopedTypeVariables #-} +{-| + Module: HaskHOL.Lib.Canon + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Canon + ( convPRESIMP + , ruleCONJ_ACI + , convSKOLEM + , convPRENEX + , convCONDS_ELIM + , convCONDS_CELIM + , convWEAK_DNF + , convWEAK_CNF + , convASSOC + , tacASM_FOL + , convLAMBDA_ELIM + , tacSELECT_ELIM + , convGEN_NNF + , convNNF + , convNNFC + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Classic +import HaskHOL.Lib.Equal +import HaskHOL.Lib.IndDefs +import HaskHOL.Lib.Theorems +import HaskHOL.Lib.Simp +import HaskHOL.Lib.DRule +import HaskHOL.Lib.Tactics +import HaskHOL.Lib.Trivia +import HaskHOL.Lib.Trivia.Context + + +pthNotNot :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +pthNotNot = cacheProof "pthNotNot" ctxtTrivia $ + ruleTAUT "~ ~ p = p" + +pthNotAnd :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +pthNotAnd = cacheProof "pthNotAnd" ctxtTrivia $ + ruleTAUT [str| ~(p /\ q) <=> ~p \/ ~q |] + +pthNotOr :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +pthNotOr = cacheProof "pthNotOr" ctxtTrivia $ + ruleTAUT [str| ~(p \/ q) <=> ~p /\ ~q |] + +pthImp :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +pthImp = cacheProof "pthImp" ctxtTrivia $ + ruleTAUT [str| p ==> q <=> ~p \/ q |] + +pthNotImp :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +pthNotImp = cacheProof "pthNotImp" ctxtTrivia $ + ruleTAUT [str| ~(p ==> q) <=> p /\ ~q |] + +pthEq :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +pthEq = cacheProof "pthEq" ctxtTrivia $ + ruleTAUT [str| (p <=> q) <=> p /\ q \/ ~p /\ ~q |] + +pthNotEq :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +pthNotEq = cacheProof "pthNotEq" ctxtTrivia $ + ruleTAUT [str| ~(p <=> q) <=> p /\ ~q \/ ~p /\ q |] + +pthEq' :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +pthEq' = cacheProof "pthEq'" ctxtTrivia $ + ruleTAUT [str| (p <=> q) <=> (p \/ ~q) /\ (~p \/ q) |] + +pthNotEq' :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +pthNotEq' = cacheProof "pthNotEq'" ctxtTrivia $ + ruleTAUT [str| ~(p <=> q) <=> (p \/ q) /\ (~p \/ ~q) |] + +pthNots :: (BasicConvs thry, TriviaCtxt thry) => [HOL cls thry HOLThm] +pthNots = + cacheProofs ["pthNotForall", "pthNotExists", "pthNotExu"] ctxtTrivia $ + ruleCONJUNCTS =<< + prove [str| (~((!) P) <=> ?x:A. ~(P x)) /\ + (~((?) P) <=> !x:A. ~(P x)) /\ + (~((?!) P) <=> (!x:A. ~(P x)) \/ + ?x y. P x /\ P y /\ ~(y = x)) |] + (_REPEAT tacCONJ `_THEN` + tacGEN_REWRITE (convLAND . + funpow 2 convRAND) [ruleGSYM axETA] `_THEN` + tacREWRITE [ thmNOT_EXISTS, thmNOT_FORALL, defEXISTS_UNIQUE + , thmDE_MORGAN, thmNOT_IMP ] `_THEN` + tacREWRITE [thmCONJ_ASSOC, thmEQ_SYM_EQ]) + +pthNotForall :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +pthNotForall = pthNots !! 0 + +pthNotExists :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +pthNotExists = pthNots !! 1 + +pthNotExu :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +pthNotExu = pthNots !! 2 + +pthExu :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +pthExu = cacheProof "pthExu" ctxtTrivia $ + prove [str| ((?!) P) <=> (?x:A. P x) /\ + !x y. ~(P x) \/ ~(P y) \/ (y = x) |] $ + tacGEN_REWRITE (convLAND . convRAND) [ruleGSYM axETA] `_THEN` + tacREWRITE [ defEXISTS_UNIQUE + , ruleTAUT [str| a /\ b ==> c <=> ~a \/ ~b \/ c |] ] `_THEN` + tacREWRITE [thmEQ_SYM_EQ] + +convPRESIMP :: (BasicConvs thry, ClassicCtxt thry) => Conversion cls thry +convPRESIMP = Conv $ \ tm -> + let ths = [ thmNOT_CLAUSES, thmAND_CLAUSES, thmOR_CLAUSES + , thmIMP_CLAUSES, thmEQ_CLAUSES, thmFORALL_SIMP + , thmEXISTS_SIMP, thmEXISTS_OR, thmFORALL_AND + , thmLEFT_EXISTS_AND, thmRIGHT_EXISTS_AND + , thmLEFT_FORALL_OR, thmRIGHT_FORALL_OR + ] in + runConv (convGEN_REWRITE convTOP_DEPTH ths) tm + +ruleCONJ_ACI :: BoolCtxt thry => HOLTerm -> HOL cls thry HOLThm +ruleCONJ_ACI fm = + let (p, p') = fromJust $ destEq fm in + if p == p' then return $! primREFL p + else do th <- useFun p' =<< mkFun funcEmpty #<< primASSUME p + th' <- useFun p =<< mkFun funcEmpty #<< primASSUME p' + liftM1 ruleIMP_ANTISYM (ruleDISCH_ALL th) =<< ruleDISCH_ALL th' + where useFun :: BoolCtxt thry => HOLTerm -> Func HOLTerm HOLThm + -> HOL cls thry HOLThm + useFun tm fn + | isConj tm = + let (l, r) = fromJust $ destConj tm in + do l' <- useFun l fn + ruleCONJ l' =<< useFun r fn + | otherwise = liftO $ apply fn tm + + mkFun :: BoolCtxt thry => Func HOLTerm HOLThm -> HOLThm + -> HOL cls thry (Func HOLTerm HOLThm) + mkFun fn th = + let tm = concl th in + if isConj tm + then do (th1, th2) <- ruleCONJ_PAIR th + flip mkFun th1 =<< mkFun fn th2 + else return $! (tm |-> th) fn + + +convSKOLEM :: (BasicConvs thry, ClassicCtxt thry) => Conversion cls thry +convSKOLEM = Conv $ \ tm -> + let ths1 = [ thmEXISTS_OR, thmLEFT_EXISTS_AND + , thmRIGHT_EXISTS_AND, thmFORALL_AND + , thmLEFT_FORALL_OR, thmRIGHT_FORALL_OR + , thmFORALL_SIMP, thmEXISTS_SIMP + ] + ths2 = [ thmRIGHT_AND_EXISTS, thmLEFT_AND_EXISTS + , thmOR_EXISTS, thmRIGHT_OR_EXISTS + , thmLEFT_OR_EXISTS, thmSKOLEM + ] in + runConv (convGEN_REWRITE convTOP_DEPTH ths1 `_THEN` + convGEN_REWRITE convREDEPTH ths2) tm + + +convPRENEX :: (BasicConvs thry, ClassicCtxt thry) => Conversion cls thry +convPRENEX = Conv $ \ tm -> + let ths = [ thmAND_FORALL, thmLEFT_AND_FORALL + , thmRIGHT_AND_FORALL, thmLEFT_OR_FORALL + , thmRIGHT_OR_FORALL, thmOR_EXISTS + , thmLEFT_OR_EXISTS, thmRIGHT_OR_EXISTS + , thmLEFT_AND_EXISTS, thmRIGHT_AND_EXISTS + ] in + runConv (convGEN_REWRITE convREDEPTH ths) tm + + + +-- eliminate all lambda-terms exception those part of quantifiers + +convHALF_MK_ABS :: (BasicConvs thry, TriviaCtxt thry) => [HOLTerm] + -> Conversion cls thry +convHALF_MK_ABS = conv + where conv [] = _ALL + conv (_:vs) = convGEN_REWRITE id [convHALF_MK_ABS_pth] `_THEN` + convBINDER (conv vs) + + convHALF_MK_ABS_pth :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + convHALF_MK_ABS_pth = cacheProof "convHALF_MK_ABS_pth" ctxtTrivia $ + prove [str| (s = \x. t x) <=> (!x. s x = t x) |] $ + tacREWRITE [thmFUN_EQ] + +findLambda :: HOLTerm -> Maybe HOLTerm +findLambda tm@( Abs{}) = Just tm +findLambda ( Var{}) = Nothing +findLambda ( Const{}) = Nothing +findLambda tm = + if isForall tm || isExists tm || isUExists tm + then findLambda =<< body =<< rand tm + else case tm of + (Comb l r) -> case findLambda l of + Nothing -> findLambda r + res@Just{} -> res + _ -> Nothing + +elimLambda :: Conversion cls thry -> Conversion cls thry +elimLambda conv = Conv $ \ tm -> + runConv conv tm <|> + (if isAbs tm then runConv (convABS $ elimLambda conv) tm + else if isVar tm || isConst tm then return $! primREFL tm + else if isForall tm || isExists tm || isUExists tm + then runConv (convBINDER $ elimLambda conv) tm + else runConv (convCOMB $ elimLambda conv) tm) + +applyPTH :: (BasicConvs thry, TriviaCtxt thry) => HOLThm -> HOL cls thry HOLThm +applyPTH = ruleMATCH_MP applyPTH_pth + where applyPTH_pth :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + applyPTH_pth = cacheProof "applyPTH_pth" ctxtTrivia $ + prove [str| (!a. (a = c) ==> (P = Q a)) ==> + (P <=> !a. (a = c) ==> Q a) |] $ + tacSIMP [thmLEFT_FORALL_IMP, thmEXISTS_REFL] + + +convLAMB1 :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convLAMB1 = Conv $ \ tm -> + (case findLambda tm of + Just atm@( Abs v _) -> + let vs = frees atm + vs' = vs ++ [v] in + do aatm <- fromRightM $ listMkAbs vs atm + f <- genVar $ typeOf aatm + eq <- mkEq f aatm + th1 <- liftM (fromRight . ruleSYM) $ ruleRIGHT_BETAS vs #<< primASSUME eq + th2 <- runConv (elimLambda $ convGEN_REWRITE id [th1]) tm + th3 <- applyPTH =<< ruleGEN f =<< ruleDISCH_ALL th2 + ruleCONV (convRAND . convBINDER . convLAND $ convHALF_MK_ABS vs') th3 + _ -> fail "") + "convLAMB1" + +convLAMBDA_ELIM :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convLAMBDA_ELIM = conv + where conv = Conv $ \ tm -> runConv (convLAMB1 `_THEN` conv) tm + <|> (return $! primREFL tm) + +-- eliminate select terms from a goal + +selectElimThm :: (BasicConvs thry, TriviaCtxt thry) => HOLTerm + -> HOL cls thry HOLThm +selectElimThm ( Comb ( Const "@" _) atm@( Abs bv _)) = + do pth <- selectElimThm_pth + ptm <- serve [trivia| P:A->bool |] + ruleCONV (convLAND convBETA) #<< + rulePINST [(tyA, typeOf bv)] [(ptm, atm)] pth + where selectElimThm_pth :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + selectElimThm_pth = cacheProof "selectElimThm_pth" ctxtTrivia $ + prove "(P:A->bool)((@) P) <=> (?) P" $ + tacREWRITE [thmEXISTS] `_THEN` + tacBETA `_THEN` + tacREFL +selectElimThm _ = fail "selectElimThm: not a select term" + + +convSELECT_ELIM :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convSELECT_ELIM = Conv $ \ tm -> + do ths <- mapM selectElimThm $ findTerms isSelect tm + runConv (convPURE_REWRITE ths) tm + +selectAxThm :: TriviaCtxt thry => HOLTerm -> HOL cls thry HOLThm +selectAxThm ( Comb ( Const "@" _) atm@( Abs bv _)) = + let fvs = frees atm in + do pth <- selectAxThm_pth + ptm <- serve [trivia| P:A->bool |] + let th1 = fromJust $ rulePINST [(tyA, typeOf bv)] [(ptm, atm)] pth + th2 <- ruleCONV (convBINDER $ convBINOP convBETA) th1 + ruleGENL fvs th2 + where selectAxThm_pth :: TriviaCtxt thry => HOL cls thry HOLThm + selectAxThm_pth = cacheProof "selectAxThm_pth" ctxtTrivia $ + ruleISPEC "P:A->bool" axSELECT +selectAxThm _ = fail "selectAxThm: not a select term" + +iconvSELECT_ELIM :: TriviaCtxt thry => Conversion cls thry +iconvSELECT_ELIM = Conv $ \ tm -> + (do t <- fromJustM $ findTerm isSelect tm + th1 <- selectAxThm t + itm <- mkImp (concl th1) tm + ith <- fromRightM $ primASSUME itm + th2 <- ruleDISCH_ALL =<< ruleMP ith th1 + let fvs = frees t + fty <- foldrM (mkFunTy . typeOf) (typeOf t) fvs + fn <- genVar fty + atm <- fromRightM $ listMkAbs fvs t + rawdef <- mkEq fn atm + def <- ruleGENL fvs =<< liftM (fromRight . ruleSYM) (ruleRIGHT_BETAS fvs #<< primASSUME rawdef) + l <- fromJustM . lHand $ concl th2 + th3 <- runConv (convPURE_REWRITE [def]) l + r <- fromJustM . rand $ concl th3 + gtm <- mkForall fn r + th4 <- fromRightM $ ruleSYM th3 + th5 <- ruleSPEC fn #<< primASSUME gtm + th6 <- fromRightM $ primEQ_MP th4 th5 + th7 <- ruleDISCH gtm th6 + th8 <- ruleIMP_TRANS th7 th2 + th9 <- ruleDISCH rawdef th8 + ruleMP (fromJust $ primINST [(atm, fn)] th9) $ primREFL atm) + "iconvSELECT_ELIM" + +iconvSELECT_ELIMS :: TriviaCtxt thry => Conversion cls thry +iconvSELECT_ELIMS = Conv $ \ tm -> + (do th <- runConv iconvSELECT_ELIM tm + tm' <- fromJustM . lHand $ concl th + th2 <- runConv iconvSELECT_ELIM tm' + ruleIMP_TRANS th2 th) + <|> (ruleDISCH tm #<< primASSUME tm) + +tacSELECT_ELIM :: (BasicConvs thry, TriviaCtxt thry) => Tactic cls thry +tacSELECT_ELIM = + tacCONV convSELECT_ELIM `_THEN` + (\ g@(Goal _ w) -> do th <- runConv iconvSELECT_ELIMS w + tacMATCH_MP th g) + +-- eliminate conditionals +findConditional :: [HOLTerm] -> HOLTerm -> Maybe HOLTerm +findConditional fvs tm@( Comb s t) + | isCond tm = + do freesL <- liftM frees $ lHand s + if null (freesL `intersect` fvs) + then return tm + else findConditional fvs s <|> findConditional fvs t + | otherwise = findConditional fvs s <|> findConditional fvs t +findConditional fvs ( Abs x t) = findConditional (x:fvs) t +findConditional _ _ = Nothing + +condsElimConv :: (BasicConvs thry, TriviaCtxt thry) => Bool + -> Conversion cls thry +condsElimConv dfl = Conv $ \ tm -> + (case findConditional [] tm of + Just t -> + do p <- fromJustM $ lHand =<< rator t + prosimps <- basicNet + falseTm <- serve [trivia| F |] + trueTm <- serve [trivia| T |] + thNew <- if p == falseTm || p == trueTm + then runConv (convDEPTH $ convREWRITES prosimps) tm + else do asm0 <- mkEq p falseTm + ath0 <- fromRightM $ primASSUME asm0 + asm1 <- mkEq p trueTm + ath1 <- fromRightM $ primASSUME asm1 + simp0 <- liftO $ netOfThm False ath0 prosimps + simp1 <- liftO $ netOfThm False ath1 prosimps + th0 <- ruleDISCH asm0 =<< runConv (convDEPTH $ convREWRITES simp0) tm + th1 <- ruleDISCH asm1 =<< runConv (convDEPTH $ convREWRITES simp1) tm + th2 <- ruleCONJ th0 th1 + th3 <- liftM1 ruleMATCH_MP (if dfl then convCONDS_ELIM_thCond else convCONDS_ELIM_thCond') th2 + let cnv = _TRY (convREWRITES prosimps) + proptsimpConv = convBINOP cnv `_THEN` cnv + rth <- runConv proptsimpConv =<< (fromJustM . rand $ concl th3) + fromRightM $ primTRANS th3 rth + ruleCONV (convRAND $ condsElimConv dfl) thNew + Nothing + | isNeg tm -> + runConv (convRAND . condsElimConv $ not dfl) tm + | isConj tm || isDisj tm -> + runConv (convBINOP $ condsElimConv dfl) tm + | isImp tm || isIff tm -> + runConv (convCOMB2 (convRAND . condsElimConv $ not dfl) + (condsElimConv dfl)) tm + | isForall tm -> + runConv (convBINDER $ condsElimConv False) tm + | isExists tm || isUExists tm -> + runConv (convBINDER $ condsElimConv True) tm + | otherwise -> return $! primREFL tm) + "condsElimConv" + where convCONDS_ELIM_thCond :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + convCONDS_ELIM_thCond = cacheProof "convCONDS_ELIM_thCond" ctxtTrivia $ + prove [str| ((b <=> F) ==> x = x0) /\ + ((b <=> T) ==> x = x1) ==> + x = (b /\ x1 \/ ~b /\ x0) |] $ + tacBOOL_CASES "b:bool" `_THEN` tacASM_REWRITE_NIL + + convCONDS_ELIM_thCond' :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + convCONDS_ELIM_thCond' = + cacheProof "convCONDS_ELIM_thCond'" ctxtTrivia $ + prove [str| ((b <=> F) ==> x = x0) /\ + ((b <=> T) ==> x = x1) ==> + x = ((~b \/ x1) /\ (b \/ x0)) |] $ + tacBOOL_CASES "b:bool" `_THEN` tacASM_REWRITE_NIL + + +convCONDS_ELIM :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convCONDS_ELIM = condsElimConv True + +convCONDS_CELIM :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convCONDS_CELIM = condsElimConv False + +-- Weak DNF +distributeDNF :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +distributeDNF = Conv $ \ tm -> + (do tmA <- serve [trivia| a:bool |] + tmB <- serve [trivia| b:bool |] + tmC <- serve [trivia| c:bool |] + case tm of + (Comb (Comb (Const "/\\" _) a) (Comb (Comb (Const "\\/" _) b) c)) -> + do pth <- convWEAK_DNF_pth1 + th <- liftO $ primINST [(tmA, a), (tmB, b), (tmC, c)] pth + th' <- runConv (convBINOP distributeDNF) #<< rand (concl th) + liftO $ primTRANS th th' + (Comb (Comb (Const "/\\" _) (Comb (Comb (Const "\\/" _) a) b)) c) -> + do pth <- convWEAK_DNF_pth2 + th <- liftO $ primINST [(tmA, a), (tmB, b), (tmC, c)] pth + th' <- runConv (convBINOP distributeDNF) #<< rand (concl th) + liftO $ primTRANS th th' + _ -> return $! primREFL tm) + "distributeDNF" + where convWEAK_DNF_pth1 :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + convWEAK_DNF_pth1 = cacheProof "convWEAK_DNF_pth1" ctxtTrivia $ + ruleTAUT [str| a /\ (b \/ c) <=> a /\ b \/ a /\ c |] + + convWEAK_DNF_pth2 :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + convWEAK_DNF_pth2 = cacheProof "convWEAK_DNF_pth2" ctxtTrivia $ + ruleTAUT [str| (a \/ b) /\ c <=> a /\ c \/ b /\ c |] + +convWEAK_DNF :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convWEAK_DNF = Conv $ \ tm -> + case tm of + (Comb (Const "!" _) Abs{}) -> runConv (convBINDER convWEAK_DNF) tm + (Comb (Const "?" _) Abs{}) -> runConv (convBINDER convWEAK_DNF) tm + (Comb (Comb (Const "\\/" _) _) _) -> runConv (convBINOP convWEAK_DNF) tm + (Comb (Comb op@(Const "/\\" _) l) r) -> + do l' <- runConv convWEAK_DNF l + r' <- runConv convWEAK_DNF r + th <- liftO $ liftM1 primMK_COMB (ruleAP_TERM op l') r' + th' <- runConv distributeDNF #<< rand (concl th) + liftO $ primTRANS th th' + _ -> return $! primREFL tm + +-- Weak CNF +distribute :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +distribute = Conv $ \ tm -> + (do aTm <- serve [trivia| a:bool |] + bTm <- serve [trivia| b:bool |] + cTm <- serve [trivia| c:bool |] + case tm of + (Comb ( Comb ( Const "\\/" _) a) + ( Comb ( Comb ( Const "/\\" _) b) c)) -> + do pth <- distribute_pth1 + let th = fromJust $ primINST [(aTm, a), (bTm, b), (cTm, c)] pth + rth <- runConv (convBINOP distribute) =<< (fromJustM . rand $ concl th) + fromRightM $ primTRANS th rth + (Comb ( Comb ( Const "\\/" _) + ( Comb ( Comb ( Const "/\\" _) a) b)) c) -> + do pth <- distribute_pth2 + let th = fromJust $ primINST [(aTm, a), (bTm, b), (cTm, c)] pth + rth <- runConv (convBINOP distribute) =<< (fromJustM . rand $ concl th) + fromRightM $ primTRANS th rth + _ -> return $! primREFL tm) + "distribute" + where distribute_pth1 :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + distribute_pth1 = cacheProof "distribute_pth1" ctxtTrivia $ + ruleTAUT [str| a \/ (b /\ c) <=> (a \/ b) /\ (a \/ c) |] + + distribute_pth2 :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + distribute_pth2 = cacheProof "distribute_pth2" ctxtTrivia $ + ruleTAUT [str| (a /\ b) \/ c <=> (a \/ c) /\ (b \/ c) |] + + + +convWEAK_CNF :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convWEAK_CNF = Conv $ \ tm -> + (case tm of + (Comb ( Const "!" _) ( Abs{})) -> runConv (convBINDER convWEAK_CNF) tm + (Comb ( Const "?" _) ( Abs{})) -> runConv (convBINDER convWEAK_CNF) tm + (Comb ( Comb ( Const "/\\" _) _) _) -> runConv (convBINOP convWEAK_CNF) tm + (Comb ( Comb op@( Const "\\/" _) l) r) -> + do lth <- runConv convWEAK_CNF l + rth <- runConv convWEAK_CNF r + th <- fromRightM $ flip primMK_COMB rth =<< ruleAP_TERM op lth + rtm <- fromJustM . rand $ concl th + th2 <- runConv distribute rtm + fromRightM $ primTRANS th th2 + _ -> return $! primREFL tm) + "convWEAK_CNF" + +distrib :: HOLTerm -> HOLTerm -> HOLTerm -> HOLTerm -> HOLThm -> HOLTerm -> + Either String HOLThm +distrib op x y z th' tm@( Comb ( Comb op' ( Comb ( Comb op'' p) q)) r) + | op' == op && op'' == op = + (let th1 = fromJust $ primINST [(x, p), (y, q), (z, r)] th' in + case rand $ concl th1 of + Just ( Comb l r') -> + do th2 <- ruleAP_TERM l =<< distrib op x y z th' r' + rtm <- note "" . rand $ concl th2 + th3 <- distrib op x y z th' rtm + primTRANS th1 =<< primTRANS th2 th3 + _ -> Left "") + "distrib" + | otherwise = return $! primREFL tm +distrib _ _ _ _ _ t = return $! primREFL t + +canonAssoc :: HOLTerm -> HOLTerm -> HOLTerm -> HOLTerm -> HOLThm -> + HOLTerm -> Either String HOLThm +canonAssoc op x y z th' tm@( Comb l@( Comb op' _) q) + | op' == op = + (do th <- ruleAP_TERM l =<< canonAssoc op x y z th' q + r <- note "" . rand $ concl th + primTRANS th =<< distrib op x y z th' r) + "canonAssoc" + | otherwise = return $! primREFL tm +canonAssoc _ _ _ _ _ tm = return $! primREFL tm + +convASSOC :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm + -> Conversion cls thry +convASSOC th = Conv $ \ tm -> + (do th' <- liftM (fromRight . ruleSYM) $ ruleSPEC_ALL =<< toHThm th + case rand $ concl th' of + Just ( Comb ( Comb op x) yopz) -> + do y <- fromJustM $ lHand yopz + z <- fromJustM $ rand yopz + fromRightM $ canonAssoc op x y z th' tm + _ -> fail "") + "convASSOC" + +getHeads :: [HOLTerm] -> HOLTerm -> ([(HOLTerm, Int)], [(HOLTerm, Int)]) -> + ([(HOLTerm, Int)], [(HOLTerm, Int)]) +getHeads lconsts tm sofar@(cheads, vheads) = + case destForall tm of + Just (v, bod) -> getHeads (lconsts \\ [v]) bod sofar + Nothing -> + case destConj tm of + Just (l, r) -> getHeads lconsts l (getHeads lconsts r sofar) + Nothing -> + case destDisj tm of + Just (l, r) -> getHeads lconsts l (getHeads lconsts r sofar) + Nothing -> + case destNeg tm of + Just tm' -> getHeads lconsts tm' sofar + Nothing -> + let (hop, args) = stripComb tm + len = length args + newHeads + | isConst hop || hop `elem` lconsts = + (insert (hop, len) cheads, vheads) + | len > 0 = + (cheads, insert (hop, len) vheads) + | otherwise = sofar in + foldr (getHeads lconsts) newHeads args + +getThmHeads :: HOLThm -> ([(HOLTerm, Int)], [(HOLTerm, Int)]) -> + ([(HOLTerm, Int)], [(HOLTerm, Int)]) +getThmHeads th = getHeads (catFrees $ hyp th) (concl th) + +convAPP :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convAPP = convREWR convAPP_pth + where convAPP_pth :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + convAPP_pth = cacheProof "convAPP_pth" ctxtTrivia $ + prove "!(f:A->B) x. f x = I f x" $ + tacREWRITE [thmI] + +convAPP_N :: (BasicConvs thry, TriviaCtxt thry) => Int -> Conversion cls thry +convAPP_N n = + if n == 1 then convAPP + else convRATOR (convAPP_N $ n - 1) `_THEN` convAPP + +convFOL :: (BasicConvs thry, TriviaCtxt thry) => [(HOLTerm, Int)] + -> Conversion cls thry +convFOL hddata = Conv $ \ tm -> + if isForall tm + then runConv (convBINDER $ convFOL hddata) tm + else if isConj tm || isDisj tm + then runConv (convBINOP $ convFOL hddata) tm + else let (op, args) = stripComb tm + th1 = primREFL op in + do th2 <- mapM (runConv (convFOL hddata)) args + th <- fromRightM $ foldlM primMK_COMB th1 th2 + tm' <- fromJustM . rand $ concl th + let n = case lookup op hddata of + Just x -> length args - x + Nothing -> 0 + if n == 0 + then return th + else do th' <- runConv (convAPP_N n) tm' + fromRightM $ primTRANS th th' + +convGEN_FOL :: (BasicConvs thry, TriviaCtxt thry) + => ([(HOLTerm, Int)], [(HOLTerm, Int)]) -> Conversion cls thry +convGEN_FOL (cheads, vheads) = + let hddata = if null vheads + then let hops = setify $ map fst cheads + getMin h = let ns = mapFilter (\ (k, n) -> if k == h then Just n else Nothing) cheads in + if length ns < 2 then Nothing else Just (h, minimum ns) in + mapFilter getMin hops + else map (\ t -> case t of + ( Const "=" _) -> (t, 2) + _ -> (t, 0)) (setify . map fst $ vheads ++ cheads) in + convFOL hddata + + +tacASM_FOL :: (BasicConvs thry, TriviaCtxt thry) => Tactic cls thry +tacASM_FOL gl@(Goal asl _) = + let headsp = foldr (getThmHeads . snd) ([], []) asl in + tacRULE_ASSUM (ruleCONV $ convGEN_FOL headsp) gl + +-- conv NFF +andPTm, orPTm, notPTm, pPTm, qPTm :: TriviaCtxt thry => PTerm thry +andPTm = [trivia| (/\) |] +orPTm = [trivia| (\/) |] +notPTm = [trivia| (~) |] +pPTm = [trivia| p:bool |] +qPTm = [trivia| q:bool |] + +nnfDConv :: (BasicConvs thry, TriviaCtxt thry) => Bool + -> (HOLTerm -> HOL cls thry (HOLThm, HOLThm)) -> HOLTerm + -> HOL cls thry (HOLThm, HOLThm) +nnfDConv cf baseconvs ( Comb ( Comb ( Const "/\\" _) l) r) = + (do pth <- pthNotAnd + andTm <- serve andPTm + orTm <- serve orPTm + pTm <- serve pPTm + qTm <- serve qPTm + (thLp, thLn) <- nnfDConv cf baseconvs l + (thRp, thRn) <- nnfDConv cf baseconvs r + let rth1 = fromJust $ primINST [(pTm, l), (qTm, r)] pth + fromRightM $ do lth <- ruleAP_TERM andTm thLp + th1 <- primMK_COMB lth thRp + rth2 <- ruleAP_TERM orTm thLn + th2 <- primTRANS rth1 =<< primMK_COMB rth2 thRn + return (th1, th2)) + "nnfDConv: conjunction case" +nnfDConv cf baseconvs ( Comb ( Comb ( Const "\\/" _) l) r) = + (do pth <- pthNotOr + andTm <- serve andPTm + orTm <- serve orPTm + pTm <- serve pPTm + qTm <- serve qPTm + (thLp, thLn) <- nnfDConv cf baseconvs l + (thRp, thRn) <- nnfDConv cf baseconvs r + let rth1 = fromJust $ primINST [(pTm, l), (qTm, r)] pth + fromRightM $ do lth <- ruleAP_TERM orTm thLp + th1 <- primMK_COMB lth thRp + rth2 <- ruleAP_TERM andTm thLn + th2 <- primTRANS rth1 =<< primMK_COMB rth2 thRn + return (th1, th2)) + "nnfDConv: disjunction case" +nnfDConv cf baseconvs ( Comb ( Comb ( Const "==>" _) l) r) = + (do pth1 <- pthImp + pth2 <- pthNotImp + andTm <- serve andPTm + orTm <- serve orPTm + pTm <- serve pPTm + qTm <- serve qPTm + (thLp, thLn) <- nnfDConv cf baseconvs l + (thRp, thRn) <- nnfDConv cf baseconvs r + let lth1 = fromJust $ primINST [(pTm, l), (qTm, r)] pth1 + let rth1 = fromJust $ primINST [(pTm, l), (qTm, r)] pth2 + fromRightM $ do lth2 <- ruleAP_TERM orTm thLn + th1 <- primTRANS lth1 =<< primMK_COMB lth2 thRp + rth2 <- ruleAP_TERM andTm thLp + th2 <- primTRANS rth1 =<< primMK_COMB rth2 thRn + return (th1, th2)) + "nnfDConv: implication case" +nnfDConv cf baseconvs tm@(Comb (Comb (Const "=" (TyApp f (TyApp b _ : _))) l) r) + | f == tyOpFun && b == tyOpBool = + (do andTm <- serve andPTm + orTm <- serve orPTm + pTm <- serve pPTm + qTm <- serve qPTm + (thLp, thLn) <- nnfDConv cf baseconvs l + (thRp, thRn) <- nnfDConv cf baseconvs r + if cf + then do pth1 <- pthEq' + pth2 <- pthNotEq' + let lth1 = fromJust $ primINST [(pTm, l), (qTm, r)] pth1 + rth1 = fromJust $ primINST [(pTm, l), (qTm, r)] pth2 + fromRightM $ do lth2 <- ruleAP_TERM orTm thLp + lth3 <- ruleAP_TERM andTm =<< primMK_COMB lth2 thRn + lth4 <- ruleAP_TERM orTm thLn + th1 <- primTRANS lth1 =<< primMK_COMB lth3 =<< primMK_COMB lth4 thRp + rth2 <- ruleAP_TERM orTm thLp + rth3 <- ruleAP_TERM andTm =<< primMK_COMB rth2 thRp + rth4 <- ruleAP_TERM orTm thLn + th2 <- primTRANS rth1 =<< primMK_COMB rth3 =<< primMK_COMB rth4 thRn + return (th1, th2) + else do pth1 <- pthEq + pth2 <- pthNotEq + let lth1 = fromJust $ primINST [(pTm, l), (qTm, r)] pth1 + rth1 = fromJust $ primINST [(pTm, l), (qTm, r)] pth2 + fromRightM $ do lth2 <- ruleAP_TERM andTm thLp + lth3 <- ruleAP_TERM orTm =<< primMK_COMB lth2 thRp + lth4 <- ruleAP_TERM andTm thLn + th1 <- primTRANS lth1 =<< primMK_COMB lth3 =<< primMK_COMB lth4 thRn + rth2 <- ruleAP_TERM andTm thLp + rth3 <- ruleAP_TERM orTm =<< primMK_COMB rth2 thRn + rth4 <- ruleAP_TERM andTm thLn + th2 <- primTRANS rth1 =<< primMK_COMB rth3 =<< primMK_COMB rth4 thRp + return (th1, th2)) + "nnfDConv: equality case" + | otherwise = nnfDConvBase baseconvs tm +nnfDConv _ baseconvs tm@(Comb q@(Const "!" (TyApp f1 (TyApp f2 (ty : _) : _))) bod@( Abs x t)) + | f1 == tyOpFun && f2 == tyOpFun = + (do pth <- pthNotForall + notTm <- serve notPTm + (thP, thN) <- nnfDConv True baseconvs t + th1 <- fromRightM $ ruleAP_TERM q =<< primABS x thP + p <- liftM (mkVar "P") $ mkFunTy ty tyBool + let rth1 = fromJust $ primINST [(p, bod)] $ primINST_TYPE [(tyA, ty)] pth + rth3 <- fromRightM $ do rth2 <- ruleAP_TERM notTm =<< primBETA =<< mkComb bod x + primTRANS rth2 thN + rth4 <- ruleMK_EXISTS x rth3 + fromRightM $ do th2 <- primTRANS rth1 rth4 + return (th1, th2)) + "nnfDConv: forall case" + | otherwise = nnfDConvBase baseconvs tm +nnfDConv cf baseconvs tm@(Comb q@(Const "?" (TyApp f1 (TyApp f2 (ty : _) : _))) bod@( Abs x t)) + | f1 == tyOpFun && f2 == tyOpFun = + (do pth <- pthNotExists + notTm <- serve notPTm + (thP, thN) <- nnfDConv cf baseconvs t + th1 <- fromRightM $ ruleAP_TERM q =<< primABS x thP + p <- liftM (mkVar "P") $ mkFunTy ty tyBool + let rth1 = fromJust $ primINST [(p, bod)] $ primINST_TYPE [(tyA, ty)] pth + rth3 <- fromRightM $ do rth2 <- ruleAP_TERM notTm =<< primBETA =<< mkComb bod x + primTRANS rth2 thN + rth4 <- ruleMK_FORALL x rth3 + fromRightM $ do th2 <- primTRANS rth1 rth4 + return (th1, th2)) + "nnfDConv: exists case" + | otherwise = nnfDConvBase baseconvs tm +nnfDConv cf baseconvs tm@( Comb ( Const "?!" ( TyApp f1 (( TyApp f2 (ty : _)) : _))) bod@( Abs x t)) + | f1 == tyOpFun && f2 == tyOpFun = + let y = variant (x : frees t) x in + (do pth1 <- pthExu + pth2 <- pthNotExu + andTm <- serve andPTm + orTm <- serve orPTm + notTm <- serve notPTm + (thP, thN) <- nnfDConv cf baseconvs t + eq <- mkEq y x + (ethP, ethN) <- baseconvs eq + bth <- fromRightM $ primBETA =<< mkComb bod x + bth' <- runConv convBETA #<< mkComb bod y + let thP' = fromJust $ primINST [(x, y)] thP + let thN' = fromJust $ primINST [(x, y)] thN + p <- liftM (mkVar "P") $ mkFunTy ty tyBool + let lth1 = fromJust $ primINST [(p, bod)] $ primINST_TYPE [(tyA, ty)] pth1 + let rth1 = fromJust $ primINST [(p, bod)] $ primINST_TYPE [(tyA, ty)] pth2 + lth2 <- ruleMK_EXISTS x #<< primTRANS bth thP + lth3 <- fromRightM $ ruleAP_TERM andTm lth2 + lth8 <- fromRightM $ do lth4 <- ruleAP_TERM notTm bth + lth5 <- ruleAP_TERM orTm =<< primTRANS lth4 thN + lth6 <- ruleAP_TERM notTm bth' + lth7 <- ruleAP_TERM orTm =<< primTRANS lth6 thN' + primMK_COMB lth5 =<< primMK_COMB lth7 ethP + lth9 <- ruleMK_FORALL x =<< ruleMK_FORALL y lth8 + lth10 <- fromRightM $ primMK_COMB lth3 lth9 + rth2 <- fromRightM $ flip primTRANS thN =<< ruleAP_TERM notTm bth + rth3 <- ruleMK_FORALL x rth2 + rth4 <- fromRightM $ ruleAP_TERM orTm rth3 + rth7 <- fromRightM $ do rth5 <- ruleAP_TERM andTm =<< primTRANS bth thP + rth6 <- ruleAP_TERM andTm =<< primTRANS bth' thP' + primMK_COMB rth5 =<< primMK_COMB rth6 ethN + rth8 <- ruleMK_EXISTS x =<< ruleMK_EXISTS y rth7 + fromRightM $ do rth9 <- primMK_COMB rth4 rth8 + th1 <- primTRANS lth1 lth10 + th2 <- primTRANS rth1 rth9 + return (th1, th2)) + "nnfDConv: unique exists case" + | otherwise = nnfDConvBase baseconvs tm +nnfDConv cf baseconvs ( Comb ( Const "~" _) t) = + (do pth <- pthNotNot + pTm <- serve pPTm + (th1, th2) <- nnfDConv cf baseconvs t + let rth1 = fromJust $ primINST [(pTm, t)] pth + fromRightM $ do rth2 <- primTRANS rth1 th1 + return (th2, rth2)) + "nnfDConv: not case" +nnfDConv _ baseconvs tm = nnfDConvBase baseconvs tm + +nnfDConvBase :: (HOLTerm -> HOL cls thry (HOLThm, HOLThm)) -> HOLTerm -> HOL cls thry (HOLThm, HOLThm) +nnfDConvBase baseconvs tm = + (baseconvs tm <|> (let th1 = primREFL tm in + do th2 <- liftM primREFL $ mkNeg tm + return (th1, th2))) + "nnfDConv: base case" + +type NNFConv cls thry = + Bool -> (Conversion cls thry, HOLTerm -> HOL cls thry (HOLThm, HOLThm)) -> + Conversion cls thry + +nnfConv' :: forall cls thry. (BasicConvs thry, TriviaCtxt thry) + => NNFConv cls thry +nnfConv' cf baseconvs@(base1, base2) = Conv $ \ tm -> + do orTm <- serve orPTm + notTm <- serve notPTm + andTm <- serve andPTm + pTm <- serve pPTm + qTm <- serve qPTm + case tm of + (Comb ( Comb ( Const "/\\" _) l) r) -> + let ?pth = pthNotAnd + ?lconv = nnfConv' + ?rconv = nnfConv' + ?btm = orTm in + boolCase "conjunction" l r + (Comb ( Comb ( Const "\\/" _) l) r) -> + let ?pth = pthNotOr + ?lconv = nnfConv' + ?rconv = nnfConv' + ?btm = andTm in + boolCase "disjunction" l r + (Comb ( Comb ( Const "==>" _) l) r) -> + let ?pth = pthNotImp + ?lconv = nnfConv + ?rconv = nnfConv' + ?btm = andTm in + boolCase "implication" l r + (Comb (Comb (Const "=" (TyApp _ (TyApp b _ : _))) l) r) + | b == tyOpBool -> + (do (thLp, thLn) <- nnfDConv cf base2 l + (thRp, thRn) <- nnfDConv cf base2 r + pth <- if cf then pthNotEq' else pthNotEq + let (ltm, rtm) = if cf then (orTm, andTm) else (andTm, orTm) + (rth1, rth2) = if cf then (thRp, thRn) else (thRn, thRp) + liftO $ do lth1 <- note "" $ primINST [(pTm, l), (qTm, r)] pth + lth2 <- ruleAP_TERM ltm thLp + lth3 <- ruleAP_TERM rtm =<< primMK_COMB lth2 rth1 + lth4 <- ruleAP_TERM ltm thLn + primTRANS lth1 =<< primMK_COMB lth3 =<< primMK_COMB lth4 rth2) + "nnfConv': equality case" + | otherwise -> baseCase tm + (Comb (Const "!" (TyApp _ (TyApp _ (ty : _) : _))) bod@( Abs x t)) -> + let ?pth = pthNotForall + ?cf = cf + ?rule = ruleMK_EXISTS in + quantCase "forall" bod x t ty + (Comb ( Const "?" ( TyApp _ (TyApp _ (ty : _) : _))) bod@( Abs x t)) -> + let ?pth = pthNotExists + ?cf = True + ?rule = ruleMK_FORALL in + quantCase "exists" bod x t ty + (Comb ( Const "?!" ( TyApp _ (TyApp _ (ty : _) : _))) bod@( Abs x t)) -> + let y = variant (x:frees t) x in + (do pth <- pthNotExu + (thP, thN) <- nnfDConv cf base2 t + eq <- mkEq y x + (_, ethN) <- base2 eq + bth <- fromRightM $ primBETA =<< mkComb bod x + bth' <- runConv convBETA #<< mkComb bod y + th1' <- instPth pth bod ty + lth1 <- fromRightM $ flip primTRANS thN =<< ruleAP_TERM notTm bth + lth2 <- ruleMK_FORALL x lth1 + lth3 <- fromRightM $ ruleAP_TERM orTm lth2 + lth6 <- fromRightM $ do lth4 <- ruleAP_TERM andTm =<< primTRANS bth thP + lth5 <- ruleAP_TERM andTm =<< (primTRANS bth' #<< primINST [(x, y)] thP) + primMK_COMB lth4 =<< primMK_COMB lth5 ethN + lth7 <- ruleMK_EXISTS x =<< ruleMK_EXISTS y lth6 + fromRightM $ primTRANS th1' =<< primMK_COMB lth3 lth7) + "nnfConv': unique exists case" + (Comb ( Const "~" _) t) -> + (do pth <- pthNotNot + th1 <- runConv (nnfConv cf baseconvs) t + liftO $ primTRANS (fromJust $ primINST [(pTm, t)] pth) th1) + "nnfConv': not case" + _ -> baseCase tm + where boolCase :: (TriviaCtxt thry, ?pth :: HOL cls thry HOLThm, + ?lconv :: NNFConv cls thry, + ?rconv :: NNFConv cls thry, ?btm :: HOLTerm) + => String -> HOLTerm -> HOLTerm -> HOL cls thry HOLThm + boolCase err l r = + (do pTm <- serve pPTm + qTm <- serve qPTm + pth <- ?pth + lth <- runConv (?lconv cf baseconvs) l + rth <- runConv (?rconv cf baseconvs) r + let lth1 = fromJust $ primINST [(pTm, l), (qTm, r)] pth + liftO $ do lth2 <- ruleAP_TERM ?btm lth + primTRANS lth1 =<< primMK_COMB lth2 rth) + ("nnfConv': " ++ err ++ " case") + + quantCase :: (TriviaCtxt thry, ?pth ::HOL cls thry HOLThm, ?cf :: Bool, + ?rule :: HOLTerm -> HOLThm -> HOL cls thry HOLThm) + => String -> HOLTerm -> HOLTerm -> HOLTerm -> HOLType + -> HOL cls thry HOLThm + quantCase err bod x t ty = + (do notTm <- serve notPTm + pth <- ?pth + thN <- runConv (nnfConv' ?cf baseconvs) t + th1 <- instPth pth bod ty + lth <- fromRightM $ ruleAP_TERM notTm =<< primBETA =<< + mkComb bod x + th2 <- ?rule x #<< primTRANS lth thN + fromRightM $ primTRANS th1 th2) + ("nnfConv': " ++ err ++ " case") + + baseCase :: TriviaCtxt thry => HOLTerm -> HOL cls thry HOLThm + baseCase tm = + (do tm' <- mkNeg tm + runConv base1 tm' <|> (return $! primREFL tm')) + " nnfConv': base case" + + instPth :: HOLThm -> HOLTerm -> HOLType -> HOL cls thry HOLThm + instPth pth bod ty = + do p <- liftM (mkVar "P") $ mkFunTy ty tyBool + liftO . primINST [(p, bod)] $ primINST_TYPE [(tyA, ty)] pth + + +nnfConv :: (BasicConvs thry, TriviaCtxt thry) => NNFConv cls thry +nnfConv cf baseconvs@(base1, base2) = Conv $ \ tm -> + do orTm <- serve orPTm + notTm <- serve notPTm + andTm <- serve andPTm + pTm <- serve pPTm + qTm <- serve qPTm + case tm of + (Comb ( Comb ( Const "/\\" _) l) r) -> + (do thLp <- runConv (nnfConv cf baseconvs) l + thRp <- runConv (nnfConv cf baseconvs) r + fromRightM $ do lth <- ruleAP_TERM andTm thLp + primMK_COMB lth thRp) + "nnfConv: conjunction case" + (Comb ( Comb ( Const "\\/" _) l) r) -> + (do thLp <- runConv (nnfConv cf baseconvs) l + thRp <- runConv (nnfConv cf baseconvs) r + fromRightM $ do lth <- ruleAP_TERM orTm thLp + primMK_COMB lth thRp) + "nnfConv: disjunction case" + (Comb ( Comb ( Const "==>" _) l) r) -> + (do pth <- pthImp + thLn <- runConv (nnfConv' cf baseconvs) l + thRp <- runConv (nnfConv cf baseconvs) r + let lth1 = fromJust $ primINST [(pTm, l), (qTm, r)] pth + fromRightM $ do lth2 <- ruleAP_TERM orTm thLn + primTRANS lth1 =<< primMK_COMB lth2 thRp) + "nnfConv: implication case" + (Comb ( Comb ( Const "=" ( TyApp f (TyApp b _ : _))) l) r) + | f == tyOpFun && b == tyOpBool -> + (do (thLp, thLn) <- nnfDConv cf base2 l + (thRp, thRn) <- nnfDConv cf base2 r + if cf + then do pth <- pthEq' + let lth1 = fromJust $ primINST [(pTm, l), (qTm, r)] pth + fromRightM $ do lth2 <- ruleAP_TERM orTm thLp + lth3 <- ruleAP_TERM orTm thLn + lth4 <- ruleAP_TERM andTm =<< primMK_COMB lth2 thRn + primTRANS lth1 =<< primMK_COMB lth4 =<< primMK_COMB lth3 thRp + else do pth <- pthEq + let lth1 = fromJust $ primINST [(pTm, l), (qTm, r)] pth + fromRightM $ do lth2 <- ruleAP_TERM andTm thLp + lth3 <- ruleAP_TERM andTm thLn + lth4 <- ruleAP_TERM orTm =<< primMK_COMB lth2 thRp + primTRANS lth1 =<< primMK_COMB lth4 =<< primMK_COMB lth3 thRn) + "nnfConv: equation case" + | otherwise -> nnfConvBase base1 tm + (Comb q@( Const "!" ( TyApp f1 (TyApp f2 (:){} : _))) ( Abs x t)) + | f1 == tyOpFun && f2 == tyOpFun -> + (do thP <- runConv (nnfConv True baseconvs) t + fromRightM $ ruleAP_TERM q =<< primABS x thP) + "nnfConv: forall case" + | otherwise -> nnfConvBase base1 tm + (Comb q@( Const "?" ( TyApp f1 (TyApp f2 (:){} : _))) ( Abs x t)) + | f1 == tyOpFun && f2 == tyOpFun -> + (do thP <- runConv (nnfConv cf baseconvs) t + fromRightM $ ruleAP_TERM q =<< primABS x thP) + "nnfConv: exists case" + | otherwise -> nnfConvBase base1 tm + (Comb ( Const "?!" ( TyApp f1 (TyApp f2 (ty : _) : _))) bod@( Abs x t)) + | f1 == tyOpFun && f2 == tyOpFun -> + let y = variant (x:frees t) x in + (do pth <- pthExu + (thP, thN) <- nnfDConv cf base2 t + eq <- mkEq y x + (ethP, _) <- base2 eq + bth <- fromRightM $ primBETA =<< mkComb bod x + bth' <- runConv convBETA #<< mkComb bod y + let thN' = fromJust $ primINST [(x, y)] thN + p <- liftM (mkVar "P") $ mkFunTy ty tyBool + let th1 = fromJust . primINST [(p, bod)] $ primINST_TYPE [(tyA, ty)] pth + th2 <- ruleMK_EXISTS x #<< primTRANS bth thP + lth1 <- fromRightM $ ruleAP_TERM andTm th2 + lth6 <- fromRightM $ do lth2 <- ruleAP_TERM notTm bth + lth3 <- ruleAP_TERM orTm =<< primTRANS lth2 thN + lth4 <- ruleAP_TERM notTm bth' + lth5 <- ruleAP_TERM orTm =<< primTRANS lth4 thN' + primMK_COMB lth3 =<< primMK_COMB lth5 ethP + th3 <- ruleMK_FORALL x =<< ruleMK_FORALL y lth6 + fromRightM $ primTRANS th1 =<< primMK_COMB lth1 th3) + "nnfConv: unique exists case" + | otherwise -> nnfConvBase base1 tm + (Comb ( Const "~" _) t) -> runConv (nnfConv' cf baseconvs) t + _ -> nnfConvBase base1 tm + +nnfConvBase :: Conversion cls thry -> HOLTerm -> HOL cls thry HOLThm +nnfConvBase base1 tm = + (runConv base1 tm <|> (return $! primREFL tm)) + "nnfConv: base case" + + +convGEN_NNF :: (BasicConvs thry, TriviaCtxt thry) => Bool + -> (Conversion cls thry, HOLTerm -> HOL cls thry (HOLThm, HOLThm)) + -> Conversion cls thry +convGEN_NNF = nnfConv + +convNNF :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convNNF = convGEN_NNF False (_ALL, \ t -> do th <- liftM primREFL $ mkNeg t + return (primREFL t, th)) + +convNNFC :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convNNFC = convGEN_NNF True (_ALL, \ t -> do th <- liftM primREFL $ mkNeg t + return (primREFL t, th)) + + + diff --git a/src/HaskHOL/Lib/Classic.hs b/src/HaskHOL/Lib/Classic.hs new file mode 100644 index 0000000..2d50907 --- /dev/null +++ b/src/HaskHOL/Lib/Classic.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE FlexibleContexts, PatternSynonyms #-} +{-| + Module: HaskHOL.Lib.Classic + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Classic + ( ClassicType + , ClassicCtxt + , axETA + , convETA + , thmEQ_EXT + , thmFUN_EQ + , isSelect -- select operator + , destSelect + , mkSelect + , axSELECT + , thmEXISTS + , ruleSELECT + , convSELECT + , thmSELECT_REFL + , thmSELECT_UNIQUE + , thmEXCLUDED_MIDDLE + , tTAUT_TAC + , ruleTAUT + , thmBOOL_CASES_AX + , tacBOOL_CASES + , tacASM_CASES + , thmNOT_EXISTS + , thmEXISTS_NOT + , thmNOT_FORALL + , thmFORALL_BOOL + , thmEXISTS_BOOL + , thmDE_MORGAN + , thmNOT_CLAUSES + , thmNOT_IMP + , thmCONTRAPOS + , thmLEFT_FORALL_OR + , thmRIGHT_FORALL_OR + , thmLEFT_OR_FORALL + , thmRIGHT_OR_FORALL + , isCond + , mkCond + , thmCOND_CLAUSES + , convCONTRAPOS + , tacREFUTE_THEN + , thmSKOLEM + , thmUNIQUE_SKOLEM_ALT + , newTypeDefinition + , getTypeDefinition + , addIndDefs + , getIndDefs + , newSpecification + , getSpecification + , thmMONO_COND + , thmCOND_CONG + , thmCOND_EQ_CLAUSE + , inductBool + , recursionBool + , defCOND + , thmCOND_ELIM + , convCOND_ELIM + , tacCOND_CASES + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Equal +import HaskHOL.Lib.Simp +import HaskHOL.Lib.DRule +import HaskHOL.Lib.Tactics +import HaskHOL.Lib.Theorems + +-- B Module defines the rules needed for the second rewrite rule. +-- Notably this is TAUT_TAC and rTAUT. +import HaskHOL.Lib.Classic.B +import HaskHOL.Lib.Classic.C + +-- Defines the finalized classic context with all parser extensions, +-- rewrites, axioms, and other jazz. +import HaskHOL.Lib.Classic.Base +import HaskHOL.Lib.Classic.Context + + +thmDE_MORGAN :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmDE_MORGAN = cacheProof "thmDE_MORGAN" ctxtClassic $ + ruleTAUT [str| !t1 t2. (~(t1 /\ t2) <=> ~t1 \/ ~t2) /\ + (~(t1 \/ t2) <=> ~t1 /\ ~t2) |] + +thmFORALL_BOOL :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmFORALL_BOOL = cacheProof "thmFORALL_BOOL" ctxtClassic $ + prove [str| (!b. P b) <=> P T /\ P F |] $ + tacEQ `_THEN` + tacDISCH `_THEN` + tacASM_REWRITE_NIL `_THEN` + tacGEN `_THEN` + tacBOOL_CASES "b:bool" `_THEN` + tacASM_REWRITE_NIL + +thmNOT_EXISTS :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmNOT_EXISTS = cacheProof "thmNOT_EXISTS" ctxtClassic $ + prove "!P. ~(?x:A. P x) <=> (!x. ~(P x))" $ + tacGEN `_THEN` + tacEQ `_THEN` + tacDISCH `_THENL` + [ tacGEN `_THEN` + tacDISCH `_THEN` + tacUNDISCH "~(?x:A. P x)" `_THEN` + tacREWRITE_NIL `_THEN` + tacEXISTS "x:A" `_THEN` + _POP_ASSUM tacACCEPT + , _DISCH_THEN (_CHOOSE_THEN tacMP) `_THEN` + tacASM_REWRITE_NIL + ] + +thmEXISTS_NOT :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmEXISTS_NOT = cacheProof "thmEXISTS_NOT" ctxtClassic $ + prove "!P. (?x:A. ~(P x)) <=> ~(!x. P x)" $ + tacONCE_REWRITE [ruleTAUT "(a <=> ~b) <=> (~a <=> b)"] `_THEN` + tacREWRITE [thmNOT_EXISTS] + +thmNOT_FORALL :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmNOT_FORALL = cacheProof "thmNOT_FORALL" ctxtClassic $ + prove "!P. ~(!x. P x) <=> (?x:A. ~(P x))" $ + tacMATCH_ACCEPT (ruleGSYM thmEXISTS_NOT) + +thmLEFT_FORALL_OR :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmLEFT_FORALL_OR = cacheProof "thmLEFT_FORALL_OR" ctxtClassic $ + prove [str| !P Q. (!x:A. P x \/ Q) <=> (!x. P x) \/ Q |] $ + _REPEAT tacGEN `_THEN` + tacONCE_REWRITE [ruleTAUT "(a <=> b) <=> (~a <=> ~b)"] `_THEN` + tacREWRITE [thmNOT_FORALL, thmDE_MORGAN, thmLEFT_EXISTS_AND] + +thmRIGHT_FORALL_OR :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmRIGHT_FORALL_OR = cacheProof "thmRIGHT_FORALL_OR" ctxtClassic $ + prove [str| !P Q. (!x:A. P \/ Q x) <=> P \/ (!x. Q x) |] $ + _REPEAT tacGEN `_THEN` + tacONCE_REWRITE [ruleTAUT "(a <=> b) <=> (~a <=> ~b)"] `_THEN` + tacREWRITE [thmNOT_FORALL, thmDE_MORGAN, thmRIGHT_EXISTS_AND] + +thmLEFT_OR_FORALL :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmLEFT_OR_FORALL = cacheProof "thmLEFT_OR_FORALL" ctxtClassic $ + prove [str| !P Q. (!x:A. P x) \/ Q <=> (!x. P x \/ Q) |] $ + tacMATCH_ACCEPT (ruleGSYM thmLEFT_FORALL_OR) + +thmRIGHT_OR_FORALL :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmRIGHT_OR_FORALL = cacheProof "thmRIGHT_OR_FORALL" ctxtClassic $ + prove [str| !P Q. P \/ (!x:A. Q x) <=> (!x. P \/ Q x) |] $ + tacMATCH_ACCEPT (ruleGSYM thmRIGHT_FORALL_OR) + +thmSKOLEM :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmSKOLEM = cacheProof "thmSKOLEM" ctxtClassic $ + prove "!P. (!x:A. ?y:B. P x y) <=> (?y. !x. P x (y x))" $ + _REPEAT (tacSTRIP `_ORELSE` tacEQ) `_THENL` + [ tacEXISTS [str| \x:A. @y:B. P x y |] `_THEN` + tacGEN `_THEN` + tacBETA `_THEN` + tacCONV convSELECT + , tacEXISTS "(y:A->B) x" + ] `_THEN` + _POP_ASSUM tacMATCH_ACCEPT + +-- select operator, giving associativity and commutativity +isSelect :: HOLTerm -> Bool +isSelect = isBinder "@" + +destSelect :: HOLTerm -> Maybe (HOLTerm, HOLTerm) +destSelect = destBinder "@" + +mkSelect :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm +mkSelect = mkBinder "@" + +isCond :: HOLTerm -> Bool +isCond tm = + case rator =<< rator =<< rator tm of + Just (Const "COND" _) -> True + _ -> False + +mkCond :: HOLTerm -> HOLTerm -> HOLTerm -> HOL cls thry HOLTerm +mkCond b x y = + (do c <- mkConst "COND" [(tyA, typeOf x)] + fromRightM $ flip mkComb y =<< flip mkComb x =<< mkComb c b) + "mkCond" + +convETA :: ClassicCtxt thry => Conversion cls thry +convETA = Conv $ \ tm -> + do t <- serve [classic| t:A->B |] + pth <- convETA_pth + case tm of + (Abs bv bod@(Comb l r)) -> + if r == bv && not (varFreeIn bv l) + then fromRightM $ primTRANS (primREFL tm) #<< + rulePINST [(tyA, typeOf bv), (tyB, typeOf bod)] [(t, l)] pth + else fail "convETA" + _ -> fail "convETA: term not an abstraction" + where convETA_pth :: ClassicCtxt thry => HOL cls thry HOLThm + convETA_pth = cacheProof "convETA_pth" ctxtClassic $ + prove [str| (\x. (t:A->B) x) = t |] $ + tacMATCH_ACCEPT axETA + + + + +thmFUN_EQ :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmFUN_EQ = cacheProof "thmFUN_EQ" ctxtClassic $ + prove "!(f:A->B) g. f = g <=> (!x. f x = g x)" $ + _REPEAT tacGEN `_THEN` + tacEQ `_THENL` + [ _DISCH_THEN tacSUBST1 `_THEN` tacGEN `_THEN` tacREFL + , tacMATCH_ACCEPT thmEQ_EXT + ] + +-- expand quantification over booleans + +thmEXISTS_BOOL :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmEXISTS_BOOL = cacheProof "thmEXISTS_BOOL" ctxtClassic $ + prove [str| (?b. P b) <=> P T \/ P F |] $ + tacMATCH_MP (ruleTAUT "(~p <=> ~q) ==> (p <=> q)") `_THEN` + tacREWRITE [thmDE_MORGAN, thmNOT_EXISTS, thmFORALL_BOOL] + +-- classically based rules +convCONTRAPOS :: (BasicConvs thry, ClassicCtxt thry) => Conversion cls thry +convCONTRAPOS = Conv $ \ tm -> + do (a, b) <- pairMapM serve ([classic| a:bool |], [classic| b:bool |]) + pth <- convCONTRAPOS_pth + liftMaybe "convCONTRAPOS: " $ + do (p, q) <- destImp tm + primINST [(a, p), (b, q)] pth + where convCONTRAPOS_pth :: (BasicConvs thry, ClassicCtxt thry) + => HOL cls thry HOLThm + convCONTRAPOS_pth = cacheProof "convCONTRAPOS_pth" ctxtClassic $ + ruleTAUT "(a ==> b) <=> (~b ==> ~a)" + +-- refutation tactic +tacREFUTE_THEN :: (BasicConvs thry, ClassicCtxt thry) => ThmTactic cls thry + -> Tactic cls thry +tacREFUTE_THEN ttac gl@(Goal _ w) = + do fTm <- serve [classic| F |] + if w == fTm + then _ALL gl + else if isNeg w then _DISCH_THEN ttac gl + else (tacCONV (convREWR tacREFUTE_THEN_pth) `_THEN` + _DISCH_THEN ttac) gl + where tacREFUTE_THEN_pth :: (BasicConvs thry, ClassicCtxt thry) + => HOL cls thry HOLThm + tacREFUTE_THEN_pth = cacheProof "tacREFUTE_THEN_pth" ctxtClassic $ + ruleTAUT "p <=> ~p ==> F" + + +-- skolemization + +thmUNIQUE_SKOLEM_ALT :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmUNIQUE_SKOLEM_ALT = cacheProof "thmUNIQUE_SKOLEM_ALT" ctxtClassic $ + prove [str| !P:A->B->bool. + (!x. ?!y. P x y) <=> ?f. !x y. P x y <=> (f x = y) |] $ + tacGEN `_THEN` tacREWRITE [thmEXISTS_UNIQUE_ALT, thmSKOLEM] + +-- basic selection theorems +thmSELECT_UNIQUE :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmSELECT_UNIQUE = cacheProof "thmSELECT_UNIQUE" ctxtClassic $ + prove "!P x. (!y:A. P y = (y = x)) ==> ((@) P = x)" $ + _REPEAT tacSTRIP `_THEN` + tacGEN_REWRITE (convLAND . convRAND) [ruleGSYM axETA] `_THEN` + tacASM_REWRITE [thmSELECT_REFL] + +-- type definitions + +data TypeDefs = TypeDefs !(Map Text ((Text, Text), (HOLThm, HOLThm))) + deriving Typeable + +deriveSafeCopy 0 'base ''TypeDefs + +getTypeDefs :: Query TypeDefs (Map Text ((Text, Text), (HOLThm, HOLThm))) +getTypeDefs = + do (TypeDefs defs) <- ask + return defs + +getTypeDef :: Text -> Query TypeDefs (Maybe HOLThm) +getTypeDef name = + do (TypeDefs defs) <- ask + case mapLookup name defs of + Just (_, (_, th)) -> return $! Just th + Nothing -> return Nothing + +addTypeDef :: Text -> ((Text, Text), (HOLThm, HOLThm)) + -> Update TypeDefs () +addTypeDef name stuff = + do (TypeDefs defs) <- get + put (TypeDefs (mapInsert name stuff defs)) + +makeAcidic ''TypeDefs ['getTypeDefs, 'getTypeDef, 'addTypeDef] + + +newTypeDefinition :: (BasicConvs thry, ClassicCtxt thry, + HOLThmRep thm Theory thry) => Text + -> Text -> Text -> thm -> HOL Theory thry HOLThm +newTypeDefinition tyname absname repname pth = + do acid <- openLocalStateHOL (TypeDefs mapEmpty) + defs <- queryHOL acid GetTypeDefs + closeAcidStateHOL acid + th <- toHThm pth + case mapLookup tyname defs of + Just (_, (th', tth')) -> + if concl th' /= concl th + then fail "newTypeDefinition: bad redefinition" + else printDebugLn "newTypeDefinition: benign redefinition." $ + return tth' + Nothing -> + do th0 <- ruleCONV (convRATOR (convREWR thmEXISTS) `_THEN` + convBETA) th + (th1, th2) <- newBasicTypeDefinition tyname absname repname th0 + th3 <- ruleGEN_ALL th1 + tth <- ruleCONJ th3 =<< ruleGEN_ALL =<< + ruleCONV (convLAND (_TRY convBETA)) th2 + acid' <- openLocalStateHOL (TypeDefs mapEmpty) + updateHOL acid' + (AddTypeDef tyname ((absname, repname), (th, tth))) + createCheckpointAndCloseHOL acid' + return tth + +getTypeDefinition :: Text -> HOL cls thry HOLThm +getTypeDefinition tyname = + do acid <- openLocalStateHOL (TypeDefs mapEmpty) + th <- queryHOL acid (GetTypeDef tyname) + closeAcidStateHOL acid + liftMaybe "getTypeDefinition: type name not found." th + +ruleSEL :: (BasicConvs thry, ClassicCtxt thry) => HOLThm -> HOL cls thry HOLThm +ruleSEL th = ruleCONV (convRATOR (convREWR thmEXISTS) `_THEN` convBETA) th + +checkDistinct :: Eq a => [a] -> Bool +checkDistinct l = + case foldr (\ t res -> case res of + Nothing -> Nothing + Just res' -> if t `elem` res' then Nothing else Just $ t : res') (Just []) l of + Just{} -> True + _ -> False + +specify :: (BasicConvs thry, ClassicCtxt thry) => HOLThm -> Text + -> HOL Theory thry HOLThm +specify th name = + do th1 <- ruleSEL th + case concl th1 of + (Comb l r) -> + let ty = typeOf r in + do th2 <- newDefinition name =<< mkEq (mkVar name ty) r + th3 <- fromRightM $ ruleSYM th2 + ruleCONV convBETA #<< flip primEQ_MP th1 =<< ruleAP_TERM l th3 + _ -> fail "specify" + +data Specifications = + Specifications ![(([Text], HOLThm), HOLThm)] deriving Typeable + +deriveSafeCopy 0 'base ''Specifications + +getSpecifications :: Query Specifications [(([Text], HOLThm), HOLThm)] +getSpecifications = + do (Specifications specs) <- ask + return specs + +getASpecification :: [Text] -> Query Specifications (Maybe HOLThm) +getASpecification names = + do (Specifications specs) <- ask + case find (\ ((names', _), _) -> names' == names) specs of + Just (_, th) -> return $! Just th + Nothing -> return Nothing + +addSpecification :: [Text] -> HOLThm -> HOLThm -> Update Specifications () +addSpecification names th sth = + do (Specifications specs) <- get + put (Specifications (((names, th), sth) : specs)) + +makeAcidic ''Specifications + ['getSpecifications, 'getASpecification, 'addSpecification] + + +newSpecification :: (BasicConvs thry, ClassicCtxt thry) => [Text] -> HOLThm + -> HOL Theory thry HOLThm +newSpecification names th = + let (asl, c) = destThm th in + do failWhen (return . not $ null asl) + "newSpecification: Assumptions not allowed in theorem" + failWhen (return . not . null $ frees c) + "newSpecification: Free variables in predicate" + let avs = fst $ stripExists c + failWhen (return $ null names || length names > length avs) + "newSpecification: Unsuitable number of constant names" + failWhen (return . not $ checkDistinct names) + "newSpecification: Constant names not distinct" + acid <- openLocalStateHOL (Specifications []) + specs <- queryHOL acid GetSpecifications + closeAcidStateHOL acid + case find (\ ((names', th'), _) -> + names' == names && + concl th' `aConv` concl th) specs of + Just (_, sth) -> + return sth + Nothing -> + do sth <- foldlM specify th names + acid' <- openLocalStateHOL (Specifications []) + updateHOL acid' (AddSpecification names th sth) + createCheckpointAndCloseHOL acid' + return sth + +getSpecification :: [Text] -> HOL cls thry HOLThm +getSpecification names = + do acid <- openLocalStateHOL (Specifications []) + th <- queryHOL acid (GetASpecification names) + closeAcidStateHOL acid + liftMaybe "getSpecification: constants not found." th + +thmCOND_ELIM :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmCOND_ELIM = cacheProof "thmCOND_ELIM" ctxtClassic $ + prove [str| (P:A->bool) (if c then x else y) <=> + (c ==> P x) /\ (~c ==> P y) |] $ + tacBOOL_CASES "c:bool" `_THEN` tacREWRITE_NIL + +convCOND_ELIM :: (BasicConvs thry, ClassicCtxt thry) => Conversion cls thry +convCOND_ELIM = convHIGHER_REWRITE [thmCOND_ELIM] True + +tacCOND_CASES :: (BasicConvs thry, ClassicCtxt thry) => Tactic cls thry +tacCOND_CASES = + tacCONV convCOND_ELIM `_THEN` tacCONJ `_THENL` + [ _DISCH_THEN (\ th -> tacASSUME th `_THEN` tacSUBST1 (ruleEQT_INTRO th)) + , _DISCH_THEN (\ th g -> (do th' <- ruleDENEG th + (tacASSUME th' `_THEN` + tacSUBST1 (ruleEQT_INTRO th')) g) + <|> (tacASSUME th `_THEN` + tacSUBST1 (ruleEQF_INTRO th)) g) + ] + where ruleDENEG :: (BasicConvs thry, ClassicCtxt thry) => HOLThm + -> HOL cls thry HOLThm + ruleDENEG = ruleGEN_REWRITE id [tacCOND_CASES_pth] + + tacCOND_CASES_pth :: (BasicConvs thry, ClassicCtxt thry) + => HOL cls thry HOLThm + tacCOND_CASES_pth = cacheProof "tacCOND_CASES_pth" ctxtClassic $ + ruleTAUT "~ ~ p <=> p" + +thmCONTRAPOS :: (BasicConvs thry, ClassicCtxt thry) => HOL cls thry HOLThm +thmCONTRAPOS = cacheProof "thmCONTRAPOS" ctxtClassic $ + ruleTAUT "!t1 t2. (~t1 ==> ~t2) <=> (t2 ==> t1)" diff --git a/src/HaskHOL/Lib/Classic/A.hs b/src/HaskHOL/Lib/Classic/A.hs new file mode 100644 index 0000000..444061b --- /dev/null +++ b/src/HaskHOL/Lib/Classic/A.hs @@ -0,0 +1,7 @@ +module HaskHOL.Lib.Classic.A + ( module HaskHOL.Lib.Classic.A.Base + , module HaskHOL.Lib.Classic.A.Context + ) where + +import HaskHOL.Lib.Classic.A.Base +import HaskHOL.Lib.Classic.A.Context diff --git a/src/HaskHOL/Lib/Classic/A/Base.hs b/src/HaskHOL/Lib/Classic/A/Base.hs new file mode 100644 index 0000000..8e97711 --- /dev/null +++ b/src/HaskHOL/Lib/Classic/A/Base.hs @@ -0,0 +1,20 @@ +module HaskHOL.Lib.Classic.A.Base where + +import HaskHOL.Core + +import HaskHOL.Lib.Bool +import HaskHOL.Lib.DRule + +-- eta conv stuff +axETA' :: HOL Theory thry HOLThm +axETA' = newAxiom "axETA" [str| !t:A->B. (\x. t x) = t |] + + +axSELECT' :: HOL Theory thry HOLThm +axSELECT' = newAxiom "axSELECT" "!P (x:A). P x ==> P((@) P)" + +-- conditionals +defCOND' :: BoolCtxt thry => HOL Theory thry HOLThm +defCOND' = newDefinition "COND" + [str| COND = \t t1 t2. @x:A. ((t <=> T) ==> (x = t1)) /\ + ((t <=> F) ==> (x = t2)) |] diff --git a/src/HaskHOL/Lib/Classic/A/Context.hs b/src/HaskHOL/Lib/Classic/A/Context.hs new file mode 100644 index 0000000..68f491a --- /dev/null +++ b/src/HaskHOL/Lib/Classic/A/Context.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TypeSynonymInstances, + UndecidableInstances #-} +module HaskHOL.Lib.Classic.A.Context + ( ClassicAType + , ClassicACtxt + , ctxtClassicA + , classicA + ) where + +import HaskHOL.Core +import HaskHOL.Lib.Simp + +import HaskHOL.Lib.IndDefs.Context +import HaskHOL.Lib.Classic.A.Base + +-- generate template types +extendTheory ctxtIndDefs "ClassicA" $ + do parseAsBinder "@" + newConstant "@" "(A->bool)->A" + sequence_ [axETA', axSELECT'] + void defCOND' + +templateProvers 'ctxtClassicA + +-- have to manually write this, for now +type family ClassicACtxt a where + ClassicACtxt a = (IndDefsCtxt a, ClassicAContext a ~ 'True) + +type instance PolyTheory ClassicAType b = ClassicACtxt b + +instance BasicConvs ClassicAType where + basicConvs _ = [] diff --git a/src/HaskHOL/Lib/Classic/B.hs b/src/HaskHOL/Lib/Classic/B.hs new file mode 100644 index 0000000..fe29e0f --- /dev/null +++ b/src/HaskHOL/Lib/Classic/B.hs @@ -0,0 +1,7 @@ +module HaskHOL.Lib.Classic.B + ( module HaskHOL.Lib.Classic.B.Base + , module HaskHOL.Lib.Classic.B.Context + ) where + +import HaskHOL.Lib.Classic.B.Base +import HaskHOL.Lib.Classic.B.Context diff --git a/src/HaskHOL/Lib/Classic/B/Base.hs b/src/HaskHOL/Lib/Classic/B/Base.hs new file mode 100644 index 0000000..cb488a9 --- /dev/null +++ b/src/HaskHOL/Lib/Classic/B/Base.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE PatternSynonyms #-} +module HaskHOL.Lib.Classic.B.Base where + +import HaskHOL.Core + +import HaskHOL.Lib.Equal +import HaskHOL.Lib.DRule +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Tactics +import HaskHOL.Lib.Simp + +import HaskHOL.Lib.Classic.A + +-- guarded definitions from classicA +-- | @!t:A->B. (\x. t x) = t@ +axETA :: ClassicACtxt thry => HOL cls thry HOLThm +axETA = cacheProof "axETA" ctxtClassicA $ getAxiom "axETA" + +-- | @!P (x:A). P x ==> P((@) P)@ +axSELECT :: ClassicACtxt thry => HOL cls thry HOLThm +axSELECT = cacheProof "axSELECT" ctxtClassicA $ getAxiom "axSELECT" + +-- | @COND = \t t1 t2. @x:A. ((t <=> T) ==> (x = t1)) /\ ((t <=> F) ==> (x = t2))@ +defCOND :: ClassicACtxt thry => HOL cls thry HOLThm +defCOND = cacheProof "defCOND" ctxtClassicA $ getDefinition "COND" + +-- bootstrapping selection +thmEQ_EXT :: (BasicConvs thry, ClassicACtxt thry) => HOL cls thry HOLThm +thmEQ_EXT = cacheProof "thmEQ_EXT" ctxtClassicA $ + do x <- toHTm "x:A" + prove "!(f:A->B) g. (!x. f x = g x) ==> f = g" $ + _REPEAT tacGEN `_THEN` + _DISCH_THEN (\ th g -> do th' <- ruleSPEC x th + th'' <- fromRightM $ primABS x th' + tacMP th'' g) `_THEN` + tacREWRITE [axETA] + +thmEXISTS :: (BasicConvs thry, ClassicACtxt thry) => HOL cls thry HOLThm +thmEXISTS = cacheProof "thmEXISTS" ctxtClassicA $ + prove [str| (?) = \P:A->bool. P ((@) P) |] $ + tacMATCH_MP thmEQ_EXT `_THEN` + tacBETA `_THEN` + tacX_GEN "P:A->bool" `_THEN` + tacGEN_REWRITE (convLAND . convRAND) [ruleGSYM axETA] `_THEN` + tacEQ `_THENL` + [ _DISCH_THEN (_CHOOSE_THEN tacMP) `_THEN` + tacMATCH_ACCEPT axSELECT + , tacDISCH `_THEN` tacEXISTS "((@) P):A" `_THEN` + _POP_ASSUM tacACCEPT + ] + +-- basic selection conversions +convSELECT :: (BasicConvs thry, ClassicACtxt thry) => Conversion cls thry +convSELECT = Conv $ \ tm -> + do p <- serve [classicA| P:A->bool |] + pth <- convSELECT_pth + case findTerm (is_epsok tm) tm of + Just (Comb _ lam@(Abs (Var _ ty) _)) -> + ruleCONV (convLAND convBETA) #<< + rulePINST [(tyA, ty)] [(p, lam)] pth + _ -> do stm <- showHOL tm + fail $ "cSELECT_CONV: " ++ stm + where is_epsok tm t + | isBinder "@" t = + case destBinder "@" t of + Just (bv, bod) -> aConv tm . fromJust $ + varSubst [(bv, t)] bod + _ -> False + | otherwise = False + + convSELECT_pth :: (BasicConvs thry, ClassicACtxt thry) + => HOL cls thry HOLThm + convSELECT_pth = cacheProof "convSELECT_pth" ctxtClassicA $ + prove "(P:A->bool)((@)P) = (?) P" $ + tacREWRITE [thmEXISTS] `_THEN` + tacBETA `_THEN` + tacREFL + +thmSELECT_REFL :: (BasicConvs thry, ClassicACtxt thry) => HOL cls thry HOLThm +thmSELECT_REFL = cacheProof "thmSELECT_REFL" ctxtClassicA $ + prove "!x:A. (@y. y = x) = x" $ + tacGEN `_THEN` + tacCONV convSELECT `_THEN` + tacEXISTS "x:A" `_THEN` + tacREFL + diff --git a/src/HaskHOL/Lib/Classic/B/Context.hs b/src/HaskHOL/Lib/Classic/B/Context.hs new file mode 100644 index 0000000..e435e2a --- /dev/null +++ b/src/HaskHOL/Lib/Classic/B/Context.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TypeSynonymInstances, + UndecidableInstances #-} +module HaskHOL.Lib.Classic.B.Context + ( ClassicBType + , ClassicBCtxt + , ctxtClassicB + , classicB + ) where + +import HaskHOL.Core +import HaskHOL.Lib.Simp + +import HaskHOL.Lib.Classic.A.Context +import HaskHOL.Lib.Classic.B.Base + +-- generate template types +extendTheory ctxtClassicA "ClassicB" $ + extendBasicRewrites =<< sequence [ thmSELECT_REFL ] + +templateProvers 'ctxtClassicB + +-- have to manually write this, for now +type family ClassicBCtxt a where + ClassicBCtxt a = (ClassicACtxt a, ClassicBContext a ~ 'True) + +type instance PolyTheory ClassicBType b = ClassicBCtxt b + +instance BasicConvs ClassicBType where + basicConvs _ = [] diff --git a/src/HaskHOL/Lib/Classic/Base.hs b/src/HaskHOL/Lib/Classic/Base.hs new file mode 100644 index 0000000..b444406 --- /dev/null +++ b/src/HaskHOL/Lib/Classic/Base.hs @@ -0,0 +1,77 @@ +module HaskHOL.Lib.Classic.Base where + +import HaskHOL.Core + +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Tactics +import HaskHOL.Lib.Simp + +import HaskHOL.Lib.Classic.C + +thmMONO_COND :: (BasicConvs thry, ClassicCCtxt thry) => HOL cls thry HOLThm +thmMONO_COND = cacheProof "thmMONO_COND" ctxtClassicC $ + prove [str| (A ==> B) /\ (C ==> D) ==> + (if b then A else C) ==> + (if b then B else D) |] $ + tacSTRIP `_THEN` + tacBOOL_CASES "b:bool" `_THEN` + tacASM_REWRITE_NIL + +thmCOND_CONG :: (BasicConvs thry, ClassicCCtxt thry) => HOL cls thry HOLThm +thmCOND_CONG = cacheProof "thmCOND_CONG" ctxtClassicC $ + ruleTAUT [str| (g = g') ==> + (g' ==> (t = t')) ==> + (~g' ==> (e = e')) ==> + ((if g then t else e) = + (if g' then t' else e')) |] + +thmCOND_EQ_CLAUSE :: (BasicConvs thry, ClassicCCtxt thry) => HOL cls thry HOLThm +thmCOND_EQ_CLAUSE = cacheProof "thmCOND_EQ_CLAUSE" ctxtClassicC $ + prove "(if x = x then y else z) = y" tacREWRITE_NIL + +inductBool :: (BasicConvs thry, ClassicCCtxt thry) => HOL cls thry HOLThm +inductBool = cacheProof "inductBool" ctxtClassicC $ + prove [str| !P. P F /\ P T ==> !x. P x |] $ + _REPEAT tacSTRIP `_THEN` + tacDISJ_CASES (ruleSPEC "x:bool" thmBOOL_CASES_AX) `_THEN` + tacASM_REWRITE_NIL + +recursionBool :: (BasicConvs thry, ClassicCCtxt thry) => HOL cls thry HOLThm +recursionBool = cacheProof "recursionBool" ctxtClassicC $ + prove [str| !a b:A. ?f. f F = a /\ f T = b |] $ + _REPEAT tacGEN `_THEN` + tacEXISTS [str| \x. if x then b:A else a |] `_THEN` + tacREWRITE_NIL + +data IndTypeStore = + IndTypeStore !(Map Text (Int, HOLThm, HOLThm)) deriving Typeable + +deriveSafeCopy 0 'base ''IndTypeStore + +addIndDef :: Text -> (Int, HOLThm, HOLThm) -> Update IndTypeStore () +addIndDef name def = + do (IndTypeStore defs) <- get + case mapLookup name defs of + Nothing -> put (IndTypeStore (mapInsert name def defs)) + _ -> return () + +getIndDefs' :: Query IndTypeStore (Map Text (Int, HOLThm, HOLThm)) +getIndDefs' = + do (IndTypeStore indTys) <- ask + return indTys + +makeAcidic ''IndTypeStore ['addIndDef, 'getIndDefs'] + + +addIndDefs :: [(Text, (Int, HOLThm, HOLThm))] -> HOL Theory thry () +addIndDefs ds = + do acid <- openLocalStateHOL (IndTypeStore mapEmpty) + mapM_ (\ (name, def) -> updateHOL acid (AddIndDef name def)) ds + createCheckpointAndCloseHOL acid + +getIndDefs :: HOL cls thry (Map Text (Int, HOLThm, HOLThm)) +getIndDefs = + do acid <- openLocalStateHOL (IndTypeStore mapEmpty) + indTys <- queryHOL acid GetIndDefs' + closeAcidStateHOL acid + return indTys diff --git a/src/HaskHOL/Lib/Classic/C.hs b/src/HaskHOL/Lib/Classic/C.hs new file mode 100644 index 0000000..9b9579b --- /dev/null +++ b/src/HaskHOL/Lib/Classic/C.hs @@ -0,0 +1,7 @@ +module HaskHOL.Lib.Classic.C + ( module HaskHOL.Lib.Classic.C.Base + , module HaskHOL.Lib.Classic.C.Context + ) where + +import HaskHOL.Lib.Classic.C.Base +import HaskHOL.Lib.Classic.C.Context diff --git a/src/HaskHOL/Lib/Classic/C/Base.hs b/src/HaskHOL/Lib/Classic/C/Base.hs new file mode 100644 index 0000000..20f9d3c --- /dev/null +++ b/src/HaskHOL/Lib/Classic/C/Base.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE PatternSynonyms #-} +module HaskHOL.Lib.Classic.C.Base where + +import HaskHOL.Core + +import HaskHOL.Lib.Equal +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Itab +import HaskHOL.Lib.Tactics +import HaskHOL.Lib.Simp + +import HaskHOL.Lib.Classic.B + +-- derive excluded middle (proof from Beeson's book) +thmEXCLUDED_MIDDLE1 :: ClassicBCtxt thry => HOL cls thry HOLThm +thmEXCLUDED_MIDDLE1 = cacheProof "thmEXCLUDED_MIDDLE1" ctxtClassicB $ + ruleITAUT "~(T <=> F)" + +thmEXCLUDED_MIDDLE2 :: ClassicBCtxt thry => HOL cls thry HOLThm +thmEXCLUDED_MIDDLE2 = cacheProof "thmEXCLUDED_MIDDLE2" ctxtClassicB $ + ruleITAUT [str| p \/ T <=> T |] + +thmEXCLUDED_MIDDLE :: (BasicConvs thry, ClassicBCtxt thry) + => HOL cls thry HOLThm +thmEXCLUDED_MIDDLE = cacheProof "thmEXCLUDED_MIDDLE" ctxtClassicB $ + prove [str| !t. t \/ ~t |] $ + tacGEN `_THEN` + _SUBGOAL_THEN [str| (((@x. (x <=> F) \/ t) <=> F) \/ t) /\ + (((@x. (x <=> T) \/ t) <=> T) \/ t) |] + tacMP `_THENL` + [ tacCONJ `_THEN` + tacCONV convSELECT `_THENL` + [ tacEXISTS "F" + , tacEXISTS "T" + ] `_THEN` + tacDISJ1 `_THEN` tacREFL + , _DISCH_THEN (\ th g -> do th' <- ruleGSYM th + tacSTRIP_ASSUME th' g) `_THEN` + _TRY (tacDISJ1 `_THEN` _FIRST_ASSUM tacACCEPT) `_THEN` + tacDISJ2 `_THEN` + tacDISCH `_THEN` + tacMP thmEXCLUDED_MIDDLE1 `_THEN` + tacPURE_ONCE_ASM_REWRITE [] `_THEN` + tacASM_REWRITE [thmEXCLUDED_MIDDLE2] + ] + + +-- basic selection operator rule +ruleSELECT :: (BasicConvs thry, ClassicBCtxt thry, HOLThmRep thm cls thry) + => thm -> HOL cls thry HOLThm +ruleSELECT pthm = + do p <- serve [classicB| P:A->bool |] + th <- toHThm pthm + pth <- ruleSELECT_pth + case rand $ concl th of + Just lam@(Abs (Var _ ty) _) -> + ruleCONV convBETA =<< + ruleMP (fromJust $ rulePINST [(tyA, ty)] [(p, lam)] pth) th + _ -> fail "ruleSELECT" + where ruleSELECT_pth :: (BasicConvs thry, ClassicBCtxt thry) + => HOL cls thry HOLThm + ruleSELECT_pth = cacheProof "ruleSELECT_pth" ctxtClassicB $ + prove "(?) (P:A->bool) ==> P((@) P)" $ + tacSIMP [axSELECT, axETA] + +thmBOOL_CASES_AX :: (BasicConvs thry, ClassicBCtxt thry) => HOL cls thry HOLThm +thmBOOL_CASES_AX = cacheProof "thmBOOL_CASES_AX" ctxtClassicB $ + prove [str| !t. (t <=> T) \/ (t <=> F) |] $ + tacGEN `_THEN` + tacDISJ_CASES (ruleSPEC "t:bool" thmEXCLUDED_MIDDLE) `_THEN` + tacASM_REWRITE_NIL + +-- classically based tactics +tacBOOL_CASES' :: (BasicConvs thry, ClassicBCtxt thry) => HOLTerm + -> Tactic cls thry +tacBOOL_CASES' p g = + do th <- ruleSPEC p thmBOOL_CASES_AX + tacSTRUCT_CASES th g + +tacBOOL_CASES :: (BasicConvs thry, ClassicBCtxt thry, HOLTermRep tm cls thry) + => tm -> Tactic cls thry +tacBOOL_CASES p = liftM1 tacBOOL_CASES' (toHTm p) + +tacASM_CASES :: (BasicConvs thry, ClassicBCtxt thry, HOLTermRep tm cls thry) + => tm -> Tactic cls thry +tacASM_CASES t g = + do th <- ruleSPEC t thmEXCLUDED_MIDDLE + tacDISJ_CASES th g + +-- tautology checker for classical logic + +-- depends on ordering of terms as prepared by findTerms, probably not good +rtaut_tac :: (BasicConvs thry, ClassicBCtxt thry) => Tactic cls thry +rtaut_tac g@(Goal _ w) = + let ok t = typeOf t == tyBool && isJust (findTerm isVar t) && t `freeIn` w + tac gl = do tm <- liftMaybe "rtaut_tac" . tryHead . sort freeIn $ + findTerms ok w + tacBOOL_CASES tm gl in + + (tacREWRITE_NIL `_THEN` + (tacREWRITE_NIL `_THEN` tac)) g + +tTAUT_TAC :: (BasicConvs thry, ClassicBCtxt thry) => Tactic cls thry +tTAUT_TAC = _REPEAT (tacGEN `_ORELSE` tacCONJ) `_THEN` _REPEAT rtaut_tac + +ruleTAUT' :: (BasicConvs thry, ClassicBCtxt thry) => HOLTerm + -> HOL cls thry HOLThm +ruleTAUT' tm = prove tm tTAUT_TAC + +ruleTAUT :: (BasicConvs thry, HOLTermRep tm cls thry, ClassicBCtxt thry) => tm + -> HOL cls thry HOLThm +ruleTAUT = ruleTAUT' <=< toHTm + +thmNOT_CLAUSES :: (BasicConvs thry, ClassicBCtxt thry) => HOL cls thry HOLThm +thmNOT_CLAUSES = cacheProof "thmNOT_CLAUSES" ctxtClassicB $ + ruleTAUT [str| (!t. ~ ~t <=> t) /\ (~T <=> F) /\ (~F <=> T) |] + +thmNOT_IMP :: (BasicConvs thry, ClassicBCtxt thry) => HOL cls thry HOLThm +thmNOT_IMP = cacheProof "thmNOT_IMP" ctxtClassicB $ + ruleTAUT [str| !t1 t2. ~(t1 ==> t2) <=> t1 /\ ~t2 |] + +thmCOND_CLAUSES :: (BasicConvs thry, ClassicBCtxt thry) => HOL cls thry HOLThm +thmCOND_CLAUSES = cacheProof "thmCOND_CLAUSES" ctxtClassicB $ + prove [str| !(t1:A) t2. ((if T then t1 else t2) = t1) /\ + ((if F then t1 else t2) = t2) |] $ + tacREWRITE [defCOND] diff --git a/src/HaskHOL/Lib/Classic/C/Context.hs b/src/HaskHOL/Lib/Classic/C/Context.hs new file mode 100644 index 0000000..2b6b77f --- /dev/null +++ b/src/HaskHOL/Lib/Classic/C/Context.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TemplateHaskell, + TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +module HaskHOL.Lib.Classic.C.Context + ( ClassicCType + , ClassicCCtxt + , ctxtClassicC + , classicC + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Simp + +import HaskHOL.Lib.Classic.B +import HaskHOL.Lib.Classic.C.Base + +-- generate template types +extendTheory ctxtClassicB "ClassicC" $ + extendBasicRewrites =<< + sequence [ruleCONJUNCT1 thmNOT_CLAUSES, thmCOND_CLAUSES] + +templateProvers 'ctxtClassicC + +-- have to manually write this, for now +type family ClassicCCtxt a where + ClassicCCtxt a = (ClassicBCtxt a, ClassicCContext a ~ 'True) + +type instance PolyTheory ClassicCType b = ClassicCCtxt b + +instance BasicConvs ClassicCType where + basicConvs _ = [] diff --git a/src/HaskHOL/Lib/Classic/Context.hs b/src/HaskHOL/Lib/Classic/Context.hs new file mode 100644 index 0000000..d2c648c --- /dev/null +++ b/src/HaskHOL/Lib/Classic/Context.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TypeSynonymInstances, + UndecidableInstances #-} +module HaskHOL.Lib.Classic.Context + ( ClassicType + , ClassicCtxt + , ctxtClassic + , classic + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Simp +import HaskHOL.Lib.IndDefs + +import HaskHOL.Lib.Classic.C.Context +import HaskHOL.Lib.Classic.Base + +-- generate template types +extendTheory ctxtClassicC "Classic" $ + do mthm <- thmMONO_COND + addMonoThm mthm + cth <- thmCOND_CONG + extendBasicCongs [cth] + rth <- thmCOND_EQ_CLAUSE + extendBasicRewrites [rth] + boolTh1 <- inductBool + boolTh2 <- recursionBool + addIndDefs [("bool", (2, boolTh1, boolTh2))] + +templateProvers 'ctxtClassic + +-- have to manually write this, for now +type family ClassicCtxt a where + ClassicCtxt a = (ClassicCCtxt a, ClassicContext a ~ 'True) + +type instance PolyTheory ClassicType b = ClassicCtxt b + +instance BasicConvs ClassicType where + basicConvs _ = [] diff --git a/src/HaskHOL/Lib/DRule.hs b/src/HaskHOL/Lib/DRule.hs new file mode 100644 index 0000000..ff9de8e --- /dev/null +++ b/src/HaskHOL/Lib/DRule.hs @@ -0,0 +1,716 @@ +{-# LANGUAGE FlexibleContexts, PatternSynonyms #-} +{-| + Module: HaskHOL.Lib.DRule + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.DRule + ( Instantiation + , mkThm + , ruleMK_CONJ + , ruleMK_DISJ + , ruleMK_FORALL + , ruleMK_EXISTS + , convMP + , convBETAS + , instantiate + , ruleINSTANTIATE + , ruleINSTANTIATE_ALL + , termMatch + , termUnify + , rulePART_MATCH + , ruleGEN_PART_MATCH + , ruleMATCH_MP + , convHIGHER_REWRITE + , newDefinition + , getDefinition + ) where + +import HaskHOL.Core +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Bool.Context +import HaskHOL.Lib.Equal + +-- | 'mkThm' can be used to construct an arbitrary 'HOLThm' using 'newAxiom'. +mkThm :: BoolCtxt thry => [HOLTerm] -> HOLTerm -> HOL Theory thry HOLThm +mkThm asl c = + do n <- tickTermCounter + ax <- newAxiom ("mkThm" `append` textShow n) =<< + foldrM mkImp c (reverse asl) + foldlM (\ th t -> ruleMP th #<< primASSUME t) ax $ reverse asl + +{-|@ + A |- p \<=\> p' B |- q \<=\> q' +----------------------------------- + A U B |- p \/\\ q \<=\> p' \/\\ q' +@ + + Throws a 'HOLException' if the conclusions of the provided theorems are not + both biconditionals. +-} +ruleMK_CONJ :: BoolCtxt thry => HOLThm -> HOLThm -> HOL cls thry HOLThm +ruleMK_CONJ eq1 eq2 = + (do andtm <- serve [bool| (/\) |] + liftO $ liftM1 primMK_COMB (ruleAP_TERM andtm eq1) eq2) + "ruleMK_CONJ" + +{-|@ + A |- p \<=\> p' B |- q \<=\> q' +----------------------------------- + A U B |- p \\/ q \<=\> p' \\/ q' +@ + + Throws a 'HOLException' if the conclusions of the provided theorems are not + both biconditionals. +-} +ruleMK_DISJ :: BoolCtxt thry => HOLThm -> HOLThm -> HOL cls thry HOLThm +ruleMK_DISJ eq1 eq2 = + (do ortm <- serve [bool| (\/) |] + liftO $ liftM1 primMK_COMB (ruleAP_TERM ortm eq1) eq2) + "ruleMK_DISJ" + +{-|@ + v A |- p \<=\> q +---------------------------- + A |- (!v. p) \<=\> (!v. q) +@ + + Throws a 'HOLException' in the following conditions: + + * The provided term is not a variable. + + * The provided term is free in the hypotheses of the provided theorem. + + * The conclusion of the provided theorem is not a biconditional. +-} +ruleMK_FORALL :: BoolCtxt thry => HOLTerm -> HOLThm -> HOL cls thry HOLThm +ruleMK_FORALL v th = + (do atm <- serve [bool| (!):(A->bool)->bool |] + liftO $ ruleAP_TERM (inst [(tyA, typeOf v)] atm) =<< primABS v th) + "ruleMK_FORALL" + +{-|@ + v A |- p \<=\> q +---------------------------- + A |- (?v. p) \<=\> (?v. q) +@ + + Throws a 'HOLException' in the following conditions: + + * The provided term is not a variable. + + * The provided term is free in the hypotheses of the provided theorem. + + * The conclusion of the provided theorem is not a biconditional. +-} +ruleMK_EXISTS :: BoolCtxt thry => HOLTerm -> HOLThm -> HOL cls thry HOLThm +ruleMK_EXISTS v th = + (do atm <- serve [bool| (?):(A->bool)->bool |] + liftO $ ruleAP_TERM (inst [(tyA, typeOf v)] atm) =<< primABS v th) + "ruleMK_EXISTS" + +{-| + 'convMP' applies a provided conversion to a theorem of the form + @A |- p ==> q@. If the conversion returns an intermediate theorem of the form + @|- p@ or @|- p \<=\> T@ then the final theorem @A |- q@ is returned. It + throws a 'HOLException' in the following cases: + + * The conclusion of the provided theorem is not an implication. + + * The application of the conversion fails. + + * The conversion does not solve the antecedent of the implication. +-} +convMP :: BoolCtxt thry => Conversion cls thry -> HOLThm -> HOL cls thry HOLThm +convMP conv th = noteHOL "convMP" $ + do (l, _) <- liftMaybe "conclusion not an implication." . destImp $ concl th + ath <- runConv conv l "conversion failed." + (ruleMP th =<< ruleEQT_ELIM ath) <|> ruleMP th ath + "antecedent not solved." + +{-| + The 'convBETAS' conversion performs a beta conversion on a application with + multiple arguments returning a theorem of the form + @|- (\ x1 ... xn. t) s1 ... sn = t[s1, ..., sn / x1, ..., xn]@ +-} +convBETAS :: Conversion cls thry +convBETAS = Conv $ \ tm -> + case tm of + (Comb Abs{} _) -> runConv convBETA tm + (Comb Comb{} _) -> + runConv (convRATOR convBETAS `_THEN` convBETA) tm + _ -> fail "convBETAS" + +-- instantiation rules +type Instantiation = ([(HOLTerm, Int)], [(HOLTerm, HOLTerm)], SubstTrip) + +{-| + Applies an 'Instantiation' to a term. This application should never fail, + provided the instantiation is correctly constructed. See 'termMatch' for more + details. +-} +instantiate :: Instantiation -> HOLTerm -> HOLTerm +instantiate (xs, tmenv, tyenv) x = + let itm = if tyenv == ([], [], []) then x else instFull tyenv x in + if null tmenv then itm + else fromJust $ do ttm <- varSubst tmenv itm + if null xs + then return ttm + else hush (hoBetas itm ttm) <|> return ttm + where betas :: Int -> HOLTerm -> Maybe HOLTerm + betas n tm = + do (args, lam) <- funpowM n (\ (l, t) -> + do tRand <- rand t + tRator <- rator t + return (tRand:l, tRator)) ([], tm) + foldlM (\ l a -> do (v, b) <- destAbs l + varSubst [(v, a)] b) lam args + + hoBetas :: HOLTerm -> HOLTerm -> Either String HOLTerm + hoBetas Var{} _ = Left "hoBetas" + hoBetas Const{} _ = Left "hoBetas" + hoBetas (Abs _ bod1) (Abs bv bod2) = + do th <- hoBetas bod1 bod2 + mkAbs bv th + hoBetas pat tm = + let (hop, args) = stripComb pat + n = length args in + if lookup hop xs == Just n + then liftO $ betas n tm + else case (pat, tm) of + (Comb lpat rpat, Comb ltm rtm) -> + do { lth <- hoBetas lpat ltm + ; (mkComb lth =<< hoBetas rpat rtm) <|> + mkComb lth rtm + } <|> + (mkComb ltm =<< hoBetas rpat rtm) + _ -> Left "hoBetas" + +{-| + The 'ruleINSTANTIATE' rule applies an 'Instantiation' to the conclusion of a + provided theorem. It throws a 'HOLException' in the case when instantiation + fails due to a term or type variable being free in the assumption list. See + 'termMatch' for more details. +-} +ruleINSTANTIATE :: HOLThmRep thm cls thry => Instantiation -> thm + -> HOL cls thry HOLThm +ruleINSTANTIATE (_, [], ([], [], [])) pthm = toHThm pthm +ruleINSTANTIATE (_, [], tyenv) pthm = + liftM (primINST_TYPE_FULL tyenv) $ toHThm pthm +ruleINSTANTIATE (bcs, tmenv, tyenv) pthm = noteHOL "ruleINSTANTIATE" $ + do thm <- toHThm pthm + let ithm = if tyenv == ([], [], []) then thm + else primINST_TYPE_FULL tyenv thm + tthm <- liftMaybe "instantiation failed." $ primINST tmenv ithm + if hyp tthm == hyp thm + then if null bcs then return tthm + else (do ethm <- ruleHO_BETAS (concl ithm) (concl tthm) + liftO $ primEQ_MP ethm tthm) + <|> return tthm + else fail "term or type variable free in assumptions." + where ruleHO_BETAS :: HOLTerm -> HOLTerm -> HOL cls thry HOLThm + ruleHO_BETAS Var{} _ = fail "ruleHO_BETAS" + ruleHO_BETAS Const{} _ = fail "ruleHO_BETAS" + ruleHO_BETAS (Abs _ bod1) (Abs bv bod2) = + do th <- ruleHO_BETAS bod1 bod2 + liftO $ primABS bv th + ruleHO_BETAS pat tm = + let (hop, args) = stripComb pat + n = length args in + if lookup hop bcs == Just n + then runConv (betasConv n) tm + else case (pat, tm) of + (Comb lpat rpat, Comb ltm rtm) -> + do { lth <- ruleHO_BETAS lpat ltm + ; do { rth <- ruleHO_BETAS rpat rtm + ; liftO (primMK_COMB lth rth) + } <|> liftO (ruleAP_THM lth rtm) + } <|> do rth <- ruleHO_BETAS rpat rtm + liftO $ ruleAP_TERM ltm rth + _ -> fail "ruleHO_BETAS" + + betasConv :: Int -> Conversion cls thry + betasConv 1 = _TRY convBETA + betasConv n = convRATOR (betasConv (n-1)) `_THEN` _TRY convBETA + + + +{-| + The 'ruleINSTANTIATE_ALL' rule applies an 'Instantiation' to all parts of a + provided theorem. This application should never fail, provided the + instantiation is correctly constructed. See 'termMatch' for more details. +-} +ruleINSTANTIATE_ALL :: (BoolCtxt thry, HOLThmRep thm cls thry) + => Instantiation -> thm -> HOL cls thry HOLThm +ruleINSTANTIATE_ALL (_, [], ([], [], [])) pthm = toHThm pthm +ruleINSTANTIATE_ALL i@(_, tmenv, (tys, opTys, opOps)) pthm = + do thm@(Thm hyps _) <- toHThm pthm + if null hyps + then ruleINSTANTIATE i pthm + else let (tyrel, tyiirel) = + if null tys then ([], hyps) + else let tvs = foldr (union . tyVars . fst) [] tys in + partition (\ tm -> let tvs' = typeVarsInTerm tm in + not(null (tvs `intersect` tvs'))) hyps + (oprel, opiirel) = + if null opTys && null opOps then ([], tyiirel) + else let tyops = filter isTypeOpVar (map fst opTys ++ + map fst opOps) in + partition (\ tm -> let tyops' = typeOpVarsInTerm tm in + not(null (tyops `intersect` tyops'))) + tyiirel + tmrel = + if null tmenv then [] + else let vs = foldr (union . frees . fst) [] tmenv in + fst $ partition (\ tm -> let vs' = frees tm in + not(null (vs `intersect` vs'))) + opiirel + rhyps = tyrel `union` oprel `union` tmrel in + do thm1 <- foldlM (flip ruleDISCH) thm rhyps + thm2 <- ruleINSTANTIATE i thm1 + funpowM (length rhyps) ruleUNDISCH thm2 + +-- term matching +termMatch :: [HOLTerm] -> HOLTerm -> HOLTerm -> Maybe Instantiation +termMatch lconsts vtm ctm = + do pinsts_homs <- termPMatch lconsts [] vtm ctm ([], []) + tyenv <- getTypeInsts (fst pinsts_homs) ([], [], []) + insts <- termHOMatch lconsts tyenv pinsts_homs + separateInsts insts + +termPMatch :: [HOLTerm] -> HOLTermEnv -> HOLTerm -> HOLTerm + -> (HOLTermEnv, [(HOLTermEnv, HOLTerm, HOLTerm)]) + -> Maybe (HOLTermEnv, [(HOLTermEnv, HOLTerm, HOLTerm)]) +termPMatch lconsts env vtm@Var{} ctm sofar@(insts, homs) = + case lookup vtm env of + Just ctm' -> + if ctm' == ctm then return sofar + else Nothing + Nothing -> + if vtm `elem` lconsts + then if ctm == vtm then return sofar + else Nothing + else do insts' <- safeInsertA (vtm, ctm) insts + return (insts', homs) +termPMatch _ _ (Const vname vty) + (Const cname cty) sofar@(insts, homs) = + if vname == cname + then if vty == cty then return sofar + else let name = mkDummy in + do insts' <- safeInsert (mkVar name vty, mkVar name cty) insts + return (insts', homs) + else Nothing +termPMatch lconsts env (Abs vv@(Var _ vty) vbod) + (Abs cv@(Var _ cty) cbod) (insts, homs) = + let name = mkDummy in + do insts' <- safeInsert (mkVar name vty, mkVar name cty) insts + termPMatch lconsts ((vv, cv):env) vbod cbod (insts', homs) +termPMatch lconsts env vtm ctm sofar@(insts, homs) = + do vhop <- repeatM rator vtm + if isVar vhop && (vhop `notElem` lconsts) && + isNothing (lookup vhop env) + then let vty = typeOf vtm + cty = typeOf ctm in + do insts' <- if vty == cty then return insts + else let name = mkDummy in + safeInsert (mkVar name vty, + mkVar name cty) insts + return (insts', (env, vtm, ctm):homs) + else case (vtm, ctm) of + (Comb lv rv, Comb lc rc) -> + do sofar' <- termPMatch lconsts env lv lc sofar + termPMatch lconsts env rv rc sofar' + (TyAbs tvv tbv, TyAbs tvc tbc) -> + termPMatch lconsts env (inst [(tvv, tvc)] tbv) tbc sofar + (TyComb tv tyv, TyComb tc tyc) -> + if tyv == tyc then termPMatch lconsts env tv tc sofar + else do (i, h) <- termPMatch lconsts env tv tc sofar + let name = mkDummy + i' <- safeInsert (mkVar name tyv, mkVar name tyc) i + return (i', h) + _ -> Nothing + +getTypeInsts :: HOLTermEnv -> SubstTrip -> Maybe SubstTrip +getTypeInsts insts i = + foldrM (\ (x, t) sofar -> case x of + (Var _ ty) -> + typeMatch ty (typeOf t) sofar + _ -> Nothing) i insts + +termHOMatch :: [HOLTerm] -> SubstTrip + -> (HOLTermEnv, [(HOLTermEnv, HOLTerm, HOLTerm)]) + -> Maybe HOLTermEnv +termHOMatch _ _ (insts, []) = return insts +termHOMatch lconsts tyenv@(tys, opTys, opOps) + (insts, homs@((env, vtm, ctm):rest)) = + case vtm of + (Var _ vty) -> + if ctm == vtm then termHOMatch lconsts tyenv (insts, rest) + else do tys' <- safeInsert (vty, typeOf ctm) tys + let newtyenv = (tys', opTys, opOps) + newinsts = (vtm, ctm):insts + termHOMatch lconsts newtyenv (newinsts, rest) + _ -> + let (vhop, vargs) = stripComb vtm + afvs = catFrees vargs + inst_fn = instFull tyenv in + ((do tmenv <- mapM (\ a -> do a' <- lookup a env <|> + lookup a insts <|> + (if a `elem` lconsts + then return a + else Nothing) + return (inst_fn a, a')) afvs + let pats0 = map inst_fn vargs + vhop' = inst_fn vhop + pats <- mapM (varSubst tmenv) pats0 + ni <- let (chop, cargs) = stripComb ctm in + if cargs == pats + then if chop == vhop + then return insts + else safeInsert (vhop, chop) insts + else do ginsts <- mapM (\ p -> + if isVar p then return (p, p) + else let ty = typeOf p + p' = unsafeGenVar ty in + return (p, p')) pats + ctm' <- subst ginsts ctm + let gvs = map snd ginsts + abstm <- hush $ listMkAbs gvs ctm' + vinsts <- safeInsertA (vhop, abstm) insts + combtm <- hush $ listMkComb vhop' gvs + let icpair = (combtm, ctm') + return (icpair:vinsts) + termHOMatch lconsts tyenv (ni, rest)) + <|> (case (ctm, vtm) of + (Comb lc rc, Comb lv rv) -> + do pinsts_homs' <- termPMatch lconsts env rv rc (insts, (env, lv, lc):tail homs) + tyenv' <- getTypeInsts (fst pinsts_homs') ([], [], []) + termHOMatch lconsts tyenv' pinsts_homs' + _ -> Nothing)) + +separateInsts :: HOLTermEnv -> Maybe Instantiation +separateInsts insts = + let (realinsts, patterns) = partition (isVar . fst) insts in + do betacounts <- + if null patterns then return [] + else foldrM (\ (p, _) sof -> + let (hop, args) = stripComb p in + (safeInsert (hop, length args) sof + <|> return sof)) [] patterns + tyenv <- getTypeInsts realinsts ([], [], []) + let realinsts' = mapFilter + (\ (x, t) -> + case x of + (Var xn xty) -> + let x' = mkVar xn $ typeSubstFull tyenv xty in + if t == x' then Nothing + else Just (x', t) + _ -> Nothing) realinsts + return (betacounts, realinsts', tyenv) + +insertByTest :: Eq a => (b -> b -> Bool) -> (a, b) -> [(a, b)] -> Maybe [(a, b)] +insertByTest test n@(x, y) l = + case lookup x l of + Nothing -> Just (n:l) + Just z -> if y `test` z then Just l else Nothing + +safeInsert :: (Eq a, Eq b) => (a, b) -> [(a, b)] -> Maybe [(a, b)] +safeInsert = insertByTest (==) + +safeInsertA :: (HOLTerm, HOLTerm) -> [(HOLTerm, HOLTerm)] + -> Maybe [(HOLTerm, HOLTerm)] +safeInsertA = insertByTest aConv + +mkDummy :: Text +mkDummy = + let (Var name _) = unsafeGenVar tyA in name + + + + +-- first order term unification +augment1 :: HOLTermEnv -> (HOLTerm, HOLTerm) -> Maybe (HOLTerm, HOLTerm) +augment1 sofar (x, s) = + do s' <- subst sofar s + if varFreeIn x s && s /= x + then Nothing + else return (x, s') + +rawAugmentInsts :: (HOLTerm, HOLTerm) -> HOLTermEnv -> Maybe HOLTermEnv +rawAugmentInsts p insts = + do insts' <- mapM (augment1 [p]) insts + return $! p:insts' + +augmentInsts :: (HOLTerm, HOLTerm) -> HOLTermEnv -> Maybe HOLTermEnv +augmentInsts (v, t) insts = + do t' <- varSubst insts t + if t' == v + then return insts + else if varFreeIn v t' then Nothing + else rawAugmentInsts (v, t') insts + +unify :: [HOLTerm] -> HOLTerm -> HOLTerm -> HOLTermEnv -> Maybe HOLTermEnv +unify vars tm1 tm2 sofar + | tm1 == tm2 = return sofar + | isVar tm1 && tm1 `elem` vars = + case lookup tm1 sofar of + Just tm1' -> unify vars tm1' tm2 sofar + Nothing -> augmentInsts (tm1, tm2) sofar + | isVar tm2 && tm2 `elem` vars = + case lookup tm2 sofar of + Just tm2' -> unify vars tm1 tm2' sofar + Nothing -> augmentInsts (tm2, tm1) sofar + | otherwise = + case (tm1, tm2) of + (Abs bv1 tm1', Abs bv2 bod) -> + do tm2' <- subst [(bv2, bv1)] bod + unify vars tm1' tm2' sofar + (Comb l1 r1, Comb l2 r2) -> + do sofar' <- unify vars r1 r2 sofar + unify vars l1 l2 sofar' + (_, _) -> Nothing + +termUnify :: [HOLTerm] -> HOLTerm -> HOLTerm -> Maybe Instantiation +termUnify vars tm1 tm2 = + do vars' <- unify vars tm1 tm2 [] + return ([], vars', ([], [], [])) + + +-- modify variables at depth +tryalpha :: HOLTerm -> HOLTerm -> HOLTerm +tryalpha v tm = + case alpha v tm <|> alpha (variant (frees tm) v) tm of + Right res -> res + _ -> tm + + +deepAlpha :: [(Text, Text)] -> HOLTerm -> Either String HOLTerm +deepAlpha [] tm = return tm +deepAlpha env tm@(Abs var@(Var vn vty) bod) = + let catchCase1 = mkAbs var =<< deepAlpha env bod in + case remove (\ (x, _) -> x == vn) env of + Just ((_, vn'), newenv) -> + case tryalpha (mkVar vn' vty) tm of + Abs var' ib -> (do ib' <- deepAlpha newenv ib + mkAbs var' ib') <|> catchCase1 + _ -> catchCase1 + Nothing -> catchCase1 +deepAlpha env (Comb l r) = + do l' <- deepAlpha env l + r' <- deepAlpha env r + mkComb l' r' +deepAlpha _ tm = return tm + + +matchBvs :: HOLTerm -> HOLTerm -> [(Text, Text)] -> [(Text, Text)] +matchBvs (Abs (Var n1 _) b1) + (Abs (Var n2 _) b2) acc = + let newacc = if n1 == n2 then acc else (n2, n1) `insert` acc in + matchBvs b1 b2 newacc +matchBvs (Comb l1 r1) (Comb l2 r2) acc = + matchBvs l1 l2 $ matchBvs r1 r2 acc +matchBvs (TyAbs tv1 tb1) (TyAbs tv2 tb2) acc = + matchBvs (inst [(tv1, tv2)] tb1) tb2 acc +matchBvs (TyComb t1 _) (TyComb t2 _) acc = + matchBvs t1 t2 acc +matchBvs _ _ acc = acc + +partInsts :: (BoolCtxt thry, HOLThmRep thm cls thry) + => (HOLTerm -> HOL cls thry HOLTerm) -> thm + -> HOLTerm -> HOL cls thry (Instantiation, HOLThm, [HOLTerm]) +partInsts partfn pthm tm = + do thm@(Thm asl c) <- toHThm pthm + sth@(Thm _ bod) <- ruleSPEC_ALL thm + pbod <- partfn bod + let lconsts = intersect (frees c) $ catFrees asl + fvs = frees bod \\ frees pbod \\ lconsts + bvms = matchBvs tm pbod [] + abod = fromRight $ deepAlpha bvms bod + ath = fromRight $ liftM1 primEQ_MP (ruleALPHA bod abod) sth + abod' <- partfn abod + let insts = fromJust $ termMatch lconsts abod' tm + return (insts, ath, fvs) + +rulePART_MATCH :: (BoolCtxt thry, HOLThmRep thm cls thry) + => (HOLTerm -> Maybe HOLTerm) -> thm -> HOLTerm + -> HOL cls thry HOLThm +rulePART_MATCH partfn thm tm = + let partFun = liftMaybe "rulePART_MATCH: parting failed." . partfn in + do (insts, ath, _) <- partInsts partFun thm tm + fth <- ruleINSTANTIATE insts ath + if hyp fth /= hyp ath + then fail "rulePART_MATCH: instantiated hyps." + else do tm' <- partFun $ concl fth + if tm' == tm + then return fth + else (do alth <- fromRightM $ ruleALPHA tm' tm + ruleSUBS [alth] fth) + "rulePART_MATCH: sanity check failure" + +ruleGEN_PART_MATCH :: BoolCtxt thry => (HOLTerm -> Maybe HOLTerm) -> HOLThm -> + HOLTerm -> HOL cls thry HOLThm +ruleGEN_PART_MATCH partfn thm tm = + let partFun = liftMaybe "rulePART_MATCH: parting failed." . partfn in + do (insts, ath, fvs) <- partInsts partFun thm tm + eth <- ruleINSTANTIATE insts =<< ruleGENL fvs ath + fth <- foldrM (\ _ th -> liftM snd $ ruleSPEC_VAR th) eth fvs + if hyp fth /= hyp ath + then fail "ruleGEN_PART_MATCH: instantiate hyps" + else do tm' <- partFun $ concl fth + if tm' == tm + then return fth + else (do alth <- fromRightM $ ruleALPHA tm' tm + ruleSUBS [alth] fth) + "ruleGEN_PART_MATCH: sanity check failure" + +ruleMATCH_MP :: (HOLThmRep thm1 cls thry, HOLThmRep thm2 cls thry, + BoolCtxt thry) => thm1 -> thm2 -> HOL cls thry HOLThm +ruleMATCH_MP pith pth = + do ith <- toHThm pith + th <- toHThm pth + sth <- let tm = concl ith + (avs, bod) = stripForall tm in + case destImp bod of + Just (ant, _) -> + (let (svs, pvs) = partition (`varFreeIn` ant) avs in + if null pvs then return ith + else do th1 <- ruleSPECL avs #<< primASSUME tm + th2 <- ruleGENL svs =<< ruleDISCH ant =<< + ruleGENL pvs =<< ruleUNDISCH th1 + th3 <- ruleDISCH tm th2 + ruleMP th3 ith) "ruleMATCH_MP" + _ -> fail "ruleMATCH_MP: not an implication" + let match_fun = rulePART_MATCH (liftM fst . destImp) sth + thm <- match_fun (concl th) "ruleMATCH_MP: no match" + ruleMP thm th + +convHIGHER_REWRITE :: (BoolCtxt thry, HOLThmRep thm cls thry) => [thm] -> Bool + -> Conversion cls thry +convHIGHER_REWRITE ths top = Conv $ \ tm -> + do thl <- mapM (ruleGINST <=< ruleSPEC_ALL) ths + let concs = map concl thl + (preds, pats) = fromJust . liftM unzip $ mapM destComb =<< + mapM lhs concs + betaFns = fromJust $ map2 convBETA_VAR preds concs + asmList = zip pats . zip preds $ zip thl betaFns + mnet = foldr (\ p n -> netEnter [] (p, p) n) netEmpty pats + lookFn t = mapFilterM (\ p -> do void $ termMatch [] p t + return p) $ netLookup t mnet + predFn t = do ts <- liftO $ lookFn t + return $! not (null ts) && t `freeIn` tm + stm <- if top then findTermM predFn tm + else liftM (head . sort freeIn) $ findTermsM predFn tm + let pat = head . fromJust $ lookFn stm + (_, tmenv, _) = fromJust $ termMatch [] pat stm + (ptm, (th, betaFn)) = fromJust $ pat `lookup` asmList + gv <- genVar $ typeOf stm + let tm' = fromJust $ subst [(stm, gv)] tm + tm'' = fromRight $ mkAbs gv tm' + (_, tmenv0, tyenv0) = fromJust $ termMatch [] ptm tm'' + ruleCONV betaFn #<< primINST tmenv =<< primINST tmenv0 + (primINST_TYPE_FULL tyenv0 th) + where convBETA_VAR :: HOLTerm -> HOLTerm -> Conversion cls thry + convBETA_VAR v = fromJust . freeBeta v + + freeBeta :: HOLTerm -> HOLTerm -> Maybe (Conversion cls thry) + freeBeta v (Abs bv bod) + | v == bv = Nothing + | otherwise = liftM convABS (freeBeta v bod) + freeBeta v tm = + let (op, args) = stripComb tm in + if null args then Nothing + else if op == v then return . convBETA_CONVS $ length args + else do (l, r) <- destComb tm + do { lconv <- freeBeta v l + ; do { rconv <- freeBeta v r + ; return (convCOMB2 lconv rconv) + } <|> return (convRATOR lconv) + } <|> liftM convRAND (freeBeta v r) + + convBETA_CONVS :: Int -> Conversion cls thry + convBETA_CONVS 1 = _TRY convBETA + convBETA_CONVS n = convRATOR (convBETA_CONVS (n - 1)) `_THEN` + _TRY convBETA + + ruleGINST :: HOLThm -> HOL cls thry HOLThm + ruleGINST th@(Thm asl c) = + let fvs = frees c \\ catFrees asl in + do gvs <- mapM (genVar . typeOf) fvs + liftMaybe "ruleGINST" $ primINST (zip fvs gvs) th + ruleGINST _ = error "ruleGINST: exhaustion warning." + + +data TheDefinitions = + TheDefinitions !(Map Text HOLThm) deriving Typeable + +deriveSafeCopy 0 'base ''TheDefinitions + +insertDefinition :: Text -> HOLThm -> Update TheDefinitions () +insertDefinition lbl thm = + do TheDefinitions defs <- get + put (TheDefinitions (mapInsert lbl thm defs)) + +getDefinitions :: Query TheDefinitions [HOLThm] +getDefinitions = + do TheDefinitions defs <- ask + return $! mapElems defs + +getADefinition :: Text -> Query TheDefinitions (Maybe HOLThm) +getADefinition name = + do (TheDefinitions defs) <- ask + return $! name `mapLookup` defs + +makeAcidic ''TheDefinitions + ['insertDefinition, 'getDefinitions, 'getADefinition] + +newDefinition :: (BoolCtxt thry, HOLTermRep tm Theory thry) => Text -> tm + -> HOL Theory thry HOLThm +newDefinition lbl ptm = + do acid <- openLocalStateHOL (TheDefinitions mapEmpty) + qth <- queryHOL acid (GetADefinition lbl) + closeAcidStateHOL acid + case qth of + Just th -> + return th + Nothing -> + do tm <- toHTm ptm + let (avs, bod) = stripForall tm + (l, r) <- liftMaybe "newDefinition: Not an equation" $ destEq bod + let (lv, largs) = stripComb l + case lv of + Var name _ + | name /= lbl -> + fail $ "newDefinition: provided label does not match " ++ + "provided term." + | otherwise -> + do rtm <- liftEither ("newDefinition: Non-variable " ++ + "in LHS pattern.") $ listMkAbs largs r + def <- mkEq lv rtm + thm1 <- newBasicDefinition lbl def + thm2 <- foldlM (\ thm t -> + do ithm <- fromRightM $ ruleAP_THM thm t + ithm' <- fromJustM . rand $ concl ithm + ithm'' <- runConv convBETA ithm' + fromRightM $ primTRANS ithm ithm'' + ) thm1 largs + let rvs = filter (not . (`elem` avs)) largs + genthm <- foldrM ruleGEN thm2 avs + th <- foldrM ruleGEN genthm rvs + acid' <- openLocalStateHOL (TheDefinitions mapEmpty) + updateHOL acid' (InsertDefinition lbl th) + createCheckpointAndCloseHOL acid' + return th + _ -> fail $ "newDefinition: Non-variable constructor in " ++ + "LHS pattern." + +getDefinition :: Text -> HOL cls thry HOLThm +getDefinition lbl = + do acid <- openLocalStateHOL (TheDefinitions mapEmpty) + qth <- queryHOL acid (GetADefinition lbl) + closeAcidStateHOL acid + liftMaybe ("getDefinition: definition for " ++ show lbl ++ + " not found.") qth diff --git a/src/HaskHOL/Lib/Equal.hs b/src/HaskHOL/Lib/Equal.hs new file mode 100644 index 0000000..c329500 --- /dev/null +++ b/src/HaskHOL/Lib/Equal.hs @@ -0,0 +1,886 @@ +{-# LANGUAGE PatternSynonyms, ScopedTypeVariables #-} + +{-| + Module: HaskHOL.Lib.Equal + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown + + This module implements the equality logic library for HaskHOL. Most notably, + it defines 'Conversion's. + It has no associated theory context, instead relying only on the context of + the logical kernel. +-} +module HaskHOL.Lib.Equal + ( -- * Derived Syntax + lHand + , lhs + , rhs + , mkPrimedVar + -- * Derived Equality Rules + , ruleAP_TERM + , ruleAP_THM + , ruleSYM + , ruleALPHA + , ruleMK_BINOP + -- * Conversions + , Conversion(..) + -- ** Subterm Conversions + , convRATOR + , convRAND + , convLAND + , convCOMB2 + , convCOMB + , convABS + , convTYAPP + , convTYABS + , convBINDER + , convSUB + , convBINOP + -- ** Equality Conversions + , convALPHA + , convTYALPHA + , convGEN_ALPHA + , convGEN_TYALPHA + , convSYM + -- ** Beta Conversions + , convBETA + , convTYBETA + -- ** Depth Conversions + , convONCE_DEPTH + , convDEPTH + , convREDEPTH + , convTOP_DEPTH + , convTOP_SWEEP + -- ** Traversal Conversions + , convDEPTH_BINOP + , convPATH + , convPAT + -- ** Substituation Conversion + , convSUBS + -- * Other Derived Rules + , ruleCONV + , ruleBETA + , ruleTYBETA + , ruleGSYM + , ruleSUBS + ) where + +import HaskHOL.Core + +-- Syntax for equality + +{-| + Returns the left hand side of a binary operator combination. Equivalent to + the composition of + + > rand <=< rator + + Fails with 'Maybe' if the term is not a combination of adequate structure. +-} +lHand :: HOLTerm -> Maybe HOLTerm +lHand = rand <=< rator + +{-| + Returns the left hand side of an equation. Fails with 'Maybe' if the term + is not equational. +-} +lhs :: HOLTerm -> Maybe HOLTerm +lhs = liftM fst . destEq + +{-| + Returns the right hand side of an equation. Fails with 'Maybe' if the term + is not equational. +-} +rhs :: HOLTerm -> Maybe HOLTerm +rhs = liftM snd . destEq + +-- Basic Constructors for Equality + +{-| + The 'mkPrimedVar' function renames a variable to avoid conflicts with a + provided list of variables and constants. Throws a 'HOLException' in the + following cases: + + * The term to be renamed is not a variable. +-} +mkPrimedVar :: [HOLTerm] -> HOLTerm -> HOL cls thry HOLTerm +mkPrimedVar avoid (Var s ty) = + do s' <- primedRec (mapFilter varName avoid) s + return $! mkVar s' ty + where varName :: HOLTerm -> Maybe Text + varName (Var x _) = Just x + varName _ = Nothing + + primedRec :: [Text] -> Text -> HOL cls thry Text + primedRec avd x + | x `elem` avd = primedRec avd (x `snoc` '\'') + | otherwise = + do cond <- do cnd <- can getConstType x + hid <- getHidden + return $! cnd && (x `notElem` hid) + if cond + then primedRec avd (x `snoc` '\'') + else return x +mkPrimedVar _ _ = fail "mkPrimedVar" + +--derived equality rules +{-|@ + f A |- x = y +---------------- + A |- f x = f y +@ + + Fails with 'Left' in the following cases: + + * The theorem conclusion is not an equation. + + * The type of the function term does not agree with theorem argument types. +-} +ruleAP_TERM :: HOLTerm -> HOLThm -> Either String HOLThm +ruleAP_TERM tm thm = + primMK_COMB (primREFL tm) thm + "ruleAP_TERM" + +{-|@ + A |- f = g x +---------------- + A |- f x = g x +@ + + Fails with 'Left' in the following cases: + + * The theorem conclusion is not an equation. + + * The type of the argument term does not agree with theorem function types. +-} +ruleAP_THM :: HOLThm -> HOLTerm -> Either String HOLThm +ruleAP_THM thm tm = + primMK_COMB thm (primREFL tm) "ruleAP_THM" + +{-|@ + A |- t1 = t2 +-------------- + A |- t2 = t1 +@ + + Fails with 'Left' if the theorem conclusion is not an equation. +-} +ruleSYM :: HOLThm -> Either String HOLThm +ruleSYM thm@(Thm _ c) = + do (l, _) <- note "ruleSYM: not an equation" $ destEq c + let lth = primREFL l + eqTm = fromJust $ rator =<< rator c + liftO $ do th1 <- ruleAP_TERM eqTm thm + th2 <- primMK_COMB th1 lth + primEQ_MP th2 lth +ruleSYM _ = error "ruleSYM: exhaustive warning." + +{-|@ + t1 t1' +------------- + |- t1 = t1' +@ + + Fails with 'Left' if the terms are not alpha equivalent. +-} +ruleALPHA :: HOLTerm -> HOLTerm -> Either String HOLThm +ruleALPHA tm1 tm2 = + primTRANS (primREFL tm1) (primREFL tm2) "ruleALPHA" + +{-|@ + op |- l1 = l2 |- r1 = r2 +------------------------------ + |- l1 op r1 = l2 op r2 +@ + + Fails with 'Left' if the argument types of the two theorems do not agree. +-} +ruleMK_BINOP :: HOLTerm -> HOLThm -> HOLThm -> Either String HOLThm +ruleMK_BINOP op lthm rthm = + liftM1 primMK_COMB (ruleAP_TERM op lthm) rthm + "ruleMK_BINOP" + + + -- Conversions and combinator type classes + +{-| + The 'Conversion' type is a special class of derived rules that accepts a + term and returns a theorem proving its equation with an equivalent term. +-} +newtype Conversion cls thry = Conv { runConv :: HOLTerm -> HOL cls thry HOLThm } + deriving Typeable + +instance Eq (Conversion cls thry) where + _ == _ = False + +instance Ord (Conversion cls thry) where + compare _ _ = GT + _ <= _ = False + _ < _ = False + +-- conversion combinators +instance Lang (Conversion cls thry) where + _FAIL = convFAIL + _NO = convNO + _ALL = convALL + _ORELSE = convORELSE + _FIRST = convFIRST + _CHANGED = convCHANGED + _TRY = convTRY + _NOTE = convNOTE + +instance LangSeq (Conversion cls thry) where + _THEN = convTHEN + _REPEAT = convREPEAT + _EVERY = convEVERY + +convFAIL :: String -> Conversion cls thry +convFAIL s = Conv $ \ _ -> fail s + +convNO :: Conversion cls thry +convNO = convFAIL "convNO" + +convALL :: Conversion cls thry +convALL = Conv $ \ tm -> return $! primREFL tm + +convTHEN :: Conversion cls thry -> Conversion cls thry -> Conversion cls thry +convTHEN c1 c2 = Conv $ \ tm -> + do th1@(Thm _ tm') <- runConv c1 tm + th2 <- runConv c2 #<< rand tm' + liftEither "convTHEN: bad sequence" $ primTRANS th1 th2 + +convORELSE :: Conversion cls thry -> Conversion cls thry -> Conversion cls thry +convORELSE c1 c2 = Conv $ \ tm -> runConv c1 tm <|> runConv c2 tm + +-- fails when given an empty list +convFIRST :: [Conversion cls thry] -> Conversion cls thry +convFIRST [] = convFAIL "convFIRST: empty list" +convFIRST xs = foldr1 _ORELSE xs + +convEVERY :: [Conversion cls thry] -> Conversion cls thry +convEVERY = foldr _THEN convALL + +convREPEAT :: Conversion cls thry -> Conversion cls thry +convREPEAT conv = + (conv `_THEN` convREPEAT conv) `_ORELSE` convALL + +-- fails if resultant equation has alpha-equivalent sides +convCHANGED :: Conversion cls thry -> Conversion cls thry +convCHANGED conv = Conv $ \ tm -> + do th@(Thm _ tm') <- runConv conv tm + let (l, r) = fromJust $ destEq tm' + if l `aConv` r + then fail "convCHANGED: no change" + else return th + +convTRY :: Conversion cls thry -> Conversion cls thry +convTRY conv = conv `_ORELSE` _ALL + +convNOTE :: String -> Conversion cls thry -> Conversion cls thry +convNOTE err conv = Conv $ \ tm -> + noteHOL err $ runConv conv tm + +-- subterm conversions + +{-| + The 'convRATOR' conversional applies a given conversion to the operator of a + combination, returning a theorem of the form @|- (t1 t2) = (t1' t2)@. + It throws a 'HOLException' in the following cases: + + * The term the resultant conversion is applied to is not a combination. + + * The original conversion fails. +-} +convRATOR :: Conversion cls thry -> Conversion cls thry +convRATOR conv = Conv $ \ tm -> + case tm of + Comb l r -> + do th <- runConv conv l "convRATOR: conversion failed." + liftO $ ruleAP_THM th r + _ -> fail "convRATOR: not a combination" + +{-| + The 'convRAND' conversional applies a given conversion to the operand of a + combination, returning a theorem of the form @|- (t1 t2) = (t1 t2')@. + It throws a 'HOLException' in the following cases: + + * The term the resultant conversion is applied to is not a combination. + + * The original conversion fails. +-} +convRAND :: Conversion cls thry -> Conversion cls thry +convRAND conv = Conv $ \ tm -> + case tm of + Comb l r -> + do th <- runConv conv r "convRAND: conversion failed." + liftO $ ruleAP_TERM l th + _ -> fail "convRAND: not a combination" + +{-| + The 'convLAND' conversional applies a given conversion to the left hand side + of a binary operator combination, returning a theorem of the form + @|- l op r = l' op r@. It is functionally equivalent to + + > convRATOR . convRAND + + , failing accordingly. +-} +convLAND :: Conversion cls thry -> Conversion cls thry +convLAND = _NOTE "convLAND" . convRATOR . convRAND + +{-| + The 'convCOMB2' conversional applies two different conversions to the operator + and operand of a combination accordingly, returning a theorem of the form + @|- (t1 t2) = (t1' t2')@. It throws a 'HOLException' in the following cases: + + * The term the resultant conversion is applied to is not a combination. + + * Either of the original conversions fail. +-} +convCOMB2 :: Conversion cls thry -> Conversion cls thry -> Conversion cls thry +convCOMB2 lconv rconv = Conv $ \ tm -> + case tm of + Comb l r -> + do lth <- runConv lconv l "convCOMB2: left conversion failed." + rth <- runConv rconv r "convCOMB2: right conversion failed." + liftO $ primMK_COMB lth rth + _ -> fail "convCOMB2: not a combination" + +{-| + The 'convCOMB' conversional applies a conversion to both the operator and + operand of a combination. It is functionally equivalent to + + > \ x -> convCOMB2 x x + + , failing accordingly. +-} +convCOMB :: Conversion cls thry -> Conversion cls thry +convCOMB conv = _NOTE "convCOMB" $ convCOMB2 conv conv + +{-| + The 'convABS' conversional applies a given conversion to the body of an + abstraction, returning a theorem of the form @|- (\ x . t) = (\ x . t')@. + It throws a 'HOLException' in the following cases: + + * The term the resultant conversion is applied to is not an abstraction. + + * The original conversion fails. +-} +convABS :: Conversion cls thry -> Conversion cls thry +convABS conv = Conv $ \ tm -> + case tm of + Abs v@(Var _ ty) bod -> + do th <- runConv conv bod "convABS: conversion failed." + liftO (primABS v th) <|> + do gv <- genVar ty + gbod <- runConv conv #<< varSubst [(v, gv)] bod + let gth = fromRight $ primABS gv gbod + gtm = concl gth + v' = variant (frees gtm) v + (l, r) = fromRight (pairMapM (alpha v') #<< destEq gtm) + tm' <- mkEq l r + liftO $ liftM1 primEQ_MP (ruleALPHA gtm tm') gth + _ -> fail "convABS: not an abstraction." + +{-| + The 'convTYAPP' conversional applies a given conversions to the body of a + type combination, returning a theorem of the form @|- (t ty) = (t' ty)@. It + throws a 'HOLException' in the following cases: + + * The term the resultant conversion is applied to is not a type combination. + + * The original conversion fails. +-} +convTYAPP :: Conversion cls thry -> Conversion cls thry +convTYAPP conv = Conv $ \ tm -> + case tm of + TyComb t ty -> + do th <- runConv conv t "convTYAPP: conversion failed." + liftO $ primTYAPP ty th + _ -> fail "convTYAPP: not a type combination." + +{-| + The 'convTYABS' conversional applies a given conversions to the body of a + type abstraction, returning a theorem of the form + @|- (\\ tv. tm) = (\\ tv. tm)@. It throws a 'HOLException' in the following + cases: + + * The term the resultant conversion is applied to is not a type abstraction. + + * The original conversion fails. +-} +convTYABS :: Conversion cls thry -> Conversion cls thry +convTYABS conv = Conv $ \ tm -> + case tm of + TyAbs tv t -> + do th <- runConv conv t "convTYABS: conversion failed." + liftO (primTYABS tv th) <|> + do gv <- genSmallTyVar + gbod <- runConv conv $ inst [(tv, gv)] t + let gth = fromRight $ primTYABS gv gbod + gtm = concl gth + v' = variantTyVar (typeVarsInTerm gtm) tv + (l, r) = fromRight (pairMapM (alphaTyabs v') #<< + destEq gtm) + tm' <- mkEq l r + liftO $ liftM1 primEQ_MP (ruleALPHA gtm tm') gth + _ -> fail "convTYABS: not an abstraction." + +{-| + The 'convBINDER' conversional applies a given conversion to the body of a term + with a binder returning a theorem of the form @|- b x . t = b x . t'@ In the + case of a basic abstraction terms, it is functionally equivalent to 'convABS' + or 'convTYABS', failing accordingly. It throws a 'HOLException' in the + following cases: + + * The term the resultant conversion is applied to is not a term with a binder. + + * The original conversion fails. +-} +convBINDER :: Conversion cls thry -> Conversion cls thry +convBINDER conv = Conv $ \ tm -> noteHOL "convBINDER" $ + case tm of + Abs{} -> runConv (convABS conv) tm + TyAbs{} -> runConv (convTYABS conv) tm + Bind{} -> + runConv (convRAND $ convABS conv) tm + TyBind{} -> + runConv (convRAND $ convTYABS conv) tm + _ -> fail "not a binder term." + +{-| + The 'convSUB' conversional applies a given conversion to the subterms of a + term. For variable and constant terms it is functionally equivalent to + 'convALL'. +-} +convSUB :: Conversion cls thry -> Conversion cls thry +convSUB conv = Conv $ \ tm -> noteHOL "convSUB" $ + case tm of + Comb{} -> runConv (convCOMB conv) tm + Abs{} -> runConv (convABS conv) tm + TyComb{} -> runConv (convTYAPP conv) tm + TyAbs{} -> runConv (convTYABS conv) tm + _ -> return $! primREFL tm + +{-| + The 'convBINOP' conversional applies a given conversion to both the left and + right hand sides of a binary operator combination, returning a theorem of the + form @|- l op r = l' op r'@. It throws a 'HOLException' in the following + cases: + + * The term the resultant conversion is applied to is not a binary operator + combination. + + * The original conversion fails. + +-} +convBINOP :: Conversion cls thry -> Conversion cls thry +convBINOP conv = Conv $ \ tm -> + case tm of + (Comb (Comb op l) r) -> + do lth <- runConv conv l + "convBINOP: conversion failed on left sub-term." + rth <- runConv conv r + "convBINOP: conversion failed on right sub-term." + liftO $ liftM1 primMK_COMB (ruleAP_TERM op lth) rth + _-> fail "convBINOP: not a binary operator combination." + +-- Equality Conversions + +{-| + The 'convALPHA' conversion converts the bound variable of lambda abstraction + to a provided one, returning a theorem of the form @|- (\ x . t) = (\ v . t)@. + It throws a 'HOLException' in the following cases: + + * The provided term is not a variable. + + * Alpha conversion fails for the term this conversion is applied to. +-} +convALPHA :: HOLTerm -> Conversion cls thry +convALPHA v@Var{} = Conv $ \ tm -> + liftEither "convALPHA" $ ruleALPHA tm =<< alpha v tm +convALPHA _ = _FAIL "convALPHA: provided term not a variable." + +{-| + The 'convTYALPHA' conversion converts the bound variable of type abstraction + to a provided one, returning a theorem of the form + @|- (\\ x . t) = (\\ v . t)@. It throws a 'HOLException' in the following + cases: + + * The provided type is not a small variable. + + * Alpha conversion fails for the term this conversion is applied to. +-} +convTYALPHA :: HOLType -> Conversion cls thry +convTYALPHA v@(TyVar True _) = Conv $ \ tm -> + liftEither "convTYALPHA" $ ruleALPHA tm =<< alphaTyabs v tm +convTYALPHA _ = _FAIL "convTYALPHA: provided type not a small variable." + +{-| + The 'convGEN_ALPHA' conversion converts the bound variable of a term with a + binder to a provided one. In the case of a basic lambda term it is + functionally equivalent to 'convALPHA', failing accordingly. In other cases + it returns a theorem of the form @|- b x . t = b v . t@. It throws a + 'HOLException' in the following cases: + + * The provided term is not a variable. + + * The term the conversion is applied to does not have a binder. +-} +convGEN_ALPHA:: HOLTerm -> Conversion cls thry +convGEN_ALPHA v@Var{} = Conv $ \ tm -> + case tm of + Abs{} -> runConv (convALPHA v) tm + (Comb b@Const{} ab@Abs{}) -> + do abth <- runConv (convALPHA v) ab + liftO $ ruleAP_TERM b abth + _ -> fail "convGEN_ALPHA: not a binder term." +convGEN_ALPHA _ = _FAIL "convGEN_ALPHA: provided term not a variable" + +{-| + The 'convGEN_TYALPHA' conversion converts the bound type variable of a term + with a type binder to a provided one. In the case of a basic type abstraction + it is functionally equivalent to 'convTYALPHA', failing accordingly. In other cases it returns a theorem of the form @|- b x . t = b v . t@. It throws a + 'HOLException' in the following cases: + + * The provided type is not a small variable. + + * The term the conversion is applied to does not have a type binder. +-} +convGEN_TYALPHA:: HOLType -> Conversion cls thry +convGEN_TYALPHA v@(TyVar True _) = Conv $ \ tm -> + case tm of + TyAbs{} -> runConv (convTYALPHA v) tm + (Comb b@Const{} ab@TyAbs{}) -> + do abth <- runConv (convTYALPHA v) ab + liftO $ ruleAP_TERM b abth + _ -> fail "convGEN_TYALPHA: not a type binder term." +convGEN_TYALPHA _ = _FAIL "convGEN_TYALPHA: provided type not a small variable." + +{-| + The 'convSYM' conversion performs a symmetry conversion on an equational + term, returning a theorem of the form @|- (l = r) = (r = l)@. + It throws a 'HOLException' if the term provided to the conversion is not an + equational term. +-} +convSYM :: Conversion cls thry +convSYM = Conv $ \ tm -> liftEither "convSYM" $ + do th1 <- ruleSYM =<< primASSUME tm + th2 <- ruleSYM =<< primASSUME (concl th1) + return $! primDEDUCT_ANTISYM th2 th1 + + +-- Beta Conversions +{-| + The 'convBETA' conversion performs a beta reduction, returning a theorem of + the form @|- (\ x . t) v = t [v/x]@. In the case where the argument term is + the same as the bound variable, the primitive rule 'primBETA' is used for + efficiency. It throws a 'HOLException' if the term the conversion is applied + to is not a valid redex. +-} +convBETA :: Conversion cls thry +convBETA = Conv $ \ tm -> liftEither "convBETA" $ + case tm of + (Comb f@(Abs v _) arg) + | v == arg -> primBETA tm + | otherwise -> + do th <- primBETA =<< mkComb f v + liftO $ primINST [(v, arg)] th + _ -> Left "not a beta-redex." + +{-| + The 'convTYBETA' conversion performs a type beta reduction, returning a + theorem of the form @|- (\\ x . t) [: tv] = t [tv/x]@. In the case where the + argument type is the same as the bound variable, the primitive rule + 'primTYBETA' is used for efficiency. It throws a 'HOLException' if the term + the conversion is applied to is not a valid type redex. +-} +convTYBETA :: Conversion cls thry +convTYBETA = Conv $ \ tm -> liftEither "convTYBETA" $ + case tm of + (TyComb t@(TyAbs tv _) ty) + | tv == ty -> primTYBETA tm + | otherwise -> + liftM (primINST_TYPE [(tv, ty)]) $ primTYBETA =<< mkTyComb t tv + _ -> Left "not a type beta-redex." + + +-- depth conversions + +{-| + The 'convONCE_DEPTH' conversional applies a given conversion to the first set + of subterms that it succeeds on from a top-down search. It does not fail + given that its implementation is wrapped in a use of '_TRY'. +-} +convONCE_DEPTH :: Conversion cls thry -> Conversion cls thry +convONCE_DEPTH = _TRY . onceDepthQConv + where onceDepthQConv :: Conversion cls thry -> Conversion cls thry + onceDepthQConv conv = conv `_ORELSE` subQConv (onceDepthQConv conv) + +{-| + The 'convDEPTH' conversional repeatedly applies a given conversion to all + subterms in a bottom-up manner until it fails. The overall conversion does + not fail given that its implementation is wrapped in a use of '_TRY', however, it can loop infinitely if provided with a conversion that itself never fails. +-} +convDEPTH :: Conversion cls thry -> Conversion cls thry +convDEPTH = _TRY . depthQConv + where depthQConv :: Conversion cls thry -> Conversion cls thry + depthQConv conv = subQConv (depthQConv conv) `thenqc` + repeatqc conv + +{-| + The 'convREDEPTH' conversional repeatedly applies a given conversion to all + subterms in a bottom-up manner, retraversing any that are changed. + Its behavior is similar to 'convDEPTH' in that it cannot fail, but it can + loop infinitely. +-} +convREDEPTH :: Conversion cls thry -> Conversion cls thry +convREDEPTH = _TRY . redepthQConv + where redepthQConv :: Conversion cls thry -> Conversion cls thry + redepthQConv conv = subQConv (redepthQConv conv) `thenqc` + (conv `thencqc` redepthQConv conv) + +{-| + The 'convTOP_DEPTH' conversional has idententical behavior to that of + 'convREDEPTH', with the exception that the traversal is top-down instead of + bottom-up. +-} +convTOP_DEPTH :: Conversion cls thry -> Conversion cls thry +convTOP_DEPTH = _TRY . topDepthQConv + where topDepthQConv :: Conversion cls thry -> Conversion cls thry + topDepthQConv conv = repeatqc conv `thenqc` + (subQConv (topDepthQConv conv) `thencqc` + (conv `thencqc` topDepthQConv conv)) + +{-| + The 'convTOP_SWEEP' conversional has identical behavior to that of + 'convDEPTH', with the exception that the the traversal is top-down instead of + bottom-up. +-} +convTOP_SWEEP :: Conversion cls thry -> Conversion cls thry +convTOP_SWEEP = _TRY . topSweepQConv + where topSweepQConv :: Conversion cls thry -> Conversion cls thry + topSweepQConv conv = repeatqc conv `thenqc` + subQConv (topSweepQConv conv) + +-- depth sub-conversions +-- tries to sequence, then tries conv1, finally conv2 +thenqc :: Conversion cls thry -> Conversion cls thry -> Conversion cls thry +thenqc conv1 conv2 = Conv $ \ tm -> + (do th@(Thm _ tm') <- runConv conv1 tm + (do tmth <- runConv conv2 . fromJust $ rand tm' + liftO $ primTRANS th tmth) + <|> return th) + <|> runConv conv2 tm + +-- tries to sequence, then tries conv1, conv2 not tried +thencqc :: Conversion cls thry -> Conversion cls thry -> Conversion cls thry +thencqc conv1 conv2 = Conv $ \ tm -> + do th@(Thm _ tm') <- runConv conv1 tm + (do tmth <- runConv conv2 . fromJust $ rand tm' + liftO $ primTRANS th tmth) + <|> return th + +{- + depth conversion for combinations, tries converting l and r, then just l, + then just r, then fails. +-} +combQConv :: Conversion cls thry -> Conversion cls thry +combQConv conv = Conv $ \ tm -> + case tm of + (Comb l r) -> + (do th <- runConv conv l + (do rth <- runConv conv r + liftO $ primMK_COMB th rth) + <|> liftO (ruleAP_THM th r)) + <|> (do rth <- runConv conv r + liftO $ ruleAP_TERM l rth) + _ -> fail "combQConv" + +repeatqc :: Conversion cls thry -> Conversion cls thry +repeatqc conv = conv `thencqc` repeatqc conv + +-- depth sub conversion. indirectly fails for variables and constants. +subQConv :: Conversion cls thry -> Conversion cls thry +subQConv conv = Conv $ \ tm -> + case tm of + Abs{} -> runConv (convABS conv) tm + TyAbs{} -> runConv (convTYABS conv) tm + TyComb{} -> runConv (convTYAPP conv) tm + _ -> runConv (combQConv conv) tm + + +-- traversal conversions + +{-| + The 'convDEPTH_BINOP' conversional applies a given conversion to the left + and right subterms of a binary operator combination whenever that operator + matches the one provided. If the combination is complex with many instances of + the operator then all subterms will be converted. It fails if the original + conversion fails on a subterm. +-} +convDEPTH_BINOP :: HOLTermRep tm cls thry => tm -> Conversion cls thry + -> Conversion cls thry +convDEPTH_BINOP pop conv = Conv $ \ tm -> noteHOL "convDEPTH_BINOP" $ + case tm of + (Comb (Comb op' l) r) -> + do op <- toHTm pop + if op' == op + then do lth <- runConv (convDEPTH_BINOP pop conv) l + rth <- runConv (convDEPTH_BINOP pop conv) r + liftO $ liftM1 primMK_COMB (ruleAP_TERM op' lth) rth + else runConv conv tm + _ -> runConv conv tm + +{-| + The 'convPATH' conversional applies a given conversion in a path specified + by the user. The path is specified as a 'String' as defined below: + + * @\'b\'@ -> traverse the body of a term abstraction -> 'convABS' + + * @\'t\'@ -> traverse the body of a type abstraction -> 'convTYABS' + + * @\'l\'@ -> traverse the operator of a combination -> 'convRATOR' + + * @\'r\'@ -> traverse the operand of a combination -> 'convRAND' + + * @\'c\'@ -> traverse the body of a type combination -> 'convTYAPP' + + It throws a 'HOLException' in the following cases: + + * An invalid path string is provided. + + * The structure of the term is not traversable by the pattern. + + * The original conversion fails on any of the subterms. +-} +convPATH :: forall cls thry. + String -> Conversion cls thry -> Conversion cls thry +convPATH pth conv = _NOTE "convPATH" $ cnvsl pth + where cnvsl :: String -> Conversion cls thry + cnvsl [] = conv + cnvsl ('b':t) = convABS (cnvsl t) + cnvsl ('t':t) = convTYABS (cnvsl t) + cnvsl ('l':t) = convRATOR (cnvsl t) + cnvsl ('r':t) = convRAND (cnvsl t) + cnvsl ('c':t) = convTYAPP (cnvsl t) + cnvsl _ = convFAIL "invalid path." + +{-| + The 'convPAT' conversional applies a given conversion following a pattern + specified by the user. The pattern is given in the form of a lambda + abstraction where the conversion is applied everywhere there is an instance of + the bound variable in the body of the abstraction. For example, + + > convPAT (\ x. x a) + + is functionally equivalent to 'convRATOR'. It fails when the original + conversion fails on a targetted subterm. +-} +convPAT :: forall cls thry. + HOLTerm -> Conversion cls thry -> Conversion cls thry +convPAT p conv = Conv $ \ t -> noteHOL "convPAT" $ + let (xs, pbod) = stripAbs p in + runConv (pconv xs pbod) t + where pconv :: [HOLTerm] -> HOLTerm -> Conversion cls thry + pconv xs pat + | pat `elem` xs = conv + | not (any (`freeIn` pat) xs) = convALL + | otherwise = + case pat of + (Comb l r) -> + convCOMB2 (pconv xs l) (pconv xs r) + (Abs _ bod) -> + convABS (pconv xs bod) + _ -> convFAIL "bad pattern." + + +{-| + The 'convSUBS' conversion accepts a list of equational theorems, deconstructs + them into a substitution list, and performs the substitution over a term, + replacing any instance of the left hand side of an equation with the right + hand side. It fails when the list of theorems are not in the correct form. +-} +convSUBS :: HOLThmRep thm cls thry => [thm] -> Conversion cls thry +convSUBS [] = convALL +convSUBS pths = Conv $ \ tm -> noteHOL "convSUBS" $ + do ths <- mapM toHThm pths + lfts <- liftMaybe "not an equational theorem." $ + mapM (lHand . concl) ths + gvs <- mapM (genVar . typeOf) lfts + let pat = fromJust $ subst (zip lfts gvs) tm + let abTh = primREFL . fromRight $ listMkAbs gvs pat + th@(Thm _ tm') <- foldlM (\ x y -> ruleCONV + (convRAND convBETA `_THEN` convLAND convBETA) + (fromRight $ primMK_COMB x y)) abTh ths + if rand tm' == Just tm + then return $! primREFL tm + else return th + +-- other derived rules +{-|@ + conv A |- t +--------------- + A U A' |- t' +@ + + Applies a conversion to the conclusion of a theorem, unifying any newly + introduced assumptions. Throws a 'HOLException' when the conversion fails. +-} +ruleCONV :: HOLThmRep thm cls thry => Conversion cls thry -> thm + -> HOL cls thry HOLThm +ruleCONV conv pthm = noteHOL "ruleCONV" $ + do thm <- toHThm pthm + thm' <- runConv conv $ concl thm + liftO $ primEQ_MP thm' thm + +{-|@ + A |- (\ x1 ... xn . t) s1 ... sn +----------------------------------- + A |- (t[s1, ..., sn/x1, ..., xn]) +@ + + Never fails, but may have no effect. +-} +ruleBETA :: HOLThm -> HOL cls thry HOLThm +ruleBETA = noteHOL "ruleBETA" . ruleCONV (convREDEPTH convBETA) + +{-|@ + A |- (\\ x1 ... xn . t) [: s1 ... sn] +--------------------------------------- + A |- (t[s1, ..., sn/x1, ..., xn]) +@ + + Never fails, but may have no effect. +-} +ruleTYBETA :: HOLThm -> HOL cls thry HOLThm +ruleTYBETA = noteHOL "ruleTYBETA" . ruleCONV (convREDEPTH convTYBETA) + +{-|@ + A |- (l1 = r1) ... (l2 = r2) +------------------------------ + A |- (r1 = l1) ... (r2 = l2) +@ + + Never fails, but may have no effect. +-} +ruleGSYM :: HOLThmRep thm cls thry => thm -> HOL cls thry HOLThm +ruleGSYM = ruleGSYM' <=< toHThm + where ruleGSYM' :: HOLThm -> HOL cls thry HOLThm + ruleGSYM' = noteHOL "ruleGSYM" . ruleCONV (convONCE_DEPTH convSYM) + +{-|@ + [A1 |- l1 = r1, ..., An |- ln = rn] A |-t +---------------------------------------------- + A1 U ... U An U A |- t[r1, ..., rn\/l1, ..., ln] +@ + + The rule version of 'convSUBS'. Throws a 'HOLException' if each theorem in + the provided list is not equational. +-} +ruleSUBS :: HOLThmRep thm cls thry => [thm] -> HOLThm -> HOL cls thry HOLThm +ruleSUBS thms = noteHOL "ruleSUBS" . ruleCONV (convSUBS thms) diff --git a/src/HaskHOL/Lib/IndDefs.hs b/src/HaskHOL/Lib/IndDefs.hs new file mode 100644 index 0000000..5c1613c --- /dev/null +++ b/src/HaskHOL/Lib/IndDefs.hs @@ -0,0 +1,569 @@ +{-# LANGUAGE FlexibleContexts, PatternSynonyms #-} +{-| + Module: HaskHOL.Lib.IndDefs + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.IndDefs + ( IndDefsType + , IndDefsCtxt + , ruleRIGHT_BETAS + , ruleEXISTS_EQUATION + , tacMONO + , proveMonotonicityHyps + , deriveNonschematicInductiveRelations + , proveInductiveRelationsExist + , newInductiveDefinition + , getInductiveDefinition + , addMonoThm + , thmIMP_REFL + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Equal +import HaskHOL.Lib.Itab +import HaskHOL.Lib.Theorems +import HaskHOL.Lib.Simp +import HaskHOL.Lib.DRule +import HaskHOL.Lib.Tactics + +import HaskHOL.Lib.IndDefs.Base +import HaskHOL.Lib.IndDefs.Context + + +strip_ncomb :: Int -> HOLTerm -> Maybe (HOLTerm, [HOLTerm]) +strip_ncomb n tm = stripRec n tm [] + where stripRec x t acc + | x < 1 = Just (t, acc) + | otherwise = case t of + (Comb l r) -> stripRec (x - 1) l (r:acc) + _ -> Nothing + +ruleRIGHT_BETAS :: [HOLTerm] -> HOLThm -> HOL cls thry HOLThm +ruleRIGHT_BETAS tms thm = + foldlM (\ a b -> ruleCONV (convRAND convBETA) #<< + ruleAP_THM a b) thm tms + +ruleEXISTS_EQUATION :: (BasicConvs thry, IndDefsCtxt thry) => HOLTerm -> HOLThm + -> HOL cls thry HOLThm +ruleEXISTS_EQUATION tm thm = + do (l, r, p, pL) <- liftEither "ruleEXISTS_EQUATION: mkTerms" $ + do (l, r) <- note "" $ destEq tm + p <- mkAbs l $ concl thm + pL <- mkComb p l + return (l, r, p, pL) + th1 <- ruleISPECL [p, r] ruleEXISTS_EQUATION_pth + th2 <- liftM (fromRight . ruleSYM) $ runConv convBETA pL + ruleMP th1 =<< ruleGEN l =<< ruleDISCH tm #<< primEQ_MP th2 thm + where ruleEXISTS_EQUATION_pth :: (BasicConvs thry, IndDefsCtxt thry) + => HOL cls thry HOLThm + ruleEXISTS_EQUATION_pth = + cacheProof "ruleEXISTS_EQUATION_pth" ctxtIndDefs $ + do t <- toHTm "t:A" + dexists <- defEXISTS + prove "!P t. (!x:A. (x = t) ==> P x) ==> (?) P" $ + tacREWRITE [dexists] `_THEN` + tacBETA `_THEN` + _REPEAT tacSTRIP `_THEN` + _FIRST_ASSUM tacMATCH_MP `_THEN` + tacEXISTS t `_THEN` + _FIRST_ASSUM tacMATCH_MP `_THEN` + tacREFL + + +getConcl :: HOLTerm -> HOLTerm +getConcl tm = fromJust $ + do bod <- repeatM (liftM snd . destForall) tm + liftM snd (destImp bod) <|> return bod + +ruleCONJ_ACI :: TheoremsCtxt thry => HOLTerm -> HOL cls thry HOLThm +ruleCONJ_ACI tm = + do thm <- thmCONJ_ACI + runConv (convAC thm) tm + +ruleSIMPLE_DISJ_PAIR :: BoolCtxt thry => HOLThm -> HOL cls thry (HOLThm, HOLThm) +ruleSIMPLE_DISJ_PAIR thm = + do (l, r) <- liftMaybe "ruleSIMPLE_DISJ_PAIR: disj theorems" $ + destDisj . head $ hyp thm + th1 <- flip ruleDISJ1 r #<< primASSUME l + th2 <- ruleDISJ2 l #<< primASSUME r + return $ pairMap (`rulePROVE_HYP` thm) (th1, th2) + + +ruleHALF_BETA_EXPAND :: BoolCtxt thry => [HOLTerm] -> HOLThm -> HOL cls thry HOLThm +ruleHALF_BETA_EXPAND args thm = ruleGENL args =<< ruleRIGHT_BETAS args thm + +ruleAND_IMPS_CONV :: BoolCtxt thry => HOLTerm -> HOL cls thry HOLThm +ruleAND_IMPS_CONV tm = + do ths <- ruleCONJUNCTS #<< primASSUME tm + let avs = fst . stripForall . concl $ head ths + thl <- mapM (ruleDISCH tm <=< ruleUNDISCH <=< ruleSPEC_ALL) ths + th1 <- foldr1M ruleSIMPLE_DISJ_CASES thl + let tm1 = head $ hyp th1 + th2 <- ruleGENL avs =<< ruleDISCH tm1 =<< ruleUNDISCH th1 + let tm2 = concl th2 + th3 <- ruleDISCH tm2 =<< ruleUNDISCH =<< ruleSPEC_ALL #<< + primASSUME tm2 + (thts, tht) <- nsplitM ruleSIMPLE_DISJ_PAIR (tail ths) th3 + let procFun thm = let t = head $ hyp thm in + ruleGENL avs =<< ruleDISCH t =<< ruleUNDISCH thm + th4 <- itlistM (liftM1 ruleCONJ . procFun) thts =<< procFun tht + liftM1 ruleIMP_ANTISYM (ruleDISCH_ALL th2) =<< ruleDISCH_ALL th4 + +calculateSimpSequence :: [HOLTerm] -> HOLTermEnv -> (HOLTermEnv, HOLTermEnv) +calculateSimpSequence avs plis = + let oks = getequs avs plis in + (oks, plis \\ oks) + where getequs _ [] = [] + getequs as (h@(_, r):t) = + if r `elem` as + then h : getequs as (filter (\ (_, x) -> x /= r) t) + else getequs as t + +convFORALL_IMPS :: BoolCtxt thry => Conversion cls thry +convFORALL_IMPS = Conv $ \ tm -> + let (avs, bod) = stripForall tm in + do th1 <- ruleDISCH tm =<< ruleUNDISCH =<< ruleSPEC_ALL =<< + liftEither "convFORALL_IMPS: primASSUME" (primASSUME tm) + th2 <- foldrM ruleSIMPLE_CHOOSE th1 avs + tm2 <- liftMaybe "convFORALL_IMPS" . tryHead $ hyp th2 + th3 <- ruleDISCH tm2 =<< ruleUNDISCH th2 + th4 <- liftEither "convFORALL_IMPS: primASSUME" . primASSUME $ concl th3 + ant <- liftMaybe "convFORALL_IMPS: lHand" $ lHand bod + th5 <- liftEither "convFORALL_IMPS: primASSUME" $ primASSUME ant + th6 <- foldrM ruleSIMPLE_EXISTS th5 avs + th7 <- ruleGENL avs =<< ruleDISCH ant =<< ruleMP th4 th6 + th8 <- ruleDISCH_ALL th3 + ruleIMP_ANTISYM th8 =<< ruleDISCH_ALL th7 + +canonicalizeClause :: IndDefsCtxt thry => HOLTerm -> [HOLTerm] -> HOL cls thry HOLThm +canonicalizeClause cls args = + (do trueTm <- serve [indDefs| T |] + let (avs, bimp) = stripForall cls + (ant, con) = fromMaybe (trueTm, bimp) $ destImp bimp + (rel, xargs) = stripComb con + plis = zip args xargs + (yes, no) = calculateSimpSequence avs plis + nvs = filter (\ x -> x `notElem` map snd yes) avs + canon' = canon rel plis yes nvs + eth <- if isImp bimp + then do atm <- foldrM (\ x y -> liftM1 mkConj (uncurry mkEq x) y) + ant $ yes ++ no + (ths, tth) <- nsplitM ruleCONJ_PAIR plis #<< + primASSUME atm + th0 <- liftM1 ruleMP (ruleSPECL avs #<< primASSUME cls) + tth + (th6, th5') <- canon' atm th0 ths + th7 <- itlistM (ruleCONJ . primREFL . snd) no #<< + primASSUME ant + th8 <- ruleGENL avs =<< ruleDISCH ant =<< ruleMP th6 th7 + ruleIMP_ANTISYM th5' =<< ruleDISCH_ALL th8 + else do atm <- listMkConj =<< mapM (uncurry mkEq) (yes ++ no) + ths <- ruleCONJUNCTS #<< primASSUME atm + th0 <- ruleSPECL avs #<< primASSUME cls + (th6, th5') <- canon' atm th0 ths + th7 <- foldr1M ruleCONJ $ map (primREFL . snd) no + th8 <- ruleGENL avs =<< ruleMP th6 th7 + ruleIMP_ANTISYM th5' =<< ruleDISCH_ALL th8 + ftm <- fromJustM $ funpowM (length args) (body <=< rand) =<< + rand (concl eth) + fth' <- itlistM ruleMK_FORALL args =<< runConv convFORALL_IMPS ftm + fromRightM $ primTRANS eth fth') + "canonicalizeClause" + where canon :: BoolCtxt thry => HOLTerm -> HOLTermEnv -> HOLTermEnv + -> [HOLTerm] -> HOLTerm -> HOLThm -> [HOLThm] + -> HOL cls thry (HOLThm, HOLThm) + canon rel plis yes nvs atm th0 ths = + do thl <- fromJustM $ + mapM (\ t -> find (\ th -> lhs (concl th) == + Just t) ths) args + th1 <- fromRightM $ foldlM primMK_COMB (primREFL rel) thl + th1_5 <- fromRightM $ ruleSYM th1 + th2 <- fromRightM $ primEQ_MP th1_5 th0 + th3 <- ruleDISCH atm th2 + tm4 <- fromJustM $ funpowM (length yes) rand =<< lHand =<< + liftM concl (primINST yes th3) + th4 <- itlistM (ruleCONJ . primREFL . fst) yes #<< + primASSUME tm4 + th5 <- ruleGENL args =<< ruleGENL nvs =<< + ruleDISCH tm4 =<< ruleMP th3 th4 + th6 <- ruleSPECL nvs =<< ruleSPECL (map snd plis) #<< + primASSUME (concl th5) + th5' <- ruleDISCH_ALL th5 + return (th6, th5') + +canonicalizeClauses :: IndDefsCtxt thry => [HOLTerm] -> HOL cls thry HOLThm +canonicalizeClauses clauses = + let concls = map getConcl clauses + uncs = map stripComb concls + rels = foldr (insert . fst) [] uncs in + do xargs <- liftMaybe "canonicalizeClauses: lookup" $ + mapM (`lookup` uncs) rels + closed <- listMkConj clauses + let avoids = variables closed + flargs = mkArgs "a" avoids . map typeOf $ foldr1 (++) xargs + cargs <- liftMaybe "canonicalClauses: zargs and cargs" $ + do zargs <- liftM (zip rels) $ shareOut xargs flargs + mapM (\ (x, _) -> x `lookup` zargs) uncs + cthms <- map2M canonicalizeClause clauses cargs + pclauses <- liftMaybe "canonicalizeClauses: rand" $ + mapM (rand . concl) cthms + let collectClauses tm = mapFilter (\ (x, y) -> if x == tm + then Just y + else Nothing) $ + zip (map fst uncs) pclauses + clausell = map collectClauses rels + cclausel <- mapM listMkConj clausell + cclauses <- listMkConj cclausel + oclauses <- listMkConj pclauses + eth <- ruleCONJ_ACI =<< mkEq oclauses cclauses + cth <- foldr1M ruleMK_CONJ cthms + pth <- fromRightM $ primTRANS cth eth + th1 <- foldr1M ruleMK_CONJ =<< mapM ruleAND_IMPS_CONV cclausel + fromRightM $ primTRANS pth th1 + +deriveCanonInductiveRelations :: BoolCtxt thry => [HOLTerm] + -> HOL cls thry HOLThm +deriveCanonInductiveRelations cls = + (do closed <- listMkConj cls + let clauses = conjuncts closed + (vargs, bodies) = unzip $ map stripForall clauses + (ants, concs) = unzip . fromJust $ mapM destImp bodies + rels = fromJust $ mapM (repeatM rator) concs + avoids = variables closed + rels' = variants avoids rels + crels = zip rels rels' + primeFun = subst crels + closed' <- liftO $ primeFun closed + defTms <- map2M (mkDef primeFun closed' rels') vargs concs + defThms <- map2M ruleHALF_BETA_EXPAND vargs #<< mapM primASSUME defTms + indThms <- map2M (mkInd rels') vargs defThms + indThmr <- foldr1M ruleCONJ indThms + indThm <- ruleGENL rels' =<< ruleDISCH closed' indThmr + mConcs <- map2M (\ a t -> do t' <- mkImp t #<< primeFun t + listMkForall a t') vargs ants + monoTm <- mkImp (concl indThmr) =<< listMkConj mConcs + monoTm' <- listMkForall rels' monoTm + forallMonoTm' <- listMkForall rels monoTm' + monoThm <- fromRightM $ primASSUME forallMonoTm' + closeThm <- fromRightM $ primASSUME closed' + monoTh1 <- ruleSPEC_ALL monoThm + monoTh2 <- ruleSPECL rels' indThm + monoThms <- ruleCONJUNCTS =<< ruleMP monoTh1 =<< ruleMP monoTh2 closeThm + closeThms <- ruleCONJUNCTS closeThm + ruleThms <- map2M (proveRule rels' closed') monoThms $ zip closeThms defThms + ruleThm <- foldr1M ruleCONJ ruleThms + dTms <- fromRightM $ map2M listMkAbs vargs ants + let doubleFun = subst (zip rels dTms) + unThs <- map2M (mkUnbetas doubleFun) clauses dTms + unThs' <- liftM (fromRight . ruleSYM) . foldr1M ruleMK_CONJ $ map fst unThs + irThm <- fromRightM $ primEQ_MP unThs' ruleThm + monoThm' <- ruleSPECL rels =<< ruleSPECL dTms monoThm + mrThm <- ruleMP monoThm' irThm + unThs'' <- liftM (fromRight . ruleSYM) . foldr1M ruleMK_CONJ $ map (fst . snd) unThs + imrThm <- fromRightM $ primEQ_MP unThs'' mrThm + indThm' <- ruleSPECL dTms indThm + ifThm <- ruleMP indThm' imrThm + unThs''' <- foldr1M ruleMK_CONJ $ map (snd . snd) unThs + fThm <- fromRightM $ primEQ_MP unThs''' ifThm + fThms <- ruleCONJUNCTS fThm + caseThm <- foldr1M ruleCONJ =<< map2M mkCase fThms =<< ruleCONJUNCTS ruleThm + ruleCONJ ruleThm =<< ruleCONJ indThm caseThm) + "deriveCanonInductiveRelations" + + where mkDef f closed rels arg con = + do tm <- mkImp closed #<< f con + tm' <- listMkForall rels tm + (l, r) <- liftEither "mkDef" $ do l <- note "" $ repeatM rator con + r <- listMkAbs arg tm' + return (l, r) + mkEq l r + + mkInd :: BoolCtxt thry => [HOLTerm] -> [HOLTerm] -> HOLThm + -> HOL cls thry HOLThm + mkInd rels args thm = + do (th1, _) <- ruleEQ_IMP =<< ruleSPEC_ALL thm + ant <- liftMaybe "mkInd: lHand" . lHand $ concl th1 + th2 <- ruleSPECL rels =<< ruleUNDISCH th1 + ruleGENL args =<< ruleDISCH ant =<< ruleUNDISCH th2 + + proveRule :: BoolCtxt thry => [HOLTerm] -> HOLTerm -> HOLThm + -> (HOLThm, HOLThm) -> HOL cls thry HOLThm + proveRule rels closed mth (cth, dth) = + let (avs, bod) = stripForall $ concl mth in + do th1 <- ruleSPECL avs mth + th2 <- ruleIMP_TRANS th1 =<< ruleSPECL avs cth + th3 <- ruleGENL rels =<< ruleDISCH closed =<< ruleUNDISCH th2 + th4 <- liftM (fromRight . ruleSYM) $ ruleSPECL avs dth + tm <- liftMaybe "proveRule: lHand" $ lHand bod + ruleGENL avs =<< ruleDISCH tm #<< primEQ_MP th4 th3 + + mkUnbetas f tm dtm = case stripForall tm of + (avs, Comb (Comb i l) r) -> + do bth <- ruleRIGHT_BETAS avs $ primREFL dtm + let l' = fromJust $ f l + (il', ir) <- liftEither "mkUnbetas: mkComb" $ pairMapM (mkComb i) (l', r) + (munb, iunb, junb) <- fromRightM $ do munb <- flip ruleAP_THM r =<< ruleAP_TERM i bth + iunb <- ruleAP_TERM il' bth + junb <- ruleAP_TERM ir bth + return (munb, iunb, junb) + let quantify th = foldrM ruleMK_FORALL th avs + munb' <- quantify munb + iunb' <- quantify iunb + junb' <- quantify junb + return (munb', (iunb', junb')) + _ -> fail "mkUnbetas" + + mkCase th1 th2 = let (avs, _) = stripForall $ concl th1 in + do th1' <- ruleSPEC_ALL th1 + ruleGENL avs =<< ruleIMP_ANTISYM th1' =<< + ruleSPEC_ALL th2 + +deriveNonschematicInductiveRelations :: IndDefsCtxt thry => HOLTerm + -> HOL cls thry HOLThm +deriveNonschematicInductiveRelations tm = + let clauses = conjuncts tm in + do canonThm <- canonicalizeClauses clauses + canonThm' <- fromRightM $ ruleSYM canonThm + pclosed <- liftMaybe "deriveNonschematicInductiveRelations" . rand $ concl canonThm + let pclauses = conjuncts pclosed + rawThm <- deriveCanonInductiveRelations pclauses + (ruleThm, otherThms) <- ruleCONJ_PAIR rawThm + (indThm, caseThm) <- ruleCONJ_PAIR otherThms + ruleThm' <- fromRightM $ primEQ_MP canonThm' ruleThm + indThm' <- ruleCONV (convONCE_DEPTH (convREWR canonThm')) indThm + ruleCONJ ruleThm' =<< ruleCONJ indThm' caseThm + +tacBackChain :: BoolCtxt thry => HOLThm -> Tactic cls thry +tacBackChain thm (Goal asl w) = + let matchFun = rulePART_MATCH (liftM snd . destImp) thm in + do th1 <- matchFun w + case destImp $ concl th1 of + Just (ant, _) -> return . GS nullMeta [Goal asl ant] $ just th1 + _ -> fail "tacBackChain" + where just th i (t:[]) = do th' <- ruleINSTANTIATE i th + ruleMATCH_MP th' t + just _ _ _ = fail "tacBackChain: bad justification" + +tacMonoAbs :: IndDefsCtxt thry => Tactic cls thry +tacMonoAbs g@(Goal _ w) = + do imp <- serve [indDefs| (==>) |] + (ant, con) <- liftMaybe "tacMonoAbs: goal not an implication" $ destImp w + let (_, vars) = stripComb con + rnum = length vars - 1 + ((hd1, args1), (hd2, args2)) <- liftMaybe "tacMonoAbs: strip_ncomb failed" $ + pairMapM (strip_ncomb rnum) (ant, con) + hd1th <- runConv convBETA hd1 + th1 <- fromRightM $ foldlM ruleAP_THM hd1th args1 + hd2th <- runConv convBETA hd2 + th4 <- fromRightM $ do th2 <- foldlM ruleAP_THM hd2th args2 + th3 <- ruleAP_TERM imp th1 + primMK_COMB th3 th2 + tacCONV (convREWR th4) g + +thmIMP_REFL :: IndDefsCtxt thry => HOL cls thry HOLThm +thmIMP_REFL = cacheProof "thmIMP_REFL" ctxtIndDefs $ + ruleITAUT "!p . p ==> p" + +tacApplyMono :: IndDefsCtxt thry => [(Text, Tactic cls thry)] + -> Tactic cls thry +tacApplyMono tacs g@(Goal _ w) = + case destImp w of + Just (a,c) -> if a `aConv` c then do th <- ruleSPEC a thmIMP_REFL + tacACCEPT th g + else let cn = case repeatM rator c of + Just (Const n _) -> n + _ -> "" in + tryFind (\ (k, t) -> if k == cn then t g else fail "") tacs + _ -> fail "tacApplyMono: not an implication" + +tacMONO :: (BasicConvs thry, IndDefsCtxt thry) => Tactic cls thry +tacMONO g = + do acid <- openLocalStateHOL (MonoThms []) + thms <- queryHOL acid GetMonos + closeAcidStateHOL acid + tacs <- liftMaybe "tacMONO: tacs" $ foldrM tacFun [("", tacMonoAbs)] thms + let tacMonoStep = _REPEAT tacGEN `_THEN` tacApplyMono tacs + (_REPEAT tacMonoStep `_THEN` tacASM_REWRITE_NIL) g + where tacFun th l = + do x <- rand =<< rand (concl th) + x' <- repeatM rator x + let c = case x' of + Const n _ -> n + _ -> "" + return ((c, tacBackChain th `_THEN` _REPEAT tacCONJ) : l) + +proveMonotonicityHyps :: (BasicConvs thry, IndDefsCtxt thry) => HOLThm + -> HOL cls thry HOLThm +proveMonotonicityHyps thm = + let proveFun :: (BasicConvs thry, IndDefsCtxt thry) => HOLTerm + -> HOL cls thry HOLThm + proveFun t = prove t $ _REPEAT tacGEN `_THEN` + _DISCH_THEN (_REPEAT _CONJUNCTS_THEN tacASSUME) `_THEN` + _REPEAT tacCONJ `_THEN` tacMONO in + do mths <- mapFilterM proveFun . filter (not . isEq) $ hyp thm + return $ foldr rulePROVE_HYP thm mths + +data IndDefs = IndDefs !(Map Text (HOLThm, HOLThm, HOLThm)) deriving Typeable + +deriveSafeCopy 0 'base ''IndDefs + +addInductiveDef :: Text -> (HOLThm, HOLThm, HOLThm) -> Update IndDefs () +addInductiveDef lbl trip = + do (IndDefs defs) <- get + put (IndDefs (mapInsert lbl trip defs)) + +getInductiveDefs :: Query IndDefs [(HOLThm, HOLThm, HOLThm)] +getInductiveDefs = + do (IndDefs defs) <- ask + return $! mapElems defs + +getAnInductiveDef :: Text -> Query IndDefs (Maybe (HOLThm, HOLThm, HOLThm)) +getAnInductiveDef ty = + do (IndDefs defs) <- ask + return $! mapLookup ty defs + +makeAcidic ''IndDefs ['addInductiveDef, 'getInductiveDefs, 'getAnInductiveDef] + +generalizeDef :: BoolCtxt thry => [HOLTerm] -> HOLTerm -> HOLThm + -> HOL cls thry HOLThm +generalizeDef vs tm thm = + case destEq tm of + Just (l@(Var lname lty), r) -> + do ty <- foldrM (mkFunTy . typeOf) lty vs + r' <- liftEither "generalizeDef: listMkAbs" $ listMkAbs vs r + tm' <- mkEq (mkVar lname ty) r' + th0 <- ruleRIGHT_BETAS vs =<< + liftEither "generalizeDef: primASSUME" (primASSUME tm') + l'' <- liftMaybe "generalizeDef: lHand" . lHand $ concl th0 + th1 <- ruleDISCH tm thm + ruleMP (fromJust $ primINST [(l'', l)] th1) th0 + _ -> fail "generalizeDef: term not an equation" + + +generalizeSchematicVariables :: BoolCtxt thry => Bool -> [HOLTerm] -> HOLThm -> HOL cls thry HOLThm +generalizeSchematicVariables gflag vs thm = + let (defs, others) = partition isEq $ hyp thm in + do th1 <- foldrM (generalizeDef vs) thm defs + if gflag + then do others' <- mapM (\ t -> let fvs = frees t in + do forallT <- listMkForall fvs t + ruleSPECL fvs =<< liftEither "generalizeSchematicVariables: forallT" (primASSUME forallT)) others + ruleGENL vs $ foldr rulePROVE_HYP th1 others' + else return th1 + +deriveExistence :: (BasicConvs thry, IndDefsCtxt thry) => HOLThm + -> HOL cls thry HOLThm +deriveExistence thm = + let defs = filter isEq $ hyp thm in + foldrM ruleEXISTS_EQUATION thm defs + +makeDefinitions :: BoolCtxt thry => HOLThm -> HOL Theory thry HOLThm +makeDefinitions thm = + let defs = filter isEq $ hyp thm in + do dths <- mapM (\ x -> case x of + ((Var name _) := _) -> newDefinition name x + _ -> fail "makeDefinitions") defs + let insts = zip (fromJust $ mapM lhs defs) + (fromJust $ mapM (lhs . concl) dths) + th <- foldrM ruleDISCH thm defs + foldlM ruleMP (fromJust $ primINST insts th) dths + + +unschematizeClauses :: [HOLTerm] -> HOL cls thry ([HOLTerm], [HOLTerm]) +unschematizeClauses clauses = + do schem <- liftMaybe "unschematizeClauses: schem" $ mapM schemFun clauses + let schems = setify schem + if isVar (head schem) + then return (clauses, []) + else if (length . setify $ map (snd . stripComb) schems) /= 1 + then fail "unschematizeClauses: schematic variables not used consistently" + else do avoids <- liftM variables $ listMkConj clauses + let grels = variants avoids $ map hackFun schems + let crels = zip grels schems + clauses' <- liftO $ mapM (subst crels) clauses + return (clauses', snd . stripComb $ head schems) + where schemFun cls = + let (avs, bod) = stripForall cls in + do bod' <- liftM snd (destImp bod) <|> Just bod + pareComb avs bod' + + pareComb qvs tm = + if null (frees tm `intersect` qvs) && + all isVar (snd $ stripComb tm) + then return tm + else pareComb qvs =<< rator tm + + hackFun tm = mkVar (fst . fromJust $ destVar =<< repeatM rator tm) $ + typeOf tm + +proveInductiveProperties :: (BasicConvs thry, IndDefsCtxt thry, + HOLTermRep tm cls thry) + => tm -> HOL cls thry ([HOLTerm], HOLThm) +proveInductiveProperties ptm = + do tm <- toHTm ptm + (clauses', fvs) <- unschematizeClauses $ conjuncts tm + th <- deriveNonschematicInductiveRelations =<< listMkConj clauses' + mth <- proveMonotonicityHyps th + return (fvs, mth) + +proveInductiveRelationsExist :: (BasicConvs thry, IndDefsCtxt thry, + HOLTermRep tm cls thry) + => tm -> HOL cls thry HOLThm +proveInductiveRelationsExist tm = + do (fvs, th1) <- proveInductiveProperties tm + th2 <- generalizeSchematicVariables True fvs th1 + deriveExistence th2 + +-- Returns a triple of theorems +-- Rule theorem -> says new relations are closed under the rules +-- Inductive Theorem -> says the relations are the least closed +-- Cases Theorem -> showing how each set of satisfying values can be composed + +newInductiveDefinition :: (BasicConvs thry, IndDefsCtxt thry, + HOLTermRep tm Theory thry) => Text -> tm + -> HOL Theory thry (HOLThm, HOLThm, HOLThm) +newInductiveDefinition lbl ptm = + do acid <- openLocalStateHOL (IndDefs mapEmpty) + qth <- queryHOL acid (GetAnInductiveDef lbl) + closeAcidStateHOL acid + case qth of + Just trip -> + return trip + Nothing -> + do tm <- toHTm ptm + (fvs, th1) <- proveInductiveProperties tm + th2 <- generalizeSchematicVariables True fvs th1 + th3 <- makeDefinitions th2 + let (avs, _) = stripForall $ concl th3 + (r, ic) <- ruleCONJ_PAIR =<< ruleSPECL avs th3 + (i, c) <- ruleCONJ_PAIR ic + rth <- ruleGENL avs r + ith <- ruleGENL avs i + cth <- ruleGENL avs c + let trip = (rth, ith, cth) + acid' <- openLocalStateHOL (IndDefs mapEmpty) + updateHOL acid' (AddInductiveDef lbl trip) + createCheckpointAndCloseHOL acid' + return trip + +getInductiveDefinition :: Text -> HOL cls thry (HOLThm, HOLThm, HOLThm) +getInductiveDefinition ty = + do acid <- openLocalStateHOL (IndDefs mapEmpty) + def <- queryHOL acid (GetAnInductiveDef ty) + closeAcidStateHOL acid + liftMaybe "getAnInductiveDefinition: definition not found." def + + + + + + + + diff --git a/src/HaskHOL/Lib/IndDefs/Base.hs b/src/HaskHOL/Lib/IndDefs/Base.hs new file mode 100644 index 0000000..0ef7737 --- /dev/null +++ b/src/HaskHOL/Lib/IndDefs/Base.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE FlexibleContexts #-} +module HaskHOL.Lib.IndDefs.Base where + +import HaskHOL.Core + +data MonoThms = MonoThms ![HOLThm] deriving Typeable + +deriveSafeCopy 0 'base ''MonoThms + +addMono :: HOLThm -> Update MonoThms () +addMono th = + do (MonoThms ths) <- get + put (MonoThms (th:ths)) + +getMonos :: Query MonoThms [HOLThm] +getMonos = + do (MonoThms ths) <- ask + return ths + +makeAcidic ''MonoThms ['addMono, 'getMonos] + +addMonoThm :: HOLThmRep thm Theory thry => thm -> HOL Theory thry () +addMonoThm pthm = + do mthm <- toHThm pthm + acid <- openLocalStateHOL (MonoThms []) + updateHOL acid (AddMono mthm) + createCheckpointAndCloseHOL acid diff --git a/src/HaskHOL/Lib/IndDefs/Context.hs b/src/HaskHOL/Lib/IndDefs/Context.hs new file mode 100644 index 0000000..a262b86 --- /dev/null +++ b/src/HaskHOL/Lib/IndDefs/Context.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TypeSynonymInstances, + UndecidableInstances #-} +module HaskHOL.Lib.IndDefs.Context + ( IndDefsType + , IndDefsCtxt + , ctxtIndDefs + , indDefs + ) where + +import HaskHOL.Core +import HaskHOL.Lib.Theorems +import HaskHOL.Lib.Simp + +import HaskHOL.Lib.Theorems.Context +import HaskHOL.Lib.IndDefs.Base + +extendTheory ctxtTheorems "IndDefs" $ + mapM_ addMonoThm [ thmMONO_AND, thmMONO_OR, thmMONO_IMP + , thmMONO_NOT, thmMONO_EXISTS, thmMONO_FORALL ] + +templateProvers 'ctxtIndDefs + +-- have to manually write this, for now +type family IndDefsCtxt a where + IndDefsCtxt a = (TheoremsCtxt a, IndDefsContext a ~ 'True) + +type instance PolyTheory IndDefsType b = IndDefsCtxt b + +instance BasicConvs IndDefsType where + basicConvs _ = [] diff --git a/src/HaskHOL/Lib/Itab.hs b/src/HaskHOL/Lib/Itab.hs new file mode 100644 index 0000000..3e401fa --- /dev/null +++ b/src/HaskHOL/Lib/Itab.hs @@ -0,0 +1,109 @@ +{-| + Module: HaskHOL.Lib.Itab + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Itab + ( tacITAUT + , ruleITAUT + ) where + +import HaskHOL.Core +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Equal +import HaskHOL.Lib.DRule +import HaskHOL.Lib.Tactics + + +tacUnifyAccept :: [HOLTerm] -> ThmTactic cls thry +tacUnifyAccept mvs th (Goal _ w) = + do insts <- liftO $ termUnify mvs (concl th) w + return (GS ([], insts) [] + (\ i _ -> do th' <- ruleINSTANTIATE insts th + ruleINSTANTIATE i th')) + +conjunctsThen' :: BoolCtxt thry => ThmTactic cls thry -> ThmTactic cls thry +conjunctsThen' ttac cth g = + do th1 <- ruleCONJUNCT1 cth + th2 <- ruleCONJUNCT2 cth + (ttac th1 `_THEN` ttac th2) g + +rIMPLICATE :: BoolCtxt thry => HOLTerm -> HOL cls thry HOLThm +rIMPLICATE t = + case destNeg t of + Just t' -> do dNot <- defNOT + ruleCONV (convRAND convBETA) #<< ruleAP_THM dNot t' + _ -> fail "rIMPLICATE" + +tacRightReversible :: BoolCtxt thry => Tactic cls thry +tacRightReversible = + _FIRST [ tacCONJ + , tacGEN + , tacDISCH + , \ gl@(Goal _ w) -> tacCONV (Conv $ \ _ -> rIMPLICATE w) gl + , tacEQ + ] + +tacLeftReversible :: BoolCtxt thry => ThmTactic cls thry +tacLeftReversible th gl = + tryFind (\ ttac -> ttac th gl) + [ conjunctsThen' tacASSUME + , tacDISJ_CASES + , tacCHOOSE + , \ thm g -> do thm' <- rIMPLICATE (concl thm) + tacASSUME (fromRight $ primEQ_MP thm' thm) g + , \ thm g -> do thm' <- uncurry ruleCONJ =<< ruleEQ_IMP thm + conjunctsThen' tacMP thm' g + ] + + +itautTac :: BoolCtxt thry => [HOLTerm] -> Int -> Tactic cls thry +itautTac mvs n gl + | n <= 0 = _FAIL "tITAUT_TAC: too deep" gl + | otherwise = + (_FIRST_ASSUM (tacUnifyAccept mvs) `_ORELSE` + tacACCEPT thmTRUTH `_ORELSE` + _FIRST_ASSUM tacCONTR `_ORELSE` + (tacRightReversible `_THEN` _TRY (itautTac mvs n)) `_ORELSE` + (_FIRST_X_ASSUM tacLeftReversible `_THEN` _TRY (itautTac mvs n)) `_ORELSE` + _FIRST_X_ASSUM (\ th -> tacASSUME th `_THEN` + (\ g -> case destForall $ concl th of + Just (v, _) -> do gv <- genVar $ typeOf v + (tacMETA_SPEC gv th `_THEN` + itautTac (gv:mvs) (n-2) `_THEN` + _NO) g + _ -> fail "")) `_ORELSE` + (tacDISJ1 `_THEN` itautTac mvs n `_THEN` _NO) `_ORELSE` + (tacDISJ2 `_THEN` itautTac mvs n `_THEN` _NO) `_ORELSE` + (\ gl2@(Goal _ w) -> case destExists w of + Just (v, _) -> do gv <- genVar $ typeOf v + (tacX_META_EXISTS gv `_THEN` + itautTac (gv:mvs) (n-2) `_THEN` + _NO) gl2 + _ -> fail "") `_ORELSE` + _FIRST_ASSUM (\ th g -> case destImp $ concl th of + Just (v, _) -> + (_SUBGOAL_THEN v (\ ath g2 -> do th' <- ruleMP th ath + tacASSUME th' g2) `_THEN` + itautTac mvs (n-1) `_THEN` + _NO) g + _ -> _NO g)) gl + +itautIterdeepTac :: BoolCtxt thry => Int -> Tactic cls thry +itautIterdeepTac n gl = + printDebugLn ("searching with limit: " ++ show n) $ + ((itautTac [] n `_THEN` _NO) `_ORELSE` itautIterdeepTac (n+1)) gl + +tacITAUT :: BoolCtxt thry => Tactic cls thry +tacITAUT = itautIterdeepTac 0 + +ruleITAUT' :: BoolCtxt thry => HOLTerm -> HOL cls thry HOLThm +ruleITAUT' tm = prove tm tacITAUT + +ruleITAUT :: (HOLTermRep tm cls thry, BoolCtxt thry) => tm + -> HOL cls thry HOLThm +ruleITAUT = ruleITAUT' <=< toHTm diff --git a/src/HaskHOL/Lib/Meson.hs b/src/HaskHOL/Lib/Meson.hs new file mode 100644 index 0000000..f391dd5 --- /dev/null +++ b/src/HaskHOL/Lib/Meson.hs @@ -0,0 +1,1242 @@ +{-# LANGUAGE PatternSynonyms, ScopedTypeVariables #-} +{-| + Module: HaskHOL.Lib.Meson + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Meson + ( tacGEN_MESON + , tacASM_MESON + , tacASM_MESON_NIL + , tacMESON + , tacMESON_NIL + , ruleMESON + , ruleMESON_NIL + , mesonDepth + , setMesonDepth + , unsetMesonDepth + , mesonPRefine + , setMesonPRefine + , unsetMesonPRefine + , mesonBrand + , setMesonBrand + , unsetMesonBrand + , mesonChatty + , setMesonChatty + , unsetMesonChatty + , mesonSkew + , setMesonSkew + , mesonSplitLimit + , setMesonSplitLimit + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Canon +import HaskHOL.Lib.Classic +import HaskHOL.Lib.Equal +import HaskHOL.Lib.Theorems +import HaskHOL.Lib.Simp +import HaskHOL.Lib.DRule +import HaskHOL.Lib.Tactics +import HaskHOL.Lib.Trivia +import HaskHOL.Lib.Trivia.Context + + +-- AST for negation normal form terms +data FOLTerm + = FVar Int + | FNApp Int [FOLTerm] + deriving (Eq, Ord) + +type FOLAtom = (Int, [FOLTerm]) + +-- Type of a MESON proof tree +data FOLGoal = Subgoal FOLAtom [FOLGoal] (Int, HOLThm) Int [(FOLTerm, Int)] + deriving Eq + +type FOLTermEnv = [(FOLTerm, Int)] +type Tup = (FOLTermEnv, Int, Int) +type Rule = (Int, [(([FOLAtom], FOLAtom), (Int, HOLThm))]) +type State = ((FOLAtom, [Rule]), Tup) + +data MesonErr = Fail | Cut deriving (Show, Typeable) +instance Exception MesonErr + +-- cacheing continuations. +-- HaskHOL thry caches at the global level, rather than locally as ML does, so each function does not maintain it's own cache automatically. +-- Additionally, caches are flushed + +type ContMem1 cls thry = (FOLGoal, Tup) -> HOL cls thry (FOLGoal, Tup) +type ContMemMany cls thry = ([FOLGoal], Tup) -> HOL cls thry (FOLGoal, Tup) + +data DeCont1 = Return1 + | Base DeCont + | Goals11 DeCont [Rule] Int [(FOLAtom, [Rule])] + | Cache1 DeCont1 deriving Eq + +data DeCont = TopRec FOLTermEnv Int FOLTermEnv FOLAtom (Int, HOLThm) DeCont1 Int + | Goals1 DeCont [Rule] Int [(FOLAtom, [Rule])] Int + | Goals2 DeCont [FOLGoal] + | Goals3 Int Int DeCont [Rule] Int [(FOLAtom, [Rule])] + | Goals4 Int Int Int DeCont [FOLGoal] + | Goals5 DeCont FOLGoal + | CacheMany DeCont deriving Eq + +cachecont :: DeCont1 -> DeCont1 +cachecont = Cache1 + +cacheconts :: DeCont -> DeCont +cacheconts = CacheMany + +-- local MESON state +type MesonState = HOLRef MesonRefs +data MesonRefs = MesonRefs + { infs :: !Int + , cutIn :: !Int + , vstore :: ![(HOLTerm, Int)] + , gstore :: ![(HOLTerm, Int)] + , vcounter :: !Int + , cstore :: ![(HOLTerm, Int)] + , ccounter :: !Int + , memory :: ![((Int, HOLTerm), HOLThm)] + , cont1 :: ![(DeCont1, [(FOLGoal, Tup)])] + , cont2 :: ![(DeCont, [([FOLGoal], Tup)])] + } + +initializeMeson :: TriviaCtxt thry => HOL cls thry MesonRefs +initializeMeson = + do falseTm <- serve [trivia| F |] + return $! MesonRefs 0 1 [] [] 0 [(falseTm, 1)] 2 [] [] [] + +-- meson settings +mesonOffInc :: Int +mesonOffInc = 10000 + +data MesonDepth = MesonDepth !Bool deriving Typeable + +deriveSafeCopy 0 'base ''MesonDepth + +getMesonDepth :: Query MesonDepth Bool +getMesonDepth = + do (MesonDepth depth) <- ask + return depth + +setMesonDepth' :: Bool -> Update MesonDepth () +setMesonDepth' depth = + put (MesonDepth depth) + +makeAcidic ''MesonDepth ['getMesonDepth, 'setMesonDepth'] + +setMesonDepth :: HOL Theory thry () +setMesonDepth = + do acid <- openLocalStateHOL (MesonDepth False) + updateHOL acid (SetMesonDepth' True) + createCheckpointAndCloseHOL acid + +unsetMesonDepth :: HOL Theory thry () +unsetMesonDepth = + do acid <- openLocalStateHOL (MesonDepth False) + updateHOL acid (SetMesonDepth' False) + createCheckpointAndCloseHOL acid + +mesonDepth :: HOL cls thry Bool +mesonDepth = + do acid <- openLocalStateHOL (MesonDepth False) + depth <- queryHOL acid GetMesonDepth + closeAcidStateHOL acid + return depth + + +data MesonPRefine = MesonPRefine !Bool deriving Typeable + +deriveSafeCopy 0 'base ''MesonPRefine + +getMesonPRefine :: Query MesonPRefine Bool +getMesonPRefine = + do (MesonPRefine prefine) <- ask + return prefine + +setMesonPRefine' :: Bool -> Update MesonPRefine () +setMesonPRefine' prefine = + put (MesonPRefine prefine) + +makeAcidic ''MesonPRefine ['getMesonPRefine, 'setMesonPRefine'] + +setMesonPRefine :: HOL Theory thry () +setMesonPRefine = + do acid <- openLocalStateHOL (MesonPRefine True) + updateHOL acid (SetMesonPRefine' True) + createCheckpointAndCloseHOL acid + +unsetMesonPRefine :: HOL Theory thry () +unsetMesonPRefine = + do acid <- openLocalStateHOL (MesonPRefine True) + updateHOL acid (SetMesonPRefine' False) + createCheckpointAndCloseHOL acid + +mesonPRefine :: HOL cls thry Bool +mesonPRefine = + do acid <- openLocalStateHOL (MesonPRefine True) + prefine <- queryHOL acid GetMesonPRefine + closeAcidStateHOL acid + return prefine + + +data MesonBrand = MesonBrand !Bool deriving Typeable + +deriveSafeCopy 0 'base ''MesonBrand + +getMesonBrand :: Query MesonBrand Bool +getMesonBrand = + do (MesonBrand brand) <- ask + return brand + +setMesonBrand' :: Bool -> Update MesonBrand () +setMesonBrand' brand = + put (MesonBrand brand) + +makeAcidic ''MesonBrand ['getMesonBrand, 'setMesonBrand'] + +setMesonBrand :: HOL Theory thry () +setMesonBrand = + do acid <- openLocalStateHOL (MesonBrand False) + updateHOL acid (SetMesonBrand' True) + createCheckpointAndCloseHOL acid + +unsetMesonBrand :: HOL Theory thry () +unsetMesonBrand = + do acid <- openLocalStateHOL (MesonBrand False) + updateHOL acid (SetMesonBrand' False) + createCheckpointAndCloseHOL acid + +mesonBrand :: HOL cls thry Bool +mesonBrand = + do acid <- openLocalStateHOL (MesonBrand False) + brand <- queryHOL acid GetMesonBrand + closeAcidStateHOL acid + return brand + + +data MesonChatty = MesonChatty !Bool deriving Typeable + +deriveSafeCopy 0 'base ''MesonChatty + +getMesonChatty :: Query MesonChatty Bool +getMesonChatty = + do (MesonChatty chatty) <- ask + return chatty + +setMesonChatty' :: Bool -> Update MesonChatty () +setMesonChatty' chatty = + put (MesonChatty chatty) + +makeAcidic ''MesonChatty ['getMesonChatty, 'setMesonChatty'] + +setMesonChatty :: HOL Theory thry () +setMesonChatty = + do acid <- openLocalStateHOL (MesonChatty False) + updateHOL acid (SetMesonChatty' True) + createCheckpointAndCloseHOL acid + +unsetMesonChatty :: HOL Theory thry () +unsetMesonChatty = + do acid <- openLocalStateHOL (MesonChatty False) + updateHOL acid (SetMesonChatty' False) + createCheckpointAndCloseHOL acid + +mesonChatty :: HOL cls thry Bool +mesonChatty = + do acid <- openLocalStateHOL (MesonChatty False) + chatty <- queryHOL acid GetMesonChatty + closeAcidStateHOL acid + return chatty + + +data MesonSkew = MesonSkew !Int deriving Typeable + +deriveSafeCopy 0 'base ''MesonSkew + +getMesonSkew :: Query MesonSkew Int +getMesonSkew = + do (MesonSkew n) <- ask + return n + +setMesonSkew' :: Int -> Update MesonSkew () +setMesonSkew' n = + put (MesonSkew n) + +makeAcidic ''MesonSkew ['getMesonSkew, 'setMesonSkew'] + +setMesonSkew :: Int -> HOL Theory thry () +setMesonSkew n = + do acid <- openLocalStateHOL (MesonSkew 3) + updateHOL acid (SetMesonSkew' n) + createCheckpointAndCloseHOL acid + +mesonSkew :: HOL cls thry Int +mesonSkew = + do acid <- openLocalStateHOL (MesonSkew 3) + depth <- queryHOL acid GetMesonSkew + closeAcidStateHOL acid + return depth + + +data MesonSplitLimit = MesonSplitLimit !Int deriving Typeable + +deriveSafeCopy 0 'base ''MesonSplitLimit + +getMesonSplitLimit :: Query MesonSplitLimit Int +getMesonSplitLimit = + do (MesonSplitLimit n) <- ask + return n + +setMesonSplitLimit' :: Int -> Update MesonSplitLimit () +setMesonSplitLimit' n = + put (MesonSplitLimit n) + +makeAcidic ''MesonSplitLimit ['getMesonSplitLimit, 'setMesonSplitLimit'] + +setMesonSplitLimit :: Int -> HOL Theory thry () +setMesonSplitLimit n = + do acid <- openLocalStateHOL (MesonSplitLimit 8) + updateHOL acid (SetMesonSplitLimit' n) + createCheckpointAndCloseHOL acid + +mesonSplitLimit :: HOL cls thry Int +mesonSplitLimit = + do acid <- openLocalStateHOL (MesonSplitLimit 8) + depth <- queryHOL acid GetMesonSplitLimit + closeAcidStateHOL acid + return depth + +-- misc stuff + +qpartition :: Eq a => (a -> Bool) -> [a] -> [a] -> ([a], [a]) +qpartition p m l = fromMaybe ([], l) $ partRec l + where partRec lst = + if lst == m then Nothing + else case lst of + [] -> Nothing + (h:t) -> if p h then case partRec t of + Nothing -> Just ([h], t) + Just (yes, no) -> Just (h:yes, no) + else case partRec t of + Just (yes, no) -> Just (yes, h:no) + Nothing -> Nothing + +-- nnf substitution functions + +folSubst :: [(FOLTerm, Int)] -> FOLTerm -> FOLTerm +folSubst theta tm@(FVar v) = revLookupd v theta tm +folSubst theta (FNApp f args) = FNApp f $ map (folSubst theta) args + +folInst :: [(FOLTerm, Int)] -> FOLAtom -> FOLAtom +folInst theta (p, args) = (p, map (folSubst theta) args) + +folSubstBump :: Int -> [(FOLTerm, Int)] -> FOLTerm -> HOL cls thry FOLTerm +folSubstBump offset theta tm@(FVar v) + | v < mesonOffInc = let v' = v + offset in + return . revLookupd v' theta $ FVar v' + | otherwise = return $! revLookupd v theta tm +folSubstBump offset theta (FNApp f args) = + liftM (FNApp f) $ mapM (folSubstBump offset theta) args + +folInstBump :: Int -> [(FOLTerm, Int)] -> FOLAtom -> HOL cls thry FOLAtom +folInstBump offset theta (p, args) = + do args' <- mapM (folSubstBump offset theta) args + return (p, args') + + +-- main nnf unification function + +isTriv :: [(FOLTerm, Int)] -> Int -> FOLTerm -> Bool +isTriv env x (FVar y) = + (y == x) || case revLookup y env of + Nothing -> False + Just t' -> isTriv env x t' +isTriv env x (FNApp _ args) = any (isTriv env x) args && error "isTriv: cyclic" + +folUnify :: Int -> FOLTerm -> FOLTerm -> [(FOLTerm, Int)] -> HOL cls thry [(FOLTerm, Int)] +folUnify offset (FNApp f fargs) (FNApp g gargs) sofar = + if f /= g then fail "folUnify" + else foldr2M (folUnify offset) sofar fargs gargs +folUnify offset tm1 (FVar x) sofar = + let x' = x + offset in + case revLookup x' sofar of + Just tm2' -> folUnify 0 tm1 tm2' sofar + Nothing -> return $! if isTriv sofar x' tm1 then sofar + else (tm1, x'):sofar +folUnify offset (FVar x) tm2 sofar = + case revLookup x sofar of + Just tm1' -> folUnify offset tm1' tm2 sofar + Nothing -> do tm2' <- folSubstBump offset [] tm2 + return $! if isTriv sofar x tm2' then sofar + else (tm2', x):sofar + + +-- test for nnf equality +folEq :: [(FOLTerm, Int)] -> FOLTerm -> FOLTerm -> HOL cls thry Bool +folEq insts tm1 tm2 = + if tm1 == tm2 then return True + else case (tm1, tm2) of + (FNApp f fargs, FNApp g gargs) -> + do conds <- zipWithM (folEq insts) fargs gargs + return $! f == g && and conds + (_, FVar x) -> + case revLookup x insts of + Just tm2' -> folEq insts tm1 tm2' + Nothing -> return (isTriv insts x tm1) <|> return False + (FVar x, _) -> + case revLookup x insts of + Just tm1' -> folEq insts tm1' tm2 + Nothing -> return (isTriv insts x tm2) <|> return False + +folAtomEq :: [(FOLTerm, Int)] -> FOLAtom -> FOLAtom -> HOL cls thry Bool +folAtomEq insts (p1, args1) (p2, args2) = + if p1 /= p2 then return False + else do conds <- zipWithM (folEq insts) args1 args2 + return $! and conds + +-- check ancestor list for repetition +checkan :: FOLTermEnv -> FOLAtom -> [Rule] -> HOL cls thry [Rule] +checkan insts (p, a) ancestors = + let p' = negate p + t' = (p', a) in + case lookup p' ancestors of + Nothing -> return ancestors + Just ours -> do conds <- mapM (folAtomEq insts t' . snd . fst) ours + if or conds + then fail "checkan" + else return ancestors + + +-- insert new goal's negation in ancestor clause, given refinement +insertan :: BoolCtxt thry => FOLTermEnv -> FOLAtom -> [Rule] -> HOL cls thry [Rule] +insertan insts (p, a) ancestors = + let p' = negate p + t' = (p', a) + (ourancp, otheranc) = fromMaybe ((p', []), ancestors) $ + remove (\ (pr, _) -> pr == p') ancestors + ouranc = snd ourancp in + do conds <- mapM (\ u -> folAtomEq insts t' (snd $ fst u)) ouranc + if or conds + then fail "insertan: loop" + else do th <- thmTRUTH + return ((p', (([], t'), (0, th)):ouranc):otheranc) + + +-- apply a multi-level "graph" instantiation + +folSubstPartial :: [(FOLTerm, Int)] -> FOLTerm -> FOLTerm +folSubstPartial insts tm@(FVar v) = + case revLookup v insts of + Nothing -> tm + Just t -> folSubstPartial insts t +folSubstPartial insts (FNApp f args) = + FNApp f $ map (folSubstPartial insts) args + + +-- tease apart local and global instantiations. +separateInsts2 :: Int -> FOLTermEnv -> FOLTermEnv -> (FOLTermEnv, FOLTermEnv) +separateInsts2 offset old new = + let (loc, glob) = qpartition (\ (_, v) -> offset <= v) old new in + if glob == old + then (map (first (folSubstPartial new)) loc, old) + else (map (first (folSubstPartial new)) loc, + map (first (folSubstPartial new)) glob) + +mkNegated :: FOLAtom -> FOLAtom +mkNegated (p, a) = (negate p, a) + +mkContraposes :: Int -> HOLThm -> [FOLAtom] -> [FOLAtom] -> [(([FOLAtom], FOLAtom), (Int, HOLThm))] -> + [(([FOLAtom], FOLAtom), (Int, HOLThm))] +mkContraposes _ _ _ [] sofar = sofar +mkContraposes n th used (h:t) sofar = + let nw = ((map mkNegated (used ++ t), h), (n, th)) in + mkContraposes (n + 1) th (used ++ [h]) t (nw:sofar) + + +-- optimize set of clausesa +optimizeRules :: [Rule] -> [Rule] +optimizeRules = map (second optimizeClauseOrder) + where optimizeClauseOrder = + sort (\ ((l1, _), _) ((l2, _), _) -> length l1 <= length l2) + +convDISJ_AC :: TheoremsCtxt thry => Conversion cls thry +convDISJ_AC = convAC thmDISJ_ACI + +convImp :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convImp = convREWR convImp_pth + where convImp_pth :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm + convImp_pth = cacheProof "convImp_pth" ctxtTrivia $ + ruleTAUT [str| a \/ b <=> ~b ==> a |] + +convPush :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convPush = convGEN_REWRITE convTOP_SWEEP [convPush_pth1, convPush_pth2] + where convPush_pth1 :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + convPush_pth1 = cacheProof "convPush_pth1" ctxtTrivia $ + ruleTAUT [str| ~(a \/ b) <=> ~a /\ ~b |] + + convPush_pth2 :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + convPush_pth2 = cacheProof "convPush_pth2" ctxtTrivia $ + ruleTAUT "~(~a) <=> a" + +convPull :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convPull = convGEN_REWRITE convDEPTH [convPull_pth] + where convPull_pth :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + convPull_pth = cacheProof "convPull_pth" ctxtTrivia $ + ruleTAUT [str| ~a \/ ~b <=> ~(a /\ b) |] + +convImf :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convImf = convREWR convImf_pth + where convImf_pth :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + convImf_pth = cacheProof "convImf_pth" ctxtTrivia $ + ruleTAUT "~p <=> p ==> F" + + +-- translate saved proof back to HOL +holNegate :: HOLTerm -> HOL cls thry HOLTerm +holNegate tm = liftMaybe "holNegate" (destNeg tm) <|> mkNeg tm + +mergeInst :: (FOLTerm, Int) -> [(FOLTerm, Int)] -> [(FOLTerm, Int)] +mergeInst (t, x) current = + let t' = folSubst current t in + (t', x) : current + +finishRule :: (BasicConvs thry, TriviaCtxt thry) => HOLThm + -> HOL cls thry HOLThm +finishRule thm = ruleGEN_REWRITE id [finishRule_pth1, finishRule_pth2] thm + where finishRule_pth1 :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + finishRule_pth1 = cacheProof "finishRule_pth1" ctxtTrivia $ + ruleTAUT "(~p ==> p) <=> p" + + finishRule_pth2 :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + finishRule_pth2 = cacheProof "finishRule_pth2" ctxtTrivia $ + ruleTAUT "(p ==> ~p) <=> ~p" + +-- create equality axioms + +convImpElim :: (BasicConvs thry, TriviaCtxt thry) => Conversion cls thry +convImpElim = convREWR convImpElim_pth + where convImpElim_pth :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + convImpElim_pth = cacheProof "convImpElim_pth" ctxtTrivia $ + ruleTAUT [str| (a ==> b) <=> ~a \/ b |] + +ruleEqElim :: (BasicConvs thry, TriviaCtxt thry) => HOLThm + -> HOL cls thry HOLThm +ruleEqElim thm = ruleMATCH_MP ruleEqElim_pth thm + where ruleEqElim_pth :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + ruleEqElim_pth = cacheProof "ruleEqElim_pth" ctxtTrivia $ + ruleTAUT [str| (a <=> b) ==> b \/ ~a |] + + +createEquivalenceAxioms :: (BasicConvs thry, TriviaCtxt thry) => (HOLTerm, Int) + -> HOL cls thry [HOLThm] +createEquivalenceAxioms (eq, _) = + (do ths@(th:_) <- sequence eqThms + fromJustM $ do veqTm <- rator =<< rator (concl th) + tyins <- typeMatch (typeOf veqTm) (typeOf eq) ([], [], []) + return $! map (primINST_TYPE_FULL tyins) ths) + "createEquivalenceAxioms" + where eqThms :: (BasicConvs thry, TriviaCtxt thry) => [HOL cls thry HOLThm] + eqThms = cacheProofs ["eqThms1", "eqThms2"] ctxtTrivia $ + ruleCONJUNCTS =<< + prove [str| (x:A = x) /\ (~(x:A = y) \/ ~(x = z) \/ (y = z)) |] + (tacREWRITE_NIL `_THEN` + tacASM_CASES "x:A = y " `_THEN` + tacASM_REWRITE_NIL `_THEN` + tacCONV (Conv ruleTAUT)) + + +tmConsts :: HOLTerm -> [(HOLTerm, Int)] -> [(HOLTerm, Int)] +tmConsts tm acc = + let (fn, args) = stripComb tm in + if null args then acc + else foldr tmConsts (insert (fn, length args) acc) args + +fmConsts :: HOLTerm -> ([(HOLTerm, Int)], [(HOLTerm, Int)]) -> Maybe ([(HOLTerm, Int)], [(HOLTerm, Int)]) +fmConsts tm acc@(preds, funs) = + case destForall tm of + Just (_, x) -> fmConsts x acc + Nothing -> + case destExists tm of + Just (_, x) -> fmConsts x acc + Nothing -> + case destConj tm of + Just (l, r) -> fmConsts l =<< fmConsts r acc + Nothing -> + case destDisj tm of + Just (l, r) -> fmConsts l =<< fmConsts r acc + Nothing -> + case destImp tm of + Just (l, r) -> fmConsts l =<< fmConsts r acc + Nothing -> + case destNeg tm of + Just x -> fmConsts x acc + Nothing -> + case destEq tm of + Just (l, r) -> if typeOf l == tyBool + then fmConsts r =<< fmConsts l acc + else catchCase tm + Nothing -> catchCase tm + + where catchCase t = let (p, args) = stripComb t in + Just $ if null args then acc + else (insert (p, length args) preds, + foldr tmConsts funs args) + +createCongruenceAxiom :: (BasicConvs thry, TriviaCtxt thry) => Bool + -> (HOLTerm, Int) -> HOL cls thry HOLThm +createCongruenceAxiom pflag (tm, len) = + let (atys, _) = splitList destFunTy $ typeOf tm in + (do (ctys, _) <- fromJustM $ chopList len atys + largs <- mapM genVar ctys + rargs <- mapM genVar ctys + let th1 = primREFL tm + ths <- mapM (\ (x, y) -> do eq <- mkEq x y + fromRightM $ primASSUME eq) (zip largs rargs) + th2 <- fromRightM $ foldlM primMK_COMB th1 ths + th3 <- if pflag then ruleEqElim th2 else return th2 + foldrM (\ e th -> ruleCONV convImpElim =<< ruleDISCH e th) th3 (hyp th3)) + "createCongruenceAxiom" + +createEqualityAxioms :: (BasicConvs thry, TriviaCtxt thry) => [HOLTerm] + -> HOL cls thry [HOLThm] +createEqualityAxioms tms = + do (preds, funs) <- liftMaybe "createEqualityAxioms" $ foldrM fmConsts ([], []) tms + let (eqs0, noneqs) = partition eqPred preds + if null eqs0 + then return [] + else do pcongs <- mapM (createCongruenceAxiom True) noneqs + fcongs <- mapM (createCongruenceAxiom False) funs + (preds1, _) <- liftMaybe "createEqualityAxioms" $ foldrM fmConsts ([], []) $ map concl (pcongs ++ fcongs) + let eqs1 = filter eqPred preds1 + eqs = eqs0 `union` eqs1 + equivs <- foldrM (\ x ys -> do xs <- createEquivalenceAxioms x + return $ union xs ys) [] eqs + return $! equivs ++ pcongs ++ fcongs + where eqPred (Const "=" _, _) = True + eqPred _ = False + +-- brand's transformation + +subtermsIrrefl :: [HOLTerm] -> HOLTerm -> [HOLTerm] -> [HOLTerm] +subtermsIrrefl _ Var{} acc = acc +subtermsIrrefl _ Const{} acc = acc +subtermsIrrefl lconsts tm acc = + let (_, args) = stripComb tm in + foldr (subtermsRefl lconsts) acc args + +subtermsRefl :: [HOLTerm] -> HOLTerm -> [HOLTerm] -> [HOLTerm] +subtermsRefl lconsts tm@Var{} acc = + if tm `elem` lconsts then insert tm acc else acc +subtermsRefl _ tm@Const{} acc = insert tm acc +subtermsRefl lconsts tm acc = + let (_, args) = stripComb tm in + foldr (subtermsRefl lconsts) (insert tm acc) args + +ruleCLAUSIFY :: (BasicConvs thry, TriviaCtxt thry) => HOLThm + -> HOL cls thry HOLThm +ruleCLAUSIFY = ruleCONV (convREWR ruleCLAUSIFY_pth) + where ruleCLAUSIFY_pth :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + ruleCLAUSIFY_pth = cacheProof "ruleCLAUSIFY_pth" ctxtTrivia $ + ruleTAUT [str| a ==> b <=> ~a \/ b |] + + +ruleBRAND :: (BasicConvs thry, TriviaCtxt thry) => [HOLTerm] -> HOLThm + -> HOL cls thry HOLThm +ruleBRAND [] th = return th +ruleBRAND (tm:tms) th = + do gv <- genVar $ typeOf tm + eq <- mkEq gv tm + th1 <- fromRightM $ ruleSYM #<< primASSUME eq + th' <- ruleCLAUSIFY =<< ruleDISCH eq =<< ruleSUBS [th1] th + tms' <- liftO $ mapM (subst [(tm, gv)]) tms + ruleBRAND tms' th' + +ruleBRAND_CONGS :: (BasicConvs thry, TriviaCtxt thry) => HOLThm + -> HOL cls thry HOLThm +ruleBRAND_CONGS th = + let lconsts = catFrees $ hyp th + lits = disjuncts $ concl th + atoms = map (\ t -> case destNeg t of + Just t' -> t' + _ -> t) lits + (eqs, noneqs) = partition partFun atoms + acc = foldr (subtermsIrrefl lconsts) [] noneqs + uts = foldr (\ x ys -> foldr (subtermsIrrefl lconsts) ys . snd $ stripComb x) acc eqs + sts = sort (\ s t -> not $ s `freeIn` t) uts in + ruleBRAND sts th + where partFun t = case stripComb t of + (Const "=" _, _) -> True + _ -> False + +ruleBRANDE :: (BasicConvs thry, TriviaCtxt thry) => HOLThm + -> HOL cls thry HOLThm +ruleBRANDE th = + let tm = concl th in + (do (l, r) <- fromJustM $ destEq tm + gv <- genVar $ typeOf l + eq <- mkEq r gv + rtm <- fromJustM $ rator tm + th1 <- fromRightM $ ruleAP_TERM rtm #<< primASSUME eq + ruleCLAUSIFY =<< ruleDISCH eq =<< fromRightM (primEQ_MP th1 th)) + "ruleBRANDE" + +ruleLDISJ_CASES :: BoolCtxt thry => HOLThm -> HOLThm -> HOLThm -> HOL cls thry HOLThm +ruleLDISJ_CASES th lth rth = + do th1 <- ruleDISJ1 lth $ concl rth + th2 <- ruleDISJ2 (concl lth) rth + ruleDISJ_CASES th th1 th2 + + +ruleASSOCIATE :: TriviaCtxt thry => HOLThm -> HOL cls thry HOLThm +ruleASSOCIATE = ruleCONV (convREWR ruleASSOCIATE_pth) + where ruleASSOCIATE_pth :: TriviaCtxt thry => HOL cls thry HOLThm + ruleASSOCIATE_pth = cacheProof "ruleASSOCIATE_pth" ctxtTrivia $ + ruleGSYM thmDISJ_ASSOC + + +ruleBRAND_TRANS :: (BasicConvs thry, TriviaCtxt thry) => HOLThm + -> HOL cls thry [HOLThm] +ruleBRAND_TRANS th = + let tm = concl th in + (case destDisj tm of + Just (l, r) -> + if isEq l + then do lth <- fromRightM $ primASSUME l + lth1 <- ruleBRANDE lth + lth2 <- ruleBRANDE #<< ruleSYM lth + rth <- ruleBRAND_TRANS =<< fromRightM (primASSUME r) + ls <- mapM (ruleASSOCIATE <=< ruleLDISJ_CASES th lth1) rth + rs <- mapM (ruleASSOCIATE <=< ruleLDISJ_CASES th lth2) rth + return $! ls ++ rs + else do rth <- ruleBRAND_TRANS =<< fromRightM (primASSUME r) + lth <- fromRightM $ primASSUME l + mapM (ruleLDISJ_CASES th lth) rth + Nothing -> + if isEq tm + then sequence [ruleBRANDE th, ruleBRANDE #<< ruleSYM th] + else return [th]) + "ruleBRAND_TRANS" + +findEqs :: HOLTerm -> [HOLTerm] +findEqs = findTerms (\ t -> case t of + (Const "=" _) -> True + _ -> False) + +ruleREFLEXATE :: [HOLThm] -> HOL cls thry [HOLThm] +ruleREFLEXATE ths = + let eqs = foldr (union . findEqs . concl) [] ths in + do tys <- liftMaybe "ruleREFLEXATE" $ mapM tyFun eqs + gvs <- mapM genVar tys + return $! foldr (\ v acc -> (primREFL v : acc)) ths gvs + where tyFun (Const _ (TyApp _ (ty:_))) = Just ty + tyFun _ = Nothing + +performBrandModification :: (BasicConvs thry, TriviaCtxt thry) => [HOLThm] + -> HOL cls thry [HOLThm] +performBrandModification ths = + if any (isJust . findTerm isEq . concl) ths + then do ths' <- mapM ruleBRAND_CONGS ths + ths'' <- foldrM (\ x ys -> do xs <- ruleBRAND_TRANS x + return $! union' (==) xs ys) [] ths' + ruleREFLEXATE ths'' + else return ths + +grabConstants :: HOLTerm -> [HOLTerm] -> Maybe [HOLTerm] +grabConstants tm acc + | isForall tm || isExists tm = + flip grabConstants acc =<< body =<< rand tm + | isIff tm || isImp tm || isConj tm || isDisj tm = + do rtm <- rand tm + grabConstants rtm =<< flip grabConstants acc =<< lHand tm + | isNeg tm = + flip grabConstants acc =<< rand tm + | otherwise = + return $! findTerms isConst tm `union` acc + +matchConsts :: (HOLTerm, HOLTerm) -> Maybe SubstTrip +matchConsts (Const s1 ty1, Const s2 ty2) + | s1 == s2 = typeMatch ty1 ty2 ([], [], []) + | otherwise = Nothing +matchConsts _ = Nothing + +polymorph :: [HOLTerm] -> HOLThm -> HOL cls thry [HOLThm] +polymorph mconsts th = + let tvs = typeVarsInTerm (concl th) \\ (unions . map typeVarsInTerm $ hyp th) in + if null tvs then return [th] + else do tyins <- liftMaybe "polymorph" $ + do pconsts <- grabConstants (concl th) [] + mapFilterM matchConsts $ allpairs (,) pconsts mconsts + let tyins' = map (`primINST_TYPE_FULL` th) tyins + ths' = setify' ((<=) `on` destThm) (==) tyins' + if null ths' + then printDebug "No useful-looking instantiation of lemma" $ return [th] + else return ths' + +polymorphAll :: [HOLTerm] -> [HOLThm] -> [HOLThm] -> HOL cls thry [HOLThm] +polymorphAll _ [] acc = return acc +polymorphAll mconsts (th:ths) acc = + do ths' <- polymorph mconsts th + mconsts' <- liftMaybe "polymorphAll" $ foldrM (grabConstants . concl) mconsts ths' + polymorphAll mconsts' ths (union' (==) ths' acc) + +tacPOLY_ASSUME :: BoolCtxt thry => [HOLThm] -> Tactic cls thry +tacPOLY_ASSUME ths gl@(Goal asl _) = + do mconsts <- liftMaybe "tacPOLY_ASSUME" $ foldrM (grabConstants . concl . snd) [] asl + ths' <- polymorphAll mconsts ths [] + _MAP_EVERY tacASSUME ths' gl + +tacCONJUNCTS_THEN' :: BoolCtxt thry => ThmTactic cls thry -> ThmTactic cls thry +tacCONJUNCTS_THEN' ttac cth gl = + do cthl <- ruleCONJUNCT1 cth + cthr <- ruleCONJUNCT2 cth + (ttac cthl `_THEN` ttac cthr) gl + +tacPURE_MESON :: (BasicConvs thry, TriviaCtxt thry) => MesonState -> Int -> Int + -> Int -> Tactic cls thry +tacPURE_MESON ref minVal maxVal inc goal = + do resetVars + resetConsts + flushCaches + (_FIRST_ASSUM tacCONTR `_ORELSE` + (\ g@(Goal asl _) -> do th <- simpleMesonRefute $ map snd asl + tacACCEPT th g)) goal + + where + simpleMesonRefute :: (BasicConvs thry, TriviaCtxt thry) => [HOLThm] + -> HOL cls thry HOLThm + simpleMesonRefute ths = + do dcutin <- liftM cutIn $ readHOLRef ref + clearContraposCache + modifyHOLRef ref $ \ st -> st { infs = 0 } + dflag <- mesonDepth + bflag <- mesonBrand + when dflag . modifyHOLRef ref $ \ st -> st { cutIn = 100001 } + ths' <- if bflag then performBrandModification ths + else liftM (ths ++) . createEqualityAxioms $ map concl ths + rules <- liftM optimizeRules $ folOfHOLClauses ths' + (proof, (insts, _, _)) <- solveGoal rules dflag inc (1, []) + modifyHOLRef ref $ \ st -> st { cutIn = dcutin } + mesonToHOL insts proof + + solveGoal :: BoolCtxt thry => [Rule] -> Bool -> Int -> FOLAtom -> HOL cls thry (FOLGoal, Tup) + solveGoal rules incdepth incsize g = solve minVal (g,[]) + where solve n gl = + if n > maxVal then fail "solveGoal: too deep" + else do cflag <- mesonChatty + _ <- if cflag + then do is <- liftM infs $ readHOLRef ref + printDebug (show is ++ " inferences so far. " ++ + "Searching with maximum size " ++ show n ++ ".") $ return () + else do is <- liftM infs $ readHOLRef ref + printDebug (show is ++ "..") $ return () + (do gi <- if incdepth then expandGoal rules gl n 100000 Return1 + else expandGoal rules gl 100000 n Return1 + _ <- if cflag + then do is <- liftM infs $ readHOLRef ref + printDebug ("Goal solved with " ++ show is ++ " inferences.") $ return () + else do is <- liftM infs $ readHOLRef ref + printDebug ("solved at " ++ show is) $ return () + return gi) <|> solve (n + incsize) gl + + expandGoal :: BoolCtxt thry => [Rule] -> (FOLAtom, [Rule]) -> Int -> Int -> DeCont1 -> HOL cls thry (FOLGoal, Tup) + expandGoal rules g maxdep maxinf = + expandGoalRec rules maxdep (g, ([], 2 * mesonOffInc, maxinf)) + + expandGoalRec :: BoolCtxt thry => [Rule] -> Int -> State -> DeCont1 -> HOL cls thry (FOLGoal, Tup) + expandGoalRec rules depth state@((g, _), (insts, offset, size)) cont = + if depth < 0 then fail "expandGoal: too deep" + else mesonExpand rules state + (\ apprule newstate@(_, (pinsts, _, _)) -> + let cont' = cacheconts $ TopRec insts offset pinsts g apprule cont size in + expandGoals rules (depth - 1) newstate cont') + + expandGoals :: BoolCtxt thry => [Rule] -> Int -> ([(FOLAtom, [Rule])], Tup) -> DeCont -> HOL cls thry (FOLGoal, Tup) + expandGoals _ _ ([], tup) cont = deCont cont ([], tup) + expandGoals rules depth (g:[], tup) cont = expandGoalRec rules depth (g, tup) $ Base cont + expandGoals rules depth (gl@(g:gs), tup@(insts, offset, size)) cont = + do dcutin <- liftM cutIn $ readHOLRef ref + skew <- mesonSkew + if size >= dcutin + then let lsize = size `div` skew + rsize = size - lsize in + do (lgoals, rgoals) <- liftMaybe "expandGoals" $ chopList (length gl `div` 2) gl + (let cont' = cacheconts $ Goals1 cont rules depth rgoals rsize in + expandGoals rules depth (lgoals, (insts, offset, lsize)) cont') + <|> (let cont' = cacheconts $ Goals3 rsize lsize cont rules depth lgoals in + expandGoals rules depth (rgoals, (insts, offset, lsize)) cont') + else let cont' = cachecont $ Goals11 cont rules depth gs in + expandGoalRec rules depth (g, tup) cont' + + mesonExpand :: forall cls thry. BoolCtxt thry => [Rule] -> State -> ((Int, HOLThm) -> ([(FOLAtom, [Rule])], Tup) -> + HOL cls thry (FOLGoal, Tup)) -> HOL cls thry (FOLGoal, Tup) + mesonExpand rules ((g, ancestors), tup@(insts, offset, size)) cont = + let pr = fst g in + do newancestors <- insertan insts g ancestors + let newstate = ((g, newancestors), tup) + pflag <- mesonPRefine + (if pflag && pr > 0 then throwHOL Fail + else case lookup pr ancestors of + Nothing -> throwHOL Fail + Just arules -> mesonExpandCont 0 arules newstate cont) `catchHOL` errCase pr newstate + where errCase :: Int -> State -> MesonErr -> HOL cls thry (FOLGoal, Tup) + errCase _ _ Cut = fail "mesonExpand" + errCase pr newstate Fail = + do prule <- liftMaybe "mesonExpand" $ lookup pr rules + let crules = filter (\ ((h, _), _) -> length h <= size) prule + mesonExpandCont offset crules newstate cont + + mesonExpandCont :: Int -> [(([FOLAtom], FOLAtom), b)] -> State -> + (b -> ([(FOLAtom, [Rule])], Tup) -> HOL cls thry (FOLGoal, Tup)) -> HOL cls thry (FOLGoal, Tup) + mesonExpandCont loffset rules state cont = + tryFind (\ r -> cont (snd r) =<< mesonSingleExpand loffset r state) rules + <|> throwHOL Fail + + mesonSingleExpand :: Int -> (([FOLAtom], FOLAtom), b) -> State -> HOL cls thry ([(FOLAtom, [Rule])], Tup) + mesonSingleExpand loffset rule (((_, ftms), ancestors), (insts, offset, size)) = + let ((hyps, conc), _) = rule in + do allEnv <- foldl2M (\ c a b -> folUnify loffset a b c) + insts ftms $ snd conc + let (loc, glob) = separateInsts2 offset insts allEnv + mkIHyp h = do h' <- folInstBump offset loc h + an <- checkan insts h' ancestors + return (h', an) + newhyps <- mapM mkIHyp hyps + modifyHOLRef ref $ \ st -> st { infs = 1 + infs st } + return (newhyps, (glob, offset + mesonOffInc, size-length hyps)) + + flushCaches :: HOL cls thry () + flushCaches = + modifyHOLRef ref $ \ st -> st { cont1 = [], cont2 = [] } + + replaceMem1 :: DeCont1 -> [(FOLGoal, Tup)] -> HOL cls thry () + replaceMem1 f m = + modifyHOLRef ref $ \ st -> st { cont1 = replaceMemRec $ cont1 st } + where replaceMemRec [] = [(f, m)] + replaceMemRec (x:xs) + | fst x == f = (f, m) : xs + | otherwise = x : replaceMemRec xs + + replaceMem :: DeCont -> [([FOLGoal], Tup)] -> HOL cls thry () + replaceMem f m = + modifyHOLRef ref $ \ st -> st { cont2 = replaceMemRec $ cont2 st } + where replaceMemRec [] = [(f, m)] + replaceMemRec (x:xs) + | fst x == f = (f, m) : xs + | otherwise = x : replaceMemRec xs + + deCont1 :: BoolCtxt thry => DeCont1 -> ContMem1 cls thry + deCont1 Return1 x = return x + deCont1 (Base cont) (g', stup) = deCont cont ([g'], stup) + deCont1 (Goals11 cont rules depth gs) (g', stup) = + let cont' = cacheconts $ Goals5 cont g' in + expandGoals rules depth (gs, stup) cont' + deCont1 (Cache1 cont) input@(_, (insts, _, size)) = + do cache <- liftM cont1 $ readHOLRef ref + case lookup cont cache of + Nothing -> + do modifyHOLRef ref $ \ st -> st { cont1 = [(cont, [input])] } + deCont1 cont input + Just m -> + do dflag <- mesonDepth + if any (\ (_, (insts', _, size')) -> insts == insts' && (size <= size' || dflag)) m + then fail "cacheconts" + else do replaceMem1 cont m + deCont1 cont input + + deCont :: BoolCtxt thry => DeCont -> ContMemMany cls thry + deCont (TopRec insts offset pinsts g apprule cont size) + (gs, (newinsts, newoffset, newsize)) = + let (locin, globin) = separateInsts2 offset pinsts newinsts + g' = Subgoal g gs apprule offset locin in + if globin == insts && null gs + then deCont1 cont (g', (globin, newoffset, size)) <|> throwHOL Cut + else deCont1 cont (g', (globin, newoffset, newsize)) <|> throwHOL Fail + deCont (Goals1 cont rules depth rgoals rsize) (lg', (i, off, n)) = + let cont' = cacheconts $ Goals2 cont lg' in + expandGoals rules depth (rgoals, (i, off, n + rsize)) cont' + deCont (Goals2 cont lg') (rg', ztup) = + deCont cont (lg' ++ rg', ztup) + deCont (Goals3 rsize lsize cont rules depth lgoals) (rg', (i, off, n)) = + let cont' = cacheconts $ Goals4 n rsize lsize cont rg' in + expandGoals rules depth (lgoals, (i, off, n + rsize)) cont' + deCont (Goals4 n rsize lsize cont rg') (lg', ztup@(_, _, fsize)) = + if n + rsize <= lsize + fsize + then fail "repetition of demigoal pair" + else deCont cont (lg' ++ rg', ztup) + deCont (Goals5 cont g') (gs', ftup) = + deCont cont (g':gs', ftup) + deCont (CacheMany cont) input@(_, (insts, _, size)) = + do cache <- liftM cont2 $ readHOLRef ref + case lookup cont cache of + Nothing -> + do modifyHOLRef ref $ \ st -> st { cont2 = [(cont, [input])] } + deCont cont input + Just m -> + do dflag <- mesonDepth + if any (\ (_, (insts', _, size')) -> insts == insts' && (size <= size' || dflag)) m + then fail "cacheconts" + else do replaceMem cont m + deCont cont input + + clearContraposCache :: HOL cls thry () + clearContraposCache = + modifyHOLRef ref $ \ st -> st { memory = [] } + + makeHOLContrapos :: (BasicConvs thry, TriviaCtxt thry) => Int -> HOLThm + -> HOL cls thry HOLThm + makeHOLContrapos n th = + let tm = concl th + key = (n, tm) in + do m <- liftM memory $ readHOLRef ref + case lookup key m of + Just res -> return res + Nothing -> if n < 0 then ruleCONV (convPull `_THEN` convImf) th + else let djs = disjuncts tm in + do acth <- if n == 0 then return th + else case chopList n djs of + Just (ldjs, rdj:rdjs) -> + let ndjs = rdj : (ldjs ++ rdjs) in + do th1 <- runConv convDISJ_AC =<< mkEq tm =<< listMkDisj ndjs + fromRightM $ primEQ_MP th1 th + _ -> fail "makeHOLContrapos" + fth <- if length djs == 1 then return acth + else ruleCONV (convImp `_THEN` convPush) acth + modifyHOLRef ref $ \ st -> st { memory = (key, fth) : m } + return fth + + resetVars :: HOL cls thry () + resetVars = modifyHOLRef ref $ \ st -> st { vstore = [], gstore = [], vcounter = 0 } + + resetConsts :: TriviaCtxt thry => HOL cls thry () + resetConsts = + do falseTm <- serve [trivia| F |] + modifyHOLRef ref $ \ st -> st { cstore = [(falseTm, 1)], ccounter = 2 } + + incVCounter :: HOL cls thry Int + incVCounter = + do n <- liftM vcounter $ readHOLRef ref + let m = n + 1 + if m >= mesonOffInc + then fail "incVCounter: too many variables" + else do modifyHOLRef ref $ \ st -> st { vcounter = m } + return n + + mesonToHOL :: (BasicConvs thry, TriviaCtxt thry) => [(FOLTerm, Int)] + -> FOLGoal -> HOL cls thry HOLThm + mesonToHOL insts (Subgoal g gs (n, th) _ locin) = + let newInsts = foldr mergeInst insts locin + g' = folInst newInsts g in + do holG <- holOfLiteral g' + ths <- mapM (mesonToHOL newInsts) gs + truthTh <- thmTRUTH + hth <- if th == truthTh then liftEither "mesonToHOL" $ primASSUME holG + else do cth <- makeHOLContrapos n th + if null ths + then return cth + else ruleMATCH_MP cth =<< foldr1M ruleCONJ ths + ith <- rulePART_MATCH Just hth holG + tm <- holNegate $ concl ith + finishRule =<< ruleDISCH tm ith + + folOfHOLClause :: HOLThm -> HOL cls thry [(([FOLAtom], FOLAtom), (Int, HOLThm))] + folOfHOLClause th = + let lconsts = catFrees $ hyp th + tm = concl th + hlits = disjuncts tm in + do flits <- mapM (folOfLiteral [] lconsts) hlits + let basics = mkContraposes 0 th [] flits [] + return $ if all (\ (p, _) -> p < 0) flits + then ((map mkNegated flits, (1, [])), (-1, th)):basics + else basics + + folOfHOLClauses :: [HOLThm] -> HOL cls thry [Rule] + folOfHOLClauses thms = + do rawrules <- foldrM (\ x ys -> do xs <- folOfHOLClause x + return $! union xs ys) [] thms + let prs = setify $ map (fst . snd . fst) rawrules + prules = map (\ t -> (t, filter ((== t) . fst . snd . fst) rawrules)) prs + srules = sort (\ (p, _) (q, _) -> abs p <= abs q) prules + return srules + + holOfTerm :: FOLTerm -> HOL cls thry HOLTerm + holOfTerm (FVar v) = holOfVar v + holOfTerm (FNApp f args) = + do f' <- holOfConst f + args' <- mapM holOfTerm args + liftEither "holOfTerm" $ listMkComb f' args' + + folOfTerm :: [HOLTerm] -> [HOLTerm] -> HOLTerm -> HOL cls thry FOLTerm + folOfTerm env consts tm = + if isVar tm && (tm `notElem` consts) + then liftM FVar $ folOfVar tm + else let (f, args) = stripComb tm in + if f `elem` env then fail "folOfTerm: higher order" + else do ff <- folOfConst f + args' <- mapM (folOfTerm env consts) args + return $! FNApp ff args' + + holOfAtom :: FOLAtom -> HOL cls thry HOLTerm + holOfAtom (p, args) = + do p' <- holOfConst p + args' <- mapM holOfTerm args + liftEither "holOfAtom" $ listMkComb p' args' + + folOfAtom :: [HOLTerm] -> [HOLTerm] -> HOLTerm -> HOL cls thry FOLAtom + folOfAtom env consts tm = + let (f, args) = stripComb tm in + if f `elem` env then fail "folOfAtom: higher order" + else do ff <- folOfConst f + args' <- mapM (folOfTerm env consts) args + return (ff, args') + + holOfLiteral :: FOLAtom -> HOL cls thry HOLTerm + holOfLiteral fa@(p, args) + | p < 0 = mkNeg =<< holOfAtom (negate p, args) + | otherwise = holOfAtom fa + + folOfLiteral :: [HOLTerm] -> [HOLTerm] -> HOLTerm -> HOL cls thry FOLAtom + folOfLiteral env consts tm = + case destNeg tm of + Nothing -> folOfAtom env consts tm + Just tm' -> do (p, a) <- folOfAtom env consts tm' + return (negate p, a) + + holOfConst :: Int -> HOL cls thry HOLTerm + holOfConst c = + do cs <- liftM cstore $ readHOLRef ref + case revLookup c cs of + Nothing -> fail "holOfConst" + Just x -> return x + + folOfConst :: HOLTerm -> HOL cls thry Int + folOfConst c = + do currentconsts <- liftM cstore $ readHOLRef ref + case lookup c currentconsts of + Nothing -> do n <- liftM ccounter $ readHOLRef ref + modifyHOLRef ref $ \ st -> st { ccounter = n + 1, cstore = (c, n):currentconsts } + return n + Just x -> return x + + holOfVar :: Int -> HOL cls thry HOLTerm + holOfVar v = holOfVar' v <|> + let v' = v `mod` mesonOffInc in + do hv' <- holOfVar' v' + gv <- genVar $ typeOf hv' + modifyHOLRef ref $ \ st -> st { gstore = (gv, v) : gstore st } + return gv + + holOfVar' :: Int -> HOL cls thry HOLTerm + holOfVar' v = + do vs <- liftM vstore $ readHOLRef ref + case revLookup v vs of + Just res -> return res + Nothing -> do gs <- liftM gstore $ readHOLRef ref + case revLookup v gs of + Just res -> return res + Nothing -> fail "holOfVar" + + folOfVar :: HOLTerm -> HOL cls thry Int + folOfVar v = + do currentvars <- liftM vstore $ readHOLRef ref + case lookup v currentvars of + Just x -> return x + Nothing -> do n <- incVCounter + modifyHOLRef ref $ \ st -> st { vstore = (v, n) : currentvars } + return n + +convQUANT_BOOL :: (BasicConvs thry, ClassicCtxt thry) => Conversion cls thry +convQUANT_BOOL = + convPURE_REWRITE [ thmFORALL_BOOL, thmEXISTS_BOOL, thmCOND_CLAUSES + , thmNOT_CLAUSES, thmIMP_CLAUSES, thmAND_CLAUSES + , thmOR_CLAUSES, thmEQ_CLAUSES, thmFORALL_SIMP + , thmEXISTS_SIMP ] + +tacSPLIT :: BoolCtxt thry => Int -> Tactic cls thry +tacSPLIT n = + (_FIRST_X_ASSUM (tacCONJUNCTS_THEN' tacASSUME) `_THEN` tacSPLIT n) `_ORELSE` + (if n > 0 then _FIRST_X_ASSUM tacDISJ_CASES `_THEN` tacSPLIT (n-1) + else _NO) `_ORELSE` + _ALL + +tacGEN_MESON :: (BasicConvs thry, TriviaCtxt thry, HOLThmRep thm cls thry) + => Int -> Int -> Int + -> [thm] -> Tactic cls thry +tacGEN_MESON minVal maxVal step ths = + liftM1 (tacGEN_MESON' minVal maxVal step) $ mapM toHThm ths + +tacGEN_MESON' :: (BasicConvs thry, TriviaCtxt thry) => Int -> Int -> Int + -> [HOLThm] -> Tactic cls thry +tacGEN_MESON' minVal maxVal step ths gl = + do pth <- thmDISJ_ASSOC + ref <- newHOLRef =<< initializeMeson + splitLimit <- mesonSplitLimit + ths' <- mapM ruleGEN_ALL ths + (tacREFUTE_THEN tacASSUME `_THEN` + tacPOLY_ASSUME ths' `_THEN` + (\ g@(Goal asl _) -> _MAP_EVERY (tacUNDISCH . concl . snd) asl g) `_THEN` + tacSELECT_ELIM `_THEN` + (\ g@(Goal _ w) -> _MAP_EVERY (\ v -> tacSPEC (v,v)) (frees w) g) `_THEN` + tacCONV (convPRESIMP `_THEN` + convTOP_DEPTH convBETA `_THEN` + convLAMBDA_ELIM `_THEN` + convCONDS_CELIM `_THEN` + convQUANT_BOOL) `_THEN` + _REPEAT (tacGEN `_ORELSE` tacDISCH) `_THEN` + tacREFUTE_THEN tacASSUME `_THEN` + tacRULE_ASSUM (ruleCONV (convNNF `_THEN` convSKOLEM)) `_THEN` + _REPEAT (_FIRST_X_ASSUM tacCHOOSE) `_THEN` + tacASM_FOL `_THEN` + tacSPLIT splitLimit `_THEN` + tacRULE_ASSUM (ruleCONV (convPRENEX `_THEN` convWEAK_CNF)) `_THEN` + tacRULE_ASSUM (repeatM (\ th -> case destForall $ concl th of + Just (x, _) -> + do tm <- genVar $ typeOf x + ruleSPEC tm th + Nothing -> fail "")) `_THEN` + _REPEAT (_FIRST_X_ASSUM (tacCONJUNCTS_THEN' tacASSUME)) `_THEN` + tacRULE_ASSUM (ruleCONV (convASSOC pth)) `_THEN` + _REPEAT (_FIRST_X_ASSUM tacSUBST_VAR) `_THEN` + tacPURE_MESON ref minVal maxVal step) gl + + +-- common meson tactics + +tacASM_MESON :: (BasicConvs thry, TriviaCtxt thry, HOLThmRep thm cls thry) + => [thm] -> Tactic cls thry +tacASM_MESON = tacGEN_MESON 0 50 1 + +tacASM_MESON_NIL :: (BasicConvs thry, TriviaCtxt thry) => Tactic cls thry +tacASM_MESON_NIL = tacGEN_MESON' 0 50 1 [] + +tacMESON :: (BasicConvs thry, TriviaCtxt thry, HOLThmRep thm cls thry) => [thm] + -> Tactic cls thry +tacMESON ths = _POP_ASSUM_LIST (const _ALL) `_THEN` tacASM_MESON ths + +tacMESON_NIL :: (BasicConvs thry, TriviaCtxt thry) => Tactic cls thry +tacMESON_NIL = _POP_ASSUM_LIST (const _ALL) `_THEN` tacASM_MESON_NIL + +ruleMESON :: (BasicConvs thry, TriviaCtxt thry, HOLThmRep thm cls thry, + HOLTermRep tm cls thry) => [thm] -> tm -> HOL cls thry HOLThm +ruleMESON ths tm = prove tm $ tacMESON ths + +ruleMESON_NIL :: (BasicConvs thry, TriviaCtxt thry, HOLTermRep tm cls thry) + => tm -> HOL cls thry HOLThm +ruleMESON_NIL tm = prove tm tacMESON_NIL diff --git a/src/HaskHOL/Lib/Misc.hs b/src/HaskHOL/Lib/Misc.hs new file mode 100644 index 0000000..e1d13dd --- /dev/null +++ b/src/HaskHOL/Lib/Misc.hs @@ -0,0 +1,26 @@ +{-| + Module: HaskHOL.Lib.Misc + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Misc where + +import HaskHOL.Core + +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Tactics +import HaskHOL.Lib.Simp + +tacASSUM_MATCH_ACCEPT :: BoolCtxt thry => Tactic cls thry +tacASSUM_MATCH_ACCEPT = _FIRST_ASSUM tacMATCH_ACCEPT + +tacASSUM_REWRITE :: (BasicConvs thry, BoolCtxt thry) + => (HOLThm -> HOL cls thry HOLThm) -> Tactic cls thry +tacASSUM_REWRITE rl = + _FIRST_X_ASSUM (\ thm gl -> + do th <- ruleREWRITE_NIL =<< rl thm + tacASSUME th gl) diff --git a/src/HaskHOL/Lib/Quot.hs b/src/HaskHOL/Lib/Quot.hs new file mode 100644 index 0000000..b923452 --- /dev/null +++ b/src/HaskHOL/Lib/Quot.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE FlexibleContexts, PatternSynonyms #-} +{-| + Module: HaskHOL.Lib.Quot + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Quot + ( defineQuotientType + , getQuotientType + , liftTheorem + , liftFunction + , getLiftedFunction + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Classic +import HaskHOL.Lib.DRule +import HaskHOL.Lib.Equal +import HaskHOL.Lib.Meson +import HaskHOL.Lib.Simp +import HaskHOL.Lib.Tactics +import HaskHOL.Lib.Theorems +import HaskHOL.Lib.Trivia +import HaskHOL.Lib.Trivia.Context + +data LiftedFunctions = + LiftedFunctions !(Map Text (HOLThm, HOLThm)) deriving Typeable + +deriveSafeCopy 0 'base ''LiftedFunctions + +addLiftedFunction :: Text -> (HOLThm, HOLThm) -> Update LiftedFunctions () +addLiftedFunction lbl ths = + do (LiftedFunctions m) <- get + put (LiftedFunctions (mapInsert lbl ths m)) + +getLiftedFunction' :: Text -> Query LiftedFunctions (Maybe (HOLThm, HOLThm)) +getLiftedFunction' name = + do (LiftedFunctions m) <- ask + return $! mapLookup name m + +makeAcidic ''LiftedFunctions ['addLiftedFunction, 'getLiftedFunction'] + +data QuotientTypes = + QuotientTypes !(Map Text (HOLThm, HOLThm)) deriving Typeable + +deriveSafeCopy 0 'base ''QuotientTypes + +addQuotientType :: Text -> (HOLThm, HOLThm) -> Update QuotientTypes () +addQuotientType lbl ths = + do (QuotientTypes m) <- get + put (QuotientTypes (mapInsert lbl ths m)) + +getQuotientType' :: Text -> Query QuotientTypes (Maybe (HOLThm, HOLThm)) +getQuotientType' name = + do (QuotientTypes m) <- ask + return $! mapLookup name m + +makeAcidic ''QuotientTypes ['addQuotientType, 'getQuotientType'] + +defineQuotientType :: (BoolCtxt thry, HOLTermRep tm Theory thry) => Text + -> Text -> Text -> tm + -> HOL Theory thry (HOLThm, HOLThm) +defineQuotientType tyname absname repname tm = + do acid <- openLocalStateHOL (QuotientTypes mapEmpty) + qth <- queryHOL acid (GetQuotientType' tyname) + closeAcidStateHOL acid + case qth of + Just th -> + return th + Nothing -> noteHOL "defineQuotientType" $ + do eqv <- toHTm tm + case typeOf eqv of + (TyApp _ (ty:_)) -> + do pty <- mkFunTy ty tyBool + let s = mkVar "s" pty + x = mkVar "x" ty + eqvx <- fromRightM $ mkComb eqv x + exx <- mkExists x =<< mkEq s eqvx + predtm <- fromRightM $ mkAbs s exx + th0 <- runConv convBETA =<< + fromRightM (mkComb predtm eqvx) + rtm <- fromJustM . rand $ concl th0 + th1 <- ruleEXISTS rtm x $ primREFL eqvx + th2 <- fromRightM $ ruleSYM th0 + th3 <- fromRightM $ primEQ_MP th2 th1 + (absth, repth) <- newBasicTypeDefinition tyname + absname repname th3 + th4 <- ruleCONV (convLAND convBETA) repth + acid' <- openLocalStateHOL (QuotientTypes mapEmpty) + updateHOL acid' (AddQuotientType tyname (absth, th4)) + createCheckpointAndCloseHOL acid' + return (absth, th4) + _ -> fail "provided term has bad type" + +getQuotientType :: Text -> HOL cls thry (HOLThm, HOLThm) +getQuotientType name = + do acid <- openLocalStateHOL (QuotientTypes mapEmpty) + qth <- queryHOL acid (GetQuotientType' name) + closeAcidStateHOL acid + liftMaybe "getQuotientType: type not found." qth + +thmSELECT_LEMMA :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +thmSELECT_LEMMA = cacheProof "thmSELECT_LEMMA" ctxtTrivia $ + prove [str| !x:A. (@y. x = y) = x |] $ + tacGEN `_THEN` + tacGEN_REWRITE (convLAND . convBINDER) [thmEQ_SYM_EQ] `_THEN` + tacMATCH_ACCEPT thmSELECT_REFL + +liftFunction :: (BasicConvs thry, TriviaCtxt thry, HOLThmRep thm1 Theory thry, + HOLThmRep thm2 Theory thry, HOLThmRep thm3 Theory thry, + HOLThmRep thm4 Theory thry) => thm1 -> thm2 -> thm3 -> Text + -> thm4 -> HOL Theory thry (HOLThm, HOLThm) +liftFunction ptybij2 prefl_th ptrans_th fname pwth = + do acid <- openLocalStateHOL (LiftedFunctions mapEmpty) + qth <- queryHOL acid (GetLiftedFunction' fname) + closeAcidStateHOL acid + case qth of + Just th -> + return th + Nothing -> noteHOL "liftFunction" $ + do tybij2 <- toHThm ptybij2 + refl_th <- toHThm prefl_th + trans_th <- toHThm ptrans_th + wth <- toHThm pwth + case concl tybij2 of + (Comb (Comb _ (Comb _ (Abs _ (Comb _ eqvx@(Comb eqv xtm))))) + tybr) -> + case destEq tybr of + Just (Comb dest mrt@(Comb mk _), rtm) -> + let ety = typeOf mrt in + do wtm <- fromJustM . repeatM + (liftM snd . destForall) $ concl wth + let wfvs = frees wtm + (hyps, con) = case destImp wtm of + Just (l, r) -> (conjuncts l, r) + Nothing -> ([], wtm) + (eqs, rels) = partition isEq hyps + rvs <- fromJustM $ mapM lHand rels + qvs <- fromJustM $ mapM lHand eqs + rvs' <- mapM (\ tm -> case tm of + (Var v _ ) -> + return $! mkVar v ety + _ -> fail "") rvs + let evs = variants wfvs rvs' + mems <- fromRightM $ map2M (\ rv ev -> flip mkComb rv =<< mkComb dest ev) rvs evs + (lcon, rcon) <- fromJustM $ destComb con + let uvar = mkVar "u" $ typeOf rcon + u = variant (evs ++ wfvs) uvar + ucon <- fromRightM $ mkComb lcon u + dbod <- listMkConj (ucon:mems) + detm <- listMkExists rvs dbod + datm <- fromRightM $ mkAbs u detm + def <- if isEq con then listMkIComb "@" [datm] + else fromRightM $ mkComb mk datm + newargs <- fromJustM $ mapM (\ e -> liftM fst (destEq e) + <|> (do le <- lHand e + lookup le $ zip rvs evs)) hyps + rdef <- fromRightM $ listMkAbs newargs def + let ldef = mkVar fname $ typeOf rdef + dth <- newDefinition fname =<< mkEq ldef rdef + eth <- foldlM (\ th v -> ruleCONV (convRAND convBETA) =<< + fromRightM (ruleAP_THM th v)) dth newargs + targs <- fromRightM $ mapM (mkComb mk <=< mkComb eqv) rvs + dme_th <- let th = fromJust $ primINST [(rtm, eqvx)] tybij2 in + do thTm <- fromJustM . lHand $ concl th + th2 <- ruleEXISTS thTm xtm $ primREFL eqvx + fromRightM $ primEQ_MP th th2 + let ith = fromJust $ primINST (zip evs targs) eth + rvs_ths = map (\ v -> fromJust $ primINST [(xtm, v)] dme_th) rvs + jth <- ruleSUBS rvs_ths ith + (apop, uxtm) <- fromJustM $ destComb =<< rand (concl jth) + extm <- fromJustM $ body uxtm + let (evs', bod) = stripExists extm + th1 <- fromRightM $ primASSUME bod + th2 <- if null evs' then return th1 + else do (th2a, th2b) <- ruleCONJ_PAIR th1 + as <- ruleCONJUNCTS th2b + let bs = map primREFL qvs + ethlist = as ++ bs + ethlist' <- fromJustM $ mapM (\ v -> find (\ th -> lHand v == lHand (concl th)) ethlist) hyps + th2c <- foldr1M ruleCONJ ethlist' + th2d <- ruleMATCH_MP wth th2c + th2e <- fromRightM (primTRANS th2d th2a) + <|> (ruleMATCH_MP trans_th =<< + ruleCONJ th2d th2a) + foldrM ruleSIMPLE_CHOOSE th2e evs' + th3 <- fromRightM . primASSUME $ concl th2 + ths <- mapM (`ruleSPEC` refl_th) rvs + th4 <- foldr1M ruleCONJ (th3:ths) + th5 <- fromRightM $ primASSUME bod + th6 <- foldrM ruleSIMPLE_EXISTS th5 evs' + th7 <- ruleDISCH_ALL th6 + th8 <- ruleMATCH_MP th7 th4 + th9 <- ruleDISCH_ALL th2 + th10 <- ruleIMP_ANTISYM th9 =<< ruleDISCH_ALL th8 + th11 <- fromRightM $ primTRANS jth =<< ruleAP_TERM apop =<< primABS u th10 + let fconv = if isEq con then Conv $ \ tm -> thmSELECT_LEMMA >>= \ th -> runConv (convREWR th) tm + else convRAND convETA + th12 <- ruleCONV (convRAND fconv) th11 + th13 <- ruleGSYM th12 + acid' <- openLocalStateHOL (LiftedFunctions mapEmpty) + updateHOL acid' (AddLiftedFunction fname (eth, th13)) + createCheckpointAndCloseHOL acid' + return (eth, th13) + _ -> fail "not an equation" + _ -> fail "term of improper form" + +getLiftedFunction :: Text -> HOL cls thry (HOLThm, HOLThm) +getLiftedFunction name = + do acid <- openLocalStateHOL (LiftedFunctions mapEmpty) + qth <- queryHOL acid (GetLiftedFunction' name) + closeAcidStateHOL acid + liftMaybe "getLiftedFunction: type not found." qth + + +liftTheorem :: (BasicConvs thry, TriviaCtxt thry, HOLThmRep thm1 cls thry, + HOLThmRep thm2 cls thry, HOLThmRep thm3 cls thry, + HOLThmRep thm4 cls thry, HOLThmRep thm5 cls thry, + HOLThmRep thm6 cls thry) => (thm1, thm1) -> thm2 -> thm3 -> thm4 + -> [thm5] -> thm6 -> HOL cls thry HOLThm +liftTheorem ptybij prefl_th psym_th ptrans_th ptrths pthm = + do (tybij1, tybij2) <- pairMapM ruleGEN_ALL ptybij + refl_th <- toHThm prefl_th + sym_th <- toHThm psym_th + trans_th <- toHThm ptrans_th + trths <- mapM toHThm ptrths + cth <- foldr1M ruleCONJ [refl_th, sym_th, trans_th, tybij1, tybij2] + ith <- ruleMATCH_MP liftTheorem_pth cth + ruleREWRITE (ith:trths) pthm + where liftTheorem_pth :: (BasicConvs thry, TriviaCtxt thry) + => HOL cls thry HOLThm + liftTheorem_pth = cacheProof "liftTheorem_pth" ctxtTrivia $ + prove [str| (!x:Repty. R x x) /\ + (!x y. R x y <=> R y x) /\ + (!x y z. R x y /\ R y z ==> R x z) /\ + (!a. mk(dest a) = a) /\ + (!r. (?x. r = R x) <=> (dest(mk r) = r)) + ==> (!x y. R x y <=> (mk(R x) = mk(R y))) /\ + (!P. (!x. P(mk(R x))) <=> (!x. P x)) /\ + (!P. (?x. P(mk(R x))) <=> (?x. P x)) /\ + (!x:Absty. mk(R((@)(dest x))) = x) |] $ + tacSTRIP `_THEN` + _SUBGOAL_THEN [str| !x y. (mk((R:Repty->Repty->bool) x):Absty = + mk(R y)) <=> (R x = R y) |] + tacASSUME `_THENL` + [ tacASM_MESON_NIL + , _ALL + ] `_THEN` + tacMATCH_MP (ruleTAUT [str| (a /\ b /\ c) /\ (b ==> a ==> d) ==> + a /\ b /\ c /\ d |]) `_THEN` + tacCONJ `_THENL` + [ tacASM_REWRITE_NIL `_THEN` tacREWRITE [thmFUN_EQ] `_THEN` + tacASM_MESON_NIL + , _ALL + ] `_THEN` + _REPEAT (_DISCH_THEN + (\ th g -> tacREWRITE [ruleGSYM th] g)) `_THEN` + tacX_GEN "x:Repty" `_THEN` + _SUBGOAL_THEN "dest(mk((R:Repty->Repty->bool) x):Absty) = R x" + tacSUBST1 `_THENL` + [ tacASM_MESON_NIL + , _ALL + ] `_THEN` + tacGEN_REWRITE (convLAND . convRAND) [ruleGSYM axETA] `_THEN` + _FIRST_ASSUM (\ th -> tacGEN_REWRITE id [th]) `_THEN` + tacCONV convSELECT `_THEN` + tacASM_MESON_NIL diff --git a/src/HaskHOL/Lib/Simp.hs b/src/HaskHOL/Lib/Simp.hs new file mode 100644 index 0000000..dc6c525 --- /dev/null +++ b/src/HaskHOL/Lib/Simp.hs @@ -0,0 +1,912 @@ +{-# LANGUAGE FlexibleInstances, PatternSynonyms, ScopedTypeVariables, + TypeSynonymInstances #-} +{-| + Module: HaskHOL.Lib.Simp + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Simp + ( GConversion + , convREWR + , convIMP_REWR + , convORDERED_REWR + , convORDERED_IMP_REWR + , termOrder + , netOfThm + , netOfConv + , netOfCong + , mkRewrites + , convREWRITES + , Prover + , mkProver + , augment + , applyProver + , Simpset + , Strategy + , basicProver + , ssOfThms + , ssOfConv + , ssOfCongs + , ssOfProver + , ssOfProvers + , ssOfMaker + , ruleAUGMENT_SIMPSET + , setBasicRewrites + , extendBasicRewrites + , basicRewrites + , BasicConvs(..) + , basicNet + , setBasicCongs + , extendBasicCongs + , basicCongs + , convGENERAL_REWRITE + , convGEN_REWRITE + , convPURE_REWRITE + , convREWRITE + , convREWRITE_NIL + , convPURE_ONCE_REWRITE + , convONCE_REWRITE + , ruleGEN_REWRITE + , rulePURE_REWRITE + , ruleREWRITE + , ruleREWRITE_NIL + , rulePURE_ONCE_REWRITE + , ruleONCE_REWRITE + , rulePURE_ASM_REWRITE + , ruleASM_REWRITE + , rulePURE_ONCE_ASM_REWRITE + , ruleONCE_ASM_REWRITE + , tacGEN_REWRITE + , tacPURE_REWRITE + , tacREWRITE + , tacREWRITE_NIL + , tacPURE_ONCE_REWRITE + , tacONCE_REWRITE + , tacPURE_ASM_REWRITE + , tacPURE_ASM_REWRITE_NIL + , tacASM_REWRITE + , tacASM_REWRITE_NIL + , tacPURE_ONCE_ASM_REWRITE + , tacONCE_ASM_REWRITE + , convGEN_SIMPLIFY + , convONCE_SIMPLIFY + , convSIMPLIFY + , emptySS + , basicSS + , convSIMP + , convPURE_SIMP + , convONCE_SIMP + , ruleSIMP + , rulePURE_SIMP + , ruleONCE_SIMP + , tacSIMP + , tacPURE_SIMP + , tacONCE_SIMP + , tacASM_SIMP + , tacPURE_ASM_SIMP + , tacONCE_ASM_SIMP + , tacABBREV + , tacEXPAND + , thmEQ_REFL + , thmIMP_CLAUSES + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Bool.Context +import HaskHOL.Lib.Equal +import HaskHOL.Lib.Itab +import HaskHOL.Lib.DRule +import HaskHOL.Lib.Tactics + +import System.IO.Unsafe (unsafePerformIO) +import Data.IORef + +class BasicConvs thry where + basicConvs :: thry -> [(Text, (Text, Conversion cls thry'))] + +instance BasicConvs BaseThry where + basicConvs _ = [] + +-- this approach leads to some nasty context stack sizes +{- +instance (BasicConvs a, BasicConvs b) => BasicConvs (ExtThry a b) where + basicConvs _ = + basicConvs (undefined :: a) ++ basicConvs (undefined :: b) +-} + +instance BasicConvs BoolType where + basicConvs _ = [] + +{-# NOINLINE conversionNet #-} +conversionNet :: HOLRef (Maybe (Net (GConversion cls thry))) +conversionNet = unsafePerformIO $ newIORef Nothing + +type GConversion cls thry = (Int, Conversion cls thry) + +-- primitive rewriting conversionals +convREWR :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm + -> Conversion cls thry +convREWR th = Conv $ \ tm -> + do th' <- toHThm th + rulePART_MATCH lhs th' tm + +convIMP_REWR :: BoolCtxt thry => HOLThm -> Conversion cls thry +convIMP_REWR th = Conv $ \ tm -> + rulePART_MATCH (lhs <=< liftM snd . destImp) th tm + +-- ordered rewriting conversionals +convORDERED_REWR :: (BoolCtxt thry, HOLThmRep thm cls thry) => + (HOLTerm -> HOLTerm -> HOL cls thry Bool) -> thm -> + Conversion cls thry +convORDERED_REWR ord th = Conv $ \ tm -> + let basic_conv = convREWR th in + do thm <- runConv basic_conv tm + case destEq $ concl thm of + Just (l, r) -> do cond <- ord l r + if cond + then return thm + else fail "convORDERED_REWR: wrong orientation" + _ -> fail "convORDERED_IMP_REWR" + +convORDERED_IMP_REWR :: BoolCtxt thry + => (HOLTerm -> HOLTerm -> HOL cls thry Bool) -> HOLThm + -> Conversion cls thry +convORDERED_IMP_REWR ord th = Conv $ \ tm -> + let basic_conv = convIMP_REWR th in + do thm <- runConv basic_conv tm + case destEq <=< rand $ concl thm of + Just (l, r) -> do cond <- ord l r + if cond + then return thm + else fail "convORDERED_IMP_REWR: wrong orientation" + _ -> fail "convORDERED_IMP_REWR" + +-- alpha conversion compatible term ordering +lexify :: (HOLTerm -> HOLTerm -> Bool) -> [HOLTerm] -> [HOLTerm] -> Bool +lexify _ [] _ = False +lexify _ _ [] = True +lexify ord (a:as) (b:bs) = + ord a b || (a == b && lexify ord as bs) + +dyn_order :: HOLTerm -> HOLTerm -> HOLTerm -> Bool +dyn_order top tm1 tm2 = + let (f1, args1) = stripComb tm1 + (f2, args2) = stripComb tm2 in + if f1 == f2 then lexify (dyn_order f1) args1 args2 + else (f2 /= top) && ((f1 == top) || (f1 > f2)) + +termOrder :: BoolCtxt thry => HOLTerm -> HOLTerm -> HOL cls thry Bool +termOrder tm1 tm2 = + do tm <- serve [bool| T |] + return $! dyn_order tm tm1 tm2 + +-- create a net for a theorem +netOfThm :: BoolCtxt thry => Bool -> HOLThm + -> Net (GConversion cls thry) + -> Maybe (Net (GConversion cls thry)) +netOfThm rep th net = + let tm = concl th + lconsts = catFrees $ hyp th + matchable x y = (termMatch lconsts x y >> return True) <|> return False in + case tm of + (l@(Abs x (Comb v@Var{} x')) := v') -> + if x' == x && v' == v && x /= v + then return $! netEnter lconsts + (l, (1, convBASEABS v th)) net + else Nothing + (l := r) -> + if rep && l `freeIn` r + then return $! + netEnter lconsts (l, (1, + Conv $ \ x -> do th' <- ruleEQT_INTRO th + runConv (convREWR th') x)) net + else do cond1 <- matchable l r + cond2 <- matchable r l + if rep && cond1 && cond2 + then return $! netEnter lconsts + (l, (1, convORDERED_REWR termOrder th)) net + else return $! netEnter lconsts + (l, (1, convREWR th)) net + (Comb (Comb _ t) (l := r)) -> + if rep && l `freeIn` r + then return $! netEnter lconsts + (l, (3, Conv $ \ x -> do th' <- ruleDISCH t =<< + ruleEQT_INTRO =<< + ruleUNDISCH th + runConv (convIMP_REWR th') x)) net + else do cond1 <- matchable l r + cond2 <- matchable r l + if rep && cond1 && cond2 + then return $! netEnter lconsts + (l, (3, convORDERED_IMP_REWR termOrder th)) net + else return $! netEnter lconsts + (l, (3, convIMP_REWR th)) net + _ -> Nothing + where convBASEABS :: HOLTerm -> HOLThm -> Conversion cls thry + convBASEABS v thm = Conv $ \ tm -> + case tm of + (Abs y (Comb t y')) -> + if y == y' && not (y `freeIn` t) + then do t' <- liftO $ termMatch [] v t + ruleINSTANTIATE t' thm + else fail "convREWR (axETA special case)" + _ -> fail "convREWR (axETA special case)" + +-- create a net for a gconversion using "defunctionalized" conversions +-- safe conversion of phantom variables, as guarded by context +netOfConv :: Ord a => HOLTerm -> a -> Net (Int, a) -> (Net (Int, a)) +netOfConv tm conv net = + netEnter [] (tm, (2, conv)) net + +netOfCong :: BoolCtxt thry => HOLThm + -> Net (GConversion cls thry) + -> Maybe (Net (GConversion cls thry)) +netOfCong th sofar = + do (pat, n) <- do (conc, n) <- repeatM (\ (tm, m) -> + case destImp tm of + Just (_, x) -> Just (x, m+1) + _ -> Nothing) (concl th, 0) + if n == 0 + then Nothing + else do pat <- lHand conc + return (pat, n) + return $! netEnter [] (pat, (4, convBASE n th)) sofar + where convBASE :: BoolCtxt thry => Int -> HOLThm -> Conversion cls thry + convBASE n thm = Conv $ \ tm -> + ruleGEN_PART_MATCH (lHand <=< funpowM n rand) thm tm + +-- rewrite maker +convIMP_CONJ :: BoolCtxt thry => Conversion cls thry +convIMP_CONJ = convREWR convIMP_CONJ_pth + where convIMP_CONJ_pth :: BoolCtxt thry => HOL cls thry HOLThm + convIMP_CONJ_pth = cacheProof "convIMP_CONJ_pth" ctxtBool $ + ruleITAUT [str| p ==> q ==> r <=> p /\ q ==> r |] + +ruleIMP_EXISTS :: BoolCtxt thry => HOLTerm -> HOLThm -> HOL cls thry HOLThm +ruleIMP_EXISTS v th = + ruleCONV (convREWR ruleIMP_EXISTS_pth) =<< ruleGEN v th + where ruleIMP_EXISTS_pth :: BoolCtxt thry => HOL cls thry HOLThm + ruleIMP_EXISTS_pth = cacheProof "ruleIMP_EXISTS_pth" ctxtBool $ + ruleITAUT "(!x. P x ==> Q) <=> (?x . P x) ==> Q" + +collect_condition :: BoolCtxt thry => [HOLTerm] -> HOLThm -> HOL cls thry HOLThm +collect_condition oldhyps th = + let conds = hyp th \\ oldhyps in + if null conds then return th + else do jth <- foldrM ruleDISCH th conds + kth <- ruleCONV (_REPEAT convIMP_CONJ) jth + case destImp $ concl kth of + Just (cond, eqn) -> let fvs = (frees cond \\ frees eqn) \\ catFrees oldhyps in + foldrM ruleIMP_EXISTS kth fvs + _ -> fail "collect_condition" + +split_rewrites :: BoolCtxt thry => [HOLTerm] -> Bool -> HOLThm -> [HOLThm] + -> HOL cls thry [HOLThm] +split_rewrites oldhyps cf th sofar = + let tm = concl th in + if isForall tm + then do th' <- ruleSPEC_ALL th + split_rewrites oldhyps cf th' sofar + else if isConj tm + then do th1 <- ruleCONJUNCT1 th + th2 <- ruleCONJUNCT2 th + sofar' <- split_rewrites oldhyps cf th2 sofar + split_rewrites oldhyps cf th1 sofar' + else if isImp tm && cf + then do th' <- ruleUNDISCH th + split_rewrites oldhyps cf th' sofar + else if isEq tm + then if cf then do th' <- collect_condition oldhyps th + return $! th':sofar + else return $! th:sofar + else case destNeg tm of + Just tm' -> do th' <- ruleEQF_INTRO th + ths <- split_rewrites oldhyps cf th' sofar + if isEq tm' + then do th'' <- ruleEQF_INTRO =<< ruleGSYM th + split_rewrites oldhyps cf th'' ths + else return ths + _ -> do th' <- ruleEQT_INTRO th + split_rewrites oldhyps cf th' sofar + +mkRewrites :: (BoolCtxt thry, HOLThmRep thm cls thry) => Bool -> thm + -> [HOLThm] -> HOL cls thry [HOLThm] +mkRewrites cf pth ths = + do th <- toHThm pth + split_rewrites (hyp th) cf th ths + +convREWRITES :: BoolCtxt thry => Net (GConversion cls thry) + -> Conversion cls thry +convREWRITES net = Conv $ \ tm -> + let pconvs = netLookup tm net in + tryFind (\ (_, cnv) -> runConv cnv tm) pconvs + "convREWRITES" + +-- provers +-- provers +data Prover cls thry = + Prover (Conversion cls thry) ([HOLThm] -> Prover cls thry) + +mkProver :: forall cls thry. (HOLTerm -> Conversion cls thry) + -> (HOLTerm -> [HOLThm] -> HOLTerm) + -> HOLTerm -> Prover cls thry +mkProver applicator augmentor = mkProverRec + where mkProverRec :: HOLTerm -> Prover cls thry + mkProverRec state = + let app = applicator state + aug thms = mkProverRec $ augmentor state thms in + Prover app aug + +augment :: Prover cls thry -> [HOLThm] -> Prover cls thry +augment (Prover _ aug) = aug + +applyProver :: Prover cls thry -> HOLTerm -> HOL cls thry HOLThm +applyProver (Prover conv _ ) = runConv conv + +-- simpsets +data Simpset cls thry = Simpset (Net (GConversion cls thry)) + (Strategy cls thry -> Strategy cls thry) + [Prover cls thry] + (HOLThm -> [HOLThm] -> HOL cls thry [HOLThm]) + +type Strategy cls thry = Simpset cls thry -> Int -> Conversion cls thry + +-- basic prover - recursively simplify then try provers +basicProver :: BoolCtxt thry => Strategy cls thry -> Strategy cls thry +basicProver strat ss@(Simpset _ _ provers _) lev = Conv $ \ tm -> + do sth <- runConv (strat ss lev) tm <|> (return $! primREFL tm) + ruleEQT_ELIM sth <|> + (do tth <- tryFind (\ pr -> case rand $ concl sth of + Just stm -> applyProver pr stm + _ -> fail "") provers + fromRightM $ liftM1 primEQ_MP (ruleSYM sth) tth) + +ssOfThms :: BoolCtxt thry => [HOLThm] + -> Simpset cls thry + -> HOL cls thry (Simpset cls thry) +ssOfThms thms (Simpset net prover provers rewmaker) = + do cthms <- foldrM rewmaker [] thms + net' <- liftO $ foldrM (netOfThm True) net cthms + return $! Simpset net' prover provers rewmaker + +ssOfConv :: HOLTerm -> Conversion cls thry -> Simpset cls thry + -> Simpset cls thry +ssOfConv keytm conv (Simpset net prover provers rewmaker) = + Simpset (netOfConv keytm conv net) prover provers rewmaker + +ssOfCongs :: BoolCtxt thry => [HOLThm] + -> Simpset cls thry + -> Maybe (Simpset cls thry) +ssOfCongs thms (Simpset net prover provers rewmaker) = + do net' <- foldrM netOfCong net thms + return $! Simpset net' prover provers rewmaker + +ssOfProver :: (Strategy cls thry -> Strategy cls thry) -> Simpset cls thry + -> Simpset cls thry +ssOfProver newprover (Simpset net _ provers rewmaker) = + Simpset net newprover provers rewmaker + +ssOfProvers :: [Prover cls thry] -> Simpset cls thry -> Simpset cls thry +ssOfProvers newprovers (Simpset net prover provers rewmaker) = + Simpset net prover (newprovers ++ provers) rewmaker + +ssOfMaker :: (HOLThm -> [HOLThm] -> HOL cls thry [HOLThm]) -> Simpset cls thry + -> Simpset cls thry +ssOfMaker newmaker (Simpset net prover provers _) = + Simpset net prover provers newmaker + +ruleAUGMENT_SIMPSET :: BoolCtxt thry => HOLThmRep thm cls thry => thm + -> Simpset cls thry + -> HOL cls thry (Simpset cls thry) +ruleAUGMENT_SIMPSET pth (Simpset net prover provers rewmaker) = + do cth <- toHThm pth + let provers' = map (`augment` [cth]) provers + cthms <- rewmaker cth [] + net' <- liftO $ foldrM (netOfThm True) net cthms + return $ Simpset net' prover provers' rewmaker + +-- sqconvs +convIMP_REWRITES :: BoolCtxt thry => Strategy cls thry + -> Simpset cls thry + -> Int -> [GConversion cls thry] -> Conversion cls thry +convIMP_REWRITES strat ss@(Simpset _ prover _ _) lev pconvs = Conv $ \ tm -> + tryFind (\ (n, cnv) -> + if n >= 4 then fail "fail" + else do th <- runConv cnv tm + let etm = concl th + if isEq etm + then return th + else if lev <= 0 then fail "convIMP_REWRITES: too deep" + else case lHand etm of + Just etm' -> + do cth <- runConv (prover strat ss (lev-1)) etm' + ruleMP th cth + _ -> fail "") pconvs + +convGEN_SUB :: BoolCtxt thry => Strategy cls thry + -> Simpset cls thry -> Int + -> [GConversion cls thry] + -> Conversion cls thry +convGEN_SUB strat ss lev pconvs = Conv $ \ tm -> + tryFind (\ (n, cnv) -> if n < 4 then fail "fail" + else do th <- runConv cnv tm + cRUN_SUB_CONV strat ss lev True th) pconvs + <|> (case tm of + (Comb l r) -> (do th1 <- runConv (strat ss lev) l + (do th2 <- runConv (strat ss lev) r + fromRightM $ primMK_COMB th1 th2) + <|> fromRightM (ruleAP_THM th1 r)) + <|> (do rth <- runConv (strat ss lev) r + fromRightM $ ruleAP_TERM l rth) + (Abs v bod) -> (do th <- runConv (strat ss lev) bod + fromRightM $ primABS v th) + <|> (do gv <- genVar $ typeOf v + let gbod = fromJust $ varSubst [(gv, v)] bod + gbodth <- runConv (strat ss lev) gbod + gth <- fromRightM $ primABS gv gbodth + let gtm = concl gth + case destEq gtm of + Just (l, r) -> let v' = variant (frees gtm) v in + do (l', r') <- liftEither "convGEN_SUB: alpha" $ + pairMapM (alpha v') (l, r) + eq <- mkEq l' r' + th <- fromRightM $ ruleALPHA gtm eq + fromRightM $ primEQ_MP th gth + _ -> fail "convGEN_SUB") + _ -> fail "convGEN_SUB") + +cRUN_SUB_CONV :: BoolCtxt thry => Strategy cls thry + -> Simpset cls thry + -> Int -> Bool -> HOLThm -> HOL cls thry HOLThm +cRUN_SUB_CONV strat ss lev triv th = + let tm = concl th in + (case destImp tm of + Just (subtm, _) -> + let (avs, bod) = stripForall subtm in + do ((t, t'), ss', mk_fun) <- fromJustM (do ts <- destEq bod + return (ts, ss, return)) + <|> (do (c, deq) <- fromJustM $ destImp bod + cTh <- fromRightM $ primASSUME c + ssth' <- ruleAUGMENT_SIMPSET cTh ss + x <- fromJustM $ destEq deq + return (x, ssth', ruleDISCH c)) + (eth, triv') <- (do x <- runConv (strat ss' lev) t + return (x, False)) + <|> return (primREFL t, triv) + eth' <- ruleGENL avs =<< mk_fun eth + th' <- case t' of + Var{} -> do t'' <- fromJustM . rand $ concl eth + liftO $! primINST [(t', t'')] th + _ -> ruleGEN_PART_MATCH lHand th (concl eth') + th'' <- ruleMP th' eth' + cRUN_SUB_CONV strat ss lev triv' th'' + _ -> if triv then fail "" + else return th) + "cRUN_SUB_CONV" + +sqconvTOP_DEPTH :: BoolCtxt thry + => Strategy cls thry +sqconvTOP_DEPTH ss@(Simpset net _ _ _) lev = Conv $ \ tm -> + let pconvs = netLookup tm net in + do th1 <- runConv (convIMP_REWRITES sqconvTOP_DEPTH ss lev pconvs) tm + <|> runConv (convGEN_SUB sqconvTOP_DEPTH ss lev pconvs) tm + case rand $ concl th1 of + Just t -> (do th2 <- runConv (sqconvTOP_DEPTH ss lev) t + fromRightM $ primTRANS th1 th2) <|> return th1 + _ -> return th1 + +sqconvONCE_DEPTH :: BoolCtxt thry => Strategy cls thry +sqconvONCE_DEPTH ss@(Simpset net _ _ _) lev = Conv $ \ tm -> + let pconvs = netLookup tm net in + runConv (convIMP_REWRITES sqconvONCE_DEPTH ss lev pconvs) tm <|> + runConv (convGEN_SUB sqconvONCE_DEPTH ss lev pconvs) tm + +-- keeping track of rewrites and gconversional nets +data Rewrites = Rewrites ![HOLThm] deriving Typeable + +deriveSafeCopy 0 'base ''Rewrites + +putRewrites :: [HOLThm] -> Update Rewrites () +putRewrites ths = + put (Rewrites ths) + +addRewrites :: [HOLThm] -> Update Rewrites () +addRewrites ths = + do (Rewrites xs) <- get + put (Rewrites (ths++xs)) + +getRewrites :: Query Rewrites [HOLThm] +getRewrites = + do (Rewrites ths) <- ask + return ths + +makeAcidic ''Rewrites ['putRewrites, 'addRewrites, 'getRewrites] + + +setBasicRewrites :: (BasicConvs thry, BoolCtxt thry) + => [HOLThm] -> HOL Theory thry () +setBasicRewrites thl = + do canonThl <- foldrM (mkRewrites False) [] thl + acid <- openLocalStateHOL (Rewrites []) + updateHOL acid (PutRewrites canonThl) + createCheckpointAndCloseHOL acid + rehashConvnet + +extendBasicRewrites :: (BasicConvs thry, BoolCtxt thry) => [HOLThm] + -> HOL Theory thry () +extendBasicRewrites thl = + do canonThl <- foldrM (mkRewrites False) [] thl + acid <- openLocalStateHOL (Rewrites []) + updateHOL acid (AddRewrites canonThl) + createCheckpointAndCloseHOL acid + rehashConvnet + +basicRewrites :: HOL cls thry [HOLThm] +basicRewrites = + do acid <- openLocalStateHOL (Rewrites []) + ths <- queryHOL acid GetRewrites + closeAcidStateHOL acid + return ths + +basicNet :: (BasicConvs thry, BoolCtxt thry) + => HOL cls thry (Net (GConversion cls thry)) +basicNet = + do net <- readHOLRef conversionNet + case net of + Just net' -> return net' + Nothing -> do rehashConvnet + basicNet + +rehashConvnet :: forall cls thry. (BasicConvs thry, BoolCtxt thry) + => HOL cls thry () +rehashConvnet = + do rewrites <- basicRewrites + let cnvs :: [(Text, (Text, Conversion cls thry))] + cnvs = basicConvs (undefined :: thry) + cnvs' <- mapM (\ (_, (y, z)) -> do tm <- toHTm y + return (tm, z)) cnvs + let convs = foldr (uncurry netOfConv) netEmpty cnvs' + net <- liftO $ foldrM (netOfThm True) convs rewrites + writeHOLRef conversionNet (Just net) + + +-- default congruences +data Congruences = Congruences ![HOLThm] deriving Typeable + +deriveSafeCopy 0 'base ''Congruences + +putCongruences :: [HOLThm] -> Update Congruences () +putCongruences ths = + put (Congruences ths) + +addCongruences :: [HOLThm] -> Update Congruences () +addCongruences ths = + do (Congruences xs) <- get + put (Congruences (ths `union` xs)) + +getCongruences :: Query Congruences [HOLThm] +getCongruences = + do (Congruences xs) <- ask + return xs + +makeAcidic ''Congruences ['putCongruences, 'addCongruences, 'getCongruences] + + +setBasicCongs :: [HOLThm] -> HOL Theory thry () +setBasicCongs thl = + do acid <- openLocalStateHOL (Congruences []) + updateHOL acid (PutCongruences thl) + createCheckpointAndCloseHOL acid + +extendBasicCongs :: [HOLThm] -> HOL Theory thry () +extendBasicCongs thl = + do acid <- openLocalStateHOL (Congruences []) + updateHOL acid (AddCongruences thl) + createCheckpointAndCloseHOL acid + +basicCongs :: HOL cls thry [HOLThm] +basicCongs = + do acid <- openLocalStateHOL (Congruences []) + congs <- queryHOL acid GetCongruences + closeAcidStateHOL acid + return congs + +-- main rewriting conversions +convGENERAL_REWRITE :: (BoolCtxt thry, HOLThmRep thm cls thry) => Bool + -> (Conversion cls thry -> Conversion cls thry) + -> Net (GConversion cls thry) -> [thm] + -> Conversion cls thry +convGENERAL_REWRITE f c n pths = Conv $ \ tm -> + do pths' <- mapM toHThm pths + runConv (convGENERAL_REWRITE' f c n pths') tm + +convGENERAL_REWRITE' :: BoolCtxt thry => Bool + -> (Conversion cls thry -> Conversion cls thry) + -> Net (GConversion cls thry) -> [HOLThm] + -> Conversion cls thry +convGENERAL_REWRITE' rep cnvl builtin_net ths = Conv $ \ tm -> + do ths_canon <- foldrM (mkRewrites False) [] ths + final_net <- liftO $ foldrM (netOfThm rep) builtin_net ths_canon + runConv (cnvl (convREWRITES final_net)) tm + +convGEN_REWRITE :: (BoolCtxt thry, HOLThmRep thm cls thry) + => (Conversion cls thry -> Conversion cls thry) -> [thm] + -> Conversion cls thry +convGEN_REWRITE cnvl = convGENERAL_REWRITE False cnvl netEmpty + +convPURE_REWRITE :: (BoolCtxt thry, HOLThmRep thm cls thry) => [thm] + -> Conversion cls thry +convPURE_REWRITE = convGENERAL_REWRITE True convTOP_DEPTH netEmpty + +convREWRITE :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) => [thm] + -> Conversion cls thry +convREWRITE thl = Conv $ \ tm -> + do net <- basicNet + runConv (convGENERAL_REWRITE True convTOP_DEPTH net thl) tm + +convREWRITE_NIL :: (BasicConvs thry, BoolCtxt thry) => Conversion cls thry +convREWRITE_NIL = Conv $ \ tm -> + do net <- basicNet + runConv (convGENERAL_REWRITE' True convTOP_DEPTH net []) tm + +convPURE_ONCE_REWRITE :: (BoolCtxt thry, HOLThmRep thm cls thry) => [thm] + -> Conversion cls thry +convPURE_ONCE_REWRITE = + convGENERAL_REWRITE False convONCE_DEPTH netEmpty + +convONCE_REWRITE :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) + => [thm] -> Conversion cls thry +convONCE_REWRITE thl = Conv $ \ tm -> + do net <- basicNet + runConv (convGENERAL_REWRITE False convONCE_DEPTH net thl) tm + +-- rewriting rules and tactics +ruleGEN_REWRITE :: (BoolCtxt thry, HOLThmRep thm cls thry) + => (Conversion cls thry -> Conversion cls thry) -> [thm] + -> HOLThm -> HOL cls thry HOLThm +ruleGEN_REWRITE cnvl thl = ruleCONV (convGEN_REWRITE cnvl thl) + +rulePURE_REWRITE :: (BoolCtxt thry, HOLThmRep thm cls thry, + HOLThmRep thm2 cls thry) => [thm] -> thm2 + -> HOL cls thry HOLThm +rulePURE_REWRITE thl = ruleCONV (convPURE_REWRITE thl) + +ruleREWRITE :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm1 cls thry, + HOLThmRep thm2 cls thry) => [thm1] -> thm2 + -> HOL cls thry HOLThm +ruleREWRITE thl = ruleCONV (convREWRITE thl) + +ruleREWRITE_NIL :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) + => thm -> HOL cls thry HOLThm +ruleREWRITE_NIL = ruleCONV convREWRITE_NIL + +rulePURE_ONCE_REWRITE :: (BoolCtxt thry, HOLThmRep thm cls thry) => [thm] + -> HOLThm -> HOL cls thry HOLThm +rulePURE_ONCE_REWRITE thl = ruleCONV (convPURE_ONCE_REWRITE thl) + +ruleONCE_REWRITE :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm1 cls thry, + HOLThmRep thm2 cls thry) => [thm1] -> thm2 + -> HOL cls thry HOLThm +ruleONCE_REWRITE thl = ruleCONV (convONCE_REWRITE thl) + +rulePURE_ASM_REWRITE :: (BoolCtxt thry, HOLThmRep thm1 cls thry, + HOLThmRep thm2 cls thry) => [thm1] -> thm2 + -> HOL cls thry HOLThm +rulePURE_ASM_REWRITE pthl pth = + do th <- toHThm pth + thl <- mapM toHThm pthl + rulePURE_REWRITE (map (fromRight . primASSUME) (hyp th) ++ thl) th + +ruleASM_REWRITE :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm1 cls thry, + HOLThmRep thm2 cls thry) => [thm1] -> thm2 + -> HOL cls thry HOLThm +ruleASM_REWRITE pthl pth = + do th <- toHThm pth + thl <- mapM toHThm pthl + ruleREWRITE (map (fromRight . primASSUME) (hyp th) ++ thl) th + +rulePURE_ONCE_ASM_REWRITE :: (BoolCtxt thry, HOLThmRep thm1 cls thry, + HOLThmRep thm2 cls thry) => [thm1] -> thm2 + -> HOL cls thry HOLThm +rulePURE_ONCE_ASM_REWRITE pthl pth = + do th <- toHThm pth + thl <- mapM toHThm pthl + rulePURE_ONCE_REWRITE (map (fromRight . primASSUME) (hyp th) ++ thl) th + +ruleONCE_ASM_REWRITE :: (BasicConvs thry, BoolCtxt thry, + HOLThmRep thm1 cls thry, + HOLThmRep thm2 cls thry) => [thm1] -> thm2 + -> HOL cls thry HOLThm +ruleONCE_ASM_REWRITE pthl pth = + do th <- toHThm pth + thl <- mapM toHThm pthl + ruleONCE_REWRITE (map (fromRight . primASSUME) (hyp th) ++ thl) th + +tacGEN_REWRITE :: (BoolCtxt thry, HOLThmRep thm cls thry) => + (Conversion cls thry -> Conversion cls thry) -> + [thm] -> Tactic cls thry +tacGEN_REWRITE cnvl thl = tacCONV (convGEN_REWRITE cnvl thl) + +tacPURE_REWRITE :: (BoolCtxt thry, HOLThmRep thm cls thry) => [thm] + -> Tactic cls thry +tacPURE_REWRITE thl = tacCONV (convPURE_REWRITE thl) + +tacREWRITE' :: (BasicConvs thry, BoolCtxt thry) => [HOLThm] -> Tactic cls thry +tacREWRITE' thl = tacCONV (convREWRITE thl) + +tacREWRITE_NIL :: (BasicConvs thry, BoolCtxt thry) => Tactic cls thry +tacREWRITE_NIL = tacREWRITE' [] + +tacREWRITE :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) => + [thm] -> Tactic cls thry +tacREWRITE pthl = liftM1 tacREWRITE' (mapM toHThm pthl) + +tacPURE_ONCE_REWRITE :: (BoolCtxt thry, HOLThmRep thm cls thry) => [thm] + -> Tactic cls thry +tacPURE_ONCE_REWRITE thl = tacCONV (convPURE_ONCE_REWRITE thl) + +tacONCE_REWRITE' :: (BasicConvs thry, BoolCtxt thry) => [HOLThm] + -> Tactic cls thry +tacONCE_REWRITE' thl = tacCONV (convONCE_REWRITE thl) + +tacONCE_REWRITE :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) => + [thm] -> Tactic cls thry +tacONCE_REWRITE pthl = liftM1 tacONCE_REWRITE' (mapM toHThm pthl) + +tacPURE_ASM_REWRITE :: (BoolCtxt thry, HOLThmRep thm cls thry) => + [thm] -> Tactic cls thry +tacPURE_ASM_REWRITE = tacASM tacPURE_REWRITE + +tacPURE_ASM_REWRITE_NIL :: BoolCtxt thry => Tactic cls thry +tacPURE_ASM_REWRITE_NIL = tacASM tacPURE_REWRITE ([]::[HOLThm]) + +tacASM_REWRITE' :: (BasicConvs thry, BoolCtxt thry) => [HOLThm] + -> Tactic cls thry +tacASM_REWRITE' = tacASM tacREWRITE + +tacASM_REWRITE_NIL :: (BasicConvs thry, BoolCtxt thry) => Tactic cls thry +tacASM_REWRITE_NIL = tacASM_REWRITE' [] + +tacASM_REWRITE :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) + => [thm] -> Tactic cls thry +tacASM_REWRITE pthl = liftM1 tacASM_REWRITE' (mapM toHThm pthl) + +tacPURE_ONCE_ASM_REWRITE :: BoolCtxt thry => [HOLThm] -> Tactic cls thry +tacPURE_ONCE_ASM_REWRITE = tacASM tacPURE_ONCE_REWRITE + +tacONCE_ASM_REWRITE :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) + => [thm] -> Tactic cls thry +tacONCE_ASM_REWRITE = tacASM tacONCE_REWRITE + +-- simplification stuff + +convGEN_SIMPLIFY :: BoolCtxt thry => HOLThmRep thm cls thry => Strategy cls thry + -> Simpset cls thry -> Int -> [thm] + -> Conversion cls thry +convGEN_SIMPLIFY strat ss lev thl = Conv $ \ tm -> + do ss' <- foldrM ruleAUGMENT_SIMPSET ss thl + runConv (_TRY (strat ss' lev)) tm + +convONCE_SIMPLIFY :: (BoolCtxt thry, HOLThmRep thm cls thry) + => Simpset cls thry + -> [thm] -> Conversion cls thry +convONCE_SIMPLIFY ss = convGEN_SIMPLIFY sqconvONCE_DEPTH ss 1 + +convSIMPLIFY :: (BoolCtxt thry, HOLThmRep thm cls thry) => Simpset cls thry + -> [thm] -> Conversion cls thry +convSIMPLIFY ss = convGEN_SIMPLIFY sqconvTOP_DEPTH ss 3 + +emptySS :: BoolCtxt thry => Simpset cls thry +emptySS = Simpset netEmpty basicProver [] $ mkRewrites True + +basicSS :: (BasicConvs thry, BoolCtxt thry) => [HOLThm] + -> HOL cls thry (Simpset cls thry) +basicSS thl = + let rewmaker = mkRewrites True in + do cthms <- foldrM rewmaker [] thl + b_net <- basicNet + net' <- liftO $ foldrM (netOfThm True) b_net cthms + congs <- basicCongs + net'' <- liftO $ foldrM netOfCong net' congs + return $ Simpset net'' basicProver [] rewmaker + +convSIMP :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) => [thm] + -> Conversion cls thry +convSIMP thl = Conv $ \ tm -> + do ss <- basicSS [] + runConv (convSIMPLIFY ss thl) tm + +convPURE_SIMP :: (BoolCtxt thry, HOLThmRep thm cls thry) => [thm] + -> Conversion cls thry +convPURE_SIMP = convSIMPLIFY emptySS + +convONCE_SIMP :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) + => [thm] -> Conversion cls thry +convONCE_SIMP thl = Conv $ \ tm -> + do ss <- basicSS [] + runConv (convONCE_SIMPLIFY ss thl) tm + +ruleSIMP :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) => [thm] + -> HOLThm -> HOL cls thry HOLThm +ruleSIMP thl = ruleCONV (convSIMP thl) + +rulePURE_SIMP :: (BoolCtxt thry, HOLThmRep thm cls thry) => [thm] + -> HOLThm -> HOL cls thry HOLThm +rulePURE_SIMP thl = ruleCONV (convPURE_SIMP thl) + +ruleONCE_SIMP :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) + => [thm] -> HOLThm -> HOL cls thry HOLThm +ruleONCE_SIMP thl = ruleCONV (convONCE_SIMP thl) + +tacSIMP :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) => [thm] + -> Tactic cls thry +tacSIMP thl = tacCONV (convSIMP thl) + +tacPURE_SIMP :: (BoolCtxt thry, HOLThmRep thm cls thry) => [thm] + -> Tactic cls thry +tacPURE_SIMP thl = tacCONV (convPURE_SIMP thl) + +tacONCE_SIMP :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) + => [thm] -> Tactic cls thry +tacONCE_SIMP thl = tacCONV (convONCE_SIMP thl) + +tacASM_SIMP :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) => [thm] + -> Tactic cls thry +tacASM_SIMP = tacASM tacSIMP + +tacPURE_ASM_SIMP :: (BoolCtxt thry, HOLThmRep thm cls thry) => [thm] + -> Tactic cls thry +tacPURE_ASM_SIMP = tacASM tacPURE_SIMP + +tacONCE_ASM_SIMP :: (BasicConvs thry, BoolCtxt thry, HOLThmRep thm cls thry) + => [thm] -> Tactic cls thry +tacONCE_ASM_SIMP = tacASM tacONCE_SIMP + +tacABBREV :: (BoolCtxt thry, HOLTermRep tm cls thry) => tm -> Tactic cls thry +tacABBREV ptm gl@(Goal asl w) = + do tm <- toHTm ptm + let (cvs, t) = fromJust $ destEq tm + (v, vs) = stripComb cvs + rs = fromRight $ listMkAbs vs t + eq <- mkEq rs v + th1 <- foldrM (\ v' th -> ruleCONV (convLAND convBETA) #<< + ruleAP_THM th v') + (fromRight $ primASSUME eq) $ reverse vs + th2 <- ruleSIMPLE_CHOOSE v =<< ruleSIMPLE_EXISTS v =<< ruleGENL vs th1 + tm' <- mkExists v eq + th3 <- ruleEXISTS tm' rs (primREFL rs) + let th4 = rulePROVE_HYP th3 th2 + avoids = foldr (union . frees . concl . snd) (frees w) asl + if v `elem` avoids + then fail "tacABBREVL variable already used." + else _CHOOSE_THEN + (\ th -> tacRULE_ASSUM (rulePURE_ONCE_REWRITE [th]) `_THEN` + tacPURE_ONCE_REWRITE [th] `_THEN` + tacASSUME th) th4 gl + +tacEXPAND :: BoolCtxt thry => Text -> Tactic cls thry +tacEXPAND s = + _FIRST_ASSUM (\ th -> do (s', _) <- liftO $ destVar =<< rhs (concl th) + if s' == s + then tacSUBST1 #<< ruleSYM th + else fail "tacEXPAND") `_THEN` + tacBETA + +-- Equality Proofs From Thereoms here for staging purposes +thmEQ_REFL :: BoolCtxt thry => HOL cls thry HOLThm +thmEQ_REFL = cacheProof "thmEQ_REFL" ctxtBool $ + prove "!x:A. x = x" $ tacGEN `_THEN` tacREFL + +thmIMP_CLAUSES :: BoolCtxt thry => HOL cls thry HOLThm +thmIMP_CLAUSES = cacheProof "thmIMP_CLAUSES" ctxtBool $ + prove [str| !t. (T ==> t <=> t) /\ + (t ==> T <=> T) /\ + (F ==> t <=> T) /\ + (t ==> t <=> T) /\ + (t ==> F <=> ~t) |] tacITAUT diff --git a/src/HaskHOL/Lib/Tactics.hs b/src/HaskHOL/Lib/Tactics.hs new file mode 100644 index 0000000..ff1d7f6 --- /dev/null +++ b/src/HaskHOL/Lib/Tactics.hs @@ -0,0 +1,939 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternSynonyms, + TypeSynonymInstances, UndecidableInstances #-} +{-| + Module: HaskHOL.Lib.Tactics + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Tactics + ( Goal(..) + , Tactic + , ThmTactic + , ThmTactical + , nullInst + , nullMeta + , def_FALSITY_ + , tacVALID + , _MAP_EVERY + , tacREPLICATE + , tacSUBST_VAR + , tacRULE_ASSUM + -- tactic combinators + , _THENL + , tacLABEL -- assumption list manipulations + , tacASSUME + , tacASM + , _POP_ASSUM + , _ASSUM_LIST + , _POP_ASSUM_LIST + , _EVERY_ASSUM + , _FIRST_ASSUM + , tacACCEPT + , tacCONV + , tacREFL -- equality tactics + , tacABS + , tacMK_COMB + , tacAP_TERM + , tacAP_THM + , tacBINOP + , tacSUBST1 + , tacSUBST_ALL + , tacBETA + , tacDISCH -- basic logical tactics + , tacMP + , tacEQ + , tacUNDISCH + , tacSPEC + , tacX_GEN + , tacGEN + , tacEXISTS + , tacX_CHOOSE + , tacCHOOSE + , tacCONJ + , tacDISJ1 + , tacDISJ2 + , tacDISJ_CASES + , tacCONTR + , tacMATCH_ACCEPT + , tacMATCH_MP + , _CONJUNCTS_THEN2 -- theorem continuations + , _CONJUNCTS_THEN + , _DISJ_CASES_THEN2 + , _DISJ_CASES_THEN + , _DISCH_THEN + , _X_CHOOSE_THEN + , _CHOOSE_THEN + , tacSTRIP_ASSUME -- derived tactics + , _STRIP_THM_THEN + , _ANTE_RES_THEN + , tacSTRUCT_CASES + , tacSTRIP + , _STRIP_GOAL_THEN + , _UNDISCH_THEN + , _FIRST_X_ASSUM + , _SUBGOAL_THEN + , tacX_META_EXISTS + , tacMETA_SPEC + , ruleTAC_PROOF + , prove + , mkGoalstate + , GoalState(..) + , ppGoal + , ppGoalState + , Refinement + , Justification + , by + , composeInsts + ) where + +import HaskHOL.Core hiding (empty) + +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Bool.Context +import HaskHOL.Lib.Equal +import HaskHOL.Lib.DRule + +import Text.PrettyPrint + +-- Types + +type Justification cls thry = Instantiation -> [HOLThm] -> HOL cls thry HOLThm +type JustificationList cls thry = + Instantiation -> [HOLThm] -> HOL cls thry [HOLThm] + +data Goal = Goal [(Text, HOLThm)] HOLTerm deriving Eq + +instance ShowHOL Goal where + showHOL g = do ctxt <- prepHOLContext + return $! ppGoal ctxt g + +ppGoal :: HOLContext thry -> Goal -> String +ppGoal ctxt (Goal asl w) = + let asl' = if null asl then empty + else ppASL ctxt 0 (reverse asl) in + render $ asl' $+$ text "-----" $+$ text (ppTerm ctxt w) + +ppASL :: HOLContext thry -> Int -> [(Text, HOLThm)] -> Doc +ppASL ctxt = ppASLrec + where ppASLrec :: Int -> [(Text, HOLThm)] -> Doc + ppASLrec _ [] = empty + ppASLrec n ((s, th):rest) = + let s' = if textNull s then empty + else lparen <> text (unpack s) <> rparen in + int n <+> text (ppTerm ctxt $ concl th) <> s' $+$ + ppASLrec (n+1) rest + +-- metavariables, instantiation, goal list, and justification +data GoalState cls thry = + GS ([HOLTerm], Instantiation) [Goal] (Justification cls thry) + +{- +instance ShowHOL [GoalState cls thry] where + showHOL [] = return "Empty goalstack" + showHOL (gs:[]) = + ppGoalState 1 gs + showHOL (gs@(GS _ g _):GS _ g0 _:_) = + let p = length g - length g0 + p' = if p < 1 then 1 else p + 1 in + ppGoalState p' gs +-} + +ppGoalState :: HOLContext thry -> Int -> GoalState cls thry -> String +ppGoalState _ _ (GS _ [] _) = "No subgoals" +ppGoalState ctxt x (GS _ gls _) = + let n = length gls in + render + (int x <+> text "subgoal(s)" <+> parens (int n <+> text "total") $+$ + (vcat . map (text . ppGoal ctxt) $ take x gls)) + +type Refinement cls thry = GoalState cls thry -> HOL cls thry (GoalState cls thry) + +type Tactic cls thry = Goal -> HOL cls thry (GoalState cls thry) +type ThmTactic cls thry = HOLThm -> Tactic cls thry +type ThmTactical cls thry = ThmTactic cls thry -> ThmTactic cls thry + +{-# INLINE nullInst #-} +nullInst :: Instantiation +nullInst = ([], [], ([], [], [])) + +{-# INLINE nullMeta #-} +nullMeta :: ([HOLTerm], Instantiation) +nullMeta = ([], nullInst) + +-- instantiation functions +-- apply instantiation to a goal +inst_goal :: BoolCtxt thry => Instantiation -> Goal -> HOL cls thry Goal +inst_goal p (Goal thms w) = + do thms' <- mapM (return `ffCombM` ruleINSTANTIATE_ALL p) thms + return . Goal thms' $ instantiate p w + +-- compose instantiations +composeInsts :: Instantiation -> Instantiation -> HOL cls thry Instantiation +composeInsts (pats1, tmenv1, (tys1, tyops, opops)) + i2@(pats2, tmenv2, tyenv2@(tys2, tyops2, opops2)) = + let tmenv = map (instFull tyenv2 `ffComb` instantiate i2) tmenv1 + tys = map (typeSubstFull tyenv2 `ffComb` id) tys1 + tmenv' = filter (\ (x, _) -> isNothing $ lookup x tmenv) tmenv2 + tys' = filter (\ (a, _) -> isNothing $ lookup a tys) tys2 + tyops' = filter (\ (a, _) -> isNothing $ lookup a tyops) tyops2 + opops' = filter (\ (a, _) -> isNothing $ lookup a opops) opops2 in + return (pats1++pats2, tmenv++tmenv', + (tys++tys', tyops++tyops', opops++opops')) + +-- falsity +mk_fthm :: BoolCtxt thry => [HOLTerm] -> HOLTerm -> HOL cls thry HOLThm +mk_fthm asl c = + do pth <- mk_fthm_pth + qth <- mk_fthm_qth + th <- ruleCONTR c pth + aths <- foldrM ruleADD_ASSUM th $ reverse asl + return $ rulePROVE_HYP qth aths + where mk_fthm_pth :: BoolCtxt thry => HOL cls thry HOLThm + mk_fthm_pth = cacheProof "mk_fthm_pth" ctxtBool $ + do (pth', _) <- ruleEQ_IMP def_FALSITY_ + ruleUNDISCH pth' + + mk_fthm_qth :: BoolCtxt thry => HOL cls thry HOLThm + mk_fthm_qth = cacheProof "mk_fthm_qth" ctxtBool $ + do falsity <- toHTm "_FALSITY_" + liftO $ primASSUME falsity + + +-- validity of tactics. +fake_thm :: BoolCtxt thry => Goal -> HOL cls thry HOLThm +fake_thm (Goal asl w) = let asms = foldr (union . hyp . snd) [] asl in + mk_fthm asms w + +tacVALID :: BoolCtxt thry => Tactic cls thry -> Tactic cls thry +tacVALID tac g = + do ftm <- serve [bool| _FALSITY_ |] + res@(GS (_, i) gls just) <- tac g + ths <- mapM fake_thm gls + thm <- just nullInst ths + let (asl', w') = destThm thm + (Goal asl'' w'') <- inst_goal i g + let maxasms = foldr (\ (_, th) -> union (nub (concl th:hyp th))) [] asl'' + if aConv w' w'' && + all (\ t -> aConv t `any` maxasms) (asl' \\ [ftm]) + then return res + else fail "VALID: Invalid tactic" + + +-- convert tactic to refinement based on head subgoal +by :: BoolCtxt thry => Tactic cls thry -> Refinement cls thry +by _ (GS _ [] _) = fail "by: no goal set" +by tac (GS (mvs, i) (g:ogls) just) = + do (GS (newmvs, newinst) subgls subjust) <- tac g + let n = length subgls + mvs' = newmvs `union` mvs + i' <- composeInsts i newinst + ogls' <- mapM (inst_goal newinst) ogls + let gls' = subgls ++ ogls' + just' i2 ths = do i2' <- composeInsts i' i2 + case chopList n ths of + Just (cths, oths) -> + do cths' <- subjust i2 cths + let sths = cths':oths + just i2' sths + _ -> fail "byJust" + return (GS (mvs', i') gls' just') + +-- tactic language +propagate_empty :: JustificationList cls thry +propagate_empty _ [] = return [] +propagate_empty _ _ = fail "propagate_empty: improper justification" + +propagate_thm :: BoolCtxt thry => HOLThm -> Justification cls thry +propagate_thm th i [] = ruleINSTANTIATE_ALL i th +propagate_thm _ _ _ = fail "propagate_thm: improper justification" + +compose_justs :: Int -> Justification cls thry -> JustificationList cls thry -> + JustificationList cls thry +compose_justs n just1 just2 i ths = + case chopList n ths of + Just (ths1, ths2) -> do res1 <- just1 i ths1 + res2 <- just2 i ths2 + return (res1:res2) + Nothing -> fail "compose_justs" + +seqapply :: BoolCtxt thry => [Tactic cls thry] -> [Goal] -> + HOL cls thry (([HOLTerm], Instantiation), [Goal], JustificationList cls thry) +seqapply [] [] = return (nullMeta, [], propagate_empty) +seqapply (tac:tacs) (goal:goals) = + do (GS (mvs1, insts1) gls1 just1) <- tac goal + goals' <- mapM (inst_goal insts1) goals + ((mvs2, insts2), gls2, just2) <- seqapply tacs goals' + insts' <- composeInsts insts1 insts2 + let justs' = compose_justs (length gls1) just1 just2 + return ((mvs1 `union` mvs2, insts'), gls1++gls2, justs') +seqapply _ _ = fail "seqapply: length mismatch" + +justsequence :: Justification cls thry -> JustificationList cls thry -> + Instantiation -> Justification cls thry +justsequence just1 just2 insts2 i ths = + do insts' <- composeInsts insts2 i + ths' <- just2 i ths + just1 insts' ths' + +tacsequence :: BoolCtxt thry => GoalState cls thry -> [Tactic cls thry] -> + HOL cls thry (GoalState cls thry) +tacsequence (GS (mvs1, insts1) gls1 just1) tacl = + do ((mvs2, insts2), gls2, just2) <- seqapply tacl gls1 + let jst = justsequence just1 just2 insts2 + just = if null gls2 + then (\ i thl -> do th1 <- jst nullInst [] + propagate_thm th1 i thl) + else jst + insts' <- composeInsts insts1 insts2 + return $! GS (mvs1 `union` mvs2, insts') gls2 just + +-- tactic combinators +instance Lang (Tactic cls thry) where + _FAIL = tacFAIL + _NO = tacNO + _ORELSE = tacORELSE + _FIRST = tacFIRST + _CHANGED = tacCHANGED + _TRY = tacTRY + _ALL g = return (GS nullMeta [g] justification) + where justification _ [th] = return th + justification _ _ = fail "tacALL: improper justification" + +-- should be just tacTHEN but there's a weird linking bug with ghci right now +instance BoolCtxt thry => LangSeq (Tactic cls thry) where + tac1 `_THEN` tac2 = tacTHEN tac1 tac2 + _REPEAT = tacREPEAT + _EVERY = tacEVERY + + +tacTHEN :: BoolCtxt thry => Tactic cls thry -> Tactic cls thry -> Tactic cls thry +tacTHEN tac1 tac2 g = + do gstate@(GS _ gls _) <- tac1 g + let tacs = replicate (length gls) tac2 + tacsequence gstate tacs + +_THENL :: BoolCtxt thry => Tactic cls thry -> [Tactic cls thry] -> Tactic cls thry +_THENL tac1 tacs g = + do gstate@(GS _ gls _) <- tac1 g + tacsequence gstate $ if null gls then [] else tacs + +tacORELSE :: Tactic cls thry -> Tactic cls thry -> Tactic cls thry +tacORELSE tac1 tac2 g = tac1 g <|> tac2 g + +tacFAIL :: String -> Tactic cls thry +tacFAIL s _ = fail s + +tacNO :: Tactic cls thry +tacNO = tacFAIL "tacNO" + +{- +tacALL :: Tactic cls thry +tacALL g = return (GS nullMeta [g] justification) + where justification _ [th] = return th + justification _ _ = fail "tacALL: improper justification" +-} + +tacTRY :: Tactic cls thry -> Tactic cls thry +tacTRY tac = tac `_ORELSE` _ALL + +tacREPEAT :: BoolCtxt thry => Tactic cls thry -> Tactic cls thry +tacREPEAT tac = (tac `_THEN` tacREPEAT tac) `_ORELSE` _ALL + +tacEVERY :: BoolCtxt thry => [Tactic cls thry] -> Tactic cls thry +tacEVERY = foldr _THEN _ALL + +tacFIRST :: [Tactic cls thry] -> Tactic cls thry +tacFIRST [] = tacFAIL "empty tactic list for tacFIRST" +tacFIRST tacs = foldr1 _ORELSE tacs + +_MAP_EVERY :: BoolCtxt thry => (b -> Tactic cls thry) -> [b] -> Tactic cls thry +_MAP_EVERY f xs = tacEVERY $ map f xs + +tacCHANGED :: Tactic cls thry -> Tactic cls thry +tacCHANGED tac g = + do gstate@(GS meta gl _) <- tac g + if meta /= nullMeta + then return gstate + else case gl of + (g':[]) + | g' == g -> fail "tacCHANGED" + | otherwise -> return gstate + _ -> return gstate + +tacREPLICATE :: BoolCtxt thry => Int -> Tactic cls thry -> Tactic cls thry +tacREPLICATE n tac + | n <= 0 = _ALL + | otherwise = tac `_THEN` tacREPLICATE (n - 1) tac + +-- combinators for theorem tacticals +instance Lang (ThmTactical cls thry) where + _FAIL = tclFAIL + _NO = tclNO + _ALL = tclALL + _ORELSE = tclORELSE + _FIRST = tclFIRST + _CHANGED = tclCHANGED + _TRY = tclTRY + +instance LangSeq (ThmTactical cls thry) where + _THEN = tclTHEN + _REPEAT = tclREPEAT + _EVERY = tclEVERY + +tclFAIL :: String -> ThmTactical cls thry +tclFAIL msg _ _ = fail msg + +tclNO :: ThmTactical cls thry +tclNO = _FAIL "tclNO" + +tclALL :: ThmTactical cls thry +tclALL = id + +tclORELSE :: ThmTactical cls thry -> ThmTactical cls thry + -> ThmTactical cls thry +tclORELSE ttcl1 ttcl2 ttac th g = ttcl1 ttac th g <|> ttcl2 ttac th g + +tclFIRST :: [ThmTactical cls thry] -> ThmTactical cls thry +tclFIRST [] = _FAIL "tclFIRST: empty list" +tclFIRST ttcll = foldr1 _ORELSE ttcll + +tclCHANGED :: ThmTactical cls thry -> ThmTactical cls thry +tclCHANGED _ = _FAIL "tclCHANGED: undefined" + + +tclTRY :: ThmTactical cls thry -> ThmTactical cls thry +tclTRY ttcl = ttcl `_ORELSE` _ALL + +tclTHEN :: ThmTactical cls thry -> ThmTactical cls thry -> ThmTactical cls thry +tclTHEN ttcl1 ttcl2 ttac = ttcl1 (ttcl2 ttac) + +tclREPEAT :: ThmTactical cls thry -> ThmTactical cls thry +tclREPEAT ttcl = (ttcl `_THEN` _REPEAT ttcl) `_ORELSE` _ALL + +tclEVERY :: [ThmTactical cls thry] -> ThmTactical cls thry +tclEVERY = foldr _THEN _ALL + + +-- manipulation of assumption list +tacLABEL :: BoolCtxt thry => Text -> ThmTactic cls thry +tacLABEL s thm (Goal asl w) = + return $! GS nullMeta [Goal ((s, thm):asl) w] justification + where justification i [th] = do thm' <- ruleINSTANTIATE_ALL i thm + return $ rulePROVE_HYP thm' th + justification _ _ = fail "tacLABEL: improper justification" + +tacASSUME :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm -> Tactic cls thry +tacASSUME th = liftM1 (tacLABEL "") $ toHThm th + +_POP_ASSUM :: ThmTactic cls thry -> Tactic cls thry +_POP_ASSUM ttac (Goal ((_, th):asl) w) = ttac th (Goal asl w) +_POP_ASSUM _ _ = fail "_POP_ASSUM: no assumption to pop" + +_ASSUM_LIST :: ([HOLThm] -> Tactic cls thry) -> Tactic cls thry +_ASSUM_LIST aslfun g@(Goal asl _) = aslfun (map snd asl) g + +_POP_ASSUM_LIST :: ([HOLThm] -> Tactic cls thry) -> Tactic cls thry +_POP_ASSUM_LIST aslfun (Goal asl w) = aslfun (map snd asl) (Goal [] w) + +_EVERY_ASSUM :: BoolCtxt thry => ThmTactic cls thry -> Tactic cls thry +_EVERY_ASSUM ttac = _ASSUM_LIST (_MAP_EVERY ttac) + +_FIRST_ASSUM :: ThmTactic cls thry -> Tactic cls thry +_FIRST_ASSUM ttac g@(Goal asl _) = tryFind (\ (_, th) -> ttac th g) asl + +tacRULE_ASSUM :: BoolCtxt thry => (HOLThm -> HOL cls thry HOLThm) -> Tactic cls thry +tacRULE_ASSUM rule g@(Goal asl _) = + (_POP_ASSUM_LIST (const _ALL) `_THEN` + _MAP_EVERY (\ (s, th) gl -> do th' <- rule th + tacLABEL s th' gl) (reverse asl)) g + +-- augment a set of theorems with assumptions +tacASM :: HOLThmRep thm cls thry => ([HOLThm] -> Tactic cls thry) -> [thm] + -> Tactic cls thry +tacASM tltac ths g@(Goal asl _) = + do ths' <- mapM toHThm ths + tltac (map snd asl++ths') g + +-- basic tactic that uses a theorem equal to the goal +tacACCEPT' :: BoolCtxt thry => ThmTactic cls thry +tacACCEPT' th (Goal _ w) = + if aConv (concl th) w + then return . GS nullMeta [] $ propagate_thm th + else fail "tacACCEPT" + +tacACCEPT :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm -> Tactic cls thry +tacACCEPT pth = liftM1 tacACCEPT' (toHThm pth) + +-- create a tactic from a conversion +tacCONV :: BoolCtxt thry => Conversion cls thry -> Tactic cls thry +tacCONV conv g@(Goal asl w) = + do t_tm <- serve [bool| T |] + th <- runConv conv w + let tm = concl th + if aConv tm w + then tacACCEPT th g + else case destEq tm of + Just (l, r) + | aConv l w -> + if r == t_tm then do th' <- ruleEQT_ELIM th + tacACCEPT th' g + else do th' <- fromRightM $ ruleSYM th + return . GS nullMeta [Goal asl r] $ justification th' + | otherwise -> fail "tacCONV: bad equation" + _ -> fail "tacCONV: not an equation" + where justification th' i [thm] = do th'' <- ruleINSTANTIATE_ALL i th' + fromRightM $ primEQ_MP th'' thm + justification _ _ _ = fail "tacCONV: improper justification" + +-- equality tactics +tacREFL :: BoolCtxt thry => Tactic cls thry +tacREFL g@(Goal _ (Comb _ x)) = tacACCEPT (primREFL x) g +tacREFL _ = fail "tacREFL: goal not a combination" + +tacABS :: Tactic cls thry +tacABS (Goal asl w@(Abs lv lb := Abs rv rb)) = + let avoids = foldr (union . thmFrees . snd) (frees w) asl in + do v <- mkPrimedVar avoids lv + l' <- liftO $ varSubst [(lv, v)] lb + w' <- mkEq l' #<< varSubst [(rv, v)] rb + return . GS nullMeta [Goal asl w'] $ justification v + where justification v i [thm] = liftO $ + do ath <- primABS v thm + liftM1 primEQ_MP (ruleALPHA (concl ath) $ instantiate i w) ath + justification _ _ _ = fail "tacABS: improper justification" +tacABS _ = fail "tacREFL: goal not an equality." + +tacMK_COMB :: Tactic cls thry +tacMK_COMB (Goal asl gl) = + do ((f, x), (g, y)) <- fromJustM (pairMapM destComb =<< destEq gl) + g1 <- mkEq f g + g2 <- mkEq x y + return $! GS nullMeta [Goal asl g1, Goal asl g2] justification + + where justification _ [th1, th2] = fromRightM $ primMK_COMB th1 th2 + justification _ _ = fail "tacMK_COMB: improper justification" + +tacAP_TERM :: BoolCtxt thry => Tactic cls thry +tacAP_TERM g = (tacMK_COMB `_THENL` [tacREFL, _ALL]) g "tacAP_TERM" + +tacAP_THM :: BoolCtxt thry => Tactic cls thry +tacAP_THM g = (tacMK_COMB `_THENL` [_ALL, tacREFL]) g "tacAP_THM" + +tacBINOP :: BoolCtxt thry => Tactic cls thry +tacBINOP g = (tacMK_COMB `_THENL` [tacAP_TERM, _ALL]) g "tacAP_THM" + +tacSUBST1' :: BoolCtxt thry => ThmTactic cls thry +tacSUBST1' th = tacCONV (convSUBS [th]) + +tacSUBST1 :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm -> Tactic cls thry +tacSUBST1 th = liftM1 tacSUBST1' (toHThm th) + +tacSUBST_ALL :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm + -> Tactic cls thry +tacSUBST_ALL rth = + tacSUBST1 rth `_THEN` tacRULE_ASSUM (ruleSUBS [rth]) + +tacBETA :: BoolCtxt thry => Tactic cls thry +tacBETA = tacCONV (convREDEPTH convBETA) + +tacSUBST_VAR :: BoolCtxt thry => ThmTactic cls thry +tacSUBST_VAR th = + let (asm, eq) = destThm th in + case destEq eq of + Nothing -> _FAIL "tacSUBST_VAR: conclusion not an equivalence" + Just (l, r) + | l `aConv` r -> _ALL + | not (frees eq `subset` catFrees asm) -> _FAIL "tacSUBST_VAR" + | (isConst l || isVar l) && not (l `freeIn` r) -> tacSUBST_ALL th + | (isConst r || isVar r) && not (r `freeIn` l) -> + liftM1 tacSUBST_ALL (fromRightM $ ruleSYM th) + | otherwise -> _FAIL "tacSUBST_VAR" + +-- basic logical tactics +tacDISCH :: BoolCtxt thry => Tactic cls thry +tacDISCH (Goal asl w) = + do f_tm <- serve [bool| F |] + (do (ant, c) <- fromJustM $ destImp w + th <- fromRightM $ primASSUME ant + return . GS nullMeta [Goal (("", th):asl) c] $ justification1 ant) + <|> + do ant <- fromJustM $ destNeg w + th <- fromRightM $ primASSUME ant + return . GS nullMeta [Goal (("", th):asl) f_tm] $ justification2 ant + "tDISCH_TAC" + where justification1 ant i [th] = + ruleDISCH (instantiate i ant) th + justification1 _ _ _ = fail "tDISCH_TAC: improper justification" + justification2 ant i [th] = + ruleNOT_INTRO =<< ruleDISCH (instantiate i ant) th + justification2 _ _ _ = fail "tDISCH_TAC: improper justification" + +tacMP :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm -> Tactic cls thry +tacMP th = liftM1 tacMP' $ toHThm th + +tacMP' :: BoolCtxt thry => ThmTactic cls thry +tacMP' thm (Goal asl w) = + (do tm <- mkImp (concl thm) w + return $ GS nullMeta [Goal asl tm] justification) "tacMP" + where justification i [th] = ruleMP th =<< ruleINSTANTIATE_ALL i thm + justification _ _ = fail "tMP_TAC: improper justification" + +tacEQ :: BoolCtxt thry => Tactic cls thry +tacEQ (Goal asl w) = + case destEq w of + Just (l, r) -> (do tm1 <- mkImp l r + tm2 <- mkImp r l + return $! GS nullMeta [Goal asl tm1, Goal asl tm2] justification) + "tacEQ" + _ -> fail "tacEQ: not an equality conclusion" + where justification _ [th1, th2] = ruleIMP_ANTISYM th1 th2 + justification _ _ = fail "tacEQ: improper justification" + +tacUNDISCH :: (BoolCtxt thry, HOLTermRep tm cls thry) => tm -> Tactic cls thry +tacUNDISCH t = liftM1 tacUNDISCH' (toHTm t) + where tacUNDISCH' :: BoolCtxt thry => HOLTerm -> Tactic cls thry + tacUNDISCH' tm (Goal asl w) = + case remove (\ (_, asm) -> concl asm `aConv` tm) asl of + Just ((_, thm), asl') -> (do tm' <- mkImp tm w + return . GS nullMeta [Goal asl' tm'] $ just thm) "tacUNDISCH" + Nothing -> fail "tacUNDISCH" + + just thm i (th:[]) = ruleMP th =<< ruleINSTANTIATE_ALL i thm + just _ _ _ = fail "tacUNDISCH: bad justification" + +tacSPEC :: (BoolCtxt thry, HOLTermRep tm1 cls thry, + HOLTermRep tm2 cls thry) => (tm1, tm2) -> Tactic cls thry +tacSPEC (pt, px) (Goal asl w) = + do x <- toHTm px + t <- toHTm pt + tm' <- (mkForall x #<< subst [(t, x)] w) "tacSPEC" + return $! GS nullMeta [Goal asl tm'] justification + where justification i (th:[]) = + do t <- toHTm pt + ruleSPEC (instantiate i t) th + justification _ _ = fail "tacSPEC: bad justification" + +tacX_GEN :: (BoolCtxt thry, HOLTermRep tm cls thry) => tm -> Tactic cls thry +tacX_GEN px (Goal asl w) = + do x' <- toHTm px + case (x', destForall w) of + (Var{}, Just (x, bod)) -> + let avoids = foldr (union . thmFrees . snd) (frees w) asl in + if x' `elem` avoids then fail "tacX_GEN" + else (let afn = ruleCONV (convGEN_ALPHA x) in + do bod' <- liftMaybe "tacX_GEN" $ varSubst [(x, x')] bod + return . GS nullMeta [Goal asl bod'] $ justification afn) + "tacX_GEN" + (_, Nothing) -> fail "tacX_GEN: not a forall conclusion" + _ -> fail "tacX_GEN: provided term not a variable." + where justification afn _ [th] = afn =<< ruleGEN px th + justification _ _ _ = fail "tacX_GEN: improper justification" + +tacGEN :: BoolCtxt thry => Tactic cls thry +tacGEN g@(Goal asl w) = + case destForall w of + Just (x, _) -> let avoids = foldr (union . thmFrees . snd) (frees w) asl in + (do x' <- mkPrimedVar avoids x + tacX_GEN x' g) + "tacGEN" + _ -> fail "tacGEN" + +tacEXISTS' :: BoolCtxt thry => HOLTerm -> Tactic cls thry +tacEXISTS' t (Goal asl w) = + case destExists w of + Just (v, bod) -> + do bod' <- liftMaybe "tacEXISTS" $ varSubst [(v, t)] bod + return $! GS nullMeta [Goal asl bod'] justification + _ -> fail "tEXISTS_TAC" + where justification i [th] = + ruleEXISTS (instantiate i w) (instantiate i t) th + justification _ _ = fail "tEXISTS_TAC: improper justification" + +tacEXISTS :: (BoolCtxt thry, HOLTermRep tm cls thry) => tm -> Tactic cls thry +tacEXISTS t = liftM1 tacEXISTS' (toHTm t) + +tacX_CHOOSE' :: BoolCtxt thry => HOLTerm -> ThmTactic cls thry +tacX_CHOOSE' x' xth (Goal asl w) = + do (x, bod) <- liftMaybe "tacX_CHOOSE: not an exists conclusion" . + destExists $ concl xth + xth' <- liftEither "tacX_CHOOSE" $ primASSUME #<< varSubst [(x, x')] bod + let avoids = foldr (union . frees . concl . snd) + (frees w `union` thmFrees xth) asl + if x' `elem` avoids + then fail "tacX_CHOOSE: provided variable is free in provided theorem" + else return $! GS nullMeta [Goal (("", xth'):asl) w] justification + where justification i [th] = do xth2 <- ruleINSTANTIATE_ALL i xth + ruleCHOOSE x' xth2 th + justification _ _ = fail "tacX_CHOOSE: improper justification" + +tacX_CHOOSE :: (BoolCtxt thry, HOLTermRep tm cls thry, HOLThmRep thm cls thry) + => tm -> thm -> Tactic cls thry +tacX_CHOOSE tm th g = + do tm' <- toHTm tm + th' <- toHThm th + tacX_CHOOSE' tm' th' g + +tacCHOOSE :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm -> Tactic cls thry +tacCHOOSE pth (Goal asl w) = + do xth <- toHThm pth + case destExists $ concl xth of + Just (x, _) -> + let avoids = foldr (union . thmFrees . snd) + (frees w `union` thmFrees xth) asl in + (do x' <- mkPrimedVar avoids x + tacX_CHOOSE x' xth $ Goal asl w) + "tacCHOOSE" + _ -> fail "tacCHOOSE: not an exists conclusion" + +tacCONJ :: BoolCtxt thry => Tactic cls thry +tacCONJ (Goal asl w) = + case destConj w of + Just (l, r) -> return $! GS nullMeta [Goal asl l, Goal asl r] justification + _ -> fail "tacCONJ" + where justification _ [th1, th2] = ruleCONJ th1 th2 + justification _ _ = fail "tacCONJ: improper justification" + +tacDISJ1 :: BoolCtxt thry => Tactic cls thry +tacDISJ1 (Goal asl w) = + case destDisj w of + Just (l, r) -> return $! GS nullMeta [Goal asl l] (justification r) + _ -> fail "tacDISJ1" + where justification r i [th] = ruleDISJ1 th $ instantiate i r + justification _ _ _ = fail "tacDISJ1: improper justification" + +tacDISJ2 :: BoolCtxt thry => Tactic cls thry +tacDISJ2 (Goal asl w) = + case destDisj w of + Just (l, r) -> return $! GS nullMeta [Goal asl r] (justification l) + _ -> fail "tacDISJ2" + where justification l i [th] = + ruleDISJ2 (instantiate i l) th + justification _ _ _ = fail "tacDISJ2: improper justification" + +tacDISJ_CASES :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm + -> Tactic cls thry +tacDISJ_CASES pth (Goal asl w) = + do dth <- toHThm pth + (lth, rth) <- liftEither "tacDISJ_CASES: Maybe block" $ + pairMapM primASSUME #<< destDisj (concl dth) + return $! GS nullMeta [Goal (("", lth):asl) w, + Goal (("", rth):asl) w] justification + where justification i [th1, th2] = do dth' <- ruleINSTANTIATE_ALL i pth + ruleDISJ_CASES dth' th1 th2 + justification _ _ = fail "tacDISJ_CASES: improper justification" + +tacCONTR :: BoolCtxt thry => ThmTactic cls thry +tacCONTR cth (Goal _ w) = + (do th <- ruleCONTR w cth + return . GS nullMeta [] $ propagate_thm th) + "tacCONTR" + +rawtac :: BoolCtxt thry => ThmTactic cls thry +rawtac thm (Goal _ w) = + (do ith <- rulePART_MATCH return thm w + return . GS nullMeta [] $ propagate_thm ith) + "tacACCEPT" + +tacMATCH_ACCEPT' :: BoolCtxt thry => ThmTactic cls thry +tacMATCH_ACCEPT' th = _REPEAT tacGEN `_THEN` rawtac th + +tacMATCH_ACCEPT :: (BoolCtxt thry, HOLThmRep thm cls thry) => + thm -> Tactic cls thry +tacMATCH_ACCEPT pth = liftM1 tacMATCH_ACCEPT' (toHThm pth) + +tacMATCH_MP :: (BoolCtxt thry, HOLThmRep thm cls thry) => thm -> Tactic cls thry +tacMATCH_MP pth (Goal asl w) = + (do th <- toHThm pth + sth <- let tm = concl th + (avs, bod) = stripForall tm in + (do (ant, con) <- fromJustM $ destImp bod + th1 <- ruleSPECL avs #<< primASSUME tm + th2 <- ruleUNDISCH th1 + let evs = filter (\ v -> varFreeIn v ant && not (varFreeIn v con)) avs + th2_5 <- ruleDISCH tm th2 + th3 <- foldrM ruleSIMPLE_CHOOSE th2_5 evs + tm3 <- liftMaybe "tacMATCH_MP" . tryHead $ hyp th3 + th4 <- ruleDISCH tm =<< ruleGEN_ALL =<< ruleDISCH tm3 =<< ruleUNDISCH th3 + ruleMP th4 th) "tacMATCH_MP: bad theorem" + let match_fun = rulePART_MATCH (liftM snd . destImp) sth + xth <- match_fun w + (lant, _) <- fromJustM . destImp $ concl xth + return $! GS nullMeta [Goal asl lant] (justification xth)) + "tacMATCH_MP: no match" + where justification xth i [thm] = do thm2 <- ruleINSTANTIATE_ALL i xth + ruleMP thm2 thm + justification _ _ _ = fail "tacMATCH_MP: improper justification" + +-- theorem continuations +_CONJUNCTS_THEN2 :: (BoolCtxt thry, HOLThmRep thm cls thry) + => ThmTactic cls thry -> ThmTactic cls thry -> thm + -> Tactic cls thry +_CONJUNCTS_THEN2 ttac1 ttac2 pth gl = + do cth <- toHThm pth + (c1th, c2th) <- liftEither "_CONJUNCTS_THEN2: Maybe block" $ + pairMapM primASSUME #<< destConj (concl cth) + (GS ti gls jfn) <- (ttac1 c1th `_THEN` ttac2 c2th) gl + let jfn' i ths = + do (thm1, thm2) <- ruleCONJ_PAIR =<< ruleINSTANTIATE_ALL i cth + thm3 <- jfn i ths + return . rulePROVE_HYP thm1 $ rulePROVE_HYP thm2 thm3 + return (GS ti gls jfn') + +_CONJUNCTS_THEN :: BoolCtxt thry => ThmTactical cls thry +_CONJUNCTS_THEN = wComb _CONJUNCTS_THEN2 + +_DISJ_CASES_THEN2 :: (BoolCtxt thry, HOLThmRep thm cls thry) + => ThmTactic cls thry -> ThmTactic cls thry + -> thm -> Tactic cls thry +_DISJ_CASES_THEN2 ttac1 ttac2 cth = + tacDISJ_CASES cth `_THENL` [_POP_ASSUM ttac1, _POP_ASSUM ttac2] + +_DISJ_CASES_THEN :: (BoolCtxt thry, HOLThmRep thm cls thry) + => ThmTactic cls thry -> thm -> Tactic cls thry +_DISJ_CASES_THEN = wComb _DISJ_CASES_THEN2 + +_DISCH_THEN :: BoolCtxt thry => ThmTactic cls thry -> Tactic cls thry +_DISCH_THEN ttac = tacDISCH `_THEN` _POP_ASSUM ttac + +_X_CHOOSE_THEN :: (BoolCtxt thry, HOLTermRep tm cls thry, + HOLThmRep thm cls thry) => tm -> ThmTactic cls thry -> thm + -> Tactic cls thry +_X_CHOOSE_THEN tm a thm g = + do tm' <- toHTm tm + thm' <- toHThm thm + _X_CHOOSE_THEN' tm' a thm' g + where _X_CHOOSE_THEN' :: BoolCtxt thry => HOLTerm -> ThmTactical cls thry + _X_CHOOSE_THEN' x ttac th = tacX_CHOOSE x th `_THEN` _POP_ASSUM ttac + +_CHOOSE_THEN :: (BoolCtxt thry, HOLThmRep thm cls thry) => ThmTactic cls thry + -> thm -> Tactic cls thry +_CHOOSE_THEN ttac th = tacCHOOSE th `_THEN` _POP_ASSUM ttac + +-- some derived tactics +_STRIP_THM_THEN :: BoolCtxt thry => ThmTactical cls thry +_STRIP_THM_THEN = + _FIRST [ _CONJUNCTS_THEN + , _DISJ_CASES_THEN + , _CHOOSE_THEN + ] + +_ANTE_RES_THEN :: BoolCtxt thry => ThmTactical cls thry +_ANTE_RES_THEN ttac ante = + _ASSUM_LIST (\ asl g -> + do tacs <- mapFilterM (\ imp -> + do th' <- ruleMATCH_MP imp ante + return (ttac th')) asl + if null tacs + then fail "_ANTE_RES_THEN" + else _EVERY tacs g) + +tacSTRIP_ASSUME :: BoolCtxt thry => ThmTactic cls thry +tacSTRIP_ASSUME = + _REPEAT _STRIP_THM_THEN + (\ gth -> _FIRST [tacCONTR gth, tacACCEPT gth, + tDISCARD_TAC gth, tacASSUME gth]) + where tDISCARD_TAC :: ThmTactic cls thry + tDISCARD_TAC th g@(Goal asl _) = + let tm = concl th in + if any (aConv tm . concl . snd) asl + then _ALL g + else fail "tDISCARD_TAC: not already present" + +tacSTRUCT_CASES :: BoolCtxt thry => ThmTactic cls thry +tacSTRUCT_CASES = + _REPEAT _STRIP_THM_THEN + (\ th -> tacSUBST1 th `_ORELSE` tacASSUME th) + +tacSTRIP :: BoolCtxt thry => Tactic cls thry +tacSTRIP g = + _STRIP_GOAL_THEN tacSTRIP_ASSUME g "tacSTRIP" + +_STRIP_GOAL_THEN :: BoolCtxt thry => ThmTactic cls thry -> Tactic cls thry +_STRIP_GOAL_THEN ttac = _FIRST [tacGEN, tacCONJ, _DISCH_THEN ttac] + +_UNDISCH_THEN :: HOLTermRep tm cls thry => tm -> ThmTactic cls thry + -> Tactic cls thry +_UNDISCH_THEN ptm ttac g@(Goal asl w) = + case asl of + [] -> _FAIL "_UNDISCH_THEN: goal with empty assumption list" g + _ -> do tm <- toHTm ptm + (thp, asl') <- liftMaybe "_UNDISCH_THEN: remove" $ + remove (\ (_, th) -> aConv (concl th) tm) asl + ttac (snd thp) $ Goal asl' w + +_FIRST_X_ASSUM :: ThmTactic cls thry -> Tactic cls thry +_FIRST_X_ASSUM ttac = _FIRST_ASSUM (\ th -> _UNDISCH_THEN (concl th) ttac) + +-- subgoaling +_SUBGOAL_THEN :: HOLTermRep tm cls thry => tm -> ThmTactic cls thry + -> Tactic cls thry +_SUBGOAL_THEN tm a b = + do tm' <- toHTm tm + _SUBGOAL_THEN' tm' a b + where _SUBGOAL_THEN' :: HOLTerm -> ThmTactic cls thry -> Tactic cls thry + _SUBGOAL_THEN' wa ttac g@(Goal asl _) = + (do wath <- fromRightM $ primASSUME wa + (GS meta gl just) <- ttac wath g + return (GS meta (Goal asl wa:gl) $ justification just)) + "_SUBGOAL_THEN" + + justification just i (l:ls) = + liftM (rulePROVE_HYP l) $ just i ls + justification _ _ _ = fail "_SUBGOAL_THEN: improper justification" + +-- metavariable tactics +tacX_META_EXISTS :: BoolCtxt thry => HOLTerm -> Tactic cls thry +tacX_META_EXISTS t@Var{} (Goal asl w) = + case destExists w of + Just (v, bod) -> + do bod' <- liftMaybe "tacX_META_EXISTS" $ varSubst [(v, t)] bod + return $! GS ([t], nullInst) [Goal asl bod'] justification + Nothing -> fail "tacX_META_EXISTS: not an existance conclusion" + where justification i [th] = + ruleEXISTS (instantiate i w) (instantiate i t) th + justification _ _ = fail "tacX_META_EXISTS: improper justification" +tacX_META_EXISTS _ _ = fail "tacX_META_EXISTS" + + +tacMETA_SPEC :: BoolCtxt thry => HOLTerm -> ThmTactic cls thry +tacMETA_SPEC t thm (Goal asl w) = + do sth <- ruleSPEC t thm + return $! GS ([t], nullInst) [Goal (("", sth):asl) w] justification + where justification i [th] = + do thm' <- ruleSPEC (instantiate i t) thm + return $ rulePROVE_HYP thm' th + justification _ _ = fail "tacMETA_SPEC: improper justification" + +-- tactic proofs +mkGoalstate :: BoolCtxt thry => Goal -> HOL cls thry (GoalState cls thry) +mkGoalstate g@(Goal _ w) + | typeOf w == tyBool = return $! GS nullMeta [g] justification + | otherwise = fail "mkGoalstate: non-boolean goal" + where justification i [th] = ruleINSTANTIATE_ALL i th + justification _ _ = fail "mkGoalstate: improper justification" + +ruleTAC_PROOF :: BoolCtxt thry => Goal -> Tactic cls thry -> HOL cls thry HOLThm +ruleTAC_PROOF g tac = + do gstate <- mkGoalstate g + (GS _ sgs just) <- by tac gstate + if null sgs + then just nullInst [] + else fail "ruleTAC_PROOF: unsolved goals" + +prove' :: BoolCtxt thry => HOLTerm -> Tactic cls thry -> HOL cls thry HOLThm +prove' tm tac = + do th <- ruleTAC_PROOF (Goal [] tm) tac + let tm' = concl th + if tm' == tm + then return th + else liftEither "prove: justification generated wrong theorem" $ + do th1 <- ruleALPHA tm' tm + primEQ_MP th1 th + +prove :: (BoolCtxt thry, HOLTermRep tm cls thry) => + tm -> Tactic cls thry -> HOL cls thry HOLThm +prove ptm = liftM1 prove' (toHTm ptm) diff --git a/src/HaskHOL/Lib/Theorems.hs b/src/HaskHOL/Lib/Theorems.hs new file mode 100644 index 0000000..84b24d1 --- /dev/null +++ b/src/HaskHOL/Lib/Theorems.hs @@ -0,0 +1,321 @@ +{-| + Module: HaskHOL.Lib.Theorems + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Theorems + ( TheoremsType + , TheoremsCtxt + , thmEQ_REFL_T + , thmEQ_SYM + , thmEQ_SYM_EQ + , thmEQ_TRANS + , thmREFL_CLAUSE + , convAC + , thmBETA + , thmCONJ_ASSOC + , thmCONJ_SYM + , thmCONJ_ACI + , thmDISJ_ASSOC + , thmDISJ_SYM + , thmDISJ_ACI + , thmIMP_CONJ + , thmIMP_IMP + , thmFORALL_SIMP + , thmEXISTS_SIMP + , thmEQ_IMP + , thmEQ_CLAUSES + , thmNOT_CLAUSES_WEAK + , thmAND_CLAUSES + , thmOR_CLAUSES + , thmIMP_EQ_CLAUSE + , thmSWAP_FORALL + , thmSWAP_EXISTS + , thmFORALL_AND + , thmAND_FORALL + , thmLEFT_AND_FORALL + , thmRIGHT_AND_FORALL + , thmEXISTS_OR + , thmOR_EXISTS + , thmLEFT_OR_EXISTS + , thmRIGHT_OR_EXISTS + , thmLEFT_EXISTS_AND + , thmRIGHT_EXISTS_AND + , thmLEFT_AND_EXISTS + , thmRIGHT_AND_EXISTS + , thmLEFT_IMP_EXISTS + , thmLEFT_FORALL_IMP + , thmEXISTS_REFL + , thmEXISTS_UNIQUE + , thmEXISTS_UNIQUE_ALT + , thmEXISTS_UNIQUE_REFL + , thmUNWIND1 + , thmUNWIND2 + , thmMONO_AND + , thmMONO_OR + , thmMONO_IMP + , thmMONO_NOT + , thmMONO_FORALL + , thmMONO_EXISTS + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Equal +import HaskHOL.Lib.Itab +import HaskHOL.Lib.Simp +import HaskHOL.Lib.Tactics + +import HaskHOL.Lib.Theorems.Base +import HaskHOL.Lib.Theorems.Context + +thmEQ_IMP :: TheoremsCtxt thry => HOL cls thry HOLThm +thmEQ_IMP = cacheProof "thmEQ_IMP" ctxtTheorems $ + ruleITAUT "(a <=> b) ==> a ==> b" + +-- basic equality proofs +thmEQ_REFL_T :: TheoremsCtxt thry => HOL cls thry HOLThm +thmEQ_REFL_T = cacheProof "thmEQ_REFL_T" ctxtTheorems $ + do th <- ruleEQT_INTRO =<< ruleSPEC_ALL thmEQ_REFL + prove "!x:A. (x = x) <=> T" $ + tacGEN `_THEN` + tacMATCH_ACCEPT th + +thmEQ_SYM :: TheoremsCtxt thry => HOL cls thry HOLThm +thmEQ_SYM = cacheProof "thmEQ_SYM" ctxtTheorems $ + prove "!(x:A) y. (x = y) ==> (y = x)" $ + _REPEAT tacGEN `_THEN` + _DISCH_THEN (tacACCEPT <#< ruleSYM) + +thmEQ_SYM_EQ :: TheoremsCtxt thry => HOL cls thry HOLThm +thmEQ_SYM_EQ = cacheProof "thmEQ_SYM_EQ" ctxtTheorems $ + prove "!(x:A) y. (x = y) <=> (y = x)" $ + _REPEAT tacGEN `_THEN` + tacEQ `_THEN` + tacMATCH_ACCEPT thmEQ_SYM + +thmEQ_TRANS :: TheoremsCtxt thry => HOL cls thry HOLThm +thmEQ_TRANS = cacheProof "thmEQ_TRANS" ctxtTheorems $ + prove [str| !(x:A) y z. (x = y) /\ (y = z) ==> (x = z) |] $ + _REPEAT tacSTRIP `_THEN` tacPURE_ASM_REWRITE_NIL `_THEN` tacREFL + +-- common case of ordered rewriting +convAC :: (TheoremsCtxt thry, HOLThmRep thm cls thry) => thm + -> Conversion cls thry +convAC acsuite = Conv $ \ tm -> + do th1 <- toHThm acsuite + th2 <- thmEQ_REFL_T + ruleEQT_ELIM =<< runConv (convPURE_REWRITE [th1, th2]) tm + +-- intuitionistic tauts +thmCONJ_ASSOC :: TheoremsCtxt thry => HOL cls thry HOLThm +thmCONJ_ASSOC = cacheProof "thmCONJ_ASSOC" ctxtTheorems $ + prove [str| !t1 t2 t3. t1 /\ t2 /\ t3 <=> (t1 /\ t2) /\ t3 |] tacITAUT + +thmCONJ_SYM :: TheoremsCtxt thry => HOL cls thry HOLThm +thmCONJ_SYM = cacheProof "thmCONJ_SYM" ctxtTheorems $ + prove [str| !t1 t2. t1 /\ t2 <=> t2 /\ t1 |] tacITAUT + +thmCONJ_ACI :: TheoremsCtxt thry => HOL cls thry HOLThm +thmCONJ_ACI = cacheProof "thmCONJ_ACI" ctxtTheorems $ + prove [str| (p /\ q <=> q /\ p) /\ + ((p /\ q) /\ r <=> p /\ (q /\ r)) /\ + (p /\ (q /\ r) <=> q /\ (p /\ r)) /\ + (p /\ p <=> p) /\ + (p /\ (p /\ q) <=> p /\ q) |] tacITAUT + +thmDISJ_ASSOC :: TheoremsCtxt thry => HOL cls thry HOLThm +thmDISJ_ASSOC = cacheProof "thmDISJ_ASSOC" ctxtTheorems $ + prove [str| !t1 t2 t3. t1 \/ t2 \/ t3 <=> (t1 \/ t2) \/ t3 |] tacITAUT + +thmDISJ_SYM :: TheoremsCtxt thry => HOL cls thry HOLThm +thmDISJ_SYM = cacheProof "thmDISJ_SYM" ctxtTheorems $ + prove [str| !t1 t2. t1 \/ t2 <=> t2 \/ t1 |] tacITAUT + +thmDISJ_ACI :: TheoremsCtxt thry => HOL cls thry HOLThm +thmDISJ_ACI = cacheProof "thmDISJ_ACI" ctxtTheorems $ + prove [str| (p \/ q <=> q \/ p) /\ + ((p \/ q) \/ r <=> p \/ (q \/ r)) /\ + (p \/ (q \/ r) <=> q \/ (p \/ r)) /\ + (p \/ p <=> p) /\ + (p \/ (p \/ q) <=> p \/ q) |] tacITAUT + +thmIMP_CONJ :: TheoremsCtxt thry => HOL cls thry HOLThm +thmIMP_CONJ = cacheProof "thmIMP_CONJ" ctxtTheorems $ + prove [str| p /\ q ==> r <=> p ==> q ==> r |] tacITAUT + +thmIMP_IMP :: TheoremsCtxt thry => HOL cls thry HOLThm +thmIMP_IMP = cacheProof "thmIMP_IMP" ctxtTheorems $ + ruleGSYM thmIMP_CONJ + +-- permuting quantifiers +thmSWAP_FORALL :: TheoremsCtxt thry => HOL cls thry HOLThm +thmSWAP_FORALL = cacheProof "thmSWAP_FORALL" ctxtTheorems $ + prove "!P:A->B->bool. (!x y. P x y) <=> (!y x. P x y)" tacITAUT + +thmSWAP_EXISTS :: TheoremsCtxt thry => HOL cls thry HOLThm +thmSWAP_EXISTS = cacheProof "thmSWAP_EXISTS" ctxtTheorems $ + prove "!P:A->B->bool. (?x y. P x y) <=> (?y x. P x y)" tacITAUT + +-- universal quantifier and conjunction +thmFORALL_AND :: TheoremsCtxt thry => HOL cls thry HOLThm +thmFORALL_AND = cacheProof "thmFORALL_AND" ctxtTheorems $ + prove [str| !P Q. (!x:A. P x /\ Q x) <=> (!x. P x) /\ (!x. Q x) |] + tacITAUT + +thmAND_FORALL :: TheoremsCtxt thry => HOL cls thry HOLThm +thmAND_FORALL = cacheProof "thmAND_FORALL" ctxtTheorems $ + prove [str| !P Q. (!x. P x) /\ (!x. Q x) <=> + (!x:A. P x /\ Q x) |] tacITAUT + +thmLEFT_AND_FORALL :: TheoremsCtxt thry => HOL cls thry HOLThm +thmLEFT_AND_FORALL = cacheProof "thmLEFT_AND_FORALL" ctxtTheorems $ + prove [str| !P Q. (!x:A. P x) /\ Q <=> (!x:A. P x /\ Q) |] tacITAUT + +thmRIGHT_AND_FORALL :: TheoremsCtxt thry => HOL cls thry HOLThm +thmRIGHT_AND_FORALL = cacheProof "thmRIGHT_AND_FORALL" ctxtTheorems $ + prove [str| !P Q. P /\ (!x:A. Q x) <=> (!x. P /\ Q x) |] tacITAUT + + +-- existential quantifier and disjunction +thmEXISTS_OR :: TheoremsCtxt thry => HOL cls thry HOLThm +thmEXISTS_OR = cacheProof "thmEXISTS_OR" ctxtTheorems $ + prove [str| !P Q. (?x:A. P x \/ Q x) <=> + (?x. P x) \/ (?x. Q x) |] tacITAUT + +thmOR_EXISTS :: TheoremsCtxt thry => HOL cls thry HOLThm +thmOR_EXISTS = cacheProof "thmOR_EXISTS" ctxtTheorems $ + prove [str| !P Q. (?x. P x) \/ (?x. Q x) <=> + (?x:A. P x \/ Q x) |] tacITAUT + +thmLEFT_OR_EXISTS :: TheoremsCtxt thry => HOL cls thry HOLThm +thmLEFT_OR_EXISTS = cacheProof "thmLEFT_OR_EXISTS" ctxtTheorems $ + prove [str| !P Q. (?x. P x) \/ Q <=> (?x:A. P x \/ Q) |] tacITAUT + +thmRIGHT_OR_EXISTS :: TheoremsCtxt thry => HOL cls thry HOLThm +thmRIGHT_OR_EXISTS = cacheProof "thmRIGHT_OR_EXISTS" ctxtTheorems $ + prove [str| !P Q. P \/ (?x. Q x) <=> (?x:A. P \/ Q x) |] tacITAUT + +-- existential quantification and conjunction +thmLEFT_EXISTS_AND :: TheoremsCtxt thry => HOL cls thry HOLThm +thmLEFT_EXISTS_AND = cacheProof "thmLEFT_EXISTS_AND" ctxtTheorems $ + prove [str| !P Q. (?x:A. P x /\ Q) <=> (?x:A. P x) /\ Q |] tacITAUT + +thmRIGHT_EXISTS_AND :: TheoremsCtxt thry => HOL cls thry HOLThm +thmRIGHT_EXISTS_AND = cacheProof "thmRIGHT_EXISTS_AND" ctxtTheorems $ + prove [str| !P Q. (?x:A. P /\ Q x) <=> P /\ (?x:A. Q x) |] tacITAUT + +thmLEFT_AND_EXISTS :: TheoremsCtxt thry => HOL cls thry HOLThm +thmLEFT_AND_EXISTS = cacheProof "thmLEFT_AND_EXISTS" ctxtTheorems $ + prove [str| !P Q. (?x:A. P x) /\ Q <=> (?x:A. P x /\ Q) |] tacITAUT + +thmRIGHT_AND_EXISTS :: TheoremsCtxt thry => HOL cls thry HOLThm +thmRIGHT_AND_EXISTS = cacheProof "thmRIGHT_AND_EXISTS" ctxtTheorems $ + prove [str| !P Q. P /\ (?x:A. Q x) <=> (?x:A. P /\ Q x) |] tacITAUT + +thmLEFT_IMP_EXISTS :: TheoremsCtxt thry => HOL cls thry HOLThm +thmLEFT_IMP_EXISTS = cacheProof "thmLEFT_IMP_EXISTS" ctxtTheorems $ + prove "!P Q. ((?x:A. P x) ==> Q) <=> (!x. P x ==> Q)" tacITAUT + +thmLEFT_FORALL_IMP :: TheoremsCtxt thry => HOL cls thry HOLThm +thmLEFT_FORALL_IMP = cacheProof "thmLEFT_FORALL_IMP" ctxtTheorems $ + prove "!P Q. (!x. P x ==> Q) <=> ((?x:A. P x) ==> Q)" tacITAUT + +thmEXISTS_REFL :: TheoremsCtxt thry => HOL cls thry HOLThm +thmEXISTS_REFL = cacheProof "thmEXISTS_REFL" ctxtTheorems $ + do a <- toHTm "a:A" + prove "!a:A. ?x. x = a" $ + tacGEN `_THEN` + tacEXISTS a `_THEN` + tacREFL + +thmEXISTS_UNIQUE :: (BasicConvs thry, TheoremsCtxt thry) => HOL cls thry HOLThm +thmEXISTS_UNIQUE = cacheProof "thmEXISTS_UNIQUE" ctxtTheorems $ + prove [str| !P. (?!x:A. P x) <=> + (?x. P x) /\ (!x x'. P x /\ P x' ==> (x = x')) |] $ + tacGEN `_THEN` tacREWRITE [defEXISTS_UNIQUE] + +thmEXISTS_UNIQUE_REFL :: (BasicConvs thry, TheoremsCtxt thry) + => HOL cls thry HOLThm +thmEXISTS_UNIQUE_REFL = cacheProof "thmEXISTS_UNIQUE_REFL" ctxtTheorems $ + prove "!a:A. ?!x. x = a" $ + tacGEN `_THEN` tacREWRITE [thmEXISTS_UNIQUE] `_THEN` + _REPEAT (tacEQ `_ORELSE` tacSTRIP) `_THENL` + [ tacEXISTS "a:A", tacASM_REWRITE_NIL ] `_THEN` + tacREFL + +thmEXISTS_UNIQUE_ALT :: (BasicConvs thry, TheoremsCtxt thry) + => HOL cls thry HOLThm +thmEXISTS_UNIQUE_ALT = cacheProof "thmEXISTS_UNIQUE_ALT" ctxtTheorems $ + do pth <- ruleGSYM thmEXISTS_REFL + prove "!P:A->bool. (?!x. P x) <=> (?x. !y. P y <=> (x = y))" $ + tacGEN `_THEN` tacREWRITE [thmEXISTS_UNIQUE] `_THEN` tacEQ `_THENL` + [ _DISCH_THEN (_CONJUNCTS_THEN2 (tacX_CHOOSE "x:A") tacASSUME) `_THEN` + tacEXISTS "x:A" `_THEN` tacGEN `_THEN` tacEQ `_THENL` + [ tacDISCH `_THEN` _FIRST_ASSUM tacMATCH_MP `_THEN` + tacASM_REWRITE_NIL + , _DISCH_THEN (\ th -> tacSUBST1 (fromRight $ ruleSYM th)) `_THEN` + _FIRST_ASSUM tacMATCH_ACCEPT + ] + , _DISCH_THEN (tacX_CHOOSE "x:A") `_THEN` + tacASM_REWRITE [pth] `_THEN` + _REPEAT tacGEN `_THEN` + _DISCH_THEN (_CONJUNCTS_THEN + (\ th -> tacSUBST1 (fromRight $ ruleSYM th))) `_THEN` + tacREFL + ] + +thmUNWIND1 :: TheoremsCtxt thry => HOL cls thry HOLThm +thmUNWIND1 = cacheProof "thmUNWIND1" ctxtTheorems $ + prove [str| !P (a:A). (?x. a = x /\ P x) <=> P a |] $ + _REPEAT tacGEN `_THEN` tacEQ `_THENL` + [ _DISCH_THEN (_CHOOSE_THEN (_CONJUNCTS_THEN2 tacSUBST1 tacACCEPT)) + , tacDISCH `_THEN` tacEXISTS "a:A" `_THEN` + tacCONJ `_THEN` _TRY (_FIRST_ASSUM tacMATCH_ACCEPT) `_THEN` + tacREFL + ] + +thmUNWIND2 :: TheoremsCtxt thry => HOL cls thry HOLThm +thmUNWIND2 = cacheProof "thmUNWIND2" ctxtTheorems $ + prove [str| !P (a:A). (?x. x = a /\ P x) <=> P a |] $ + _REPEAT tacGEN `_THEN` tacCONV (convLAND (convONCE_DEPTH convSYM)) `_THEN` + tacMATCH_ACCEPT thmUNWIND1 + +-- monotonicity theorems for inductive definitions +thmMONO_AND :: TheoremsCtxt thry => HOL cls thry HOLThm +thmMONO_AND = cacheProof "thmMONO_AND" ctxtTheorems $ + ruleITAUT [str| (A ==> B) /\ (C ==> D) ==> (A /\ C ==> B /\ D) |] + +thmMONO_OR :: TheoremsCtxt thry => HOL cls thry HOLThm +thmMONO_OR = cacheProof "thmMONO_OR" ctxtTheorems $ + ruleITAUT [str| (A ==> B) /\ (C ==> D) ==> (A \/ C ==> B \/ D) |] + +thmMONO_IMP :: TheoremsCtxt thry => HOL cls thry HOLThm +thmMONO_IMP = cacheProof "thmMONO_IMP" ctxtTheorems $ + ruleITAUT [str| (B ==> A) /\ (C ==> D) ==> + ((A ==> C) ==> (B ==> D)) |] + +thmMONO_NOT :: TheoremsCtxt thry => HOL cls thry HOLThm +thmMONO_NOT = cacheProof "thmMONO_NOT" ctxtTheorems $ + ruleITAUT "(B ==> A) ==> (~A ==> ~B)" + +thmMONO_FORALL :: (BasicConvs thry, TheoremsCtxt thry) => HOL cls thry HOLThm +thmMONO_FORALL = cacheProof "thmMONO_FORALL" ctxtTheorems $ + prove "(!x:A. P x ==> Q x) ==> ((!x. P x) ==> (!x. Q x))" $ + _REPEAT tacSTRIP `_THEN` + _FIRST_ASSUM tacMATCH_MP `_THEN` + tacASM_REWRITE_NIL + +thmMONO_EXISTS :: (BasicConvs thry, TheoremsCtxt thry) => HOL cls thry HOLThm +thmMONO_EXISTS = cacheProof "thmMONO_EXISTS" ctxtTheorems $ + prove "(!x:A. P x ==> Q x) ==> ((?x. P x) ==> (?x. Q x))" $ + tacDISCH `_THEN` + _DISCH_THEN (tacX_CHOOSE "x:A") `_THEN` + tacEXISTS "x:A" `_THEN` + _FIRST_ASSUM tacMATCH_MP `_THEN` + tacASM_REWRITE_NIL diff --git a/src/HaskHOL/Lib/Theorems/Base.hs b/src/HaskHOL/Lib/Theorems/Base.hs new file mode 100644 index 0000000..481b2e5 --- /dev/null +++ b/src/HaskHOL/Lib/Theorems/Base.hs @@ -0,0 +1,76 @@ +module HaskHOL.Lib.Theorems.Base where + +import HaskHOL.Core + +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Bool.Context +import HaskHOL.Lib.Tactics +import HaskHOL.Lib.Itab +import HaskHOL.Lib.Simp + + +-- basic rewrites +thmEQ_CLAUSES :: (BasicConvs thry, BoolCtxt thry) => HOL cls thry HOLThm +thmEQ_CLAUSES = cacheProof "thmEQ_CLAUSES" ctxtBool $ + prove [str| !t. ((T <=> t) <=> t) /\ + ((t <=> T) <=> t) /\ + ((F <=> t) <=> ~t) /\ + ((t <=> F) <=> ~t) |] tacITAUT + +thmNOT_CLAUSES_WEAK :: BoolCtxt thry => HOL cls thry HOLThm +thmNOT_CLAUSES_WEAK = cacheProof "thmNOT_CLAUSES_WEAK" ctxtBool $ + prove [str| (~T <=> F) /\ (~F <=> T) |] tacITAUT + +thmAND_CLAUSES :: BoolCtxt thry => HOL cls thry HOLThm +thmAND_CLAUSES = cacheProof "thmAND_CLAUSES" ctxtBool $ + prove [str| !t. (T /\ t <=> t) /\ + (t /\ T <=> t) /\ + (F /\ t <=> F) /\ + (t /\ F <=> F) /\ + (t /\ t <=> t) |] tacITAUT + +thmOR_CLAUSES :: BoolCtxt thry => HOL cls thry HOLThm +thmOR_CLAUSES = cacheProof "thmOR_CLAUSES" ctxtBool $ + prove [str| !t. (T \/ t <=> T) /\ + (t \/ T <=> T) /\ + (F \/ t <=> t) /\ + (t \/ F <=> t) /\ + (t \/ t <=> t) |] tacITAUT + +thmREFL_CLAUSE :: BoolCtxt thry => HOL cls thry HOLThm +thmREFL_CLAUSE = cacheProof "thmREFL_CLAUSE" ctxtBool $ + do x <- toHTm "x:A" + th <- ruleEQT_INTRO =<< ruleSPEC x thmEQ_REFL + prove "!x:A. (x = x) = T" $ + tacGEN `_THEN` + tacACCEPT th + +thmIMP_EQ_CLAUSE :: (BasicConvs thry, BoolCtxt thry) => HOL cls thry HOLThm +thmIMP_EQ_CLAUSE = cacheProof "thmIMP_EQ_CLAUSE" ctxtBool $ + do th1 <- ruleEQT_INTRO =<< ruleSPEC_ALL thmEQ_REFL + th2 <- thmIMP_CLAUSES + prove "((x = x) ==> p) <=> p" $ tacREWRITE [th1, th2] + +-- degenerate cases of quantifiers +thmFORALL_SIMP :: BoolCtxt thry => HOL cls thry HOLThm +thmFORALL_SIMP = cacheProof "thmFORALL_SIMP" ctxtBool $ + prove "!t. (!x:A. t) = t" tacITAUT + +thmEXISTS_SIMP :: BoolCtxt thry => HOL cls thry HOLThm +thmEXISTS_SIMP = cacheProof "thmEXISTS_SIMP" ctxtBool $ + prove "!t. (?x:A. t) = t" tacITAUT + + +-- beta reduction stuff +thmBETA :: BoolCtxt thry => HOL cls thry HOLThm +thmBETA = cacheProof "thmBETA" ctxtBool $ + prove [str| !(f:A->B) y. (\x. (f:A->B) x) y = f y |] $ + _REPEAT tacGEN `_THEN` tacBETA `_THEN` tacREFL + +-- basic congruence +thmBASIC_CONG :: BoolCtxt thry => HOL cls thry HOLThm +thmBASIC_CONG = cacheProof "thmBASIC_CONG" ctxtBool $ + prove [str| (p <=> p') ==> + (p' ==> (q <=> q')) ==> + (p ==> q <=> p' ==> q') |] + tacITAUT diff --git a/src/HaskHOL/Lib/Theorems/Context.hs b/src/HaskHOL/Lib/Theorems/Context.hs new file mode 100644 index 0000000..22f5595 --- /dev/null +++ b/src/HaskHOL/Lib/Theorems/Context.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TypeSynonymInstances, + UndecidableInstances #-} +module HaskHOL.Lib.Theorems.Context + ( TheoremsType + , TheoremsCtxt + , ctxtTheorems + , theorems + ) where + +import HaskHOL.Core +import HaskHOL.Lib.Simp + +import HaskHOL.Lib.Bool.Context +import HaskHOL.Lib.Theorems.Base + + +extendTheory ctxtBool "Theorems" $ + do extendBasicRewrites =<< sequence [ thmREFL_CLAUSE + , thmEQ_CLAUSES + , thmNOT_CLAUSES_WEAK + , thmAND_CLAUSES + , thmOR_CLAUSES + , thmIMP_CLAUSES + , thmFORALL_SIMP + , thmEXISTS_SIMP + , thmBETA + , thmIMP_EQ_CLAUSE + ] + extendBasicCongs =<< sequence [ thmBASIC_CONG ] + +templateProvers 'ctxtTheorems + +-- have to manually write this, for now +type family TheoremsCtxt a :: Constraint where + TheoremsCtxt a = (BoolCtxt a, TheoremsContext a ~ 'True) + +type instance PolyTheory TheoremsType b = TheoremsCtxt b + +instance BasicConvs TheoremsType where + basicConvs _ = [] diff --git a/src/HaskHOL/Lib/Trivia.hs b/src/HaskHOL/Lib/Trivia.hs new file mode 100644 index 0000000..d7d995e --- /dev/null +++ b/src/HaskHOL/Lib/Trivia.hs @@ -0,0 +1,32 @@ +{-| + Module: HaskHOL.Lib.Trivia + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Trivia + ( TriviaType + , TriviaCtxt + , defI + , defO + , thmI + , thm_one + , def_one + , induct_one + , recursion_one + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Simp +import HaskHOL.Lib.Tactics + +import HaskHOL.Lib.Trivia.Base +import HaskHOL.Lib.Trivia.Context + +thmI :: (BasicConvs thry, TriviaCtxt thry) => HOL cls thry HOLThm +thmI = cacheProof "thmI" ctxtTrivia $ + prove "!x:A. I x = x" $ tacREWRITE [defI] diff --git a/src/HaskHOL/Lib/Trivia/A.hs b/src/HaskHOL/Lib/Trivia/A.hs new file mode 100644 index 0000000..5f44bf9 --- /dev/null +++ b/src/HaskHOL/Lib/Trivia/A.hs @@ -0,0 +1,7 @@ +module HaskHOL.Lib.Trivia.A + ( module HaskHOL.Lib.Trivia.A.Base + , module HaskHOL.Lib.Trivia.A.Context + ) where + +import HaskHOL.Lib.Trivia.A.Base +import HaskHOL.Lib.Trivia.A.Context diff --git a/src/HaskHOL/Lib/Trivia/A/Base.hs b/src/HaskHOL/Lib/Trivia/A/Base.hs new file mode 100644 index 0000000..78dc90b --- /dev/null +++ b/src/HaskHOL/Lib/Trivia/A/Base.hs @@ -0,0 +1,33 @@ +module HaskHOL.Lib.Trivia.A.Base where + +import HaskHOL.Core + +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Classic +import HaskHOL.Lib.Classic.Context +import HaskHOL.Lib.DRule +import HaskHOL.Lib.Tactics +import HaskHOL.Lib.Simp + +thmEXISTS_ONE_REP :: ClassicCtxt thry => HOL cls thry HOLThm +thmEXISTS_ONE_REP = cacheProof "thmEXISTS_ONE_REP" ctxtClassic $ + prove "?b:bool . b" $ + tacEXISTS "T" `_THEN` + tacBETA `_THEN` + tacACCEPT thmTRUTH + + + +defO' :: BoolCtxt thry => HOL Theory thry HOLThm +defO' = newDefinition "o" + [str| (o) (f:B->C) g = \x:A. f(g(x)) |] + +defI' :: BoolCtxt thry => HOL Theory thry HOLThm +defI' = newDefinition "I" + [str| I = \x:A. x |] + +tyDefOne' :: (BasicConvs thry, ClassicCtxt thry) => HOL Theory thry HOLThm +tyDefOne' = newTypeDefinition "1" "one_ABS" "one_REP" thmEXISTS_ONE_REP + +defONE' :: BoolCtxt thry => HOL Theory thry HOLThm +defONE' = newDefinition "one" "one = @x:1. T" diff --git a/src/HaskHOL/Lib/Trivia/A/Context.hs b/src/HaskHOL/Lib/Trivia/A/Context.hs new file mode 100644 index 0000000..3def318 --- /dev/null +++ b/src/HaskHOL/Lib/Trivia/A/Context.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TypeSynonymInstances, + UndecidableInstances #-} +module HaskHOL.Lib.Trivia.A.Context + ( TriviaAType + , TriviaACtxt + , ctxtTriviaA + , triviaA + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Simp + +import HaskHOL.Lib.Classic.Context +import HaskHOL.Lib.Trivia.A.Base + +-- generate template types +extendTheory ctxtClassic "TriviaA" $ + do parseAsInfix ("o", (26, "right")) + sequence_ [defO', defI'] + void tyDefOne' + void defONE' + +templateProvers 'ctxtTriviaA + +-- have to manually write this, for now +type family TriviaACtxt a where + TriviaACtxt a = (ClassicCtxt a, TriviaAContext a ~ 'True) + +type instance PolyTheory TriviaAType b = TriviaACtxt b + +instance BasicConvs TriviaAType where + basicConvs _ = [] diff --git a/src/HaskHOL/Lib/Trivia/Base.hs b/src/HaskHOL/Lib/Trivia/Base.hs new file mode 100644 index 0000000..80ce8b5 --- /dev/null +++ b/src/HaskHOL/Lib/Trivia/Base.hs @@ -0,0 +1,50 @@ +module HaskHOL.Lib.Trivia.Base where + +import HaskHOL.Core + +import HaskHOL.Lib.Equal +import HaskHOL.Lib.DRule +import HaskHOL.Lib.Bool +import HaskHOL.Lib.Tactics +import HaskHOL.Lib.Simp +import HaskHOL.Lib.Classic + +import HaskHOL.Lib.Trivia.A + +-- guarded definitions from TriviaA +defO :: TriviaACtxt thry => HOL cls thry HOLThm +defO = cacheProof "defO" ctxtTriviaA $ getDefinition "o" + +defI :: TriviaACtxt thry => HOL cls thry HOLThm +defI = cacheProof "defI" ctxtTriviaA $ getDefinition "I" + +ty1 :: TriviaACtxt thry => HOL cls thry HOLThm +ty1 = cacheProof "ty1" ctxtTriviaA $ getTypeDefinition "1" + +def_one :: TriviaACtxt thry => HOL cls thry HOLThm +def_one = cacheProof "def_one" ctxtTriviaA $ getDefinition "one" + +thm_one :: (BasicConvs thry, TriviaACtxt thry) => HOL cls thry HOLThm +thm_one = cacheProof "thm_one" ctxtTriviaA $ + do th <- ruleCONJUNCT1 ty1 + prove "!v:1. v = one" $ + tacMP (ruleGEN_ALL =<< ruleSPEC "one_REP a" =<< + ruleCONJUNCT2 ty1) `_THEN` + tacREWRITE [th] `_THEN` + tacDISCH `_THEN` + tacONCE_REWRITE [ruleGSYM th] `_THEN` + tacASM_REWRITE_NIL + +induct_one :: (BasicConvs thry, TriviaACtxt thry) => HOL cls thry HOLThm +induct_one = cacheProof "induct_one" ctxtTriviaA $ + prove "!P. P one ==> !x. P x" $ + tacONCE_REWRITE [thm_one] `_THEN` tacREWRITE_NIL + +recursion_one :: TriviaACtxt thry => HOL cls thry HOLThm +recursion_one = cacheProof "recursion_one" ctxtTriviaA $ + prove "!e:A. ?fn. fn one = e" $ + tacGEN `_THEN` + tacEXISTS [str| \x:1. e:A |] `_THEN` + tacBETA `_THEN` + tacREFL + diff --git a/src/HaskHOL/Lib/Trivia/Context.hs b/src/HaskHOL/Lib/Trivia/Context.hs new file mode 100644 index 0000000..985ad64 --- /dev/null +++ b/src/HaskHOL/Lib/Trivia/Context.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TypeSynonymInstances, + UndecidableInstances #-} +module HaskHOL.Lib.Trivia.Context + ( TriviaType + , TriviaCtxt + , ctxtTrivia + , trivia + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Classic +import HaskHOL.Lib.Simp + +import HaskHOL.Lib.Trivia.A.Context +import HaskHOL.Lib.Trivia.Base + +-- generate template types +extendTheory ctxtTriviaA "Trivia" $ + do iTh <- induct_one + rTh <- recursion_one + addIndDefs [("1", (1, iTh, rTh))] + +templateProvers 'ctxtTrivia + +-- have to manually write this, for now +type family TriviaCtxt a where + TriviaCtxt a = (TriviaACtxt a, TriviaContext a ~ 'True) + +type instance PolyTheory TriviaType b = TriviaCtxt b + +instance BasicConvs TriviaType where + basicConvs _ = [] diff --git a/src/HaskHOL/Lib/TypeQuant.hs b/src/HaskHOL/Lib/TypeQuant.hs new file mode 100644 index 0000000..4e762d4 --- /dev/null +++ b/src/HaskHOL/Lib/TypeQuant.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE PatternSynonyms #-} +{-| + Module: HaskHOL.Lib.TypeQuant + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.TypeQuant + ( TypeQuantType + , TypeQuantCtxt + , convALPHA_TY + , convGEN_ALPHA_TY + , ruleGEN_TY + , ruleSPEC_TY + , tacX_GEN_TY + , tacGEN_TY + , tacTYABS + , tacUTYPE_E + , tacTYABS_E + , tacTYALL_ELIM + , tacTYALL_E + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Equal +import HaskHOL.Lib.Bool +import HaskHOL.Lib.DRule +import HaskHOL.Lib.Tactics +import HaskHOL.Lib.Misc +import HaskHOL.Lib.Simp + +import HaskHOL.Lib.TypeQuant.Context + +-- Equality Rules +convALPHA_TY :: HOLType -> Conversion cls thry +convALPHA_TY v@(TyVar True _) = Conv $ \ tm -> + fromRightM (ruleALPHA tm =<< alphaTyabs v tm) "convALPHA_TY" +convALPHA_TY _ = + _FAIL "convALPHA_TY: provided type is not a small type variable." + +convGEN_ALPHA_TY :: HOLType -> Conversion cls thry +convGEN_ALPHA_TY v@(TyVar True _) = Conv $ \ tm -> + case tm of + TyAbs{} -> runConv (convALPHA_TY v) tm + (Comb b ab@TyAbs{}) -> + do abth <- runConv (convALPHA_TY v) ab + fromRightM $ ruleAP_TERM b abth + _ -> fail "convGEN_ALPHA_TY" +convGEN_ALPHA_TY _ = + _FAIL "convGEN_ALPHA_TY: provided type not a small type variable." + +-- Boolean Logic Rules +{-|@ + A |- t +------------ given 'x + A |- !! 'x. t +@-} +ruleGEN_TY :: TypeQuantCtxt thry => HOLType -> HOLThm -> HOL cls thry HOLThm +ruleGEN_TY ty@(TyVar True _) th = + do pth <- ruleGEN_TY_pth + th1 <- ruleEQT_INTRO th + liftO $ do th2 <- primTYABS ty th1 + phi <- note "" . lHand $ concl th2 + ptm <- note "" $ rand =<< rand (concl pth) + pth' <- note "" $ primINST [(ptm, phi)] pth + primEQ_MP pth' th2 + where -- proves |- P = (\\ 'x . T) <=> (!!) P + ruleGEN_TY_pth :: TypeQuantCtxt thry => HOL cls thry HOLThm + ruleGEN_TY_pth = cacheProof "ruleGEN_TY_pth" ctxtTypeQuant $ + do p <- toHTm "P: %'X . bool" + dTyForall <- defTY_FORALL + thm <- ruleCONV (convRAND convBETA) #<< ruleAP_THM dTyForall p + liftO $ ruleSYM thm +ruleGEN_TY _ _ = fail "ruleGEN_TY: not a small, type variable" + + +-- !! 'x. t ----> t [u/'x] +ruleSPEC_TY :: TypeQuantCtxt thry => HOLType -> HOLThm + -> HOL cls thry HOLThm +ruleSPEC_TY ty thm = + do p <- serve [typeQuant| P: % 'A. bool |] + x <- toHTy "'X" + pth <- ruleSPEC_TY_pth + case rand $ concl thm of + Just ab@TyAbs{} -> + (ruleCONV convTYBETA =<< + ruleMP (fromJust $ rulePINST [(x, ty)] [(p, ab)] pth) thm) "ruleSPEC_TY" + _ -> fail "ruleSPEC_TY: not a type abstraction" + where -- proves |- (!!) P ==> P [: 'X] + ruleSPEC_TY_pth :: TypeQuantCtxt thry + => HOL cls thry HOLThm + ruleSPEC_TY_pth = cacheProof "ruleSPEC_TY_pth" ctxtTypeQuant $ + do p <- toHTm "P: % 'A. bool" + x <- toHTy "'X" + tyForallP <- toHTm "(!!)(P: % 'A. bool)" + dTyForall <- defTY_FORALL + let th1 = fromRight $ ruleAP_THM dTyForall p + th2 <- ruleCONV convBETA #<< + primEQ_MP th1 =<< primASSUME tyForallP + th3 <- ruleCONV (convRAND convTYBETA) #<< primTYAPP x th2 + ruleDISCH_ALL =<< ruleEQT_ELIM th3 + +-- Basic boolean tactics +tacX_GEN_TY :: TypeQuantCtxt thry => HOLType -> Tactic cls thry +tacX_GEN_TY x'@(TyVar True _) (Goal asl w) = + do (x, bod) <- liftMaybe "tacX_GEN_TY: not a tyforall" $ destTyAll w + let avoids = foldr (union . typeVarsInThm . snd) (typeVarsInTerm w) asl + if x' `elem` avoids + then fail "tacX_GEN_TY: provided type is free in goal" + else (let afn = ruleCONV (convGEN_ALPHA_TY x) + bod' = inst [(x, x')] bod in + return . GS nullMeta [Goal asl bod'] $ justification afn) + "tacX_GEN_TY" + where justification afn _ [th] = afn =<< ruleGEN_TY x' th + justification _ _ _ = fail "tacX_GEN_TY: improper justification" +tacX_GEN_TY _ _ = + fail "tacX_GEN_TY: provided type is not a small type variable." + +tacGEN_TY :: TypeQuantCtxt thry => Tactic cls thry +tacGEN_TY g@(Goal asl w) = + do (x, _) <- liftMaybe "tacGEN_TY: not a tyforall" $ destTyAll w + let avoids = foldr (union . typeVarsInThm . snd) (typeVarsInTerm w) asl + x' = variantTyVar avoids x + tacX_GEN_TY x' g + +-- More advanced elimination tactics + +tacUTYPE_E :: (BasicConvs thry, BoolCtxt thry) => HOLType -> Tactic cls thry +tacUTYPE_E ty = tacASSUM_REWRITE (ruleTYBETA <#< primTYAPP ty) + +tacTYABS_E :: (BasicConvs thry, BoolCtxt thry) => Tactic cls thry +tacTYABS_E = tacASSUM_REWRITE $ \ thm -> + do tv <- liftMaybe ("tacTYABS_E: assumption not an equation of " ++ + "universal type") $ do (l, _) <- destEq $ concl thm + (tv, _) <- destUType $ typeOf l + return tv + ruleTYBETA #<< primTYAPP tv thm + +tacTYALL_ELIM :: (BasicConvs thry, TypeQuantCtxt thry) => HOLType + -> Tactic cls thry +tacTYALL_ELIM ty = tacASSUM_REWRITE (ruleSPEC_TY ty) + +tacTYALL_E :: (BasicConvs thry, TypeQuantCtxt thry) => Tactic cls thry +tacTYALL_E = tacASSUM_REWRITE $ \ thm -> + do tv <- liftMaybe ("tacTYALL_E: assumption does not have a universally " ++ + "quantified type") . liftM fst . destTyAll $ concl thm + ruleSPEC_TY tv thm + +tacTYABS :: Tactic cls thry +tacTYABS (Goal asl w@(TyAbs ltv lb := TyAbs rtv rb)) = + let lb' = inst [(ltv, tv)] lb + rb' = inst [(rtv, tv)] rb in + do w' <- mkEq lb' rb' + return $! GS nullMeta [Goal asl w'] justification + where avoids = foldr (union . typeVarsInThm . snd) (typeVarsInTerm w) asl + tv = variantTyVar avoids ltv + justification i [thm] =liftO $ + do ath <- primTYABS tv thm + bth <- ruleALPHA (concl ath) (instantiate i w) + primEQ_MP bth ath + justification _ _ = fail "tacTYABS: bad justification." +tacTYABS _ = fail "tacTYABS: not an equation of type abstractions." diff --git a/src/HaskHOL/Lib/TypeQuant/Context.hs b/src/HaskHOL/Lib/TypeQuant/Context.hs new file mode 100644 index 0000000..3cf2719 --- /dev/null +++ b/src/HaskHOL/Lib/TypeQuant/Context.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TypeSynonymInstances, + UndecidableInstances #-} +module HaskHOL.Lib.TypeQuant.Context + ( TypeQuantType + , TypeQuantCtxt + , ctxtTypeQuant + , typeQuant + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Equal +import HaskHOL.Lib.Simp + +import HaskHOL.Lib.Trivia.Context + +-- generate template types +extendTheory ctxtTrivia "TypeQuant" $ return () + +templateProvers 'ctxtTypeQuant + +-- have to manually write this, for now +type family TypeQuantCtxt a where + TypeQuantCtxt a = (TriviaCtxt a, TypeQuantContext a ~ 'True) + +type instance PolyTheory TypeQuantType b = TypeQuantCtxt b + +instance BasicConvs TypeQuantType where + basicConvs _ = + [("tybeta", ([str| ((\\ 'B. t):(% 'B. C)) [: 'A] |], convTYBETA))]