From 05922e067d7bc160a489471ce9782069611aafd0 Mon Sep 17 00:00:00 2001 From: Evan Austin Date: Tue, 17 Feb 2015 12:34:44 -0600 Subject: [PATCH] Initial move from the private to public repo. --- HaskHOL-Math.cabal | 91 ++ LICENSE | 24 + Setup.hs | 2 + src/HaskHOL/Lib/Arith.hs | 299 +++++ src/HaskHOL/Lib/Arith/A.hs | 7 + src/HaskHOL/Lib/Arith/A/Base.hs | 86 ++ src/HaskHOL/Lib/Arith/A/Context.hs | 55 + src/HaskHOL/Lib/Arith/Base.hs | 837 ++++++++++++++ src/HaskHOL/Lib/Arith/Context.hs | 33 + src/HaskHOL/Lib/CalcNum.hs | 1532 +++++++++++++++++++++++++ src/HaskHOL/Lib/CalcNum/Pre.hs | 270 +++++ src/HaskHOL/Lib/CalcNum/Pre2.hs | 287 +++++ src/HaskHOL/Lib/Grobner.hs | 3 + src/HaskHOL/Lib/IndTypes.hs | 625 ++++++++++ src/HaskHOL/Lib/IndTypes/A.hs | 9 + src/HaskHOL/Lib/IndTypes/A/Base.hs | 91 ++ src/HaskHOL/Lib/IndTypes/A/Context.hs | 45 + src/HaskHOL/Lib/IndTypes/A/Pre.hs | 50 + src/HaskHOL/Lib/IndTypes/B.hs | 9 + src/HaskHOL/Lib/IndTypes/B/Base.hs | 24 + src/HaskHOL/Lib/IndTypes/B/Context.hs | 34 + src/HaskHOL/Lib/IndTypes/B/Pre.hs | 832 ++++++++++++++ src/HaskHOL/Lib/IndTypes/Base.hs | 265 +++++ src/HaskHOL/Lib/IndTypes/Context.hs | 70 ++ src/HaskHOL/Lib/IndTypes/Pre.hs | 271 +++++ src/HaskHOL/Lib/Lists.hs | 100 ++ src/HaskHOL/Lib/Lists/A.hs | 7 + src/HaskHOL/Lib/Lists/A/Base.hs | 116 ++ src/HaskHOL/Lib/Lists/A/Context.hs | 54 + src/HaskHOL/Lib/Lists/Base.hs | 118 ++ src/HaskHOL/Lib/Lists/Context.hs | 30 + src/HaskHOL/Lib/Normalizer.hs | 715 ++++++++++++ src/HaskHOL/Lib/Nums.hs | 206 ++++ src/HaskHOL/Lib/Nums/A.hs | 7 + src/HaskHOL/Lib/Nums/A/Base.hs | 20 + src/HaskHOL/Lib/Nums/A/Context.hs | 32 + src/HaskHOL/Lib/Nums/B.hs | 7 + src/HaskHOL/Lib/Nums/B/Base.hs | 52 + src/HaskHOL/Lib/Nums/B/Context.hs | 34 + src/HaskHOL/Lib/Nums/Base.hs | 206 ++++ src/HaskHOL/Lib/Nums/Context.hs | 33 + src/HaskHOL/Lib/Pair.hs | 59 + src/HaskHOL/Lib/Pair/A.hs | 7 + src/HaskHOL/Lib/Pair/A/Base.hs | 47 + src/HaskHOL/Lib/Pair/A/Context.hs | 38 + src/HaskHOL/Lib/Pair/B.hs | 7 + src/HaskHOL/Lib/Pair/B/Base.hs | 59 + src/HaskHOL/Lib/Pair/B/Context.hs | 34 + src/HaskHOL/Lib/Pair/Base.hs | 131 +++ src/HaskHOL/Lib/Pair/C.hs | 7 + src/HaskHOL/Lib/Pair/C/Base.hs | 200 ++++ src/HaskHOL/Lib/Pair/C/Context.hs | 50 + src/HaskHOL/Lib/Pair/Context.hs | 39 + src/HaskHOL/Lib/Recursion.hs | 199 ++++ src/HaskHOL/Lib/WF.hs | 109 ++ src/HaskHOL/Lib/WF/Base.hs | 25 + src/HaskHOL/Lib/WF/Context.hs | 36 + src/HaskHOL/Math.hs | 70 ++ 58 files changed, 8705 insertions(+) create mode 100644 HaskHOL-Math.cabal create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 src/HaskHOL/Lib/Arith.hs create mode 100644 src/HaskHOL/Lib/Arith/A.hs create mode 100644 src/HaskHOL/Lib/Arith/A/Base.hs create mode 100644 src/HaskHOL/Lib/Arith/A/Context.hs create mode 100644 src/HaskHOL/Lib/Arith/Base.hs create mode 100644 src/HaskHOL/Lib/Arith/Context.hs create mode 100644 src/HaskHOL/Lib/CalcNum.hs create mode 100644 src/HaskHOL/Lib/CalcNum/Pre.hs create mode 100644 src/HaskHOL/Lib/CalcNum/Pre2.hs create mode 100644 src/HaskHOL/Lib/Grobner.hs create mode 100644 src/HaskHOL/Lib/IndTypes.hs create mode 100644 src/HaskHOL/Lib/IndTypes/A.hs create mode 100644 src/HaskHOL/Lib/IndTypes/A/Base.hs create mode 100644 src/HaskHOL/Lib/IndTypes/A/Context.hs create mode 100644 src/HaskHOL/Lib/IndTypes/A/Pre.hs create mode 100644 src/HaskHOL/Lib/IndTypes/B.hs create mode 100644 src/HaskHOL/Lib/IndTypes/B/Base.hs create mode 100644 src/HaskHOL/Lib/IndTypes/B/Context.hs create mode 100644 src/HaskHOL/Lib/IndTypes/B/Pre.hs create mode 100644 src/HaskHOL/Lib/IndTypes/Base.hs create mode 100644 src/HaskHOL/Lib/IndTypes/Context.hs create mode 100644 src/HaskHOL/Lib/IndTypes/Pre.hs create mode 100644 src/HaskHOL/Lib/Lists.hs create mode 100644 src/HaskHOL/Lib/Lists/A.hs create mode 100644 src/HaskHOL/Lib/Lists/A/Base.hs create mode 100644 src/HaskHOL/Lib/Lists/A/Context.hs create mode 100644 src/HaskHOL/Lib/Lists/Base.hs create mode 100644 src/HaskHOL/Lib/Lists/Context.hs create mode 100644 src/HaskHOL/Lib/Normalizer.hs create mode 100644 src/HaskHOL/Lib/Nums.hs create mode 100644 src/HaskHOL/Lib/Nums/A.hs create mode 100644 src/HaskHOL/Lib/Nums/A/Base.hs create mode 100644 src/HaskHOL/Lib/Nums/A/Context.hs create mode 100644 src/HaskHOL/Lib/Nums/B.hs create mode 100644 src/HaskHOL/Lib/Nums/B/Base.hs create mode 100644 src/HaskHOL/Lib/Nums/B/Context.hs create mode 100644 src/HaskHOL/Lib/Nums/Base.hs create mode 100644 src/HaskHOL/Lib/Nums/Context.hs create mode 100644 src/HaskHOL/Lib/Pair.hs create mode 100644 src/HaskHOL/Lib/Pair/A.hs create mode 100644 src/HaskHOL/Lib/Pair/A/Base.hs create mode 100644 src/HaskHOL/Lib/Pair/A/Context.hs create mode 100644 src/HaskHOL/Lib/Pair/B.hs create mode 100644 src/HaskHOL/Lib/Pair/B/Base.hs create mode 100644 src/HaskHOL/Lib/Pair/B/Context.hs create mode 100644 src/HaskHOL/Lib/Pair/Base.hs create mode 100644 src/HaskHOL/Lib/Pair/C.hs create mode 100644 src/HaskHOL/Lib/Pair/C/Base.hs create mode 100644 src/HaskHOL/Lib/Pair/C/Context.hs create mode 100644 src/HaskHOL/Lib/Pair/Context.hs create mode 100644 src/HaskHOL/Lib/Recursion.hs create mode 100644 src/HaskHOL/Lib/WF.hs create mode 100644 src/HaskHOL/Lib/WF/Base.hs create mode 100644 src/HaskHOL/Lib/WF/Context.hs create mode 100644 src/HaskHOL/Math.hs diff --git a/HaskHOL-Math.cabal b/HaskHOL-Math.cabal new file mode 100644 index 0000000..d9420cc --- /dev/null +++ b/HaskHOL-Math.cabal @@ -0,0 +1,91 @@ +name: haskhol-math +version: 0.0.1 +synopsis: HaskHOL libraries for mathematical and structural 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 + , parsec >=3.1 + , pretty >=1.1 + , vector >= 0.10 + , haskhol-core >=1.1 + , haskhol-deductive >=0.1 + + exposed-modules: + HaskHOL.Math + HaskHOL.Lib.Pair + HaskHOL.Lib.Nums + HaskHOL.Lib.Recursion + HaskHOL.Lib.Arith + HaskHOL.Lib.WF + HaskHOL.Lib.CalcNum + HaskHOL.Lib.Normalizer + HaskHOL.Lib.Grobner + HaskHOL.Lib.IndTypes + HaskHOL.Lib.Lists + exposed: True + buildable: True + hs-source-dirs: src + other-modules: + HaskHOL.Lib.Pair.A + HaskHOL.Lib.Pair.A.Base + HaskHOL.Lib.Pair.A.Context + HaskHOL.Lib.Pair.B + HaskHOL.Lib.Pair.B.Base + HaskHOL.Lib.Pair.B.Context + HaskHOL.Lib.Pair.C + HaskHOL.Lib.Pair.C.Base + HaskHOL.Lib.Pair.C.Context + HaskHOL.Lib.Pair.Base + HaskHOL.Lib.Pair.Context + HaskHOL.Lib.Nums.A + HaskHOL.Lib.Nums.A.Base + HaskHOL.Lib.Nums.A.Context + HaskHOL.Lib.Nums.B + HaskHOL.Lib.Nums.B.Base + HaskHOL.Lib.Nums.B.Context + HaskHOL.Lib.Nums.Base + HaskHOL.Lib.Nums.Context + HaskHOL.Lib.Arith.A + HaskHOL.Lib.Arith.A.Base + HaskHOL.Lib.Arith.A.Context + HaskHOL.Lib.Arith.Base + HaskHOL.Lib.Arith.Context + HaskHOL.Lib.WF.Base + HaskHOL.Lib.WF.Context + HaskHOL.Lib.CalcNum.Pre + HaskHOL.Lib.CalcNum.Pre2 + HaskHOL.Lib.IndTypes.A + HaskHOL.Lib.IndTypes.A.Base + HaskHOL.Lib.IndTypes.A.Context + HaskHOL.Lib.IndTypes.A.Pre + HaskHOL.Lib.IndTypes.B + HaskHOL.Lib.IndTypes.B.Base + HaskHOL.Lib.IndTypes.B.Context + HaskHOL.Lib.IndTypes.B.Pre + HaskHOL.Lib.IndTypes.Base + HaskHOL.Lib.IndTypes.Context + HaskHOL.Lib.IndTypes.Pre + HaskHOL.Lib.Lists.A + HaskHOL.Lib.Lists.A.Base + HaskHOL.Lib.Lists.A.Context + HaskHOL.Lib.Lists.Base + HaskHOL.Lib.Lists.Context + + ghc-prof-options: -prof -fprof-auto + ghc-options: -Wall + 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/Lib/Arith.hs b/src/HaskHOL/Lib/Arith.hs new file mode 100644 index 0000000..f6c6a6c --- /dev/null +++ b/src/HaskHOL/Lib/Arith.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE PatternSynonyms #-} +{-| + Module: HaskHOL.Lib.Arith + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Arith + ( ArithType + , ArithCtxt + , defPRE + , defADD + , defMULT + , defEXP + , defLE + , defLT + , defGE + , defGT + , defMAX + , defMIN + , defEVEN + , defODD + , defSUB + , defFACT + , thmADD_0 -- stage2 + , thmADD_SUC + , thmLE_SUC_LT + , thmLT_SUC_LE + , thmLE_0 + , wfNUM' + , thmSUB_0 + , thmSUB_PRESUC + , thmLE_REFL + , thmNOT_EVEN + , thmNOT_ODD + , thmADD_CLAUSES -- stage3 + , thmLE_SUC + , thmLT_SUC + , wopNUM + , thmSUB_SUC + , thmEVEN_OR_ODD + , thmEVEN_AND_ODD + , thmLET_CASES + , thmEQ_IMP_LE + , thmADD_SYM -- stage4 + , thmEQ_ADD_LCANCEL + , thmBIT0 + , thmMULT_0 + , thmADD_ASSOC + , thmADD_EQ_0 + , thmLT_0 + , thmLT_ADD + , thmADD_SUB + , thmLT_REFL + , thmSUB_EQ_0 + , thmLE_CASES + , thmLE_ANTISYM + , thmLET_ANTISYM + , thmEVEN_ADD + , thmLE_TRANS + , thmSUB_REFL + , thmLE_ADD + , thmLTE_CASES + , thmSUB_ADD_LCANCEL + , thmBIT0_THM -- stage5 + , thmBIT1 + , thmMULT_SUC + , thmNOT_LE + , thmNOT_LT + , thmLE_EXISTS + , thmLT_EXISTS + , thmLT_ADDR + , thmADD_SUB2 + , thmLTE_ANTISYM + , thmLE_LT + , thmARITH_ZERO + , thmADD_AC + , thmODD_ADD + , thmEQ_ADD_RCANCEL + , thmLTE_TRANS + , thmADD_SUBR2 + , thmEQ_ADD_LCANCEL_0 + , thmLE_ADDR + , thmBIT1_THM -- stage6 + , thmLT_ADD_LCANCEL + , thmLE_ADD_LCANCEL + , thmARITH_SUC + , thmARITH_PRE + , thmARITH_ADD + , thmARITH_EVEN + , thmARITH_ODD + , thmLE_ADD2 + , thmADD_SUBR + , thmLT_LE + , thmLET_ADD2 + , thmADD1 -- stage7 + , thmMULT_CLAUSES + , thmLT_IMP_LE + , thmLE_ADD_RCANCEL + , thmLTE_ADD2 + , thmMULT_SYM -- stage8 + , thmLEFT_ADD_DISTRIB + , thmLE_MULT_LCANCEL + , thmLT_MULT_LCANCEL + , thmMULT_EQ_0 + , thmEQ_MULT_LCANCEL + , thmEVEN_MULT + , thmEXP_EQ_0 + , thmLT_ADD2 + , thmRIGHT_ADD_DISTRIB -- stage9 + , thmLEFT_SUB_DISTRIB + , thmEVEN_DOUBLE + , thmLE_MULT_RCANCEL + , thmDIVMOD_EXIST -- stage10 + , thmMULT_2 + , thmDIVMOD_EXIST_0 + , specDIVISION_0 + , defMinimal + , thmARITH_MULT + , thmMULT_ASSOC + , thmLE_MULT2 + , thmRIGHT_SUB_DISTRIB + , thmARITH_LE -- stage11 + , thmEXP_ADD + , thmMULT_AC + , thmARITH_LT -- stage12 + , thmARITH_GE + , thmARITH_EQ + , thmONE -- here + , thmTWO + , thmARITH_EXP + , thmARITH_GT + , thmARITH_SUB + , thmARITH_0 + , thmBITS_INJ + , thmSUB_ELIM + , thmEXP_2 + , convNUM_CANCEL + , ruleLE_IMP + , thmDIVISION + ) where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (getSpecification) + +import HaskHOL.Lib.Nums + +import HaskHOL.Lib.Arith.Base +import HaskHOL.Lib.Arith.Context + +specDIVISION_0 :: ArithCtxt thry => HOL cls thry HOLThm +specDIVISION_0 = cacheProof "specDIVISION_0" ctxtArith $ + getSpecification ["DIV", "MOD"] + +defMinimal :: ArithCtxt thry => HOL cls thry HOLThm +defMinimal = cacheProof "defMinimal" ctxtArith $ getDefinition "minimal" + + +thmONE :: (BasicConvs thry, ArithCtxt thry) => HOL cls thry HOLThm +thmONE = cacheProof "thmONE" ctxtArith $ + prove "1 = SUC 0" $ + tacREWRITE [thmBIT1, ruleREWRITE [defNUMERAL] thmADD_CLAUSES, defNUMERAL] + +thmTWO :: (BasicConvs thry, ArithCtxt thry) => HOL cls thry HOLThm +thmTWO = cacheProof "thmTWO" ctxtArith $ + prove "2 = SUC 1" $ + tacREWRITE [ thmBIT0, thmBIT1 + , ruleREWRITE [defNUMERAL] thmADD_CLAUSES, defNUMERAL ] + +thmARITH_GT :: (BasicConvs thry, ArithCtxt thry) => HOL cls thry HOLThm +thmARITH_GT = cacheProof "thmARITH_GT" ctxtArith $ + ruleREWRITE [ruleGSYM defGE, ruleGSYM defGT] thmARITH_LT + +thmARITH_SUB :: (BasicConvs thry, ArithCtxt thry) => HOL cls thry HOLThm +thmARITH_SUB = cacheProof "thmARITH_SUB" ctxtArith . + prove [str| (!m n. NUMERAL m - NUMERAL n = NUMERAL(m - n)) /\ + (_0 - _0 = _0) /\ + (!n. _0 - BIT0 n = _0) /\ + (!n. _0 - BIT1 n = _0) /\ + (!n. BIT0 n - _0 = BIT0 n) /\ + (!n. BIT1 n - _0 = BIT1 n) /\ + (!m n. BIT0 m - BIT0 n = BIT0 (m - n)) /\ + (!m n. BIT0 m - BIT1 n = PRE(BIT0 (m - n))) /\ + (!m n. BIT1 m - BIT0 n = if n <= m then BIT1 (m - n) else _0) /\ + (!m n. BIT1 m - BIT1 n = BIT0 (m - n)) |] $ + tacREWRITE [defNUMERAL, ruleDENUMERAL thmSUB_0] `_THEN` + tacPURE_REWRITE [thmBIT0, thmBIT1] `_THEN` + tacREWRITE [ ruleGSYM thmMULT_2, thmSUB_SUC, thmLEFT_SUB_DISTRIB ] `_THEN` + tacREWRITE [defSUB] `_THEN` _REPEAT tacGEN `_THEN` tacCOND_CASES `_THEN` + tacREWRITE [ruleDENUMERAL thmSUB_EQ_0] `_THEN` + tacRULE_ASSUM (ruleREWRITE [thmNOT_LE]) `_THEN` + tacASM_REWRITE [thmLE_SUC_LT, thmLT_MULT_LCANCEL, thmARITH_EQ] `_THEN` + _POP_ASSUM (_CHOOSE_THEN tacSUBST1 . ruleREWRITE [thmLE_EXISTS]) `_THEN` + tacREWRITE [thmADD1, thmLEFT_ADD_DISTRIB] `_THEN` + tacREWRITE [thmADD_SUB2, ruleGSYM thmADD_ASSOC] + +thmARITH_EXP :: (BasicConvs thry, ArithCtxt thry) => HOL cls thry HOLThm +thmARITH_EXP = cacheProof "thmARITH_EXP" ctxtArith $ + prove [str| (!m n. (NUMERAL m) EXP (NUMERAL n) = NUMERAL(m EXP n)) /\ + (_0 EXP _0 = BIT1 _0) /\ + (!m. (BIT0 m) EXP _0 = BIT1 _0) /\ + (!m. (BIT1 m) EXP _0 = BIT1 _0) /\ + (!n. _0 EXP (BIT0 n) = (_0 EXP n) * (_0 EXP n)) /\ + (!m n. (BIT0 m) EXP (BIT0 n) = + ((BIT0 m) EXP n) * ((BIT0 m) EXP n)) /\ + (!m n. (BIT1 m) EXP (BIT0 n) = + ((BIT1 m) EXP n) * ((BIT1 m) EXP n)) /\ + (!n. _0 EXP (BIT1 n) = _0) /\ + (!m n. (BIT0 m) EXP (BIT1 n) = + BIT0 m * ((BIT0 m) EXP n) * ((BIT0 m) EXP n)) /\ + (!m n. (BIT1 m) EXP (BIT1 n) = + BIT1 m * ((BIT1 m) EXP n) * ((BIT1 m) EXP n)) |] $ + tacREWRITE [defNUMERAL] `_THEN` _REPEAT tacSTRIP `_THEN` + _TRY (tacGEN_REWRITE (convLAND . convRAND) [thmBIT0, thmBIT1]) `_THEN` + tacREWRITE [ ruleDENUMERAL defEXP, ruleDENUMERAL thmMULT_CLAUSES + , thmEXP_ADD ] + +thmARITH_0 :: (BasicConvs thry, ArithCtxt thry) => HOL cls thry HOLThm +thmARITH_0 = cacheProof "thmARITH_0" ctxtArith $ + ruleMESON [defNUMERAL, thmADD_CLAUSES] [str| m + _0 = m /\ _0 + n = n |] + +thmBITS_INJ :: (BasicConvs thry, ArithCtxt thry) => HOL cls thry HOLThm +thmBITS_INJ = cacheProof "thmBITS_INJ" ctxtArith . + prove [str| (BIT0 m = BIT0 n <=> m = n) /\ + (BIT1 m = BIT1 n <=> m = n) |] $ + tacREWRITE [thmBIT0, thmBIT1] `_THEN` + tacREWRITE [ruleGSYM thmMULT_2] `_THEN` + tacREWRITE [thmSUC_INJ, thmEQ_MULT_LCANCEL, thmARITH_EQ] + +thmSUB_ELIM :: (BasicConvs thry, ArithCtxt thry) => HOL cls thry HOLThm +thmSUB_ELIM = cacheProof "thmSUB_ELIM" ctxtArith $ + prove [str| P(a - b) <=> !d. a = b + d \/ a < b /\ d = 0 ==> P d |] $ + tacDISJ_CASES (ruleSPECL ["a:num", "b:num"] =<< thmLTE_CASES) `_THENL` + [ tacASM_MESON [thmNOT_LT, thmSUB_EQ_0, thmLT_IMP_LE, thmLE_ADD] + , _ALL + ] `_THEN` + _FIRST_ASSUM (_X_CHOOSE_THEN "e:num" tacSUBST1 . + ruleREWRITE [thmLE_EXISTS]) `_THEN` + tacSIMP [ thmADD_SUB2, ruleGSYM thmNOT_LE + , thmLE_ADD, thmEQ_ADD_LCANCEL ] `_THEN` + tacMESON_NIL + +thmEXP_2 :: (BasicConvs thry, ArithCtxt thry) => HOL cls thry HOLThm +thmEXP_2 = cacheProof "thmEXP_2" ctxtArith . + prove "!n. n EXP 2 = n * n" $ + tacREWRITE [ thmBIT0_THM, thmBIT1_THM, defEXP + , thmEXP_ADD, thmMULT_CLAUSES, thmADD_CLAUSES ] + +convNUM_CANCEL :: (BasicConvs thry, ArithCtxt thry) => Conversion cls thry +convNUM_CANCEL = Conv $ \ tm -> + do tmAdd <- serve [arith| (+) |] + tmeq <- serve [arith| (=) :num->num->bool |] + let (l, r) = fromJust $ destEq tm + lats = sort (<=) $ binops tmAdd l + rats = sort (<=) $ binops tmAdd r + (i, lats', rats') = minter [] [] [] lats rats + let l' = fromRight $ listMkBinop tmAdd (i ++ lats') + r' = fromRight $ listMkBinop tmAdd (i ++ rats') + lth <- ruleAC =<< mkEq l l' + rth <- ruleAC =<< mkEq r r' + let eth = fromRight $ liftM1 primMK_COMB (ruleAP_TERM tmeq lth) rth + ruleGEN_REWRITE (convRAND . _REPEAT) + [thmEQ_ADD_LCANCEL, thmEQ_ADD_LCANCEL_0, convNUM_CANCEL_pth] eth + where minter :: [HOLTerm] -> [HOLTerm] -> [HOLTerm] -> [HOLTerm] -> [HOLTerm] + -> ([HOLTerm], [HOLTerm], [HOLTerm]) + minter i l1' l2' [] l2 = (i, l1', l2' ++ l2) + minter i l1' l2' l1 [] = (i, l1 ++ l1', l2') + minter i l1' l2' l1@(h1:t1) l2@(h2:t2) + | h1 == h2 = minter (h1:i) l1' l2' t1 t2 + | h1 < h2 = minter i (h1:l1') l2' t1 l2 + | otherwise = minter i l1' (h2:l2') l1 t2 + + ruleAC :: (BasicConvs thry, ArithCtxt thry) => HOLTerm + -> HOL cls thry HOLThm + ruleAC = runConv (convAC thmADD_AC) + + convNUM_CANCEL_pth :: (BasicConvs thry, ArithCtxt thry) + => HOL cls thry HOLThm + convNUM_CANCEL_pth = cacheProof "convNUM_CANCEL_pth" ctxtArith $ + ruleGEN_REWRITE (funpow 2 convBINDER . convLAND) + [thmEQ_SYM_EQ] =<< thmEQ_ADD_LCANCEL_0 + +ruleLE_IMP :: (BasicConvs thry, ArithCtxt thry, HOLThmRep thm cls thry) => thm + -> HOL cls thry HOLThm +ruleLE_IMP th = + ruleGEN_ALL =<< ruleMATCH_MP ruleLE_IMP_pth =<< ruleSPEC_ALL th + where ruleLE_IMP_pth :: (BasicConvs thry, ArithCtxt thry) + => HOL cls thry HOLThm + ruleLE_IMP_pth = cacheProof "ruleLE_IMP_pth" ctxtArith $ + rulePURE_ONCE_REWRITE[thmIMP_CONJ] =<< thmLE_TRANS + +thmDIVISION :: (BasicConvs thry, ArithCtxt thry) => HOL cls thry HOLThm +thmDIVISION = cacheProof "thmDIVISION" ctxtArith . + prove [str| !m n. ~(n = 0) ==> + (m = m DIV n * n + m MOD n) /\ m MOD n < n |] $ + tacMESON [specDIVISION_0] diff --git a/src/HaskHOL/Lib/Arith/A.hs b/src/HaskHOL/Lib/Arith/A.hs new file mode 100644 index 0000000..b149480 --- /dev/null +++ b/src/HaskHOL/Lib/Arith/A.hs @@ -0,0 +1,7 @@ +module HaskHOL.Lib.Arith.A + ( module HaskHOL.Lib.Arith.A.Base + , module HaskHOL.Lib.Arith.A.Context + ) where + +import HaskHOL.Lib.Arith.A.Base +import HaskHOL.Lib.Arith.A.Context diff --git a/src/HaskHOL/Lib/Arith/A/Base.hs b/src/HaskHOL/Lib/Arith/A/Base.hs new file mode 100644 index 0000000..2b4a971 --- /dev/null +++ b/src/HaskHOL/Lib/Arith/A/Base.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ConstraintKinds, QuasiQuotes #-} +module HaskHOL.Lib.Arith.A.Base where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (getDefinition, newDefinition) + +import HaskHOL.Lib.Pair +import HaskHOL.Lib.Nums +import HaskHOL.Lib.Recursion + + +defPRE' :: (BasicConvs thry, NumsCtxt thry) => HOL Theory thry HOLThm +defPRE' = newRecursiveDefinition "PRE" recursionNUM + [str| (PRE 0 = 0) /\ (!n. PRE (SUC n) = n) |] + +defADD' :: (BasicConvs thry, NumsCtxt thry) => HOL Theory thry HOLThm +defADD' = newRecursiveDefinition "+" recursionNUM + [str| (!n. 0 + n = n) /\ + (!m n. (SUC m) + n = SUC(m + n)) |] + +defMULT' :: (BasicConvs thry, NumsCtxt thry) => HOL Theory thry HOLThm +defMULT' = newRecursiveDefinition "*" recursionNUM + [str| (!n. 0 * n = 0) /\ + (!m n. (SUC m) * n = (m * n) + n) |] + + +defEXP' :: (BasicConvs thry, NumsCtxt thry) => HOL Theory thry HOLThm +defEXP' = newRecursiveDefinition "EXP" recursionNUM + [str| (!m. m EXP 0 = 1) /\ + (!m n. m EXP (SUC n) = m * (m EXP n)) |] + + +defLE' :: (BasicConvs thry, NumsCtxt thry) => HOL Theory thry HOLThm +defLE' = newRecursiveDefinition "<=" recursionNUM + [str| (!m. (m <= 0) <=> (m = 0)) /\ + (!m n. (m <= SUC n) <=> (m = SUC n) \/ (m <= n)) |] + + +defLT' :: (BasicConvs thry, NumsCtxt thry) => HOL Theory thry HOLThm +defLT' = newRecursiveDefinition "<" recursionNUM + [str| (!m. (m < 0) <=> F) /\ + (!m n. (m < SUC n) <=> (m = n) \/ (m < n)) |] + + +defGE' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defGE' = newDefinition ">=" + [str| m >= n <=> n <= m |] + + +defGT' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defGT' = newDefinition ">" + [str| m > n <=> n < m |] + + +defMAX' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defMAX' = newDefinition "MAX" + [str| !m n. MAX m n = if m <= n then n else m |] + + +defMIN' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defMIN' = newDefinition "MIN" + [str| !m n. MIN m n = if m <= n then m else n |] + + +defEVEN' :: (BasicConvs thry, NumsCtxt thry) => HOL Theory thry HOLThm +defEVEN' = newRecursiveDefinition "EVEN" recursionNUM + [str| (EVEN 0 <=> T) /\ + (!n. EVEN (SUC n) <=> ~(EVEN n)) |] + + +defODD' :: (BasicConvs thry, NumsCtxt thry) => HOL Theory thry HOLThm +defODD' = newRecursiveDefinition "ODD" recursionNUM + [str| (ODD 0 <=> F) /\ + (!n. ODD (SUC n) <=> ~(ODD n)) |] + + +defSUB' :: (BasicConvs thry, NumsCtxt thry) => HOL Theory thry HOLThm +defSUB' = newRecursiveDefinition "-" recursionNUM + [str| (!m. m - 0 = m) /\ + (!m n. m - (SUC n) = PRE(m - n)) |] + + +defFACT' :: (BasicConvs thry, NumsCtxt thry) => HOL Theory thry HOLThm +defFACT' = newRecursiveDefinition "FACT" recursionNUM + [str| (FACT 0 = 1) /\ + (!n. FACT (SUC n) = (SUC n) * FACT(n)) |] diff --git a/src/HaskHOL/Lib/Arith/A/Context.hs b/src/HaskHOL/Lib/Arith/A/Context.hs new file mode 100644 index 0000000..5ac2205 --- /dev/null +++ b/src/HaskHOL/Lib/Arith/A/Context.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TemplateHaskell, + TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +module HaskHOL.Lib.Arith.A.Context + ( ArithAType + , ArithACtxt + , ctxtArithA + , arithA + ) where + +import HaskHOL.Core +import HaskHOL.Deductive +import HaskHOL.Lib.Pair + +import HaskHOL.Lib.Nums.Context +import HaskHOL.Lib.Arith.A.Base + +-- generate template types +extendTheory ctxtNums "ArithA" $ + do mapM_ parseAsInfix [ ("<", (12, "right")) + , ("<=", (12, "right")) + , (">", (12, "right")) + , (">=",(12,"right")) + , ("+",(16, "right")) + , ("-", (18, "left")) + , ("*", (20,"right")) + , ("EXP", (24, "left")) + , ("DIV", (22, "left")) + , ("MOD", (22, "left")) + ] + sequence_ [ defPRE' + , defADD' + , defMULT' + , defEXP' + , defLE' + , defLT' + , defGE' + , defGT' + , defMAX' + , defMIN' + , defEVEN' + , defODD' + , defSUB' + , defFACT' + ] + +templateProvers 'ctxtArithA + +-- have to manually write this, for now +type family ArithACtxt a where + ArithACtxt a = (NumsCtxt a, ArithAContext a ~ True) + +type instance PolyTheory ArithAType b = ArithACtxt b + +instance BasicConvs ArithAType where + basicConvs _ = basicConvs (undefined :: PairType) diff --git a/src/HaskHOL/Lib/Arith/Base.hs b/src/HaskHOL/Lib/Arith/Base.hs new file mode 100644 index 0000000..376d572 --- /dev/null +++ b/src/HaskHOL/Lib/Arith/Base.hs @@ -0,0 +1,837 @@ +module HaskHOL.Lib.Arith.Base where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (getDefinition, getSpecification, + newSpecification, newDefinition) + +import HaskHOL.Lib.Pair +import HaskHOL.Lib.Nums +import HaskHOL.Lib.Recursion +import HaskHOL.Lib.Arith.A + +defPRE :: ArithACtxt thry => HOL cls thry HOLThm +defPRE = cacheProof "defPRE" ctxtArithA $ getRecursiveDefinition "PRE" + +defADD :: ArithACtxt thry => HOL cls thry HOLThm +defADD = cacheProof "defADD" ctxtArithA $ getRecursiveDefinition "+" + +defMULT :: ArithACtxt thry => HOL cls thry HOLThm +defMULT = cacheProof "defMULT" ctxtArithA $ getRecursiveDefinition "*" + +defEXP :: ArithACtxt thry => HOL cls thry HOLThm +defEXP = cacheProof "defEXP" ctxtArithA $ getRecursiveDefinition "EXP" + +defLE :: ArithACtxt thry => HOL cls thry HOLThm +defLE = cacheProof "defLE" ctxtArithA $ getRecursiveDefinition "<=" + +defLT :: ArithACtxt thry => HOL cls thry HOLThm +defLT = cacheProof "defLT" ctxtArithA $ getRecursiveDefinition "<" + +defGE :: ArithACtxt thry => HOL cls thry HOLThm +defGE = cacheProof "defGE" ctxtArithA $ getDefinition ">=" + +defGT :: ArithACtxt thry => HOL cls thry HOLThm +defGT = cacheProof "defGT" ctxtArithA $ getDefinition ">" + +defMAX :: ArithACtxt thry => HOL cls thry HOLThm +defMAX = cacheProof "defMAX" ctxtArithA $ getDefinition "MAX" + +defMIN :: ArithACtxt thry => HOL cls thry HOLThm +defMIN = cacheProof "defMIN" ctxtArithA $ getDefinition "MIN" + +defEVEN :: ArithACtxt thry => HOL cls thry HOLThm +defEVEN = cacheProof "defEVEN" ctxtArithA $ getRecursiveDefinition "EVEN" + +defODD :: ArithACtxt thry => HOL cls thry HOLThm +defODD = cacheProof "defODD" ctxtArithA $ getRecursiveDefinition "ODD" + +defSUB :: ArithACtxt thry => HOL cls thry HOLThm +defSUB = cacheProof "defSUB" ctxtArithA $ getRecursiveDefinition "-" + +defFACT :: ArithACtxt thry => HOL cls thry HOLThm +defFACT = cacheProof "defFACT" ctxtArithA $ getRecursiveDefinition "FACT" + + +thmADD_0 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmADD_0 = cacheProof "thmADD_0" ctxtArithA $ + prove "!m. m + 0 = m" $ + tacINDUCT `_THEN` tacASM_REWRITE [defADD] + +thmADD_SUC :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmADD_SUC = cacheProof "thmADD_SUC" ctxtArithA $ + prove "!m n. m + (SUC n) = SUC (m + n)" $ + tacINDUCT `_THEN` tacASM_REWRITE [defADD] + +thmLE_SUC_LT :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_SUC_LT = cacheProof "thmLE_SUC_LT" ctxtArithA $ + prove "!m n. (SUC m <= n) <=> (m < n)" $ + tacGEN `_THEN` tacINDUCT `_THEN` + tacASM_REWRITE [defLE, defLT, thmNOT_SUC, thmSUC_INJ] + +thmLT_SUC_LE :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLT_SUC_LE = cacheProof "thmLT_SUC_LE" ctxtArithA $ + prove "!m n. (m < SUC n) <=> (m <= n)" $ + tacGEN `_THEN` tacINDUCT `_THEN` tacONCE_REWRITE [defLT, defLE] `_THEN` + tacASM_REWRITE_NIL `_THEN` tacREWRITE [defLT] + +thmLE_0 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_0 = cacheProof "thmLE_0" ctxtArithA $ + prove "!n. 0 <= n" $ + tacINDUCT `_THEN` tacASM_REWRITE [defLE] + +wfNUM' :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +wfNUM' = cacheProof "wfNUM'" ctxtArithA $ + prove "!P. (!n. (!m. m < n ==> P m) ==> P n) ==> !n. P n" $ + tacGEN `_THEN` + tacMP (ruleSPEC "\\n. !m. m < n ==> P m" inductionNUM) `_THEN` + tacREWRITE [defLT, thmBETA] `_THEN` tacMESON [defLT] + +thmSUB_0 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmSUB_0 = cacheProof "thmSUB_0" ctxtArithA $ + prove [str| !m. (0 - m = 0) /\ (m - 0 = m) |] $ + tacREWRITE [defSUB] `_THEN` tacINDUCT `_THEN` + tacASM_REWRITE [defSUB, defPRE] + +thmSUB_PRESUC :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmSUB_PRESUC = cacheProof "thmSUB_PRESUC" ctxtArithA $ + prove "!m n. PRE(SUC m - n) = m - n" $ + tacGEN `_THEN` tacINDUCT `_THEN` tacASM_REWRITE [defSUB, defPRE] + +thmLE_REFL :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_REFL = cacheProof "thmLE_REFL" ctxtArithA $ + prove "!n. n <= n" $ tacINDUCT `_THEN` tacREWRITE [defLE] + +thmNOT_EVEN :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmNOT_EVEN = cacheProof "thmNOT_EVEN" ctxtArithA $ + prove "!n. ~(EVEN n) <=> ODD n" $ + tacINDUCT `_THEN` tacASM_REWRITE [defEVEN, defODD] + +thmNOT_ODD :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmNOT_ODD = cacheProof "thmNOT_ODD" ctxtArithA $ + prove "!n. ~(ODD n) <=> EVEN n" $ + tacINDUCT `_THEN` tacASM_REWRITE [defEVEN, defODD] + +thmADD_CLAUSES :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmADD_CLAUSES = cacheProof "thmADD_CLAUSES" ctxtArithA $ + prove [str| (!n. 0 + n = n) /\ + (!m. m + 0 = m) /\ + (!m n. (SUC m) + n = SUC(m + n)) /\ + (!m n. m + (SUC n) = SUC(m + n)) |] $ + tacREWRITE [defADD, thmADD_0, thmADD_SUC] + +thmLE_SUC :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_SUC = cacheProof "thmLE_SUC" ctxtArithA $ + prove "!m n. (SUC m <= SUC n) <=> (m <= n)" $ + tacREWRITE [thmLE_SUC_LT, thmLT_SUC_LE] + +thmLT_SUC :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLT_SUC = cacheProof "thmLT_SUC" ctxtArithA $ + prove "!m n. (SUC m < SUC n) <=> (m < n)" $ + tacREWRITE [thmLT_SUC_LE, thmLE_SUC_LT] + +wopNUM :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +wopNUM = cacheProof "wopNUM" ctxtArithA $ + prove [str| !P. (?n. P n) <=> (?n. P(n) /\ !m. m < n ==> ~P(m)) |] $ + tacGEN `_THEN` tacEQ `_THENL` [_ALL, tacMESON_NIL] `_THEN` + tacCONV convCONTRAPOS `_THEN` tacREWRITE [thmNOT_EXISTS] `_THEN` + tacDISCH `_THEN` tacMATCH_MP wfNUM' `_THEN` tacASM_MESON_NIL + +thmSUB_SUC :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmSUB_SUC = cacheProof "thmSUB_SUC" ctxtArithA $ + prove "!m n. SUC m - SUC n = m - n" $ + _REPEAT tacINDUCT `_THEN` + tacASM_REWRITE [defSUB, defPRE, thmSUB_PRESUC] + +thmEVEN_OR_ODD :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmEVEN_OR_ODD = cacheProof "thmEVEN_OR_ODD" ctxtArithA $ + prove [str| !n. EVEN n \/ ODD n |] $ + tacINDUCT `_THEN` + tacREWRITE [defEVEN, defODD, thmNOT_EVEN, thmNOT_ODD] `_THEN` + tacONCE_REWRITE [thmDISJ_SYM] `_THEN` tacASM_REWRITE_NIL + +thmEVEN_AND_ODD :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmEVEN_AND_ODD = cacheProof "thmEVEN_AND_ODD" ctxtArithA $ + prove [str| !n. ~(EVEN n /\ ODD n) |] $ + tacREWRITE [ruleGSYM thmNOT_EVEN, ruleITAUT [str| ~(p /\ ~p) |]] + +thmLET_CASES :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLET_CASES = cacheProof "thmLET_CASES" ctxtArithA $ + prove [str| !m n. m <= n \/ n < m |] $ + _REPEAT tacINDUCT `_THEN` + tacASM_REWRITE [thmLE_SUC_LT, thmLT_SUC_LE, thmLE_0] + +thmEQ_IMP_LE :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmEQ_IMP_LE = cacheProof "thmEQ_IMP_LE" ctxtArithA $ + prove "!m n. (m = n) ==> m <= n" $ + _REPEAT tacSTRIP `_THEN` tacASM_REWRITE [thmLE_REFL] + +thmADD_SYM :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmADD_SYM = cacheProof "thmADD_SYM" ctxtArithA $ + prove "!m n. m + n = n + m" $ + tacINDUCT `_THEN` tacASM_REWRITE [thmADD_CLAUSES] + +thmEQ_ADD_LCANCEL :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmEQ_ADD_LCANCEL = cacheProof "thmEQ_ADD_LCANCEL" ctxtArithA $ + prove "!m n p. (m + n = m + p) <=> (n = p)" $ + tacINDUCT `_THEN` tacASM_REWRITE [thmADD_CLAUSES, thmSUC_INJ] + +thmBIT0 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmBIT0 = cacheProof "thmBIT0" ctxtArithA $ + prove "!n. BIT0 n = n + n" $ + tacINDUCT `_THEN` tacASM_REWRITE [defBIT0, thmADD_CLAUSES] + +thmMULT_0 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmMULT_0 = cacheProof "thmMULT_0" ctxtArithA $ + prove "!m. m * 0 = 0" $ + tacINDUCT `_THEN` tacASM_REWRITE [defMULT, thmADD_CLAUSES] + +thmADD_ASSOC :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmADD_ASSOC = cacheProof "thmADD_ASSOC" ctxtArithA $ + prove "!m n p. m + (n + p) = (m + n) + p" $ + tacINDUCT `_THEN` tacASM_REWRITE [thmADD_CLAUSES] + +thmADD_EQ_0 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmADD_EQ_0 = cacheProof "thmADD_EQ_0" ctxtArithA $ + prove [str| !m n. (m + n = 0) <=> (m = 0) /\ (n = 0) |] $ + _REPEAT tacINDUCT `_THEN` tacREWRITE [thmADD_CLAUSES, thmNOT_SUC] + +thmLT_0 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLT_0 = cacheProof "thmLT_0" ctxtArithA $ + prove "!n. 0 < SUC n" $ + tacREWRITE [thmLT_SUC_LE, thmLE_0] + +thmLT_ADD :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLT_ADD = cacheProof "thmLT_ADD" ctxtArithA $ + prove "!m n. (m < m + n) <=> (0 < n)" $ + tacINDUCT `_THEN` tacASM_REWRITE [thmADD_CLAUSES, thmLT_SUC] + +thmADD_SUB :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmADD_SUB = cacheProof "thmADD_SUB" ctxtArithA $ + prove "!m n. (m + n) - n = m" $ + tacGEN `_THEN` tacINDUCT `_THEN` + tacASM_REWRITE [thmADD_CLAUSES, thmSUB_SUC, thmSUB_0] + +thmLT_REFL :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLT_REFL = cacheProof "thmLT_REFL" ctxtArithA $ + prove "!n. ~(n < n)" $ + tacINDUCT `_THEN` tacASM_REWRITE [thmLT_SUC] `_THEN` + tacREWRITE [defLT] + +thmSUB_EQ_0 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmSUB_EQ_0 = cacheProof "thmSUB_EQ_0" ctxtArithA $ + prove "!m n. (m - n = 0) <=> m <= n" $ + _REPEAT tacINDUCT `_THEN` + tacASM_REWRITE [thmSUB_SUC, thmLE_SUC, thmSUB_0] `_THEN` + tacREWRITE [defLE, thmLE_0] + +thmLE_CASES :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_CASES = cacheProof "thmLE_CASES" ctxtArithA $ + prove [str| !m n. m <= n \/ n <= m |] $ + _REPEAT tacINDUCT `_THEN` tacASM_REWRITE [thmLE_0, thmLE_SUC] + +thmLE_ANTISYM :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_ANTISYM = cacheProof "thmLE_ANTISYM" ctxtArithA $ + prove [str| !m n. (m <= n /\ n <= m) <=> (m = n) |] $ + _REPEAT tacINDUCT `_THEN` + tacASM_REWRITE [thmLE_SUC, thmSUC_INJ] `_THEN` + tacREWRITE [defLE, thmNOT_SUC, ruleGSYM thmNOT_SUC] + +thmLET_ANTISYM :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLET_ANTISYM = cacheProof "thmLET_ANTISYM" ctxtArithA $ + prove [str| !m n. ~(m <= n /\ n < m) |] $ + _REPEAT tacINDUCT `_THEN` tacASM_REWRITE [thmLE_SUC, thmLT_SUC] `_THEN` + tacREWRITE [defLE, defLT, thmNOT_SUC] + +thmEVEN_ADD :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmEVEN_ADD = cacheProof "thmEVEN_ADD" ctxtArithA $ + prove "!m n. EVEN(m + n) <=> (EVEN m <=> EVEN n)" $ + tacINDUCT `_THEN` tacASM_REWRITE [defEVEN, thmADD_CLAUSES] `_THEN` + tacX_GEN "p:num" `_THEN` + _DISJ_CASES_THEN tacMP (ruleSPEC "n:num" thmEVEN_OR_ODD) `_THEN` + _DISJ_CASES_THEN tacMP (ruleSPEC "p:num" thmEVEN_OR_ODD) `_THEN` + tacREWRITE [ruleGSYM thmNOT_EVEN] `_THEN` tacDISCH `_THEN` + tacASM_REWRITE_NIL + +thmLE_TRANS :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_TRANS = cacheProof "thmLE_TRANS" ctxtArithA $ + prove [str| !m n p. m <= n /\ n <= p ==> m <= p |] $ + _REPEAT tacINDUCT `_THEN` tacASM_REWRITE [thmLE_SUC, thmLE_0] `_THEN` + tacREWRITE [defLE, thmNOT_SUC] + +thmSUB_REFL :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmSUB_REFL = cacheProof "thmSUB_REFL" ctxtArithA $ + prove "!n. n - n = 0" $ + tacINDUCT `_THEN` tacASM_REWRITE [thmSUB_SUC, thmSUB_0] + +thmLE_ADD :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_ADD = cacheProof "thmLE_ADD" ctxtArithA $ + prove "!m n. m <= m + n" $ + tacGEN `_THEN` tacINDUCT `_THEN` + tacASM_REWRITE [defLE, thmADD_CLAUSES, thmLE_REFL] + +thmLTE_CASES :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLTE_CASES = cacheProof "thmLTE_CASES" ctxtArithA $ + prove [str| !m n. m < n \/ n <= m |] $ + tacONCE_REWRITE [thmDISJ_SYM] `_THEN` tacMATCH_ACCEPT thmLET_CASES + +thmSUB_ADD_LCANCEL :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmSUB_ADD_LCANCEL = cacheProof "thmSUB_ADD_LCANCEL" ctxtArithA $ + prove "!m n p. (m + n) - (m + p) = n - p" $ + tacINDUCT `_THEN` + tacASM_REWRITE [thmADD_CLAUSES, thmSUB_0, thmSUB_SUC] + +thmBIT0_THM :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmBIT0_THM = cacheProof "thmBIT0_THM" ctxtArithA $ + prove "!n. NUMERAL (BIT0 n) = NUMERAL n + NUMERAL n" $ + tacREWRITE [defNUMERAL, thmBIT0] + +thmBIT1 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmBIT1 = cacheProof "thmBIT1" ctxtArithA $ + prove "!n. BIT1 n = SUC(n + n)" $ + tacREWRITE [defBIT1, thmBIT0] + +thmMULT_SUC :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmMULT_SUC = cacheProof "thmMULT_SUC" ctxtArithA $ + prove "!m n. m * (SUC n) = m + (m * n)" $ + tacINDUCT `_THEN` + tacASM_REWRITE [defMULT, thmADD_CLAUSES, thmADD_ASSOC] + +thmNOT_LE :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmNOT_LE = cacheProof "thmNOT_LE" ctxtArithA $ + prove "!m n. ~(m <= n) <=> (n < m)" $ + _REPEAT tacINDUCT `_THEN` + tacASM_REWRITE [thmLE_SUC, thmLT_SUC] `_THEN` + tacREWRITE [ defLE, defLT, thmNOT_SUC + , ruleGSYM thmNOT_SUC, thmLE_0 ] `_THEN` + (\ g@(Goal _ asl) -> let a = head $ frees asl in + tacSPEC (a, a) g) `_THEN` + tacINDUCT `_THEN` tacREWRITE [thmLT_0] + + +thmNOT_LT :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmNOT_LT = cacheProof "thmNOT_LT" ctxtArithA $ + prove "!m n. ~(m < n) <=> n <= m" $ + _REPEAT tacINDUCT `_THEN` + tacASM_REWRITE [thmLE_SUC, thmLT_SUC] `_THEN` + tacREWRITE [defLE, defLT, thmNOT_SUC, ruleGSYM thmNOT_SUC, thmLE_0]`_THEN` + (\ g@(Goal _ asl) -> let a = head $ frees asl in + tacSPEC (a, a) g) `_THEN` + tacINDUCT `_THEN` tacREWRITE [thmLT_0] + +thmLE_EXISTS :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_EXISTS = cacheProof "thmLE_EXISTS" ctxtArithA $ + prove "!m n. (m <= n) <=> (?d. n = m + d)" $ + tacGEN `_THEN` tacINDUCT `_THEN` tacASM_REWRITE [defLE] `_THENL` + [ tacREWRITE [ruleCONV (convLAND convSYM) =<< + ruleSPEC_ALL thmADD_EQ_0] `_THEN` + tacREWRITE [thmRIGHT_EXISTS_AND, thmEXISTS_REFL] + , tacEQ `_THENL` + [ _DISCH_THEN (_DISJ_CASES_THEN2 tacSUBST1 tacMP) `_THENL` + [ tacEXISTS "0" `_THEN` tacREWRITE [thmADD_CLAUSES] + , _DISCH_THEN (_X_CHOOSE_THEN "d:num" tacSUBST1) `_THEN` + tacEXISTS "SUC d" `_THEN` tacREWRITE [thmADD_CLAUSES] + ] + , tacONCE_REWRITE [thmLEFT_IMP_EXISTS] `_THEN` + tacINDUCT `_THEN` tacREWRITE [thmADD_CLAUSES, thmSUC_INJ] `_THEN` + _DISCH_THEN tacSUBST1 `_THEN` tacREWRITE_NIL `_THEN` + tacDISJ2 `_THEN` + tacREWRITE [thmEQ_ADD_LCANCEL, ruleGSYM thmEXISTS_REFL] + ] + ] + +thmLT_EXISTS :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLT_EXISTS = cacheProof "thmLT_EXISTS" ctxtArithA $ + prove "!m n. (m < n) <=> (?d. n = m + SUC d)" $ + tacGEN `_THEN` tacINDUCT `_THEN` + tacREWRITE [defLT, thmADD_CLAUSES, ruleGSYM thmNOT_SUC] `_THEN` + tacASM_REWRITE [thmSUC_INJ] `_THEN` tacEQ `_THENL` + [ _DISCH_THEN (_DISJ_CASES_THEN2 tacSUBST1 tacMP) `_THENL` + [ tacEXISTS "0" `_THEN` tacREWRITE [thmADD_CLAUSES] + , _DISCH_THEN (_X_CHOOSE_THEN "d:num" tacSUBST1) `_THEN` + tacEXISTS "SUC d" `_THEN` tacREWRITE [thmADD_CLAUSES] + ] + , tacONCE_REWRITE [thmLEFT_IMP_EXISTS] `_THEN` + tacINDUCT `_THEN` tacREWRITE [thmADD_CLAUSES, thmSUC_INJ] `_THEN` + _DISCH_THEN tacSUBST1 `_THEN` tacREWRITE_NIL `_THEN` + tacDISJ2 `_THEN` tacREWRITE [ thmSUC_INJ, thmEQ_ADD_LCANCEL + , ruleGSYM thmEXISTS_REFL ] + ] + +thmLT_ADDR :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLT_ADDR = cacheProof "thmLT_ADDR" ctxtArithA $ + prove "!m n. (n < m + n) <=> (0 < m)" $ + tacONCE_REWRITE [thmADD_SYM] `_THEN` tacMATCH_ACCEPT thmLT_ADD + +thmADD_SUB2 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmADD_SUB2 = cacheProof "thmADD_SUB2" ctxtArithA $ + prove "!m n. (m + n) - m = n" $ + tacONCE_REWRITE [thmADD_SYM] `_THEN` tacMATCH_ACCEPT thmADD_SUB + +thmLTE_ANTISYM :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLTE_ANTISYM = cacheProof "thmLTE_ANTISYM" ctxtArithA $ + prove [str| !m n. ~(m < n /\ n <= m) |] $ + tacONCE_REWRITE [thmCONJ_SYM] `_THEN` tacREWRITE [thmLET_ANTISYM] + +thmLE_LT :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_LT = cacheProof "thmLE_LT" ctxtArithA $ + prove [str| !m n. (m <= n) <=> (m < n) \/ (m = n) |] $ + _REPEAT tacINDUCT `_THEN` + tacASM_REWRITE [ thmLE_SUC, thmLT_SUC + , thmSUC_INJ, thmLE_0, thmLT_0 ] `_THEN` + tacREWRITE [defLE, defLT] + +thmARITH_ZERO :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmARITH_ZERO = cacheProof "thmARITH_ZERO" ctxtArithA $ + prove [str| (NUMERAL 0 = 0) /\ (BIT0 _0 = _0) |] $ + tacREWRITE [defNUMERAL, thmBIT0, ruleDENUMERAL thmADD_CLAUSES] + +thmADD_AC :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmADD_AC = cacheProof "thmADD_AC" ctxtArithA $ + prove [str| (m + n = n + m) /\ + ((m + n) + p = m + (n + p)) /\ + (m + (n + p) = n + (m + p)) |] $ + tacMESON [thmADD_ASSOC, thmADD_SYM] + +thmODD_ADD :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmODD_ADD = cacheProof "thmODD_ADD" ctxtArithA $ + prove "!m n. ODD(m + n) <=> ~(ODD m <=> ODD n)" $ + _REPEAT tacGEN `_THEN` + tacREWRITE [ruleGSYM thmNOT_EVEN, thmEVEN_ADD] `_THEN` + tacCONV (Conv ruleITAUT) + +thmEQ_ADD_RCANCEL :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmEQ_ADD_RCANCEL = cacheProof "thmEQ_ADD_RCANCEL" ctxtArithA $ + prove "!m n p. (m + p = n + p) <=> (m = n)" $ + tacONCE_REWRITE [thmADD_SYM] `_THEN` + tacMATCH_ACCEPT thmEQ_ADD_LCANCEL + +thmLTE_TRANS :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLTE_TRANS = cacheProof "thmLTE_TRANS" ctxtArithA $ + prove [str| !m n p. m < n /\ n <= p ==> m < p |] $ + _REPEAT tacINDUCT `_THEN` + tacASM_REWRITE [thmLE_SUC, thmLT_SUC, thmLT_0] `_THEN` + tacREWRITE [defLT, defLE, thmNOT_SUC] + +thmADD_SUBR2 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmADD_SUBR2 = cacheProof "thmADD_SUBR2" ctxtArithA $ + prove "!m n. m - (m + n) = 0" $ + tacREWRITE [thmSUB_EQ_0, thmLE_ADD] + +thmEQ_ADD_LCANCEL_0 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmEQ_ADD_LCANCEL_0 = cacheProof "thmEQ_ADD_LCANCEL_0" ctxtArithA $ + prove "!m n. (m + n = m) <=> (n = 0)" $ + tacINDUCT `_THEN` tacASM_REWRITE [thmADD_CLAUSES, thmSUC_INJ] + +thmLE_ADDR :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_ADDR = cacheProof "thmLE_ADDR" ctxtArithA $ + prove "!m n. n <= m + n" $ + tacONCE_REWRITE [thmADD_SYM] `_THEN` tacMATCH_ACCEPT thmLE_ADD + +thmBIT1_THM :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmBIT1_THM = cacheProof "thmBIT1_THM" ctxtArithA $ + prove "!n. NUMERAL (BIT1 n) = SUC(NUMERAL n + NUMERAL n)" $ + tacREWRITE [defNUMERAL, thmBIT1] + +thmLT_ADD_LCANCEL :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLT_ADD_LCANCEL = cacheProof "thmLT_ADD_LCANCEL" ctxtArithA $ + prove "!m n p. (m + n) < (m + p) <=> n < p" $ + tacREWRITE [ thmLT_EXISTS, ruleGSYM thmADD_ASSOC + , thmEQ_ADD_LCANCEL, thmSUC_INJ ] + +thmLE_ADD_LCANCEL :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_ADD_LCANCEL = cacheProof "thmLE_ADD_LCANCEL" ctxtArithA $ + prove "!m n p. (m + n) <= (m + p) <=> n <= p" $ + tacREWRITE [thmLE_EXISTS, ruleGSYM thmADD_ASSOC, thmEQ_ADD_LCANCEL] + +thmARITH_SUC :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmARITH_SUC = cacheProof "thmARITH_SUC" ctxtArithA $ + prove [str| (!n. SUC(NUMERAL n) = NUMERAL(SUC n)) /\ + (SUC _0 = BIT1 _0) /\ + (!n. SUC (BIT0 n) = BIT1 n) /\ + (!n. SUC (BIT1 n) = BIT0 (SUC n)) |] $ + tacREWRITE [defNUMERAL, thmBIT0, thmBIT1, ruleDENUMERAL thmADD_CLAUSES] + +thmARITH_PRE :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmARITH_PRE = cacheProof "thmARITH_PRE" ctxtArithA $ + prove [str| (!n. PRE(NUMERAL n) = NUMERAL(PRE n)) /\ + (PRE _0 = _0) /\ + (!n. PRE(BIT0 n) = if n = _0 then _0 else BIT1 (PRE n)) /\ + (!n. PRE(BIT1 n) = BIT0 n) |] $ + tacREWRITE [defNUMERAL, thmBIT1, thmBIT0, ruleDENUMERAL defPRE] `_THEN` + tacINDUCT `_THEN` tacREWRITE [ defNUMERAL, ruleDENUMERAL defPRE + , ruleDENUMERAL thmADD_CLAUSES + , ruleDENUMERAL thmNOT_SUC, thmARITH_ZERO ] + +thmARITH_ADD :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmARITH_ADD = cacheProof "thmARITH_ADD" ctxtArithA $ + prove [str| (!m n. NUMERAL(m) + NUMERAL(n) = NUMERAL(m + n)) /\ + (_0 + _0 = _0) /\ + (!n. _0 + BIT0 n = BIT0 n) /\ + (!n. _0 + BIT1 n = BIT1 n) /\ + (!n. BIT0 n + _0 = BIT0 n) /\ + (!n. BIT1 n + _0 = BIT1 n) /\ + (!m n. BIT0 m + BIT0 n = BIT0 (m + n)) /\ + (!m n. BIT0 m + BIT1 n = BIT1 (m + n)) /\ + (!m n. BIT1 m + BIT0 n = BIT1 (m + n)) /\ + (!m n. BIT1 m + BIT1 n = BIT0 (SUC(m + n))) |] $ + tacPURE_REWRITE [ defNUMERAL, thmBIT0, thmBIT1 + , ruleDENUMERAL thmADD_CLAUSES, thmSUC_INJ ] `_THEN` + tacREWRITE [thmADD_AC] + +thmARITH_EVEN :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmARITH_EVEN = cacheProof "thmARITH_EVEN" ctxtArithA $ + prove [str| (!n. EVEN(NUMERAL n) <=> EVEN n) /\ + (EVEN _0 <=> T) /\ + (!n. EVEN(BIT0 n) <=> T) /\ + (!n. EVEN(BIT1 n) <=> F) |] $ + tacREWRITE [ defNUMERAL, thmBIT1, thmBIT0, ruleDENUMERAL defEVEN + , thmEVEN_ADD ] + +thmARITH_ODD :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmARITH_ODD = cacheProof "thmARITH_ODD" ctxtArithA $ + prove [str| (!n. ODD(NUMERAL n) <=> ODD n) /\ + (ODD _0 <=> F) /\ + (!n. ODD(BIT0 n) <=> F) /\ + (!n. ODD(BIT1 n) <=> T) |] $ + tacREWRITE [ defNUMERAL, thmBIT1, thmBIT0 + , ruleDENUMERAL defODD, thmODD_ADD ] + +thmLE_ADD2 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_ADD2 = cacheProof "thmLE_ADD2" ctxtArithA $ + prove [str| !m n p q. m <= p /\ n <= q ==> m + n <= p + q |] $ + _REPEAT tacGEN `_THEN` tacREWRITE [thmLE_EXISTS] `_THEN` + _DISCH_THEN + (_CONJUNCTS_THEN2 (tacX_CHOOSE "a:num") + (tacX_CHOOSE "b:num")) `_THEN` + tacEXISTS "a + b" `_THEN` tacASM_REWRITE [thmADD_AC] + +thmADD_SUBR :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmADD_SUBR = cacheProof "thmADD_SUBR" ctxtArithA $ + prove "!m n. n - (m + n) = 0" $ + tacONCE_REWRITE [thmADD_SYM] `_THEN` tacMATCH_ACCEPT thmADD_SUBR2 + +thmLT_LE :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLT_LE = cacheProof "thmLT_LE" ctxtArithA $ + prove [str| !m n. (m < n) <=> (m <= n) /\ ~(m = n) |] $ + tacREWRITE [thmLE_LT] `_THEN` _REPEAT tacGEN `_THEN` tacEQ `_THENL` + [ tacDISCH `_THEN` tacASM_REWRITE_NIL `_THEN` + _DISCH_THEN tacSUBST_ALL `_THEN` _POP_ASSUM tacMP `_THEN` + tacREWRITE [thmLT_REFL] + , _DISCH_THEN (_CONJUNCTS_THEN2 tacSTRIP_ASSUME tacMP) `_THEN` + tacASM_REWRITE_NIL + ] + +thmLET_ADD2 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLET_ADD2 = cacheProof "thmLET_ADD2" ctxtArithA $ + prove [str| !m n p q. m <= p /\ n < q ==> m + n < p + q |] $ + _REPEAT tacGEN `_THEN` tacREWRITE [thmLE_EXISTS, thmLT_EXISTS] `_THEN` + _DISCH_THEN (_CONJUNCTS_THEN2 (tacX_CHOOSE "a:num") + (tacX_CHOOSE "b:num")) `_THEN` + tacEXISTS "a + b" `_THEN` + tacASM_REWRITE [thmSUC_INJ, thmADD_CLAUSES, thmADD_AC] + +thmADD1 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmADD1 = cacheProof "thmADD1" ctxtArithA $ + prove "!m. SUC m = m + 1" $ + tacREWRITE [thmBIT1_THM, thmADD_CLAUSES] + +thmMULT_CLAUSES :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmMULT_CLAUSES = cacheProof "thmMULT_CLAUSES" ctxtArithA $ + prove [str| (!n. 0 * n = 0) /\ + (!m. m * 0 = 0) /\ + (!n. 1 * n = n) /\ + (!m. m * 1 = m) /\ + (!m n. (SUC m) * n = (m * n) + n) /\ + (!m n. m * (SUC n) = m + (m * n)) |] $ + tacREWRITE [ thmBIT1_THM, defMULT, thmMULT_0 + , thmMULT_SUC, thmADD_CLAUSES ] + +thmLT_IMP_LE :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLT_IMP_LE = cacheProof "thmLT_IMP_LE" ctxtArithA $ + prove "!m n. m < n ==> m <= n" $ + tacREWRITE [thmLT_LE] `_THEN` _REPEAT tacSTRIP `_THEN` + tacASM_REWRITE_NIL + +thmLE_ADD_RCANCEL :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_ADD_RCANCEL = cacheProof "thmLE_ADD_RCANCEL" ctxtArithA $ + prove "!m n p. (m + p) <= (n + p) <=> (m <= n)" $ + tacONCE_REWRITE [thmADD_SYM] `_THEN` + tacMATCH_ACCEPT thmLE_ADD_LCANCEL + +thmLTE_ADD2 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLTE_ADD2 = cacheProof "thmLTE_ADD2" ctxtArithA $ + prove [str| !m n p q. m < p /\ n <= q ==> m + n < p + q |] $ + tacONCE_REWRITE [thmADD_SYM, thmCONJ_SYM] `_THEN` + tacMATCH_ACCEPT thmLET_ADD2 + +thmMULT_SYM :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmMULT_SYM = cacheProof "thmMULT_SYM" ctxtArithA . + prove "!m n. m * n = n * m" $ + tacINDUCT `_THEN` + tacASM_REWRITE [ thmMULT_CLAUSES + , ruleEQT_INTRO =<< ruleSPEC_ALL thmADD_SYM ] + +thmLEFT_ADD_DISTRIB :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLEFT_ADD_DISTRIB = cacheProof "thmLEFT_ADD_DISTRIB" ctxtArithA . + prove "!m n p. m * (n + p) = (m * n) + (m * p)" $ + tacGEN `_THEN` tacINDUCT `_THEN` + tacASM_REWRITE [defADD, thmMULT_CLAUSES, thmADD_ASSOC] + +thmLE_MULT_LCANCEL :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_MULT_LCANCEL = cacheProof "thmLE_MULT_LCANCEL" ctxtArithA $ + do cths <- ruleCONJUNCTS thmMULT_CLAUSES + prove [str| !m n p. (m * n) <= (m * p) <=> (m = 0) \/ n <= p |] $ + _REPEAT tacINDUCT `_THEN` + tacASM_REWRITE [ thmMULT_CLAUSES, thmADD_CLAUSES + , thmLE_REFL, thmLE_0, thmNOT_SUC ] `_THEN` + tacREWRITE [thmLE_SUC] `_THEN` + tacREWRITE [defLE, thmLE_ADD_LCANCEL, ruleGSYM thmADD_ASSOC] `_THEN` + tacASM_REWRITE [ruleGSYM (cths !! 4), thmNOT_SUC] + +thmLT_MULT_LCANCEL :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLT_MULT_LCANCEL = cacheProof "thmLT_MULT_LCANCEL" ctxtArithA $ + do cths <- ruleCONJUNCTS thmMULT_CLAUSES + prove [str| !m n p. (m * n) < (m * p) <=> ~(m = 0) /\ n < p |] $ + _REPEAT tacINDUCT `_THEN` + tacASM_REWRITE [ thmMULT_CLAUSES, thmADD_CLAUSES + , thmLT_REFL, thmLT_0, thmNOT_SUC] `_THEN` + tacREWRITE [thmLT_SUC] `_THEN` + tacREWRITE [defLT, thmLT_ADD_LCANCEL, ruleGSYM thmADD_ASSOC] `_THEN` + tacASM_REWRITE [ruleGSYM (cths !! 4), thmNOT_SUC] + +thmMULT_EQ_0 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmMULT_EQ_0 = cacheProof "thmMULT_EQ_0" ctxtArithA . + prove [str| !m n. (m * n = 0) <=> (m = 0) \/ (n = 0) |] $ + _REPEAT tacINDUCT `_THEN` + tacREWRITE [thmMULT_CLAUSES, thmADD_CLAUSES, thmNOT_SUC] + +thmEQ_MULT_LCANCEL :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmEQ_MULT_LCANCEL = cacheProof "thmEQ_MULT_LCANCEL" ctxtArithA $ + prove [str| !m n p. (m * n = m * p) <=> (m = 0) \/ (n = p) |] $ + tacINDUCT `_THEN` tacREWRITE [thmMULT_CLAUSES, thmNOT_SUC] `_THEN` + _REPEAT tacINDUCT `_THEN` + tacASM_REWRITE [ thmMULT_CLAUSES, thmADD_CLAUSES + , ruleGSYM thmNOT_SUC, thmNOT_SUC ] `_THEN` + tacASM_REWRITE [thmSUC_INJ, ruleGSYM thmADD_ASSOC, thmEQ_ADD_LCANCEL] + +thmEVEN_MULT :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmEVEN_MULT = cacheProof "thmEVEN_MULT" ctxtArithA . + prove [str| !m n. EVEN(m * n) <=> EVEN(m) \/ EVEN(n) |] $ + tacINDUCT `_THEN` + tacASM_REWRITE [thmMULT_CLAUSES, thmEVEN_ADD, defEVEN] `_THEN` + tacX_GEN "p:num" `_THEN` + _DISJ_CASES_THEN tacMP (ruleSPEC "n:num" thmEVEN_OR_ODD) `_THEN` + _DISJ_CASES_THEN tacMP (ruleSPEC "p:num" thmEVEN_OR_ODD) `_THEN` + tacREWRITE [ruleGSYM thmNOT_EVEN] `_THEN` tacDISCH `_THEN` + tacASM_REWRITE_NIL + +thmEXP_EQ_0 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmEXP_EQ_0 = cacheProof "thmEXP_EQ_0" ctxtArithA . + prove [str| !m n. (m EXP n = 0) <=> (m = 0) /\ ~(n = 0) |] $ + _REPEAT tacINDUCT `_THEN` + tacASM_REWRITE [ thmBIT1_THM, thmNOT_SUC, defEXP + , thmMULT_CLAUSES, thmADD_CLAUSES, thmADD_EQ_0 ] + +thmLT_ADD2 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLT_ADD2 = cacheProof "thmLT_ADD2" ctxtArithA . + prove [str| !m n p q. m < p /\ n < q ==> m + n < p + q |] $ + _REPEAT tacSTRIP `_THEN` tacMATCH_MP thmLTE_ADD2 `_THEN` + tacASM_REWRITE_NIL `_THEN` tacMATCH_MP thmLT_IMP_LE `_THEN` + tacASM_REWRITE_NIL + +thmRIGHT_ADD_DISTRIB :: (BasicConvs thry, ArithACtxt thry) + => HOL cls thry HOLThm +thmRIGHT_ADD_DISTRIB = cacheProof "thmRIGHT_ADD_DISTRIB" ctxtArithA . + prove "!m n p. (m + n) * p = (m * p) + (n * p)" $ + tacONCE_REWRITE [thmMULT_SYM] `_THEN` tacMATCH_ACCEPT thmLEFT_ADD_DISTRIB + +thmLEFT_SUB_DISTRIB :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLEFT_SUB_DISTRIB = cacheProof "thmLEFT_SUB_DISTRIB" ctxtArithA . + prove "!m n p. m * (n - p) = m * n - m * p" $ + _REPEAT tacGEN `_THEN` tacCONV convSYM `_THEN` + tacDISJ_CASES (ruleSPECL ["n:num", "p:num"] thmLE_CASES) `_THENL` + [ _FIRST_ASSUM + (\ th -> tacREWRITE [ruleREWRITE [ruleGSYM thmSUB_EQ_0] th])`_THEN` + tacASM_REWRITE [thmMULT_CLAUSES, thmSUB_EQ_0, thmLE_MULT_LCANCEL] + , _POP_ASSUM (_CHOOSE_THEN tacSUBST1 . ruleREWRITE [thmLE_EXISTS]) `_THEN` + tacREWRITE [thmLEFT_ADD_DISTRIB] `_THEN` + tacREWRITE [ruleONCE_REWRITE [thmADD_SYM] thmADD_SUB] + ] + +thmEVEN_DOUBLE :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmEVEN_DOUBLE = cacheProof "thmEVEN_DOUBLE" ctxtArithA . + prove "!n. EVEN(2 * n)" $ + tacGEN `_THEN` tacREWRITE [thmEVEN_MULT] `_THEN` tacDISJ1 `_THEN` + tacPURE_REWRITE [thmBIT0_THM, thmBIT1_THM] `_THEN` + tacREWRITE [defEVEN, thmEVEN_ADD] + +thmLE_MULT_RCANCEL :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_MULT_RCANCEL = cacheProof "thmLE_MULT_RCANCEL" ctxtArithA . + prove [str| !m n p. (m * p) <= (n * p) <=> (m <= n) \/ (p = 0) |] $ + tacONCE_REWRITE [thmMULT_SYM, thmDISJ_SYM] `_THEN` + tacMATCH_ACCEPT thmLE_MULT_LCANCEL + +thmDIVMOD_EXIST :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmDIVMOD_EXIST = cacheProof "thmDIVMOD_EXIST" ctxtArithA . + prove [str| !m n. ~(n = 0) ==> ?q r. (m = q * n + r) /\ r < n |] $ + _REPEAT tacSTRIP `_THEN` + tacMP (ruleSPEC [str| \r. ?q. m = q * n + r |] wopNUM) `_THEN` + tacBETA `_THEN` _DISCH_THEN (tacMP . liftM fst . ruleEQ_IMP) `_THEN` + tacREWRITE [thmLEFT_IMP_EXISTS] `_THEN` + _DISCH_THEN (tacMP . ruleSPECL ["m:num", "0"]) `_THEN` + tacREWRITE [thmMULT_CLAUSES, thmADD_CLAUSES] `_THEN` + _DISCH_THEN (_X_CHOOSE_THEN "r:num" tacMP) `_THEN` + _DISCH_THEN (_CONJUNCTS_THEN2 (tacX_CHOOSE "q:num") tacMP) `_THEN` + _DISCH_THEN (\ th -> _MAP_EVERY tacEXISTS ["q:num", "r:num"] `_THEN` + tacMP th) `_THEN` + tacCONV convCONTRAPOS `_THEN` tacASM_REWRITE [thmNOT_LT] `_THEN` + _DISCH_THEN (_X_CHOOSE_THEN "d:num" tacSUBST_ALL . + ruleREWRITE [thmLE_EXISTS]) `_THEN` + tacREWRITE [thmNOT_FORALL] `_THEN` tacEXISTS "d:num" `_THEN` + tacREWRITE [thmNOT_IMP, thmRIGHT_AND_EXISTS] `_THEN` + tacEXISTS "q + 1" `_THEN` tacREWRITE [thmRIGHT_ADD_DISTRIB] `_THEN` + tacREWRITE [thmMULT_CLAUSES, thmADD_ASSOC, thmLT_ADDR] `_THEN` + tacASM_REWRITE [ruleGSYM thmNOT_LE, defLE] + +thmMULT_2 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmMULT_2 = cacheProof "thmMULT_2" ctxtArithA . + prove "!n. 2 * n = n + n" $ + tacGEN `_THEN` + tacREWRITE [thmBIT0_THM, thmMULT_CLAUSES, thmRIGHT_ADD_DISTRIB] + +thmARITH_MULT :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmARITH_MULT = cacheProof "thmARITH_MULT" ctxtArithA $ + prove [str| (!m n. NUMERAL(m) * NUMERAL(n) = NUMERAL(m * n)) /\ + (_0 * _0 = _0) /\ + (!n. _0 * BIT0 n = _0) /\ + (!n. _0 * BIT1 n = _0) /\ + (!n. BIT0 n * _0 = _0) /\ + (!n. BIT1 n * _0 = _0) /\ + (!m n. BIT0 m * BIT0 n = BIT0 (BIT0 (m * n))) /\ + (!m n. BIT0 m * BIT1 n = BIT0 m + BIT0 (BIT0 (m * n))) /\ + (!m n. BIT1 m * BIT0 n = BIT0 n + BIT0 (BIT0 (m * n))) /\ + (!m n. BIT1 m * BIT1 n = + BIT1 m + BIT0 n + BIT0 (BIT0 (m * n))) |] $ + tacPURE_REWRITE [ defNUMERAL, thmBIT0, thmBIT1 + , ruleDENUMERAL thmMULT_CLAUSES + , ruleDENUMERAL thmADD_CLAUSES, thmSUC_INJ ] `_THEN` + tacREWRITE [thmLEFT_ADD_DISTRIB, thmRIGHT_ADD_DISTRIB, thmADD_AC] + +thmMULT_ASSOC :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmMULT_ASSOC = cacheProof "thmMULT_ASSOC" ctxtArithA . + prove "!m n p. m * (n * p) = (m * n) * p" $ + tacINDUCT `_THEN` tacASM_REWRITE [thmMULT_CLAUSES, thmRIGHT_ADD_DISTRIB] + +thmLE_MULT2 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmLE_MULT2 = cacheProof "thmLE_MULT2" ctxtArithA . + prove [str| !m n p q. m <= n /\ p <= q ==> m * p <= n * q |] $ + _REPEAT tacGEN `_THEN` tacREWRITE [thmLE_EXISTS] `_THEN` + _DISCH_THEN (_CONJUNCTS_THEN2 (tacX_CHOOSE "a:num") + (tacX_CHOOSE "b:num")) `_THEN` + tacEXISTS "a * p + m * b + a * b" `_THEN` + tacASM_REWRITE [thmLEFT_ADD_DISTRIB] `_THEN` + tacREWRITE [thmLEFT_ADD_DISTRIB, thmRIGHT_ADD_DISTRIB, thmADD_ASSOC] + +thmRIGHT_SUB_DISTRIB :: (BasicConvs thry, ArithACtxt thry) + => HOL cls thry HOLThm +thmRIGHT_SUB_DISTRIB = cacheProof "thmRIGHT_SUB_DISTRIB" ctxtArithA . + prove "!m n p. (m - n) * p = m * p - n * p" $ + tacONCE_REWRITE [thmMULT_SYM] `_THEN` tacMATCH_ACCEPT thmLEFT_SUB_DISTRIB + +thmARITH_LE :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmARITH_LE = cacheProof "thmARITH_LE" ctxtArithA $ + do tm <- toHTm "EVEN" + prove [str| (!m n. NUMERAL m <= NUMERAL n <=> m <= n) /\ + ((_0 <= _0) <=> T) /\ + (!n. (BIT0 n <= _0) <=> n <= _0) /\ + (!n. (BIT1 n <= _0) <=> F) /\ + (!n. (_0 <= BIT0 n) <=> T) /\ + (!n. (_0 <= BIT1 n) <=> T) /\ + (!m n. (BIT0 m <= BIT0 n) <=> m <= n) /\ + (!m n. (BIT0 m <= BIT1 n) <=> m <= n) /\ + (!m n. (BIT1 m <= BIT0 n) <=> m < n) /\ + (!m n. (BIT1 m <= BIT1 n) <=> m <= n) |] $ + tacREWRITE [ defNUMERAL, thmBIT1, thmBIT0 + , ruleDENUMERAL thmNOT_SUC + , ruleDENUMERAL =<< ruleGSYM thmNOT_SUC, thmSUC_INJ] `_THEN` + tacREWRITE [ruleDENUMERAL thmLE_0] `_THEN` + tacREWRITE [ruleDENUMERAL defLE, ruleGSYM thmMULT_2] `_THEN` + tacREWRITE [ thmLE_MULT_LCANCEL, thmSUC_INJ, ruleDENUMERAL thmMULT_EQ_0 + , ruleDENUMERAL thmNOT_SUC ] `_THEN` + tacREWRITE [ruleDENUMERAL thmNOT_SUC] `_THEN` + tacREWRITE [thmLE_SUC_LT] `_THEN` + tacREWRITE [thmLT_MULT_LCANCEL] `_THEN` + _SUBGOAL_THEN "2 = SUC 1" (\ th -> tacREWRITE [th]) `_THENL` + [ tacREWRITE [ defNUMERAL, thmBIT0, thmBIT1 + , ruleDENUMERAL thmADD_CLAUSES ] + , tacREWRITE [ ruleDENUMERAL thmNOT_SUC + , thmNOT_SUC, thmEQ_MULT_LCANCEL ] `_THEN` + tacREWRITE [ruleONCE_REWRITE [thmDISJ_SYM] thmLE_LT] `_THEN` + _MAP_EVERY tacX_GEN ["m:num", "n:num"] `_THEN` + _SUBGOAL_THEN "~(SUC 1 * m = SUC (SUC 1 * n))" + (\ th -> tacREWRITE [th]) `_THEN` + _DISCH_THEN (tacMP <#< ruleAP_TERM tm) `_THEN` + tacREWRITE [thmEVEN_MULT, thmEVEN_ADD, defNUMERAL, thmBIT1, defEVEN] + ] + +thmMULT_AC :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmMULT_AC = cacheProof "thmMULT_AC" ctxtArithA . + prove [str| (m * n = n * m) /\ + ((m * n) * p = m * (n * p)) /\ + (m * (n * p) = n * (m * p)) |] $ + tacMESON [thmMULT_ASSOC, thmMULT_SYM] + +thmARITH_LT :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmARITH_LT = cacheProof "thmARITH_LT" ctxtArithA $ + prove [str| (!m n. NUMERAL m < NUMERAL n <=> m < n) /\ + ((_0 < _0) <=> F) /\ + (!n. (BIT0 n < _0) <=> F) /\ + (!n. (BIT1 n < _0) <=> F) /\ + (!n. (_0 < BIT0 n) <=> _0 < n) /\ + (!n. (_0 < BIT1 n) <=> T) /\ + (!m n. (BIT0 m < BIT0 n) <=> m < n) /\ + (!m n. (BIT0 m < BIT1 n) <=> m <= n) /\ + (!m n. (BIT1 m < BIT0 n) <=> m < n) /\ + (!m n. (BIT1 m < BIT1 n) <=> m < n) |] $ + tacREWRITE [defNUMERAL, ruleGSYM thmNOT_LE, thmARITH_LE] `_THEN` + tacREWRITE [ruleDENUMERAL defLE] + +thmARITH_GE :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmARITH_GE = cacheProof "thmARITH_GE" ctxtArithA $ + ruleREWRITE [ruleGSYM defGE, ruleGSYM defGT] thmARITH_LE + +thmARITH_EQ :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmARITH_EQ = cacheProof "thmARITH_EQ" ctxtArithA $ + prove [str| (!m n. (NUMERAL m = NUMERAL n) <=> (m = n)) /\ + ((_0 = _0) <=> T) /\ + (!n. (BIT0 n = _0) <=> (n = _0)) /\ + (!n. (BIT1 n = _0) <=> F) /\ + (!n. (_0 = BIT0 n) <=> (_0 = n)) /\ + (!n. (_0 = BIT1 n) <=> F) /\ + (!m n. (BIT0 m = BIT0 n) <=> (m = n)) /\ + (!m n. (BIT0 m = BIT1 n) <=> F) /\ + (!m n. (BIT1 m = BIT0 n) <=> F) /\ + (!m n. (BIT1 m = BIT1 n) <=> (m = n)) |] $ + tacREWRITE [defNUMERAL, ruleGSYM thmLE_ANTISYM, thmARITH_LE] `_THEN` + tacREWRITE [thmLET_ANTISYM, thmLTE_ANTISYM, ruleDENUMERAL thmLE_0] + +thmEXP_ADD :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmEXP_ADD = cacheProof "thmEXP_ADD" ctxtArithA . + prove "!m n p. m EXP (n + p) = (m EXP n) * (m EXP p)" $ + tacGEN `_THEN` tacGEN `_THEN` tacINDUCT `_THEN` + tacASM_REWRITE [defEXP, thmADD_CLAUSES, thmMULT_CLAUSES, thmMULT_AC] + +thmDIVMOD_EXIST_0 :: (BasicConvs thry, ArithACtxt thry) => HOL cls thry HOLThm +thmDIVMOD_EXIST_0 = cacheProof "thmDIVMOD_EXIST_0" ctxtArithA . + prove [str| !m n. ?q r. if n = 0 then q = 0 /\ r = m + else m = q * n + r /\ r < n |] $ + _REPEAT tacGEN `_THEN` tacASM_CASES "n = 0" `_THEN` + tacASM_SIMP [thmDIVMOD_EXIST, thmRIGHT_EXISTS_AND, thmEXISTS_REFL] + +specDIVISION_0' :: (BasicConvs thry, ArithACtxt thry) => HOL Theory thry HOLThm +specDIVISION_0' = newSpecification ["DIV", "MOD"] =<< + ruleREWRITE [thmSKOLEM] thmDIVMOD_EXIST_0 + +defMinimal' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defMinimal' = newDefinition "minimal" + [str| (minimal) (P:num->bool) = @n. P n /\ !m. m < n ==> ~(P m) |] diff --git a/src/HaskHOL/Lib/Arith/Context.hs b/src/HaskHOL/Lib/Arith/Context.hs new file mode 100644 index 0000000..d4d3876 --- /dev/null +++ b/src/HaskHOL/Lib/Arith/Context.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TemplateHaskell, + TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +module HaskHOL.Lib.Arith.Context + ( ArithType + , ArithCtxt + , ctxtArith + , arith + ) where + +import HaskHOL.Core +import HaskHOL.Deductive +import HaskHOL.Lib.Pair + +import HaskHOL.Lib.Arith.A.Context +import HaskHOL.Lib.Arith.Base + +-- generate template types +extendTheory ctxtArithA "Arith" $ + do parseAsBinder "minimal" + void specDIVISION_0' + void defMinimal' + +templateProvers 'ctxtArith + +-- have to manually write this, for now +type family ArithCtxt a where + ArithCtxt a = (ArithACtxt a, ArithContext a ~ True) + +type instance PolyTheory ArithType b = ArithCtxt b + +instance BasicConvs ArithType where + basicConvs _ = basicConvs (undefined :: PairType) + diff --git a/src/HaskHOL/Lib/CalcNum.hs b/src/HaskHOL/Lib/CalcNum.hs new file mode 100644 index 0000000..e239854 --- /dev/null +++ b/src/HaskHOL/Lib/CalcNum.hs @@ -0,0 +1,1532 @@ +{-# LANGUAGE PatternSynonyms #-} +{-| + Module: HaskHOL.Lib.CalcNum + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.CalcNum + ( thmARITH + , convNUM_EVEN + , convNUM_SUC + , convNUM_LE + , convNUM_EQ + , convNUM_ADD + , convNUM_MULT + , convNUM_EXP + , convNUM_LT + , convNUM + , ruleNUM_ADC + , adcClauses + , adcFlags + , topsplit + ) where + +import HaskHOL.Core +import HaskHOL.Deductive + +import HaskHOL.Lib.Nums +import HaskHOL.Lib.Arith +import HaskHOL.Lib.WF +import HaskHOL.Lib.WF.Context + +import HaskHOL.Lib.CalcNum.Pre +import HaskHOL.Lib.CalcNum.Pre2 + +import qualified Data.Vector as V + +tmA', tmB', tmC', tmD', tmE', tmH', tmL', tmMul' :: WFCtxt thry => PTerm thry +tmA' = [wF| a:num |] +tmB' = [wF| b:num |] +tmC' = [wF| c:num |] +tmD' = [wF| d:num |] +tmE' = [wF| e:num |] +tmH' = [wF| h:num |] +tmL' = [wF| l:num |] +tmMul' = [wF| (*) |] + +-- numeral conversions +convNUM_EVEN :: (BasicConvs thry, WFCtxt thry) => Conversion cls thry +convNUM_EVEN = Conv $ \ tm -> + do (tth, rths) <- ruleCONJ_PAIR thmARITH_EVEN + runConv (convGEN_REWRITE id [tth] `_THEN` convGEN_REWRITE id [rths]) tm + +convNUM_SUC :: (BasicConvs thry, WFCtxt thry) => Conversion cls thry +convNUM_SUC = Conv $ \ tm -> + case tm of + (Comb SUC (NUMERAL mtm)) -> + if wellformed mtm + then do tmM <- serve tmM' + tmN <- serve tmN' + tmZero <- serve tmZero' + pth <- convNUM_SUC_pth + th1 <- ruleNUM_ADC tmZero mtm + let ntm = fromJust . rand $ concl th1 + liftO $ primEQ_MP + (fromJust $ primINST [(tmM, mtm), (tmN, ntm)] pth) th1 + else fail "convNUM_SUC: not wellformed." + _ -> fail "convNUM_SUC" + where convNUM_SUC_pth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm + convNUM_SUC_pth = cacheProof "convNUM_SUC_pth" ctxtWF . + prove "SUC(_0 + m) = n <=> SUC(NUMERAL m) = NUMERAL n" $ + tacBINOP `_THEN` tacMESON [defNUMERAL, thmADD_CLAUSES] + +convNUM_ADD :: (BasicConvs thry, WFCtxt thry) => Conversion cls thry +convNUM_ADD = Conv $ \ tm -> + case tm of + (Comb (Comb (Const "+" _) (NUMERAL mtm)) (NUMERAL ntm)) -> + if wellformed mtm && wellformed ntm + then do tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + pth <- convNUM_ADD_pth + th1 <- ruleNUM_ADD mtm ntm + let ptm = fromJust . rand $ concl th1 + th2 = fromJust $ primINST [ (tmM, mtm), (tmN, ntm) + , (tmP, ptm) ] pth + liftO $ primEQ_MP th2 th1 + else fail "convNUM_ADD: not wellformed." + _ -> fail "convNUM_ADD" + where convNUM_ADD_pth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm + convNUM_ADD_pth = cacheProof "convNUM_ADD_pth" ctxtWF $ + ruleMESON [defNUMERAL] + "m + n = p <=> NUMERAL m + NUMERAL n = NUMERAL p" + +convNUM_MULT :: (BasicConvs thry, WFCtxt thry) => Conversion cls thry +convNUM_MULT = Conv $ \ tm -> + case tm of + (Comb (Comb (Const "*" _) (NUMERAL mtm)) (NUMERAL ntm)) -> + if mtm == ntm + then do tmM <- serve tmM' + tmP <- serve tmP' + pth <- convNUM_MULT_pth2 + th1 <- ruleNUM_SQUARE mtm + let ptm = fromJust . rand $ concl th1 + liftO $ primEQ_MP + (fromJust $ primINST [(tmM, mtm), (tmP, ptm)] pth) th1 + else let (w1, z1) = fromJust $ bitcounts mtm + (w2, z2) = fromJust $ bitcounts ntm in + do tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + pth <- convNUM_MULT_pth1 + th1 <- ruleNUM_MUL (w1+z1) (w2+z2) mtm ntm + let ptm = fromJust . rand $ concl th1 + th2 = fromJust $ primINST [ (tmM, mtm), (tmN, ntm) + , (tmP, ptm) ] pth + liftO $ primEQ_MP th2 th1 + _ -> fail "convNUM_MULT" + where convNUM_MULT_pth1 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_MULT_pth1 = cacheProof "convNUM_MULT_pth1" ctxtWF $ + ruleMESON [defNUMERAL] + "m * n = p <=> NUMERAL m * NUMERAL n = NUMERAL p" + + convNUM_MULT_pth2 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_MULT_pth2 = cacheProof "convNUM_MULT_pth2" ctxtWF $ + ruleMESON [defNUMERAL, thmEXP_2] + "m EXP 2 = p <=> NUMERAL m * NUMERAL m = NUMERAL p" + +convNUM_LE :: (BasicConvs thry, WFCtxt thry) => Conversion cls thry +convNUM_LE = Conv $ \ tm -> + case tm of + (Comb (Comb (Const "<=" _) (NUMERAL mtm)) (NUMERAL ntm)) -> + let rel = orderrelation mtm ntm in + if rel == Just EQ + then do pth <- convNUM_LE_rth + tmN <- serve tmN' + liftO $ primINST [(tmN, ntm)] pth + else if rel == Just LT + then do pth <- convNUM_LE_pth + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + dtm <- subbn ntm mtm + th <- ruleNUM_ADD dtm mtm + liftO $ ruleQUICK_PROVE_HYP th #<< + primINST [(tmM, dtm), (tmN, mtm), (tmP, ntm)] pth + else do pth <- convNUM_LE_qth + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + dtm <- sbcbn mtm ntm + th <- ruleNUM_ADC dtm ntm + liftO $ ruleQUICK_PROVE_HYP th #<< + primINST [(tmM, dtm), (tmN, mtm), (tmP, ntm)] pth + _ -> fail "convNUM_LE" + where convNUM_LE_pth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm + convNUM_LE_pth = cacheProof "convNUM_LE_pth" ctxtWF $ + ruleUNDISCH =<< + prove "m + n = p ==> ((NUMERAL n <= NUMERAL p) <=> T)" + (_DISCH_THEN (tacSUBST1 . ruleSYM) `_THEN` + tacREWRITE [defNUMERAL] `_THEN` + tacMESON [thmLE_ADD, thmADD_SYM]) + + convNUM_LE_qth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm + convNUM_LE_qth = cacheProof "convNUM_LE_qth" ctxtWF $ + ruleUNDISCH =<< + prove "SUC(m + p) = n ==> (NUMERAL n <= NUMERAL p <=> F)" + (_DISCH_THEN (tacSUBST1 . ruleSYM) `_THEN` + tacREWRITE [ defNUMERAL, thmNOT_LE + , thmADD_CLAUSES, thmLT_EXISTS ] `_THEN` + tacMESON [thmADD_SYM]) + + convNUM_LE_rth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm + convNUM_LE_rth = cacheProof "convNUM_LE_rth" ctxtWF $ + prove "NUMERAL n <= NUMERAL n <=> T" $ + tacREWRITE [thmLE_REFL] + +convNUM_EQ :: (BasicConvs thry, WFCtxt thry) => Conversion cls thry +convNUM_EQ = Conv $ \ tm -> + do tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + pth <- convNUM_EQ_pth + qth <- convNUM_EQ_qth + rth <- convNUM_EQ_rth + case tm of + (NUMERAL mtm := NUMERAL ntm) -> + let rel = orderrelation mtm ntm in + if rel == Just EQ + then liftO $ primINST [(tmN, ntm)] rth + else if rel == Just LT + then do dtm <- sbcbn ntm mtm + th <- ruleNUM_ADC dtm mtm + liftO $ ruleQUICK_PROVE_HYP th #<< + primINST [ (tmM, dtm), (tmN, mtm) + , (tmP, ntm) ] pth + else do dtm <- sbcbn mtm ntm + th <- ruleNUM_ADC dtm ntm + liftO $ ruleQUICK_PROVE_HYP th #<< + primINST [ (tmM, dtm), (tmN, mtm) + , (tmP, ntm) ] qth + _ -> fail "convNUM_EQ" + where convNUM_EQ_pth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm + convNUM_EQ_pth = cacheProof "convNUM_EQ_pth" ctxtWF $ + ruleUNDISCH =<< + prove "SUC(m + n) = p ==> ((NUMERAL n = NUMERAL p) <=> F)" + (_DISCH_THEN (tacSUBST1 <#< ruleSYM) `_THEN` + tacREWRITE [ defNUMERAL, ruleGSYM thmLE_ANTISYM + , thmDE_MORGAN ] `_THEN` + tacREWRITE [thmNOT_LE, thmLT_EXISTS, thmADD_CLAUSES] `_THEN` + tacMESON [thmADD_SYM]) + + convNUM_EQ_qth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm + convNUM_EQ_qth = cacheProof "convNUM_EQ_qth" ctxtWF $ + ruleUNDISCH =<< + prove "SUC(m + p) = n ==> ((NUMERAL n = NUMERAL p) <=> F)" + (_DISCH_THEN (tacSUBST1 <#< ruleSYM) `_THEN` + tacREWRITE [ defNUMERAL, ruleGSYM thmLE_ANTISYM + , thmDE_MORGAN ] `_THEN` + tacREWRITE [thmNOT_LE, thmLT_EXISTS, thmADD_CLAUSES] `_THEN` + tacMESON [thmADD_SYM]) + + convNUM_EQ_rth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm + convNUM_EQ_rth = cacheProof "convNUM_EQ_rth" ctxtWF $ + prove "(NUMERAL n = NUMERAL n) <=> T" tacREWRITE_NIL + +convNUM_EXP :: (BasicConvs thry, WFCtxt thry) =>Conversion cls thry +convNUM_EXP = Conv $ \ tm -> + (do tth <- convNUM_EXP_tth + th <- runConv (convGEN_REWRITE id [tth]) tm + (lop, r) <- liftO $ destComb =<< rand (concl th) + (_, l) <- liftO $ destComb lop + if not (wellformed l && wellformed r) + then fail "" + else do th' <- ruleNUM_EXP_CONV l r + tm' <- liftO $ rand (concl th') + fth <- convNUM_EXP_fth + tmM <- serve tmM' + liftO $ liftM1 primTRANS (primTRANS th th') #<< + primINST [(tmM, tm')] fth) "convNUM_EXP" + where ruleNUM_EXP_CONV :: (BasicConvs thry, WFCtxt thry )=> HOLTerm -> HOLTerm + -> HOL cls thry HOLThm + ruleNUM_EXP_CONV l (Const "_0" _) = + do pth <- convNUM_EXP_pth + tmM <- serve tmM' + liftO $ primINST [(tmM, l)] pth + ruleNUM_EXP_CONV l r = + let (b, r') = fromJust $ destComb r in + do tmBIT0 <- serve tmBIT0' + tmMul <- serve tmMul' + tmA <- serve tmA' + tmB <- serve tmB' + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + if b == tmBIT0 + then do th1 <- ruleNUM_EXP_CONV l r' + let tm1 = fromJust . rand $ concl th1 + th2 <- runConv convNUM_MULT' #<< + mkBinop tmMul tm1 tm1 + let tm2 = fromJust . rand $ concl th2 + pth <- convNUM_EXP_pth0 + let th3 = fromJust $ + primINST [ (tmM, l), (tmN, r'), (tmP, tm1) + , (tmB, tm2), (tmA, tm2) ] pth + ruleMP (ruleMP th3 th1) th2 + else do th1 <- ruleNUM_EXP_CONV l r' + let tm1 = fromJust . rand $ concl th1 + th2 <- runConv convNUM_MULT' #<< + mkBinop tmMul tm1 tm1 + let tm2 = fromJust . rand $ concl th2 + th3 <- runConv convNUM_MULT' #<< + mkBinop tmMul l tm2 + let tm3 = fromJust . rand $ concl th3 + pth <- convNUM_EXP_pth1 + let th4 = fromJust $ + primINST [ (tmM, l), (tmN, r'), (tmP, tm1) + , (tmB, tm2), (tmA, tm3) ] pth + ruleMP (ruleMP (ruleMP th4 th1) th2) th3 + convNUM_MULT' :: (BasicConvs thry, WFCtxt thry) => Conversion cls thry + convNUM_MULT' = Conv $ \ tm -> + case tm of + (Comb (Comb (Const "*" _) mtm) ntm) + | mtm == ntm -> + do th1 <- ruleNUM_SQUARE mtm + let ptm = fromJust . rand $ concl th1 + pth <- convNUM_EXP_pth_refl + tmM <- serve tmM' + tmP <- serve tmP' + liftO $ primEQ_MP + (fromJust $ primINST [(tmM, mtm), (tmP, ptm)] pth) th1 + | otherwise -> + let (w1, z1) = fromJust $ bitcounts mtm + (w2, z2) = fromJust $ bitcounts ntm in + ruleNUM_MUL (w1+z1) (w2+z2) mtm ntm + _ -> fail "convNUM_MULT'" + + convNUM_EXP_pth0 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_EXP_pth0 = cacheProof "convNUM_EXP_pth0" ctxtWF . + prove "(m EXP n = p) ==> (p * p = a) ==> (m EXP (BIT0 n) = a)" $ + _REPEAT (_DISCH_THEN (tacSUBST1 . ruleSYM)) `_THEN` + tacREWRITE [thmBIT0, thmEXP_ADD] + + convNUM_EXP_pth1 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_EXP_pth1 = cacheProof "convNUM_EXP_pth1" ctxtWF . + prove [str| (m EXP n = p) ==> (p * p = b) ==> (m * b = a) + ==> (m EXP (BIT1 n) = a) |] $ + _REPEAT (_DISCH_THEN (tacSUBST1 . ruleSYM)) `_THEN` + tacREWRITE [thmBIT1, thmEXP_ADD, defEXP] + + convNUM_EXP_pth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm + convNUM_EXP_pth = cacheProof "convNUM_EXP_pth" ctxtWF . + prove "m EXP _0 = BIT1 _0" $ + tacMP (ruleCONJUNCT1 defEXP) `_THEN` + tacREWRITE [defNUMERAL, thmBIT1] `_THEN` + _DISCH_THEN tacMATCH_ACCEPT + + convNUM_EXP_tth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm + convNUM_EXP_tth = cacheProof "convNUM_EXP_tth" ctxtWF . + prove "(NUMERAL m) EXP (NUMERAL n) = m EXP n" $ + tacREWRITE [defNUMERAL] + + convNUM_EXP_fth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm + convNUM_EXP_fth = cacheProof "convNUM_EXP_fth" ctxtWF . + prove "m = NUMERAL m" $ + tacREWRITE [defNUMERAL] + + convNUM_EXP_pth_refl :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_EXP_pth_refl = cacheProof "convNUM_EXP_pth_refl" ctxtWF $ + ruleMESON [thmEXP_2] "m EXP 2 = p <=> m * m = p" + +convNUM_LT :: (BasicConvs thry, WFCtxt thry) => Conversion cls thry +convNUM_LT = Conv $ \ tm -> + case tm of + (Comb (Comb (Const "<" _) (NUMERAL mtm)) (NUMERAL ntm)) -> + let rel = fromJust $ orderrelation mtm ntm in + if rel == EQ + then do pth <- convNUM_LT_rth + tmN <- serve tmN' + liftO $ primINST [(tmN, ntm)] pth + else if rel == LT + then do dtm <- sbcbn ntm mtm + th <- ruleNUM_ADC dtm mtm + pth <- convNUM_LT_pth + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + liftO $ ruleQUICK_PROVE_HYP th #<< + primINST [(tmM, dtm), (tmN, mtm), (tmP, ntm)] pth + else do dtm <- subbn mtm ntm + th <- ruleNUM_ADD dtm ntm + pth <- convNUM_LT_qth + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + liftO $ ruleQUICK_PROVE_HYP th #<< + primINST [(tmM, dtm), (tmN, mtm), (tmP, ntm)] pth + _ -> fail "convNUM_LT" + where convNUM_LT_pth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm + convNUM_LT_pth = cacheProof "convNUM_LT_pth" ctxtWF $ + ruleUNDISCH =<< + prove "SUC(m + n) = p ==> ((NUMERAL n < NUMERAL p) <=> T)" + (tacREWRITE [defNUMERAL, thmLT_EXISTS, thmADD_CLAUSES] `_THEN` + tacMESON [thmADD_SYM]) + + convNUM_LT_qth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm + convNUM_LT_qth = cacheProof "convNUM_LT_qth" ctxtWF $ + ruleUNDISCH =<< + prove "m + p = n ==> (NUMERAL n < NUMERAL p <=> F)" + (_DISCH_THEN (tacSUBST1 . ruleSYM) `_THEN` + tacREWRITE [thmNOT_LT, defNUMERAL] `_THEN` + tacMESON [thmLE_ADD, thmADD_SYM]) + + convNUM_LT_rth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm + convNUM_LT_rth = cacheProof "convNUM_LT_rth" ctxtWF $ + prove "NUMERAL n < NUMERAL n <=> F" $ tacMESON[thmLT_REFL] + +ruleNUM_ADD :: (BasicConvs thry, WFCtxt thry) => HOLTerm -> HOLTerm + -> HOL cls thry HOLThm +ruleNUM_ADD mtm ntm = + let (mLo, mHi) = fromJust $ topsplit mtm + (nLo, nHi) = fromJust $ topsplit ntm + mInd = case mHi of + (Const "_0" _) -> mLo + _ -> mLo + 16 + nInd = case nHi of + (Const "_0" _) -> nLo + _ -> nLo + 16 + ind = 32 * mInd + nInd in + do clauses <- addClauses + let th1 = clauses V.! ind + flags <- addFlags + case flags V.! ind of + 0 -> do tmM <- serve tmM' + liftO $ primINST [(tmM, mHi)] th1 + 1 -> do tmN <- serve tmN' + liftO $ primINST [(tmN, nHi)] th1 + 2 -> do th2@(Thm _ (Comb _ ptm)) <- ruleNUM_ADD mHi nHi + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + let th3 = fromJust $ primINST [ (tmM, mHi), (tmN, nHi) + , (tmP, ptm)] th1 + liftO $ primEQ_MP th3 th2 + 3 -> do th2@(Thm _ (Comb _ ptm)) <- ruleNUM_ADC mHi nHi + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + let th3 = fromJust $ primINST [ (tmM, mHi), (tmN, nHi) + , (tmP, ptm)] th1 + liftO $ primEQ_MP th3 th2 + _ -> fail "ruleNUM_ADD" + +ruleNUM_ADC :: (BasicConvs thry, WFCtxt thry) => HOLTerm -> HOLTerm + -> HOL cls thry HOLThm +ruleNUM_ADC mtm ntm = + let (mLo, mHi) = fromJust $ topsplit mtm + (nLo, nHi) = fromJust $ topsplit ntm + mInd = case mHi of + (Const "_0" _) -> mLo + _ -> mLo + 16 + nInd = case nHi of + (Const "_0" _) -> nLo + _ -> nLo + 16 + ind = 32 * mInd + nInd in + do clauses <- adcClauses + flags <- adcFlags + let th1 = clauses V.! ind + case flags V.! ind of + 0 -> do tmM <- serve tmM' + liftO $ primINST [(tmM, mHi)] th1 + 1 -> do tmN <- serve tmN' + liftO $ primINST [(tmN, nHi)] th1 + 2 -> do th2@(Thm _ (Comb _ ptm)) <- ruleNUM_ADD mHi nHi + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + let th3 = fromJust $ primINST [ (tmM, mHi), (tmN, nHi) + , (tmP, ptm)] th1 + liftO $ primEQ_MP th3 th2 + 3 -> do th2@(Thm _ (Comb _ ptm)) <- ruleNUM_ADC mHi nHi + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + let th3 = fromJust $ primINST [ (tmM, mHi), (tmN, nHi) + , (tmP, ptm)] th1 + liftO $ primEQ_MP th3 th2 + _ -> fail "ruleNUM_ADC" + + +ruleNUM_MUL_pth_0 :: (BasicConvs thry, WFCtxt thry) => [HOL cls thry HOLThm] +ruleNUM_MUL_pth_0 = + cacheProofs ["ruleNUM_MUL_pth_0l", "ruleNUM_MUL_pth_0r"] ctxtWF $ + do th <- prove [str| _0 * n = _0 /\ m * _0 = _0 |] $ + tacMESON [defNUMERAL, thmMULT_CLAUSES] + (th1, th2) <- ruleCONJ_PAIR th + return [th1, th2] + +ruleNUM_MUL_pth_1 :: (BasicConvs thry, WFCtxt thry) => [HOL cls thry HOLThm] +ruleNUM_MUL_pth_1 = + cacheProofs ["ruleNUM_MUL_pth_1l", "ruleNUM_MUL_pth_1r"] ctxtWF $ + do th <- prove [str| (BIT1 _0) * n = n /\ m * (BIT1 _0) = m |] $ + tacMESON [defNUMERAL, thmMULT_CLAUSES] + (th1, th2) <- ruleCONJ_PAIR th + return [th1, th2] + +ruleNUM_MUL_pth_even :: (BasicConvs thry, WFCtxt thry) => [HOL cls thry HOLThm] +ruleNUM_MUL_pth_even = + cacheProofs ["ruleNUM_MUL_pth_evenl", "ruleNUM_MUL_pth_evenr"] ctxtWF $ + do th <- prove [str| (m * n = p <=> (BIT0 m) * n = BIT0 p) /\ + (m * n = p <=> m * BIT0 n = BIT0 p) |] $ + tacREWRITE [thmBIT0] `_THEN` + tacREWRITE [ruleGSYM thmMULT_2] `_THEN` + tacREWRITE [runConv (convAC thmMULT_AC) =<< toHTm + "m * 2 * n = 2 * m * n"] `_THEN` + tacREWRITE [ ruleGSYM thmMULT_ASSOC + , thmEQ_MULT_LCANCEL, thmARITH_EQ ] + (th1, th2) <- ruleCONJ_PAIR th + return [th1, th2] + + +ruleNUM_MUL :: (BasicConvs thry, WFCtxt thry) => Int -> Int -> HOLTerm + -> HOLTerm -> HOL cls thry HOLThm +ruleNUM_MUL _ _ (Const "_0" _) tm' = + do pth <- ruleNUM_MUL_pth_0l + tmN <- serve tmN' + liftO $ primINST [(tmN, tm')] pth + where ruleNUM_MUL_pth_0l :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_MUL_pth_0l = ruleNUM_MUL_pth_0 !! 0 +ruleNUM_MUL _ _ tm (Const "_0" _) = + do pth <- ruleNUM_MUL_pth_0r + tmM <- serve tmM' + liftO $ primINST [(tmM, tm)] pth + where ruleNUM_MUL_pth_0r :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_MUL_pth_0r = ruleNUM_MUL_pth_0 !! 1 +ruleNUM_MUL _ _ (BIT1 (Const "_0" _)) tm' = + do pth <- ruleNUM_MUL_pth_1l + tmN <- serve tmN' + liftO $ primINST [(tmN, tm')] pth + where ruleNUM_MUL_pth_1l :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_MUL_pth_1l = ruleNUM_MUL_pth_1 !! 0 +ruleNUM_MUL _ _ tm (BIT1 (Const "_0" _)) = + do pth <- ruleNUM_MUL_pth_1r + tmM <- serve tmM' + liftO $ primINST [(tmM, tm)] pth + where ruleNUM_MUL_pth_1r :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_MUL_pth_1r = ruleNUM_MUL_pth_1 !! 1 +ruleNUM_MUL k l (BIT0 mtm) tm' = + do th0 <- ruleNUM_MUL (k - 1) l mtm tm' + pth <- ruleNUM_MUL_pth_evenl + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + let tm0 = fromJust . rand $ concl th0 + th1 = fromJust $ primINST [(tmM, mtm), (tmN, tm'), (tmP, tm0)] pth + liftO $ primEQ_MP th1 th0 + where ruleNUM_MUL_pth_evenl :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_MUL_pth_evenl = ruleNUM_MUL_pth_even !! 0 +ruleNUM_MUL k l tm (BIT0 ntm) = + do th0 <- ruleNUM_MUL k (l - 1) tm ntm + pth <- ruleNUM_MUL_pth_evenr + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + let tm0 = fromJust . rand $ concl th0 + th1 = fromJust $ primINST [(tmM, tm), (tmN, ntm), (tmP, tm0)] pth + liftO $ primEQ_MP th1 th0 + where ruleNUM_MUL_pth_evenr :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_MUL_pth_evenr = ruleNUM_MUL_pth_even !! 1 +ruleNUM_MUL k l tm@(BIT1 mtm) tm'@(BIT1 ntm) + | k <= 50 || l <= 50 || k * k < l || l * l < k = + case (mtm, ntm) of + (BIT1 (BIT1 _), _) -> + do pth <- ruleNUM_MUL_pth_recodel + tmA <- serve tmA' + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + tmZero <- serve tmZero' + th1 <- ruleNUM_ADC tmZero tm + let ptm = fromJust . rand $ concl th1 + th2 <- ruleNUM_MUL k l ptm tm' + let tm2 = fromJust . rand $ concl th2 + atm <- subbn tm2 tm' + let th3 = fromJust $ primINST [ (tmM, tm), (tmN, tm') + , (tmP, ptm), (tmA, atm) ] pth + th4 = rulePROVE_HYP th1 th3 + th5 <- ruleNUM_ADD atm tm' + liftO $ primEQ_MP th4 =<< primTRANS th2 =<< ruleSYM th5 + (_, BIT1 (BIT1 _)) -> + do pth <- ruleNUM_MUL_pth_recoder + tmA <- serve tmA' + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + tmZero <- serve tmZero' + th1 <- ruleNUM_ADC tmZero tm' + let ptm = fromJust . rand $ concl th1 + th2 <- ruleNUM_MUL k l tm ptm + let tm2 = fromJust . rand $ concl th2 + atm <- subbn tm2 tm + let th3 = fromJust $ primINST [ (tmM, tm), (tmN, tm') + , (tmP, ptm), (tmA, atm) ] pth + th4 = rulePROVE_HYP th1 th3 + th5 <- ruleNUM_ADD atm tm + liftO $ primEQ_MP th4 =<< primTRANS th2 =<< ruleSYM th5 + _ + | k <= l -> + do pth <- ruleNUM_MUL_pth_oddl + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + th0 <- ruleNUM_MUL (k - 1) l mtm tm' + let ptm = fromJust . rand $ concl th0 + th1 = fromRight $ primEQ_MP + (fromJust $ primINST [ (tmM, mtm), (tmN, tm') + , (tmP, ptm)] pth) th0 + tm1 = fromJust $ lHand =<< rand (concl th1) + th2 <- ruleNUM_ADD tm1 tm' + liftO $ primTRANS th1 th2 + | otherwise -> + do pth <- ruleNUM_MUL_pth_oddr + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + th0 <- ruleNUM_MUL k (l - 1) tm ntm + let ptm = fromJust . rand $ concl th0 + th1 = fromRight $ primEQ_MP + (fromJust $ primINST [ (tmM, tm), (tmN, ntm) + , (tmP, ptm) ] pth) th0 + tm1 = fromJust $ lHand =<< rand (concl th1) + th2 <- ruleNUM_ADD tm1 tm + liftO $ primTRANS th1 th2 + | otherwise = + let mval = fromJust $ destRawNumeral mtm + nval = fromJust $ destRawNumeral ntm in + if nval <= mval + then do pth <- ruleNUM_MUL_pth_oo1 + tmA <- serve tmA' + tmB <- serve tmB' + tmC <- serve tmC' + tmD <- serve tmD' + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + n <- mkNumeral (mval - nval) + let ptm = fromJust $ rand n + th2 <- ruleNUM_ADD ntm ptm + th3 <- ruleNUM_ADC mtm ntm + let atm = fromJust . rand $ concl th3 + th4 <- ruleNUM_SQUARE ptm + let btm = fromJust . rand $ concl th4 + th5 <- ruleNUM_SQUARE atm + let ctm = fromJust . rand $ concl th5 + dtm <- subbn ctm btm + th6 <- ruleNUM_ADD btm dtm + let th1 = fromJust $ primINST [ (tmA, atm), (tmB, btm) + , (tmC, ctm), (tmD, dtm) + , (tmM, mtm), (tmN, ntm) + , (tmP, ptm) ] pth + th7 <- foldr1M ruleCONJ [th2, th3, th4, th5, th6] + liftO $ ruleQUICK_PROVE_HYP th7 th1 + else do pth <- ruleNUM_MUL_pth_oo2 + tmA <- serve tmA' + tmB <- serve tmB' + tmC <- serve tmC' + tmD <- serve tmD' + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + n <- mkNumeral (nval - mval) + let ptm = fromJust $ rand n + th2 <- ruleNUM_ADD mtm ptm + th3 <- ruleNUM_ADC ntm mtm + let atm = fromJust . rand $ concl th3 + th4 <- ruleNUM_SQUARE ptm + let btm = fromJust . rand $ concl th4 + th5 <- ruleNUM_SQUARE atm + let ctm = fromJust . rand $ concl th5 + dtm <- subbn ctm btm + th6 <- ruleNUM_ADD btm dtm + let th1 = fromJust $ primINST [ (tmA, atm), (tmB, btm) + , (tmC, ctm), (tmD, dtm) + , (tmM, mtm), (tmN, ntm) + , (tmP, ptm) ] pth + th7 <- foldr1M ruleCONJ [th2, th3, th4, th5, th6] + liftO $ ruleQUICK_PROVE_HYP th7 th1 + where ruleNUM_MUL_pth_oo :: (BasicConvs thry, WFCtxt thry) + => [HOL cls thry HOLThm] + ruleNUM_MUL_pth_oo = + cacheProofs ["ruleNUM_MUL_pth_oo1", "ruleNUM_MUL_pth_oo2"] ctxtWF $ + do tmM <- serve tmM' + tmN <- serve tmN' + th1 <- prove [str| n + p = m /\ SUC(m + n) = a /\ + p EXP 2 = b /\ a EXP 2 = c /\ b + d = c + ==> ((BIT1 m) * (BIT1 n) = d) |] $ + tacABBREV "two = 2" `_THEN` + tacREWRITE [thmBIT1, thmIMP_CONJ] `_THEN` + _FIRST_X_ASSUM (tacSUBST1 . ruleSYM) `_THEN` + tacREWRITE [thmEXP_2, ruleGSYM thmMULT_2] `_THEN` + tacREPLICATE 4 (_DISCH_THEN + (tacSUBST1 . ruleSYM)) `_THEN` + tacREWRITE [thmADD1, runConv (convAC thmADD_AC) =<< + toHTm [str| ((n + p) + n) + 1 = + (p + (n + n)) + 1 |]] `_THEN` + tacREWRITE [ruleGSYM thmMULT_2] `_THEN` + tacREWRITE [ thmLEFT_ADD_DISTRIB + , thmRIGHT_ADD_DISTRIB ] `_THEN` + tacREWRITE [ ruleGSYM thmADD_ASSOC, thmMULT_CLAUSES + , thmEQ_ADD_LCANCEL ] `_THEN` + _DISCH_THEN tacSUBST1 `_THEN` + tacREWRITE [ thmMULT_2, thmLEFT_ADD_DISTRIB + , thmRIGHT_ADD_DISTRIB ] `_THEN` + tacREWRITE [thmMULT_AC] `_THEN` + tacREWRITE [thmADD_AC] + th2 <- ruleUNDISCH_ALL th1 + let th3 = fromJust $ primINST [(tmM, tmN), (tmN, tmM)] th2 + th4 <- rulePURE_ONCE_REWRITE [thmMULT_SYM] th3 + return [th2, th4] + ruleNUM_MUL_pth_oo1 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_MUL_pth_oo1 = ruleNUM_MUL_pth_oo !! 0 + ruleNUM_MUL_pth_oo2 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_MUL_pth_oo2 = ruleNUM_MUL_pth_oo !! 1 + + ruleNUM_MUL_pth_odd :: (BasicConvs thry, WFCtxt thry) + => [HOL cls thry HOLThm] + ruleNUM_MUL_pth_odd = + cacheProofs ["ruleNUM_MUL_pth_oddl", "ruleNUM_MUL_pth_oddr"] ctxtWF $ + do th <- prove [str|(m * n = p <=> BIT1 m * n = BIT0 p + n) /\ + (m * n = p <=> m * BIT1 n = BIT0 p + m) |] $ + tacREWRITE [thmBIT0, thmBIT1] `_THEN` + tacREWRITE [ruleGSYM thmMULT_2] `_THEN` + tacREWRITE [thmMULT_CLAUSES] `_THEN` + tacREWRITE [ruleMESON [thmMULT_AC, thmADD_SYM] + "m + m * 2 * n = 2 * m * n + m"] `_THEN` + tacREWRITE [ ruleGSYM thmMULT_ASSOC + , thmEQ_MULT_LCANCEL + , thmEQ_ADD_RCANCEL ] `_THEN` + tacREWRITE [thmARITH_EQ] + (th1, th2) <- ruleCONJ_PAIR th + return [th1, th2] + ruleNUM_MUL_pth_oddl :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_MUL_pth_oddl = ruleNUM_MUL_pth_odd !! 0 + ruleNUM_MUL_pth_oddr :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_MUL_pth_oddr = ruleNUM_MUL_pth_odd !! 1 + + ruleNUM_MUL_pth_recodel :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_MUL_pth_recodel = cacheProof "ruleNUM_MUL_pth_recodel" ctxtWF $ + do th <- prove "SUC(_0 + m) = p ==> (p * n = a + n <=> m * n = a)" $ + tacSUBST1 (ruleMESON [defNUMERAL] "_0 = 0") `_THEN` + _DISCH_THEN (tacSUBST1 . ruleSYM) `_THEN` + tacREWRITE [thmADD_CLAUSES, thmMULT_CLAUSES + , thmEQ_ADD_RCANCEL] + ruleUNDISCH_ALL th + + ruleNUM_MUL_pth_recoder :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_MUL_pth_recoder = cacheProof "ruleNUM_MUL_pth_recoder" ctxtWF $ + do th <- prove "SUC(_0 + n) = p ==> (m * p = a + m <=> m * n = a)" $ + tacONCE_REWRITE [thmMULT_SYM] `_THEN` + tacSUBST1 (ruleMESON [defNUMERAL] "_0 = 0") `_THEN` + _DISCH_THEN (tacSUBST1 . ruleSYM) `_THEN` + tacREWRITE [thmADD_CLAUSES, thmMULT_CLAUSES + , thmEQ_ADD_RCANCEL] + ruleUNDISCH_ALL th +ruleNUM_MUL _ _ _ _ = fail "ruleNUM_MUL" + +convNUM_SHIFT :: (BasicConvs thry, WFCtxt thry) => Int -> Conversion cls thry +convNUM_SHIFT k = Conv $ \ tm -> + if k <= 0 + then do pth <- convNUM_SHIFT_pth_base + tmN <- serve tmN' + liftO $ primINST [(tmN, tm)] pth + else case tm of + (Comb _ (Comb _ (Comb _ (Comb _ _)))) + | k >= 4 -> + let (i, ntm) = fromJust $ topsplit tm in + do th1 <- runConv (convNUM_SHIFT (k - 4)) ntm + case concl th1 of + (Comb _ (Comb (Comb _ (Const "_0" _)) + (Comb (Comb _ ptm) btm))) -> + do tmB <- serve tmB' + tmN <- serve tmN' + tmP <- serve tmP' + pths <- convNUM_SHIFT_pths0 + let th2 = pths V.! i + let th3 = fromJust $ + primINST [ (tmN, ntm), (tmB, btm) + , (tmP, ptm) ] th2 + liftO $ primEQ_MP th3 th1 + (Comb _ (Comb (Comb _ atm) + (Comb (Comb _ ptm) btm))) -> + do tmA <- serve tmA' + tmB <- serve tmB' + tmN <- serve tmN' + tmP <- serve tmP' + pths <- convNUM_SHIFT_pths1 + let th2 = pths V.! i + let th3 = fromJust $ + primINST [ (tmN, ntm), (tmA, atm) + , (tmB, btm), (tmP, ptm) + ] th2 + liftO $ primEQ_MP th3 th1 + _ -> fail "convNUM_SHIFT" + | otherwise -> fail "convNUM_SHIFT: malformed numeral" + (BIT0 ntm) -> + do th1 <- runConv (convNUM_SHIFT (k - 1)) ntm + case concl th1 of + (Comb _ (Comb (Comb _ (Const "_0" _)) + (Comb (Comb _ ptm) btm))) -> + do pth <- convNUM_SHIFT_pthz + tmB <- serve tmB' + tmN <- serve tmN' + tmP <- serve tmP' + liftO $ primEQ_MP + (fromJust $ primINST [ (tmN, ntm), (tmB, btm) + , (tmP, ptm) ] pth) th1 + (Comb _ (Comb (Comb _ atm) + (Comb (Comb _ ptm) btm))) -> + do pth <- convNUM_SHIFT_pth0 + tmA <- serve tmA' + tmB <- serve tmB' + tmN <- serve tmN' + tmP <- serve tmP' + liftO $ primEQ_MP + (fromJust $ primINST [ (tmN, ntm), (tmA, atm) + , (tmB, btm), (tmP, ptm) + ] pth) th1 + _ -> fail "convNUM_SHIFT" + (BIT1 ntm) -> + do th1 <- runConv (convNUM_SHIFT (k - 1)) ntm + let (Comb _ (Comb (Comb _ atm) + (Comb (Comb _ ptm) btm))) = concl th1 + pth <- convNUM_SHIFT_pth1 + tmA <- serve tmA' + tmB <- serve tmB' + tmN <- serve tmN' + tmP <- serve tmP' + liftO $ primEQ_MP + (fromJust $ primINST [ (tmN, ntm), (tmA, atm) + , (tmB, btm), (tmP, ptm) ] pth) th1 + (Const "_0" _) -> + do th1 <- runConv (convNUM_SHIFT (k - 1)) tm + let (Comb _ (Comb (Comb _ atm) + (Comb (Comb _ ptm) btm))) = concl th1 + pth <- convNUM_SHIFT_pth_triv + tmA <- serve tmA' + tmB <- serve tmB' + tmP <- serve tmP' + liftO $ primEQ_MP + (fromJust $ primINST [ (tmA, atm), (tmB, btm) + , (tmP, ptm) ] pth) th1 + _ -> fail "convNUM_SHIFT: malformed numeral" + where convNUM_SHIFT_pth0 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_SHIFT_pth0 = cacheProof "convNUM_SHIFT_pth0" ctxtWF . + prove "(n = a + p * b <=> BIT0 n = BIT0 a + BIT0 p * b)" $ + tacREWRITE [thmBIT0, thmBIT1] `_THEN` + tacREWRITE [ ruleGSYM thmMULT_2, ruleGSYM thmMULT_ASSOC + , ruleGSYM thmLEFT_ADD_DISTRIB ] `_THEN` + tacREWRITE [thmEQ_MULT_LCANCEL, thmARITH_EQ] + + convNUM_SHIFT_pthz :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_SHIFT_pthz = cacheProof "convNUM_SHIFT_pthz" ctxtWF $ + do th1 <- ruleSPEC "_0" defNUMERAL + prove "n = _0 + p * b <=> BIT0 n = _0 + BIT0 p * b" $ + tacSUBST1 (ruleSYM th1) `_THEN` + tacREWRITE [thmBIT1, thmBIT0] `_THEN` + tacREWRITE [thmADD_CLAUSES, ruleGSYM thmMULT_2] `_THEN` + tacREWRITE [ ruleGSYM thmMULT_ASSOC, thmEQ_MULT_LCANCEL + , thmARITH_EQ ] + + convNUM_SHIFT_pth1 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_SHIFT_pth1 = cacheProof "convNUM_SHIFT_pth1" ctxtWF . + prove "(n = a + p * b <=> BIT1 n = BIT1 a + BIT0 p * b)" $ + tacREWRITE [thmBIT0, thmBIT1] `_THEN` + tacREWRITE [ ruleGSYM thmMULT_2, ruleGSYM thmMULT_ASSOC + , ruleGSYM thmLEFT_ADD_DISTRIB, thmADD_CLAUSES + , thmSUC_INJ ] `_THEN` + tacREWRITE [thmEQ_MULT_LCANCEL, thmARITH_EQ] + + convNUM_SHIFT_pth_base :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_SHIFT_pth_base = cacheProof "convNUM_SHIFT_pth_base" ctxtWF . + prove "n = _0 + BIT1 _0 * n" $ + tacMESON [thmADD_CLAUSES, thmMULT_CLAUSES, defNUMERAL] + + convNUM_SHIFT_pth_triv :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_SHIFT_pth_triv = cacheProof "convNUM_SHIFT_pth_triv" ctxtWF $ + do th1 <- ruleSPEC "_0" defNUMERAL + prove "_0 = a + p * b <=> _0 = a + BIT0 p * b" $ + tacCONV (convBINOP convSYM) `_THEN` + tacSUBST1 (ruleSYM th1) `_THEN` + tacREWRITE [thmADD_EQ_0, thmMULT_EQ_0, thmBIT0] + +convNUM_UNSHIFT :: (BasicConvs thry, WFCtxt thry) => Conversion cls thry +convNUM_UNSHIFT = Conv $ \ tm -> + case tm of + (Comb (Comb (Const "+" _) atm) (Comb (Comb (Const "*" _) ptm) btm)) -> + case (atm, ptm, btm) of + (_, _, Const "_0" _) -> + do pth <- convNUM_UNSHIFT_pth_triv + tmA <- serve tmA' + tmP <- serve tmP' + liftO $ primINST [(tmA, atm), (tmP, ptm)] pth + (_, BIT1 (Const "_0" _), _) -> + do pth <- convNUM_UNSHIFT_pth_base + tmA <- serve tmA' + tmB <- serve tmB' + let th1 = fromJust $ primINST [(tmA, atm), (tmB, btm)] pth + (Comb _ (Comb (Comb _ mtm) ntm)) = concl th1 + th2 <- ruleNUM_ADD mtm ntm + liftO $ primTRANS th1 th2 + (Comb _ (Comb _ (Comb _ (Comb _ atm'))), + Comb _ (Comb _ (Comb _ (Comb _ ptm'@(Comb _ _)))), _) -> + let (i, _) = fromJust $ topsplit atm in + case (atm', ptm') of + (Comb _ (Comb _ (Comb _ (Comb _ atm''))), + Comb _ (Comb _ (Comb _ (Comb _ ptm''@(Comb _ _))))) -> + do tmAdd <- serve tmAdd' + tmMul <- serve tmMul' + let (j, _) = fromJust $ topsplit atm' + tm' = fromRight $ liftM1 mkComb + (mkComb tmAdd atm'') =<< + liftM1 mkComb (mkComb tmMul ptm'') btm + th1 <- runConv convNUM_UNSHIFT tm' + tmA <- serve tmA' + tmB <- serve tmB' + tmN <- serve tmN' + tmP <- serve tmP' + pths <- convNUM_UNSHIFT_puths2 + let pth = pths V.! (16 * j + i) + ntm = fromJust . rand $ concl th1 + th2 = fromJust $ + primINST [ (tmA, atm''), (tmP, ptm'') + , (tmB, btm), (tmN, ntm) ] pth + liftO $ primEQ_MP th2 th1 + _ -> + do tmAdd <- serve tmAdd' + tmMul <- serve tmMul' + let tm' = fromRight $ liftM1 mkComb + (mkComb tmAdd atm') =<< + liftM1 mkComb (mkComb tmMul ptm') btm + th1 <- runConv convNUM_UNSHIFT tm' + tmA <- serve tmA' + tmB <- serve tmB' + tmN <- serve tmN' + tmP <- serve tmP' + pths <- convNUM_UNSHIFT_puths1 + let pth = pths V.! i + ntm = fromJust . rand $ concl th1 + th2 = fromJust $ + primINST [ (tmA, atm'), (tmP, ptm') + , (tmB, btm), (tmN, ntm) ] pth + liftO $ primEQ_MP th2 th1 + (Const "_0" _, BIT0 qtm, _) -> + do pth <- convNUM_UNSHIFT_pthz + tmB <- serve tmB' + tmP <- serve tmP' + let th1 = fromJust $ primINST [(tmB, btm), (tmP, qtm)] pth + ruleCONV (convRAND (convRAND convNUM_UNSHIFT)) th1 + (BIT0 ctm, BIT0 qtm, _) -> + do pth <- convNUM_UNSHIFT_pth0 + tmA <- serve tmA' + tmB <- serve tmB' + tmP <- serve tmP' + let th1 = fromJust $ primINST [ (tmA, ctm), (tmB, btm) + , (tmP, qtm) ] pth + ruleCONV (convRAND (convRAND convNUM_UNSHIFT)) th1 + (BIT1 ctm, BIT0 qtm, _) -> + do pth <- convNUM_UNSHIFT_pth1 + tmA <- serve tmA' + tmB <- serve tmB' + tmP <- serve tmP' + let th1 = fromJust $ primINST [ (tmA, ctm), (tmB, btm) + , (tmP, qtm) ] pth + ruleCONV (convRAND (convRAND convNUM_UNSHIFT)) th1 + _ -> fail "convNUM_UNSHIFT: malformed numeral" + _ -> fail "convNUM_UNSHIFT: malformed numeral" + where convNUM_UNSHIFT_pth_triv :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_UNSHIFT_pth_triv = cacheProof "convNUM_UNSHIFT_pth_triv" ctxtWF $ + do th1 <- ruleSPEC "_0" defNUMERAL + prove "a + p * _0 = a" $ + tacSUBST1 (ruleSYM th1) `_THEN` + tacREWRITE [thmMULT_CLAUSES, thmADD_CLAUSES] + + convNUM_UNSHIFT_pth_base :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_UNSHIFT_pth_base = cacheProof "convNUM_UNSHIFT_pth_base" ctxtWF $ + do th1 <- ruleSPEC "BIT1 _0" defNUMERAL + prove "a + BIT1 _0 * b = a + b" $ + tacSUBST1 (ruleSYM th1) `_THEN` + tacREWRITE [thmMULT_CLAUSES, thmADD_CLAUSES] + + convNUM_UNSHIFT_pth0 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_UNSHIFT_pth0 = cacheProof "convNUM_UNSHIFT_pth0" ctxtWF . + prove "BIT0 a + BIT0 p * b = BIT0(a + p * b)" $ + tacREWRITE [thmBIT0] `_THEN` tacREWRITE [ruleGSYM thmMULT_2] `_THEN` + tacREWRITE [ruleGSYM thmMULT_ASSOC, ruleGSYM thmLEFT_ADD_DISTRIB] + + convNUM_UNSHIFT_pth1 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_UNSHIFT_pth1 = cacheProof "convNUM_UNSHIFT_pth1" ctxtWF . + prove "BIT1 a + BIT0 p * b = BIT1(a + p * b)" $ + tacREWRITE [thmBIT0, thmBIT1] `_THEN` + tacREWRITE [ruleGSYM thmMULT_2] `_THEN` + tacREWRITE [thmADD_CLAUSES, thmSUC_INJ] `_THEN` + tacREWRITE [ruleGSYM thmMULT_ASSOC, ruleGSYM thmLEFT_ADD_DISTRIB] `_THEN` + tacREWRITE [thmEQ_MULT_LCANCEL, thmARITH_EQ] + + convNUM_UNSHIFT_pthz :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + convNUM_UNSHIFT_pthz = cacheProof "convNUM_UNSHIFT_pthz" ctxtWF $ + do th1 <- ruleSPEC "_0" defNUMERAL + prove "_0 + BIT0 p * b = BIT0(_0 + p * b)" $ + tacSUBST1 (ruleSYM th1) `_THEN` + tacREWRITE [thmBIT1, thmBIT0] `_THEN` + tacREWRITE [thmADD_CLAUSES] `_THEN` + tacREWRITE [thmRIGHT_ADD_DISTRIB] + +ruleNUM_SQUARE :: (BasicConvs thry, WFCtxt thry) => HOLTerm + -> HOL cls thry HOLThm +ruleNUM_SQUARE tm = + let (w, z) = fromJust $ bitcounts tm in + ruleGEN_NUM_SQUARE w z tm + where ruleGEN_NUM_SQUARE :: (BasicConvs thry, WFCtxt thry) => Int -> Int + -> HOLTerm -> HOL cls thry HOLThm + ruleGEN_NUM_SQUARE _ _ (Const "_0" _) = + ruleNUM_SQUARE_pth0 + ruleGEN_NUM_SQUARE w z (BIT0 (BIT0 (BIT0 ptm))) = + do th1 <- ruleGEN_NUM_SQUARE w (z - 3) ptm + let ntm = fromJust . rand $ concl th1 + pth <- ruleNUM_SQUARE_pth_even3 + tmM <- serve tmM' + tmN <- serve tmN' + liftO $ + primEQ_MP (fromJust $ primINST [(tmM, ptm), (tmN, ntm)] pth) th1 + ruleGEN_NUM_SQUARE w z (BIT0 mtm) = + do th1 <- ruleGEN_NUM_SQUARE w (z - 1) mtm + let ntm = fromJust . rand $ concl th1 + pth <- ruleNUM_SQUARE_pth_even + tmM <- serve tmM' + tmN <- serve tmN' + liftO $ + primEQ_MP (fromJust $ primINST [(tmM, mtm), (tmN, ntm)] pth) th1 + ruleGEN_NUM_SQUARE _ _ (BIT1 (Const "_0" _)) = + ruleNUM_SQUARE_pth1 + ruleGEN_NUM_SQUARE w z (BIT1 mtm) + | (w < 100 || z < 20) && w + z < 150 = + case mtm of + (BIT1 (BIT1 ntm)) -> + do tmBIT0 <- serve tmBIT0' + tmOne <- serve [wF| BIT1 _0 |] + th1 <- ruleNUM_ADD ntm tmOne + let mtm' = fromJust . rand $ concl th1 + th2 <- ruleNUM_SQUARE mtm' + let ptm = fromJust . rand $ concl th2 + atm <- subbn (fromRight $ mkComb tmBIT0 =<< + mkComb tmBIT0 ptm) mtm' + th3 <- ruleNUM_ADD mtm' atm + pth <- ruleNUM_SQUARE_pth_qstep + tmA <- serve tmA' + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + let th4 = fromJust $ + primINST [ (tmA, atm), (tmM, mtm') + , (tmN, ntm), (tmP, ptm) ] pth + th5 <- ruleCONJ th1 =<< ruleCONJ th2 th3 + liftO $ ruleQUICK_PROVE_HYP th5 th4 + _ -> + do th1 <- ruleGEN_NUM_SQUARE (w - 1) z mtm + let ntm = fromJust . rand $ concl th1 + pth <- ruleNUM_SQUARE_pth_odd + tmM <- serve tmM' + tmN <- serve tmN' + let th2 = fromRight $ primEQ_MP (fromJust $ + primINST [ (tmM, mtm) + , (tmN, ntm) ] pth) th1 + (Comb _ (Comb _ (Comb _ + (Comb (Comb _ ptm) qtm)))) = concl th2 + th3 <- ruleNUM_ADD ptm qtm + th4 <- ruleAP_BIT1 =<< ruleAP_BIT0 th3 + liftO $ primTRANS th2 th4 + | w + z < 800 = + let k2 = (w + z) `div` 2 in + do th1 <- runConv (convNUM_SHIFT k2) tm + let (Comb (Comb _ ltm) + (Comb (Comb _ ptm) htm)) = fromJust . rand $ concl th1 + th2 <- ruleNUM_ADD htm ltm + let mtm' = fromJust . rand $ concl th2 + th3 <- ruleNUM_SQUARE htm + th4 <- ruleNUM_SQUARE ltm + th5 <- ruleNUM_SQUARE mtm' + let atm = fromJust . rand $ concl th3 + ctm = fromJust . rand $ concl th4 + dtm = fromJust . rand $ concl th5 + th6 <- ruleNUM_ADD atm ctm + let etm = fromJust . rand $ concl th6 + btm <- subbn dtm etm + th7 <- ruleNUM_ADD etm btm + let dtm' = fromJust . rand $ concl th7 + pth <- ruleNUM_SQUARE_pth_rec + tmA <- serve tmA' + tmB <- serve tmB' + tmC <- serve tmC' + tmD <- serve tmD' + tmE <- serve tmE' + tmH <- serve tmH' + tmL <- serve tmL' + tmM <- serve tmM' + tmN <- serve tmN' + tmP <- serve tmP' + let th8 = fromJust $ + primINST [ (tmA, atm), (tmB, btm), (tmC, ctm) + , (tmD, dtm'), (tmE, etm), (tmH, htm) + , (tmL, tm), (tmM, mtm'), (tmN, tm) + , (tmP, ptm)] pth + th9 <- foldr1M ruleCONJ [th1, th2, th3, th4, th5, th6, th7] + let th10 = fromRight $ ruleQUICK_PROVE_HYP th9 th8 + ruleCONV (convRAND (convRAND + (convRAND convNUM_UNSHIFT) `_THEN` + convNUM_UNSHIFT)) th10 + | otherwise = + let k3 = (w + z) `div` 3 in + do th0 <- runConv (convNUM_SHIFT k3 `_THEN` + convRAND (convRAND (convNUM_SHIFT k3))) tm + let (Comb (Comb _ ltm) + (Comb (Comb _ ptm) + (Comb (Comb _ mtm') + (Comb (Comb _ _) htm)))) = fromJust . rand $ + concl th0 + th1 <- ruleNUM_SQUARE htm + th2 <- ruleNUM_SQUARE ltm + let atm = fromJust . rand $ concl th2 + etm = fromJust . rand $ concl th1 + lnum = fromJust $ destRawNumeral ltm + mnum = fromJust $ destRawNumeral mtm' + hnum = fromJust $ destRawNumeral htm + b <- mkNumeral $ 2 * lnum * mnum + let btm = fromJust $ rand b + c <- mkNumeral $ mnum * mnum + 2 * lnum * hnum + let ctm = fromJust $ rand c + d <- mkNumeral $ 2 * hnum * mnum + let dtm = fromJust $ rand d + pth <- ruleNUM_SQUARE_pth_toom3 + tmA <- serve tmA' + tmB <- serve tmB' + tmC <- serve tmC' + tmD <- serve tmD' + tmE <- serve tmE' + tmH <- serve tmH' + tmL <- serve tmL' + tmM <- serve tmM' + tmP <- serve tmP' + let th = fromJust $ + primINST [ (tmA, atm), (tmB, btm), (tmC, ctm) + , (tmD, dtm), (tmE, etm), (tmH, htm) + , (tmM, mtm'), (tmL, ltm) + , (tmP, ptm) ] pth + th' <- ruleCONV (convBINOP2 (convRAND (convRAND + (convBINOP2 convTOOM3 + (convBINOP2 convTOOM3 convTOOM3)))) + convTOOM3) th + let [tm3, tm4, tm5] = conjuncts . fromJust $ rand =<< + rand =<< lHand (concl th') + th3 <- ruleNUM_SQUARE #<< lHand =<< lHand tm3 + th4 <- ruleNUM_SQUARE #<< lHand =<< lHand tm4 + th5 <- ruleNUM_SQUARE #<< lHand =<< lHand tm5 + ruleMP th' =<< foldr1M ruleCONJ [th1, th2, th3, th4, th5] + ruleGEN_NUM_SQUARE _ _ _ = fail "ruleGEN_NUM_SQUARE" + + convTOOM3 :: (BasicConvs thry, WFCtxt thry) => Conversion cls thry + convTOOM3 = convBINOP2 (convLAND convNUM_UNSHIFT2) convNUM_UNSHIFT4 + + convBINOP2 :: BasicConvs thry => Conversion cls thry + -> Conversion cls thry + -> Conversion cls thry + convBINOP2 conv1 = convCOMB2 (convRAND conv1) + + convNUM_UNSHIFT4 :: (BasicConvs thry, WFCtxt thry) + => Conversion cls thry + convNUM_UNSHIFT4 = convRAND (convRAND convNUM_UNSHIFT3) `_THEN` + convNUM_UNSHIFT + + convNUM_UNSHIFT3 :: (BasicConvs thry, WFCtxt thry) + => Conversion cls thry + convNUM_UNSHIFT3 = convRAND (convRAND convNUM_UNSHIFT2) `_THEN` + convNUM_UNSHIFT + + convNUM_UNSHIFT2 :: (BasicConvs thry, WFCtxt thry) + => Conversion cls thry + convNUM_UNSHIFT2 = convRAND (convRAND convNUM_UNSHIFT) `_THEN` + convNUM_UNSHIFT + + ruleNUM_SQUARE_pth0 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_SQUARE_pth0 = cacheProof "ruleNUM_SQUARE_pth0" ctxtWF . + prove "_0 EXP 2 = _0" $ + tacMESON [ defNUMERAL + , runConv (convREWRITE [thmARITH]) =<< toHTm "0 EXP 2" ] + + ruleNUM_SQUARE_pth1 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_SQUARE_pth1 = cacheProof "ruleNUM_SQUARE_pth1" ctxtWF . + prove "(BIT1 _0) EXP 2 = BIT1 _0" $ + tacMESON [ defNUMERAL + , runConv (convREWRITE [thmARITH]) =<< toHTm "1 EXP 2" ] + + ruleNUM_SQUARE_pth_even :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_SQUARE_pth_even = cacheProof "ruleNUM_SQUARE_pth_even" ctxtWF . + prove "m EXP 2 = n <=> (BIT0 m) EXP 2 = BIT0(BIT0 n)" $ + tacABBREV "two = 2" `_THEN` + tacREWRITE [thmBIT0] `_THEN` tacEXPAND "two" `_THEN` + tacREWRITE [ruleGSYM thmMULT_2] `_THEN` + tacREWRITE [thmEXP_2] `_THEN` + tacREWRITE [runConv (convAC thmMULT_AC) =<< toHTm + "(2 * m) * (2 * n) = 2 * 2 * m * n"] `_THEN` + tacREWRITE [thmEQ_MULT_LCANCEL, thmARITH_EQ] + + ruleNUM_SQUARE_pth_odd :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_SQUARE_pth_odd = cacheProof "ruleNUM_SQUARE_pth_odd" ctxtWF . + prove "m EXP 2 = n <=> (BIT1 m) EXP 2 = BIT1(BIT0(m + n))" $ + tacABBREV "two = 2" `_THEN` + tacREWRITE [defNUMERAL, thmBIT0, thmBIT1] `_THEN` + tacEXPAND "two" `_THEN` tacREWRITE [ruleGSYM thmMULT_2] `_THEN` + tacREWRITE [thmEXP_2, thmMULT_CLAUSES, thmADD_CLAUSES] `_THEN` + tacREWRITE [ thmSUC_INJ, ruleGSYM thmMULT_ASSOC + , ruleGSYM thmLEFT_ADD_DISTRIB ] `_THEN` + tacREWRITE [runConv (convAC thmADD_AC) =<< toHTm + "(m + m * 2 * m) + m = m * 2 * m + m + m"] `_THEN` + tacREWRITE [ ruleGSYM thmMULT_2 + , runConv (convAC thmMULT_AC) =<< toHTm + "m * 2 * m = 2 * m * m"] `_THEN` + tacREWRITE [ ruleGSYM thmMULT_ASSOC + , ruleGSYM thmLEFT_ADD_DISTRIB ] `_THEN` + tacREWRITE [thmEQ_MULT_LCANCEL, thmARITH_EQ] `_THEN` + tacGEN_REWRITE (convRAND . convRAND) [thmADD_SYM] `_THEN` + tacREWRITE [thmEQ_ADD_RCANCEL] + + ruleNUM_SQUARE_pth_qstep :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_SQUARE_pth_qstep = cacheProof "ruleNUM_SQUARE_pth_qstep" ctxtWF $ + ruleUNDISCH =<< + prove [str| n + BIT1 _0 = m /\ + m EXP 2 = p /\ + m + a = BIT0(BIT0 p) + ==> (BIT1(BIT1(BIT1 n))) EXP 2 = + BIT1(BIT0(BIT0(BIT0 a))) |] + (tacABBREV "two = 2" `_THEN` + tacSUBST1 (ruleMESON [defNUMERAL] "_0 = 0") `_THEN` + tacREWRITE [thmBIT1, thmBIT0] `_THEN` tacEXPAND "two" `_THEN` + tacREWRITE [ruleGSYM thmMULT_2] `_THEN` + tacREWRITE [ thmADD1, thmLEFT_ADD_DISTRIB + , ruleGSYM thmADD_ASSOC ] `_THEN` + tacREWRITE [thmMULT_ASSOC] `_THEN` + tacREWRITE [thmARITH] `_THEN` + tacREWRITE [thmIMP_CONJ] `_THEN` + _DISCH_THEN (tacSUBST1 . ruleSYM) `_THEN` + _DISCH_THEN (tacSUBST1 . ruleSYM) `_THEN` tacDISCH `_THEN` + tacMATCH_MP (ruleMESON [thmEQ_ADD_LCANCEL] + "!m:num. m + n = m + p ==> n = p") `_THEN` + tacEXISTS "16 * (n + 1)" `_THEN` + tacASM_REWRITE [ thmADD_ASSOC + , ruleGSYM thmLEFT_ADD_DISTRIB ] `_THEN` + tacEXPAND "two" `_THEN` tacREWRITE [thmEXP_2] `_THEN` + tacREWRITE [thmLEFT_ADD_DISTRIB, thmRIGHT_ADD_DISTRIB] `_THEN` + tacREWRITE [thmMULT_CLAUSES, thmMULT_ASSOC] `_THEN` + tacREWRITE [runConv (convAC thmMULT_AC) =<< toHTm + "(8 * n) * NUMERAL p = (8 * NUMERAL p) * n"] `_THEN` + tacREWRITE [thmARITH] `_THEN` + tacREWRITE [runConv (convAC thmADD_AC) =<< toHTm + "(n + 16) + p + q + 49 = (n + p + q) + (16 + 49)"] `_THEN` + tacREWRITE [ruleGSYM thmADD_ASSOC] `_THEN` + tacREWRITE [thmARITH] `_THEN` + tacREWRITE [thmADD_ASSOC, thmEQ_ADD_RCANCEL] `_THEN` + tacREWRITE [ ruleGSYM thmADD_ASSOC, ruleGSYM thmMULT_2 + , thmMULT_ASSOC] `_THEN` + tacONCE_REWRITE [runConv (convAC thmADD_AC) =<< toHTm + "a + b + c:num = b + a + c"] `_THEN` + tacREWRITE [ruleGSYM thmRIGHT_ADD_DISTRIB] `_THEN` + tacREWRITE [thmARITH]) + + ruleNUM_SQUARE_pth_rec :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_SQUARE_pth_rec = cacheProof "ruleNUM_SQUARE_pth_rec" ctxtWF $ + ruleUNDISCH =<< + prove [str| n = l + p * h /\ + h + l = m /\ + h EXP 2 = a /\ + l EXP 2 = c /\ + m EXP 2 = d /\ + a + c = e /\ + e + b = d + ==> n EXP 2 = c + p * (b + p * a) |] + (tacREWRITE [thmIMP_CONJ] `_THEN` + _DISCH_THEN tacSUBST1 `_THEN` + tacREPLICATE 5 (_DISCH_THEN (tacSUBST1 . ruleSYM)) `_THEN` + tacREWRITE [ thmEXP_2, thmLEFT_ADD_DISTRIB + , thmRIGHT_ADD_DISTRIB ] `_THEN` + tacREWRITE [thmMULT_AC] `_THEN` + tacCONV (convBINOP convNUM_CANCEL) `_THEN` + _DISCH_THEN tacSUBST1 `_THEN` + tacREWRITE [thmRIGHT_ADD_DISTRIB] `_THEN` + tacREWRITE [thmMULT_AC] `_THEN` tacREWRITE [thmADD_AC]) + + ruleNUM_SQUARE_pth_toom3 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_SQUARE_pth_toom3 = cacheProof "ruleNUM_SQUARE_pth_toom3" ctxtWF $ + do rewrites <- mapM (\ k -> + do tmSuc <- serve tmSuc' + n <- mkSmallNumeral (k - 1) + th <- runConv (convREWRITE [thmARITH_SUC]) #<< + mkComb tmSuc n + liftO $ ruleSYM th) [1..5] + prove [str| h EXP 2 = e /\ + l EXP 2 = a /\ + (l + BIT1 _0 * (m + BIT1 _0 * h)) EXP 2 = + a + BIT1 _0 * (b + BIT1 _0 * (c + BIT1 _0 * + (d + BIT1 _0 * e))) /\ + (l + BIT0(BIT1 _0) * (m + BIT0(BIT1 _0) * h)) EXP 2 = + a + BIT0(BIT1 _0) * (b + BIT0(BIT1 _0) * + (c + BIT0(BIT1 _0) * (d + BIT0(BIT1 _0) * e))) /\ + (h + BIT0(BIT1 _0) * (m + BIT0(BIT1 _0) * l)) EXP 2 = + e + BIT0(BIT1 _0) * (d + BIT0(BIT1 _0) * + (c + BIT0(BIT1 _0) * (b + BIT0(BIT1 _0) * a))) + ==> (l + p * (m + p * h)) EXP 2 = + a + p * (b + p * (c + p * (d + p * e))) |] $ + tacABBREV "two = 2" `_THEN` + tacSUBST1 (ruleMESON [defNUMERAL] "_0 = 0") `_THEN` + tacREWRITE [thmBIT1, thmBIT0] `_THEN` + tacEXPAND "two" `_THEN` tacREWRITE [ruleGSYM thmMULT_2] `_THEN` + tacREWRITE [thmARITH] `_THEN` + _SUBGOAL_THEN + [str| !p x y z. (x + p * (y + p * z)) EXP 2 = + x * x + p * (2 * x * y + p * ((2 * x * z + y * y) + + p * (2 * y * z + p * z * z))) |] + (\ th -> tacREWRITE [th]) `_THENL` + [ tacREWRITE [ thmEXP_2, thmMULT_2, thmLEFT_ADD_DISTRIB + , thmRIGHT_ADD_DISTRIB ] `_THEN` + tacREWRITE [thmMULT_AC] `_THEN` tacREWRITE [thmADD_AC] + , tacREWRITE [thmEXP_2] + ] `_THEN` + _MAP_EVERY tacABBREV + [ "a':num = l * l", "b' = 2 * l * m", "c' = 2 * l * h + m * m" + , "d' = 2 * m * h", "e':num = h * h" ] `_THEN` + tacSUBST1 (runConv (convAC thmMULT_AC) =<< toHTm + "2 * m * l = 2 * l * m") `_THEN` + tacSUBST1 (runConv (convAC thmMULT_AC) =<< toHTm + "2 * h * l = 2 * l * h") `_THEN` + tacSUBST1 (runConv (convAC thmMULT_AC) =<< toHTm + "2 * h * m = 2 * m * h") `_THEN` + tacASM_REWRITE_NIL `_THEN` tacEXPAND "two" `_THEN` + _POP_ASSUM_LIST (const _ALL) `_THEN` + tacASM_CASES "a':num = a" `_THEN` tacASM_REWRITE_NIL `_THEN` + tacASM_CASES "e':num = e" `_THEN` tacASM_REWRITE_NIL `_THEN` + _POP_ASSUM_LIST (const _ALL) `_THEN` + tacREWRITE [thmEQ_ADD_LCANCEL, thmEQ_MULT_LCANCEL] `_THEN` + tacREWRITE [thmLEFT_ADD_DISTRIB, thmMULT_ASSOC] `_THEN` + tacREWRITE [thmARITH] `_THEN` + tacREWRITE [thmMULT_CLAUSES, thmEQ_ADD_LCANCEL] `_THEN` + tacREWRITE [thmADD_ASSOC, thmEQ_ADD_RCANCEL] `_THEN` + tacREWRITE [ruleGSYM thmADD_ASSOC] `_THEN` tacDISCH `_THEN` + _FIRST_ASSUM (tacMP . ruleMATCH_MP + (ruleMESON_NIL [str| b = b' /\ c = c' /\ d = d' + ==> 5 * b + c' + d' = + 5 * b' + c + d |])) `_THEN` + tacREWRITE [thmLEFT_ADD_DISTRIB, thmMULT_ASSOC] `_THEN` + tacREWRITE rewrites `_THEN` + tacREWRITE [thmMULT_CLAUSES, thmADD_CLAUSES] `_THEN` + tacCONV (convLAND convNUM_CANCEL) `_THEN` + _DISCH_THEN tacSUBST_ALL `_THEN` + _FIRST_ASSUM (tacMP . ruleMATCH_MP + (ruleMESON_NIL [str| b = b' /\ c = c' /\ d = d' ==> + b + d':num = b' + d /\ + 4 * b + d' = + 4 * b' + d |])) `_THEN` + tacREWRITE [thmLEFT_ADD_DISTRIB, thmMULT_ASSOC] `_THEN` + tacREWRITE (init rewrites) `_THEN` + tacREWRITE [thmMULT_CLAUSES, thmADD_CLAUSES] `_THEN` + tacCONV (convLAND (convBINOP convNUM_CANCEL)) `_THEN` + tacREWRITE [ruleGSYM thmMULT_2] `_THEN` + tacONCE_REWRITE [thmADD_SYM] `_THEN` + tacREWRITE [ruleGSYM =<< liftM (!! 4) + (ruleCONJUNCTS thmMULT_CLAUSES)] `_THEN` + tacSIMP [thmEQ_MULT_LCANCEL, thmNOT_SUC] + + ruleNUM_SQUARE_pth_even3 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry HOLThm + ruleNUM_SQUARE_pth_even3 = cacheProof "ruleNUM_SQUARE_pth_even3" ctxtWF . + prove [str| m EXP 2 = n <=> + (BIT0(BIT0(BIT0 m))) EXP 2 = + BIT0(BIT0(BIT0(BIT0(BIT0(BIT0 n))))) |] $ + tacABBREV "two = 2" `_THEN` + tacREWRITE [thmBIT0] `_THEN` + tacREWRITE [ruleGSYM thmMULT_2] `_THEN` + tacEXPAND "two" `_THEN` tacREWRITE [thmEXP_2] `_THEN` + tacREWRITE [runConv (convAC thmMULT_AC) =<< toHTm + [str| (2 * 2 * 2 * m) * 2 * 2 * 2 * m = + 2 * 2 * 2 * 2 * 2 * 2 * m * m |]] `_THEN` + tacREWRITE [thmEQ_MULT_LCANCEL, thmARITH_EQ] + +convNUM :: (BasicConvs thry, WFCtxt thry) => Conversion cls thry +convNUM = Conv $ \ tm -> + do tmSUC <- serve tmSuc' + let n = fromJust (destNumeral tm) - 1 + if n < 0 + then fail "convNUM" + else do tm' <- mkNumeral n + th <- runConv convNUM_SUC #<< mkComb tmSUC tm' + liftO $ ruleSYM th + +-- Misc utility stuff +ruleAP_BIT0 :: WFCtxt thry => HOLThm -> HOL cls thry HOLThm +ruleAP_BIT0 th = + do tm <- serve tmBIT0' + liftO $ primMK_COMB (primREFL tm) th + +ruleAP_BIT1 :: WFCtxt thry => HOLThm -> HOL cls thry HOLThm +ruleAP_BIT1 th = + do tm <- serve tmBIT1' + liftO $ primMK_COMB (primREFL tm) th + +ruleQUICK_PROVE_HYP :: HOLThm -> HOLThm -> Either String HOLThm +ruleQUICK_PROVE_HYP ath bth = + primEQ_MP (primDEDUCT_ANTISYM ath bth) ath + +destRawNumeral :: HOLTerm -> Maybe Int +destRawNumeral (BIT1 t) = + do t' <- destRawNumeral t + return $! 2 * t' + 1 +destRawNumeral (BIT0 t) = + do t' <- destRawNumeral t + return $! 2 * t' +destRawNumeral (Const "_0" _) = + return 0 +destRawNumeral _ = Nothing + +bitcounts :: HOLTerm -> Maybe (Int, Int) +bitcounts = bctr 0 0 + where bctr :: Int -> Int -> HOLTerm -> Maybe (Int, Int) + bctr w z (Const "_0" _) = Just (w, z) + bctr w z (BIT0 t) = bctr w (succ z) t + bctr w z (BIT1 t) = bctr (succ w) z t + bctr _ _ _ = Nothing + +wellformed :: HOLTerm -> Bool +wellformed (Const "_0" _) = True +wellformed (BIT0 t) = wellformed t +wellformed (BIT1 t) = wellformed t +wellformed _ = False + +orderrelation :: HOLTerm -> HOLTerm -> Maybe Ordering +orderrelation mtm ntm + | mtm == ntm = if wellformed mtm then Just EQ else Nothing + | otherwise = + case (mtm, ntm) of + (Const "_0" _, Const "_0" _) -> Just EQ + (Const "_0" _, _) -> + if wellformed ntm then Just LT else Nothing + (_, Const "_0" _) -> + if wellformed ntm then Just GT else Nothing + (BIT0 mt, BIT0 nt) -> + orderrelation mt nt + (BIT1 mt, BIT1 nt) -> + orderrelation mt nt + (BIT0 mt, BIT1 nt) -> + Just $ if orderrelation mt nt == Just GT then GT else LT + (BIT1 mt, BIT0 nt) -> + Just $ if orderrelation mt nt == Just LT then LT else EQ + _ -> Nothing + +doublebn :: WFCtxt thry => HOLTerm -> HOL cls thry HOLTerm +doublebn tm@(Const "_0" _) = return tm +doublebn tm = + do tmBIT0 <- serve tmBIT0' + liftO $ mkComb tmBIT0 tm + +subbn :: WFCtxt thry => HOLTerm -> HOLTerm -> HOL cls thry HOLTerm +subbn = subbnRec + where subbnRec :: WFCtxt thry => HOLTerm -> HOLTerm -> HOL cls thry HOLTerm + subbnRec mtm (Const "_0" _) = + return mtm + subbnRec (BIT0 mt) (BIT0 nt) = + doublebn =<< subbnRec mt nt + subbnRec (BIT1 mt) (BIT1 nt) = + doublebn =<< subbnRec mt nt + subbnRec (BIT1 mt) (BIT0 nt) = + do tmBIT1 <- serve tmBIT1' + tm' <- subbnRec mt nt + liftO $ mkComb tmBIT1 tm' + subbnRec (BIT0 mt) (BIT1 nt) = + do tmBIT1 <- serve tmBIT1' + tm' <- sbcbn mt nt + liftO $ mkComb tmBIT1 tm' + subbnRec _ _ = fail "subbn" + +sbcbn :: WFCtxt thry => HOLTerm -> HOLTerm -> HOL cls thry HOLTerm +sbcbn = sbcbnRec + where sbcbnRec :: WFCtxt thry => HOLTerm -> HOLTerm -> HOL cls thry HOLTerm + sbcbnRec (BIT0 mt) nt@(Const "_0" _) = + do tmBIT1 <- serve tmBIT1' + tm' <- sbcbnRec mt nt + liftO $ mkComb tmBIT1 tm' + sbcbnRec (BIT1 mt) (Const "_0" _) = + doublebn mt + sbcbnRec (BIT0 mt) (BIT0 nt) = + do tmBIT1 <- serve tmBIT1' + tm' <- sbcbnRec mt nt + liftO $ mkComb tmBIT1 tm' + sbcbnRec (BIT1 mt) (BIT1 nt) = + do tmBIT1 <- serve tmBIT1' + tm' <- sbcbnRec mt nt + liftO $ mkComb tmBIT1 tm' + sbcbnRec (BIT1 mt) (BIT0 nt) = + doublebn =<< subbn mt nt + sbcbnRec (BIT0 mt) (BIT1 nt) = + doublebn =<< sbcbnRec mt nt + sbcbnRec _ _ = fail "sbcbn" + +topsplit :: HOLTerm -> Maybe (Int, HOLTerm) +topsplit n@(Const "_0" _) = Just (0, n) +topsplit (BIT1 n@(Const "_0" _)) = Just (1, n) +topsplit (BIT0 (BIT1 n@(Const "_0" _))) = Just (2, n) +topsplit (BIT1 (BIT1 n@(Const "_0" _))) = Just (3, n) +topsplit (BIT0 (BIT0 (BIT1 n@(Const "_0" _)))) = Just (4, n) +topsplit (BIT1 (BIT0 (BIT1 n@(Const "_0" _)))) = Just (5, n) +topsplit (BIT0 (BIT1 (BIT1 n@(Const "_0" _)))) = Just (6, n) +topsplit (BIT1 (BIT1 (BIT1 n@(Const "_0" _)))) = Just (7, n) +topsplit (BIT0 (BIT0 (BIT0 (BIT0 n)))) = Just (0, n) +topsplit (BIT1 (BIT0 (BIT0 (BIT0 n)))) = Just (1, n) +topsplit (BIT0 (BIT1 (BIT0 (BIT0 n)))) = Just (2, n) +topsplit (BIT1 (BIT1 (BIT0 (BIT0 n)))) = Just (3, n) +topsplit (BIT0 (BIT0 (BIT1 (BIT0 n)))) = Just (4, n) +topsplit (BIT1 (BIT0 (BIT1 (BIT0 n)))) = Just (5, n) +topsplit (BIT0 (BIT1 (BIT1 (BIT0 n)))) = Just (6, n) +topsplit (BIT1 (BIT1 (BIT1 (BIT0 n)))) = Just (7, n) +topsplit (BIT0 (BIT0 (BIT0 (BIT1 n)))) = Just (8, n) +topsplit (BIT1 (BIT0 (BIT0 (BIT1 n)))) = Just (9, n) +topsplit (BIT0 (BIT1 (BIT0 (BIT1 n)))) = Just (10, n) +topsplit (BIT1 (BIT1 (BIT0 (BIT1 n)))) = Just (11, n) +topsplit (BIT0 (BIT0 (BIT1 (BIT1 n)))) = Just (12, n) +topsplit (BIT1 (BIT0 (BIT1 (BIT1 n)))) = Just (13, n) +topsplit (BIT0 (BIT1 (BIT1 (BIT1 n)))) = Just (14, n) +topsplit (BIT1 (BIT1 (BIT1 (BIT1 n)))) = Just (15, n) +topsplit _ = Nothing diff --git a/src/HaskHOL/Lib/CalcNum/Pre.hs b/src/HaskHOL/Lib/CalcNum/Pre.hs new file mode 100644 index 0000000..c778ec0 --- /dev/null +++ b/src/HaskHOL/Lib/CalcNum/Pre.hs @@ -0,0 +1,270 @@ +module HaskHOL.Lib.CalcNum.Pre where + +import HaskHOL.Core hiding (base) +import HaskHOL.Deductive + +import HaskHOL.Lib.Nums +import HaskHOL.Lib.Arith +import HaskHOL.Lib.WF.Context + + +-- Build up lookup table for numeral conversions. +tmZero', tmBIT0', tmBIT1', tmM', tmN', tmP', tmAdd', tmSuc' :: WFCtxt thry => PTerm thry +tmZero' = [wF| _0 |] +tmBIT0' = [wF| BIT0 |] +tmBIT1' = [wF| BIT1 |] +tmM' = [wF| m:num |] +tmN' = [wF| n:num |] +tmP' = [wF| p:num |] +tmAdd' = [wF| (+) |] +tmSuc' = [wF| SUC |] + + +mkClauses :: (BasicConvs thry, WFCtxt thry) => Bool -> HOLTerm + -> HOL cls thry (HOLThm, Int) +mkClauses sucflag t = + do tmSuc <- serve tmSuc' + tmAdd <- serve tmAdd' + tmM <- serve tmM' + tmP <- serve tmP' + let tm = if sucflag then fromRight $ mkComb tmSuc t else t + th1 <- runConv (convPURE_REWRITE + [thmARITH_ADD, thmARITH_SUC, thmARITH_0]) tm + tm1 <- patadj #<< rand (concl th1) + if not (tmAdd `freeIn` tm1) + then return (th1, if tmM `freeIn` tm1 then 0 else 1) + else let ptm = fromJust $ rand =<< rand =<< rand =<< + rand tm1 in + do tmc <- liftM1 mkEq (mkEq ptm tmP) =<< mkEq tm #<< + subst [(ptm, tmP)] tm1 + th <- ruleEQT_ELIM =<< + runConv (convREWRITE [ thmARITH_ADD + , thmARITH_SUC + , thmARITH_0 + , thmBITS_INJ]) tmc + return (th, if tmSuc `freeIn` tm1 then 3 else 2) + where patadj :: HOLTerm -> HOL cls thry HOLTerm + patadj tm = + do tms <- mapM (pairMapM toHTm) [("SUC m", "SUC (m + _0)"), ("SUC n", "SUC (_0 + n)")] + liftO $ subst tms tm + +starts :: WFCtxt thry => HOL cls thry [HOLTerm] +starts = + do tmM <- serve tmM' + tmN <- serve tmN' + tmAdd <- serve tmAdd' + ms <- bases tmM + ns <- bases tmN + return $! allpairsV (\ mtm ntm -> fromRight $ + flip mkComb ntm =<< mkComb tmAdd mtm) ms ns + where allpairsV :: (a -> b -> c) -> [a] -> [b] -> [c] + allpairsV _ [] _ = [] + allpairsV f (h:t) ys = + foldr (\ x a -> f h x : a) (allpairsV f t ys) ys + + + bases :: WFCtxt thry => HOLTerm -> HOL cls thry [HOLTerm] + bases v = + do tmBIT1 <- serve tmBIT1' + tmBIT0 <- serve tmBIT0' + tmZero <- serve tmZero' + let v0 = fromRight $ mkComb tmBIT0 v + v1 = fromRight $ mkComb tmBIT1 v + part2 <- mapM (`mkCompnumeral` v) [8..15] + part1 <- mapM (liftO . subst [(v1, v0)]) part2 + part0 <- mapM (`mkCompnumeral` tmZero) [0..15] + return $! part0 ++ part1 ++ part2 + + mkCompnumeral :: WFCtxt thry => Int -> HOLTerm -> HOL cls thry HOLTerm + mkCompnumeral 0 base = return base + mkCompnumeral k base = + do tmBIT1 <- serve tmBIT1' + tmBIT0 <- serve tmBIT0' + t <- mkCompnumeral (k `div` 2) base + liftO $ if k `mod` 2 == 1 + then mkComb tmBIT1 t + else mkComb tmBIT0 t + +convNUM_SHIFT_pths1' :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +convNUM_SHIFT_pths1' = cacheProof "convNUM_SHIFT_pths1'" ctxtWF . + prove [str| (n = a + p * b <=> + BIT0(BIT0(BIT0(BIT0 n))) = + BIT0(BIT0(BIT0(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT1(BIT0(BIT0(BIT0 n))) = + BIT1(BIT0(BIT0(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT0(BIT1(BIT0(BIT0 n))) = + BIT0(BIT1(BIT0(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT1(BIT1(BIT0(BIT0 n))) = + BIT1(BIT1(BIT0(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT0(BIT0(BIT1(BIT0 n))) = + BIT0(BIT0(BIT1(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT1(BIT0(BIT1(BIT0 n))) = + BIT1(BIT0(BIT1(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT0(BIT1(BIT1(BIT0 n))) = + BIT0(BIT1(BIT1(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT1(BIT1(BIT1(BIT0 n))) = + BIT1(BIT1(BIT1(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT0(BIT0(BIT0(BIT1 n))) = + BIT0(BIT0(BIT0(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT1(BIT0(BIT0(BIT1 n))) = + BIT1(BIT0(BIT0(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT0(BIT1(BIT0(BIT1 n))) = + BIT0(BIT1(BIT0(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT1(BIT1(BIT0(BIT1 n))) = + BIT1(BIT1(BIT0(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT0(BIT0(BIT1(BIT1 n))) = + BIT0(BIT0(BIT1(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT1(BIT0(BIT1(BIT1 n))) = + BIT1(BIT0(BIT1(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT0(BIT1(BIT1(BIT1 n))) = + BIT0(BIT1(BIT1(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = a + p * b <=> + BIT1(BIT1(BIT1(BIT1 n))) = + BIT1(BIT1(BIT1(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) |] $ + tacMP (ruleREWRITE [ruleGSYM thmMULT_2] thmBIT0) `_THEN` + tacMP (ruleREWRITE [ruleGSYM thmMULT_2] thmBIT1) `_THEN` + tacABBREV "two = 2" `_THEN` + _DISCH_THEN (\ th -> tacREWRITE [th]) `_THEN` + _DISCH_THEN (\ th -> tacREWRITE [th]) `_THEN` + _FIRST_X_ASSUM (tacSUBST1 . ruleSYM) `_THEN` + tacREWRITE [ thmADD_CLAUSES, thmSUC_INJ + , thmEQ_MULT_LCANCEL, thmARITH_EQ + , ruleGSYM thmLEFT_ADD_DISTRIB, ruleGSYM thmMULT_ASSOC ] + +convNUM_SHIFT_pths0' :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +convNUM_SHIFT_pths0' = cacheProof "convNUM_SHIFT_pths0'" ctxtWF . + prove [str| (n = _0 + p * b <=> + BIT0(BIT0(BIT0(BIT0 n))) = + _0 + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT1(BIT0(BIT0(BIT0 n))) = + BIT1 _0 + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT0(BIT1(BIT0(BIT0 n))) = + BIT0(BIT1 _0) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT1(BIT1(BIT0(BIT0 n))) = + BIT1(BIT1 _0) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT0(BIT0(BIT1(BIT0 n))) = + BIT0(BIT0(BIT1 _0)) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT1(BIT0(BIT1(BIT0 n))) = + BIT1(BIT0(BIT1 _0)) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT0(BIT1(BIT1(BIT0 n))) = + BIT0(BIT1(BIT1 _0)) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT1(BIT1(BIT1(BIT0 n))) = + BIT1(BIT1(BIT1 _0)) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT0(BIT0(BIT0(BIT1 n))) = + BIT0(BIT0(BIT0(BIT1 _0))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT1(BIT0(BIT0(BIT1 n))) = + BIT1(BIT0(BIT0(BIT1 _0))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT0(BIT1(BIT0(BIT1 n))) = + BIT0(BIT1(BIT0(BIT1 _0))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT1(BIT1(BIT0(BIT1 n))) = + BIT1(BIT1(BIT0(BIT1 _0))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT0(BIT0(BIT1(BIT1 n))) = + BIT0(BIT0(BIT1(BIT1 _0))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT1(BIT0(BIT1(BIT1 n))) = + BIT1(BIT0(BIT1(BIT1 _0))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT0(BIT1(BIT1(BIT1 n))) = + BIT0(BIT1(BIT1(BIT1 _0))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ + (n = _0 + p * b <=> + BIT1(BIT1(BIT1(BIT1 n))) = + BIT1(BIT1(BIT1(BIT1 _0))) + BIT0(BIT0(BIT0(BIT0 p))) * b) |] $ + tacSUBST1 (ruleMESON [defNUMERAL] "_0 = 0") `_THEN` + tacMP (ruleREWRITE [ruleGSYM thmMULT_2] thmBIT0) `_THEN` + tacMP (ruleREWRITE [ruleGSYM thmMULT_2] thmBIT1) `_THEN` + tacABBREV "two = 2" `_THEN` + _DISCH_THEN (\ th -> tacREWRITE [th]) `_THEN` + _DISCH_THEN (\ th -> tacREWRITE [th]) `_THEN` + _FIRST_X_ASSUM (tacSUBST1 . ruleSYM) `_THEN` + tacREWRITE [ thmADD_CLAUSES, thmSUC_INJ + , thmEQ_MULT_LCANCEL, thmARITH_EQ + , ruleGSYM thmLEFT_ADD_DISTRIB, ruleGSYM thmMULT_ASSOC ] + +convNUM_UNSHIFT_puths1' :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +convNUM_UNSHIFT_puths1' = cacheProof "convNUM_UNSHIFT_puths1'" ctxtWF . + prove [str| (a + p * b = n <=> + BIT0(BIT0(BIT0(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT0(BIT0(BIT0(BIT0 n)))) /\ + (a + p * b = n <=> + BIT1(BIT0(BIT0(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT1(BIT0(BIT0(BIT0 n)))) /\ + (a + p * b = n <=> + BIT0(BIT1(BIT0(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT0(BIT1(BIT0(BIT0 n)))) /\ + (a + p * b = n <=> + BIT1(BIT1(BIT0(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT1(BIT1(BIT0(BIT0 n)))) /\ + (a + p * b = n <=> + BIT0(BIT0(BIT1(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT0(BIT0(BIT1(BIT0 n)))) /\ + (a + p * b = n <=> + BIT1(BIT0(BIT1(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT1(BIT0(BIT1(BIT0 n)))) /\ + (a + p * b = n <=> + BIT0(BIT1(BIT1(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT0(BIT1(BIT1(BIT0 n)))) /\ + (a + p * b = n <=> + BIT1(BIT1(BIT1(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT1(BIT1(BIT1(BIT0 n)))) /\ + (a + p * b = n <=> + BIT0(BIT0(BIT0(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT0(BIT0(BIT0(BIT1 n)))) /\ + (a + p * b = n <=> + BIT1(BIT0(BIT0(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT1(BIT0(BIT0(BIT1 n)))) /\ + (a + p * b = n <=> + BIT0(BIT1(BIT0(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT0(BIT1(BIT0(BIT1 n)))) /\ + (a + p * b = n <=> + BIT1(BIT1(BIT0(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT1(BIT1(BIT0(BIT1 n)))) /\ + (a + p * b = n <=> + BIT0(BIT0(BIT1(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT0(BIT0(BIT1(BIT1 n)))) /\ + (a + p * b = n <=> + BIT1(BIT0(BIT1(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT1(BIT0(BIT1(BIT1 n)))) /\ + (a + p * b = n <=> + BIT0(BIT1(BIT1(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT0(BIT1(BIT1(BIT1 n)))) /\ + (a + p * b = n <=> + BIT1(BIT1(BIT1(BIT1 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = + BIT1(BIT1(BIT1(BIT1 n)))) |] $ + tacSUBST1 (ruleMESON [defNUMERAL] "_0 = 0") `_THEN` + tacMP (ruleREWRITE [ruleGSYM thmMULT_2] thmBIT0) `_THEN` + tacMP (ruleREWRITE [ruleGSYM thmMULT_2] thmBIT1) `_THEN` + tacABBREV "two = 2" `_THEN` + _DISCH_THEN (\ th -> tacREWRITE[th]) `_THEN` + _DISCH_THEN (\ th -> tacREWRITE[th]) `_THEN` + _FIRST_X_ASSUM (tacSUBST1 . ruleSYM) `_THEN` + tacREWRITE [ thmADD_CLAUSES, thmSUC_INJ + , thmEQ_MULT_LCANCEL, thmARITH_EQ + , ruleGSYM thmLEFT_ADD_DISTRIB + , ruleGSYM thmMULT_ASSOC + ] diff --git a/src/HaskHOL/Lib/CalcNum/Pre2.hs b/src/HaskHOL/Lib/CalcNum/Pre2.hs new file mode 100644 index 0000000..97f3214 --- /dev/null +++ b/src/HaskHOL/Lib/CalcNum/Pre2.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, TemplateHaskell, + TypeFamilies #-} +module HaskHOL.Lib.CalcNum.Pre2 where + +import HaskHOL.Core +import HaskHOL.Deductive + +import HaskHOL.Lib.Arith +import HaskHOL.Lib.WF.Context + +import HaskHOL.Lib.CalcNum.Pre + +import Data.Vector (Vector) +import qualified Data.Vector as V + +thmARITH :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +thmARITH = cacheProof "thmARITH" ctxtWF $ foldr1M ruleCONJ =<< + sequence [ thmARITH_ZERO, thmARITH_SUC, thmARITH_PRE + , thmARITH_ADD, thmARITH_MULT, thmARITH_EXP + , thmARITH_EVEN, thmARITH_ODD, thmARITH_EQ + , thmARITH_LE, thmARITH_LT, thmARITH_GE + , thmARITH_GT, thmARITH_SUB + ] + +-- Lookup arrays for numeral conversions +data ADDClauses = ADDClauses !(Vector HOLThm) deriving Typeable + +deriveSafeCopy 0 'base ''ADDClauses + +getAddClauses :: Query ADDClauses (Vector HOLThm) +getAddClauses = + do (ADDClauses v) <- ask + return v + +putAddClauses :: Vector HOLThm -> Update ADDClauses () +putAddClauses v = + put (ADDClauses v) + +makeAcidic ''ADDClauses ['getAddClauses, 'putAddClauses] + +data ADDFlags = ADDFlags !(Vector Int) deriving Typeable + +deriveSafeCopy 0 'base ''ADDFlags + +getAddFlags :: Query ADDFlags (Vector Int) +getAddFlags = + do (ADDFlags v) <- ask + return v + +putAddFlags :: Vector Int -> Update ADDFlags () +putAddFlags v = + put (ADDFlags v) + +makeAcidic ''ADDFlags ['getAddFlags, 'putAddFlags] + + +data ADCClauses = ADCClauses !(Vector HOLThm) deriving Typeable + +deriveSafeCopy 0 'base ''ADCClauses + +getAdcClauses :: Query ADCClauses (Vector HOLThm) +getAdcClauses = + do (ADCClauses v) <- ask + return v + +putAdcClauses :: Vector HOLThm -> Update ADCClauses () +putAdcClauses v = + put (ADCClauses v) + +makeAcidic ''ADCClauses ['getAdcClauses, 'putAdcClauses] + +data ADCFlags = ADCFlags !(Vector Int) deriving Typeable + +deriveSafeCopy 0 'base ''ADCFlags + +getAdcFlags :: Query ADCFlags (Vector Int) +getAdcFlags = + do (ADCFlags v) <- ask + return v + +putAdcFlags :: Vector Int -> Update ADCFlags () +putAdcFlags v = + put (ADCFlags v) + +makeAcidic ''ADCFlags ['getAdcFlags, 'putAdcFlags] + + +addClauses :: (BasicConvs thry, WFCtxt thry) => HOL cls thry (Vector HOLThm) +addClauses = + do acid <- openLocalStateHOLBase (ADDClauses V.empty) + v <- queryHOL acid GetAddClauses + closeAcidStateHOL acid + if not (V.null v) + then return v + else do (clauses, flags) <- liftM unzip $ + mapM (mkClauses False) =<< starts + let v' = V.fromList clauses + acid' <- openLocalStateHOLBase (ADDClauses V.empty) + updateHOLUnsafe acid' (PutAddClauses v') + createCheckpointAndCloseHOL acid' + acid2 <- openLocalStateHOLBase (ADDFlags V.empty) + updateHOLUnsafe acid2 (PutAddFlags (V.fromList flags)) + createCheckpointAndCloseHOL acid2 + return v' + +addFlags :: (BasicConvs thry, WFCtxt thry) => HOL cls thry (Vector Int) +addFlags = + do acid <- openLocalStateHOLBase (ADDFlags V.empty) + v <- queryHOL acid GetAddFlags + closeAcidStateHOL acid + if not (V.null v) + then return v + else do (clauses, flags) <- liftM unzip $ + mapM (mkClauses False) =<< starts + let v' = V.fromList flags + acid' <- openLocalStateHOLBase (ADDClauses V.empty) + updateHOLUnsafe acid' (PutAddClauses (V.fromList clauses)) + createCheckpointAndCloseHOL acid' + acid2 <- openLocalStateHOLBase (ADDFlags V.empty) + updateHOLUnsafe acid2 (PutAddFlags v') + createCheckpointAndCloseHOL acid2 + return v' + + +adcClauses :: (BasicConvs thry, WFCtxt thry) => HOL cls thry (Vector HOLThm) +adcClauses = + do acid <- openLocalStateHOLBase (ADCClauses V.empty) + v <- queryHOL acid GetAdcClauses + closeAcidStateHOL acid + if not (V.null v) + then return v + else do (clauses, flags) <- liftM unzip $ + mapM (mkClauses True) =<< starts + let v' = V.fromList clauses + acid' <- openLocalStateHOLBase (ADCClauses V.empty) + updateHOLUnsafe acid' (PutAdcClauses v') + createCheckpointAndCloseHOL acid' + acid2 <- openLocalStateHOLBase (ADCFlags V.empty) + updateHOLUnsafe acid2 (PutAdcFlags (V.fromList flags)) + createCheckpointAndCloseHOL acid2 + return v' + +adcFlags :: (BasicConvs thry, WFCtxt thry) => HOL cls thry (Vector Int) +adcFlags = + do acid <- openLocalStateHOLBase (ADCFlags V.empty) + v <- queryHOL acid GetAdcFlags + closeAcidStateHOL acid + if not (V.null v) + then return v + else do (clauses, flags) <- liftM unzip $ + mapM (mkClauses True) =<< starts + let v' = V.fromList flags + acid' <- openLocalStateHOLBase (ADCClauses V.empty) + updateHOLUnsafe acid' (PutAdcClauses (V.fromList clauses)) + createCheckpointAndCloseHOL acid' + acid2 <- openLocalStateHOLBase (ADCFlags V.empty) + updateHOLUnsafe acid2 (PutAdcFlags v') + createCheckpointAndCloseHOL acid2 + return v' + +data SHIFTPths1 = SHIFTPths1 !(Vector HOLThm) deriving Typeable + +deriveSafeCopy 0 'base ''SHIFTPths1 + +getShiftPths1 :: Query SHIFTPths1 (Vector HOLThm) +getShiftPths1 = + do (SHIFTPths1 v) <- ask + return v + +putShiftPths1 :: Vector HOLThm -> Update SHIFTPths1 () +putShiftPths1 v = + put (SHIFTPths1 v) + +makeAcidic ''SHIFTPths1 ['getShiftPths1, 'putShiftPths1] + + +data SHIFTPths0 = SHIFTPths0 !(Vector HOLThm) deriving Typeable + +deriveSafeCopy 0 'base ''SHIFTPths0 + +getShiftPths0 :: Query SHIFTPths0 (Vector HOLThm) +getShiftPths0 = + do (SHIFTPths0 v) <- ask + return v + +putShiftPths0 :: Vector HOLThm -> Update SHIFTPths0 () +putShiftPths0 v = + put (SHIFTPths0 v) + +makeAcidic ''SHIFTPths0 ['getShiftPths0, 'putShiftPths0] + + +data UNSHIFTpuths1 = UNSHIFTpuths1 !(Vector HOLThm) deriving Typeable + +deriveSafeCopy 0 'base ''UNSHIFTpuths1 + +getUnshiftpuths1 :: Query UNSHIFTpuths1 (Vector HOLThm) +getUnshiftpuths1 = + do (UNSHIFTpuths1 v) <- ask + return v + +putUnshiftpuths1 :: Vector HOLThm -> Update UNSHIFTpuths1 () +putUnshiftpuths1 v = + put (UNSHIFTpuths1 v) + +makeAcidic ''UNSHIFTpuths1 ['getUnshiftpuths1, 'putUnshiftpuths1] + + +data UNSHIFTpuths2 = UNSHIFTpuths2 !(Vector HOLThm) deriving Typeable + +deriveSafeCopy 0 'base ''UNSHIFTpuths2 + +getUnshiftpuths2 :: Query UNSHIFTpuths2 (Vector HOLThm) +getUnshiftpuths2 = + do (UNSHIFTpuths2 v) <- ask + return v + +putUnshiftpuths2 :: Vector HOLThm -> Update UNSHIFTpuths2 () +putUnshiftpuths2 v = + put (UNSHIFTpuths2 v) + +makeAcidic ''UNSHIFTpuths2 ['getUnshiftpuths2, 'putUnshiftpuths2] + + +convNUM_SHIFT_pths1 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry (Vector HOLThm) +convNUM_SHIFT_pths1 = + do acid <- openLocalStateHOLBase (SHIFTPths1 V.empty) + v <- queryHOL acid GetShiftPths1 + closeAcidStateHOL acid + if not (V.null v) + then return v + else do ths <- ruleCONJUNCTS convNUM_SHIFT_pths1' + let v' = V.fromList ths + acid' <- openLocalStateHOLBase (SHIFTPths1 V.empty) + updateHOLUnsafe acid (PutShiftPths1 v') + createCheckpointAndCloseHOL acid' + return v' + +convNUM_SHIFT_pths0 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry (Vector HOLThm) +convNUM_SHIFT_pths0 = + do acid <- openLocalStateHOLBase (SHIFTPths0 V.empty) + v <- queryHOL acid GetShiftPths0 + closeAcidStateHOL acid + if not (V.null v) + then return v + else do ths <- ruleCONJUNCTS convNUM_SHIFT_pths0' + let v' = V.fromList ths + acid' <- openLocalStateHOLBase (SHIFTPths0 V.empty) + updateHOLUnsafe acid (PutShiftPths0 v') + createCheckpointAndCloseHOL acid' + return v' + +convNUM_UNSHIFT_puths1 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry (Vector HOLThm) +convNUM_UNSHIFT_puths1 = + do acid <- openLocalStateHOLBase (UNSHIFTpuths1 V.empty) + v <- queryHOL acid GetUnshiftpuths1 + closeAcidStateHOL acid + if not (V.null v) + then return v + else do ths <- ruleCONJUNCTS convNUM_UNSHIFT_puths1' + let v' = V.fromList ths + acid' <- openLocalStateHOLBase (UNSHIFTpuths1 V.empty) + updateHOLUnsafe acid (PutUnshiftpuths1 v') + createCheckpointAndCloseHOL acid' + return v' + +convNUM_UNSHIFT_puths2 :: (BasicConvs thry, WFCtxt thry) + => HOL cls thry (Vector HOLThm) +convNUM_UNSHIFT_puths2 = + do acid <- openLocalStateHOLBase (UNSHIFTpuths2 V.empty) + v <- queryHOL acid GetUnshiftpuths2 + closeAcidStateHOL acid + if not (V.null v) + then return v + else do puths <- convNUM_UNSHIFT_puths1 + ths <- mapM (\ i -> + let th1 = puths V.! (i `mod` 16) + th2 = puths V.! (i `div` 16) in + ruleGEN_REWRITE convRAND [th1] th2) [0..256] + let v' = V.fromList ths + acid' <- openLocalStateHOLBase (UNSHIFTpuths2 V.empty) + updateHOLUnsafe acid (PutUnshiftpuths2 v') + createCheckpointAndCloseHOL acid' + return v' diff --git a/src/HaskHOL/Lib/Grobner.hs b/src/HaskHOL/Lib/Grobner.hs new file mode 100644 index 0000000..8aeae04 --- /dev/null +++ b/src/HaskHOL/Lib/Grobner.hs @@ -0,0 +1,3 @@ +module HaskHOL.Lib.Grobner where + +-- Stub diff --git a/src/HaskHOL/Lib/IndTypes.hs b/src/HaskHOL/Lib/IndTypes.hs new file mode 100644 index 0000000..d694446 --- /dev/null +++ b/src/HaskHOL/Lib/IndTypes.hs @@ -0,0 +1,625 @@ +{-# LANGUAGE PatternSynonyms #-} +{-| + Module: HaskHOL.Lib.IndTypes + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.IndTypes + ( IndTypesType + , IndTypesCtxt + , thmINJ_INVERSE2 + , thmNUMPAIR_INJ_LEMMA + , thmNUMSUM_INJ + , specNUMPAIR_DEST + , specNUMSUM_DEST + , defINJN + , defINJA + , defINJF + , defINJP + , defZCONSTR + , defZBOT + , rulesZRECSPACE + , inductZRECSPACE + , casesZRECSPACE + , tyDefMkRecspace + , tyDefDestRecspace + , defBOTTOM + , defCONSTR + , defFCONS + , defFNIL + , thmINJN_INJ -- stage2 + , thmINJA_INJ + , thmINJF_INJ + , thmINJP_INJ + , thmMK_REC_INJ + , thmDEST_REC_INJ + , thmZCONSTR_ZBOT --stage3 + , thmCONSTR_INJ + , thmCONSTR_IND + , thmCONSTR_BOT --stage4 + , thmCONSTR_REC --stage5 + , Pre.inductSUM + , Pre.recursionSUM + , Pre.defOUTL + , Pre.defOUTR + , inductOPTION -- stage1 + , recursionOPTION + , inductLIST + , recursionLIST + , defISO + , thmISO_REFL -- stage2 + , thmISO_FUN + , thmISO_USAGE + , defineType + , getType + , convFORALL_UNWIND + ) where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (getDefinition, newDefinition) + +import HaskHOL.Lib.Pair + +import HaskHOL.Lib.IndTypes.A +import HaskHOL.Lib.IndTypes.B +import qualified HaskHOL.Lib.IndTypes.Pre as Pre + +import HaskHOL.Lib.IndTypes.Base +import HaskHOL.Lib.IndTypes.Context + +defISO :: IndTypesCtxt thry => HOL cls thry HOLThm +defISO = cacheProof "defISO" ctxtIndTypes $ getDefinition "ISO" + +indDefOption :: (BasicConvs thry, IndTypesCtxt thry) + => HOL cls thry (HOLThm, HOLThm) +indDefOption = + do defs <- getIndDefs + let (_, th1, th2) = fromJust (mapLookup "option" defs) + return (th1, th2) + +inductOPTION :: (BasicConvs thry, IndTypesCtxt thry) => HOL cls thry HOLThm +inductOPTION = cacheProof "inductOPTION" ctxtIndTypes $ + liftM fst indDefOption + +recursionOPTION :: (BasicConvs thry, IndTypesCtxt thry) => HOL cls thry HOLThm +recursionOPTION = cacheProof "recursionOPTION" ctxtIndTypes $ + liftM snd indDefOption + + +indDefList :: (BasicConvs thry, IndTypesCtxt thry) + => HOL cls thry (HOLThm, HOLThm) +indDefList = + do defs <- getIndDefs + let (_, th1, th2) = fromJust (mapLookup "list" defs) + return (th1, th2) + +inductLIST :: (BasicConvs thry, IndTypesCtxt thry) => HOL cls thry HOLThm +inductLIST = cacheProof "inductLIST" ctxtIndTypes $ + liftM fst indDefList + +recursionLIST :: (BasicConvs thry, IndTypesCtxt thry) => HOL cls thry HOLThm +recursionLIST = cacheProof "recursionLIST" ctxtIndTypes $ + liftM snd indDefList + + +thmISO_REFL :: (BasicConvs thry, IndTypesCtxt thry) => HOL cls thry HOLThm +thmISO_REFL = cacheProof "thmISO_REFL" ctxtIndTypes $ + prove [str| ISO (\x:A. x) (\x. x) |] $ tacREWRITE [defISO] + +thmISO_FUN :: (BasicConvs thry, IndTypesCtxt thry) => HOL cls thry HOLThm +thmISO_FUN = cacheProof "thmISO_FUN" ctxtIndTypes . + prove [str| ISO (f:A->A') f' /\ ISO (g:B->B') g' + ==> ISO (\h a'. g(h(f' a'))) (\h a. g'(h(f a))) |] $ + tacREWRITE [defISO, thmFUN_EQ] `_THEN` tacMESON_NIL + +thmISO_USAGE :: (BasicConvs thry, IndTypesCtxt thry) => HOL cls thry HOLThm +thmISO_USAGE = cacheProof "thmISO_USAGE" ctxtIndTypes . + prove [str| ISO f g + ==> (!P. (!x. P x) <=> (!x. P(g x))) /\ + (!P. (?x. P x) <=> (?x. P(g x))) /\ + (!a b. (a = g b) <=> (f a = b)) |] $ + tacREWRITE [defISO, thmFUN_EQ] `_THEN` tacMESON_NIL + +proveITT_pth :: (BasicConvs thry, IndTypesCtxt thry) => HOL cls thry HOLThm +proveITT_pth = cacheProof "proveITT_pth" ctxtIndTypes . + prove "(?) P ==> (c = (@)P) ==> P c" $ + tacGEN_REWRITE (convLAND . convRAND) [ruleGSYM axETA] `_THEN` + tacDISCH `_THEN` _DISCH_THEN tacSUBST1 `_THEN` + tacMATCH_MP axSELECT `_THEN` _POP_ASSUM tacACCEPT + +defineType :: (BasicConvs thry, IndTypesCtxt thry) => Text + -> HOL Theory thry (HOLThm, HOLThm) +defineType s = + do acid <- openLocalStateHOL (InductiveTypes mapEmpty) + indTys <- queryHOL acid GetInductiveTypes + closeAcidStateHOL acid + case mapLookup s indTys of + Just retval -> + return retval + Nothing -> + do defspec <- parseInductiveTypeSpecification s + let newtypes = map fst defspec + constructors = foldr ((++) . map fst) [] $ map snd defspec + failWhen (return $ (length (setify newtypes)) /= + length newtypes) + "defineType: multiple definitions of a type." + failWhen (return $ (length (setify constructors)) /= + length constructors) + "defineType: multiple instances of a constructor." + cond1 <- mapM (can getTypeArity . fromJust . destVarType) + newtypes + cond2 <- mapM (can getConstType) constructors + if or cond1 + then do t <- findM (can getTypeArity) . catMaybes $ + map destVarType newtypes + fail $ "defineType: type " ++ show t ++ + " already defined." + else if or cond2 + then do t <- findM (can getConstType) constructors + fail $ "defineType: constant " ++ show t ++ + " already defined." + else do retval <- defineTypeRaw defspec + acid' <- openLocalStateHOL (InductiveTypes mapEmpty) + updateHOL acid' (AddInductiveType s retval) + createCheckpointAndCloseHOL acid' + return retval + +getType :: Text -> HOL cls thry (HOLThm, HOLThm) +getType name = + do acid <- openLocalStateHOL (InductiveTypes mapEmpty) + qth <- queryHOL acid (GetInductiveType name) + closeAcidStateHOL acid + liftMaybe ("getType: type " ++ show name ++ + " not found.") qth + + +defineTypeRaw :: (BasicConvs thry, IndTypesCtxt thry) + => [(HOLType, [(Text, [HOLType])])] + -> HOL Theory thry (HOLThm, HOLThm) +defineTypeRaw def = + let newtys = map fst def + truecons = foldr (++) [] $ map (map fst . snd) def in + do (p, ith0, rth0) <- defineTypeNested def + let (avs, etm) = stripForall $ concl rth0 + allcls = conjuncts . snd $ stripExists etm + relcls = fst . fromJust $ chopList (length truecons) allcls + gencons = fromJust $ mapM (repeatM rator <=< rand <=< lHand . + snd . stripForall) relcls + cdefs <- map2M (\ s r -> do dth <- newDefinition s =<< + mkEq (mkVar s $ typeOf r) r + liftO $ ruleSYM dth) truecons gencons + let tavs = mkArgs "f" [] $ map typeOf avs + ith1 <- ruleSUBS cdefs ith0 + rth1 <- ruleGENL tavs =<< ruleSUBS cdefs =<< ruleSPECL tavs rth0 + let retval = (p, ith1, rth1) + newentries = map (\s -> (fromJust $ destVarType s, retval)) newtys + addIndDefs newentries + mapM_ extendRectypeNet newentries + return (ith1, rth1) + +defineTypeNested :: (BasicConvs thry, IndTypesCtxt thry) + => [(HOLType, [(Text, [HOLType])])] + -> HOL Theory thry (Int, HOLThm, HOLThm) +defineTypeNested def = + let n = length . foldr (++) [] $ map (map fst . snd) def + newtys = map fst def + utys = unions $ foldr (union . map snd . snd) [] def + rectys = filter (isNested newtys) utys in + if null rectys then do (th1, th2) <- defineTypeBasecase + return (n, th1, th2) + else let nty = head (sort (\ t1 t2 -> t2 `occursIn` t1) rectys) in + do (k, tyal, ncls, ith, rth) <- createAuxiliaryClauses nty + let cls = fromRight . mapM (modifyClause tyal) $ def ++ ncls + (_, ith1, rth1) <- defineTypeNested cls + let xnewtys = map (head . snd . fromJust . destType . typeOf) . + fst . stripExists . snd . stripForall $ + concl rth1 + xtyal = fromJust . mapM + (\ ty -> + do s <- destVarType ty + s' <- findM (\ t -> + do (t', _) <- destType t + let (op, _) = destTypeOp t' + return $! op == s) xnewtys + return (ty, s')) $ map fst cls + ith0 = primINST_TYPE xtyal ith + rth0 = primINST_TYPE xtyal rth + (isoth, rclauses) <- proveInductiveTypesIsomorphic n k + (ith0, rth0) (ith1, rth1) + irth3 <- ruleCONJ ith1 rth1 + let vtylist = foldr (insert . typeOf) [] . variables $ + concl irth3 + isoths <- ruleCONJUNCTS isoth + let isotys = fromJust $ mapM (liftM (head . snd) . destType <=< + liftM typeOf . lHand . concl) isoths + ctylist = filter (\ ty -> + any (\ t -> t `occursIn` ty) isotys) + vtylist + atylist = foldr (union . stripList destFunTy) [] ctylist + isoths' <- mapM (liftTypeBijections isoths) $ + filter (\ ty -> any (\ t -> t `occursIn` ty) isotys) + atylist + cisoths <- mapM (ruleBETA <=< liftTypeBijections isoths') + ctylist + uisoths <- mapM ruleISO_USAGE cisoths + let visoths = fromRight $ mapM (primASSUME . concl) uisoths + irth3' <- ruleREWRITE_FUN_EQ visoths irth3 + let irth4 = foldr rulePROVE_HYP irth3' uisoths + isoths'' <- mapM ruleSIMPLE_ISO_EXPAND isoths' + irth5 <- ruleREWRITE (rclauses : isoths'') irth4 + irth6 <- repeatM ruleSCRUB_ASSUMPTION irth5 + let ncjs = filter (\ t -> + let ts = snd . stripComb . fromJust $ rand =<< + (lhs . snd $ stripForall t) in + any (\ v -> not $ isVar v) ts) . conjuncts . + snd . stripExists . snd . stripForall . fromJust . + rand $ concl irth6 + dths <- mapM mkNewcon ncjs + (ith6, rth6) <- ruleCONJ_PAIR =<< rulePURE_REWRITE dths irth6 + return (n, ith6, rth6) + where ruleSCRUB_ASSUMPTION :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm + ruleSCRUB_ASSUMPTION th = + let hyps = hyp th + eqn = fromJust $ findM (\ t -> + do x <- lhs t + return $! all (\ u -> + let u' = fromJust $ rand u in + x `freeIn` u') hyps) hyps + (l, r) = fromJust $ destEq eqn in + do th' <- ruleDISCH eqn th + flip ruleMP (primREFL r) #<< primINST [(l, r)] th' + + ruleSIMPLE_BETA :: (BasicConvs thry, ClassicCtxt thry) => HOLThm + -> HOL cls thry HOLThm + ruleSIMPLE_BETA = + ruleGSYM <=< rulePURE_REWRITE [thmBETA, thmFUN_EQ] + + ruleISO_USAGE :: (BasicConvs thry, IndTypesCtxt thry) => HOLThm + -> HOL cls thry HOLThm + ruleISO_USAGE = ruleMATCH_MP thmISO_USAGE + + ruleSIMPLE_ISO_EXPAND :: IndTypesCtxt thry => HOLThm + -> HOL cls thry HOLThm + ruleSIMPLE_ISO_EXPAND = ruleCONV (convREWR defISO) + + ruleREWRITE_FUN_EQ :: (BasicConvs thry, ClassicCtxt thry) => [HOLThm] + -> HOLThm + -> HOL cls thry HOLThm + ruleREWRITE_FUN_EQ thms thm = + do ths <- foldrM (mkRewrites False) [] [thmFUN_EQ] + net <- basicNet + let net' = fromJust $ foldrM (netOfThm False) net ths + ruleCONV (convGENERAL_REWRITE True convTOP_DEPTH net' thms) thm + + defineTypeBasecase :: (BasicConvs thry, IndTypesCtxt thry) + => HOL Theory thry (HOLThm, HOLThm) + defineTypeBasecase = + let addId _ = liftM (fst . fromJust . destVar) $ genVar tyBool in + do def' <- mapM (return `ffCombM` (mapM (addId `ffCombM` return))) + def + Pre.defineTypeRaw def' + + mkNewcon :: (BasicConvs thry, PairCtxt thry) => HOLTerm + -> HOL Theory thry HOLThm + mkNewcon tm = + let (vs, bod) = stripForall tm + rdeb = fromJust $ rand =<< lhs bod + rdef = fromRight $ listMkAbs vs rdeb in + do newname <- liftM (fst . fromJust . destVar) $ genVar tyBool + def' <- mkEq (mkVar newname $ typeOf rdef) rdef + dth <- newDefinition newname def' + ruleSIMPLE_BETA dth + + createAuxiliaryClauses :: HOLType -> + HOL cls thry (Int, HOLTypeEnv, + [(HOLType, [(Text, [HOLType])])], HOLThm, HOLThm) + createAuxiliaryClauses nty = + do id' <- liftM (fst . fromJust . destVar) $ genVar tyBool + let (tycon, _) = fromJust $ destType nty + indTys <- getIndDefs + (k, ith, rth) <- liftMaybe ("definedType: Can't find definition " + ++ "for nested type: " + ++ show tycon) $ + (fst $ destTypeOp tycon) `mapLookup` indTys + let (evs, bod) = stripExists . snd . stripForall $ concl rth + cjs = fromJust . mapM (lHand . snd . stripForall) $ + conjuncts bod + rtys = map (head . snd . fromJust . destType . typeOf) evs + tyins = fromJust $ tryFind + (\ vty -> typeMatch vty nty ([], [], [])) rtys + cjs' = map (instFull tyins . fromJust . rand) . fst . + fromJust $ chopList k cjs + mtys = foldr (insert . typeOf) [] cjs' + pcons = map (\ ty -> + filter (\ t -> typeOf t == ty) cjs') mtys + cls' = zip mtys $ map (map (recoverClause id')) pcons + tyal = map (\ ty -> let x = fst . destTypeOp . fst . + fromJust $ destType ty in + (mkVarType (x `append` id'), ty)) mtys + let cls'' = fromRight $ mapM (modifyType tyal `ffCombM` + mapM (modifyItem tyal)) cls' + return (k, tyal, cls'', + primINST_TYPE_FULL tyins ith, + primINST_TYPE_FULL tyins rth) + + recoverClause :: Text -> HOLTerm -> (Text, [HOLType]) + recoverClause id' tm = + let (con, args) = stripComb tm + (x, _) = fromJust $ destConst con in + (x `append` id', map typeOf args) + + modifyClause :: HOLTypeEnv -> (HOLType, [(Text, [HOLType])]) + -> Either String (HOLType, [(Text, [HOLType])]) + modifyClause alist (l, lis) = + do lis' <- mapM (modifyItem alist) lis + return (l, lis') + + modifyItem :: HOLTypeEnv -> (Text, [HOLType]) + -> Either String (Text, [HOLType]) + modifyItem alist (s, l) = + do l' <- mapM (modifyType alist) l + return (s, l') + + modifyType :: HOLTypeEnv -> HOLType -> Either String HOLType + modifyType alist ty = + case revLookup ty alist of + Just res -> return res + _ -> do (tycon, tyargs) <- note "modifyType" $ destType ty + tyApp tycon =<< mapM (modifyType alist) tyargs + + isNested :: [HOLType] -> HOLType -> Bool + isNested vs ty = not (isVarType ty) && + not (null $ intersect (tyVars ty) vs) + +proveInductiveTypesIsomorphic :: (BasicConvs thry, IndTypesCtxt thry) + => Int -> Int + -> (HOLThm, HOLThm) + -> (HOLThm, HOLThm) + -> HOL cls thry (HOLThm, HOLThm) +proveInductiveTypesIsomorphic n k (ith0, rth0) (ith1, rth1) = + do sth0 <- ruleSPEC_ALL rth0 + sth1 <- ruleSPEC_ALL rth1 + tmT <- liftM concl thmTRUTH + let (pevs0, pbod0) = stripExists $ concl sth0 + (pevs1, pbod1) = stripExists $ concl sth1 + (pcjs0, _) = fromJust . chopList k $ conjuncts pbod0 + (pcjs1, _) = fromJust $ chopList k =<< + (liftM snd . chopList n $ conjuncts pbod1) + (pcjs1', pcjs0') = fromJust $ pairMapM (mapM grabType) (pcjs1, pcjs0) + tyal0 = setify $ zip pcjs1' pcjs0' + tyal1 = map (\ (a, b) -> (b, a)) tyal0 + tyins0 = fromRight $ mapM (\ f -> + do (domty, ranty) <- note "" . destFunTy $ typeOf f + l <- tysubst tyal0 domty + return (l, ranty)) pevs0 + tyins1 = fromRight $ mapM (\ f -> + do (domty, ranty) <- note "" . destFunTy $ typeOf f + l <- tysubst tyal1 domty + return (l, ranty)) pevs1 + tth0 = primINST_TYPE tyins0 sth0 + tth1 = primINST_TYPE tyins1 sth1 + (_, bod0) = stripExists $ concl tth0 + (_, bod1) = stripExists $ concl tth1 + (lcjs0, rcjs0) = fromJust . chopList k . map (snd . stripForall) $ + conjuncts bod0 + (lcjs1, rcjsx) = fromJust $ chopList k =<< + (liftM (map (snd . stripForall) . snd) . + chopList n $ conjuncts bod1) + rcjs1 = fromJust $ + mapM (\ t -> findM (clauseCorresponds t) rcjsx) rcjs0 + (insts0, insts1) <- liftM unzip $ map2M procClause (lcjs0++rcjs0) + (lcjs1++rcjs1) + uth0 <- ruleBETA #<< primINST insts0 tth0 + uth1 <- ruleBETA #<< primINST insts1 tth1 + (efvs0, sth0') <- ruleDE_EXISTENTIALIZE uth0 + (efvs1, sth1') <- ruleDE_EXISTENTIALIZE uth1 + let efvs2 = fromJust $ mapM (\ t1 -> findM (\ t2 -> + do t1' <- destType $ typeOf t1 + t2' <- destType $ typeOf t2 + return $! (head . tail $ snd t1') == + (head $ snd t2')) efvs1) efvs0 + isotms <- map2M (\ ff gg -> listMkIComb "ISO" [ff, gg]) efvs0 efvs2 + ctm <- listMkConj isotms + cth1 <- runConv (convISO_EXPAND) ctm + let ctm1 = fromJust . rand $ concl cth1 + cjs = conjuncts ctm1 + eee = map (\ x -> x `mod` 2 == 0) [0..(length cjs -1)] + (cjs1, cjs2) = partition fst $ zip eee cjs + ctm2 <- liftM1 mkConj (listMkConj $ map snd cjs1) =<< + listMkConj (map snd cjs2) + let ruleDETRIV = ruleTRIV_ANTE <=< ruleREWRITE [sth0', sth1'] + jth0 <- do itha <- ruleSPEC_ALL ith0 + let icjs = conjuncts . fromJust . rand $ concl itha + cinsts <- liftO $ mapM (\ tm -> tryFind (\ vtm -> + termMatch [] vtm tm) icjs) =<< + liftM conjuncts (rand ctm2) + let tvs = (fst . stripForall $ concl ith0) \\ + (foldr (\ (_, x, _) -> union (map snd x)) [] + cinsts) + ctvs = fromRight $ mapM (\ p -> + do (_, tys) <- note "" . destType $ typeOf p + let x = mkVar "x" $ head tys + x' <- mkAbs x tmT + return (x', p)) tvs + ithas <- foldrM ruleINSTANTIATE itha cinsts + ruleDETRIV #<< primINST ctvs ithas + jth1 <- do itha <- ruleSPEC_ALL ith1 + let icjs = conjuncts . fromJust . rand $ concl itha + cinsts <-liftO $ mapM (\ tm -> tryFind (\ vtm -> + termMatch [] vtm tm) icjs) =<< + liftM conjuncts (lHand ctm2) + let tvs = (fst . stripForall $ concl ith1) \\ + (foldr (\ (_, x, _) -> union (map snd x)) [] + cinsts) + ctvs = fromRight $ mapM (\ p -> + do (_, tys) <- note "" . destType $ typeOf p + let x = mkVar "x" $ head tys + x' <- mkAbs x tmT + return (x', p)) tvs + ithas <- foldrM ruleINSTANTIATE itha cinsts + ruleDETRIV #<< primINST ctvs ithas + cths4 <- liftM1 (map2M ruleCONJ) (ruleCONJUNCTS jth0) =<< + ruleCONJUNCTS jth1 + cths5 <- mapM (rulePURE_ONCE_REWRITE [ruleGSYM defISO]) cths4 + cth6 <- foldr1M ruleCONJ cths5 + cth7 <- ruleCONJ sth0' sth1' + return (cth6, cth7) + where ruleTRIV_ANTE :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm + ruleTRIV_ANTE th = + let tm = concl th in + if isImp tm + then let (ant, _) = fromJust . destImp $ concl th + cjs = conjuncts ant in + do cths <- mapM (runConv convTRIV_IMP) cjs + ruleMP th =<< foldr1M ruleCONJ cths + else return th + where convTRIV_IMP :: BoolCtxt thry => Conversion cls thry + convTRIV_IMP = Conv $ \ tm -> + let (avs, bod) = stripForall tm in + do bth <- + if isEq bod + then return . primREFL . fromJust $ rand bod + else let (ant, con) = fromJust $ destImp bod in + do ants <- ruleCONJUNCTS #<< primASSUME ant + ith <- runConv (convSUBS ants) #<< + lhs con + ruleDISCH ant ith + ruleGENL avs bth + + convISO_EXPAND :: IndTypesCtxt thry => Conversion cls thry + convISO_EXPAND = convPURE_ONCE_REWRITE [defISO] + + ruleDE_EXISTENTIALIZE :: (BasicConvs thry, IndTypesCtxt thry) => HOLThm + -> HOL cls thry ([HOLTerm], HOLThm) + ruleDE_EXISTENTIALIZE th = + if not . isExists $ concl th then return ([], th) + else do th1 <- ruleMATCH_MP proveITT_pth th + let v1 = fromJust $ rand =<< rand (concl th1) + gv <- genVar $ typeOf v1 + th2 <- ruleCONV convBETA =<< ruleUNDISCH #<< + primINST [(v1, gv)] th1 + (vs, th3) <- ruleDE_EXISTENTIALIZE th2 + return (gv:vs, th3) + + procClause :: HOLTerm -> HOLTerm + -> HOL cls thry ((HOLTerm, HOLTerm), (HOLTerm, HOLTerm)) + procClause tm0 tm1 = + let (l0, r0) = fromJust $ destEq tm0 + (l1, r1) = fromJust $ destEq tm1 + (vc0, wargs0) = stripComb r0 + (_, vargs0) = stripComb . fromJust $ rand l0 in + do gargs0 <- mapM (genVar . typeOf) wargs0 + let nestf0 = fromJust $ mapM (\ a -> can (findM (\ t -> + do t' <- rand t + return $! isComb t && t' == a)) wargs0) vargs0 + targs0 = fromJust $ map2M (\ a f -> + if f then find (\ t -> isComb t && + rand t == Just a) wargs0 + else Just a) vargs0 nestf0 + gvlist0 = zip wargs0 gargs0 + xargs = fromJust $ mapM (\ v -> v `lookup` gvlist0) targs0 + l1' = fst . stripComb . fromJust $ rand l1 + itm0 = fromRight $ listMkAbs gargs0 =<< + listMkComb l1' xargs + inst0 = (vc0, itm0) + (vc1, wargs1) = stripComb r1 + (_, vargs1) = stripComb . fromJust $ rand l1 + gargs1 <- mapM (genVar . typeOf) wargs1 + let targs1 = fromJust $ map2M (\ a f -> + if f then find (\ t -> isComb t && + rand t == Just a) wargs1 + else Just a) vargs1 nestf0 + gvlist1 = zip wargs1 gargs1 + xargs' = fromJust $ mapM (\ v -> v `lookup` gvlist1) targs1 + l0' = fst . stripComb . fromJust $ rand l0 + itm1 = fromRight $ listMkAbs gargs1 =<< + listMkComb l0' xargs' + inst1 = (vc1, itm1) + return (inst0, inst1) + + clauseCorresponds :: HOLTerm -> HOLTerm -> Maybe Bool + clauseCorresponds cl0 cl1 = + do (f0, ctm0) <- destComb =<< lhs cl0 + c0 <- liftM fst . destConst . fst $ stripComb ctm0 + (dty0, rty0) <- destFunTy $ typeOf f0 + (f1, ctm1) <- destComb =<< lhs cl1 + c1 <- liftM fst . destConst . fst $ stripComb ctm1 + (dty1, rty1) <- destFunTy $ typeOf f1 + return $! c0 == c1 && dty0 == rty1 && rty0 == dty1 + + grabType :: HOLTerm -> Maybe HOLType + grabType = liftM typeOf . rand <=< lHand . snd . stripForall + +liftTypeBijections :: (BasicConvs thry, IndTypesCtxt thry) => [HOLThm] + -> HOLType + -> HOL cls thry HOLThm +liftTypeBijections iths cty = + let itys = fromJust $ mapM (liftM (head . snd) . destType <=< + liftM typeOf . lHand . concl) iths in + case cty `lookup` zip itys iths of + Just res -> return res + _ -> if not $ any (flip occursIn cty) itys + then liftM (primINST_TYPE [(tyA, cty)]) thmISO_REFL + else let (tycon, isotys) = fromJust $ destType cty in + if tycon == tyOpFun + then ruleMATCH_MP thmISO_FUN =<< foldr1M ruleCONJ =<< + mapM (liftTypeBijections iths) isotys + else fail $ "liftTypeBijections: Unexpected type operator " + ++ show tycon + + +convFORALL_UNWIND :: (BasicConvs thry, IndTypesCtxt thry) => Conversion cls thry +convFORALL_UNWIND = Conv $ \ tm -> + let (avs, bod) = stripForall tm + (ant, con) = fromJust $ destImp bod + eqs = conjuncts ant + eq = fromJust $ findM (\ x -> + if isEq x then return True + else do (xl, xr) <- destEq tm + return $! (xl `elem` avs && not (xl `freeIn` xr)) || + (xr `elem` avs && not (xr `freeIn` xl))) eqs + (l, r) = fromJust $ destEq eq + v = if l `elem` avs && not (l `freeIn` r) then l else r + cjs' = eq : (eqs \\ [eq]) + n = length avs - (1 + (fromJust . index v $ reverse avs)) in + do th1 <- ruleCONJ_ACI =<< mkEq ant =<< listMkConj cjs' + let th2 = fromRight $ + liftM1 ruleAP_THM (flip ruleAP_TERM th1 #<< rand =<< + rator bod) con + th3 <- foldrM ruleMK_FORALL th2 avs + th4 <- runConv (funpow n convBINDER convPUSH_FORALL) #<< + rand (concl th3) + ruleCONV (convRAND convFORALL_UNWIND) #<< primTRANS th3 th4 + where convPUSH_FORALL :: (BasicConvs thry, IndTypesCtxt thry) + => Conversion cls thry + convPUSH_FORALL = + (convREWR thmSWAP_FORALL `_THEN` convBINDER convPUSH_FORALL) + `_ORELSE` convGEN_REWRITE id [ convFORALL_UNWIND_pth1 + , convFORALL_UNWIND_pth2 + , convFORALL_UNWIND_pth3 + , convFORALL_UNWIND_pth4 + ] + + convFORALL_UNWIND_pth1 :: (BasicConvs thry, IndTypesCtxt thry) + => HOL cls thry HOLThm + convFORALL_UNWIND_pth1 = cacheProof "convFORALL_UNWIND_pth1" ctxtIndTypes $ + ruleMESON_NIL [str| (!x. x = a /\ p x ==> q x) <=> (p a ==> q a) |] + + convFORALL_UNWIND_pth2 :: (BasicConvs thry, IndTypesCtxt thry) + => HOL cls thry HOLThm + convFORALL_UNWIND_pth2 = cacheProof "convFORALL_UNWIND_pth2" ctxtIndTypes $ + ruleMESON_NIL [str| (!x. a = x /\ p x ==> q x) <=> (p a ==> q a) |] + + convFORALL_UNWIND_pth3 :: (BasicConvs thry, IndTypesCtxt thry) + => HOL cls thry HOLThm + convFORALL_UNWIND_pth3 = cacheProof "convFORALL_UNWIND_pth3" ctxtIndTypes $ + ruleMESON_NIL [str| (!x. x = a ==> q x) <=> q a |] + + convFORALL_UNWIND_pth4 :: (BasicConvs thry, IndTypesCtxt thry) + => HOL cls thry HOLThm + convFORALL_UNWIND_pth4 = cacheProof "convFORALL_UNWIND_pth4" ctxtIndTypes $ + ruleMESON_NIL [str| (!x. a = x ==> q x) <=> q a |] diff --git a/src/HaskHOL/Lib/IndTypes/A.hs b/src/HaskHOL/Lib/IndTypes/A.hs new file mode 100644 index 0000000..a9fedc4 --- /dev/null +++ b/src/HaskHOL/Lib/IndTypes/A.hs @@ -0,0 +1,9 @@ +module HaskHOL.Lib.IndTypes.A + ( module HaskHOL.Lib.IndTypes.A.Pre + , module HaskHOL.Lib.IndTypes.A.Base + , module HaskHOL.Lib.IndTypes.A.Context + ) where + +import HaskHOL.Lib.IndTypes.A.Pre +import HaskHOL.Lib.IndTypes.A.Base +import HaskHOL.Lib.IndTypes.A.Context diff --git a/src/HaskHOL/Lib/IndTypes/A/Base.hs b/src/HaskHOL/Lib/IndTypes/A/Base.hs new file mode 100644 index 0000000..b198849 --- /dev/null +++ b/src/HaskHOL/Lib/IndTypes/A/Base.hs @@ -0,0 +1,91 @@ +module HaskHOL.Lib.IndTypes.A.Base where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (getDefinition, getSpecification, + newSpecification, newDefinition) + +import HaskHOL.Lib.Pair +import HaskHOL.Lib.Recursion +import HaskHOL.Lib.Nums +import HaskHOL.Lib.Arith +import HaskHOL.Lib.CalcNum +import HaskHOL.Lib.WF +import HaskHOL.Lib.WF.Context + +import HaskHOL.Lib.IndTypes.A.Pre + +thmNUMPAIR_INJ :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +thmNUMPAIR_INJ = cacheProof "thmNUMPAIR_INJ" ctxtWF $ + prove [str| !x1 y1 x2 y2. (NUMPAIR x1 y1 = NUMPAIR x2 y2) <=> + (x1 = x2) /\ (y1 = y2) |] $ + _REPEAT tacGEN `_THEN` tacEQ `_THEN` tacDISCH `_THEN` + tacASM_REWRITE_NIL `_THEN` + _FIRST_ASSUM (tacSUBST_ALL . ruleMATCH_MP thmNUMPAIR_INJ_LEMMA) `_THEN` + _POP_ASSUM tacMP `_THEN` tacREWRITE [defNUMPAIR] `_THEN` + tacREWRITE [thmEQ_MULT_LCANCEL, thmEQ_ADD_RCANCEL, thmEXP_EQ_0, thmARITH] + +specNUMPAIR_DEST' :: (BasicConvs thry, WFCtxt thry) => HOL Theory thry HOLThm +specNUMPAIR_DEST' = newSpecification ["NUMFST", "NUMSND"] =<< + ruleMATCH_MP thmINJ_INVERSE2 thmNUMPAIR_INJ + +specNUMSUM_DEST' :: (BasicConvs thry, WFCtxt thry) => HOL Theory thry HOLThm +specNUMSUM_DEST' = newSpecification ["NUMLEFT", "NUMRIGHT"] =<< + ruleMATCH_MP thmINJ_INVERSE2 thmNUMSUM_INJ + + +defINJN' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defINJN' = newDefinition "INJN" + [str| INJN (m:num) = \(n:num) (a:A). n = m |] + +defINJA' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defINJA' = newDefinition "INJA" + [str| INJA (a:A) = \(n:num) b. b = a |] + +defINJF' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defINJF' = newDefinition "INJF" + [str| INJF (f:num->(num->A->bool)) = \n. f (NUMFST n) (NUMSND n) |] + +defINJP' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defINJP' = newDefinition "INJP" + [str| INJP f1 f2:num->A->bool = + \n a. if NUMLEFT n then f1 (NUMRIGHT n) a + else f2 (NUMRIGHT n) a |] + + +defZCONSTR' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defZCONSTR' = newDefinition "ZCONSTR" + [str| ZCONSTR c i r :num->A->bool = + INJP (INJN (SUC c)) (INJP (INJA i) (INJF r)) |] + +defZBOT' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defZBOT' = newDefinition "ZBOT" + [str| ZBOT = INJP (INJN 0) (@z:num->A->bool. T) |] + +indDefZRECSPACE' :: (BasicConvs thry, IndDefsCtxt thry) + => HOL Theory thry (HOLThm, HOLThm, HOLThm) +indDefZRECSPACE' = newInductiveDefinition "ZRECSPACE" + [str| ZRECSPACE (ZBOT:num->A->bool) /\ + (!c i r. (!n. ZRECSPACE (r n)) ==> ZRECSPACE (ZCONSTR c i r)) |] + +tyDefRecspace' :: BoolCtxt thry => HOLThm -> HOL Theory thry (HOLThm, HOLThm) +tyDefRecspace' rep = + newBasicTypeDefinition "recspace" "_mk_rec" "_dest_rec" =<< + ruleCONJUNCT1 rep + +defBOTTOM' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defBOTTOM' = newDefinition "BOTTOM" + [str| BOTTOM = _mk_rec (ZBOT:num->A->bool) |] + +defCONSTR' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defCONSTR' = newDefinition "CONSTR" + [str| CONSTR c i r :(A)recspace = + _mk_rec (ZCONSTR c i (\n. _dest_rec(r n))) |] + +defFCONS' :: (BasicConvs thry, NumsCtxt thry) => HOL Theory thry HOLThm +defFCONS' = newRecursiveDefinition "FCONS" recursionNUM + [str| (!a f. FCONS (a:A) f 0 = a) /\ + (!a f n. FCONS (a:A) f (SUC n) = f n) |] + +defFNIL' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defFNIL' = newDefinition "FNIL" + "FNIL (n:num) = @x:A. T" diff --git a/src/HaskHOL/Lib/IndTypes/A/Context.hs b/src/HaskHOL/Lib/IndTypes/A/Context.hs new file mode 100644 index 0000000..31d854b --- /dev/null +++ b/src/HaskHOL/Lib/IndTypes/A/Context.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TemplateHaskell, + TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +module HaskHOL.Lib.IndTypes.A.Context + ( IndTypesAType + , IndTypesACtxt + , ctxtIndTypesA + , indTypesA + ) where + +import HaskHOL.Core +import HaskHOL.Deductive +import HaskHOL.Lib.Pair + +import HaskHOL.Lib.WF.Context +import HaskHOL.Lib.IndTypes.A.Base + +-- generate template types +extendTheory ctxtWF "IndTypesA" $ + do sequence_ [ specNUMPAIR_DEST' + , specNUMSUM_DEST' + , defINJN' + , defINJA' + , defINJF' + , defINJP' + , defZCONSTR' + , defZBOT' + ] + (rep, _, _) <- indDefZRECSPACE' + _ <- tyDefRecspace' rep + sequence_ [ defBOTTOM' + , defCONSTR' + , defFCONS' + , defFNIL' + ] + +templateProvers 'ctxtIndTypesA + +-- have to manually write this, for now +type family IndTypesACtxt a where + IndTypesACtxt a = (WFCtxt a, IndTypesAContext a ~ True) + +type instance PolyTheory IndTypesAType b = IndTypesACtxt b + +instance BasicConvs IndTypesAType where + basicConvs _ = basicConvs (undefined :: PairType) diff --git a/src/HaskHOL/Lib/IndTypes/A/Pre.hs b/src/HaskHOL/Lib/IndTypes/A/Pre.hs new file mode 100644 index 0000000..83ea1c4 --- /dev/null +++ b/src/HaskHOL/Lib/IndTypes/A/Pre.hs @@ -0,0 +1,50 @@ +module HaskHOL.Lib.IndTypes.A.Pre where + +import HaskHOL.Core +import HaskHOL.Deductive + +import HaskHOL.Lib.Nums +import HaskHOL.Lib.Arith +import HaskHOL.Lib.CalcNum +import HaskHOL.Lib.WF +import HaskHOL.Lib.WF.Context + +thmINJ_INVERSE2 :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +thmINJ_INVERSE2 = cacheProof "thmINJ_INVERSE2" ctxtWF $ + prove [str| !P:A->B->C. + (!x1 y1 x2 y2. (P x1 y1 = P x2 y2) <=> (x1 = x2) /\ (y1 = y2)) + ==> ?X Y. !x y. (X(P x y) = x) /\ (Y(P x y) = y) |] $ + tacGEN `_THEN` tacDISCH `_THEN` + tacEXISTS [str| \z:C. @x:A. ?y:B. P x y = z |] `_THEN` + tacEXISTS [str| \z:C. @y:B. ?x:A. P x y = z |] `_THEN` + _REPEAT tacGEN `_THEN` tacASM_REWRITE [thmBETA] `_THEN` + tacCONJ `_THEN` tacMATCH_MP thmSELECT_UNIQUE `_THEN` tacGEN `_THEN` + tacBETA `_THEN` tacEQ `_THEN` tacSTRIP `_THEN` tacASM_REWRITE_NIL `_THEN` + (\ g@(Goal _ w) -> tacEXISTS + (rand =<< liftM snd (destExists w)) g) `_THEN` tacREFL + +thmNUMPAIR_INJ_LEMMA :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +thmNUMPAIR_INJ_LEMMA = cacheProof "thmNUMPAIR_INJ_LEMMA" ctxtWF $ + do tm <- toHTm "EVEN" + prove "!x1 y1 x2 y2. (NUMPAIR x1 y1 = NUMPAIR x2 y2) ==> (x1 = x2)" $ + tacREWRITE [defNUMPAIR] `_THEN` + _REPEAT (tacINDUCT `_THEN` tacGEN) `_THEN` + tacASM_REWRITE [ defEXP, ruleGSYM thmMULT_ASSOC, thmARITH + , thmEQ_MULT_LCANCEL + , thmNOT_SUC, ruleGSYM thmNOT_SUC, thmSUC_INJ ] `_THEN` + _DISCH_THEN (tacMP <#< ruleAP_TERM tm) `_THEN` + tacREWRITE [thmEVEN_MULT, thmEVEN_ADD, thmARITH] + +thmNUMSUM_INJ :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +thmNUMSUM_INJ = cacheProof "thmNUMSUM_INJ" ctxtWF $ + do tm <- toHTm "EVEN" + prove [str| !b1 x1 b2 x2. (NUMSUM b1 x1 = NUMSUM b2 x2) <=> + (b1 = b2) /\ (x1 = x2) |] $ + _REPEAT tacGEN `_THEN` tacEQ `_THEN` tacDISCH `_THEN` + tacASM_REWRITE_NIL `_THEN` + _POP_ASSUM (tacMP . ruleREWRITE [defNUMSUM]) `_THEN` + _DISCH_THEN (\ th -> tacMP th `_THEN` + tacMP (ruleAP_TERM tm th)) `_THEN` + _REPEAT tacCOND_CASES `_THEN` + tacREWRITE [defEVEN, thmEVEN_DOUBLE] `_THEN` + tacREWRITE [thmSUC_INJ, thmEQ_MULT_LCANCEL, thmARITH] diff --git a/src/HaskHOL/Lib/IndTypes/B.hs b/src/HaskHOL/Lib/IndTypes/B.hs new file mode 100644 index 0000000..fdc3bed --- /dev/null +++ b/src/HaskHOL/Lib/IndTypes/B.hs @@ -0,0 +1,9 @@ +module HaskHOL.Lib.IndTypes.B + ( module HaskHOL.Lib.IndTypes.B.Pre + , module HaskHOL.Lib.IndTypes.B.Base + , module HaskHOL.Lib.IndTypes.B.Context + ) where + +import HaskHOL.Lib.IndTypes.B.Pre hiding (defineTypeRaw) +import HaskHOL.Lib.IndTypes.B.Base +import HaskHOL.Lib.IndTypes.B.Context diff --git a/src/HaskHOL/Lib/IndTypes/B/Base.hs b/src/HaskHOL/Lib/IndTypes/B/Base.hs new file mode 100644 index 0000000..510a3ab --- /dev/null +++ b/src/HaskHOL/Lib/IndTypes/B/Base.hs @@ -0,0 +1,24 @@ +module HaskHOL.Lib.IndTypes.B.Base where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (getDefinition, getSpecification, + newSpecification, newDefinition) + +import HaskHOL.Lib.Recursion +import HaskHOL.Lib.Nums + +import HaskHOL.Lib.IndTypes.B.Pre +import HaskHOL.Lib.IndTypes.A + +indDefSum' :: (BasicConvs thry, IndTypesACtxt thry) + => HOL Theory thry (HOLThm, HOLThm) +indDefSum' = defineTypeRaw =<< + parseInductiveTypeSpecification "sum = INL A | INR B" + +defOUTL' :: (BasicConvs thry, NumsCtxt thry) => HOLThm -> HOL Theory thry HOLThm +defOUTL' th = newRecursiveDefinition "OUTL" th + [str| OUTL (INL x :A+B) = x |] + +defOUTR' :: (BasicConvs thry, NumsCtxt thry) => HOLThm -> HOL Theory thry HOLThm +defOUTR' th = newRecursiveDefinition "OUTR" th + [str| OUTR (INR y :A+B) = y |] diff --git a/src/HaskHOL/Lib/IndTypes/B/Context.hs b/src/HaskHOL/Lib/IndTypes/B/Context.hs new file mode 100644 index 0000000..6fd7856 --- /dev/null +++ b/src/HaskHOL/Lib/IndTypes/B/Context.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TemplateHaskell, + TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +module HaskHOL.Lib.IndTypes.B.Context + ( IndTypesBType + , IndTypesBCtxt + , ctxtIndTypesB + , indTypesB + ) where + +import HaskHOL.Core +import HaskHOL.Deductive +import HaskHOL.Lib.Pair + +import HaskHOL.Lib.IndTypes.A.Context +import HaskHOL.Lib.IndTypes.B.Base + +-- generate template types +extendTheory ctxtIndTypesA "IndTypesB" $ + do (indth, recth) <- indDefSum' + sequence_ [ defOUTL' recth + , defOUTR' recth + ] + addIndDefs [("sum", (2, indth, recth))] + +templateProvers 'ctxtIndTypesB + +-- have to manually write this, for now +type family IndTypesBCtxt a where + IndTypesBCtxt a = (IndTypesACtxt a, IndTypesBContext a ~ True) + +type instance PolyTheory IndTypesBType b = IndTypesBCtxt b + +instance BasicConvs IndTypesBType where + basicConvs _ = basicConvs (undefined :: PairType) diff --git a/src/HaskHOL/Lib/IndTypes/B/Pre.hs b/src/HaskHOL/Lib/IndTypes/B/Pre.hs new file mode 100644 index 0000000..773c079 --- /dev/null +++ b/src/HaskHOL/Lib/IndTypes/B/Pre.hs @@ -0,0 +1,832 @@ +{-# LANGUAGE PatternSynonyms #-} +module HaskHOL.Lib.IndTypes.B.Pre where + +import HaskHOL.Core hiding (many, rights) +import HaskHOL.Deductive hiding (getDefinition, getSpecification, newDefinition) + +import HaskHOL.Lib.Pair +import HaskHOL.Lib.Recursion +import HaskHOL.Lib.Nums +import HaskHOL.Lib.WF +import HaskHOL.Lib.WF.Context + +import HaskHOL.Lib.IndTypes.A + +specNUMPAIR_DEST :: IndTypesACtxt thry => HOL cls thry HOLThm +specNUMPAIR_DEST = cacheProof "specNUMPAIR_DEST" ctxtIndTypesA $ + getSpecification ["NUMFST", "NUMSND"] + +specNUMSUM_DEST :: IndTypesACtxt thry => HOL cls thry HOLThm +specNUMSUM_DEST = cacheProof "specNUMSUM_DEST" ctxtIndTypesA $ + getSpecification ["NUMLEFT", "NUMRIGHT"] + +defINJN :: IndTypesACtxt thry => HOL cls thry HOLThm +defINJN = cacheProof "defINJN" ctxtIndTypesA $ getDefinition "INJN" + +defINJA :: IndTypesACtxt thry => HOL cls thry HOLThm +defINJA = cacheProof "defINJA" ctxtIndTypesA $ getDefinition "INJA" + +defINJF :: IndTypesACtxt thry => HOL cls thry HOLThm +defINJF = cacheProof "defINJF" ctxtIndTypesA $ getDefinition "INJF" + +defINJP :: IndTypesACtxt thry => HOL cls thry HOLThm +defINJP = cacheProof "defINJP" ctxtIndTypesA $ getDefinition "INJP" + +defZCONSTR :: IndTypesACtxt thry => HOL cls thry HOLThm +defZCONSTR = cacheProof "defZCONSTR" ctxtIndTypesA $ getDefinition "ZCONSTR" + +defZBOT :: IndTypesACtxt thry => HOL cls thry HOLThm +defZBOT = cacheProof "defZBOT" ctxtIndTypesA $ getDefinition "ZBOT" + +defBOTTOM :: IndTypesACtxt thry => HOL cls thry HOLThm +defBOTTOM = cacheProof "defBOTTOM" ctxtIndTypesA $ getDefinition "BOTTOM" + +defCONSTR :: IndTypesACtxt thry => HOL cls thry HOLThm +defCONSTR = cacheProof "defCONSTR" ctxtIndTypesA $ getDefinition "CONSTR" + +defFCONS :: IndTypesACtxt thry => HOL cls thry HOLThm +defFCONS = cacheProof "defFCONS" ctxtIndTypesA $ getRecursiveDefinition "FCONS" + +defFNIL :: IndTypesACtxt thry => HOL cls thry HOLThm +defFNIL = cacheProof "defFNIL" ctxtIndTypesA $ getDefinition "FNIL" + +rulesZRECSPACE :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +rulesZRECSPACE = cacheProof "rulesZRECSPACE" ctxtIndTypesA $ + do (th, _, _) <- indDefZRECSPACE + return th + +inductZRECSPACE :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +inductZRECSPACE = cacheProof "inductZRECSPACE" ctxtIndTypesA $ + do (_, th, _) <- indDefZRECSPACE + return th + +casesZRECSPACE :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +casesZRECSPACE = cacheProof "casesZRECSPACE" ctxtIndTypesA $ + do (_, _, th) <- indDefZRECSPACE + return th + +indDefZRECSPACE :: IndTypesACtxt thry => HOL cls thry (HOLThm, HOLThm, HOLThm) +indDefZRECSPACE = getInductiveDefinition "ZRECSPACE" + + +tyDefMkRecspace :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +tyDefMkRecspace = cacheProof "tyDefMkRecspace" ctxtIndTypesA $ + liftM fst tyDefRecspace + +tyDefDestRecspace :: (BasicConvs thry, IndTypesACtxt thry) + => HOL cls thry HOLThm +tyDefDestRecspace = cacheProof "tyDefDestRecspace" ctxtIndTypesA $ + liftM snd tyDefRecspace + +tyDefRecspace :: IndTypesACtxt thry => HOL cls thry (HOLThm, HOLThm) +tyDefRecspace = getBasicTypeDefinition "recspace" + +thmINJN_INJ :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +thmINJN_INJ = cacheProof "thmINJN_INJ" ctxtIndTypesA $ + do tm1 <- toHTm "n1:num" + tm2 <- toHTm "a:A" + prove "!n1 n2. (INJN n1 :num->A->bool = INJN n2) <=> (n1 = n2)" $ + _REPEAT tacGEN `_THEN` tacEQ `_THEN` tacDISCH `_THEN` + tacASM_REWRITE_NIL `_THEN` + _POP_ASSUM (\ th g -> do th' <- ruleREWRITE [defINJN] th + tacMP (ruleAP_THM th' tm1) g) `_THEN` + _DISCH_THEN (tacMP . flip ruleAP_THM tm2) `_THEN` tacREWRITE [thmBETA] + +thmINJA_INJ :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +thmINJA_INJ = cacheProof "thmINJA_INJ" ctxtIndTypesA $ + prove "!a1 a2. (INJA a1 = INJA a2) <=> (a1:A = a2)" $ + _REPEAT tacGEN `_THEN` tacREWRITE [defINJA, thmFUN_EQ] `_THEN` + tacEQ `_THENL` + [ _DISCH_THEN (tacMP . ruleSPEC "a1:A") `_THEN` tacREWRITE_NIL + , _DISCH_THEN tacSUBST1 `_THEN` tacREWRITE_NIL + ] + +thmINJF_INJ :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +thmINJF_INJ = cacheProof "thmINJF_INJ" ctxtIndTypesA $ + do tm1 <- toHTm "a:A" + tm2 <- toHTm "NUMPAIR n m" + prove "!f1 f2. (INJF f1 :num->A->bool = INJF f2) <=> (f1 = f2)" $ + _REPEAT tacGEN `_THEN` tacEQ `_THEN` tacDISCH `_THEN` + tacASM_REWRITE_NIL `_THEN` tacREWRITE [thmFUN_EQ] `_THEN` + _MAP_EVERY tacX_GEN ["n:num", "m:num", "a:A"] `_THEN` + _POP_ASSUM (tacMP . ruleREWRITE [defINJF]) `_THEN` + _DISCH_THEN (tacMP <#< flip ruleAP_THM tm1 <=< flip ruleAP_THM tm2) `_THEN` + tacREWRITE [specNUMPAIR_DEST] + +thmINJP_INJ :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +thmINJP_INJ = cacheProof "thmINJP_INJ" ctxtIndTypesA $ + do tm <- toHTm "NUMSUM b n" + prove [str| !(f1:num->A->bool) f1' f2 f2'. + (INJP f1 f2 = INJP f1' f2') <=> (f1 = f1') /\ (f2 = f2') |] $ + _REPEAT tacGEN `_THEN` tacEQ `_THEN` tacDISCH `_THEN` + tacASM_REWRITE_NIL `_THEN` tacONCE_REWRITE [thmFUN_EQ] `_THEN` + tacREWRITE [thmAND_FORALL] `_THEN` tacX_GEN "n:num" `_THEN` + _POP_ASSUM (tacMP . ruleREWRITE [defINJP]) `_THEN` + _DISCH_THEN (tacMP . ruleGEN "b:bool" . flip ruleAP_THM tm) `_THEN` + _DISCH_THEN (\ th -> tacMP (ruleSPEC "T" th) `_THEN` + tacMP (ruleSPEC "F" th)) `_THEN` + tacASM_SIMP [specNUMSUM_DEST, axETA] + +thmMK_REC_INJ :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +thmMK_REC_INJ = cacheProof "thmMK_REC_INJ" ctxtIndTypesA . + prove [str| !x y. (_mk_rec x :(A)recspace = _mk_rec y) ==> + (ZRECSPACE x /\ ZRECSPACE y ==> (x = y)) |] $ + _REPEAT tacGEN `_THEN` tacDISCH `_THEN` + tacREWRITE [tyDefDestRecspace] `_THEN` + _DISCH_THEN (\ th -> tacONCE_REWRITE [ruleGSYM th]) `_THEN` + tacASM_REWRITE_NIL + +thmDEST_REC_INJ :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +thmDEST_REC_INJ = cacheProof "thmDEST_REC_INJ" ctxtIndTypesA $ + do tm <- toHTm "_mk_rec:(num->A->bool)->(A)recspace" + prove "!x y. (_dest_rec x = _dest_rec y) <=> (x:(A)recspace = y)" $ + _REPEAT tacGEN `_THEN` tacEQ `_THEN` tacDISCH `_THEN` + tacASM_REWRITE_NIL `_THEN` _POP_ASSUM (tacMP . ruleAP_TERM tm) `_THEN` + tacREWRITE [tyDefMkRecspace] + +thmZCONSTR_ZBOT :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +thmZCONSTR_ZBOT = cacheProof "thmZCONSTR_ZBOT" ctxtIndTypesA . + prove "!c i r. ~(ZCONSTR c i r :num->A->bool = ZBOT)" $ + tacREWRITE [defZCONSTR, defZBOT, thmINJP_INJ, thmINJN_INJ, thmNOT_SUC] + +thmCONSTR_INJ :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +thmCONSTR_INJ = cacheProof "thmCONSTR_INJ" ctxtIndTypesA . + prove [str| !c1 i1 r1 c2 i2 r2. + (CONSTR c1 i1 r1 :(A)recspace = CONSTR c2 i2 r2) <=> + (c1 = c2) /\ (i1 = i2) /\ (r1 = r2) |] $ + _REPEAT tacGEN `_THEN` tacEQ `_THEN` tacDISCH `_THEN` + tacASM_REWRITE_NIL `_THEN` + _POP_ASSUM (tacMP . ruleREWRITE [defCONSTR]) `_THEN` + _DISCH_THEN (tacMP . ruleMATCH_MP thmMK_REC_INJ) `_THEN` + (\ g@(Goal _ w) -> + _SUBGOAL_THEN (funpowM 2 lHand w) tacASSUME g) `_THENL` + [ tacCONJ `_THEN` tacMATCH_MP (ruleCONJUNCT2 rulesZRECSPACE) `_THEN` + tacREWRITE [tyDefMkRecspace, tyDefDestRecspace] + , tacASM_REWRITE_NIL `_THEN` tacREWRITE [defZCONSTR] `_THEN` + tacREWRITE [thmINJP_INJ, thmINJN_INJ, thmINJF_INJ, thmINJA_INJ] `_THEN` + tacONCE_REWRITE [thmFUN_EQ] `_THEN` tacBETA `_THEN` + tacREWRITE [thmSUC_INJ, thmDEST_REC_INJ] + ] + +thmCONSTR_IND :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +thmCONSTR_IND = cacheProof "thmCONSTR_IND" ctxtIndTypesA . + prove [str| !P. P(BOTTOM) /\ + (!c i r. (!n. P(r n)) ==> P(CONSTR c i r)) ==> + !x:(A)recspace. P(x) |] $ + _REPEAT tacSTRIP `_THEN` + tacMP (ruleSPEC [str| \z:num->A->bool. ZRECSPACE(z) /\ P(_mk_rec z) |] + inductZRECSPACE) `_THEN` + tacBETA `_THEN` + tacASM_REWRITE [rulesZRECSPACE, ruleGSYM defBOTTOM] `_THEN` + (\ g@(Goal _ w) -> + _SUBGOAL_THEN (funpowM 2 lHand w) tacASSUME g) `_THENL` + [ _REPEAT tacGEN `_THEN` tacREWRITE [thmFORALL_AND] `_THEN` + _REPEAT tacSTRIP `_THENL` + [ tacMATCH_MP (ruleCONJUNCT2 rulesZRECSPACE) `_THEN` tacASM_REWRITE_NIL + , _FIRST_ASSUM (_ANTE_RES_THEN tacMP) `_THEN` + tacREWRITE [defCONSTR] `_THEN` + tacRULE_ASSUM (ruleREWRITE [tyDefDestRecspace]) `_THEN` + tacASM_SIMP [axETA] + ] + , tacASM_REWRITE_NIL `_THEN` + _DISCH_THEN (tacMP . ruleSPEC "_dest_rec (x:(A)recspace)") `_THEN` + tacREWRITE [tyDefMkRecspace] `_THEN` + tacREWRITE [ruleITAUT [str| (a ==> a /\ b) <=> (a ==> b) |]] `_THEN` + _DISCH_THEN tacMATCH_MP `_THEN` + tacREWRITE [tyDefMkRecspace, tyDefDestRecspace] + ] + +thmCONSTR_BOT :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +thmCONSTR_BOT = cacheProof "thmCONSTR_BOT" ctxtIndTypesA . + prove "!c i r. ~(CONSTR c i r :(A)recspace = BOTTOM)" $ + _REPEAT tacGEN `_THEN` tacREWRITE [defCONSTR, defBOTTOM] `_THEN` + _DISCH_THEN (tacMP . ruleMATCH_MP thmMK_REC_INJ) `_THEN` + tacREWRITE [thmZCONSTR_ZBOT, rulesZRECSPACE] `_THEN` + tacMATCH_MP (ruleCONJUNCT2 rulesZRECSPACE) `_THEN` + tacREWRITE [tyDefMkRecspace, tyDefDestRecspace] + +thmCONSTR_REC :: (BasicConvs thry, IndTypesACtxt thry) => HOL cls thry HOLThm +thmCONSTR_REC = cacheProof "thmCONSTR_REC" ctxtIndTypesA $ + prove [str| !Fn:num->A->(num->(A)recspace)->(num->B)->B. + ?f. (!c i r. f (CONSTR c i r) = + Fn c i r (\n. f (r n))) |] $ + _REPEAT tacSTRIP `_THEN` (tacMP . proveInductiveRelationsExist) + [str| (Z:(A)recspace->B->bool) BOTTOM b /\ + (!c i r y. (!n. Z (r n) (y n)) ==> + Z (CONSTR c i r) (Fn c i r y)) |] `_THEN` + _DISCH_THEN (_CHOOSE_THEN (_CONJUNCTS_THEN2 + tacSTRIP_ASSUME tacMP)) `_THEN` + _DISCH_THEN (_CONJUNCTS_THEN2 tacASSUME (tacASSUME . ruleGSYM)) `_THEN` + _SUBGOAL_THEN "!x. ?!y. (Z:(A)recspace->B->bool) x y" tacMP `_THENL` + [ (\ g@(Goal _ w) -> + tacMP (rulePART_MATCH rand thmCONSTR_IND w) g) `_THEN` + _DISCH_THEN tacMATCH_MP `_THEN` tacCONJ `_THEN` + _REPEAT tacGEN `_THENL` + [ _FIRST_ASSUM (\ t -> tacGEN_REWRITE convBINDER [ruleGSYM t])`_THEN` + tacREWRITE [ruleGSYM thmCONSTR_BOT, thmEXISTS_UNIQUE_REFL] + , _DISCH_THEN (tacMP . + ruleREWRITE [thmEXISTS_UNIQUE, thmFORALL_AND]) `_THEN` + _DISCH_THEN (_CONJUNCTS_THEN2 tacMP tacASSUME) `_THEN` + _DISCH_THEN (tacMP . ruleREWRITE [thmSKOLEM]) `_THEN` + _DISCH_THEN (_X_CHOOSE_THEN "y:num->B" tacASSUME) `_THEN` + tacREWRITE [thmEXISTS_UNIQUE] `_THEN` + _FIRST_ASSUM (\ th -> _CHANGED + (tacONCE_REWRITE [ruleGSYM th])) `_THEN` + tacCONJ `_THENL` + [ tacEXISTS + "(Fn:num->A->(num->(A)recspace)->(num->B)->B) c i r y" `_THEN` + tacREWRITE [ thmCONSTR_BOT, thmCONSTR_INJ + , ruleGSYM thmCONJ_ASSOC ] `_THEN` + tacREWRITE [thmUNWIND1, thmRIGHT_EXISTS_AND] `_THEN` + tacEXISTS "y:num->B" `_THEN` tacASM_REWRITE_NIL + , tacREWRITE [ thmCONSTR_BOT, thmCONSTR_INJ + , ruleGSYM thmCONJ_ASSOC ] `_THEN` + tacREWRITE [thmUNWIND1, thmRIGHT_EXISTS_AND] `_THEN` + _REPEAT tacSTRIP `_THEN` tacASM_REWRITE_NIL `_THEN` + _REPEAT tacAP_TERM `_THEN` tacONCE_REWRITE [thmFUN_EQ] `_THEN` + tacX_GEN "w:num" `_THEN` _FIRST_ASSUM tacMATCH_MP `_THEN` + tacEXISTS "w:num" `_THEN` tacASM_REWRITE_NIL + ] + ] + , tacREWRITE [thmUNIQUE_SKOLEM_ALT] `_THEN` + _DISCH_THEN (_X_CHOOSE_THEN "fn:(A)recspace->B" + (tacASSUME . ruleGSYM)) `_THEN` + tacEXISTS "fn:(A)recspace->B" `_THEN` tacASM_REWRITE_NIL `_THEN` + _REPEAT tacGEN `_THEN` _FIRST_ASSUM tacMATCH_MP `_THEN` + tacGEN `_THEN` + _FIRST_ASSUM (\ th -> tacGEN_REWRITE id [ruleGSYM th]) `_THEN` + tacREWRITE [thmBETA] + ] + +parseInductiveTypeSpecification :: Text -> + HOL cls thry [(HOLType, [(Text, [HOLType])])] +parseInductiveTypeSpecification s = + do ctxt <- prepHOLContext + case runHOLParser parser s ctxt of + Left _ -> fail "parseInductiveTypeSpecification" + Right res -> mapM toTys res + where parser :: MyParser thry [(Text, [(Text, [PreType])])] + parser = mywhiteSpace >> mysemiSep1 typeParser + + typeParser :: MyParser thry (Text, [(Text, [PreType])]) + typeParser = do x <- myidentifier + myreservedOp "=" + ptys <- subtypeParser `mysepBy1` myreservedOp "|" + return (x, ptys) + + subtypeParser :: MyParser thry (Text, [PreType]) + subtypeParser = do x <- myidentifier + ptys <- mymany ptype + return (x, ptys) + + toTys :: (Text, [(Text, [PreType])]) -> + HOL cls thry (HOLType, [(Text, [HOLType])]) + toTys (s', ptys) = + let ty = mkVarType s' in + do tys <- mapM (\ (x, y) -> do y' <- mapM tyElab y + return (x, y')) ptys + return (ty, tys) + +{- Basic version of defineTypeRaw. + Returns the induction and recursion theorems separately. + The parser isn't used. +-} +defineTypeRaw :: (BasicConvs thry, IndTypesACtxt thry) + => [(HOLType, [(Text, [HOLType])])] + -> HOL Theory thry (HOLThm, HOLThm) +defineTypeRaw def = + do (defs, rth, ith) <- justifyInductiveTypeModel def + neths <- proveModelInhabitation rth + tybijpairs <- mapM (defineInductiveType defs) neths + let preds = fromJust $ mapM (repeatM rator . concl) neths + mkdests = fromJust $ mapM (\ (th, _) -> do tm <- lHand $ concl th + tm' <- rand tm + pairMapM rator (tm, tm')) + tybijpairs + consindex = zip preds mkdests + condefs <- mapM (defineInductiveTypeConstructor defs consindex) =<< + ruleCONJUNCTS rth + conthms <- mapM (\ th -> let args = fst . stripAbs . fromJust . rand $ + concl th in + ruleRIGHT_BETAS args th) condefs + iith <- instantiateInductionTheorem consindex ith + fth <- deriveInductionTheorem consindex tybijpairs conthms iith rth + rath <- createRecursiveFunctions tybijpairs consindex conthms rth + kth <- deriveRecursionTheorem tybijpairs consindex conthms rath + return (fth, kth) + +sucivate :: Int -> HOL cls thry HOLTerm +sucivate n = + do zero <- toHTm "0" + suc <- toHTm "SUC" + liftEither "sucivate" $ funpowM n (mkComb suc) zero + +ruleSCRUB_EQUATION :: BoolCtxt thry => HOLTerm -> (HOLThm, HOLTermEnv) + -> HOL cls thry (HOLThm, HOLTermEnv) +ruleSCRUB_EQUATION eq (th, insts) = + do eq' <- liftO $ foldrM subst eq (map (: []) insts) + let (l, r) = fromJust $ destEq eq' + th' <- ruleDISCH eq' th + th'' <- flip ruleMP (primREFL r) #<< primINST [(l, r)] th' + return (th'', (l, r):insts) + +justifyInductiveTypeModel :: (BasicConvs thry, WFCtxt thry) + => [(HOLType, [(Text, [HOLType])])] + -> HOL cls thry ([HOLThm], HOLThm, HOLThm) +justifyInductiveTypeModel def = + do tTm <- serve [wF| T |] + nTm <- serve [wF| n:num |] + bepsTm <- serve [wF| @x:bool. T |] + let (newtys, rights) = unzip def + tyargls = foldr ((++) . map snd) [] rights + alltys = foldr (munion . flip (\\) newtys) [] tyargls + epstms <- mapM (\ ty -> mkSelect (mkVar "v" ty) tTm) alltys + pty <- foldr1M (\ ty1 ty2 -> mkType "prod" [ty1, ty2]) alltys <|> + return tyBool + recty <- mkType "recspace" [pty] + constr <- mkConst "CONSTR" [(tyA, pty)] + fcons <- mkConst "FCONS" [(tyA, recty)] + bot <- mkConst "BOTTOM" [(tyA, pty)] + let bottail = fromRight $ mkAbs nTm bot + -- + mkConstructor :: Int -> (Text, [HOLType]) -> HOL cls thry HOLTerm + mkConstructor n (cname, cargs) = + let ttys = map (\ ty -> if ty `elem` newtys + then recty else ty) cargs + args = mkArgs "a" [] ttys + (rargs, iargs) = partition (\ t -> typeOf t == recty) args + -- + mkInjector :: [HOLTerm] -> [HOLType] -> [HOLTerm] + -> Maybe [HOLTerm] + mkInjector _ [] _ = return [] + mkInjector (tm:tms) (ty:tys) is = + (do (a, iargs') <- remove (\ t -> typeOf t == ty) is + tl <- mkInjector tms tys iargs' + return (a:tl)) + <|> (do tl <- mkInjector tms tys is + return (tm:tl)) + mkInjector _ _ _ = Nothing in + -- + do iarg <- (foldr1M mkPair #<< mkInjector epstms alltys iargs) <|> + return bepsTm + let rarg = fromRight $ foldrM (mkBinop fcons) bottail rargs + conty <- foldrM mkFunTy recty $ map typeOf args + n' <- sucivate n + let condef = fromRight $ listMkComb constr [n', iarg, rarg] + mkEq (mkVar cname conty) #<< listMkAbs args condef + -- + mkConstructors :: Int -> [(Text, [HOLType])] + -> HOL cls thry [HOLTerm] + mkConstructors _ [] = return [] + mkConstructors n (x:xs) = + do hd <- mkConstructor n x + tl <- mkConstructors (n + 1) xs + return (hd:tl) + -- + condefs <- mkConstructors 0 $ concat rights + let conths = fromRight $ mapM primASSUME condefs + predty <- mkFunTy recty tyBool + let edefs = foldr (\ (x, l) acc -> map (\ t -> (x, t)) l ++ acc) [] def + idefs = fromJust $ map2 (\ (r, (_, atys)) d -> + ((r, atys), d)) edefs condefs + -- + mkRule :: ((HOLType, [HOLType]), HOLTerm) + -> HOL cls thry HOLTerm + mkRule ((r, a), condef) = + let (left, right) = fromJust $ destEq condef + (args, _) = stripAbs right + (conc, conds) = fromRight $ + do lapp <- listMkComb left args + conds' <- foldr2M (\ arg argty sofar -> + if argty `elem` newtys + then do ty' <- note "" $ destVarType argty + arg' <- mkComb (mkVar ty' predty) arg + return (arg':sofar) + else return sofar) [] args a + ty' <- note "" $ destVarType r + conc' <- mkComb (mkVar ty' predty) lapp + return (conc', conds') in + do rule <- if null conds then return conc + else flip mkImp conc =<< listMkConj conds + listMkForall args rule + -- + rules <- listMkConj =<< mapM mkRule idefs + th0 <- deriveNonschematicInductiveRelations rules + th1 <- proveMonotonicityHyps th0 + (th2a, th2bc) <- ruleCONJ_PAIR th1 + th2b <- ruleCONJUNCT1 th2bc + return (conths, th2a, th2b) + where munion :: Eq a => [a] -> [a] -> [a] + munion s1 = fromJust . munion' s1 + + munion' :: Eq a => [a] -> [a] -> Maybe [a] + munion' [] s2 = Just s2 + munion' (h1:s1') s2 = + (do (_, s2') <- remove (== h1) s2 + tl <- munion' s1' s2' + return (h1:tl)) + <|> do tl <- munion' s1' s2 + return (h1:tl) + +proveModelInhabitation :: BoolCtxt thry => HOLThm -> HOL cls thry [HOLThm] +proveModelInhabitation rth = + do srules <- mapM ruleSPEC_ALL =<< ruleCONJUNCTS rth + let (imps, bases) = partition (isImp . concl) srules + concs = map concl bases ++ map (fromJust . rand . concl) imps + preds = setify . fromJust $ mapM (repeatM rator) concs + ithms <- exhaustInhabitations imps bases + liftO $ mapM (\ p -> find + (\ th -> (fst . stripComb $ concl th) == p) ithms) preds + + where exhaustInhabitations :: BoolCtxt thry => [HOLThm] -> [HOLThm] + -> HOL cls thry [HOLThm] + exhaustInhabitations ths sofar = + let dunnit = setify $ map (fst . stripComb . concl) sofar + useful = filter (\ (Thm _ c) -> + (fst . stripComb . fromJust $ rand c) + `notElem` dunnit) ths in + if null useful then return sofar + else do newth <- tryFind followHorn useful + exhaustInhabitations ths (newth:sofar) + where followHorn :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm + followHorn thm@(Thm _ c) = + let preds = map (fst . stripComb) . conjuncts . fromJust $ + lHand c + asms = fromJust $ mapM (\ p -> find + (\ (Thm _ c') -> fst (stripComb c') == p) + sofar) preds in + ruleMATCH_MP thm =<< foldr1M ruleCONJ asms + followHorn _ = error "followHorn: exhaustive warning." + +defineInductiveType :: BoolCtxt thry => [HOLThm] -> HOLThm + -> HOL Theory thry (HOLThm, HOLThm) +defineInductiveType cdefs exth@(Thm asl extm) = + let (epred@(Var ename _), _) = stripComb extm + th1@(Thm _ c1) = fromRight $ primASSUME #<< + find (\ eq -> lHand eq == Just epred) asl in + do th1' <- runConv (convSUBS cdefs) #<< rand c1 + let th2 = fromRight $ primTRANS th1 th1' + th2' = fromRight $ ruleAP_THM th2 #<< rand extm + th3@(Thm asl3 _) = fromRight $ primEQ_MP th2' exth + (th4, _) <- foldrM ruleSCRUB_EQUATION (th3, []) asl3 + let mkname = "_mk_" `append` ename + destname = "_dest_" `append` ename + (bij1, bij2@(Thm _ bc)) <- newBasicTypeDefinition ename mkname destname + th4 + let bij2a = fromRight $ ruleAP_THM th2 #<< rand =<< rand bc + bij2b = fromRight $ primTRANS bij2a bij2 + return (bij1, bij2b) +defineInductiveType _ _ = error "defineInductiveType: exhaustive warning." + +defineInductiveTypeConstructor :: (BasicConvs thry, PairCtxt thry) => [HOLThm] + -> [(HOLTerm, (HOLTerm, HOLTerm))] + -> HOLThm -> HOL Theory thry HOLThm +defineInductiveTypeConstructor defs consindex (Thm _ c) = + let (_, bod) = stripForall c + (defrt, expth, deflf@(Var name _)) = fromJust $ + do asms <- if isImp bod then liftM conjuncts $ lHand bod + else return [] + conc <- if isImp bod then rand bod else return bod + asmlist <- mapM destComb asms + (cpred, cterm) <- destComb conc + let (oldcon, oldargs) = stripComb cterm + (newrights, newargs) <- mapAndUnzipM (modifyArg asmlist) oldargs + (retmk, _) <- cpred `lookup` consindex + defbod <- hush $ mkComb retmk =<< listMkComb oldcon newrights + defrt' <- hush $ listMkAbs newargs defbod + expth' <- find (\ (Thm _ c') -> lHand c' == Just oldcon) defs + deflf' <- liftM (\ (x, _) -> mkVar x $ typeOf defrt') $ + destVar oldcon + return (defrt', expth', deflf') in + do rexpth <- runConv (convSUBS [expth]) defrt + defth <- newDefinition name =<< mkEq deflf #<< rand (concl rexpth) + liftO $ primTRANS defth =<< ruleSYM rexpth + where modifyArg :: HOLTermEnv -> HOLTerm -> Maybe (HOLTerm, HOLTerm) + modifyArg asmlist v = + (do (_, dest) <- liftM1 lookup (v `revLookup` asmlist) consindex + ty' <- liftM (head . snd) . destType $ typeOf dest + v' <- liftM (\ (x, _) -> mkVar x ty') $ destVar v + v'' <- hush $ mkComb dest v' + return (v'', v')) + <|> return (v, v) +defineInductiveTypeConstructor _ _ _ = + error "defineInductiveTypeConstructor: exhaustive warning." + +instantiateInductionTheorem :: BoolCtxt thry => [(HOLTerm, (HOLTerm, HOLTerm))] + -> HOLThm -> HOL cls thry HOLThm +instantiateInductionTheorem consindex ith@(Thm _ c) = + let (avs, bod) = stripForall c + (consindex', recty, newtys) = fromJust $ + do corlist <- mapM ((repeatM rator `ffCombM` repeatM rator) <=< + destImp <=< body <=< rand) =<< + liftM conjuncts (rand bod) + consindex'' <- mapM (\ v -> do w <- v `revLookup` corlist + r' <- w `lookup` consindex + return (w, r')) avs + recty' <- liftM (head . snd) . destType . typeOf . fst . snd $ + head consindex + newtys' <- mapM (liftM (head . snd) . destType . typeOf . snd . snd) + consindex'' + return (consindex'', recty', newtys') in + do ptypes <- mapM (`mkFunTy` tyBool) newtys + let preds = mkArgs "P" [] ptypes + args = mkArgs "x" [] $ map (const recty) preds + lambs <- map2M (\ (r, (m, _)) (p, a) -> + let l = fromRight $ mkComb r a in + do cnj <- mkConj l #<< mkComb p =<< mkComb m a + liftO $ mkAbs a cnj) consindex' $ zip preds args + ruleSPECL lambs ith +instantiateInductionTheorem _ _ = + error "instantiateInductionTheorem: exhaustive warning." + +pullbackInductionClause :: BoolCtxt thry => [(HOLThm, HOLThm)] -> [HOLThm] + -> HOLThm -> HOLTerm -> HOL cls thry HOLThm +pullbackInductionClause tybijpairs conthms rthm tm = + let (avs, bimp) = stripForall tm in + case bimp of + (ant :==> con) -> + do ths <- mapM (ruleCONV convBETA) =<< ruleCONJUNCTS #<< + primASSUME ant + (tths, pths) <- mapAndUnzipM ruleCONJ_PAIR ths + tth <- liftM1 ruleMATCH_MP (ruleSPEC_ALL rthm) =<< + foldr1M ruleCONJ tths + mths <- mapM ruleIP (tth:tths) + conth1 <- runConv convBETA con + let contm1 = fromJust . rand $ concl conth1 + cth2 <- runConv (convSUBS (tail mths)) #<< rand contm1 + let conth2 = fromRight $ primTRANS conth1 =<< + flip ruleAP_TERM cth2 #<< rator contm1 + conth3 <- rulePRE conth2 + let lctms = map concl pths + asmin <- liftM1 mkImp (listMkConj lctms) #<< rand =<< + rand (concl conth3) + let argsin = fromJust $ mapM rand =<< + liftM conjuncts (lHand asmin) + argsgen = map (\ x -> + mkVar (fst . fromJust $ destVar =<< rand x) $ + typeOf x) argsin + asmgen <- liftO $ subst (zip argsin argsgen) asmin + asmquant <- flip listMkForall asmgen #<< + liftM (snd . stripComb) (rand =<< rand asmgen) + th0 <- ruleSPEC_ALL #<< primASSUME asmquant + let th1 = fromJust $ primINST (zip argsgen argsin) th0 + th2 <- ruleMP th1 =<< foldr1M ruleCONJ pths + th2' <- ruleCONJ tth th2 + let th3 = fromRight $ liftM1 primEQ_MP (ruleSYM conth3) th2' + ruleDISCH asmquant =<< ruleGENL avs =<< ruleDISCH ant th3 + con -> + do conth2 <- runConv convBETA con + tth <- rulePART_MATCH return rthm #<< + lHand =<< rand (concl conth2) + conth3 <- rulePRE conth2 + let asmgen = fromJust $ rand =<< rand (concl conth3) + asmquant <- flip listMkForall asmgen #<< + liftM (snd . stripComb) (rand asmgen) + th2 <- ruleSPEC_ALL #<< primASSUME asmquant + th2' <- ruleCONJ tth th2 + let th3 = fromRight $ liftM1 primEQ_MP (ruleSYM conth3) th2' + ruleDISCH asmquant =<< ruleGENL avs th3 + where rulePRE :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm + rulePRE thm = let thms = fromRight $ mapM ruleSYM conthms in + ruleGEN_REWRITE (funpow 3 convRAND) thms thm + + ruleIP :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm + ruleIP thm = do thm' <- ruleGEN_REWRITE id (map snd tybijpairs) thm + liftO $ ruleSYM thm' + +finishInductionConclusion :: BoolCtxt thry => [(HOLTerm, (HOLTerm, HOLTerm))] + -> [(HOLThm, HOLThm)] -> HOLThm -> HOL cls thry HOLThm +finishInductionConclusion consindex tybijpairs th@(Thm _ c) = + let (v', dv) = fromJust $ + do (_, bimp) <- destForall c + pv <- lHand =<< body =<< rator =<< rand bimp + (p, v) <- destComb pv + (_, dest) <- p `lookup` consindex + ty <- liftM (head . snd) . destType $ typeOf dest + v'' <- liftM (\ (x, _) -> mkVar x ty) $ destVar v + dv' <- hush $ mkComb dest v'' + return (v'', dv') in + do th1 <- rulePRE =<< ruleSPEC dv th + th2 <- ruleMP th1 #<< liftM primREFL (rand =<< lHand (concl th1)) + th3 <- ruleCONV convBETA th2 + ruleGEN v' =<< ruleFIN =<< ruleCONJUNCT2 th3 + where rulePRE :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm + rulePRE = let (tybij1, tybij2) = unzip tybijpairs in + ruleGEN_REWRITE (convLAND . convLAND . convRAND) tybij1 <=< + ruleGEN_REWRITE convLAND tybij2 + + ruleFIN :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm + ruleFIN = let (tybij1, _) = unzip tybijpairs in + ruleGEN_REWRITE convRAND tybij1 +finishInductionConclusion _ _ _ = + error "finishInductionConclusion: exhaustive warning." + +deriveInductionTheorem :: BoolCtxt thry => [(HOLTerm, (HOLTerm, HOLTerm))] + -> [(HOLThm, HOLThm)] -> [HOLThm] -> HOLThm -> HOLThm + -> HOL cls thry HOLThm +deriveInductionTheorem consindex tybijpairs conthms iith rth = + do bths <- liftM1 (map2M (pullbackInductionClause tybijpairs conthms)) + (ruleCONJUNCTS rth) #<< liftM conjuncts (lHand $ concl iith) + asm <- listMkConj #<< mapM (lHand . concl) bths + ths <- map2M ruleMP bths =<< ruleCONJUNCTS #<< primASSUME asm + th1 <- ruleMP iith =<< foldr1M ruleCONJ ths + th2 <- foldr1M ruleCONJ =<< + mapM (finishInductionConclusion consindex tybijpairs) =<< + ruleCONJUNCTS th1 + th3 <- ruleDISCH asm th2 + let preds = fromJust $ mapM (rator <=< body <=< rand) =<< + liftM conjuncts (rand $ concl th3) + th4 <- ruleGENL preds th3 + let pasms = filter (flip elem (map fst consindex) . fromJust . lHand) $ + hyp th4 + th5 <- foldrM ruleDISCH th4 pasms + (th6, _) <- foldrM ruleSCRUB_EQUATION (th5, []) $ hyp th5 + th7 <- ruleUNDISCH_ALL th6 + liftM fst . foldrM ruleSCRUB_EQUATION (th7, []) $ hyp th7 + +createRecursiveFunctions :: BoolCtxt thry => [(HOLThm, HOLThm)] + -> [(HOLTerm, (HOLTerm, HOLTerm))] -> [HOLThm] + -> HOLThm -> HOL cls thry HOLThm +createRecursiveFunctions tybijpairs consindex conthms rth = + let domtys = map (head . snd . fromJust . destType . typeOf . snd . snd) + consindex + recty = (head . snd . fromJust . destType . typeOf . fst . snd . head) + consindex + ranty = mkVarType "Z" in + do fn <- liftM (mkVar "fn") $ mkFunTy recty ranty + fns <- liftM (mkArgs "fn" []) $ mapM (`mkFunTy` ranty) domtys + let args = mkArgs "a" [] domtys + rights = fromRight $ + map2M (\ (_, (_, d)) a -> mkAbs a =<< + mkComb fn =<< mkComb d a) consindex args + eqs <- map2M mkEq fns rights + let fdefs = fromRight $ mapM primASSUME eqs + fxths1 = fromRight $ + mapM (\ th1 -> tryFind + (`primMK_COMB` th1) fdefs) conthms + fxths2 <- mapM (\ th -> do th' <- runConv convBETA #<< rand (concl th) + liftO $ primTRANS th th') fxths1 + fxths3 <- liftM1 (map2M simplifyFxthm) (ruleCONJUNCTS rth) fxths2 + let fxths4 = fromRight $ + map2M (\ th1 -> primTRANS th1 <=< ruleAP_TERM fn) fxths2 + fxths3 + fxth5 <- foldr1M ruleCONJ =<< map2M (cleanupFxthm fn) conthms fxths4 + let pasms = filter (flip elem (map fst consindex) . fromJust . lHand) $ + hyp fxth5 + fxth6 <- foldrM ruleDISCH fxth5 pasms + (fxth7, _) <- foldrM ruleSCRUB_EQUATION (fxth6, []) $ + foldr (union . hyp) [] conthms + fxth8 <- ruleUNDISCH_ALL fxth7 + (fxth9, _) <- foldrM ruleSCRUB_EQUATION (fxth8, []) (hyp fxth8 \\ eqs) + return fxth9 + + where mkTybijcons :: (HOLThm, HOLThm) -> Either String HOLThm + mkTybijcons (th1, th2) = + do tms <- note "" $ pairMapM (rand <=< lHand . concl) (th2, th1) + th3 <- note "" $ primINST [tms] th2 + th4 <- flip ruleAP_TERM th1 #<< rator =<< lHand =<< + rand (concl th2) + liftM1 primEQ_MP (ruleSYM th3) th4 + + convS :: BoolCtxt thry => Conversion cls thry + convS = convGEN_REWRITE id (fromRight $ mapM mkTybijcons tybijpairs) + + ruleE :: BoolCtxt thry => HOLThm -> HOL cls thry HOLThm + ruleE = ruleGEN_REWRITE id (map snd tybijpairs) + + simplifyFxthm :: BoolCtxt thry => HOLThm -> HOLThm + -> HOL cls thry HOLThm + simplifyFxthm rthm fxth = + let pat = fromJust . funpowM 4 rand $ concl fxth + rtm = fromJust . repeatM (liftM snd . destForall)$ concl rthm in + if isImp rtm + then do th1 <- rulePART_MATCH (rand <=< rand) rthm pat + let tms1 = conjuncts . fromJust . lHand $ concl th1 + ths2 <- mapM (\ t -> do tth <- thmTRUTH + th <- runConv convS t + liftO $ liftM1 primEQ_MP + (ruleSYM th) tth) tms1 + ruleE =<< ruleMP th1 =<< foldr1M ruleCONJ ths2 + else ruleE =<< rulePART_MATCH rand rthm pat + + cleanupFxthm :: HOLTerm -> HOLThm -> HOLThm -> HOL cls thry HOLThm + cleanupFxthm fn cth fxth = + let tms = snd . stripComb . fromJust $ rand =<< rand (concl fxth) in + do kth <- ruleRIGHT_BETAS tms #<< primASSUME (head $ hyp cth) + liftO $ primTRANS fxth =<< ruleAP_TERM fn kth + +createRecursionIsoConstructor :: (BasicConvs thry, WFCtxt thry) + => [(HOLTerm, (HOLTerm, HOLTerm))] -> HOLThm + -> HOL cls thry HOLTerm +createRecursionIsoConstructor consindex cth = + do s <- serve [wF| s:num->Z |] + let zty = mkVarType "Z" + numty <- mkType "num" [] + let recty = head . snd . fromJust . destType . typeOf . fst $ + head consindex + domty = head . snd . fromJust $ destType recty + i = mkVar"i" domty + r <- liftM (mkVar "r") $ mkFunTy numty recty + let mks = map (fst . snd) consindex + mkindex = map (\ t -> (head . tail . snd . fromJust . destType $ + typeOf t, t)) mks + artms = snd . stripComb . fromJust $ rand =<< rand (concl cth) + artys = mapFilter (liftM typeOf . rand) artms + (args, bod) = stripAbs . fromJust . rand . head $ hyp cth + (ccitm, rtm) = fromJust $ destComb bod + (_, itm) = fromJust $ destComb ccitm + (rargs, iargs) = partition (`freeIn` rtm) args + xths <- mapM (extractArg itm) iargs + cargs' <- liftO $ mapM (subst [(itm, i)] <=< lHand . concl) xths + indices <- mapM sucivate [0..(length rargs - 1)] + let rindexed = fromRight $ mapM (mkComb r) indices + rargs' = fromRight $ map2M (\ a rx -> flip mkComb rx #<< + (a `lookup` mkindex)) artys rindexed + sargs' = fromRight $ mapM (mkComb s) indices + allargs = cargs' ++ rargs' ++ sargs' + funty <- foldrM (mkFunTy . typeOf) zty allargs + let funname = fst . fromJust $ destConst =<< repeatM rator =<< + lHand (concl cth) + funarg = mkVar (funname `snoc` '\'') funty + liftO $ listMkAbs [i, r, s] =<< listMkComb funarg allargs + where extractArg :: (BasicConvs thry, PairCtxt thry) => HOLTerm -> HOLTerm + -> HOL cls thry HOLThm + extractArg tup v + | v == tup = return $ primREFL tup + | otherwise = + let (t1, t2) = fromJust $ destPair tup in + do thPAIR <- ruleISPECL [t1, t2] $ if v `freeIn` t1 + then thmFST + else thmSND + let tup' = fromJust . rand $ concl thPAIR + if tup' == v + then return thPAIR + else do th <- extractArg tup' v + ruleSUBS [ruleSYM thPAIR] th + +deriveRecursionTheorem :: (BasicConvs thry, IndTypesACtxt thry) + => [(HOLThm, HOLThm)] + -> [(HOLTerm, (HOLTerm, HOLTerm))] -> [HOLThm] + -> HOLThm -> HOL cls thry HOLThm +deriveRecursionTheorem tybijpairs consindex conthms rath = + do isocons <- mapM (createRecursionIsoConstructor consindex) conthms + let ty = typeOf $ head isocons + fcons <- mkConst "FCONS" [(tyA, ty)] + fnil <- mkConst "FNIL" [(tyA, ty)] + let bigfun = fromRight $ foldrM (mkBinop fcons) fnil isocons + eth <- ruleISPEC bigfun thmCONSTR_REC + let fn = fromJust $ rator =<< rand (head . conjuncts $ concl rath) + betm = fromJust $ + do (v, bod) <- destAbs =<< rand (concl eth) + varSubst [(v, fn)] bod + fnths <- mapM (\ t -> ruleRIGHT_BETAS [fromJust $ bndvar =<< rand t] #<< + primASSUME t) $ hyp rath + rthm <- foldr1M ruleCONJ =<< mapM (hackdownRath betm fnths) =<< + ruleCONJUNCTS rath + let seqs = fromJust $ + let unseqs = filter isEq $ hyp rthm in + do tys <- mapM (liftM (head . snd) . destType . typeOf . + snd . snd) consindex + mapM (\ x -> findM + (\ t -> do t' <- lHand t + ty' <- liftM (head . snd) . destType $ + typeOf t' + return $! ty' == x) unseqs) tys + rethm <- foldrM ruleEXISTS_EQUATION rthm seqs + fethm <- ruleCHOOSE fn eth rethm + let pcons = fromJust . mapM (repeatM rator <=< rand <=< + repeatM (liftM snd . destForall)) . + conjuncts $ concl rthm + ruleGENL pcons fethm + where convC :: IndTypesACtxt thry => Conversion cls thry + convC = funpow 3 convRATOR . _REPEAT $ convGEN_REWRITE id [defFCONS] + + convL :: BoolCtxt thry => HOLTerm -> Conversion cls thry + convL betm = convREWR (primASSUME betm) + + ruleSIMPER :: (BasicConvs thry, IndTypesACtxt thry) => [HOLThm] + -> HOLThm -> HOL cls thry HOLThm + ruleSIMPER fnths th = + let ths1 = fromRight $ mapM ruleSYM fnths + ths2 = map fst tybijpairs in + do ths3 <- sequence [thmFST, thmSND, defFCONS, thmBETA] + rulePURE_REWRITE (ths1++ths2++ths3) th + + hackdownRath :: (BasicConvs thry, IndTypesACtxt thry) => HOLTerm + -> [HOLThm] -> HOLThm + -> HOL cls thry HOLThm + hackdownRath betm fnths th = + let (ltm, rtm) = fromJust . destEq $ concl th + wargs = snd . stripComb . fromJust $ rand ltm in + do th0 <- runConv (convL betm) rtm + let th1 = fromRight $ primTRANS th th0 + th1' <- runConv convC #<< rand (concl th1) + let th2 = fromRight $ primTRANS th1 th1' + th2' <- runConv (funpow 2 convRATOR convBETA) #<< + rand (concl th2) + let th3 = fromRight $ primTRANS th2 th2' + th3' <- runConv (convRATOR convBETA) #<< rand (concl th3) + let th4 = fromRight $ primTRANS th3 th3' + th4' <- runConv convBETA #<< rand (concl th4) + let th5 = fromRight $ primTRANS th4 th4' + ruleGENL wargs =<< ruleSIMPER fnths th5 diff --git a/src/HaskHOL/Lib/IndTypes/Base.hs b/src/HaskHOL/Lib/IndTypes/Base.hs new file mode 100644 index 0000000..c84995a --- /dev/null +++ b/src/HaskHOL/Lib/IndTypes/Base.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, PatternSynonyms, QuasiQuotes, + ScopedTypeVariables, TemplateHaskell, TypeFamilies #-} +module HaskHOL.Lib.IndTypes.Base where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (getDefinition, newDefinition) + +import HaskHOL.Lib.Pair + +import HaskHOL.Lib.IndTypes.B +import HaskHOL.Lib.IndTypes.Pre + +import System.IO.Unsafe (unsafePerformIO) +import Data.IORef + +--evnote: need list for distintness and injectivity stores because of dupe keys +{-# NOINLINE rectypeNet #-} +rectypeNet :: HOLRef (Maybe (Net (GConversion cls thry))) +rectypeNet = unsafePerformIO $ newIORef Nothing + +data InductiveTypes = + InductiveTypes !(Map Text (HOLThm, HOLThm)) deriving Typeable + +putInductiveTypes :: Map Text (HOLThm, HOLThm) -> Update InductiveTypes () +putInductiveTypes m = + put (InductiveTypes m) + +getInductiveTypes :: Query InductiveTypes (Map Text (HOLThm, HOLThm)) +getInductiveTypes = + do (InductiveTypes m) <- ask + return m + +addInductiveType :: Text -> (HOLThm, HOLThm) -> Update InductiveTypes () +addInductiveType s ths = + do (InductiveTypes m) <- get + put (InductiveTypes (mapInsert s ths m)) + +getInductiveType :: Text -> Query InductiveTypes (Maybe (HOLThm, HOLThm)) +getInductiveType s = + do (InductiveTypes m) <- ask + return $! mapLookup s m + +deriveSafeCopy 0 'base ''InductiveTypes + +makeAcidic ''InductiveTypes + ['putInductiveTypes, 'getInductiveTypes, 'addInductiveType, 'getInductiveType] + +data DistinctnessStore = + DistinctnessStore ![(Text, HOLThm)] deriving Typeable + +deriveSafeCopy 0 'base ''DistinctnessStore + +getDistinctnessStore :: Query DistinctnessStore [(Text, HOLThm)] +getDistinctnessStore = + do (DistinctnessStore m) <- ask + return m + +addDistinctnessStore :: Text -> [HOLThm] -> Update DistinctnessStore () +addDistinctnessStore tyname ths = + do (DistinctnessStore m) <- get + put (DistinctnessStore (map (\ x -> (tyname, x)) ths ++ m)) + +putDistinctnessStore :: [(Text, HOLThm)] -> Update DistinctnessStore () +putDistinctnessStore m = + put (DistinctnessStore m) + +makeAcidic ''DistinctnessStore + ['getDistinctnessStore, 'addDistinctnessStore, 'putDistinctnessStore] + +data InjectivityStore = InjectivityStore ![(Text, HOLThm)] deriving Typeable + +deriveSafeCopy 0 'base ''InjectivityStore + +getInjectivityStore :: Query InjectivityStore [(Text, HOLThm)] +getInjectivityStore = + do (InjectivityStore m) <- ask + return m + +addInjectivityStore :: Text -> [HOLThm] -> Update InjectivityStore () +addInjectivityStore tyname ths = + do (InjectivityStore m) <- get + put (InjectivityStore (map (\ x -> (tyname, x)) ths ++ m)) + +makeAcidic ''InjectivityStore ['getInjectivityStore, 'addInjectivityStore] + + +rehashRectypeNet :: forall cls thry. BoolCtxt thry => HOL cls thry () +rehashRectypeNet = + do acid1 <- openLocalStateHOL (DistinctnessStore []) + ths1 <- liftM (map snd) $ queryHOL acid1 GetDistinctnessStore + closeAcidStateHOL acid1 + acid2 <- openLocalStateHOL (InjectivityStore []) + ths2 <- liftM (map snd) $ queryHOL acid2 GetInjectivityStore + closeAcidStateHOL acid2 + canonThl <- foldrM (mkRewrites False) [] $ ths1 ++ ths2 + net' <- liftO $ foldrM (netOfThm True) (netEmpty :: Net (GConversion cls thry)) canonThl + writeHOLRef rectypeNet (Just net') + +extendRectypeNet :: (BasicConvs thry, IndTypesBCtxt thry) + => (Text, (Int, HOLThm, HOLThm)) + -> HOL Theory thry () +extendRectypeNet (tyname, (_, _, rth)) = + do ths1 <- liftM (: []) (proveConstructorsDistinct rth) <|> return [] + ths2 <- liftM (:[]) (proveConstructorsInjective rth) <|> return [] + acid1 <- openLocalStateHOL (DistinctnessStore []) + updateHOL acid1 (AddDistinctnessStore tyname ths1) + createCheckpointAndCloseHOL acid1 + acid2 <- openLocalStateHOL (InjectivityStore []) + updateHOL acid2 (AddInjectivityStore tyname ths2) + createCheckpointAndCloseHOL acid2 + rehashRectypeNet + +basicRectypeNet :: BoolCtxt thry => HOL cls thry (Net (GConversion cls thry)) +basicRectypeNet = + do net <- readHOLRef rectypeNet + case net of + Just net' -> return net' + Nothing -> do rehashRectypeNet + basicRectypeNet + + +indDefOption' :: (BasicConvs thry, IndTypesBCtxt thry) + => HOL Theory thry (HOLThm, HOLThm) +indDefOption' = defineTypeRaw =<< + parseInductiveTypeSpecification "option = NONE | SOME A" + +indDefList' :: (BasicConvs thry, IndTypesBCtxt thry) + => HOL Theory thry (HOLThm, HOLThm) +indDefList' = defineTypeRaw =<< + parseInductiveTypeSpecification "list = NIL | CONS A list" + +defISO' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defISO' = newDefinition "ISO" + [str| ISO (f:A->B) (g:B->A) <=> (!x. f(g x) = x) /\ (!y. g(f y) = y) |] + +convUNWIND :: TheoremsCtxt thry => Conversion cls thry +convUNWIND = Conv $ \ tm -> + let (evs, bod) = stripExists tm + eqs = conjuncts bod in + (do eq <- liftO $ find (\ x -> + case x of + (l := r) -> (l `elem` evs && not (l `freeIn` r)) || + (r `elem` evs && not (r `freeIn` l)) + _ -> False) eqs + (l, r) <- liftO $ destEq eq + let v = if l `elem` evs && not (l `freeIn` r) then l else r + cjs' = eq : (eqs \\ [eq]) + n = length evs - (1 + fromJust (index v (reverse evs))) + th1 <- ruleCONJ_ACI =<< mkEq bod =<< listMkConj cjs' + th2 <- foldrM ruleMK_EXISTS th1 evs + th3 <- runConv (funpow n convBINDER (convPUSH_EXISTS baseconv)) #<< + rand (concl th2) + ruleCONV (convRAND convUNWIND) #<< primTRANS th2 th3) <|> + (return $! primREFL tm) + where baseconv ::TheoremsCtxt thry => Conversion cls thry + baseconv = + convGEN_REWRITE id + [ thmUNWIND1, thmUNWIND2 + , ruleEQT_INTRO =<< ruleSPEC_ALL thmEXISTS_REFL + , ruleEQT_INTRO =<< ruleGSYM (ruleSPEC_ALL thmEXISTS_REFL) + ] + +convINSIDE_EXISTS :: Conversion cls thry -> Conversion cls thry +convINSIDE_EXISTS conv = Conv $ \ tm -> + if isExists tm then runConv (convBINDER (convINSIDE_EXISTS conv)) tm + else runConv conv tm + +convPUSH_EXISTS :: TheoremsCtxt thry => Conversion cls thry + -> Conversion cls thry +convPUSH_EXISTS bc = Conv $ \ tm -> + runConv (convREWR thmSWAP_EXISTS `_THEN` convBINDER (convPUSH_EXISTS bc)) tm + <|> runConv bc tm + +convBREAK_CONS :: TheoremsCtxt thry => Conversion cls thry +convBREAK_CONS = Conv $ \ tm -> + do net <- basicRectypeNet + let conv0 = convTOP_SWEEP (convREWRITES net) + conv1 = if isConj tm then convLAND conv0 else conv0 + runConv (conv1 `_THEN` (convGEN_REWRITE convDEPTH + [ thmAND_CLAUSES, thmOR_CLAUSES ] `_THEN` + convASSOC thmCONJ_ASSOC)) tm + +convMATCH_SEQPATTERN_TRIV :: (BasicConvs thry, IndTypesBCtxt thry) + => Conversion cls thry +convMATCH_SEQPATTERN_TRIV = + convMATCH_SEQPATTERN `_THEN` convGEN_REWRITE id [thmCOND_CLAUSES] + +convMATCH_SEQPATTERN :: (BasicConvs thry, IndTypesBCtxt thry) + => Conversion cls thry +convMATCH_SEQPATTERN = + convGEN_REWRITE id [convUNWIND_pth1] `_THEN` + convRATOR (convLAND + (convBINDER (convRATOR convBETA `_THEN` convBETA) `_THEN` + convPUSH_EXISTS (convGEN_REWRITE id [convUNWIND_pth2] `_THEN` + convBREAK_CONS) `_THEN` + convUNWIND `_THEN` + convGEN_REWRITE convDEPTH [ ruleEQT_INTRO =<< ruleSPEC_ALL thmEQ_REFL + , thmAND_CLAUSES + ] `_THEN` + convGEN_REWRITE convDEPTH [thmEXISTS_SIMP])) + where convUNWIND_pth1 :: (BasicConvs thry, IndTypesBCtxt thry) + => HOL cls thry HOLThm + convUNWIND_pth1 = cacheProof "convUNWIND_pth1" ctxtIndTypesB $ prove + [str| _MATCH x (_SEQPATTERN r s) = + (if ?y. r x y then _MATCH x r else _MATCH x s) /\ + _FUNCTION (_SEQPATTERN r s) x = + (if ?y. r x y then _FUNCTION r x else _FUNCTION s x) |] $ + tacREWRITE [def_MATCH, def_SEQPATTERN, def_FUNCTION] `_THEN` + tacMESON_NIL + + convUNWIND_pth2 :: (BasicConvs thry, IndTypesBCtxt thry) + => HOL cls thry HOLThm + convUNWIND_pth2 = cacheProof "convUNWIND_pth2" ctxtIndTypesB $ prove + [str|((?y. _UNGUARDED_PATTERN (GEQ s t) (GEQ u y)) <=> s = t) /\ + ((?y. _GUARDED_PATTERN (GEQ s t) p (GEQ u y)) <=> s = t /\ p)|] $ + tacREWRITE [ def_UNGUARDED_PATTERN + , def_GUARDED_PATTERN, defGEQ ] `_THEN` + tacMESON_NIL + +convMATCH_ONEPATTERN_TRIV :: (BasicConvs thry, IndTypesBCtxt thry) + => Conversion cls thry +convMATCH_ONEPATTERN_TRIV = + convMATCH_ONEPATTERN `_THEN` convGEN_REWRITE id [convUNWIND_pth5] + where convUNWIND_pth5 :: (BasicConvs thry, IndTypesBCtxt thry) + => HOL cls thry HOLThm + convUNWIND_pth5 = cacheProof "convUNWIND_pth5" ctxtIndTypesB $ + prove "(if ?!z. z = k then @z. z = k else @x. F) = k" + tacMESON_NIL + +convMATCH_ONEPATTERN :: (BasicConvs thry, IndTypesBCtxt thry) + => Conversion cls thry +convMATCH_ONEPATTERN = Conv $ \ tm -> + do th1 <- runConv (convGEN_REWRITE id [convUNWIND_pth3]) tm + let tm' = fromJust $ body =<< rand =<< lHand =<< rand (concl th1) + th2 <- runConv (convINSIDE_EXISTS + (convGEN_REWRITE id [convUNWIND_pth4] `_THEN` + convRAND convBREAK_CONS) `_THEN` + convUNWIND `_THEN` + convGEN_REWRITE convDEPTH + [ ruleEQT_INTRO =<< ruleSPEC_ALL thmEQ_REFL + , thmAND_CLAUSES + ] `_THEN` + convGEN_REWRITE convDEPTH [thmEXISTS_SIMP]) tm' + let conv = Conv $ \ x -> if lHand (concl th2) == Just x + then return th2 + else fail "" + ruleCONV (convRAND + (convRATOR + (convCOMB2 (convRAND (convBINDER conv)) + (convBINDER conv)))) th1 + where convUNWIND_pth3 :: (BasicConvs thry, IndTypesBCtxt thry) + => HOL cls thry HOLThm + convUNWIND_pth3 = cacheProof "convUNWIND_pth3" ctxtIndTypesB $ prove + [str|(_MATCH x (\y z. P y z) = if ?!z. P x z then @z. P x z else @x. F) /\ + (_FUNCTION (\y z. P y z) x = if ?!z. P x z then @z. P x z else @x. F) |] $ + tacREWRITE [ def_MATCH, def_FUNCTION] + + convUNWIND_pth4 :: (BasicConvs thry, IndTypesBCtxt thry) + => HOL cls thry HOLThm + convUNWIND_pth4 = cacheProof "convUNWIND_pth4" ctxtIndTypesB $ prove + [str|(_UNGUARDED_PATTERN (GEQ s t) (GEQ u y) <=> y = u /\ s = t) /\ + (_GUARDED_PATTERN (GEQ s t) p (GEQ u y) <=> y = u /\ s = t /\ p) |] $ + tacREWRITE [ def_UNGUARDED_PATTERN + , def_GUARDED_PATTERN, defGEQ ] `_THEN` + tacMESON_NIL diff --git a/src/HaskHOL/Lib/IndTypes/Context.hs b/src/HaskHOL/Lib/IndTypes/Context.hs new file mode 100644 index 0000000..496378e --- /dev/null +++ b/src/HaskHOL/Lib/IndTypes/Context.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, QuasiQuotes, + TemplateHaskell, TypeFamilies, TypeSynonymInstances, + UndecidableInstances #-} +module HaskHOL.Lib.IndTypes.Context + ( IndTypesType + , IndTypesCtxt + , ctxtIndTypes + , indTypes + ) where + +import HaskHOL.Core +import HaskHOL.Deductive +import HaskHOL.Lib.Pair + +import HaskHOL.Lib.IndTypes.Pre +import HaskHOL.Lib.IndTypes.B.Context +import HaskHOL.Lib.IndTypes.Base + +import Unsafe.Coerce (unsafeCoerce) + +-- generate template types +extendTheory ctxtIndTypesB "IndTypes" $ + do (oindth, orecth) <- indDefOption' + (lindth, lrecth) <- indDefList' + addIndDefs [ ("option", (2, oindth, orecth)) + , ("list", (2, lindth, lrecth)) + ] + void defISO' + sindth <- inductSUM + srecth <- recursionSUM + acid1 <- openLocalStateHOL (InductiveTypes mapEmpty) + updateHOL acid1 (PutInductiveTypes $ mapFromList + [ ("list = NIL | CONS A list", (lindth, lrecth)) + , ("option = NONE | SOME A", (oindth, orecth)) + , ("sum = INL A | INR B", (sindth, srecth)) + ]) + createCheckpointAndCloseHOL acid1 + th <- ruleTAUT "(T <=> F) <=> F" + acid2 <- openLocalStateHOL (DistinctnessStore []) + updateHOL acid2 (PutDistinctnessStore [("bool", th)]) + createCheckpointAndCloseHOL acid2 + mapM_ extendRectypeNet =<< liftM mapToAscList getIndDefs + +templateProvers 'ctxtIndTypes + +-- have to manually write this, for now +type family IndTypesCtxt a where + IndTypesCtxt a = (IndTypesBCtxt a, IndTypesContext a ~ True) + +type instance PolyTheory IndTypesType b = IndTypesCtxt b + +instance BasicConvs IndTypesType where + basicConvs _ = basicConvs (undefined :: PairType) ++ + [ ("convMATCH_SEQPATTERN", + ("_MATCH x (_SEQPATTERN r s)", convMATCH_SEQPATTERN_TRIV')) + , ("convFUN_SEQPATTERN", + ("_FUNCTION (_SEQPATTERN r s) x", convMATCH_SEQPATTERN_TRIV')) + , ("convMATCH_ONEPATTERN", + ([str| _MATCH x (\y z. P y z) |], convMATCH_ONEPATTERN_TRIV')) + , ("convFUN_ONEPATTERN", + ([str| _FUNCTION (\y z. P y z) x |], convMATCH_ONEPATTERN_TRIV')) + ] + +convMATCH_SEQPATTERN_TRIV' :: Conversion cls thry +convMATCH_SEQPATTERN_TRIV' = + unsafeCoerce (convMATCH_SEQPATTERN_TRIV :: Conversion cls IndTypesType) + +convMATCH_ONEPATTERN_TRIV' :: Conversion cls thry +convMATCH_ONEPATTERN_TRIV' = + unsafeCoerce (convMATCH_ONEPATTERN_TRIV :: Conversion cls IndTypesType) diff --git a/src/HaskHOL/Lib/IndTypes/Pre.hs b/src/HaskHOL/Lib/IndTypes/Pre.hs new file mode 100644 index 0000000..751c481 --- /dev/null +++ b/src/HaskHOL/Lib/IndTypes/Pre.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE PatternSynonyms #-} +module HaskHOL.Lib.IndTypes.Pre where + +import HaskHOL.Core hiding (lefts) +import HaskHOL.Deductive + +import HaskHOL.Lib.Pair +import HaskHOL.Lib.Recursion +import HaskHOL.Lib.Nums +import HaskHOL.Lib.CalcNum + +import HaskHOL.Lib.IndTypes.B +import qualified HaskHOL.Lib.IndTypes.B.Pre as Pre + +defOUTL :: IndTypesBCtxt thry => HOL cls thry HOLThm +defOUTL = cacheProof "defOUTL" ctxtIndTypesB $ getRecursiveDefinition "OUTL" + +defOUTR :: IndTypesBCtxt thry => HOL cls thry HOLThm +defOUTR = cacheProof "defOUTR" ctxtIndTypesB $ getRecursiveDefinition "OUTR" + +indDefSum :: (BasicConvs thry, IndTypesBCtxt thry) + => HOL cls thry (HOLThm, HOLThm) +indDefSum = + do defs <- getIndDefs + let (_, th1, th2) = fromJust (mapLookup "sum" defs) + return (th1, th2) + +inductSUM :: (BasicConvs thry, IndTypesBCtxt thry) => HOL cls thry HOLThm +inductSUM = cacheProof "inductSUM" ctxtIndTypesB $ + liftM fst indDefSum + +recursionSUM :: (BasicConvs thry, IndTypesBCtxt thry) => HOL cls thry HOLThm +recursionSUM = cacheProof "recursionSUM" ctxtIndTypesB $ + liftM snd indDefSum + +defineTypeRaw :: (BasicConvs thry, IndTypesBCtxt thry) + => [(HOLType, [(Text, [HOLType])])] + -> HOL Theory thry (HOLThm, HOLThm) +defineTypeRaw def = + do (ith, rth) <- Pre.defineTypeRaw def + rth' <- generalizeRecursionTheorem rth + return (ith, rth') + +generalizeRecursionTheorem :: IndTypesBCtxt thry => HOLThm + -> HOL cls thry HOLThm +generalizeRecursionTheorem thm = + let (_, ebod) = stripForall $ concl thm + (evs, _) = stripExists ebod + n = length evs in + if n == 1 then return thm + else let tys = map (\ i -> mkVarType $ "Z" `append` textShow i) + [0..(n-1)] in + do sty <- mkSum tys + inls <- mkInls sty + outls <- mkOutls sty + let zty = typeOf . fromJust . rand . snd . stripForall . head $ + conjuncts bod + ith = primINST_TYPE [(zty, sty)] thm + (_, ebod') = stripForall $ concl ith + (evs', bod) = stripExists ebod' + fns' <- map2M mkNewfun evs' outls + let fnalist = zip evs' . fromJust $ + mapM (rator <=< lhs . concl) fns' + inlalist = zip evs' inls + outlalist = zip evs' outls + defs <- mapM (hackClause outlalist inlalist) $ conjuncts bod + jth <- ruleBETA =<< ruleSPECL (map fst defs) ith + let bth = fromRight . primASSUME . snd . stripExists $ concl jth + cth <- foldr1M ruleCONJ =<< mapM (finishClause outlalist) =<< + ruleCONJUNCTS bth + dth <- ruleELIM_OUTCOMBS cth + eth <- ruleGEN_REWRITE convONCE_DEPTH (map ruleSYM fns') dth + fth <- foldrM ruleSIMPLE_EXISTS eth (map snd fnalist) + let dtms = map (head . hyp) fns' + gth <- foldrM (\ e th -> let (l, r) = fromJust $ destEq e in + do th' <- ruleDISCH e th + let th'' = fromJust $ + primINST [(l, r)] th' + ruleMP th'' $ primREFL r) fth dtms + hth <- liftM (rulePROVE_HYP jth) $ + foldrM ruleSIMPLE_CHOOSE gth evs' + let xvs = map (fst . stripComb . fromJust . rand . snd . + stripForall) . conjuncts $ concl eth + ruleGENL xvs hth + + where ruleELIM_OUTCOMBS :: IndTypesBCtxt thry => HOLThm -> HOL cls thry HOLThm + ruleELIM_OUTCOMBS = ruleGEN_REWRITE convTOP_DEPTH [defOUTL, defOUTR] + + mkSum :: [HOLType] -> HOL cls thry HOLType + mkSum tys = + let k = length tys in + if k == 1 then return $! head tys + else let (tys1, tys2) = fromJust $ chopList (k `div` 2) tys in + do tys1' <- mkSum tys1 + tys2' <- mkSum tys2 + mkType "sum" [tys1', tys2'] + + mkInls :: HOLType -> HOL cls thry [HOLTerm] + mkInls typ = + do bods <- mkInlsRec typ + liftO $ mapM (\ t -> flip mkAbs t #<< findTerm isVar t) bods + where mkInlsRec :: HOLType -> HOL cls thry [HOLTerm] + mkInlsRec ty@TyVar{} = return [mkVar "x" ty] + mkInlsRec ty = + let (_, [ty1, ty2]) = fromJust $ destType ty in + do inls1 <- mkInlsRec ty1 + inls2 <- mkInlsRec ty2 + inl <- mkConst "INL" [(tyA, ty1), (tyB, ty2)] + inr <- mkConst "INR" [(tyA, ty1), (tyB, ty2)] + let insl1' = fromRight $ mapM (mkComb inl) inls1 + insl2' = fromRight $ mapM (mkComb inr) inls2 + return $! insl1' ++ insl2' + + mkOutls :: HOLType -> HOL cls thry [HOLTerm] + mkOutls typ = + let x = mkVar "x" typ in + do inls <- mkOutlsRec x typ + liftO $ mapM (mkAbs x) inls + where mkOutlsRec :: HOLTerm -> HOLType -> HOL cls thry [HOLTerm] + mkOutlsRec sof TyVar{} = return [sof] + mkOutlsRec sof ty = + let (_, [ty1, ty2]) = fromJust $ destType ty in + do outl <- mkConst "OUTL" [(tyA, ty1), (tyB, ty2)] + outr <- mkConst "OUTR" [(tyA, ty1), (tyB, ty2)] + outl' <- flip mkOutlsRec ty1 #<< mkComb outl sof + outr' <- flip mkOutlsRec ty2 #<< mkComb outr sof + return $! outl' ++ outr' + + mkNewfun :: HOLTerm -> HOLTerm -> HOL cls thry HOLThm + mkNewfun fn outl = + let (x, l, r) = fromJust $ + do (s, ty) <- destVar fn + dty <- liftM (head . snd) $ destType ty + let x' = mkVar "x" dty + (y, bod) <- destAbs outl + fnx <- hush $ mkComb fn x' + r' <- hush $ mkAbs x #<< varSubst [(y, fnx)] bod + let l' = mkVar s $ typeOf r' + return (x', l', r') in + do etm <- mkEq l r + ruleRIGHT_BETAS [x] #<< primASSUME etm + + hackClause :: HOLTermEnv -> HOLTermEnv -> HOLTerm + -> HOL cls thry (HOLTerm, HOLTerm) + hackClause outlalist inlalist tm = + let (_, bod) = stripForall tm + (l, r) = fromJust $ destEq bod + (fn, args) = stripComb r in + do pargs <- mapM (\ a -> + do g <- genVar $ typeOf a + if isVar a + then return (g, g) + else let outl = fromJust $ flip lookup + outlalist =<< rator a + outl' = fromRight $ + mkComb outl g in + return (outl', g)) args + let (args', args'') = unzip pargs + inl = fromJust $ flip lookup inlalist =<< rator l + rty = head . snd . fromJust . destType $ typeOf inl + nty <- foldrM (mkFunTy . typeOf) rty args' + let fn' = mkVar (fst . fromJust $ destVar fn) nty + r' = fromRight $ listMkAbs args'' =<< mkComb inl =<< + listMkComb fn' args' + return (r', fn) + + finishClause :: BoolCtxt thry => HOLTermEnv -> HOLThm + -> HOL cls thry HOLThm + finishClause outlalist t = + let (avs, bod) = stripForall $ concl t + outl = fromJust $ flip lookup outlalist =<< rator =<< + lHand bod in + do th' <- ruleSPECL avs t + ruleGENL avs =<< ruleBETA #<< ruleAP_TERM outl th' + +proveConstructorsInjective :: (BasicConvs thry, PairCtxt thry) => HOLThm + -> HOL cls thry HOLThm +proveConstructorsInjective ax = + let cls = conjuncts . snd . stripExists . snd . stripForall $ concl ax + pats = fromJust $ mapM (rand <=< lHand . snd . stripForall) cls in + foldr1M ruleCONJ =<< mapFilterM proveDistinctness pats + where ruleDEPAIR :: (BasicConvs thry, PairCtxt thry) => HOLThm + -> HOL cls thry HOLThm + ruleDEPAIR = ruleGEN_REWRITE convTOP_SWEEP [thmPAIR_EQ] + + proveDistinctness :: (BasicConvs thry, PairCtxt thry) + => HOLTerm + -> HOL cls thry HOLThm + proveDistinctness pat = + let (f, args) = stripComb pat in + do rt <- foldr1M mkPair args + ty <- mkFunTy (typeOf pat) $ typeOf rt + fn <- genVar ty + dtm <- flip mkEq rt #<< mkComb fn pat + eth <- proveRecursiveFunctionsExist ax =<< + listMkForall args dtm + let args' = variants args args + atm <- mkEq pat #<< listMkComb f args' + let ath = fromRight $ primASSUME atm + bth = fromRight $ ruleAP_TERM fn ath + cth1 <- ruleSPECL args #<< primASSUME #<< + liftM snd (destExists $ concl eth) + let cth2 = fromJust $ primINST (zip args' args) cth1 + pth = fromRight $ liftM1 primTRANS + (liftM1 primTRANS (ruleSYM cth1) bth) cth2 + qth <- ruleDEPAIR pth + let qtm = concl qth + qths <- ruleCONJUNCTS #<< primASSUME qtm + let rth = fromRight $ foldlM (flip primMK_COMB) (primREFL f) + qths + tth <- liftM1 ruleIMP_ANTISYM (ruleDISCH atm qth) =<< + ruleDISCH qtm rth + uth <- ruleGENL args =<< ruleGENL args' tth + liftM (rulePROVE_HYP eth) $ ruleSIMPLE_CHOOSE fn uth + +proveDistinct_pth :: (BasicConvs thry, IndTypesBCtxt thry) + => HOL cls thry HOLThm +proveDistinct_pth = cacheProof "proveDistinct_pth" ctxtIndTypesB $ + ruleTAUT "a ==> F <=> ~a" + +proveConstructorsDistinct :: (BasicConvs thry, IndTypesBCtxt thry) => HOLThm + -> HOL cls thry HOLThm +proveConstructorsDistinct ax = + let cls = conjuncts . snd . stripExists . snd . stripForall $ concl ax + lefts = fromJust $ mapM (destComb <=< lHand . snd . stripForall) cls + fns = foldr (insert . fst) [] lefts + pats = map (\ f -> map snd (filter (\ (x,_) -> x == f) lefts)) fns in + foldr1M ruleCONJ =<< liftM (foldr1 (++)) + (mapFilterM proveDistinct pats) + where allopairs :: Monad m => (a -> a -> m a) -> [a] -> [a] -> m [a] + allopairs _ [] _ = return [] + allopairs f (l:ls) (_:ms) = + do xs <- mapM (f l) ms + ys <- allopairs f ls ms + return $! xs ++ ys + allopairs _ _ _ = return [] + + ruleNEGATE :: (BasicConvs thry, IndTypesBCtxt thry) => HOLThm + -> HOL cls thry HOLThm + ruleNEGATE = ruleGEN_ALL <=< ruleCONV (convREWR proveDistinct_pth) + + ruleREWRITE' :: BoolCtxt thry => HOLTerm -> HOLThm + -> HOL cls thry HOLThm + ruleREWRITE' bod th = + do ths <- ruleCONJUNCTS #<< primASSUME bod + ruleGEN_REWRITE convONCE_DEPTH ths th + + proveDistinct :: (BasicConvs thry, IndTypesBCtxt thry) + => [HOLTerm] -> HOL cls thry [HOLThm] + proveDistinct pat = + do tyNum <- mkType "num" [] + nums <- mapM mkNumeral ([0..(length pat -1)] :: [Int]) + fn <- genVar =<< mkType "fun" [typeOf $ head pat, tyNum] + let ls = fromRight $ mapM (mkComb fn) pat + defs <- map2M (\ l r -> let l' = frees . fromJust $ rand l in + listMkForall l' =<< mkEq l r) ls nums + eth <- proveRecursiveFunctionsExist ax =<< listMkConj defs + let (ev, bod) = fromJust . destExists $ concl eth + pat' = fromRight $ mapM (\ t -> + let (f, args) = if isNumeral t + then (t, []) + else stripComb t in + listMkComb f $ variants args args) + pat + pairs <- allopairs mkEq pat pat' + nths <- mapM (ruleREWRITE' bod <#< ruleAP_TERM fn <=< primASSUME) + pairs + fths <- map2M (\ t th -> ruleNEGATE =<< ruleDISCH t =<< + ruleCONV convNUM_EQ th) pairs nths + ruleCONJUNCTS =<< liftM (rulePROVE_HYP eth) + (ruleSIMPLE_CHOOSE ev =<< foldr1M ruleCONJ fths) diff --git a/src/HaskHOL/Lib/Lists.hs b/src/HaskHOL/Lib/Lists.hs new file mode 100644 index 0000000..9398f33 --- /dev/null +++ b/src/HaskHOL/Lib/Lists.hs @@ -0,0 +1,100 @@ +{-| + Module: HaskHOL.Lib.Lists + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Lists + ( ListsType + , ListsCtxt + , defHD + , defTL + , defAPPEND + , defREVERSE + , defLENGTH + , defMAP + , defLAST + , defBUTLAST + , defREPLICATE + , defNULL + , defALL + , defEX + , defITLIST + , defMEM + , defALL2 + , defMAP2 + , defEL + , defFILTER + , defASSOC + , defITLIST2 + , defZIP + , inductCHAR + , recursionCHAR + , thmMONO_ALL + , thmMONO_ALL2 + , thmREVERSE_APPEND + , thmREVERSE_APPEND2 + , mkChar + ) where + +import HaskHOL.Core +import HaskHOL.Deductive + +import HaskHOL.Lib.Lists.Base +import HaskHOL.Lib.Lists.Context + +import Data.Char (ord) +import Data.Bits (testBit) + +thmAPPEND_NIL :: ListsCtxt thry => HOL cls thry HOLThm +thmAPPEND_NIL = cacheProof "thmAPPEND_NIL" ctxtLists . + prove [str| ! (l:A list). APPEND l [] = l |] $ + tacLIST_INDUCT `_THEN` tacASM_REWRITE [defAPPEND] + +thmAPPEND_ASSOC :: ListsCtxt thry => HOL cls thry HOLThm +thmAPPEND_ASSOC = cacheProof "thmAPPEND_ASSOC" ctxtLists . + prove [str| ! (l:A list) m n. APPEND l (APPEND m n) = + APPEND (APPEND l m) n |] $ + tacLIST_INDUCT `_THEN` tacASM_REWRITE [defAPPEND] + +thmREVERSE_APPEND :: ListsCtxt thry => HOL cls thry HOLThm +thmREVERSE_APPEND = cacheProof "thmREVERSE_APPEND" ctxtLists . + prove [str| ! (xs:A list) (ys:A list). REVERSE (APPEND xs ys) = + APPEND (REVERSE ys) (REVERSE xs) |] $ + tacLIST_INDUCT `_THEN` + tacASM_REWRITE [defAPPEND, defREVERSE, thmAPPEND_NIL, thmAPPEND_ASSOC] + +thmREVERSE_APPEND2 :: ListsCtxt thry => HOL cls thry HOLThm +thmREVERSE_APPEND2 = cacheProof "thmREVERSE_APPEND2" ctxtLists . + prove [str| !! 'A. ! (xs:A' list) (ys:A' list). + REVERSE (APPEND xs ys) = APPEND (REVERSE ys) (REVERSE xs) |] $ + tacGEN_TY `_THEN` tacLIST_INDUCT `_THEN` + tacASM_REWRITE [defAPPEND, defREVERSE, thmAPPEND_NIL, thmAPPEND_ASSOC] + +{-# INLINEABLE tmASCII #-} +tmASCII :: ListsCtxt thry => PTerm thry +tmASCII = [lists| ASCII |] + +{-# INLINEABLE tmT #-} +tmT :: ListsCtxt thry => PTerm thry +tmT = [lists| T |] + +{-# INLINEABLE tmF #-} +tmF :: ListsCtxt thry => PTerm thry +tmF = [lists| F |] + +mkChar :: ListsCtxt thry => Char -> HOL cls thry HOLTerm +mkChar = mkCode . ord + where mkCode :: ListsCtxt thry => Int -> HOL cls thry HOLTerm + mkCode n = + do ascii <- serve tmASCII + bits <- mapM (\ i -> mkBool (testBit n i)) [0..7] + liftO $ foldrM (flip mkComb) ascii bits + + mkBool :: ListsCtxt thry => Bool -> HOL cls thry HOLTerm + mkBool True = serve tmT + mkBool _ = serve tmF + diff --git a/src/HaskHOL/Lib/Lists/A.hs b/src/HaskHOL/Lib/Lists/A.hs new file mode 100644 index 0000000..e465f01 --- /dev/null +++ b/src/HaskHOL/Lib/Lists/A.hs @@ -0,0 +1,7 @@ +module HaskHOL.Lib.Lists.A + ( module HaskHOL.Lib.Lists.A.Base + , module HaskHOL.Lib.Lists.A.Context + ) where + +import HaskHOL.Lib.Lists.A.Base +import HaskHOL.Lib.Lists.A.Context diff --git a/src/HaskHOL/Lib/Lists/A/Base.hs b/src/HaskHOL/Lib/Lists/A/Base.hs new file mode 100644 index 0000000..c75fb1a --- /dev/null +++ b/src/HaskHOL/Lib/Lists/A/Base.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE ConstraintKinds, QuasiQuotes #-} +module HaskHOL.Lib.Lists.A.Base where + +import HaskHOL.Core +import HaskHOL.Deductive + +import HaskHOL.Lib.Recursion +import HaskHOL.Lib.Nums +import HaskHOL.Lib.IndTypes + +defHD' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defHD' = newRecursiveDefinition "HD" recursionLIST "HD(CONS (h:A) t) = h" + +defTL' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defTL' = newRecursiveDefinition "TL" recursionLIST "TL(CONS (h:A) t) = t" + +defAPPEND' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defAPPEND' = newRecursiveDefinition "APPEND" recursionLIST + [str| (!l:(A)list. APPEND [] l = l) /\ + (!h t l. APPEND (CONS h t) l = CONS h (APPEND t l)) |] + +defREVERSE' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defREVERSE' = newRecursiveDefinition "REVERSE" recursionLIST + [str| (REVERSE [] = []) /\ + (REVERSE (CONS (x:A) l) = APPEND (REVERSE l) [x]) |] + +defLENGTH' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defLENGTH' = newRecursiveDefinition "LENGTH" recursionLIST + [str| (LENGTH [] = 0) /\ + (!h:A. !t. LENGTH (CONS h t) = SUC (LENGTH t)) |] + +defMAP' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defMAP' = newRecursiveDefinition "MAP" recursionLIST + [str| (!f:A->B. MAP f NIL = NIL) /\ + (!f h t. MAP f (CONS h t) = CONS (f h) (MAP f t)) |] + +defLAST' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defLAST' = newRecursiveDefinition "LAST" recursionLIST + "LAST (CONS (h:A) t) = if t = [] then h else LAST t" + +defBUTLAST' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defBUTLAST' = newRecursiveDefinition "BUTLAST" recursionLIST + [str| (BUTLAST [] = []) /\ + (BUTLAST (CONS h t) = if t = [] then [] else CONS h (BUTLAST t)) |] + +defREPLICATE' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defREPLICATE' = newRecursiveDefinition "REPLICATE" recursionNUM + [str| (REPLICATE 0 x = []) /\ + (REPLICATE (SUC n) x = CONS x (REPLICATE n x)) |] + +defNULL' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defNULL' = newRecursiveDefinition "NULL" recursionLIST + [str| (NULL [] = T) /\ + (NULL (CONS h t) = F) |] + +defALL' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defALL' = newRecursiveDefinition "ALL" recursionLIST + [str| (ALL P [] = T) /\ + (ALL P (CONS h t) <=> P h /\ ALL P t) |] + +defEX' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defEX' = newRecursiveDefinition "EX" recursionLIST + [str| (EX P [] = F) /\ + (EX P (CONS h t) <=> P h \/ EX P t) |] + +defITLIST' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defITLIST' = newRecursiveDefinition "ITLIST" recursionLIST + [str| (ITLIST f [] b = b) /\ + (ITLIST f (CONS h t) b = f h (ITLIST f t b)) |] + +defMEM' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defMEM' = newRecursiveDefinition "MEM" recursionLIST + [str| (MEM x [] <=> F) /\ + (MEM x (CONS h t) <=> (x = h) \/ MEM x t) |] + +defALL2' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defALL2' = newRecursiveDefinition "ALL2" recursionLIST + [str| (ALL2 P [] l2 <=> (l2 = [])) /\ + (ALL2 P (CONS h1 t1) l2 <=> + if l2 = [] then F + else P h1 (HD l2) /\ ALL2 P t1 (TL l2)) |] + +defMAP2' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defMAP2' = newRecursiveDefinition "MAP2" recursionLIST + [str| (MAP2 f [] l = []) /\ + (MAP2 f (CONS h1 t1) l = CONS (f h1 (HD l)) (MAP2 f t1 (TL l))) |] + +defEL' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defEL' = newRecursiveDefinition "EL" recursionNUM + [str| (EL 0 l = HD l) /\ + (EL (SUC n) l = EL n (TL l)) |] + +defFILTER' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defFILTER' = newRecursiveDefinition "FILTER" recursionLIST + [str| (FILTER P [] = []) /\ + (FILTER P (CONS h t) = + if P h then CONS h (FILTER P t) else FILTER P t) |] + +defASSOC' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defASSOC' = newRecursiveDefinition "ASSOC" recursionLIST + "ASSOC a (CONS h t) = if FST h = a then SND h else ASSOC a t" + +defITLIST2' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defITLIST2' = newRecursiveDefinition "ITLIST2" recursionLIST + [str| (ITLIST2 f [] l2 b = b) /\ + (ITLIST2 f (CONS h1 t1) l2 b = f h1 (HD l2) (ITLIST2 f t1 (TL l2) b)) + |] + +defZIP' :: (BasicConvs thry, IndTypesCtxt thry) => HOL Theory thry HOLThm +defZIP' = newRecursiveDefinition "ZIP" recursionLIST + [str| (ZIP [] l2 = []) /\ + (ZIP (CONS h1 t1) l2 = CONS (h1,HD l2) (ZIP t1 (TL l2))) |] + +tyDefCHAR' :: (BasicConvs thry, IndTypesCtxt thry) + => HOL Theory thry (HOLThm, HOLThm) +tyDefCHAR' = defineType "char = ASCII bool bool bool bool bool bool bool bool" diff --git a/src/HaskHOL/Lib/Lists/A/Context.hs b/src/HaskHOL/Lib/Lists/A/Context.hs new file mode 100644 index 0000000..2a306b1 --- /dev/null +++ b/src/HaskHOL/Lib/Lists/A/Context.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TemplateHaskell, + TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +module HaskHOL.Lib.Lists.A.Context + ( ListsAType + , ListsACtxt + , ctxtListsA + , listsA + ) where + +import HaskHOL.Core +import HaskHOL.Deductive + +import HaskHOL.Lib.IndTypes.Context + +import HaskHOL.Lib.Lists.A.Base + +-- generate template types +extendTheory ctxtIndTypes "ListsA" $ + do sequence_ [ defHD' + , defTL' + , defAPPEND' + , defREVERSE' + , defLENGTH' + , defMAP' + , defLAST' + , defBUTLAST' + , defREPLICATE' + , defNULL' + , defALL' + , defEX' + , defITLIST' + , defMEM' + , defALL2' + , defMAP2' + , defEL' + , defFILTER' + , defASSOC' + , defITLIST2' + , defZIP' + ] + void tyDefCHAR' + newTypeAbbrev "string" "char list" + +templateProvers 'ctxtListsA + +-- have to manually write this, for now +type family ListsACtxt a where + ListsACtxt a = (IndTypesCtxt a, ListsAContext a ~ True) + +type instance PolyTheory ListsAType b = ListsACtxt b + +instance BasicConvs ListsAType where + basicConvs _ = basicConvs (undefined :: IndTypesType) + diff --git a/src/HaskHOL/Lib/Lists/Base.hs b/src/HaskHOL/Lib/Lists/Base.hs new file mode 100644 index 0000000..ffe6e13 --- /dev/null +++ b/src/HaskHOL/Lib/Lists/Base.hs @@ -0,0 +1,118 @@ +module HaskHOL.Lib.Lists.Base where + +import HaskHOL.Core +import HaskHOL.Deductive + +import HaskHOL.Lib.IndTypes +import HaskHOL.Lib.Recursion + +import HaskHOL.Lib.Lists.A + +defHD :: ListsACtxt thry => HOL cls thry HOLThm +defHD = cacheProof "defHD" ctxtListsA $ getRecursiveDefinition "HD" + +defTL :: ListsACtxt thry => HOL cls thry HOLThm +defTL = cacheProof "defTL" ctxtListsA $ getRecursiveDefinition "TL" + +defAPPEND :: ListsACtxt thry => HOL cls thry HOLThm +defAPPEND = cacheProof "defAPPEND" ctxtListsA $ getRecursiveDefinition "APPEND" + +defREVERSE :: ListsACtxt thry => HOL cls thry HOLThm +defREVERSE = cacheProof "defREVERSE" ctxtListsA $ + getRecursiveDefinition "REVERSE" + +defLENGTH :: ListsACtxt thry => HOL cls thry HOLThm +defLENGTH = cacheProof "defLENGTH" ctxtListsA $ getRecursiveDefinition "LENGTH" + +defMAP :: ListsACtxt thry => HOL cls thry HOLThm +defMAP = cacheProof "defMAP" ctxtListsA $ getRecursiveDefinition "MAP" + +defLAST :: ListsACtxt thry => HOL cls thry HOLThm +defLAST = cacheProof "defLAST" ctxtListsA $ getRecursiveDefinition "LAST" + +defBUTLAST :: ListsACtxt thry => HOL cls thry HOLThm +defBUTLAST = cacheProof "defBUTLAST" ctxtListsA $ + getRecursiveDefinition "BUTLAST" + +defREPLICATE :: ListsACtxt thry => HOL cls thry HOLThm +defREPLICATE = cacheProof "defREPLICATE" ctxtListsA $ + getRecursiveDefinition "REPLICATE" + +defNULL :: ListsACtxt thry => HOL cls thry HOLThm +defNULL = cacheProof "defNULL" ctxtListsA $ getRecursiveDefinition "NULL" + +defALL :: ListsACtxt thry => HOL cls thry HOLThm +defALL = cacheProof "defALL" ctxtListsA $ getRecursiveDefinition "ALL" + +defEX :: ListsACtxt thry => HOL cls thry HOLThm +defEX = cacheProof "defEX" ctxtListsA $ getRecursiveDefinition "EX" + +defITLIST :: ListsACtxt thry => HOL cls thry HOLThm +defITLIST = cacheProof "defITLIST" ctxtListsA $ getRecursiveDefinition "ITLIST" + +defALL2 :: ListsACtxt thry => HOL cls thry HOLThm +defALL2 = cacheProof "defALL2" ctxtListsA $ getRecursiveDefinition "ALL2" + +defMAP2 :: ListsACtxt thry => HOL cls thry HOLThm +defMAP2 = cacheProof "defMAP2" ctxtListsA $ getRecursiveDefinition "MAP2" + +defEL :: ListsACtxt thry => HOL cls thry HOLThm +defEL = cacheProof "defEL" ctxtListsA $ getRecursiveDefinition "EL" + +defFILTER :: ListsACtxt thry => HOL cls thry HOLThm +defFILTER = cacheProof "defFILTER" ctxtListsA $ getRecursiveDefinition "FILTER" + +defASSOC :: ListsACtxt thry => HOL cls thry HOLThm +defASSOC = cacheProof "defASSOC" ctxtListsA $ getRecursiveDefinition "ASSOC" + +defITLIST2 :: ListsACtxt thry => HOL cls thry HOLThm +defITLIST2 = cacheProof "defITLIST2" ctxtListsA $ + getRecursiveDefinition "ITLIST2" + +defZIP :: ListsACtxt thry => HOL cls thry HOLThm +defZIP = cacheProof "defZIP" ctxtListsA $ getRecursiveDefinition "ZIP" + +defMEM :: ListsACtxt thry => HOL cls thry HOLThm +defMEM = cacheProof "defMEM" ctxtListsA $ getRecursiveDefinition "MEM" + + +inductCHAR :: ListsACtxt thry => HOL cls thry HOLThm +inductCHAR = cacheProof "inductCHAR" ctxtListsA $ + liftM fst tyChar + +recursionCHAR :: ListsACtxt thry => HOL cls thry HOLThm +recursionCHAR = cacheProof "recursionCHAR" ctxtListsA $ + liftM snd tyChar + +tyChar :: ListsACtxt thry => HOL cls thry (HOLThm, HOLThm) +tyChar = getType "char" + + + +inductLIST' :: (BasicConvs thry, ListsACtxt thry) => HOL cls thry HOLThm +inductLIST' = cacheProof "inductLIST'" ctxtListsA $ + prove [str| !P:(A)list->bool. P [] /\ + (!h t. P t ==> P (CONS h t)) ==> !l. P l |] $ + tacMATCH_ACCEPT inductLIST + +tacLIST_INDUCT :: (BasicConvs thry, ListsACtxt thry) => Tactic cls thry +tacLIST_INDUCT = + tacMATCH_MP inductLIST' `_THEN` tacCONJ `_THENL` + [ _ALL, tacGEN `_THEN` tacGEN `_THEN` tacDISCH] + +thmMONO_ALL :: (BasicConvs thry, ListsACtxt thry) => HOL cls thry HOLThm +thmMONO_ALL = cacheProof "thmMONO_ALL" ctxtListsA . + prove "(!x:A. P x ==> Q x) ==> ALL P l ==> ALL Q l" $ + tacDISCH `_THEN` tacSPEC ("l:A list", "l:A list") `_THEN` + tacLIST_INDUCT `_THEN` tacASM_REWRITE [defALL] `_THEN` tacASM_MESON_NIL + +thmMONO_ALL2 :: (BasicConvs thry, ListsACtxt thry) => HOL cls thry HOLThm +thmMONO_ALL2 = cacheProof "thmMONO_ALL2" ctxtListsA . + prove [str| (!x y. (P:A->B->bool) x y ==> Q x y) ==> + ALL2 P l l' ==> ALL2 Q l l' |] $ + tacDISCH `_THEN` tacSPEC ("l':B list", "l':B list") `_THEN` + tacSPEC ("l:A list", "l:A list") `_THEN` tacLIST_INDUCT `_THEN` + tacREWRITE [defALL2] `_THEN` tacGEN `_THEN` tacCOND_CASES `_THEN` + tacREWRITE_NIL `_THEN` tacASM_MESON_NIL + + diff --git a/src/HaskHOL/Lib/Lists/Context.hs b/src/HaskHOL/Lib/Lists/Context.hs new file mode 100644 index 0000000..aef6d36 --- /dev/null +++ b/src/HaskHOL/Lib/Lists/Context.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TemplateHaskell, + TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +module HaskHOL.Lib.Lists.Context + ( ListsType + , ListsCtxt + , ctxtLists + , lists + ) where + +import HaskHOL.Core +import HaskHOL.Deductive +import HaskHOL.Lib.IndTypes + +import HaskHOL.Lib.Lists.A.Context +import HaskHOL.Lib.Lists.Base + +-- generate template types +extendTheory ctxtListsA "Lists" $ + mapM_ addMonoThm [thmMONO_ALL, thmMONO_ALL2] + +templateProvers 'ctxtLists + +-- have to manually write this, for now +type family ListsCtxt a where + ListsCtxt a = (ListsACtxt a, ListsContext a ~ True) + +type instance PolyTheory ListsType b = ListsCtxt b + +instance BasicConvs ListsType where + basicConvs _ = basicConvs (undefined :: IndTypesType) diff --git a/src/HaskHOL/Lib/Normalizer.hs b/src/HaskHOL/Lib/Normalizer.hs new file mode 100644 index 0000000..1b2c022 --- /dev/null +++ b/src/HaskHOL/Lib/Normalizer.hs @@ -0,0 +1,715 @@ +{-# LANGUAGE PatternSynonyms, ScopedTypeVariables #-} +{-| + Module: HaskHOL.Lib.Normalizer + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Normalizer + ( convSEMIRING_NORMALIZERS + , convNUM_NORMALIZE + ) where + +import HaskHOL.Core +import HaskHOL.Deductive + +import HaskHOL.Lib.Nums +import HaskHOL.Lib.Arith +import HaskHOL.Lib.WF +import HaskHOL.Lib.WF.Context +import HaskHOL.Lib.CalcNum + +import Data.Vector (fromList, (!)) + +semiring_pth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +semiring_pth = cacheProof "semiring_pth" ctxtWF . + prove [str| (!x:A y z. add x (add y z) = add (add x y) z) /\ + (!x y. add x y = add y x) /\ + (!x. add r0 x = x) /\ + (!x y z. mul x (mul y z) = mul (mul x y) z) /\ + (!x y. mul x y = mul y x) /\ + (!x. mul r1 x = x) /\ + (!x. mul r0 x = r0) /\ + (!x y z. mul x (add y z) = add (mul x y) (mul x z)) /\ + (!x. pwr x 0 = r1) /\ + (!x n. pwr x (SUC n) = mul x (pwr x n)) + ==> (mul r1 x = x) /\ + (add (mul a m) (mul b m) = mul (add a b) m) /\ + (add (mul a m) m = mul (add a r1) m) /\ + (add m (mul a m) = mul (add a r1) m) /\ + (add m m = mul (add r1 r1) m) /\ + (mul r0 m = r0) /\ + (add r0 a = a) /\ + (add a r0 = a) /\ + (mul a b = mul b a) /\ + (mul (add a b) c = add (mul a c) (mul b c)) /\ + (mul r0 a = r0) /\ + (mul a r0 = r0) /\ + (mul r1 a = a) /\ + (mul a r1 = a) /\ + (mul (mul lx ly) (mul rx ry) = + mul (mul lx rx) (mul ly ry)) /\ + (mul (mul lx ly) (mul rx ry) = + mul lx (mul ly (mul rx ry))) /\ + (mul (mul lx ly) (mul rx ry) = + mul rx (mul (mul lx ly) ry)) /\ + (mul (mul lx ly) rx = mul (mul lx rx) ly) /\ + (mul (mul lx ly) rx = mul lx (mul ly rx)) /\ + (mul lx rx = mul rx lx) /\ + (mul lx (mul rx ry) = mul (mul lx rx) ry) /\ + (mul lx (mul rx ry) = mul rx (mul lx ry)) /\ + (add (add a b) (add c d) = add (add a c) (add b d)) /\ + (add (add a b) c = add a (add b c)) /\ + (add a (add c d) = add c (add a d)) /\ + (add (add a b) c = add (add a c) b) /\ + (add a c = add c a) /\ + (add a (add c d) = add (add a c) d) /\ + (mul (pwr x p) (pwr x q) = pwr x (p + q)) /\ + (mul x (pwr x q) = pwr x (SUC q)) /\ + (mul (pwr x q) x = pwr x (SUC q)) /\ + (mul x x = pwr x 2) /\ + (pwr (mul x y) q = mul (pwr x q) (pwr y q)) /\ + (pwr (pwr x p) q = pwr x (p * q)) /\ + (pwr x 0 = r1) /\ + (pwr x 1 = x) /\ + (mul x (add y z) = add (mul x y) (mul x z)) /\ + (pwr x (SUC q) = mul x (pwr x q)) |] $ + tacSTRIP `_THEN` + _SUBGOAL_THEN [str| (!m:A n. add m n = add n m) /\ + (!m n p. add (add m n) p = add m (add n p)) /\ + (!m n p. add m (add n p) = add n (add m p)) /\ + (!x. add x r0 = x) /\ + (!m n. mul m n = mul n m) /\ + (!m n p. mul (mul m n) p = mul m (mul n p)) /\ + (!m n p. mul m (mul n p) = mul n (mul m p)) /\ + (!m n p. mul (add m n) p = add (mul m p) (mul n p)) /\ + (!x. mul x r1 = x) /\ + (!x. mul x r0 = r0) |] + tacMP `_THENL` + [ tacASM_MESON_NIL + , _MAP_EVERY (\ t -> _UNDISCH_THEN t (const _ALL)) + [ "!x:A y z. add x (add y z) = add (add x y) z" + , "!x:A y. add x y :A = add y x" + , "!x:A y z. mul x (mul y z) = mul (mul x y) z" + , "!x:A y. mul x y :A = mul y x" + ] `_THEN` + tacSTRIP + ] `_THEN` + tacASM_REWRITE [ runConv convNUM =<< toHTm "2" + , runConv convNUM =<< toHTm "1" ] `_THEN` + _SUBGOAL_THEN "!m n:num x:A. pwr x (m + n) :A = mul (pwr x m) (pwr x n)" + tacASSUME `_THENL` + [ tacGEN `_THEN` tacINDUCT `_THEN` tacASM_REWRITE [thmADD_CLAUSES] + , _ALL + ] `_THEN` + _SUBGOAL_THEN "!x:A y:A n:num. pwr (mul x y) n = mul (pwr x n) (pwr y n)" + tacASSUME `_THENL` + [ tacGEN `_THEN` tacGEN `_THEN` tacINDUCT `_THEN` tacASM_REWRITE_NIL + , _ALL + ] `_THEN` + _SUBGOAL_THEN "!x:A m:num n. pwr (pwr x m) n = pwr x (m * n)" + (\ th -> tacASM_MESON [th]) `_THEN` + tacGEN `_THEN` tacGEN `_THEN` tacINDUCT `_THEN` + tacASM_REWRITE [thmMULT_CLAUSES] + +convSEMIRING_NORMALIZERS :: forall cls thry. (BasicConvs thry, WFCtxt thry) + => HOLThm -> HOLThm + -> ( HOLTerm -> Bool, Conversion cls thry + , Conversion cls thry, Conversion cls thry ) + -> (HOLTerm -> HOLTerm -> Bool) -> + HOL cls thry + ( Conversion cls thry, Conversion cls thry + , Conversion cls thry, Conversion cls thry + , Conversion cls thry, Conversion cls thry ) +convSEMIRING_NORMALIZERS sth rth ( isSemiringConstant, convSEMIRING_ADD + , convSEMIRING_MUL, convSEMIRING_POW ) + variableOrder = + do thms <- ruleCONJUNCTS =<< ruleMATCH_MP semiring_pth sth + tmP <- serve tmP' + tmQ <- serve tmQ' + tmOnen <- serve tmOnen' + tmZeron <- serve tmZeron' + tmTrue <- serve tmTrue' + let pthms = fromList thms + tmAdd = fromJust $ rator =<< rator =<< lHand (concl $ pthms ! 6) + tmMul = fromJust $ rator =<< rator =<< lHand (concl $ pthms ! 12) + tmPow = fromJust $ rator =<< rator =<< rand (concl $ pthms ! 31) + tmZero = fromJust $ rand (concl $ pthms ! 5) + tmOne = fromJust $ rand =<< lHand (concl $ pthms ! 13) + ty = typeOf . fromJust . rand . concl $ pthms ! 0 + tmA = mkVar "a" ty + tmB = mkVar "b" ty + tmC = mkVar "c" ty + tmD = mkVar "d" ty + tmLX = mkVar "lx" ty + tmLY = mkVar "ly" ty + tmM = mkVar "m" ty + tmRX = mkVar "rx" ty + tmRY = mkVar "ry" ty + tmX = mkVar "x" ty + tmY = mkVar "y" ty + tmZ = mkVar "z" ty + destAdd = destBinop tmAdd + destMul = destBinop tmMul + destPow tm = + do (l, r) <- destBinop tmPow tm + if isNumeral r + then Just (l, r) + else Nothing + isAdd = isBinop tmAdd + isMul = isBinop tmMul + (nthm1, nthm2, tmSub, tmNeg, destSub) <- + if concl rth == tmTrue + then return (rth, rth, tmTrue, tmTrue, \ t -> Just (t, t)) + else do nthm1 <- ruleSPEC tmX =<< ruleCONJUNCT1 rth + nthm2 <- ruleSPECL [tmX, tmY] =<< ruleCONJUNCT2 rth + let tmSub = fromJust $ rator =<< rator =<< lHand (concl nthm2) + tmNeg = fromJust $ rator =<< lHand (concl nthm1) + destSub = destBinop tmSub + return (nthm1, nthm2, tmSub, tmNeg, destSub) +-- + let convPOWVAR_MUL :: Conversion cls thry + convPOWVAR_MUL = Conv $ \ tm -> + let (l, r) = fromJust $ destMul tm in + if isSemiringConstant l && isSemiringConstant r + then runConv convSEMIRING_MUL tm + else do { (lx, ln) <- liftO $ destPow l + ; do { (_, rn) <- liftO $ destPow r + ; th1 <- liftO . primINST [ (tmX, lx), (tmP, ln) + , (tmQ, rn) ] $ pthms ! 28 + ; (tm1, tm2) <- liftO $ destComb =<< + rand (concl th1) + ; th2 <- runConv convNUM_ADD tm2 + ; liftO $ primTRANS th1 =<< ruleAP_TERM tm1 th2 + } <|> + do { th1 <- liftO . primINST [ (tmX, lx) + , (tmQ, ln) ] $ pthms ! 30 + ; (tm1, tm2) <- liftO $ destComb =<< + rand (concl th1) + ; th2 <- runConv convNUM_SUC tm2 + ; liftO $ primTRANS th1 =<< ruleAP_TERM tm1 th2 + } + } <|> + do { (rx, rn) <- liftO $ destPow r + ; th1 <- liftO . primINST [(tmX, rx), (tmQ, rn)] $ pthms ! 29 + ; (tm1, tm2) <- liftO $ destComb =<< rand (concl th1) + ; th2 <- runConv convNUM_SUC tm2 + ; liftO $ primTRANS th1 =<< ruleAP_TERM tm1 th2 + } <|> (liftO . primINST [(tmX, l)] $ pthms ! 31) +-- + let ruleMONOMIAL_DEONE :: HOLThm -> Maybe HOLThm + ruleMONOMIAL_DEONE th = + (do (l, r) <- destMul =<< rand (concl th) + if l == tmOne + then hush $ primTRANS th #<< primINST [(tmX, r)] + (pthms ! 0) + else return th) + <|> return th +-- + let ruleMONOMIAL_POW :: HOLTerm -> HOLTerm -> HOLTerm + -> HOL cls thry HOLThm + ruleMONOMIAL_POW tm bod ntm + | not (isComb bod) = return $! primREFL tm + | isSemiringConstant bod = runConv convSEMIRING_POW tm + | otherwise = + let (lop, r) = fromJust $ destComb bod in + if not (isComb lop) then return $! primREFL tm + else let (op, l) = fromJust $ destComb lop in + if op == tmPow && isNumeral r + then let th1 = fromJust . primINST + [(tmX, l), (tmP, r), (tmQ, ntm)] $ pthms ! 33 + (l', r') = fromJust $ destComb =<< + rand (concl th1) in + do th2 <- runConv convNUM_MULT r' + liftO $ primTRANS th1 =<< ruleAP_TERM l' th2 + else if op == tmMul + then let th1 = fromJust . primINST + [ (tmX, l), (tmY, r) + , (tmQ, ntm) ] $ pthms ! 32 + (xy, z) = fromJust $ destComb =<< + rand (concl th1) + (x, y) = fromJust $ destComb xy in + do thl <- ruleMONOMIAL_POW y l ntm + thr <- ruleMONOMIAL_POW z r ntm + let thl' = fromRight $ ruleAP_TERM x thl + liftO $ primTRANS th1 =<< + primMK_COMB thl' thr + else return $! primREFL tm +-- + convMONOMIAL_POW :: Conversion cls thry + convMONOMIAL_POW = Conv $ \ tm -> + let (lop, r) = fromJust $ destComb tm + (op, l) = fromJust $ destComb lop in + if op /= tmPow || not (isNumeral r) + then fail "convMONOMIAL_POW" + else if r == tmZeron then liftO . primINST [(tmX, l)] $ pthms ! 34 + else if r == tmOnen then liftO . primINST [(tmX, l)] $ pthms ! 35 + else do th <- ruleMONOMIAL_POW tm l r + liftO $ ruleMONOMIAL_DEONE th +-- + let powvar :: HOLTerm -> Maybe HOLTerm + powvar tm + | isSemiringConstant tm = Just tmOne + | otherwise = + (do (lop, r) <- destComb tm + (op, l) <- destComb lop + if op == tmPow && isNumeral r + then Just l + else Nothing) + <|> Just tm +-- + vorder :: HOLTerm -> HOLTerm -> Ordering + vorder x y + | x == y = EQ + | x == tmOne = LT + | y == tmOne = GT + | variableOrder x y = LT + | otherwise = GT +-- + ruleMONOMIAL_MUL :: HOLTerm -> HOLTerm -> HOLTerm + -> HOL cls thry HOLThm + ruleMONOMIAL_MUL tm l r = + do { (lx, ly) <- liftO $ destMul l + ; vl <- liftO $ powvar lx + ; do { (rx, ry) <- liftO $ destMul r + ; vr <- liftO $ powvar rx + ; let ord = vorder vl vr + ; if ord == EQ + then do th1 <- liftO . primINST [ (tmLX, lx), (tmLY, ly) + , (tmRX, rx), (tmRY, ry) + ] $ pthms ! 14 + (tm1, tm2) <- liftO $ destComb =<< + rand (concl th1) + (tm3, tm4) <- liftO $ destComb tm1 + th1_5 <- runConv convPOWVAR_MUL tm4 + th2 <- liftO $ liftM1 ruleAP_THM + (ruleAP_TERM tm3 th1_5) tm2 + th3 <- liftO $ primTRANS th1 th2 + (tm5, tm6) <- liftO $ destComb =<< + rand (concl th3) + (tm7, tm8) <- liftO $ destComb tm6 + tm7' <- liftO $ rand tm7 + th4 <- ruleMONOMIAL_MUL tm6 tm7' tm8 + liftO $ primTRANS th3 =<< ruleAP_TERM tm5 th4 + else let th0 = (!) pthms $ if ord == LT then 15 + else 16 in + do th1 <- liftO $ primINST + [ (tmLX, lx), (tmLY, ly) + , (tmRX, rx), (tmRY, ry) ] th0 + (tm1, tm2) <- liftO $ destComb =<< + rand (concl th1) + (tm3, tm4) <- liftO $ destComb tm2 + tm3' <- liftO $ rand tm3 + th2 <- ruleMONOMIAL_MUL tm2 tm3' tm4 + liftO $ primTRANS th1 =<< ruleAP_TERM tm1 th2 + } <|> + do { vr <- liftO $ powvar r + ; let ord = vorder vl vr + ; if ord == EQ + then do th1 <- liftO . primINST [ (tmLX, lx), (tmLY, ly) + , (tmRX, r) ] $ pthms ! 17 + (tm1, tm2) <- liftO $ destComb =<< + rand (concl th1) + (tm3, tm4) <- liftO $ destComb tm1 + th1_5 <- runConv convPOWVAR_MUL tm4 + th2 <- liftO $ liftM1 ruleAP_THM + (ruleAP_TERM tm3 th1_5) tm2 + liftO $ primTRANS th1 th2 + else if ord == LT + then do th1 <- liftO . primINST + [ (tmLX, lx), (tmLY, ly) + , (tmRX, r) ] $ pthms ! 18 + (tm1, tm2) <- liftO $ destComb =<< + rand (concl th1) + (tm3, tm4) <- liftO $ destComb tm2 + tm3' <- liftO $ rand tm3 + th2 <- ruleMONOMIAL_MUL tm2 tm3' tm4 + liftO $ primTRANS th1 =<< + ruleAP_TERM tm1 th2 + else liftO . primINST [(tmLX, l), (tmRX, r)] $ + pthms ! 19 + } + } <|> + do { vl <- liftO $ powvar l + ; do { (rx, ry) <- liftO $ destMul r + ; vr <- liftO $ powvar rx + ; let ord = vorder vl vr + ; if ord == EQ + then do th1 <- liftO . primINST [ (tmLX, l), (tmRX, rx) + , (tmRY, ry) ] $ + pthms ! 20 + (tm1, tm2) <- liftO $ destComb =<< + rand (concl th1) + (tm3, tm4) <- liftO $ destComb tm1 + th2 <- runConv convPOWVAR_MUL tm4 + liftO $ primTRANS th1 =<< liftM1 ruleAP_THM + (ruleAP_TERM tm3 th2) tm2 + else if ord == GT + then do th1 <- liftO . primINST + [ (tmLX, l), (tmRX, rx) + , (tmRY, ry) ] $ pthms ! 21 + (tm1, tm2) <- liftO $ destComb =<< + rand (concl th1) + (tm3, tm4) <- liftO $ destComb tm2 + tm3' <- liftO $ rand tm3 + th2 <- ruleMONOMIAL_MUL tm2 tm3' tm4 + liftO $ primTRANS th1 =<< + ruleAP_TERM tm1 th2 + else return $! primREFL tm + } <|> + let vr = fromJust $ powvar r + ord = vorder vl vr in + if ord == EQ + then runConv convPOWVAR_MUL tm + else if ord == GT + then liftO . primINST [(tmLX, l), (tmRX, r)] $ pthms ! 19 + else return $! primREFL tm + } +-- + convMONOMIAL_MUL :: Conversion cls thry + convMONOMIAL_MUL = Conv $ \ tm -> + let (l, r) = fromJust $ destMul tm in + do th <- ruleMONOMIAL_MUL tm l r + liftO $ ruleMONOMIAL_DEONE th +-- + let convPOLYNOMIAL_MONOMIAL_MUL :: Conversion cls thry + convPOLYNOMIAL_MONOMIAL_MUL = Conv $ \ tm -> + let (l, r) = fromJust $ destMul tm in + (do (y, z) <- liftO $ destAdd r + th1 <- liftO . primINST [(tmX, l), (tmY, y), (tmZ, z)] $ + pthms ! 36 + (tm1, tm2) <- liftO $ destComb =<< rand (concl th1) + (tm3, tm4) <- liftO $ destComb tm1 + thl <- runConv convMONOMIAL_MUL tm4 + thr <- runConv convPOLYNOMIAL_MONOMIAL_MUL tm2 + th2 <- liftO $ liftM1 primMK_COMB (ruleAP_TERM tm3 thl) thr + liftO $ primTRANS th1 th2) + <|> runConv convMONOMIAL_MUL tm +-- + let convMONOMIAL_ADD :: Conversion cls thry + convMONOMIAL_ADD = Conv $ \ tm -> + let (l, r) = fromJust $ destAdd tm in + if isSemiringConstant l && isSemiringConstant r + then runConv convSEMIRING_ADD tm + else let th1 = fromJust $ + let ll' = lHand l + lr' = lHand r in + if isMul l && + (liftM isSemiringConstant ll' == Just True) + then if isMul r && + (liftM isSemiringConstant lr' == Just True) + then do rr <- rand r + ll <- ll' + lr <- lr' + primINST [ (tmA, ll), (tmB, lr) + , (tmM, rr) ] $ pthms ! 1 + else do ll <- ll' + primINST [(tmA, ll),(tmM, r)] $ + pthms ! 2 + else if isMul r && + (liftM isSemiringConstant lr' == Just True) + then do lr <- lr' + primINST [(tmA, lr), (tmM, l)] $ + pthms ! 3 + else primINST [(tmM, r)] $ pthms ! 4 + (tm1, tm2) = fromJust $ destComb =<< rand (concl th1) + (tm3, tm4) = fromJust $ destComb tm1 in + do th1_5 <- runConv convSEMIRING_ADD tm4 + let th2 = fromRight $ ruleAP_TERM tm3 th1_5 + th3 = fromRight $ primTRANS th1 =<< + ruleAP_THM th2 tm2 + tm5 = fromJust . rand $ concl th3 + if lHand tm5 == Just tmZero + then let tm5' = fromJust $ rand tm5 in + liftO $ primTRANS th3 #<< + primINST [(tmM, tm5')] (pthms ! 5) + else liftO $ ruleMONOMIAL_DEONE th3 +-- + let powervars :: HOLTerm -> [HOLTerm] + powervars tm = + let ptms = stripList destMul tm in + if isSemiringConstant $ head ptms + then tail ptms + else ptms + + destVarpow :: HOLTerm -> Maybe (HOLTerm, Integer) + destVarpow tm = + (do (x, n) <- destPow tm + n' <- destNumeral n + return (x, n')) + <|> return (tm, if isSemiringConstant tm then 0 else 1) + + morder :: HOLTerm -> HOLTerm -> Ordering + morder tm1 tm2 = + let vdegs1 = fromJust . mapM destVarpow $ powervars tm1 + vdegs2 = fromJust . mapM destVarpow $ powervars tm2 + deg1 = foldr ((+) . snd) 0 vdegs1 + deg2 = foldr ((+) . snd) 0 vdegs2 in + if deg1 < deg2 then LT + else if deg1 > deg2 then GT + else lexorder vdegs1 vdegs2 + where lexorder :: [(HOLTerm, Integer)] -> [(HOLTerm, Integer)] + -> Ordering + lexorder [] [] = EQ + lexorder _ [] = LT + lexorder [] _ = GT + lexorder ((x1, n1):vs1) ((x2, n2):vs2) + | variableOrder x1 x2 = GT + | variableOrder x2 x1 = LT + | n1 < n2 = LT + | n2 < n1 = GT + | otherwise = lexorder vs1 vs2 +-- + let ruleDEZERO :: HOLThm -> Either String HOLThm + ruleDEZERO th = + do tm <- note "" . rand $ concl th + if not (isAdd tm) + then return th + else do (lop, r) <- note "" $ destComb tm + l <- note "" $ rand lop + if l == tmZero + then primTRANS th #<< primINST [(tmA, r)] (pthms ! 6) + else if r == tmZero + then primTRANS th #<< + primINST [(tmA, l)] (pthms ! 7) + else return th + + convPOLYNOMIAL_ADD :: Conversion cls thry + convPOLYNOMIAL_ADD = Conv $ \ tm -> + let (l, r) = fromJust $ destAdd tm in + if l == tmZero then liftO . primINST [(tmA, r)] $ pthms ! 6 + else if r == tmZero then liftO . primINST [(tmA, l)] $ pthms ! 7 + else if isAdd l + then let (a, b) = fromJust $ destAdd l in + if isAdd r + then let (c, d) = fromJust $ destAdd r + ord = morder a c in + if ord == EQ + then let th1 = fromJust . primINST + [ (tmA, a), (tmB, b), (tmC, c) + , (tmD, d) ] $ pthms ! 22 + (tm1, tm2) = fromJust $ destComb =<< + rand (concl th1) + (tm3, tm4) = fromJust $ destComb tm1 in + do th1_5 <- runConv convMONOMIAL_ADD tm4 + let th2 = fromRight $ + ruleAP_TERM tm3 th1_5 + th3 <- runConv convPOLYNOMIAL_ADD tm2 + liftO $ ruleDEZERO =<< + primTRANS th1 =<< + primMK_COMB th2 th3 + else let th1 = fromJust $ + if ord == GT + then primINST [ (tmA, a), (tmB, b) + , (tmC, r) ] $ pthms ! 23 + else primINST [ (tmA, l), (tmC, c) + , (tmD, d) ] $ pthms ! 24 + (tm1, tm2) = fromJust $ destComb =<< + rand (concl th1) in + do th2 <- runConv convPOLYNOMIAL_ADD tm2 + liftO $ ruleDEZERO =<< + primTRANS th1 =<< + ruleAP_TERM tm1 th2 + else let ord = morder a r in + if ord == EQ + then let th1 = fromJust $ primINST [(tmA, a), (tmB, b), (tmC, r)] (pthms ! 25) + (tm1, tm2) = fromJust $ destComb =<< rand (concl th1) + (tm3, tm4) = fromJust $ destComb tm1 in + do thl <- runConv convMONOMIAL_ADD tm4 + let th2 = fromRight $ liftM1 ruleAP_THM (ruleAP_TERM tm3 thl) tm2 + liftO $ ruleDEZERO =<< primTRANS th1 th2 + else if ord == GT + then let th1 = fromJust $ primINST [(tmA, a), (tmB, b), (tmC, r)] (pthms ! 23) + (tm1, tm2) = fromJust $ destComb =<< rand (concl th1) in + do th <- runConv convPOLYNOMIAL_ADD tm2 + liftO $ ruleDEZERO =<< primTRANS th1 =<< ruleAP_TERM tm1 th + else liftO $ ruleDEZERO #<< + primINST [(tmA, l), (tmC, r)] (pthms ! 26) + else if isAdd r + then let (c, d) = fromJust $ destAdd r + ord = morder l c in + if ord == EQ + then let th1 = fromJust . primINST + [ (tmA, l), (tmC, c) + , (tmD, d) ] $ pthms ! 27 + (tm1, tm2) = fromJust $ destComb =<< + rand (concl th1) + (tm3, tm4) = fromJust $ destComb tm1 in + do th1_5 <- runConv convMONOMIAL_ADD tm4 + let th2 = fromRight $ liftM1 ruleAP_THM + (ruleAP_TERM tm3 th1_5) tm2 + liftO $ ruleDEZERO =<< primTRANS th1 th2 + else if ord == GT + then return $! primREFL tm + else let th1 = fromJust . primINST + [ (tmA, l), (tmC, c) + , (tmD, d) ] $ pthms ! 24 + (tm1, tm2) = fromJust $ destComb =<< + rand (concl th1) in + do th2 <- runConv convPOLYNOMIAL_ADD tm2 + liftO $ ruleDEZERO =<< primTRANS th1 =<< + ruleAP_TERM tm1 th2 + else let ord = morder l r in + if ord == EQ + then runConv convMONOMIAL_ADD tm + else if ord == GT + then liftO . ruleDEZERO $ primREFL tm + else liftO $ ruleDEZERO #<< + primINST [(tmA, l), (tmC, r)] (pthms ! 26) +-- + let rulePMUL :: HOLTerm -> HOL cls thry HOLThm + rulePMUL tm = + let (l, r) = fromJust $ destMul tm in + if not (isAdd l) then runConv convPOLYNOMIAL_MONOMIAL_MUL tm + else if not (isAdd r) + then let th1 = fromJust . + primINST [(tmA, l), (tmB, r)] $ pthms ! 8 in + do th2 <- runConv convPOLYNOMIAL_MONOMIAL_MUL #<< + rand (concl th1) + liftO $ primTRANS th1 th2 + else let (a, b) = fromJust $ destAdd l + th1 = fromJust . + primINST [(tmA, a), (tmB, b), (tmC, r)] $ pthms ! 109 + (tm1, tm2) = fromJust $ destComb =<< rand (concl th1) + (tm3, tm4) = fromJust $ destComb tm1 in + do th1_5 <- runConv convPOLYNOMIAL_MONOMIAL_MUL tm4 + let th2 = fromRight $ ruleAP_TERM tm3 th1_5 + th2_5 <- rulePMUL tm2 + let th3 = fromRight $ primTRANS th1 =<< + primMK_COMB th2 th2_5 + th4 <- runConv convPOLYNOMIAL_ADD #<< + rand (concl th3) + liftO $ primTRANS th3 th4 + + convPOLYNOMIAL_MUL :: Conversion cls thry + convPOLYNOMIAL_MUL = Conv $ \ tm -> + let (l, r) = fromJust $ destMul tm in + if l == tmZero + then liftO . primINST [(tmA, r)] $ pthms ! 10 + else if r == tmZero + then liftO . primINST [(tmA, l)] $ pthms ! 11 + else if l == tmOne + then liftO . primINST [(tmA, r)] $ pthms ! 12 + else if r == tmOne + then liftO . primINST [(tmA, l)] $ pthms ! 13 + else rulePMUL tm +-- + let rulePPOW :: HOLTerm -> HOL cls thry HOLThm + rulePPOW tm = + let (l, n) = fromJust $ destPow tm in + if n == tmZeron then liftO $ primINST [(tmX, l)] $ pthms ! 34 + else if n == tmOnen then liftO $ + primINST [(tmX, l)] $ pthms ! 35 + else do th1 <- runConv convNUM n + let qtm' = fromJust $ rand =<< rand (concl th1) + th2 = fromJust . primINST + [(tmX, l), (tmQ, qtm')] $ pthms ! 37 + (tm1, tm2) = fromJust $ destComb =<< + rand (concl th2) + thr <- rulePPOW tm2 + let th3 = fromRight $ primTRANS th2 =<< + ruleAP_TERM tm1 thr + tm' = fromJust $ rator tm + th4 = fromRight $ + liftM1 primTRANS (ruleAP_TERM tm' th1) th3 + th5 <- runConv convPOLYNOMIAL_MUL #<< rand (concl th4) + liftO $ primTRANS th4 th5 + + convPOLYNOMIAL_POW :: Conversion cls thry + convPOLYNOMIAL_POW = Conv $ \ tm -> + if isAdd (fromJust $ lHand tm) + then rulePPOW tm + else runConv convMONOMIAL_POW tm +-- + let convPOLYNOMIAL_NEG :: Conversion cls thry + convPOLYNOMIAL_NEG = Conv $ \ tm -> + let (l, r) = fromJust $ destComb tm in + if l /= tmNeg then fail "convPOLYNOMIAL_NEG" + else let th1 = fromJust $ primINST [(tmX, r)] nthm1 in + do th2 <- runConv convPOLYNOMIAL_MONOMIAL_MUL #<< + rand (concl th1) + liftO $ primTRANS th1 th2 +-- + let convPOLYNOMIAL_SUB :: Conversion cls thry + convPOLYNOMIAL_SUB = Conv $ \ tm -> + let (l, r) = fromJust $ destSub tm + th1 = fromJust $ primINST [(tmX, l), (tmY, r)] nthm2 + (tm1, tm2) = fromJust $ destComb =<< rand (concl th1) in + do thr1 <- runConv convPOLYNOMIAL_MONOMIAL_MUL tm2 + let th2 = fromRight $ ruleAP_TERM tm1 thr1 + thr2 <- runConv convPOLYNOMIAL_ADD #<< rand (concl th2) + liftO $ primTRANS th1 =<< primTRANS th2 thr2 +-- + let convPOLYNOMIAL :: Conversion cls thry + convPOLYNOMIAL = Conv $ \ tm -> + if not (isComb tm) || isSemiringConstant tm + then return $! primREFL tm + else let (lop, r) = fromJust $ destComb tm in + if lop == tmNeg + then do th0_5 <- runConv convPOLYNOMIAL r + let th1 = fromRight $ ruleAP_TERM lop th0_5 + th2 <- runConv convPOLYNOMIAL_NEG #<< rand (concl th1) + liftO $ primTRANS th1 th2 + else if not (isComb lop) + then return $! primREFL tm + else let (op, l) = fromJust $ destComb lop in + if op == tmPow && isNumeral r + then do th0_5 <- runConv convPOLYNOMIAL l + let th1 = fromRight $ liftM1 + ruleAP_THM (ruleAP_TERM op th0_5) r + th2 <- runConv convPOLYNOMIAL_POW #<< + rand (concl th1) + liftO $ primTRANS th1 th2 + else if op == tmAdd || op == tmMul || op == tmSub + then do thl <- runConv convPOLYNOMIAL l + thr <- runConv convPOLYNOMIAL r + let th1 = fromRight $ liftM1 + primMK_COMB (ruleAP_TERM op thl) thr + fn + | op == tmAdd = + convPOLYNOMIAL_ADD + | op == tmMul = + convPOLYNOMIAL_MUL + | otherwise = + convPOLYNOMIAL_SUB + th2 <- runConv fn #<< rand (concl th1) + liftO $ primTRANS th1 th2 + else return $! primREFL tm +-- + return ( convPOLYNOMIAL_NEG, convPOLYNOMIAL_ADD, convPOLYNOMIAL_SUB + , convPOLYNOMIAL_MUL, convPOLYNOMIAL_POW, convPOLYNOMIAL ) + +tmTrue', tmP', tmQ', tmZeron', tmOnen' :: WFCtxt thry => PTerm thry +tmTrue' = [wF| T |] +tmP' = [wF| p:num |] +tmQ' = [wF| q:num |] +tmZeron' = [wF| 0 |] +tmOnen' = [wF| 1 |] + +convNUM_NORMALIZE_sth :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +convNUM_NORMALIZE_sth = cacheProof "convNUM_NORMALIZE_sth" ctxtWF $ + prove [str| (!x y z. x + (y + z) = (x + y) + z) /\ + (!x y. x + y = y + x) /\ + (!x. 0 + x = x) /\ + (!x y z. x * (y * z) = (x * y) * z) /\ + (!x y. x * y = y * x) /\ + (!x. 1 * x = x) /\ + (!x. 0 * x = 0) /\ + (!x y z. x * (y + z) = x * y + x * z) /\ + (!x. x EXP 0 = 1) /\ + (!x n. x EXP (SUC n) = x * x EXP n) |] $ + tacREWRITE [ defEXP, thmMULT_CLAUSES, thmADD_CLAUSES + , thmLEFT_ADD_DISTRIB] `_THEN` + tacREWRITE [thmADD_AC, thmMULT_AC] + +convNUM_NORMALIZE :: (BasicConvs thry, WFCtxt thry) => Conversion cls thry +convNUM_NORMALIZE = Conv $ \ tm -> + do sth <- convNUM_NORMALIZE_sth + rth <- thmTRUTH + (_, _, _, _, _, conv) <- convSEMIRING_NORMALIZERS sth rth + (isNumeral, convNUM_ADD, convNUM_MULT, convNUM_EXP) (<) + runConv conv tm + diff --git a/src/HaskHOL/Lib/Nums.hs b/src/HaskHOL/Lib/Nums.hs new file mode 100644 index 0000000..2a63acc --- /dev/null +++ b/src/HaskHOL/Lib/Nums.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE PatternSynonyms, QuasiQuotes #-} +{-| + Module: HaskHOL.Lib.Nums + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Nums + ( NumsType + , NumsCtxt + , defONE_ONE -- A + , defONTO + , axINFINITY -- B + , thmIND_SUC_0_EXISTS + , defIND_SUC -- C + , defIND_0 + , rulesNUM_REP + , inductNUM_REP + , casesNUM_REP + , tyDefMkNum + , tyDefDestNum + , defZERO + , defSUC + , defNUMERAL + , thmIND_SUC_SPEC -- Stage2 + , thmIND_SUC_INJ -- Stage 3 + , thmIND_SUC_0 + , thmNOT_SUC' --Stage4 + , thmSUC_INJ + , inductionNUM' -- Stage5 + , thmNUM_AXIOM' -- Stage6 + , thmNOT_SUC -- Stage7 + , inductionNUM + , thmNUM_AXIOM + , recursionNUM -- Stage 8 + , recursionStdNUM -- Base + , defBIT0' + , defBIT1 + , tacINDUCT + , mkNumeral + , mkSmallNumeral + , destSmallNumeral + , isNumeral + , newSpecification + , getSpecification + , ruleDENUMERAL + , defBIT0 + , pattern ZERO + , pattern SUC + , pattern NUMERAL + , pattern BIT0 + , pattern BIT1 + ) where + +import HaskHOL.Lib.Nums.B +import HaskHOL.Lib.Nums.Base +import HaskHOL.Lib.Nums.Context + +import HaskHOL.Core +import HaskHOL.Deductive hiding (getDefinition, newDefinition, newSpecification, + getSpecification) +import HaskHOL.Lib.Pair + +defBIT0' :: NumsCtxt thry => HOL cls thry HOLThm +defBIT0' = cacheProof "defBIT0'" ctxtNums $ getDefinition "BIT0" + +defBIT1 :: NumsCtxt thry => HOL cls thry HOLThm +defBIT1 = cacheProof "defBIT1" ctxtNums $ getDefinition "BIT1" + +pattern ZERO <- Const "_0" _ +pattern SUC <- Const "SUC" _ +pattern NUMERAL tm <- Comb (Const "NUMERAL" _) tm +pattern BIT0 tm <- Comb (Const "BIT0" _) tm +pattern BIT1 tm <- Comb (Const "BIT1" _) tm + +data TheSpecifications = + TheSpecifications ![(([Text], HOLThm), HOLThm)] deriving Typeable + +deriveSafeCopy 0 'base ''TheSpecifications + +getSpecifications :: Query TheSpecifications [(([Text], HOLThm), HOLThm)] +getSpecifications = + do (TheSpecifications specs) <- ask + return specs + +getASpecification :: [Text] -> Query TheSpecifications (Maybe HOLThm) +getASpecification names = + do (TheSpecifications specs) <- ask + case find (\ ((names', _), _) -> names' == names) specs of + Just (_, th) -> return $! Just th + Nothing -> return Nothing + +addSpecification :: [Text] -> HOLThm -> HOLThm -> Update TheSpecifications () +addSpecification names th sth = + do (TheSpecifications specs) <- get + put (TheSpecifications (((names, th), sth) : specs)) + +makeAcidic ''TheSpecifications + ['getSpecifications, 'getASpecification, 'addSpecification] + + +defBIT0 :: (BasicConvs thry, NumsCtxt thry) => HOL cls thry HOLThm +defBIT0 = cacheProof "defBIT0" ctxtNums $ + do th <- ruleBETA =<< + ruleISPECL ["0", "\\m n:num. SUC (SUC m)"] recursionNUM + ruleREWRITE [ruleGSYM defBIT0'] =<< ruleSELECT th + +tacINDUCT :: (BasicConvs thry, NumsCtxt thry) => Tactic cls thry +tacINDUCT = tacMATCH_MP inductionNUM `_THEN` tacCONJ `_THENL` + [_ALL, tacGEN `_THEN` tacDISCH] + +mkNumeral :: (Integral i, NumsCtxt thry) => i -> HOL cls thry HOLTerm +mkNumeral n + | n < 0 = fail "mkNumeral: negative argument" + | otherwise = + do numeral <- serve [nums| NUMERAL |] + n' <- mkNum n + liftO $ mkComb numeral n' + where mkNum :: (Integral i, NumsCtxt thry) => i -> HOL cls thry HOLTerm + mkNum x + | x == 0 = serve [nums| _0 |] + | otherwise = + do l <- if x `mod` 2 == 0 then serve [nums| BIT0 |] + else serve [nums| BIT1 |] + r <- mkNum $ x `div` 2 + liftO $ mkComb l r + +mkSmallNumeral :: NumsCtxt thry => Int -> HOL cls thry HOLTerm +mkSmallNumeral = mkNumeral + +destSmallNumeral :: HOLTerm -> Maybe Int +destSmallNumeral = liftM fromInteger . destNumeral + +isNumeral :: HOLTerm -> Bool +isNumeral = isJust . destNumeral + +newSpecification :: (BasicConvs thry, NumsCtxt thry) => [Text] -> HOLThm + -> HOL Theory thry HOLThm +newSpecification [] _ = fail "newSpecification: no constant names provided." +newSpecification names th@(Thm asl c) + | not $ null asl = fail $ "newSpecification: " ++ + "assumptions not allowed in theorem." + | not . null $ frees c = fail $ "newSpecification: " ++ + "free variables in predicate." + | otherwise = + let (avs, _) = stripExists c + ns = length names in + do failWhen (return $ ns > length avs) $ + "newSpecification: too many constant names provided." + failWhen (return $ (length $ nub names) /= ns) $ + "newSpecification: constant names not distinct" + acid <- openLocalStateHOL (TheSpecifications []) + specs <- queryHOL acid GetSpecifications + closeAcidStateHOL acid + case find (\ ((names', th'), _) -> + names' == names && c `aConv` concl th') specs of + Just (_, sth) -> + do warn True "newSpecification: benign respecification." + return sth + _ -> do sth <- specifies names th + acid' <- openLocalStateHOL (TheSpecifications []) + updateHOL acid' (AddSpecification names th sth) + createCheckpointAndCloseHOL acid' + return sth + where specifies :: (BasicConvs thry, NumsCtxt thry) => [Text] -> HOLThm + -> HOL Theory thry HOLThm + specifies [] thm = return thm + specifies (n:ns) thm = + do th' <- specify n thm + specifies ns th' + + specify :: (BasicConvs thry, NumsCtxt thry) => Text -> HOLThm + -> HOL Theory thry HOLThm + specify name thm = + do ntm <- mkCode $ unpack name + gv <- genVar $ typeOf ntm + th0 <- ruleCONV (convREWR thmSKOLEM) =<< ruleGEN gv thm + th1 <- ruleCONV (convRATOR (convREWR thmEXISTS) `_THEN` + convBETA) th0 + let (_, r) = fromJust . destComb $ concl th1 + rn = fromRight $ mkComb r ntm + tm <- mkEq (mkVar name $ typeOf rn) rn + th2 <- newDefinition name tm + th3 <- ruleGSYM th2 + ruleGEN_REWRITE convONCE_DEPTH [th3] =<< ruleSPEC ntm =<< + ruleCONV convBETA th1 + + mkCode :: NumsCtxt thry => String -> HOL cls thry HOLTerm + mkCode name = + foldr1M mkPair =<< mapM (mkNumeral . fromEnum) name +newSpecification _ _ = fail "newSpecification: exhausting warning." + +getSpecification :: [Text] -> HOL cls thry HOLThm +getSpecification names = + do acid <- openLocalStateHOL (TheSpecifications []) + th <- queryHOL acid (GetASpecification names) + closeAcidStateHOL acid + liftMaybe "getSpecification: constants not found." th + +ruleDENUMERAL :: (NumsCtxt thry, HOLThmRep thm cls thry) => thm + -> HOL cls thry HOLThm +ruleDENUMERAL = ruleGEN_REWRITE convDEPTH [defNUMERAL] <=< toHThm + diff --git a/src/HaskHOL/Lib/Nums/A.hs b/src/HaskHOL/Lib/Nums/A.hs new file mode 100644 index 0000000..11189bd --- /dev/null +++ b/src/HaskHOL/Lib/Nums/A.hs @@ -0,0 +1,7 @@ +module HaskHOL.Lib.Nums.A + ( module HaskHOL.Lib.Nums.A.Base + , module HaskHOL.Lib.Nums.A.Context + ) where + +import HaskHOL.Lib.Nums.A.Base +import HaskHOL.Lib.Nums.A.Context diff --git a/src/HaskHOL/Lib/Nums/A/Base.hs b/src/HaskHOL/Lib/Nums/A/Base.hs new file mode 100644 index 0000000..e4c8c16 --- /dev/null +++ b/src/HaskHOL/Lib/Nums/A/Base.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ConstraintKinds, QuasiQuotes #-} +module HaskHOL.Lib.Nums.A.Base where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (getDefinition, newDefinition) + +import HaskHOL.Lib.Pair + + +defONE_ONE' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defONE_ONE' = newDefinition "ONE_ONE" $ + [str| ONE_ONE(f:A->B) = !x1 x2. (f x1 = f x2) ==> (x1 = x2) |] + +defONTO' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defONTO' = newDefinition "ONTO" $ + [str| ONTO(f:A->B) = !y. ?x. y = f x |] + +axINFINITY' :: HOL Theory thry HOLThm +axINFINITY' = newAxiom "axINFINITY" [str| ?f:ind->ind. ONE_ONE f /\ ~(ONTO f) |] + diff --git a/src/HaskHOL/Lib/Nums/A/Context.hs b/src/HaskHOL/Lib/Nums/A/Context.hs new file mode 100644 index 0000000..fd5e40d --- /dev/null +++ b/src/HaskHOL/Lib/Nums/A/Context.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TemplateHaskell, + TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +module HaskHOL.Lib.Nums.A.Context + ( NumsAType + , NumsACtxt + , ctxtNumsA + , numsA + ) where + +import HaskHOL.Core +import HaskHOL.Deductive + +import HaskHOL.Lib.Pair +import HaskHOL.Lib.Pair.Context +import HaskHOL.Lib.Nums.A.Base + +-- generate template types +extendTheory ctxtPair "NumsA" $ + do newType "ind" 0 + sequence_ [defONE_ONE', defONTO'] + void axINFINITY' + +templateProvers 'ctxtNumsA + +-- have to manually write this, for now +type family NumsACtxt a where + NumsACtxt a = (PairCtxt a, NumsAContext a ~ True) + +type instance PolyTheory NumsAType b = NumsACtxt b + +instance BasicConvs NumsAType where + basicConvs _ = basicConvs (undefined :: PairType) diff --git a/src/HaskHOL/Lib/Nums/B.hs b/src/HaskHOL/Lib/Nums/B.hs new file mode 100644 index 0000000..6f512f7 --- /dev/null +++ b/src/HaskHOL/Lib/Nums/B.hs @@ -0,0 +1,7 @@ +module HaskHOL.Lib.Nums.B + ( module HaskHOL.Lib.Nums.B.Base + , module HaskHOL.Lib.Nums.B.Context + ) where + +import HaskHOL.Lib.Nums.B.Base +import HaskHOL.Lib.Nums.B.Context diff --git a/src/HaskHOL/Lib/Nums/B/Base.hs b/src/HaskHOL/Lib/Nums/B/Base.hs new file mode 100644 index 0000000..7f51d8d --- /dev/null +++ b/src/HaskHOL/Lib/Nums/B/Base.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE ConstraintKinds, QuasiQuotes #-} +module HaskHOL.Lib.Nums.B.Base where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (newDefinition, getDefinition) +import HaskHOL.Lib.Pair + +import HaskHOL.Lib.Nums.A + +defONE_ONE :: NumsACtxt thry => HOL cls thry HOLThm +defONE_ONE = cacheProof "defONE_ONE" ctxtNumsA $ getDefinition "ONE_ONE" + +defONTO :: NumsACtxt thry => HOL cls thry HOLThm +defONTO = cacheProof "defONTO" ctxtNumsA $ getDefinition "ONTO" + +axINFINITY :: NumsACtxt thry => HOL cls thry HOLThm +axINFINITY = cacheProof "axINFINITY" ctxtNumsA $ getAxiom "axINFINITY" + +defIND_SUC' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defIND_SUC' = newDefinition "IND_SUC" + [str| IND_SUC = @f:ind->ind. ?z. (!x1 x2. (f x1 = f x2) = (x1 = x2)) /\ + (!x. ~(f x = z)) |] + +defIND_0' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defIND_0' = newDefinition "IND_0" + [str| IND_0 = @z:ind. (!x1 x2. IND_SUC x1 = IND_SUC x2 <=> x1 = x2) /\ + (!x. ~(IND_SUC x = z)) |] + + +indDefNUM_REP'' :: (BasicConvs thry, IndDefsCtxt thry) + => HOL Theory thry (HOLThm, HOLThm, HOLThm) +indDefNUM_REP'' = newInductiveDefinition "NUM_REP" + [str| NUM_REP IND_0 /\ (!i. NUM_REP i ==> NUM_REP (IND_SUC i)) |] + + +tyDefNum'' :: IndDefsCtxt thry => HOLThm -> HOL Theory thry (HOLThm, HOLThm) +tyDefNum'' rep = + newBasicTypeDefinition "num" "mk_num" "dest_num" =<< + ruleCONJUNCT1 rep + +defZERO' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defZERO' = newDefinition "_0" + [str| _0 = mk_num IND_0 |] + + +defSUC' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defSUC' = newDefinition "SUC" + [str| SUC n = mk_num (IND_SUC (dest_num n)) |] + +defNUMERAL' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defNUMERAL' = newDefinition "NUMERAL" + [str| NUMERAL (n:num) = n |] diff --git a/src/HaskHOL/Lib/Nums/B/Context.hs b/src/HaskHOL/Lib/Nums/B/Context.hs new file mode 100644 index 0000000..e46358f --- /dev/null +++ b/src/HaskHOL/Lib/Nums/B/Context.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TemplateHaskell, + TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +module HaskHOL.Lib.Nums.B.Context + ( NumsBType + , NumsBCtxt + , ctxtNumsB + , numsB + ) where + +import HaskHOL.Core +import HaskHOL.Deductive +import HaskHOL.Lib.Pair + +import HaskHOL.Lib.Nums.A.Context +import HaskHOL.Lib.Nums.B.Base + +-- generate template types +extendTheory ctxtNumsA "NumsB" $ + do sequence_ [defIND_SUC', defIND_0'] + (rep, _, _) <- indDefNUM_REP'' + void $ tyDefNum'' rep + sequence_ [defZERO', defSUC', defNUMERAL'] + +templateProvers 'ctxtNumsB + +-- have to manually write this, for now +type family NumsBCtxt a where + NumsBCtxt a = (NumsACtxt a, NumsBContext a ~ True) + +type instance PolyTheory NumsBType b = NumsBCtxt b + +instance BasicConvs NumsBType where + basicConvs _ = basicConvs (undefined :: PairType) + diff --git a/src/HaskHOL/Lib/Nums/Base.hs b/src/HaskHOL/Lib/Nums/Base.hs new file mode 100644 index 0000000..aaf24d8 --- /dev/null +++ b/src/HaskHOL/Lib/Nums/Base.hs @@ -0,0 +1,206 @@ +module HaskHOL.Lib.Nums.Base where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (getDefinition, newDefinition) +import HaskHOL.Lib.Pair + +import HaskHOL.Lib.Nums.B + +defIND_SUC :: NumsBCtxt thry => HOL cls thry HOLThm +defIND_SUC = cacheProof "defIND_SUC" ctxtNumsB $ getDefinition "IND_SUC" + +defIND_0 :: NumsBCtxt thry => HOL cls thry HOLThm +defIND_0 = cacheProof "defIND_0" ctxtNumsB $ getDefinition "IND_0" + +defZERO :: NumsBCtxt thry => HOL cls thry HOLThm +defZERO = cacheProof "defZERO" ctxtNumsB $ getDefinition "_0" + +defSUC :: NumsBCtxt thry => HOL cls thry HOLThm +defSUC = cacheProof "defSUC" ctxtNumsB $ getDefinition "SUC" + +defNUMERAL :: NumsBCtxt thry => HOL cls thry HOLThm +defNUMERAL = cacheProof "defNUMERAL" ctxtNumsB $ getDefinition "NUMERAL" + +rulesNUM_REP :: NumsBCtxt thry => HOL cls thry HOLThm +rulesNUM_REP = cacheProof "rulesNUM_REP" ctxtNumsB $ + do (th, _, _) <- indDefNUM_REP' + return th + +inductNUM_REP :: NumsBCtxt thry => HOL cls thry HOLThm +inductNUM_REP = cacheProof "inductNUM_REP" ctxtNumsB $ + do (_, th, _) <- indDefNUM_REP' + return th + +casesNUM_REP :: NumsBCtxt thry => HOL cls thry HOLThm +casesNUM_REP = cacheProof "casesNUM_REP" ctxtNumsB $ + do (_, _, th) <- indDefNUM_REP' + return th + +indDefNUM_REP' :: NumsBCtxt thry => HOL cls thry (HOLThm, HOLThm, HOLThm) +indDefNUM_REP' = getInductiveDefinition "NUM_REP" + +tyDefMkNum :: NumsBCtxt thry => HOL cls thry HOLThm +tyDefMkNum = cacheProof "tyDefMkNum" ctxtNumsB $ + liftM fst tyDefNum' + +tyDefDestNum :: NumsBCtxt thry => HOL cls thry HOLThm +tyDefDestNum = cacheProof "tyDefDestNum" ctxtNumsB $ + liftM snd tyDefNum' + +tyDefNum' ::NumsBCtxt thry => HOL cls thry (HOLThm, HOLThm) +tyDefNum' = getBasicTypeDefinition "num" + +thmIND_SUC_0_EXISTS :: (BasicConvs thry, NumsBCtxt thry) => HOL cls thry HOLThm +thmIND_SUC_0_EXISTS = cacheProof "thmIND_SUC_0_EXISTS" ctxtNumsB $ + prove [str| ?(f:ind->ind) z. (!x1 x2. (f x1 = f x2) = (x1 = x2)) /\ + (!x. ~(f x = z)) |] $ + tacX_CHOOSE "f:ind -> ind" axINFINITY `_THEN` + tacEXISTS "f:ind -> ind" `_THEN` + _POP_ASSUM tacMP `_THEN` + tacREWRITE [defONE_ONE, defONTO] `_THEN` + tacMESON_NIL + +thmIND_SUC_SPEC :: (BasicConvs thry, NumsBCtxt thry) => HOL cls thry HOLThm +thmIND_SUC_SPEC = cacheProof "thmIND_SUC_SPEC" ctxtNumsB $ + do th1 <- ruleGSYM defIND_SUC + th2 <- ruleREWRITE [th1] =<< ruleSELECT thmIND_SUC_0_EXISTS + th3 <- ruleGSYM defIND_0 + ruleREWRITE [th3] =<< ruleSELECT th2 + +thmIND_SUC_INJ :: (BasicConvs thry, NumsBCtxt thry) => HOL cls thry HOLThm +thmIND_SUC_INJ = cacheProof "thmIND_SUC_INJ" ctxtNumsB $ + liftM fst $ ruleCONJ_PAIR thmIND_SUC_SPEC + +thmIND_SUC_0 :: (BasicConvs thry, NumsBCtxt thry) => HOL cls thry HOLThm +thmIND_SUC_0 = cacheProof "thmIND_SUC_0" ctxtNumsB $ + liftM snd $ ruleCONJ_PAIR thmIND_SUC_SPEC + +thmNUM_ZERO_PRIM :: (BasicConvs thry, NumsBCtxt thry) => HOL cls thry HOLThm +thmNUM_ZERO_PRIM = cacheProof "thmNUM_ZERO_PRIM" ctxtNumsB $ + prove [str| _0 = 0 |] $ tacREWRITE [defNUMERAL] + +thmNOT_SUC' :: (BasicConvs thry, NumsBCtxt thry) => HOL cls thry HOLThm +thmNOT_SUC' = cacheProof "thmNOT_SUC'" ctxtNumsB $ + prove [str| !n. ~(SUC n = _0) |] + (tacREWRITE [defSUC, defZERO] `_THEN` + tacMESON [rulesNUM_REP, tyDefMkNum, tyDefDestNum, thmIND_SUC_0]) + +thmNOT_SUC :: (BasicConvs thry, NumsBCtxt thry) => HOL cls thry HOLThm +thmNOT_SUC = cacheProof "thmNOT_SUC" ctxtNumsB $ + ruleGEN_REWRITE convDEPTH [thmNUM_ZERO_PRIM] =<< thmNOT_SUC' + +thmSUC_INJ :: (BasicConvs thry, NumsBCtxt thry) => HOL cls thry HOLThm +thmSUC_INJ = cacheProof "thmSUC_INJ" ctxtNumsB $ + do (mk, dest) <- pairMapM toHTm ("mk_num", "dest_num") + prove [str| !m n. SUC m = SUC n <=> m = n |] $ + _REPEAT tacGEN `_THEN` tacREWRITE [defSUC] `_THEN` + tacEQ `_THEN` tacDISCH `_THEN` tacASM_REWRITE_NIL `_THEN` + _POP_ASSUM (tacMP . ruleAP_TERM dest) `_THEN` + _SUBGOAL_THEN "!p. NUM_REP (IND_SUC (dest_num p))" tacMP `_THENL` + [ tacGEN `_THEN` + liftM1 tacMATCH_MP (ruleCONJUNCT2 rulesNUM_REP) + , _ALL + ] `_THEN` + tacREWRITE [tyDefMkNum, tyDefDestNum] `_THEN` + tacDISCH `_THEN` tacASM_REWRITE [thmIND_SUC_INJ] `_THEN` + _DISCH_THEN (tacMP . ruleAP_TERM mk) `_THEN` + tacREWRITE [tyDefMkNum] + +inductionNUM' :: (BasicConvs thry, NumsBCtxt thry) => HOL cls thry HOLThm +inductionNUM' = cacheProof "inductionNUM'" ctxtNumsB $ + prove [str| !P. P(_0) /\ (!n. P(n) ==> P(SUC n)) ==> !n. P n |] + (_REPEAT tacSTRIP `_THEN` + tacMP (ruleSPEC [str| \i. NUM_REP i /\ + P(mk_num i):bool |] inductNUM_REP) `_THEN` + tacASM_REWRITE [ruleGSYM defZERO, rulesNUM_REP] `_THEN` + wComb (\ (Goal _ g) -> flip _SUBGOAL_THEN (\ t -> tacREWRITE [t]) . + fromJust $ funpowM 2 lHand g) `_THENL` + [ _REPEAT tacSTRIP `_THENL` + [ liftM1 tacMATCH_MP (ruleCONJUNCT2 rulesNUM_REP) `_THEN` + tacASM_REWRITE_NIL + , _SUBGOAL_THEN "mk_num (IND_SUC i) = SUC (mk_num i)" + tacSUBST1 `_THENL` + [ tacREWRITE [defSUC] `_THEN` _REPEAT tacAP_TERM `_THEN` + tacCONV convSYM `_THEN` + tacREWRITE [ruleGSYM tyDefDestNum] `_THEN` + _FIRST_ASSUM tacMATCH_ACCEPT + , _FIRST_ASSUM tacMATCH_MP `_THEN` _FIRST_ASSUM tacMATCH_ACCEPT + ] + ] + , _DISCH_THEN (tacMP . ruleSPEC "dest_num n") `_THEN` + tacREWRITE [ tyDefMkNum, tyDefDestNum ] + ]) + +inductionNUM :: (BasicConvs thry, NumsBCtxt thry) => HOL cls thry HOLThm +inductionNUM = cacheProof "inductionNUM" ctxtNumsB $ + ruleGEN_REWRITE convDEPTH [thmNUM_ZERO_PRIM] =<< inductionNUM' + +thmNUM_AXIOM' :: (BasicConvs thry, NumsBCtxt thry) => HOL cls thry HOLThm +thmNUM_AXIOM' = cacheProof "thmNUM_AXIOM'" ctxtNumsB $ + prove [str| ! (e:A) f. ?!fn. (fn _0 = e) /\ + (!n. fn (SUC n) = f (fn n) n) |] + (_REPEAT tacGEN `_THEN` tacONCE_REWRITE [thmEXISTS_UNIQUE] `_THEN` + tacCONJ `_THENL` + [ (tacMP . proveInductiveRelationsExist) + [str| PRG _0 e /\ + (!b:A n:num. PRG n b ==> PRG (SUC n) (f b n)) |] `_THEN` + _DISCH_THEN (_CHOOSE_THEN (_CONJUNCTS_THEN2 tacASSUME tacMP)) `_THEN` + _DISCH_THEN (_CONJUNCTS_THEN2 tacASSUME + (tacASSUME . ruleGSYM)) `_THEN` + _SUBGOAL_THEN [str| !n:num. ?!y:A. PRG n y |] tacMP `_THENL` + [ tacMATCH_MP inductionNUM' `_THEN` _REPEAT tacSTRIP `_THEN` + _FIRST_ASSUM (\ th -> tacGEN_REWRITE convBINDER + [ruleGSYM th]) `_THEN` + (\ gl -> do th <- ruleGSYM thmNOT_SUC' + ths <- sequence [ thmNOT_SUC', thmSUC_INJ + , thmEXISTS_UNIQUE_REFL ] + tacREWRITE (th:ths) gl) `_THEN` + tacREWRITE [thmUNWIND1] `_THEN` + tacUNDISCH [str| ?!y. PRG (n:num) (y:A) |] `_THEN` + tacREWRITE [thmEXISTS_UNIQUE] `_THEN` + _DISCH_THEN (_CONJUNCTS_THEN2 (tacX_CHOOSE "y:A") + tacASSUME) `_THEN` + _REPEAT tacSTRIP `_THEN` tacASM_REWRITE_NIL `_THENL` + [ _MAP_EVERY tacEXISTS ["(f:A->num->A) y n", "y:A"] + , tacAP_THM `_THEN` tacAP_TERM `_THEN` _FIRST_ASSUM tacMATCH_MP + ] `_THEN` + tacASM_REWRITE_NIL + , tacREWRITE [thmUNIQUE_SKOLEM_ALT] `_THEN` + _DISCH_THEN (_X_CHOOSE_THEN "fn:num->A" + (tacASSUME . ruleGSYM)) `_THEN` + tacEXISTS "fn:num->A" `_THEN` tacASM_REWRITE_NIL `_THEN` + tacGEN `_THEN` _FIRST_ASSUM (tacMATCH_MP . + ruleCONJUNCT2) `_THEN` + _FIRST_ASSUM (\ th -> tacGEN_REWRITE id [ruleGSYM th]) `_THEN` + tacREFL + ] + , _REPEAT tacSTRIP `_THEN` tacONCE_REWRITE [thmFUN_EQ] `_THEN` + tacMATCH_MP inductionNUM' `_THEN` tacASM_REWRITE_NIL `_THEN` + _REPEAT tacSTRIP `_THEN` tacASM_REWRITE_NIL + ]) + +thmNUM_AXIOM :: (BasicConvs thry, NumsBCtxt thry) => HOL cls thry HOLThm +thmNUM_AXIOM = cacheProof "thmNUM_AXIOM" ctxtNumsB $ + ruleGEN_REWRITE convDEPTH [thmNUM_ZERO_PRIM] =<< thmNUM_AXIOM' + +recursionNUM :: (BasicConvs thry, NumsBCtxt thry) => HOL cls thry HOLThm +recursionNUM = cacheProof "recursionNUM" ctxtNumsB $ + do pth <- thmNUM_AXIOM + let avs = fst . stripForall $ concl pth + ruleGENL avs =<< ruleEXISTENCE =<< ruleSPECL avs pth + +recursionStdNUM :: (BasicConvs thry, NumsBCtxt thry) => HOL cls thry HOLThm +recursionStdNUM = cacheProof "recursionStdNUM" ctxtNumsB $ + prove [str| !e:Z f. ?fn. (fn 0 = e) /\ (!n. fn (SUC n) = f n (fn n)) |] $ + _REPEAT tacGEN `_THEN` + tacMP (ruleISPECL ["e:Z", [str| (\z n. (f:num->Z->Z) n z) |]] + recursionNUM) `_THEN` + tacREWRITE_NIL + +defBIT0'' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defBIT0'' = newDefinition "BIT0" + [str| BIT0 = @fn. fn 0 = 0 /\ (!n. fn (SUC n) = SUC (SUC(fn n))) |] + +defBIT1' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defBIT1' = newDefinition "BIT1" + [str| BIT1 n = SUC (BIT0 n) |] diff --git a/src/HaskHOL/Lib/Nums/Context.hs b/src/HaskHOL/Lib/Nums/Context.hs new file mode 100644 index 0000000..1a6c588 --- /dev/null +++ b/src/HaskHOL/Lib/Nums/Context.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TemplateHaskell, + TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +module HaskHOL.Lib.Nums.Context + ( NumsType + , NumsCtxt + , ctxtNums + , nums + ) where + +import HaskHOL.Core +import HaskHOL.Deductive +import HaskHOL.Lib.Pair + +import HaskHOL.Lib.Nums.B.Context +import HaskHOL.Lib.Nums.Base + +-- generate template types +extendTheory ctxtNumsB "Nums" $ + do indth <- inductionNUM + recth <- recursionStdNUM + addIndDefs [("num", (2, indth, recth))] + sequence_ [defBIT0'', defBIT1'] + +templateProvers 'ctxtNums + +-- have to manually write this, for now +type family NumsCtxt a where + NumsCtxt a = (NumsBCtxt a, NumsContext a ~ True) + +type instance PolyTheory NumsType b = NumsCtxt b + +instance BasicConvs NumsType where + basicConvs _ = basicConvs (undefined :: PairType) diff --git a/src/HaskHOL/Lib/Pair.hs b/src/HaskHOL/Lib/Pair.hs new file mode 100644 index 0000000..e3bb4a5 --- /dev/null +++ b/src/HaskHOL/Lib/Pair.hs @@ -0,0 +1,59 @@ + +module HaskHOL.Lib.Pair + ( PairType + , PairCtxt + , defLET + , defLET_END + , defGABS + , defGEQ + , def_SEQPATTERN + , def_UNGUARDED_PATTERN + , def_GUARDED_PATTERN + , def_MATCH + , def_FUNCTION + , defMK_PAIR + , thmPAIR_EXISTS + , tyDefProd + , defCOMMA + , defFST + , defSND + , thmREP_ABS_PAIR + , thmPAIR_SURJECTIVE + , thmPAIR_EQ + , thmFST + , thmSND + , thmPAIR + , recursionPAIR + , inductPAIR + , defCURRY + , defUNCURRY + , defPASSOC + , convGEN_BETA + , mkPair + , destPair + , newDefinition + , getDefinition + , thmFORALL_PAIR + , createIteratedProjections + , createProjections + ) where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (newDefinition, getDefinition) + +import HaskHOL.Lib.Pair.B +import HaskHOL.Lib.Pair.C +import HaskHOL.Lib.Pair.Base +import HaskHOL.Lib.Pair.Context + + +mkPair :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm +mkPair = mkBinary "," + +destPair :: HOLTerm -> Maybe (HOLTerm, HOLTerm) +destPair = destBinary "," + +thmFORALL_PAIR :: (BasicConvs thry, PairCtxt thry) => HOL cls thry HOLThm +thmFORALL_PAIR = cacheProof "thmFORALL_PAIR" ctxtPair $ + prove "!P. (!p. P p) <=> (!p1 p2. P(p1,p2))" $ + tacMESON [thmPAIR] diff --git a/src/HaskHOL/Lib/Pair/A.hs b/src/HaskHOL/Lib/Pair/A.hs new file mode 100644 index 0000000..f499075 --- /dev/null +++ b/src/HaskHOL/Lib/Pair/A.hs @@ -0,0 +1,7 @@ +module HaskHOL.Lib.Pair.A + ( module HaskHOL.Lib.Pair.A.Base + , module HaskHOL.Lib.Pair.A.Context + ) where + +import HaskHOL.Lib.Pair.A.Base +import HaskHOL.Lib.Pair.A.Context diff --git a/src/HaskHOL/Lib/Pair/A/Base.hs b/src/HaskHOL/Lib/Pair/A/Base.hs new file mode 100644 index 0000000..1af776e --- /dev/null +++ b/src/HaskHOL/Lib/Pair/A/Base.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE ConstraintKinds, QuasiQuotes #-} +module HaskHOL.Lib.Pair.A.Base where + +import HaskHOL.Core +import HaskHOL.Deductive + +defLET' :: BoolCtxt thry => HOL Theory thry HOLThm +defLET' = newDefinition "LET" + [str| LET (f:A->B) x = f x |] + +defLET_END' :: BoolCtxt thry => HOL Theory thry HOLThm +defLET_END' = newDefinition "LET_END" + [str| LET_END (t:A) = t |] + +defGABS' :: BoolCtxt thry => HOL Theory thry HOLThm +defGABS' = newDefinition "GABS" + [str| GABS (P:A->bool) = (@) P |] + +defGEQ' :: BoolCtxt thry => HOL Theory thry HOLThm +defGEQ' = newDefinition "GEQ" + [str| GEQ a b = (a:A = b) |] + +def_SEQPATTERN' :: BoolCtxt thry => HOL Theory thry HOLThm +def_SEQPATTERN' = newDefinition "_SEQPATTERN" + [str| _SEQPATTERN = \ r s x. if ? y. r x y then r x else s x |] + +def_UNGUARDED_PATTERN' :: BoolCtxt thry => HOL Theory thry HOLThm +def_UNGUARDED_PATTERN' = newDefinition "_UNGUARDED_PATTERN" + [str| _UNGUARDED_PATTERN = \ p r. p /\ r |] + +def_GUARDED_PATTERN' :: BoolCtxt thry => HOL Theory thry HOLThm +def_GUARDED_PATTERN' = newDefinition "_GUARDED_PATTERN" + [str| _GUARDED_PATTERN = \ p g r. p /\ g /\ r |] + +def_MATCH' :: BoolCtxt thry => HOL Theory thry HOLThm +def_MATCH' = newDefinition "_MATCH" + [str| _MATCH = \ e r. if (?!) (r e) then (@) (r e) else @ z. F |] + +def_FUNCTION' :: BoolCtxt thry => HOL Theory thry HOLThm +def_FUNCTION' = newDefinition "_FUNCTION" + [str| _FUNCTION = \ r x. if (?!) (r x) then (@) (r x) else @ z. F |] + +defMK_PAIR' :: BoolCtxt thry => HOL Theory thry HOLThm +defMK_PAIR' = newDefinition "mk_pair" + [str| mk_pair (x:A) (y:B) = \ a b. (a = x) /\ (b = y) |] + + diff --git a/src/HaskHOL/Lib/Pair/A/Context.hs b/src/HaskHOL/Lib/Pair/A/Context.hs new file mode 100644 index 0000000..ef7adad --- /dev/null +++ b/src/HaskHOL/Lib/Pair/A/Context.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TemplateHaskell, + TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +module HaskHOL.Lib.Pair.A.Context + ( PairAType + , PairACtxt + , ctxtPairA + , pairA + ) where + +import HaskHOL.Core +import HaskHOL.Deductive + +import HaskHOL.Lib.Pair.A.Base + +-- generate template types +extendTheory ctxtDeductive "PairA" $ + sequence_ [ defLET' + , defLET_END' + , defGABS' + , defGEQ' + , def_SEQPATTERN' + , def_UNGUARDED_PATTERN' + , def_GUARDED_PATTERN' + , def_MATCH' + , def_FUNCTION' + , defMK_PAIR' + ] + +templateProvers 'ctxtPairA + +-- have to manually write this, for now +type family PairACtxt a where + PairACtxt a = (DeductiveCtxt a, PairAContext a ~ True) + +type instance PolyTheory PairAType b = PairACtxt b + +instance BasicConvs PairAType where + basicConvs _ = basicConvs (undefined :: DeductiveType) diff --git a/src/HaskHOL/Lib/Pair/B.hs b/src/HaskHOL/Lib/Pair/B.hs new file mode 100644 index 0000000..b14bbf1 --- /dev/null +++ b/src/HaskHOL/Lib/Pair/B.hs @@ -0,0 +1,7 @@ +module HaskHOL.Lib.Pair.B + ( module HaskHOL.Lib.Pair.B.Base + , module HaskHOL.Lib.Pair.B.Context + ) where + +import HaskHOL.Lib.Pair.B.Base +import HaskHOL.Lib.Pair.B.Context diff --git a/src/HaskHOL/Lib/Pair/B/Base.hs b/src/HaskHOL/Lib/Pair/B/Base.hs new file mode 100644 index 0000000..1714be1 --- /dev/null +++ b/src/HaskHOL/Lib/Pair/B/Base.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleContexts, PatternSynonyms #-} +module HaskHOL.Lib.Pair.B.Base where + +import HaskHOL.Core +import HaskHOL.Deductive + +import HaskHOL.Lib.Pair.A + +defLET :: PairACtxt thry => HOL cls thry HOLThm +defLET = cacheProof "defLET" ctxtPairA $ getDefinition "LET" + +defLET_END :: PairACtxt thry => HOL cls thry HOLThm +defLET_END = cacheProof "defLET_END" ctxtPairA $ getDefinition "LET_END" + +defGABS :: PairACtxt thry => HOL cls thry HOLThm +defGABS = cacheProof "defGABS" ctxtPairA $ getDefinition "GABS" + +defGEQ :: PairACtxt thry => HOL cls thry HOLThm +defGEQ = cacheProof "defGEQ" ctxtPairA $ getDefinition "GEQ" + +def_SEQPATTERN :: PairACtxt thry => HOL cls thry HOLThm +def_SEQPATTERN = cacheProof "def_SEQPATTERN" ctxtPairA $ + getDefinition "_SEQPATTERN" + +def_UNGUARDED_PATTERN :: PairACtxt thry => HOL cls thry HOLThm +def_UNGUARDED_PATTERN = cacheProof "def_UNGUARDED_PATTERN" ctxtPairA $ + getDefinition "_UNGUARDED_PATTERN" + +def_GUARDED_PATTERN :: PairACtxt thry => HOL cls thry HOLThm +def_GUARDED_PATTERN = cacheProof "def_GUARDED_PATTERN" ctxtPairA $ + getDefinition "_GUARDED_PATTERN" + +def_MATCH :: PairACtxt thry => HOL cls thry HOLThm +def_MATCH = cacheProof "def_MATCH" ctxtPairA $ getDefinition "_MATCH" + +def_FUNCTION :: PairACtxt thry => HOL cls thry HOLThm +def_FUNCTION = cacheProof "def_FUNCTION" ctxtPairA $ getDefinition "_FUNCTION" + +defMK_PAIR :: PairACtxt thry => HOL cls thry HOLThm +defMK_PAIR = cacheProof "defMK_PAIR" ctxtPairA $ getDefinition "mk_pair" + +thmPAIR_EXISTS :: (BasicConvs thry, PairACtxt thry) => HOL cls thry HOLThm +thmPAIR_EXISTS = cacheProof "thmPAIR_EXISTS" ctxtPairA $ + prove "? x. ? (a:A) (b:B). x = mk_pair a b" tacMESON_NIL + +tyDefProd' :: (BasicConvs thry, PairACtxt thry) => HOL Theory thry HOLThm +tyDefProd' = newTypeDefinition "prod" "ABS_prod" "REP_prod" thmPAIR_EXISTS + +defCOMMA' :: BoolCtxt thry => HOL Theory thry HOLThm +defCOMMA' = newDefinition "," + [str| ((x:A), (y:B)) = ABS_prod(mk_pair x y) |] + +defFST' :: BoolCtxt thry => HOL Theory thry HOLThm +defFST' = newDefinition "FST" + [str| FST (p:A#B) = @ x. ? y. p = (x, y) |] + +defSND' :: BoolCtxt thry => HOL Theory thry HOLThm +defSND' = newDefinition "SND" + [str| SND (p:A#B) = @ y. ? x. p = (x, y) |] diff --git a/src/HaskHOL/Lib/Pair/B/Context.hs b/src/HaskHOL/Lib/Pair/B/Context.hs new file mode 100644 index 0000000..6dc9167 --- /dev/null +++ b/src/HaskHOL/Lib/Pair/B/Context.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TemplateHaskell, + TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +module HaskHOL.Lib.Pair.B.Context + ( PairBType + , PairBCtxt + , ctxtPairB + , pairB + ) where + +import HaskHOL.Core +import HaskHOL.Deductive + +import HaskHOL.Lib.Pair.A +import HaskHOL.Lib.Pair.B.Base + +-- generate template types +extendTheory ctxtPairA "PairB" $ + do void tyDefProd' + parseAsInfix (",", (14, "right")) + sequence_ [ defCOMMA' + , defFST' + , defSND' + ] + +templateProvers 'ctxtPairB + +-- have to manually write this, for now +type family PairBCtxt a where + PairBCtxt a = (PairACtxt a, PairBContext a ~ True) + +type instance PolyTheory PairBType b = PairBCtxt b + +instance BasicConvs PairBType where + basicConvs _ = basicConvs (undefined :: DeductiveType) diff --git a/src/HaskHOL/Lib/Pair/Base.hs b/src/HaskHOL/Lib/Pair/Base.hs new file mode 100644 index 0000000..857b870 --- /dev/null +++ b/src/HaskHOL/Lib/Pair/Base.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module HaskHOL.Lib.Pair.Base where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (getDefinition, newDefinition) + +import HaskHOL.Lib.Pair.A +import HaskHOL.Lib.Pair.B +import HaskHOL.Lib.Pair.C + + +defCURRY :: PairCCtxt thry => HOL cls thry HOLThm +defCURRY = cacheProof "defCURRY" ctxtPairC $ getDefinition "CURRY" + +defUNCURRY :: PairCCtxt thry => HOL cls thry HOLThm +defUNCURRY = cacheProof "defUNCURRY" ctxtPairC $ getDefinition "UNCURRY" + +defPASSOC :: PairCCtxt thry => HOL cls thry HOLThm +defPASSOC = cacheProof "defPASSOC" ctxtPairC $ getDefinition "PASSOC" + +type ProjectionState = HOLRef ProjectionCache +data ProjectionCache = ProjectionCache !(Map Text [HOLThm]) deriving Typeable + +createProjections :: (BasicConvs thry, ClassicCtxt thry) => ProjectionState + -> Text -> HOL cls thry [HOLThm] +createProjections ref conname = + do (ProjectionCache projs) <- readHOLRef ref + case mapLookup conname projs of + Just ths -> return ths + _ -> + do genty <- getConstType conname + let conty = fromJust . liftM (fst . destTypeOp) $ + (liftM fst . destType) =<< + repeatM (liftM snd . destFunTy) genty + itys <- getIndDefs + (_, _, rth) <- liftMaybe ("createProjections: not in " ++ + "inductive type store") $ + mapLookup conty itys + sth <- ruleSPEC_ALL rth + let (evs, bod) = stripExists $ concl sth + cjs = conjuncts bod + (ourcj, n) = fromJust . findM (\ (x, _) -> + do x' <- rand =<< (lHand . snd $ stripForall x) + (x'', _) <- destConst . fst $ stripComb x' + return $ x'' == conname) $ zip cjs [0..] + (avs, eqn) = stripForall ourcj + (con', args) = stripComb . fromJust $ rand eqn + (aargs, zargs) = fromJust $ chopList (length avs) args + gargs <- mapM (genVar . typeOf) zargs + gcon <- genVar =<< foldrM (mkFunTy . typeOf) + (typeOf . fromJust $ rand eqn) avs + let btm = fromRight $ listMkAbs (aargs++gargs) =<< listMkComb gcon avs + bth = fromJust $ primINST [(con', btm)] sth + cths <- ruleCONJUNCTS #<< + primASSUME (snd . stripExists $ concl bth) + let cth = cths !! n + dth <- ruleCONV (funpow (length avs) convBINDER + (convRAND convBETAS)) cth + let etm = fromJust $ rator =<< + lHand (snd . stripForall $ concl dth) + eth <- ruleSIMPLE_EXISTS etm dth + fth <- liftM (rulePROVE_HYP bth) $ + foldrM ruleSIMPLE_CHOOSE eth evs + let zty = typeOf . fromJust . rand . snd . stripForall $ + concl dth + mkProjector a = + let ity = typeOf a + atm = fromRight $ listMkAbs avs a + th1 = fromJust $ + rulePINST [(zty, ity)] [(gcon, atm)] fth in + do th2 <- ruleSPEC_ALL =<< ruleSELECT =<< + ruleBETA th1 + liftO $ ruleSYM th2 + ths <- mapM mkProjector avs + writeHOLRef ref $ ProjectionCache (mapInsert conname ths projs) + return ths + +convGEQ :: PairACtxt thry => Conversion cls thry +convGEQ = convREWR (ruleGSYM defGEQ) + +ruleDEGEQ :: PairACtxt thry => HOLThm -> HOL cls thry HOLThm +ruleDEGEQ = ruleCONV (convREWR defGEQ) + +ruleGABS :: (BasicConvs thry, PairCCtxt thry) => HOLThm -> HOL cls thry HOLThm +ruleGABS = liftM1 ruleMATCH_MP ruleGABS_pth + where ruleGABS_pth :: (BasicConvs thry, PairCCtxt thry) => HOL cls thry HOLThm + ruleGABS_pth = cacheProof "ruleGABS_pth" ctxtPairC $ + prove "(?) P ==> P (GABS P)" $ + tacSIMP [defGABS, axSELECT, axETA] + +createIteratedProjections :: (BasicConvs thry, ClassicCtxt thry) + => ProjectionState -> HOLTerm + -> HOL cls thry [HOLThm] +createIteratedProjections ref tm + | null $ frees tm = return [] + | isVar tm = return [primREFL tm] + | otherwise = + let (con, _) = stripComb tm in + do prjths <- createProjections ref . fst . fromJust $ destConst con + let atm = fromJust $ rand =<< rand (concl $ head prjths) + instn <- liftO $ termMatch [] atm tm + arths <- mapM (ruleINSTANTIATE instn) prjths + ths <- mapM (\ arth -> + do sths <- createIteratedProjections ref #<< + lHand (concl arth) + mapM (ruleCONV (convRAND $ convSUBS [arth])) sths) arths + return $! unions ths + +convGEN_BETA :: (BasicConvs thry, PairCCtxt thry) => Conversion cls thry +convGEN_BETA = Conv $ \ tm -> + runConv convBETA tm + <|> noteHOL "convGEN_BETA" + (do (l, r) <- liftMaybe "not a combination." $ destComb tm + (vstr, bod) <- liftMaybe "rator not an abstraction." $ destGAbs l + instn <- liftO $ termMatch [] vstr r + ref <- newHOLRef $ ProjectionCache mapEmpty + prjs <- createIteratedProjections ref vstr + bth <- runConv (convSUBS prjs) bod + gv <- genVar $ typeOf vstr + bod' <- liftO $ subst [(vstr, gv)] =<< rand (concl bth) + let pat = fromRight $ mkAbs gv bod' + th1 <- runConv convBETA #<< mkComb pat vstr + let th2 = fromRight $ primTRANS th1 =<< ruleSYM bth + avs = fst . stripForall . fromJust $ body =<< rand l + th3 <- ruleGENL avs th2 + efn <- genVar $ typeOf pat + efn' <- mkExists efn #<< subst [(pat, efn)] (concl th3) + th4 <- ruleEXISTS efn' pat th3 + th5 <- ruleCONV (funpow (length avs + 1) convBINDER convGEQ) th4 + th6 <- ruleCONV convBETA =<< ruleGABS th5 + ruleINSTANTIATE instn =<< ruleDEGEQ =<< ruleSPEC_ALL th6) diff --git a/src/HaskHOL/Lib/Pair/C.hs b/src/HaskHOL/Lib/Pair/C.hs new file mode 100644 index 0000000..1a93db7 --- /dev/null +++ b/src/HaskHOL/Lib/Pair/C.hs @@ -0,0 +1,7 @@ +module HaskHOL.Lib.Pair.C + ( module HaskHOL.Lib.Pair.C.Base + , module HaskHOL.Lib.Pair.C.Context + ) where + +import HaskHOL.Lib.Pair.C.Base +import HaskHOL.Lib.Pair.C.Context diff --git a/src/HaskHOL/Lib/Pair/C/Base.hs b/src/HaskHOL/Lib/Pair/C/Base.hs new file mode 100644 index 0000000..2d2625d --- /dev/null +++ b/src/HaskHOL/Lib/Pair/C/Base.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, FlexibleContexts, + PatternSynonyms, QuasiQuotes, TemplateHaskell, TypeFamilies #-} +module HaskHOL.Lib.Pair.C.Base where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (getDefinition, newDefinition) +import qualified HaskHOL.Deductive as D + +import HaskHOL.Lib.Pair.B + +tyDefProd :: PairBCtxt thry => HOL cls thry HOLThm +tyDefProd = cacheProof "tyDefProd" ctxtPairB $ getTypeDefinition "prod" + +defCOMMA :: PairBCtxt thry => HOL cls thry HOLThm +defCOMMA = cacheProof "defCOMMA" ctxtPairB $ D.getDefinition "," + +defFST :: PairBCtxt thry => HOL cls thry HOLThm +defFST = cacheProof "defFST" ctxtPairB $ D.getDefinition "FST" + +defSND :: PairBCtxt thry => HOL cls thry HOLThm +defSND = cacheProof "defSND" ctxtPairB $ D.getDefinition "SND" + +thmREP_ABS_PAIR :: (BasicConvs thry, PairBCtxt thry) => HOL cls thry HOLThm +thmREP_ABS_PAIR = cacheProof "thmREP_ABS_PAIR" ctxtPairB $ + prove "!(x:A) (y:B). REP_prod (ABS_prod (mk_pair x y)) = mk_pair x y" $ + tacMESON [tyDefProd] + +thmPAIR_SURJECTIVE :: (BasicConvs thry, PairBCtxt thry) => HOL cls thry HOLThm +thmPAIR_SURJECTIVE = cacheProof "thmPAIR_SURJECTIVE" ctxtPairB $ + do tm <- toHTm "ABS_prod:(A->B->bool)->A#B" + (th1, th2) <- ruleCONJ_PAIR tyDefProd + prove "!p:A#B. ?x y. p = x,y" $ + tacGEN `_THEN` tacREWRITE [defCOMMA] `_THEN` + tacMP (ruleSPEC "REP_prod p :A->B->bool" th2) `_THEN` + tacREWRITE [th1] `_THEN` + _DISCH_THEN (_X_CHOOSE_THEN "a:A" + (_X_CHOOSE_THEN "b:B" tacMP)) `_THEN` + _DISCH_THEN (tacMP . ruleAP_TERM tm) `_THEN` + tacREWRITE [th1] `_THEN` _DISCH_THEN tacSUBST1 `_THEN` + _MAP_EVERY tacEXISTS ["a:A", "b:B"] `_THEN` tacREFL + +thmPAIR_EQ :: (BasicConvs thry, PairBCtxt thry) => HOL cls thry HOLThm +thmPAIR_EQ = cacheProof "thmPAIR_EQ" ctxtPairB $ + do tm <- toHTm "REP_prod:A#B->A->B->bool" + prove [str| !(x:A) (y:B) a b. (x,y = a,b) <=> (x = a) /\ (y = b) |] $ + _REPEAT tacGEN `_THEN` tacEQ `_THENL` + [ tacREWRITE [defCOMMA] `_THEN` + _DISCH_THEN (tacMP . ruleAP_TERM tm) `_THEN` + tacREWRITE [thmREP_ABS_PAIR] `_THEN` + tacREWRITE [defMK_PAIR, thmFUN_EQ] + , _ALL + ] `_THEN` + tacMESON_NIL + +thmFST :: (BasicConvs thry, PairBCtxt thry) => HOL cls thry HOLThm +thmFST = cacheProof "thmFST" ctxtPairB $ + prove "!(x:A) (y:B). FST(x,y) = x" $ + _REPEAT tacGEN `_THEN` tacREWRITE[defFST] `_THEN` + tacMATCH_MP thmSELECT_UNIQUE `_THEN` tacGEN `_THEN` tacBETA `_THEN` + tacREWRITE [thmPAIR_EQ] `_THEN` tacEQ `_THEN` + tacSTRIP `_THEN` tacASM_REWRITE_NIL `_THEN` + tacEXISTS "y:B" `_THEN` tacASM_REWRITE_NIL + +thmSND :: (BasicConvs thry, PairBCtxt thry) => HOL cls thry HOLThm +thmSND = cacheProof "thmSND" ctxtPairB $ + prove "!(x:A) (y:B). SND(x,y) = y" $ + _REPEAT tacGEN `_THEN` tacREWRITE [defSND] `_THEN` + tacMATCH_MP thmSELECT_UNIQUE `_THEN` tacGEN `_THEN` tacBETA `_THEN` + tacREWRITE [thmPAIR_EQ] `_THEN` tacEQ `_THEN` + tacSTRIP `_THEN` tacASM_REWRITE_NIL `_THEN` + tacEXISTS "x:A" `_THEN` tacASM_REWRITE_NIL + +thmPAIR :: (BasicConvs thry, PairBCtxt thry) => HOL cls thry HOLThm +thmPAIR = cacheProof "thmPAIR" ctxtPairB $ + prove "!x:A#B. FST x,SND x = x" $ + tacGEN `_THEN` + _X_CHOOSE_THEN "a:A" (_X_CHOOSE_THEN "b:B" tacSUBST1) + (ruleSPEC "x:A#B" thmPAIR_SURJECTIVE) `_THEN` + tacREWRITE [thmFST, thmSND] + +recursionPAIR :: (BasicConvs thry, PairBCtxt thry) => HOL cls thry HOLThm +recursionPAIR = cacheProof "recursionPAIR" ctxtPairB $ + prove "!PAIR'. ?fn:A#B->C. !a0 a1. fn (a0,a1) = PAIR' a0 a1" $ + tacGEN `_THEN` + tacEXISTS [str| \p. (PAIR':A->B->C) (FST p) (SND p) |] `_THEN` + tacREWRITE [thmFST, thmSND] + +inductPAIR :: (BasicConvs thry, PairBCtxt thry) => HOL cls thry HOLThm +inductPAIR = cacheProof "inductPAIR" ctxtPairB $ + prove "!P. (!x y. P (x,y)) ==> !p. P p" $ + _REPEAT tacSTRIP `_THEN` + tacGEN_REWRITE convRAND [ruleGSYM thmPAIR] `_THEN` + _FIRST_ASSUM tacMATCH_ACCEPT + +data Definitions = Definitions !(Map Text HOLThm) deriving Typeable + +deriveSafeCopy 0 'base ''Definitions + +getDefinitions :: Query Definitions [HOLThm] +getDefinitions = + do (Definitions m) <- ask + return $! mapElems m + +getDefinition' :: Text -> Query Definitions (Maybe HOLThm) +getDefinition' lbl = + do (Definitions m) <- ask + return $! mapLookup lbl m + +addDefinition :: Text -> HOLThm -> Update Definitions () +addDefinition lbl th = + do (Definitions m) <- get + put (Definitions (mapInsert lbl th m)) + +addDefinitions :: [(Text, HOLThm)] -> Update Definitions () +addDefinitions m = + put (Definitions (mapFromList m)) + +makeAcidic ''Definitions + ['getDefinitions, 'getDefinition', 'addDefinition, 'addDefinitions] + + +newDefinition :: (BasicConvs thry, PairBCtxt thry, HOLTermRep tm Theory thry) + => Text -> tm -> HOL Theory thry HOLThm +newDefinition lbl ptm = + do acid <- openLocalStateHOL (Definitions mapEmpty) + qth <- queryHOL acid (GetDefinition' lbl) + case qth of + Just th -> + closeAcidStateHOL acid >> return th + Nothing -> noteHOL "newDefinition" $ + do defs <- queryHOL acid GetDefinitions + closeAcidStateHOL acid + tm <- toHTm ptm + let (avs, def) = stripForall tm + (do(th, th') <- tryFind (\ th -> do th' <- rulePART_MATCH Just + th def + return (th, th')) defs + void . rulePART_MATCH Just th' . snd . stripForall $ + concl th + warn True "Benign redefinition" + th'' <- ruleGEN_ALL =<< ruleGENL avs th' + acid' <- openLocalStateHOL (Definitions mapEmpty) + updateHOL acid' (AddDefinition lbl th'') + createCheckpointAndCloseHOL acid' + return th'') + <|> (do (l, r) <- liftMaybe "newDefinition: Not an equation" $ + destEq def + let (fn, args) = stripComb l + args' <- mapM depair args + let (gargs, reps) = (id `ffComb` unions) $ unzip args' + l' = fromRight $ listMkComb fn gargs + r' <- liftO $ subst reps r + th1 <- D.newDefinition lbl =<< mkEq l' r' + let slist = zip gargs args + th2 <- liftM (fromJust . primINST slist) $ + ruleSPEC_ALL th1 + xreps <- liftO $ mapM (subst slist . snd) reps + let conv = convPURE_REWRITE [thmFST, thmSND] + threps <- mapM (\ x -> do x' <- runConv conv x + liftO $ ruleSYM x') xreps + rth <- runConv (convSUBS threps) r + th3 <- liftO $ primTRANS th2 =<< ruleSYM rth + th4 <- ruleGEN_ALL =<< ruleGENL avs th3 + acid' <- openLocalStateHOL (Definitions mapEmpty) + updateHOL acid' (AddDefinition lbl th4) + createCheckpointAndCloseHOL acid' + return th4) + where depair :: HOLTerm -> HOL cls thry (HOLTerm, [(HOLTerm, HOLTerm)]) + depair x = + do gv <- genVar $ typeOf x + args' <- depairRec gv x + return (gv, args') + where depairRec :: HOLTerm -> HOLTerm + -> HOL cls thry [(HOLTerm, HOLTerm)] + depairRec gv arg = + (do (l, r) <- liftO $ destBinary "," arg + l' <- liftM1 depairRec (listMkIComb "FST" [gv]) l + r' <- liftM1 depairRec (listMkIComb "SND" [gv]) r + return $! l' ++ r') + <|> return [(arg, gv)] + +getDefinition :: Text -> HOL cls thry HOLThm +getDefinition lbl = + do acid <- openLocalStateHOL (Definitions mapEmpty) + qth <- queryHOL acid (GetDefinition' lbl) + closeAcidStateHOL acid + liftMaybe ("getDefinition: definition for " ++ show lbl ++ + " not found.") qth + +defCURRY' :: (BasicConvs thry, PairBCtxt thry) => HOL Theory thry HOLThm +defCURRY' = newDefinition "CURRY" + [str| CURRY(f:A#B->C) x y = f(x,y) |] + +defUNCURRY' :: (BasicConvs thry, PairBCtxt thry) => HOL Theory thry HOLThm +defUNCURRY' = newDefinition "UNCURRY" + [str| !f x y. UNCURRY(f:A->B->C)(x,y) = f x y |] + +defPASSOC' :: (BasicConvs thry, PairBCtxt thry) => HOL Theory thry HOLThm +defPASSOC' = newDefinition "PASSOC" + [str| !f x y z. PASSOC (f:(A#B)#C->D) (x,y,z) = f ((x,y),z) |] diff --git a/src/HaskHOL/Lib/Pair/C/Context.hs b/src/HaskHOL/Lib/Pair/C/Context.hs new file mode 100644 index 0000000..584b61d --- /dev/null +++ b/src/HaskHOL/Lib/Pair/C/Context.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TemplateHaskell, + TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +module HaskHOL.Lib.Pair.C.Context + ( PairCType + , PairCCtxt + , ctxtPairC + , pairC + ) where + +import HaskHOL.Core +import HaskHOL.Deductive + +import HaskHOL.Lib.Pair.B +import HaskHOL.Lib.Pair.C.Base + +-- generate template types +extendTheory ctxtPairB "PairC" $ + do extendBasicRewrites =<< sequence [thmFST, thmSND, thmPAIR] + ths <- sequence [ defSND, defFST, defCOMMA, defMK_PAIR + , defGEQ, defGABS, defLET_END, defLET + , def_one, defI, defO, defCOND, def_FALSITY_ + , defTY_EXISTS, defTY_FORALL + , defEXISTS_UNIQUE, defNOT, defFALSE, defOR + , defEXISTS, defFORALL, defIMP, defAND + , defT + ] + let ths' = zip [ "SND", "FST", ",", "mk_pair", "GEQ" + , "GABS", "LET_END", "LET", "one", "I" + , "o", "COND", "_FALSITY_", "??", "!!" + , "?!", "~", "F", "\\/", "?", "!" + , "==>", "/\\", "T" + ] ths + acid <- openLocalStateHOL (Definitions mapEmpty) + updateHOL acid (AddDefinitions ths') + closeAcidStateHOL acid + sequence_ [ defCURRY' + , defUNCURRY' + , defPASSOC' + ] + +templateProvers 'ctxtPairC + +-- have to manually write this, for now +type family PairCCtxt a where + PairCCtxt a = (PairBCtxt a, PairCContext a ~ True) + +type instance PolyTheory PairCType b = PairCCtxt b + +instance BasicConvs PairCType where + basicConvs _ = basicConvs (undefined :: DeductiveType) diff --git a/src/HaskHOL/Lib/Pair/Context.hs b/src/HaskHOL/Lib/Pair/Context.hs new file mode 100644 index 0000000..b5b95bf --- /dev/null +++ b/src/HaskHOL/Lib/Pair/Context.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, QuasiQuotes, + TemplateHaskell, TypeFamilies, TypeSynonymInstances, + UndecidableInstances #-} +module HaskHOL.Lib.Pair.Context + ( PairType + , PairCtxt + , ctxtPair + , pair + ) where + +import HaskHOL.Core +import HaskHOL.Deductive + +import HaskHOL.Lib.Pair.C +import HaskHOL.Lib.Pair.Base + +import Unsafe.Coerce (unsafeCoerce) + +-- generate template types +extendTheory ctxtPairC "Pair" $ + do indth <- inductPAIR + recth <- recursionPAIR + addIndDefs [("prod", (1, indth, recth))] + +templateProvers 'ctxtPair + +-- have to manually write this, for now +type family PairCtxt a where + PairCtxt a = (PairCCtxt a, PairContext a ~ True) + +type instance PolyTheory PairType b = PairCtxt b + +instance BasicConvs PairType where + basicConvs _ = basicConvs (undefined :: DeductiveType) ++ + [("convGEN_BETA", ([str| GABS (\ a. b) c |], convGEN_BETA'))] + + +convGEN_BETA' :: Conversion cls thry +convGEN_BETA' = unsafeCoerce (convGEN_BETA :: Conversion cls PairCType) diff --git a/src/HaskHOL/Lib/Recursion.hs b/src/HaskHOL/Lib/Recursion.hs new file mode 100644 index 0000000..6207520 --- /dev/null +++ b/src/HaskHOL/Lib/Recursion.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE FlexibleContexts, PatternSynonyms #-} +{-| + Module: HaskHOL.Lib.Recursion + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.Recursion + ( newRecursiveDefinition + , getRecursiveDefinition + , proveRecursiveFunctionsExist + ) where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (newSpecification) + +import HaskHOL.Lib.Nums + +data TheRecursiveDefinitions = + TheRecursiveDefinitions !(Map String HOLThm) deriving Typeable + +deriveSafeCopy 0 'base ''TheRecursiveDefinitions + +insertDefinition :: String -> HOLThm -> Update TheRecursiveDefinitions () +insertDefinition lbl thm = + do TheRecursiveDefinitions defs <- get + put (TheRecursiveDefinitions (mapInsert lbl thm defs)) + +getDefinitions :: Query TheRecursiveDefinitions [HOLThm] +getDefinitions = + do TheRecursiveDefinitions defs <- ask + return $! mapElems defs + +getADefinition :: String -> Query TheRecursiveDefinitions (Maybe HOLThm) +getADefinition name = + do (TheRecursiveDefinitions defs) <- ask + return $! name `mapLookup` defs + +makeAcidic ''TheRecursiveDefinitions + ['insertDefinition, 'getDefinitions, 'getADefinition] + + +proveRawRecursiveFunctionsExist :: BoolCtxt thry => HOLThm -> HOLTerm + -> HOL cls thry HOLThm +proveRawRecursiveFunctionsExist ax tm = + let rawcls = conjuncts tm + spcls = map (snd . stripForall) rawcls + lpats = fromJust $ mapM (liftM stripComb . lHand) spcls + ufns = itlist (insert . fst) lpats [] in + do axth <- ruleSPEC_ALL ax + let (exvs, axbody) = stripExists $ concl axth + axcls = conjuncts axbody + f = liftM fst . (destConst <=< repeatM rator <=< rand <=< + lHand . snd . stripForall) + findax (x, _) = lookup x =<< mapM (\ t -> do f' <- f t + return (f', t)) axcls + (raxs, axfns) <- liftMaybe ("proveRawRecursiveFunctionsExist: " ++ + "failed to find.") $ + do raxs <- mapM (findax <=< destConst <=< + repeatM rator . head . snd) lpats + axfns <- mapM (repeatM rator <=< lHand . snd . + stripForall) raxs + return (raxs, axfns) + let urfns = + map (\ v -> lookupd v (setify . zip axfns $ map fst lpats) v) + exvs + axtm <- listMkExists exvs =<< listMkConj raxs + urtm <- listMkExists urfns tm + insts <- liftO $ termMatch [] axtm urtm + ixth <- ruleINSTANTIATE insts axth + let (ixvs, ixbody) = stripExists $ concl ixth + ixtm <- liftO $ subst (zip ixvs urfns) ixbody + ixths <- ruleCONJUNCTS #<< primASSUME ixtm + let rixths = fromJust $ + mapM (\ t -> find (aConv t . concl) ixths) rawcls + rixth <- itlistM ruleSIMPLE_EXISTS ufns =<< + foldr1M ruleCONJ rixths + rixth' <- foldrM ruleSIMPLE_CHOOSE rixth urfns + return $ rulePROVE_HYP ixth rixth' + + +canonize :: BoolCtxt thry => HOLTerm -> HOL cls thry HOLThm +canonize t = + let (avs, bod) = stripForall t + (l, r) = fromJust $ destEq bod + (fn, rarg:vargs) = stripComb l + l' = fromRight $ mkComb fn rarg in + do r' <- liftEither "canonize: failed to build abstraction." $ + listMkAbs vargs r + let fvs = frees rarg + t' <- listMkForall fvs =<< mkEq l' r' + ruleGENL avs =<< ruleRIGHT_BETAS vargs =<< ruleSPECL fvs #<< + primASSUME t' + + +proveCanonRecursiveFunctionsExist :: BoolCtxt thry => HOLThm -> HOLTerm + -> HOL cls thry HOLThm +proveCanonRecursiveFunctionsExist ax tm = + do ths <- mapM canonize $ conjuncts tm + atm <- listMkConj $ map (head . hyp) ths + aths <- ruleCONJUNCTS #<< primASSUME atm + rth <- foldr1M ruleCONJ #<< map2 rulePROVE_HYP aths ths + eth <- proveRawRecursiveFunctionsExist ax atm + let evs = fst . stripExists $ concl eth + fth <- itlistM ruleSIMPLE_CHOOSE evs =<< + foldrM ruleSIMPLE_EXISTS rth evs + return $ rulePROVE_HYP eth fth + + +reshuffle :: HOLTerm -> [HOLTerm] -> [HOLThm] -> HOL cls thry [HOLThm] +reshuffle fn args acc = + let args' = uncurry (flip (++)) $ partition isVar args in + if args' == args then return acc + else do gvs <- mapM (genVar . typeOf) args + let gvs' = fromJust $ mapM (\ x -> x `lookup` zip args gvs) args' + lty <- itlistM (mkFunTy . typeOf) gvs' <#< + funpowM (length gvs) + (liftM (head . tail . snd) . destType) $ typeOf fn + fn' <- genVar lty + def <- mkEq fn #<< listMkAbs gvs =<< listMkComb fn' gvs' + def' <- fromRightM $ primASSUME def + return (def':acc) + + +proveRecursiveFunctionsExist :: BoolCtxt thry => HOLThm -> HOLTerm + -> HOL cls thry HOLThm +proveRecursiveFunctionsExist ax tm = + let rawcls = conjuncts tm + spcls = map (snd . stripForall) rawcls + lpats = fromJust $ mapM (liftM stripComb . lHand) spcls + ufns = foldr (insert . fst) [] lpats + uxargs = fromJust $ mapM (`lookup` lpats) ufns in + do trths <- foldr2M reshuffle [] ufns uxargs + pth <- thmBETA + tth <- runConv (convGEN_REWRITE convREDEPTH (pth:trths)) tm + eth <- proveCanonRecursiveFunctionsExist ax #<< rand (concl tth) + let (evs, ebod) = stripExists $ concl eth + stth <- fromRightM $ ruleSYM tth + fth <- itlistM ruleSIMPLE_EXISTS ufns #<< + primEQ_MP stth #<< primASSUME ebod + gth <- foldrM scrubDef fth $ map concl trths + hth <- foldrM ruleSIMPLE_CHOOSE gth evs + return $ rulePROVE_HYP eth hth + where scrubDef :: BoolCtxt thry => HOLTerm -> HOLThm -> HOL cls thry HOLThm + scrubDef t th = + do (l, r) <- liftMaybe "scrubDef: not an equation." $ destEq t + th' <- ruleDISCH t th + ruleMP (fromJust $ primINST [(l, r)] th') $ primREFL r + + +newRecursiveDefinition :: (BasicConvs thry, NumsCtxt thry, + HOLThmRep thm Theory thry, + HOLTermRep tm Theory thry) => String -> thm -> tm + -> HOL Theory thry HOLThm +newRecursiveDefinition lbl pax ptm = + (do acid <- openLocalStateHOL (TheRecursiveDefinitions mapEmpty) + ths <- queryHOL acid GetDefinitions + closeAcidStateHOL acid + tm <- toHTm ptm + th <- tryFind (findRedefinition tm) ths + warn True "Benign redefinition of recursive function." + return th) + <|> do tm <- toHTm ptm + let rawcls = conjuncts tm + spcls = map (snd . stripForall) rawcls + lpats <- liftMaybe ("newRecursiveDefinition: definition not " ++ + "provided as a conjunction of equations.") $ + mapM (liftM stripComb . lHand) spcls + let ufns = foldr (insert . fst) [] lpats + fvs = map (\ t -> frees t \\ ufns) rawcls + gcls <- map2M listMkForall fvs rawcls + ax <- toHThm pax + eth <- proveRecursiveFunctionsExist ax =<< listMkConj gcls + let (evs, _) = stripExists $ concl eth + dth <- newSpecification (map (fst . fromJust . destVar) evs) eth + dths <- map2M ruleSPECL fvs =<< ruleCONJUNCTS dth + th <- foldr1M ruleCONJ dths + acid <- openLocalStateHOL (TheRecursiveDefinitions mapEmpty) + updateHOL acid (InsertDefinition lbl th) + createCheckpointAndCloseHOL acid + return th + where findRedefinition :: BoolCtxt thry => HOLTerm -> HOLThm + -> HOL cls thry HOLThm + findRedefinition tm th = + do th' <- rulePART_MATCH return th tm + _ <- rulePART_MATCH return th' $ concl th + return th' + +getRecursiveDefinition :: String -> HOL cls thry HOLThm +getRecursiveDefinition lbl = + do acid <- openLocalStateHOL (TheRecursiveDefinitions mapEmpty) + qth <- queryHOL acid (GetADefinition lbl) + closeAcidStateHOL acid + liftMaybe ("getRecursiveDefinition: definition for " ++ lbl ++ + " not found.") qth + diff --git a/src/HaskHOL/Lib/WF.hs b/src/HaskHOL/Lib/WF.hs new file mode 100644 index 0000000..99ec0fd --- /dev/null +++ b/src/HaskHOL/Lib/WF.hs @@ -0,0 +1,109 @@ +{-| + Module: HaskHOL.Lib.WF + Copyright: (c) The University of Kansas 2013 + LICENSE: BSD3 + + Maintainer: ecaustin@ittc.ku.edu + Stability: unstable + Portability: unknown +-} +module HaskHOL.Lib.WF + ( WFType + , WFCtxt + , defWF + , defMEASURE + , defNUMPAIR + , defNUMSUM + , thmWF_LEX_DEPENDENT + , thmWF_IND + , thmWF_LEX + , thmWF_MEASURE_GEN + , wfNUM + , thmWF_MEASURE + , thmMEASURE_LE + , thmWF_FALSE + ) where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (getDefinition) + +import HaskHOL.Lib.Pair +import HaskHOL.Lib.Arith + +import HaskHOL.Lib.WF.Context + +defWF :: WFCtxt thry => HOL cls thry HOLThm +defWF = cacheProof "defWF" ctxtWF $ getDefinition "WF" + +defMEASURE :: WFCtxt thry => HOL cls thry HOLThm +defMEASURE = cacheProof "defMEASURE" ctxtWF $ getDefinition "MEASURE" + +defNUMPAIR :: WFCtxt thry => HOL cls thry HOLThm +defNUMPAIR = cacheProof "defNUMPAIR" ctxtWF $ getDefinition "NUMPAIR" + +defNUMSUM :: WFCtxt thry => HOL cls thry HOLThm +defNUMSUM = cacheProof "defNUMSUM" ctxtWF $ getDefinition "NUMSUM" + +thmWF_LEX_DEPENDENT :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +thmWF_LEX_DEPENDENT = cacheProof "thmWF_LEX_DEPENDENT" ctxtWF . + prove [str| !R:A->A->bool S:A->B->B->bool. WF(R) /\ (!a. WF(S a)) + ==> WF(\(r1,s1) (r2,s2). R r1 r2 \/ (r1 = r2) /\ S r1 s1 s2) |] $ + _REPEAT tacGEN `_THEN` tacREWRITE [defWF] `_THEN` tacSTRIP `_THEN` + tacX_GEN "P:A#B->bool" `_THEN` tacREWRITE [thmLEFT_IMP_EXISTS] `_THEN` + tacGEN_REWRITE id [thmFORALL_PAIR] `_THEN` + _MAP_EVERY tacX_GEN ["a0:A", "b0:B"] `_THEN` tacDISCH `_THEN` + _FIRST_X_ASSUM (tacMP . ruleSPEC [str| \a:A. ?b:B. P(a,b) |]) `_THEN` + tacREWRITE [thmLEFT_IMP_EXISTS] `_THEN` + _DISCH_THEN (tacMP . ruleSPECL ["a0:A", "b0:B"]) `_THEN` + tacASM_REWRITE_NIL `_THEN` + _DISCH_THEN (_X_CHOOSE_THEN "a:A" (_CONJUNCTS_THEN2 tacMP tacASSUME)) + `_THEN` _DISCH_THEN (tacX_CHOOSE "b1:B") `_THEN` + _FIRST_X_ASSUM (tacMP . ruleSPECL ["a:A", [str| \b. (P:A#B->bool) (a,b) |]]) + `_THEN` tacREWRITE [thmLEFT_IMP_EXISTS] `_THEN` + _DISCH_THEN (tacMP . ruleSPEC "b1:B") `_THEN` tacASM_REWRITE_NIL `_THEN` + _DISCH_THEN (_X_CHOOSE_THEN "b:B" (_CONJUNCTS_THEN2 tacMP tacASSUME)) + `_THEN` tacDISCH `_THEN` tacEXISTS "(a:A, b:B)" `_THEN` tacASM_REWRITE_NIL + `_THEN` tacREWRITE [thmFORALL_PAIR] `_THEN` tacASM_MESON_NIL + +thmWF_IND :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +thmWF_IND = cacheProof "thmWF_IND" ctxtWF . + prove [str| WF(<<) <=> !P:A->bool. + (!x. (!y. y << x ==> P(y)) ==> P(x)) ==> !x. P(x) |] $ + tacREWRITE [defWF] `_THEN` tacEQ `_THEN` tacDISCH `_THEN` tacGEN `_THEN` + _POP_ASSUM (tacMP . ruleSPEC [str| \x:A. ~P(x) |]) `_THEN` + tacREWRITE_NIL `_THEN` tacMESON_NIL + +thmWF_MEASURE_GEN :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +thmWF_MEASURE_GEN = cacheProof "thmWF_MEASURE_GEN" ctxtWF . + prove [str| !m:A->B. WF(<<) ==> WF(\x x'. m x << m x') |] $ + tacGEN `_THEN` tacREWRITE [thmWF_IND] `_THEN` _REPEAT tacSTRIP `_THEN` + _FIRST_ASSUM (tacMP . ruleSPEC [str| \y:B. !x:A. (m(x) = y) ==> P x |]) + `_THEN` tacUNDISCH "!x. (!y. (m:A->B) y << m x ==> P y) ==> P x" `_THEN` + tacREWRITE_NIL `_THEN` tacMESON_NIL + +wfNUM :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +wfNUM = cacheProof "wfNUM" ctxtWF . + prove "WF(<)" $ tacREWRITE [thmWF_IND, wfNUM'] + +thmWF_LEX :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +thmWF_LEX = cacheProof "thmWF_LEX" ctxtWF . + prove [str| !R:A->A->bool S:B->B->bool. WF(R) /\ WF(S) + ==> WF(\(r1,s1) (r2,s2). R r1 r2 \/ (r1 = r2) /\ S s1 s2) |] $ + tacSIMP [thmWF_LEX_DEPENDENT, axETA] + +thmWF_MEASURE :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +thmWF_MEASURE = cacheProof "thmWF_MEASURE" ctxtWF . + prove "!m:A->num. WF(MEASURE m)" $ + _REPEAT tacGEN `_THEN` tacREWRITE [defMEASURE] `_THEN` + tacMATCH_MP thmWF_MEASURE_GEN `_THEN` + tacMATCH_ACCEPT wfNUM + +thmMEASURE_LE :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +thmMEASURE_LE = cacheProof "thmMEASURE_LE" ctxtWF . + prove "(!y. MEASURE m y a ==> MEASURE m y b) <=> m(a) <= m(b)" $ + tacREWRITE [defMEASURE] `_THEN` + tacMESON [thmNOT_LE, thmLTE_TRANS, thmLT_REFL] + +thmWF_FALSE :: (BasicConvs thry, WFCtxt thry) => HOL cls thry HOLThm +thmWF_FALSE = cacheProof "thmWF_FALSE" ctxtWF . + prove [str| WF(\x y:A. F) |] $ tacREWRITE [defWF] diff --git a/src/HaskHOL/Lib/WF/Base.hs b/src/HaskHOL/Lib/WF/Base.hs new file mode 100644 index 0000000..3585a2a --- /dev/null +++ b/src/HaskHOL/Lib/WF/Base.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ConstraintKinds, QuasiQuotes #-} +module HaskHOL.Lib.WF.Base where + +import HaskHOL.Core +import HaskHOL.Deductive hiding (getDefinition, newDefinition) + +import HaskHOL.Lib.Pair + +defWF' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defWF' = newDefinition "WF" + [str| WF(<<) <=> + !P:A->bool. (?x. P(x)) ==> (?x. P(x) /\ !y. y << x ==> ~P(y)) |] + +defMEASURE' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defMEASURE' = newDefinition "MEASURE" + [str| MEASURE m = \x y. m(x) < m(y) |] + +defNUMPAIR' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defNUMPAIR' = newDefinition "NUMPAIR" + [str| NUMPAIR x y = (2 EXP x) * (2 * y + 1) |] + + +defNUMSUM' :: (BasicConvs thry, PairCtxt thry) => HOL Theory thry HOLThm +defNUMSUM' = newDefinition "NUMSUM" + "NUMSUM b x = if b then SUC(2 * x) else 2 * x" diff --git a/src/HaskHOL/Lib/WF/Context.hs b/src/HaskHOL/Lib/WF/Context.hs new file mode 100644 index 0000000..c2be43b --- /dev/null +++ b/src/HaskHOL/Lib/WF/Context.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances, TemplateHaskell, + TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +module HaskHOL.Lib.WF.Context + ( WFType + , WFCtxt + , ctxtWF + , wF + ) where + +import HaskHOL.Core +import HaskHOL.Deductive +import HaskHOL.Lib.Pair + +import HaskHOL.Lib.Arith.Context +import HaskHOL.Lib.WF.Base + +-- generate template types +extendTheory ctxtArith "WF" $ + do parseAsInfix ("<<", (12, "right")) + parseAsInfix ("<<<", (12, "right")) + sequence_ [ defWF' + , defMEASURE' + , defNUMPAIR' + , defNUMSUM' + ] + +templateProvers 'ctxtWF + +-- have to manually write this, for now +type family WFCtxt a where + WFCtxt a = (ArithCtxt a, WFContext a ~ True) + +type instance PolyTheory WFType b = WFCtxt b + +instance BasicConvs WFType where + basicConvs _ = basicConvs (undefined :: PairType) diff --git a/src/HaskHOL/Math.hs b/src/HaskHOL/Math.hs new file mode 100644 index 0000000..53082ac --- /dev/null +++ b/src/HaskHOL/Math.hs @@ -0,0 +1,70 @@ +{-| + Module: HaskHOL.Math + 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 basic + mathematical theories of the HaskHOL proof system, ranging from pairs to + semirings. It re-exports all of the math 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.Math + ( -- * Theory Context + -- $ThryCtxt + MathType + , MathCtxt + , ctxtMath + , math + , module HaskHOL.Lib.Pair + , module HaskHOL.Lib.Nums + , module HaskHOL.Lib.Recursion + , module HaskHOL.Lib.Arith + , module HaskHOL.Lib.WF + , module HaskHOL.Lib.CalcNum + , module HaskHOL.Lib.Normalizer + --, module HaskHOL.Lib.Grobner + , module HaskHOL.Lib.IndTypes + , module HaskHOL.Lib.Lists + ) where + +import HaskHOL.Core + +import HaskHOL.Lib.Pair +import HaskHOL.Lib.Nums +import HaskHOL.Lib.Recursion +import HaskHOL.Lib.Arith +import HaskHOL.Lib.WF +import HaskHOL.Lib.CalcNum +import HaskHOL.Lib.Normalizer +--import HaskHOL.Lib.Grobner +import HaskHOL.Lib.IndTypes +import HaskHOL.Lib.Lists + +import HaskHOL.Lib.Lists.Context + +{- $ThryCtxt + See 'extendCtxt' in the "HaskHOL.Core.Ext" module for more information. +-} + +{-| + The theory context type for the math libraries. + An alias to 'ListsType'. +-} +type MathType = ListsType +type MathCtxt a = ListsCtxt a + +{-| + The theory context for the math libraries. + An alias to 'ctxtLists'. +-} +ctxtMath :: TheoryPath MathType +ctxtMath = ctxtLists + +-- | The quasi-quoter for the math libraries. An alias to 'wF'. +math :: QuasiQuoter +math = lists