├── .github └── workflows │ └── build.yml ├── .gitignore ├── .gitmodules ├── .vscode └── tasks.json ├── CeCILL_LICENSE.txt ├── Makefile ├── README.md ├── _CoqProject ├── count-lines.sh ├── opam ├── theories ├── Complexity │ ├── Definitions.v │ ├── EncodableP.v │ ├── LinTimeDecodable.v │ ├── Monotonic.v │ ├── NP.v │ ├── ONotation.v │ ├── ONotationIsAppropriate.v │ ├── PolyTimeComputable.v │ ├── SpaceBoundsTime.v │ ├── Subtypes.v │ └── UpToCPoly.v ├── HierarchyTheorem │ ├── AbstractTimeHierarchyTheorem.v │ └── TimeHierarchyTheorem.v ├── L │ ├── AbstractMachines │ │ ├── AbstractHeapMachine.v │ │ ├── AbstractHeapMachineDef.v │ │ ├── AbstractSubstMachine.v │ │ ├── Computable │ │ │ ├── EvalForTime.v │ │ │ ├── EvalForTimeBool.v │ │ │ ├── HeapMachine.v │ │ │ ├── LargestVar.v │ │ │ ├── Lookup.v │ │ │ ├── Shared.v │ │ │ ├── SubstMachine.v │ │ │ ├── Unfolding.v │ │ │ └── UnivDecTime.v │ │ ├── FlatPro │ │ │ ├── Computable │ │ │ │ ├── Compile.v │ │ │ │ ├── Decompile.v │ │ │ │ ├── HeapStep.v │ │ │ │ ├── JumpTarget.v │ │ │ │ └── LPro.v │ │ │ ├── SizeAnalysisStep.v │ │ │ ├── SizeAnalysisUnfoldClos.v │ │ │ └── SubtermProperty.v │ │ ├── FunctionalDefinitions.v │ │ ├── LambdaDepth.v │ │ ├── TM_LHeapInterpreter │ │ │ ├── LMBounds.v │ │ │ └── LMBounds_Loop.v │ │ ├── UnfoldHeap.v │ │ └── UnfoldTailRec.v │ ├── ComparisonTimeBoundDerivation.v │ ├── Datatypes │ │ ├── LBinNums.v │ │ ├── LComparison.v │ │ ├── LDepPair.v │ │ └── LNat.v │ ├── Functions │ │ ├── BinNums.v │ │ ├── BinNumsAdd.v │ │ ├── BinNumsCompare.v │ │ ├── BinNumsSub.v │ │ └── IterupN.v │ └── TM │ │ ├── CompCode.v │ │ ├── TMflat.v │ │ ├── TMflatComp.v │ │ ├── TMflatEnc.v │ │ ├── TMflatFun.v │ │ ├── TMflatten.v │ │ ├── TMunflatten.v │ │ └── TapeDecode.v ├── Libs │ ├── CookPrelim │ │ ├── FlatFinTypes.v │ │ ├── MorePrelim.v │ │ ├── PolyBounds.v │ │ └── Tactics.v │ ├── PSLCompat.v │ ├── Pigeonhole.v │ └── UniformHomomorphisms.v ├── NP │ ├── Clique │ │ ├── Clique.v │ │ ├── FlatClique.v │ │ ├── FlatUGraph.v │ │ ├── UGraph.v │ │ ├── kSAT_to_Clique.v │ │ └── kSAT_to_FlatClique.v │ ├── L │ │ ├── CanEnumTerm.v │ │ ├── CanEnumTerm_def.v │ │ ├── GenNP.v │ │ ├── GenNPBool.v │ │ ├── GenNP_is_hard.v │ │ └── LMGenNP.v │ ├── SAT │ │ ├── CookLevin.v │ │ ├── CookLevin │ │ │ ├── Reductions │ │ │ │ ├── BinaryCC_to_FSAT.v │ │ │ │ ├── CC_homomorphisms.v │ │ │ │ ├── CC_to_BinaryCC.v │ │ │ │ ├── FlatCC_to_BinaryCC.v │ │ │ │ ├── FlatSingleTMGenNP_to_FlatTCC.v │ │ │ │ ├── FlatTCC_to_FlatCC.v │ │ │ │ ├── PTCC_Preludes.v │ │ │ │ ├── SingleTMGenNP_to_TCC.v │ │ │ │ ├── TCC_to_CC.v │ │ │ │ └── TMGenNP_fixed_singleTapeTM_to_FlatFunSingleTMGenNP.v │ │ │ └── Subproblems │ │ │ │ ├── BinaryCC.v │ │ │ │ ├── CC.v │ │ │ │ ├── FlatCC.v │ │ │ │ ├── FlatTCC.v │ │ │ │ ├── SingleTMGenNP.v │ │ │ │ ├── TCC.v │ │ │ │ └── TM_single.v │ │ ├── FSAT │ │ │ ├── FSAT.v │ │ │ ├── FSAT_to_SAT.v │ │ │ └── FormulaEncoding.v │ │ ├── SAT.v │ │ ├── SAT_inNP.v │ │ ├── SharedSAT.v │ │ ├── kSAT.v │ │ └── kSAT_to_SAT.v │ └── TM │ │ ├── IntermediateProblems.v │ │ ├── LM_to_mTM.v │ │ ├── L_to_LM.v │ │ ├── M_L2TM.v │ │ ├── M_LM2TM.v │ │ ├── M_multi2mono.v │ │ ├── TMGenNP.v │ │ ├── TMGenNP_fixed_mTM.v │ │ └── mTM_to_singleTapeTM.v └── TM │ ├── Code │ ├── Decode.v │ ├── DecodeBool.v │ └── DecodeList.v │ ├── Compound │ └── MoveToSymbol_niceSpec.v │ ├── PrettyBounds │ ├── BaseCode.v │ ├── BaseCodeSpace.v │ ├── M2MBounds.v │ ├── PrettyBounds.v │ ├── SizeBounds.v │ ├── SpaceBounds.v │ ├── UnfoldClosBounds.v │ └── UnivSpaceBounds.v │ └── Single │ ├── DecodeTape.v │ ├── DecodeTapes.v │ └── EncodeTapesInvariants.v └── website ├── .gitignore ├── config.js ├── coqdoc.css ├── coqdocjs.css ├── coqdocjs.js └── resources ├── footer.html └── header.html /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | 2 | name: build 3 | 4 | on: [push, pull_request] 5 | 6 | 7 | jobs: 8 | build: 9 | runs-on: ubuntu-latest 10 | steps: 11 | 12 | - name: Checkout code 13 | uses: actions/checkout@v2 14 | with: 15 | fetch-depth: 1 16 | 17 | - name: Try to restore build cache 18 | id: opam-cache 19 | uses: actions/cache@v2 20 | with: 21 | path: | 22 | ~/.opam 23 | ~/bin 24 | key: ${{ runner.os }}-${{ hashFiles('opam') }} 25 | restore-keys : | 26 | ${{ runner.os }}-${{ hashFiles('opam') }} 27 | ${{ runner.os }}- 28 | 29 | - name: Install OCaml 30 | uses: avsm/setup-ocaml@v1 31 | with: 32 | ocaml-version: 4.09.1+flambda 33 | 34 | - run: opam repo add coq-released https://coq.inria.fr/opam/released 35 | - run: opam update 36 | - run: opam install coq-library-undecidability.1.0.1+8.16 37 | - run: opam exec -- make all -j2 TIMED=1 38 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.aux 2 | *.vo 3 | *.v.d 4 | *.glob 5 | *Makefile.coq 6 | *Makefile.coq.d 7 | *Makefile.coq.conf 8 | *.coqdeps.d 9 | *.lia.cache 10 | *.nia.cache 11 | *.vok 12 | *.vos 13 | 14 | ._CoqProject.tmp -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uds-psl/coq-library-complexity/14b5f413d2fb7adecde79c5451b483f9a1af59a8/.gitmodules -------------------------------------------------------------------------------- /.vscode/tasks.json: -------------------------------------------------------------------------------- 1 | { 2 | // See https://go.microsoft.com/fwlink/?LinkId=733558 3 | // for the documentation about the tasks.json format 4 | "version": "2.0.0", 5 | "tasks": [ 6 | { 7 | "label": "make", 8 | "type": "shell", 9 | "command": "make -j6 -k", 10 | "problemMatcher": [], 11 | "group": { 12 | "kind": "build", 13 | "isDefault": true 14 | } 15 | } 16 | ] 17 | } -------------------------------------------------------------------------------- /CeCILL_LICENSE.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uds-psl/coq-library-complexity/14b5f413d2fb7adecde79c5451b483f9a1af59a8/CeCILL_LICENSE.txt -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: Makefile.coq 2 | $(MAKE) -f Makefile.coq all 3 | 4 | html: Makefile.coq 5 | $(MAKE) -f Makefile.coq html 6 | mv html/*.html ./website 7 | rm -rf html 8 | 9 | install: Makefile.coq 10 | $(MAKE) -f Makefile.coq install 11 | 12 | uninstall: Makefile.coq 13 | $(MAKE) -f Makefile.coq uninstall 14 | 15 | clean: Makefile.coq 16 | $(MAKE) -f Makefile.coq clean 17 | rm -f Makefile.coq Makefile.coq.conf $(TMP_COQPROJECT) 18 | 19 | Makefile.coq: _CoqProject 20 | coq_makefile -f _CoqProject -o Makefile.coq 21 | 22 | .PHONY: all install html clean 23 | 24 | dummy: 25 | 26 | force _CoqProject Makefile: ; 27 | 28 | %: Makefile.coq force 29 | @+$(MAKE) -f Makefile.coq $@ 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # The Coq Library of Complexity Theory 2 | [![build](https://github.com/uds-psl/coq-library-complexity/workflows/build/badge.svg?branch=coq-8.15)](https://github.com/uds-psl/coq-library-complexity/actions) 3 | 4 | This library contains complexity theory formalised in the Coq proof assistant, developed at Saarland University and initiated by Fabian Kunze. It is built upon the [Coq Library of Undecidability Proofs](https://github.com/uds-psl/coq-library-undecidability). 5 | 6 | ## Content 7 | 8 | ### Directory structure 9 | 10 | - `Complexity`: basic notions of complexity theory, formulated for the call-by-value lambda calculus `L` 11 | - `HierarchyTheorem`: the Time Hierarchy Theorem 12 | - `NP`: NP hardness and completeness proofs 13 | - `NP/SAT`: the Cook Levin Theorem 14 | - `L/AbstractMachines`: universal machines for L and their computability and resource analysis 15 | - `L/TM`: the `L`-computability of Turing machine related concepts 16 | - `TM`: the `TM`-computability results and resource analysis of concrete TMs 17 | - `Libs`: internal library files used in multiple other directories 18 | 19 | ## Installation 20 | 21 | ### Building from source 22 | 23 | This library depends on the [Coq Library of Undecidability Proofs](https://github.com/uds-psl/coq-library-undecidability) version 1.0.1. See the installation instructions of this library. It will suffice to install the `opam` package `coq-library-undecidability.1.0.1+8.16`, for instance by `opam install . --deps-only`. 24 | 25 | - `make all` builds the library and the dependencies 26 | - `make html` generates clickable coqdoc `.html` in the `website` subdirectory 27 | - `make clean` removes all build files in `theories` and `.html` files in the `website` directory 28 | 29 | ### Troubleshooting 30 | 31 | #### Version of Coq and dependencies 32 | 33 | Be careful that this branch only compiles under Coq 8.16 34 | and with the Coq Library of Undecidability Proofs, version 1.0.1. 35 | Newer versions of the library are not supported, in particular versions 1.1 and upwards are not supported. 36 | 37 | ## Published work and technical reports 38 | 39 | - Mechanising Complexity Theory: The Cook-Levin Theorem in Coq. Lennard Gäher, Fabian Kunze. ITP 2021. Subdirectory `NP/SAT`. https://doi.org/10.4230/LIPIcs.ITP.2021.20 40 | - A Mechanised Proof of the Time Invariance Thesis for the Weak Call-By-Value λ-Calculus. Yannick Forster, Fabian Kunze, Gert Smolka, Maxi Wuttke. ITP 2021. Subdirectories `L/TM` and `TM`. https://doi.org/10.4230/LIPIcs.ITP.2021.19 41 | - Formal Small-step Verification of a Call-by-value Lambda Calculus Machine. Fabian Kunze, Gert Smolka, and Yannick Forster. APLAS 2018. Subdirectory `L/AbstractMachines`. https://www.ps.uni-saarland.de/extras/cbvlcm2/ 42 | - The Weak Call-By-Value λ-Calculus is Reasonable for Both Time and Space.Yannick Forster, Fabian Kunze, Marc Roth. POPL 2020. Mechanised parts in `L/AbstractMachines` and `SpaceboundsTime.v` https://www.ps.uni-saarland.de/extras/wcbv-reasonable/ 43 | 44 | ### Related Papers and abstracts from the Coq Library of Undecidability Proofs 45 | 46 | We make heavy use of the following results, which for technical reasons are oursourced to the Library of Undecidability Proofs. 47 | 48 | We use two frameworks which ease computability proofs with resource analysis for call-by-value lambda-calculus and Turing machines: 49 | - A certifying extraction with time bounds from Coq to call-by-value lambda-calculus. ITP '19. https://github.com/uds-psl/certifying-extraction-with-time-bounds 50 | - Verified Programming of Turing Machines in Coq. Yannick Forster, Fabian Kunze, Maxi Wuttke. Technical report. https://github.com/uds-psl/tm-verification-framework/ 51 | 52 | ## Contributors 53 | 54 | - Fabian Kunze, Saarland University (2017-2022) 55 | - Lennard Gäher, Saarland University (2017-2021) 56 | - Maxi Wuttke, Saarland University (2017-2021) 57 | - Yannick Forster, Saarland University (2017-2019) 58 | - Stefan Haan (2022) 59 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -Q theories Complexity 2 | 3 | -arg -w -arg -notation-overridden 4 | COQDOCFLAGS = "--charset utf-8 -s --with-header website/resources/header.html --with-footer website/resources/footer.html --index indexpage" 5 | 6 | 7 | theories/Complexity/Definitions.v 8 | theories/Complexity/EncodableP.v 9 | theories/Complexity/LinTimeDecodable.v 10 | theories/Complexity/Monotonic.v 11 | theories/Complexity/NP.v 12 | theories/Complexity/ONotation.v 13 | theories/Complexity/ONotationIsAppropriate.v 14 | theories/Complexity/PolyTimeComputable.v 15 | theories/Complexity/SpaceBoundsTime.v 16 | theories/Complexity/Subtypes.v 17 | theories/Complexity/UpToCPoly.v 18 | 19 | theories/HierarchyTheorem/AbstractTimeHierarchyTheorem.v 20 | theories/HierarchyTheorem/TimeHierarchyTheorem.v 21 | 22 | theories/L/ComparisonTimeBoundDerivation.v 23 | 24 | 25 | theories/L/AbstractMachines/TM_LHeapInterpreter/LMBounds.v 26 | theories/L/AbstractMachines/TM_LHeapInterpreter/LMBounds_Loop.v 27 | theories/L/AbstractMachines/AbstractSubstMachine.v 28 | theories/L/AbstractMachines/AbstractHeapMachine.v 29 | theories/L/AbstractMachines/AbstractHeapMachineDef.v 30 | theories/L/AbstractMachines/UnfoldHeap.v 31 | theories/L/AbstractMachines/FunctionalDefinitions.v 32 | theories/L/AbstractMachines/LambdaDepth.v 33 | theories/L/AbstractMachines/UnfoldTailRec.v 34 | theories/L/AbstractMachines/Computable/Shared.v 35 | theories/L/AbstractMachines/Computable/HeapMachine.v 36 | theories/L/AbstractMachines/Computable/SubstMachine.v 37 | theories/L/AbstractMachines/Computable/Unfolding.v 38 | theories/L/AbstractMachines/Computable/Lookup.v 39 | theories/L/AbstractMachines/Computable/UnivDecTime.v 40 | theories/L/AbstractMachines/Computable/LargestVar.v 41 | theories/L/AbstractMachines/Computable/EvalForTime.v 42 | theories/L/AbstractMachines/Computable/EvalForTimeBool.v 43 | theories/L/AbstractMachines/FlatPro/Computable/Compile.v 44 | theories/L/AbstractMachines/FlatPro/Computable/Decompile.v 45 | theories/L/AbstractMachines/FlatPro/SizeAnalysisStep.v 46 | theories/L/AbstractMachines/FlatPro/SubtermProperty.v 47 | theories/L/AbstractMachines/FlatPro/SizeAnalysisUnfoldClos.v 48 | #L/AbstractMachines/FlatPro/Computable/JumpTarget.v 49 | #L/AbstractMachines/FlatPro/Computable/HeapStep.v 50 | theories/L/AbstractMachines/FlatPro/Computable/LPro.v 51 | 52 | theories/L/Datatypes/LBinNums.v 53 | theories/L/Datatypes/LComparison.v 54 | theories/L/Datatypes/LDepPair.v 55 | theories/L/Functions/IterupN.v 56 | theories/L/Functions/BinNums.v 57 | theories/L/Functions/BinNumsAdd.v 58 | theories/L/Functions/BinNumsSub.v 59 | theories/L/Functions/BinNumsCompare.v 60 | 61 | theories/L/TM/TMflat.v 62 | theories/L/TM/CompCode.v 63 | theories/L/TM/TMunflatten.v 64 | theories/L/TM/TMflatEnc.v 65 | theories/L/TM/TMflatFun.v 66 | theories/L/TM/TMflatComp.v 67 | theories/L/TM/TapeDecode.v 68 | theories/L/TM/TMflatten.v 69 | 70 | 71 | theories/Libs/PSLCompat.v 72 | 73 | 74 | theories/Libs/Pigeonhole.v 75 | theories/Libs/UniformHomomorphisms.v 76 | theories/Libs/CookPrelim/PolyBounds.v 77 | theories/Libs/CookPrelim/Tactics.v 78 | theories/Libs/CookPrelim/MorePrelim.v 79 | theories/Libs/CookPrelim/FlatFinTypes.v 80 | 81 | 82 | 83 | 84 | theories/NP/Clique/Clique.v 85 | theories/NP/Clique/FlatClique.v 86 | theories/NP/Clique/FlatUGraph.v 87 | theories/NP/Clique/kSAT_to_Clique.v 88 | theories/NP/Clique/kSAT_to_FlatClique.v 89 | theories/NP/Clique/UGraph.v 90 | 91 | theories/NP/L/CanEnumTerm_def.v 92 | theories/NP/L/CanEnumTerm.v 93 | theories/NP/L/GenNP_is_hard.v 94 | theories/NP/L/GenNP.v 95 | theories/NP/L/GenNPBool.v 96 | theories/NP/L/LMGenNP.v 97 | 98 | 99 | 100 | 101 | theories/NP/SAT/CookLevin.v 102 | theories/NP/SAT/SharedSAT.v 103 | theories/NP/SAT/SAT.v 104 | theories/NP/SAT/SAT_inNP.v 105 | theories/NP/SAT/kSAT.v 106 | theories/NP/SAT/kSAT_to_SAT.v 107 | 108 | theories/NP/SAT/FSAT/FSAT.v 109 | theories/NP/SAT/FSAT/FormulaEncoding.v 110 | theories/NP/SAT/FSAT/FSAT_to_SAT.v 111 | 112 | theories/NP/SAT/CookLevin/Reductions/TMGenNP_fixed_singleTapeTM_to_FlatFunSingleTMGenNP.v 113 | theories/NP/SAT/CookLevin/Reductions/PTCC_Preludes.v 114 | theories/NP/SAT/CookLevin/Reductions/FlatSingleTMGenNP_to_FlatTCC.v 115 | theories/NP/SAT/CookLevin/Reductions/TCC_to_CC.v 116 | theories/NP/SAT/CookLevin/Reductions/FlatTCC_to_FlatCC.v 117 | theories/NP/SAT/CookLevin/Reductions/CC_homomorphisms.v 118 | theories/NP/SAT/CookLevin/Reductions/CC_to_BinaryCC.v 119 | theories/NP/SAT/CookLevin/Reductions/FlatCC_to_BinaryCC.v 120 | theories/NP/SAT/CookLevin/Reductions/SingleTMGenNP_to_TCC.v 121 | theories/NP/SAT/CookLevin/Reductions/BinaryCC_to_FSAT.v 122 | 123 | theories/NP/SAT/CookLevin/Subproblems/FlatCC.v 124 | theories/NP/SAT/CookLevin/Subproblems/FlatTCC.v 125 | theories/NP/SAT/CookLevin/Subproblems/BinaryCC.v 126 | theories/NP/SAT/CookLevin/Subproblems/CC.v 127 | theories/NP/SAT/CookLevin/Subproblems/TCC.v 128 | theories/NP/SAT/CookLevin/Subproblems/TM_single.v 129 | theories/NP/SAT/CookLevin/Subproblems/SingleTMGenNP.v 130 | 131 | 132 | 133 | 134 | theories/NP/TM/IntermediateProblems.v 135 | theories/NP/TM/L_to_LM.v 136 | theories/NP/TM/LM_to_mTM.v 137 | theories/NP/TM/M_LM2TM.v 138 | theories/NP/TM/M_multi2mono.v 139 | theories/NP/TM/mTM_to_singleTapeTM.v 140 | theories/NP/TM/TMGenNP_fixed_mTM.v 141 | theories/NP/TM/TMGenNP.v 142 | 143 | 144 | 145 | 146 | 147 | 148 | theories/TM/Compound/MoveToSymbol_niceSpec.v 149 | theories/TM/Code/Decode.v 150 | theories/TM/Code/DecodeList.v 151 | theories/TM/Code/DecodeBool.v 152 | theories/TM/Single/EncodeTapesInvariants.v 153 | theories/TM/Single/DecodeTape.v 154 | theories/TM/Single/DecodeTapes.v 155 | 156 | # PrettyBounds 157 | theories/TM/PrettyBounds/PrettyBounds.v 158 | theories/TM/PrettyBounds/BaseCode.v 159 | theories/TM/PrettyBounds/M2MBounds.v 160 | 161 | theories/TM/PrettyBounds/SpaceBounds.v 162 | theories/TM/PrettyBounds/SizeBounds.v 163 | theories/TM/PrettyBounds/BaseCodeSpace.v 164 | theories/TM/PrettyBounds/UnfoldClosBounds.v 165 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "dev+8.16" 3 | maintainer: "kunze@ps.uni-saarland.de" 4 | homepage: "https://github.com/uds-psl/coq-library-complexity/" 5 | dev-repo: "git+https://github.com/uds-psl/coq-library-complexity/" 6 | bug-reports: "https://github.com/uds-psl/coq-library-complexity/issues" 7 | authors: ["Fabian Kunze" 8 | "Lennard Gäher" 9 | "Maximilian Wuttke" 10 | "Yannick Forster" 11 | "Stefan Haan"] 12 | license: "CeCILL" 13 | build: [ 14 | [make "-j%{jobs}%"] 15 | ] 16 | install: [ 17 | [make "install"] 18 | ] 19 | remove: [ 20 | ["rm" "-R" "%{lib}%/coq/user-contrib/Complexity"] 21 | ] 22 | depends: [ 23 | "coq" {>= "8.16" & < "8.17"} 24 | "coq-library-undecidability" {= "1.0.1+8.16" } 25 | ] 26 | 27 | synopsis: "A Coq Library of Complexity Theory" 28 | flags: light-uninstall 29 | url { 30 | git: "https://github.com/uds-psl/coq-library-complexity#coq-8.16" 31 | } 32 | -------------------------------------------------------------------------------- /theories/Complexity/EncodableP.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L.Tactics Require Import LTactics. 2 | From Undecidability.L.Datatypes Require Import LProd LTerm. 3 | 4 | From Undecidability.L Require Import Functions.Encoding. 5 | From Complexity Require Import Complexity.Monotonic . 6 | 7 | Class encodableP `(X:Type) `{encodable X}: Type := 8 | { 9 | c__regP : nat; 10 | comp_enc_lin : computableTime' (enc (X:=X)) (fun x _ => (size (enc x) *c__regP,tt)); 11 | }. 12 | 13 | Arguments encodableP : clear implicits. 14 | Arguments encodableP _ {_}. 15 | Arguments c__regP : clear implicits. 16 | Arguments c__regP _ {_ _} : simpl never. 17 | Global Hint Mode encodableP + + : typeclass_instances. (* treat argument as input and force evar-freeness*) 18 | 19 | #[export] 20 | Existing Instance comp_enc_lin. 21 | #[export] 22 | Typeclasses Opaque enc. 23 | 24 | 25 | #[export] 26 | Instance regP_nat : encodableP nat. 27 | Proof. 28 | evar (c:nat). 29 | exists c. 30 | eexists _. 31 | eapply computesTime_timeLeq. 32 | 2:now apply term_nat_enc. 33 | repeat intro. split. 2:easy. 34 | cbn [fst]. rewrite -> size_nat_enc. [c]:exact 14. unfold c, c__natsizeS, c__natsizeO. nia. 35 | Qed. 36 | 37 | 38 | #[export] 39 | Instance regP_term : encodableP term. 40 | Proof. 41 | evar (c:nat). 42 | exists c. 43 | eexists _. 44 | eapply computesTime_timeLeq. 45 | 2:now apply term_term_enc. 46 | repeat intro. split. 2:easy. 47 | cbn [fst]. rewrite -> size_term_enc_r. [c]:exact 30. unfold c. nia. 48 | Qed. 49 | 50 | #[export] 51 | Instance regP_Prod X Y `{encodableP X} `{encodableP Y}: encodableP (X*Y). 52 | Proof. 53 | evar (c:nat). 54 | exists c. 55 | eexists _. 56 | eapply computesTime_timeLeq. 57 | 2:now apply term_prod_enc. 58 | intros [] _. split. 2:easy. 59 | cbn [fst]. rewrite -> size_prod. 60 | cbn. [c]:exact (c__regP X + c__regP Y + 4). unfold c. nia. 61 | Qed. 62 | 63 | From Undecidability.L.Datatypes Require Import Lists. 64 | 65 | #[export] 66 | Instance regP_list X `{encodableP X}: encodableP (list X). 67 | Proof. 68 | evar (c:nat). 69 | exists c. 70 | eexists _. 71 | eapply computesTime_timeLeq. 72 | 2:now apply term_list_enc. 73 | intros l _. split. 2:easy. 74 | cbn [fst]. rewrite -> size_list. 75 | cbn. [c]:exact (c__regP X + 17). unfold c, c__listsizeCons, c__listsizeNil. 76 | induction l;cbn. all:nia. 77 | Qed. 78 | 79 | Import LOptions. 80 | 81 | #[export] 82 | Instance regP_option X `{encodableP X}: encodableP (option X). 83 | Proof. 84 | evar (c:nat). 85 | exists c. 86 | eexists _. 87 | eapply computesTime_timeLeq. 88 | 2:now apply term_option_enc. 89 | intros l _. split. 2:easy. 90 | cbn [fst]. rewrite -> size_option. 91 | [c]:exact (c__regP X + 5). unfold c. 92 | now destruct l. 93 | Qed. 94 | 95 | #[export] 96 | Instance regP_bool : encodableP bool. 97 | Proof. 98 | evar (c:nat). 99 | exists c. 100 | eexists _. 101 | eapply computesTime_timeLeq. 102 | 2:now apply bool_enc. 103 | intros l _. split. 2:easy. 104 | unfold enc;cbn. 105 | [c]:exact (4). unfold c. 106 | destruct l;cbn [size ]. all:lia. 107 | Qed. 108 | -------------------------------------------------------------------------------- /theories/Complexity/LinTimeDecodable.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L.Tactics Require Import LTactics. 2 | From Undecidability.L.Datatypes Require Import LNat Lists LTerm LOptions LUnit. 3 | 4 | From Undecidability.L.Complexity.LinDecode Require Export LTD_def LTDbool LTDlist LTDnat. 5 | 6 | From Undecidability.L Require Import Functions.Decoding. 7 | 8 | 9 | #[export] 10 | Instance linDec_unit : linTimeDecodable unit. 11 | Proof. 12 | evar (c : nat). exists c. 13 | unfold decode, decode_unit. cbn. extract. 14 | solverec. [c]: exact 5. all: unfold c; lia. 15 | Qed. 16 | 17 | #[export] 18 | Instance linDec_term : linTimeDecodable term. 19 | Proof. 20 | evar (c:nat). exists c. 21 | unfold decode,decode_term;cbn. extract. 22 | recRel_prettify2;cbn[size];ring_simplify. 23 | [c]:exact (max (c__linDec nat) 10). 24 | all:unfold c;try nia. 25 | Qed. 26 | 27 | #[export] 28 | Instance linDec_prod X Y `{_ : linTimeDecodable X} `{_:linTimeDecodable Y} : linTimeDecodable (X * Y). 29 | Proof. 30 | evar (c : nat). exists c. 31 | unfold decode, decode_prod, prod_decode; cbn. 32 | extract. recRel_prettify2; cbn [size]; ring_simplify. 33 | [c]: exact (max (max (c__linDec X) (c__linDec Y)) 14). all: unfold c; try nia. 34 | Qed. 35 | 36 | #[export] 37 | Instance linDec_sum X Y `{_ : linTimeDecodable X} `{_:linTimeDecodable Y} : linTimeDecodable (X + Y). 38 | Proof. 39 | evar (c : nat). exists c. 40 | unfold decode, decode_sum, sum_decode; cbn. 41 | extract. recRel_prettify2; cbn [size]; ring_simplify. 42 | [c]: exact (max (max (c__linDec X) (c__linDec Y)) 14). all: unfold c; try nia. 43 | Qed. 44 | 45 | -------------------------------------------------------------------------------- /theories/Complexity/Monotonic.v: -------------------------------------------------------------------------------- 1 | From smpl Require Import Smpl. 2 | From Undecidability Require Import L.Prelim.MoreBase. 3 | Definition monotonic (f:nat -> nat) : Prop := 4 | forall x x', x <= x' -> f x <= f x'. 5 | 6 | Lemma monotonic_c c: monotonic (fun _ => c). 7 | Proof. 8 | hnf. 9 | intros **. easy. 10 | Qed. 11 | 12 | 13 | Lemma monotonic_add f1 f2: monotonic f1 -> monotonic f2 -> monotonic (fun x => f1 x + f2 x). 14 | Proof. 15 | unfold monotonic. 16 | intros H1 H2 **. 17 | rewrite H1,H2. reflexivity. all:eassumption. 18 | Qed. 19 | 20 | Lemma monotonic_S f : monotonic f -> monotonic (fun x => S (f x)). 21 | Proof. 22 | intros H. eapply (@monotonic_add (fun _ => 1) f); [apply monotonic_c | apply H]. 23 | Qed. 24 | 25 | Lemma monotonic_mul f1 f2: monotonic f1 -> monotonic f2 -> monotonic (fun x => f1 x * f2 x). 26 | Proof. 27 | unfold monotonic. 28 | intros H1 H2 **. 29 | rewrite H1,H2. reflexivity. all:eassumption. 30 | Qed. 31 | 32 | Require Import Nat. 33 | Lemma monotonic_pow_c f1 c: monotonic f1 -> monotonic (fun x => (f1 x) ^ c). 34 | Proof. 35 | intros **. 36 | unfold monotonic. 37 | intros H1 **. eapply PeanoNat.Nat.pow_le_mono_l. apply H. easy. 38 | Qed. 39 | 40 | Lemma monotonic_x: monotonic (fun x => x). 41 | Proof. 42 | unfold monotonic. easy. 43 | Qed. 44 | 45 | Lemma monotonic_comp f1 f2: monotonic f1 -> monotonic f2 -> monotonic (fun x => f1 (f2 x)). 46 | Proof. 47 | unfold monotonic. 48 | intros H1 H2 **. 49 | rewrite H1. reflexivity. eauto. 50 | Qed. 51 | 52 | Smpl Create monotonic. 53 | Smpl Add 10 (first [ simple eapply monotonic_add | simple eapply monotonic_S | simple eapply monotonic_mul | simple eapply monotonic_c | simple eapply monotonic_x | simple eapply monotonic_pow_c] ) : monotonic. 54 | 55 | Smpl Add 20 (lazymatch goal with 56 | |- monotonic (fun x => ?f (@?g x)) => 57 | (lazymatch g with 58 | | fun x => x => fail 59 | | _ => simple eapply monotonic_comp 60 | end) 61 | end) : monotonic. 62 | 63 | #[export] 64 | Instance monotonic_pointwise_eq: Proper ((pointwise_relation _ eq) ==> iff) monotonic. 65 | Proof. 66 | intros ? ? R1. unfold monotonic. setoid_rewrite R1. all:easy. 67 | Qed. 68 | 69 | (* 70 | Inductive TTnat: Type -> Type := 71 | TTnatBase : TTnat nat 72 | | TTnatArr X Y (ttx : TTnat X) (tty : TTnat Y) : TTnat (X -> Y). 73 | 74 | Arguments TTnatArr _ _ {_ _}. 75 | Existing Class TTnat. 76 | #[export] 77 | Existing Instances TTnatBase TTnatArr. 78 | 79 | 80 | Fixpoint leHO {ty} {tt : TTnat ty} : ty -> ty -> Prop := 81 | match tt with 82 | TTnatBase => le 83 | | TTnatArr X Y => respectful (@leHO X _) (@leHO Y _) 84 | end. 85 | Arguments leHO : simpl never. 86 | 87 | (* 88 | #[export] 89 | Instance leHO_Pointwise_le X Y (ttx : TTnat X) (tty : TTnat Y) (f g : X -> Y): 90 | Proper 91 | Pointwise (@leHO _ ttx ==> leqHO _ tty).*) 92 | 93 | Notation "'monotonicHO'" := (Proper leHO) (at level 0). 94 | 95 | (*) 96 | Lemma leHO_monotonic (f : nat -> nat) : 97 | monotonic f <-> monotonicHO f. 98 | Proof. 99 | reflexivity. 100 | Qed. 101 | 102 | Module test. 103 | Variable f : nat -> nat -> nat. 104 | Context {Hf : monotonicHO f}. 105 | 106 | Goal forall x y y', y <= y' -> f x y <= f x y'. 107 | Proof. 108 | pose Hf. 109 | intros. now setoid_rewrite H. 110 | Qed. 111 | End test. 112 | 113 | *)*) 114 | -------------------------------------------------------------------------------- /theories/Complexity/ONotationIsAppropriate.v: -------------------------------------------------------------------------------- 1 | From Undecidability Require Import PSL.Prelim L.Prelim.MoreBase. 2 | From Complexity.Complexity Require Import Monotonic ONotation. 3 | Require Import smpl.Smpl. 4 | Require Import Nat Lia. 5 | 6 | Lemma inO_bound_reverse f g : 7 | (exists n0, forall n, n0 <= n -> g n > 0) 8 | -> (exists c, forall n, f n <= c + c * g n) -> f ∈O g. 9 | Proof. 10 | intros (n0&pos) (c&H). hnf. setoid_rewrite H. 11 | eexists (2*c),n0. intros n ?%pos. nia. 12 | Qed. 13 | 14 | Lemma inO_equiv_pointwise f g (gNonZero : exists n0, forall n, n0 <= n -> g n > 0): 15 | f ∈O g <-> exists c, forall n, f n <= c + c * g n. 16 | Proof. 17 | split;eauto 10 using inO__bound, inO_bound_reverse. 18 | Qed. 19 | 20 | 21 | Lemma inO_equiv_pointwise2 f g : (f ∈O (fun n => 1 + g n) <-> exists c, forall n, f n <= c + c * g n). 22 | Proof. 23 | rewrite inO_equiv_pointwise. 2:{exists 0. intros;nia. } 24 | split. all:intros (c&Hc). 25 | -exists (2*c). intros. rewrite Hc. nia. 26 | -exists c. intros. rewrite Hc. nia. 27 | Qed. 28 | 29 | Require ZArith. 30 | From Coq.QArith Require QArith Qabs Qround. 31 | Module smallo_equiv. 32 | Import QArith Qabs Qround ZArith. 33 | Close Scope nat_scope. 34 | Definition inoR (f g : Q -> Q) := 35 | (forall ε, 0 < ε -> exists x0, forall x : Q, x0 <= x -> Qabs (f x) < ε * (Qabs (g x)))%Q. 36 | 37 | Definition NtoQ x := inject_Z (Z.of_nat x). 38 | Definition QtoNceil x:= Z.to_nat (Qceiling (Qabs x)). 39 | 40 | 41 | Lemma NtoQ_inj_lt n m : (n < m)%nat <-> (NtoQ n < NtoQ m)%Q. 42 | Proof. 43 | rewrite Nat2Z.inj_lt,Zlt_Qlt. easy. 44 | Qed. 45 | 46 | Lemma NtoQ_inj_le n m : (n <= m)%nat <-> (NtoQ n <= NtoQ m)%Q. 47 | Proof. 48 | rewrite Nat2Z.inj_le,Zle_Qle. easy. 49 | Qed. 50 | 51 | Lemma NtoQ_inj_add n m : (NtoQ (n+m) = NtoQ n + NtoQ m)%Q. 52 | Proof. 53 | unfold NtoQ. rewrite Nat2Z.inj_add,inject_Z_plus. easy. 54 | Qed. 55 | 56 | Lemma NtoQ_inj_mult n m : (NtoQ (n*m) = NtoQ n * NtoQ m)%Q. 57 | Proof. 58 | unfold NtoQ. rewrite Nat2Z.inj_mul,inject_Z_mult. easy. 59 | Qed. 60 | 61 | Lemma NtoQ_id n : QtoNceil (NtoQ n) = n. 62 | Proof. 63 | unfold QtoNceil,NtoQ. rewrite Qabs_pos,Qceiling_Z,Nat2Z.id. easy. apply NtoQ_inj_le with (n:=0%nat). nia. 64 | Qed. 65 | 66 | Lemma QtoN_ceil q : NtoQ (QtoNceil q) = inject_Z (Qceiling (Qabs q)). 67 | Proof. 68 | unfold QtoNceil,NtoQ. rewrite Z2Nat.id. easy. apply Qceiling_resp_le with (x:=0%Q), Qabs_nonneg. 69 | Qed. 70 | 71 | Definition liftR (f : nat -> nat) (x:Q) := NtoQ (f (QtoNceil x)). 72 | 73 | Lemma NtoQ_pos x : 0 <= NtoQ x. 74 | Proof. 75 | unfold liftR. change 0 with (inject_Z 0). unfold NtoQ. rewrite <- Zle_Qle. lia. 76 | Qed. 77 | 78 | 79 | #[export] 80 | Hint Resolve NtoQ_pos : core. 81 | Lemma ino_agree_real f g (fNonZero : (exists n0, forall x, n0 <= x -> 0 < f x)%nat) : 82 | f ∈o g <-> inoR (liftR f) (liftR g). 83 | Proof. 84 | Local Hint Resolve Qlt_le_weak Qinv_lt_0_compat : core. 85 | destruct fNonZero as [c__fnz fNonZero]. split. all:unfold inoR, ino. 86 | -intros H ε ?. specialize (H (Z.to_nat (Qceiling (/ε)) + 1)%nat) as (n0&H). 87 | exists (NtoQ (max n0 (max 0 c__fnz))). intros x Hx. 88 | eapply Qmult_lt_l with (z:=/ε). now auto. 89 | rewrite Qmult_assoc,Qmult_comm with (y:=ε), Qmult_inv_r, Qmult_1_l. 2:now apply Qnot_eq_sym,Qlt_not_eq. 90 | assert (max n0 (max 0 c__fnz) <= QtoNceil x)%nat. 91 | { apply (Qle_trans) with (z:= inject_Z (Qceiling (Qabs x))) in Hx. 92 | 2:{rewrite Qabs_pos. now apply Qle_ceiling. eapply Qle_trans. 2:exact Hx. apply NtoQ_inj_le with (n:=0%nat). nia. } 93 | apply NtoQ_inj_le. now rewrite QtoN_ceil. 94 | } 95 | eassert (Hx' : (n0 <= _)%nat). 96 | 2:{ 97 | specialize H with (1:=Hx') as H'. rewrite NtoQ_inj_lt in H'. rewrite NtoQ_inj_mult,NtoQ_inj_add in H'. 98 | replace (Z.to_nat (Qceiling (/ ε))) with (QtoNceil (/ ε)) in H'. 2:{ unfold QtoNceil. rewrite Qabs_pos. all:now eauto. } 99 | rewrite !Qabs_pos. 2-3:now apply NtoQ_pos. 100 | eapply Qlt_trans. 2:exact H'. rewrite QtoN_ceil. 101 | eapply Qmult_lt_compat_r. 102 | {setoid_rewrite <- NtoQ_inj_lt with (n:=0%nat). apply fNonZero. nia. } 103 | rewrite Qabs_pos. 2:now eauto. 104 | eapply Qle_lt_trans. eapply Qle_ceiling. rewrite <- inject_Z_plus with (y:=1%Z),<- Zlt_Qlt. nia. 105 | } 106 | nia. 107 | -intros H c. edestruct (H (/ (NtoQ (c + 1)))) as [x0 Hx0]. 108 | { apply Qinv_lt_0_compat. apply NtoQ_inj_lt with (n:=0%nat). nia. } 109 | exists (max 0 (QtoNceil x0)). intros n Hn. 110 | rewrite NtoQ_inj_lt, NtoQ_inj_mult. 111 | specialize (Hx0 (NtoQ n)). unfold liftR in Hx0. rewrite NtoQ_id in Hx0. 112 | setoid_rewrite Qabs_pos in Hx0. 2,3:now eauto. 113 | rewrite <- Qmult_lt_l with (z:=NtoQ (c+1)) in Hx0. 2:{ 114 | apply NtoQ_inj_lt with (n:=0%nat). nia. } 115 | rewrite Qmult_assoc, Qmult_inv_r in Hx0. 2:{ apply Qnot_eq_sym,Qlt_not_eq. apply NtoQ_inj_lt with (n:=0%nat). nia. } 116 | rewrite Qmult_1_l in Hx0. 117 | eapply Qle_lt_trans. 118 | 2:{ apply Hx0. rewrite NtoQ_inj_le in Hn. eapply Qle_trans. 2:exact Hn. 119 | eapply Qle_trans. now apply Qle_ceiling. eapply Qle_trans. 2:now apply NtoQ_inj_le,Nat.le_max_r. 120 | rewrite QtoN_ceil. rewrite <- Zle_Qle. apply Qceiling_resp_le. apply Qle_Qabs. 121 | } 122 | rewrite <- !NtoQ_inj_mult, <- NtoQ_inj_le. nia. 123 | Qed. 124 | 125 | End smallo_equiv. 126 | 127 | -------------------------------------------------------------------------------- /theories/Complexity/Subtypes.v: -------------------------------------------------------------------------------- 1 | Require Export Complexity.L.Datatypes.LDepPair. 2 | From Undecidability Require Import LTactics. 3 | From Complexity Require Import Definitions NP PolyTimeComputable. 4 | 5 | (* this notion allows to restrict a problem of a subset of the domain*) 6 | Definition restrictBy {X} (validX P:X->Prop) : { x:X | validX x} -> Prop := fun '(exist x _) => P x. 7 | Arguments restrictBy {_} _ _ !_. 8 | 9 | 10 | 11 | 12 | Lemma polyTimeComputable_sig_in X Y `(encodable X) `(encodable Y) P f' (f:{x:X|P x} -> Y): 13 | (forall x Hx, f' x = f (exist P x Hx)) 14 | -> polyTimeComputable f' 15 | -> polyTimeComputable f. 16 | Proof. 17 | intros Hext [time Hcomp]. exists (fun x => time x +2). 2,3:solve [smpl_inO]. 18 | - apply computableTimeExt with (x:=fun x => f' (proj1_sig x)) (x':=f). 19 | + intros []; cbn. apply Hext. 20 | + extract. solverec. reflexivity. 21 | - eexists (resSize__rSP resSize__polyTC). 2,3:solve [smpl_inO]. 22 | intros []. rewrite <- Hext. rewrite bounds__rSP, enc_sig_exist_eq. reflexivity. 23 | Qed. 24 | 25 | Lemma polyTimeComputable_sig_out X Y {RX: encodable X} {RY:encodable Y} validY (f : X -> {y:Y | validY y}): 26 | polyTimeComputable (fun x => proj1_sig (f x)) 27 | -> polyTimeComputable f. 28 | Proof. 29 | intros H. exists (time__polyTC H). 2,3:now smpl_inO. 30 | - computable_casted_result. eauto. 31 | - exists (resSize__rSP H). 2,3:now smpl_inO. 32 | intro. rewrite <- bounds__rSP, enc_sig_eq. reflexivity. 33 | Qed. 34 | 35 | Lemma reducesPolyMO_intro_restrictBy_out X Y `{RX: encodable X} `{RY:encodable Y} 36 | (P : X -> Prop) (validY Q:Y->Prop) (f:X -> Y): 37 | polyTimeComputable f 38 | -> (forall x , {Hfx : validY (f x) | P x <-> Q (f x)}) 39 | -> P ⪯p restrictBy validY Q. 40 | Proof. 41 | intros H H'. unshelve eexists (fun x => exist _ (f x) (proj1_sig (H' x))). 42 | - now apply polyTimeComputable_sig_out. 43 | - intros x. all:now edestruct H'. 44 | Qed. 45 | 46 | 47 | Lemma reducesPolyMO_intro_restrictBy_in X Y `{RX: encodable X} `{RY:encodable Y} 48 | (validX P : X -> Prop) Q (f:X -> Y): 49 | polyTimeComputable f 50 | -> (forall x (H : validX x) , P x <-> Q (f x)) 51 | -> restrictBy validX P ⪯p Q. 52 | Proof. 53 | intros H H'. unshelve eexists (fun x => f (proj1_sig x)). 54 | - eapply polyTimeComputable_sig_in. 2:easy. reflexivity. 55 | - unfold restrictBy. intros []. now apply H'. 56 | Qed. 57 | 58 | Lemma reducesPolyMO_intro_restrictBy_both X Y `{RX: encodable X} `{RY:encodable Y} 59 | (validX P : X -> Prop) (validY Q:Y->Prop) (f:X -> Y): 60 | polyTimeComputable f 61 | -> (forall x (H : validX x) , {Hfx : validY (f x) | P x <-> Q (f x)}) 62 | -> restrictBy validX P ⪯p restrictBy validY Q. 63 | Proof. 64 | intros H H'. eapply reducesPolyMO_intro_restrictBy_out with (f := fun '(exist x _) => f x). 65 | - eapply polyTimeComputable_sig_in. reflexivity. easy. 66 | - unfold restrictBy. intros []. easy. 67 | Qed. -------------------------------------------------------------------------------- /theories/HierarchyTheorem/TimeHierarchyTheorem.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L Tactics.LTactics AbstractMachines.LargestVar Util.Subterm. 2 | 3 | From Complexity.L Require Import AbstractHeapMachineDef UnfoldTailRec AbstractHeapMachine. 4 | From Complexity.L.AbstractMachines.Computable Require Import Unfolding HeapMachine Shared EvalForTime EvalForTimeBool. 5 | 6 | From Complexity.HierarchyTheorem Require Import AbstractTimeHierarchyTheorem. 7 | From Complexity.Complexity Require Import Definitions. 8 | From Undecidability.L.Datatypes Require Import Lists. 9 | From Complexity.L.Datatypes Require Import LBinNums. 10 | From Complexity.L.Functions Require Import BinNums BinNumsCompare. 11 | From Undecidability.L.Functions Require Import UnboundIteration. 12 | 13 | Section TimeHierarchy. 14 | 15 | Variable f : nat -> nat. 16 | Hypothesis TC__f : timeConstructible f. 17 | Hypothesis f_geq_n : forall n, n <= f n. 18 | 19 | Let fT := projT1 TC__f. 20 | 21 | Definition comp_t__E: computableTime' (fun n => N.of_nat (f n)) (fun n _ => (fT n,tt)) := timeConstructible_computableTime' TC__f. 22 | Definition inO_time_t__E: fT ∈O f := timeConstructible_inO TC__f. 23 | 24 | Definition L__f : term * nat -> Prop := 25 | Eval unfold L__f in 26 | @L__f f. 27 | 28 | 29 | Definition E (fuel:N) (s:term) := negb (evalForTimeBool false fuel s). 30 | 31 | #[export] 32 | Instance term_t__E : computableTime' E (fun fuel _ => (1, fun s _ => (t__evalForTimeBool (largestVar s) (size s) (N.to_nat fuel) + 7, tt))). 33 | Proof. 34 | extract. solverec. 35 | Qed. 36 | 37 | Definition t__E (largestVar size:nat) fuel := t__evalForTimeBool largestVar size fuel + 8. 38 | 39 | Import L_Notations. 40 | 41 | Lemma E__spec (s:term) (fuel : N): 42 | closed s -> 43 | exists res : bool, 44 | (extT E) (enc fuel) (enc s) ⇓(<=t__E (largestVar s) (size s) (N.to_nat fuel)) (enc res) /\ 45 | if res 46 | then ~ (s ⇓(<= N.to_nat fuel ) (enc false)) 47 | else s ⇓(<= N.to_nat fuel) (enc false). 48 | Proof. 49 | intros. eexists. split. 50 | { 51 | eapply le_evalLe_proper, evalle_trans. 2,3:reflexivity. 52 | 2:now Lsimpl. 53 | 2:Lreflexivity. 54 | solverec. reflexivity. 55 | } 56 | unfold E. destruct (evalForTimeBool_spec false s fuel). 57 | -cbn. easy. 58 | -cbn. easy. 59 | Qed. 60 | 61 | Lemma mono_t__E maxVar maxVar' x x' size size' : 62 | maxVar <= maxVar' -> x <= x' -> size <= size' -> t__E maxVar size x <= t__E maxVar' size' x'. 63 | Proof. 64 | intros H1 H2 H3. 65 | unfold t__E,t__evalForTimeBool. 66 | rewrite mono_t__evalForTime. 2-4:eassumption. 67 | repeat (lazymatch goal with 68 | |- _ + _ <= _ + _ => eapply Nat.add_le_mono 69 | | |- _ * _ <= _ * _ => eapply Nat.mul_le_mono 70 | | |- _ => first [eassumption | reflexivity | eapply N_size_nat_monotone | eapply unfoldBool_time_mono | Lia.nia |eapply heapStep_timeBound_mono'] 71 | end). 72 | Qed. 73 | 74 | Lemma suplin_t__E maxVar size x : x <= t__E maxVar size x. 75 | Proof. 76 | unfold t__E,t__evalForTimeBool . intros. rewrite <- suplin_t__evalForTime. Lia.nia. 77 | Qed. 78 | 79 | Lemma inO_size_nat f' g: 80 | f' ∈O g -> 81 | (fun n => N.size_nat (N.of_nat (f' n))) ∈O g. 82 | Proof using fT f TC__f. 83 | intros (c0&n0&H). 84 | eexists c0,n0. 85 | intros. rewrite N_size_nat_leq. easy. 86 | Qed. 87 | 88 | Ltac inO_leq n := simple eapply inO_leq with (n0:=n);intros ;try rewrite <- !f_geq_n;nia. 89 | 90 | Lemma in_O_t__E : 91 | (fun n : nat => t__E n (2 * n) (f n)) ∈O (fun n => n * f n * f n). 92 | Proof using f_geq_n fT TC__f. 93 | unfold t__E,t__evalForTimeBool,t__evalForTime. 94 | 95 | all:unfold unfoldBool_time. 96 | all:unfold heapStep_timeBound,Lookup.lookupTime. 97 | smpl_inO. 98 | 1,4,6-11:inO_leq 1. 99 | 2:unfold unfoldBool_time. 100 | 2-3:unfold heapStep_timeBound,Lookup.lookupTime. 101 | -eapply inO_size_nat. inO_leq 1. 102 | -transitivity (fun n => f n * ( n * f n)). 2:inO_leq 1. 103 | simple eapply inO_mul_l. 104 | all:smpl_inO. 105 | 1-2,5-8:solve [inO_leq 1]. 106 | +eapply inO_size_nat. smpl_inO. all:inO_leq 1. 107 | +simple eapply inO_mul_l. all:smpl_inO. all:inO_leq 1. 108 | -setoid_rewrite Nat.mul_comm at 1. eapply inO_mul_l. 109 | all:smpl_inO. all:try inO_leq 1. 110 | Qed. 111 | 112 | Lemma LA_In_f_times_step': 113 | L__f ∈TimeO (fun n : nat => t__E n (2 * n) (f n)). 114 | Proof using f_geq_n fT TC__f. 115 | eapply LA_In_f_times_step. 116 | all:eauto using comp_t__E,E__spec,proc_extT,inO_time_t__E,mono_t__E,suplin_t__E. 117 | Qed. 118 | 119 | Lemma L_A_notIn_f : ~ L__f ∈Timeo f. 120 | Proof. 121 | apply L_A_notIn_f. 122 | Qed. 123 | 124 | Lemma LA_In_f_times_step: 125 | L__f ∈TimeO (fun n => n * f n * f n). 126 | Proof using f_geq_n fT TC__f. 127 | eapply inTime_mono. 128 | apply in_O_t__E. 129 | apply LA_In_f_times_step'. 130 | Qed. 131 | 132 | Lemma TimeHierarchyTheorem : 133 | exists (P : term * nat -> Prop), ~P ∈Timeo f /\ P ∈TimeO (fun n => n * f n * f n). 134 | Proof using f_geq_n fT TC__f. 135 | exists L__f;split. all:eauto using L_A_notIn_f, LA_In_f_times_step. 136 | Qed. 137 | End TimeHierarchy. 138 | 139 | (**Check TimeHierarchyTheorem. 140 | Axiom free: 141 | Print Assumptions TimeHierarchyTheorem. 142 | *) 143 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/AbstractHeapMachineDef.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L_facts. 2 | From Undecidability.L Require Import AbstractMachines.LargestVar. 3 | 4 | (** ** Abstract Heap Machine *) 5 | Section Lin. 6 | 7 | Let HA:=nat. 8 | 9 | Notation clos := (term * HA)%type. 10 | Inductive task := appT | closT (g:clos). 11 | 12 | Inductive heapEntry := heapEntryC (g:clos) (alpha:HA). 13 | 14 | (** *** Heaps *) 15 | 16 | Let Heap := list heapEntry. 17 | Implicit Type H : Heap. 18 | Definition put H e := (H++[e],|H|). 19 | Definition get H alpha:= nth_error H alpha. 20 | Definition extended H H' := forall alpha m, get H alpha = Some m -> get H' alpha = Some m. 21 | 22 | 23 | Fixpoint lookup H alpha x : option clos:= 24 | match get H alpha with 25 | Some (heapEntryC bound env') => 26 | match x with 27 | 0 => Some bound 28 | | S x' => lookup H env' x' 29 | end 30 | | _ => None 31 | end. 32 | 33 | (** *** Reduction Rules *) 34 | 35 | Definition state := (list task * list clos *Heap)%type. 36 | 37 | Hint Transparent state : core. 38 | 39 | Inductive step : state -> state -> Prop := 40 | step_pushVal a s T V H: 41 | step (closT (lam s,a)::T,V,H) (T,(s,a)::V,H) 42 | | step_beta b s g H H' c T V: 43 | put H (heapEntryC g b) = (H',c) 44 | -> step (appT::T,g::(s,b)::V,H) (closT (s,c) ::T,V,H') 45 | | step_load a x g T V H: 46 | lookup H a x = Some g 47 | -> step (closT (var x,a)::T,V,H) (T,g::V,H) 48 | | step_app s t a T V H: step (closT (app s t,a)::T,V,H) (closT (s,a)::closT(t,a)::appT::T,V,H). 49 | 50 | Hint Constructors step : core. 51 | 52 | 53 | (** *** Unfolding *) 54 | 55 | Import L_Notations_app. 56 | 57 | Inductive unfolds H a: nat -> term -> term -> Prop := 58 | | unfoldsUnbound k n : 59 | n < k -> 60 | unfolds H a k (var n) (var n) 61 | | unfoldsBound k b s s' n: 62 | n >= k -> 63 | lookup H a (n-k) = Some (s,b) -> 64 | unfolds H b 1 s s' -> 65 | unfolds H a k (var n) (lam s') 66 | | unfoldsLam k s s': 67 | unfolds H a (S k) s s' -> 68 | unfolds H a k (lam s) (lam s') 69 | | unfoldsApp k (s t s' t' : term): 70 | unfolds H a k s s' -> 71 | unfolds H a k t t' -> 72 | unfolds H a k (s t) (s' t'). 73 | 74 | 75 | Inductive reprC : Heap -> clos -> term -> Prop := 76 | reprCC H s a s' : 77 | unfolds H a 1 s s' -> 78 | reprC H (s,a) (lam s'). 79 | 80 | Definition init s :state := ([closT (s,0 (*dont care*))],[],[]). 81 | 82 | End Lin. 83 | 84 | Module clos_notation. 85 | Notation clos := (term * nat)%type (only parsing). 86 | End clos_notation. 87 | Import clos_notation. 88 | 89 | #[export] 90 | Hint Transparent state : core. 91 | 92 | Definition largestVarC : clos -> nat := (fun '(s,_) => largestVar s). 93 | 94 | Definition largestVarCs (T:list clos) := 95 | maxl (map largestVarC T). 96 | 97 | Definition largestVarH (H:list heapEntry) := 98 | maxl (map (fun e:heapEntry => let (q,_) := e in largestVarC q) H). 99 | 100 | 101 | Definition sizeC g := 102 | match g with 103 | (s,a) => size s + a 104 | end. 105 | 106 | Definition sizeT t := 107 | match t with 108 | appT => 1 109 | | closT g => sizeC g 110 | end. 111 | 112 | Definition sizeHE e := 113 | match e with 114 | heapEntryC g b => sizeC g + b 115 | end. 116 | Definition sizeH H := 117 | sumn (map sizeHE H). 118 | 119 | Definition sizeSt '(T,V,H) := sumn (map sizeC T) + sumn (map sizeC V) + sizeH H. 120 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/Computable/EvalForTimeBool.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L Tactics.LTactics AbstractMachines.LargestVar. 2 | 3 | From Complexity.L Require Import AbstractHeapMachineDef UnfoldTailRec AbstractHeapMachine. 4 | From Complexity.L.AbstractMachines.Computable Require Import Unfolding HeapMachine Shared EvalForTime. 5 | 6 | From Undecidability.L.Datatypes Require Import Lists LProd. 7 | From Complexity.L.Datatypes Require Import LBinNums. 8 | From Undecidability.L.Functions Require Import UnboundIteration Proc. 9 | From Complexity.L.Functions Require Import BinNums BinNumsCompare. 10 | 11 | Definition evalForTimeBool (checkFor:bool) (fuel : N) (s:term) := match evalForTime fuel s with 12 | Some (g,H) => match unfoldBoolean H g with 13 | None => false 14 | | Some b => if checkFor then b else negb b 15 | end 16 | | None => false 17 | end. 18 | 19 | Definition t__evalForTimeBool (largestVar size:nat) fuel := t__evalForTime largestVar size fuel+ unfoldBool_time (4*fuel+1) largestVar + 22. 20 | 21 | Lemma evalForTimeBool_spec (checkFor :bool) (s:term) (fuel : N): 22 | reflect (closed s /\ s ⇓(<= N.to_nat fuel) (enc checkFor)) (evalForTimeBool checkFor fuel s). 23 | Proof. 24 | unfold evalForTimeBool. 25 | eassert (H':=evalForTime_spec _ _). 26 | destruct evalForTime as [[]|] eqn:eq;rewrite eq. 27 | 2:{ econstructor. easy. } 28 | destruct H' as (?&_&H'). 29 | destruct unfoldBoolean eqn:eq'. 30 | -eapply iff_reflect. destruct H' as (?&eq''&?). 31 | eapply unfoldBoolean_sound in eq'. 32 | replace x with (enc b) in *. 33 | 2:{ eapply reprC_functional. all:easy. } 34 | (destruct b,checkFor;cbn). 35 | all:intuition. all:eapply inj_enc,eval_unique. all:eapply evalLe_eval_subrelation;easy. 36 | -econstructor. intros (_&H''). 37 | destruct H' as (?&H'&?). 38 | replace x with (enc checkFor) in *. 39 | 2:{ all:eapply eval_unique. all:eapply evalLe_eval_subrelation;easy. } 40 | eapply unfoldBoolean_complete in H'. easy. 41 | Qed. 42 | 43 | #[export] 44 | Instance evalForTimeBool__comp : computableTime' evalForTimeBool (fun _ _ => (1,fun fuel _ => (1,fun s _ => (t__evalForTimeBool (largestVar s) (size s) (N.to_nat fuel),tt)))). 45 | Proof. 46 | unfold evalForTimeBool. extract. solverec. 47 | all:unfold t__evalForTimeBool. 4:lia. 48 | all:eassert (H':=evalForTime_spec _ _). 49 | all:rewrite H in H'. 50 | all:destruct H' as (?&(?&?&R)&?). 51 | all:rewrite unfoldBool_time_mono with (l':=(4 * N.to_nat x0 + 1)) (n':=(largestVar x1));[try lia | |]. 52 | all:try (etransitivity;[eapply AbstractHeapMachine.length_H;eassumption|lia]). 53 | all:rewrite largestVarH_leq with (1:=R). 54 | all:rewrite largestVarC_V_leq with (1:=R);[|easy]. 55 | all:now rewrite Nat.max_id. 56 | Qed. 57 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/Computable/HeapMachine.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L Tactics.LTactics. 2 | 3 | From Complexity.L.AbstractMachines Require Import FunctionalDefinitions. 4 | From Undecidability.L.Datatypes Require Import LTerm LOptions LProd Lists. 5 | 6 | From Undecidability.L Require Import AbstractMachines.LargestVar. 7 | 8 | 9 | From Complexity.L.AbstractMachines Require Import AbstractHeapMachineDef AbstractHeapMachine. 10 | From Complexity.L.AbstractMachines.Computable Require Import Shared Lookup. 11 | 12 | (** *** Heap Machine *) 13 | Import GenEncode. 14 | MetaCoq Run (tmGenEncode "task_enc" task). 15 | #[export] 16 | Hint Resolve task_enc_correct : Lrewrite. 17 | #[export] 18 | Instance termT_S : computableTime' closT (fun _ _ => (1,tt)). 19 | Proof. 20 | extract constructor. 21 | solverec. 22 | Qed. 23 | 24 | #[export] 25 | Instance TermT_init : computableTime' init (fun s _ => (108 * size s + 44,tt)). 26 | Proof. extract. solverec. Qed. 27 | 28 | 29 | (** *** Heap Machine Step *) 30 | 31 | 32 | Definition heapStep_time (T:list task) (H: list heapEntry) := 33 | match T with 34 | closT (var n,_)::_ => lookupTime (length H) n 35 | | appT::_ => length H*27 36 | | _ => 0 37 | end + 85. 38 | 39 | 40 | Definition heapStep_timeBound maxVar k := 41 | lookupTime k maxVar + k * 27 + 85. 42 | 43 | Lemma heapStep_timeBound_le s k T V H: 44 | pow step k (init s) (T,V,H) -> 45 | heapStep_time T H <= heapStep_timeBound (largestVar s) k. 46 | Proof. 47 | intros H'. 48 | unfold heapStep_timeBound, heapStep_time. destruct T as [|[|[[] a]]]. 49 | 1,4,5:now Lia.lia. 50 | -rewrite length_H. 2:eassumption. Lia.lia. 51 | -rewrite lookupTime_mono with (k':=k) (n':=largestVar s). 52 | +Lia.lia. 53 | +eapply length_H;eassumption. 54 | +eapply subterm_property in H' as (H'&_). 55 | rewrite <- subterm_largestVar. 2:eapply H'. 2:eauto. easy. 56 | Qed. 57 | 58 | Lemma heapStep_timeBound_mono' maxVar maxVar' k k' : 59 | k <= k' -> maxVar <= maxVar' -> 60 | heapStep_timeBound maxVar k <= heapStep_timeBound maxVar' k'. 61 | Proof. 62 | intros H1 H3. 63 | unfold heapStep_timeBound. rewrite Lookup.lookupTime_mono. 2,3:eassumption. Lia.nia. 64 | Qed. 65 | 66 | Lemma heapStep_timeBound_mono maxVar k k' : 67 | k <= k' -> heapStep_timeBound maxVar k <= heapStep_timeBound maxVar k'. 68 | Proof. 69 | intros. 70 | unfold heapStep_timeBound. rewrite lookupTime_mono. 2:eassumption. 2:reflexivity. Lia.lia. 71 | Qed. 72 | 73 | #[export] 74 | Instance term_heapStep : computableTime' heapStep (fun '(T,V,H) _ => (heapStep_time T H,tt)). 75 | Proof. 76 | Arguments put : simpl never. 77 | extract. 78 | {unfold heapStep_time. recRel_prettify2. 79 | all:cbn [length]. 80 | all:try Lia.nia. 81 | } 82 | Qed. 83 | (* with Lrewrite_new: *) 84 | (* QED: Finished transaction in 58.067 secs (57.751u,0.056s) (successful)*) 85 | (* Tactics: total time: 61.772s *) 86 | 87 | (* with Lsimpl: *) 88 | (*total time: 200.012s *) 89 | (* Finished transaction in 27.174 secs (27.097u,0.s) (successful) *) 90 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/Computable/LargestVar.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L Tactics.LTactics. 2 | From Undecidability.L.Datatypes Require Import LNat LProd Lists LTerm LOptions. 3 | 4 | From Complexity.L.AbstractMachines Require Import FunctionalDefinitions AbstractHeapMachineDef. 5 | 6 | Require Import Undecidability.L.AbstractMachines.LargestVar. 7 | 8 | From Undecidability.L Require Import Prelim.LoopSum Functions.LoopSum Functions.UnboundIteration. 9 | Import Nat. 10 | 11 | #[export] 12 | Instance termT_max : computableTime' max (fun x _ => (5,fun y _ => (min x y * 15 + 8,tt))). 13 | Proof. 14 | extract. fold max. solverec. 15 | Qed. 16 | Import L. 17 | Definition largestVarTR' '(stack,res) : (list term * nat) + nat := 18 | match stack with 19 | [] => inr res 20 | | s::stack => 21 | match s with 22 | var n => inl (stack,max n res) 23 | | app s t => inl (s::t::stack,res) 24 | | lam s => inl (s::stack,res) 25 | end 26 | end. 27 | 28 | Fixpoint largestVarTR'_fuel (s:term) : nat := 29 | match s with 30 | var _ => 1 31 | | app s t => 1 + (largestVarTR'_fuel s + largestVarTR'_fuel t) 32 | | lam s => 1 + largestVarTR'_fuel s 33 | end. 34 | 35 | 36 | Lemma largestVarTR'_correct stack res s k: 37 | loopSum (largestVarTR'_fuel s + k) largestVarTR' (s::stack,res) 38 | = loopSum k largestVarTR' (stack,max (largestVar s) res). 39 | Proof. 40 | induction s in res,stack,k |- *. 41 | all:cbn. 42 | -reflexivity. 43 | -rewrite <- !Nat.add_assoc. cbn. 44 | rewrite IHs1, IHs2. easy. 45 | -rewrite IHs. easy. 46 | Qed. 47 | 48 | Lemma largestVarTR_correct s: 49 | loopSum (largestVarTR'_fuel s + 1) largestVarTR' ([s],0) = Some (largestVar s). 50 | Proof. 51 | rewrite largestVarTR'_correct. cbn. easy. 52 | Qed. 53 | 54 | #[export] 55 | Instance termT_largestVarTR' : computableTime' largestVarTR' 56 | (fun x _ => (let '(stack,res) := x in 57 | match stack with 58 | var n ::_ => n*15 59 | | _ => 0 60 | end + 31,tt)). 61 | Proof. 62 | extract. solverec. 63 | Qed. 64 | 65 | Lemma largestVarTR'_fuel_leq_largestVar s : largestVarTR'_fuel s <= size s. 66 | Proof. 67 | induction s;cbn [size largestVarTR'_fuel];try Lia.lia. 68 | Qed. 69 | 70 | #[export] 71 | Instance termT_largestVar : computableTime' largestVar (fun s _ => ((40 * size s) +46,tt)). 72 | Proof. 73 | eexists. 74 | eapply computesTime_timeLeq. 75 | 76 | 2:{ unshelve (eapply uiter_total_instanceTime with (1 := largestVarTR_correct) (preprocessT:=(fun _ _ => (5,tt)))). 77 | { extract. solverec. } 78 | } 79 | split. 2:exact Logic.I. 80 | cbn [fst]. 81 | erewrite uiterTime_bound_recRel with (iterT := fun _ '(stack,res) => ((sumn (map size stack)) * 40 82 | + 40)) 83 | (P:= fun n x => True). 84 | { cbn [length map sumn]. Lia.lia. } 85 | {intros n [stack res] H. cbn. 86 | destruct stack as [|[[]| |]]. 87 | 2-5:split;[easy|]. 88 | all:cbn [length map sumn largestVarTR'_fuel size];try Lia.lia. 89 | } 90 | all:easy. 91 | Qed. 92 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/Computable/Lookup.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import Tactics.LTactics. 2 | From Undecidability.L.Datatypes Require Import Lists. 3 | 4 | From Complexity.L.AbstractMachines Require Import AbstractHeapMachineDef Computable.Shared. 5 | 6 | Definition lookupTime l x := (x+1) * (l*15 + 41). 7 | 8 | #[export] 9 | Instance term_lookup : computableTime' lookup (fun H _ => (5,fun alpha _ => (1,fun x _ => (lookupTime (length H) x ,tt)))). 10 | extract. unfold lookupTime. solverec. 11 | Qed. 12 | 13 | 14 | Lemma lookupTime_mono k k' n n' : 15 | k <= k' -> n <= n' -> lookupTime k n <= lookupTime k' n'. 16 | Proof. 17 | unfold lookupTime. now intros -> ->. 18 | Qed. 19 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/Computable/Shared.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L Tactics.LTactics. 2 | 3 | From Complexity.L.AbstractMachines Require Import FunctionalDefinitions AbstractHeapMachineDef. 4 | From Undecidability.L.AbstractMachines Require Import Programs. 5 | 6 | From Undecidability.L.Datatypes Require Import Lists LOptions LProd LTerm. 7 | 8 | From Undecidability.L Require Import Tactics.GenEncode. 9 | 10 | (** * Computability in L *) 11 | 12 | (** *** Encoding Heaps *) 13 | Import AbstractHeapMachineDef. 14 | 15 | MetaCoq Run (tmGenEncode "heapEntry_enc" heapEntry). 16 | #[export] 17 | Hint Resolve heapEntry_enc_correct : Lrewrite. 18 | 19 | #[export] 20 | Instance term_heapEntryC : computableTime' heapEntryC (fun _ _ => (1,fun _ _ => (1,tt))). 21 | Proof. 22 | extract constructor. solverec. 23 | Qed. 24 | 25 | (** *** Primitive functions with Heaps*) 26 | 27 | #[export] 28 | Instance term_get : computableTime' get (fun A _ => (1,fun n _ => (min n (length A)*15+21,tt))). 29 | Proof. 30 | extract. solverec. unfold nth_error_time, c__ntherror. solverec. 31 | Qed. 32 | 33 | Import Datatypes. 34 | #[export] 35 | Instance put_get : computableTime' put (fun A _ => (1,fun _ _ => (length A * 27 + 37,tt))). 36 | Proof. 37 | extract. solverec. unfold c__app, c__length. lia. 38 | Qed. 39 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/Computable/Unfolding.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L_facts Tactics.LTactics. 2 | From Undecidability.L.Datatypes Require Import LSum LBool LNat Lists LProd. 3 | 4 | From Complexity.L.AbstractMachines Require Import FunctionalDefinitions AbstractHeapMachineDef UnfoldTailRec UnfoldHeap. 5 | 6 | Require Import Undecidability.L.AbstractMachines.LargestVar. 7 | 8 | From Undecidability.L Require Import Prelim.LoopSum Functions.LoopSum Functions.UnboundIteration Functions.LoopSum Functions.Equality. 9 | 10 | From Complexity.L.AbstractMachines.Computable Require Import Shared Lookup. 11 | Import Nat. 12 | Import UnfoldTailRec.task. 13 | 14 | Import GenEncode. 15 | MetaCoq Run (tmGenEncode "task_enc" task). 16 | #[export] 17 | Hint Resolve task_enc_correct : Lrewrite. 18 | 19 | #[export] 20 | Instance termT_S : computableTime' closT (fun _ _ => (1,fun _ _ => (1,tt))). 21 | Proof. 22 | extract constructor. 23 | solverec. 24 | Qed. 25 | 26 | Definition time_unfoldTailRecStep : (list task * list heapEntry * list term ) -> _ := 27 | fun '(stack,H,res) => match stack with 28 | | closT (var n,a) k::_ => lookupTime (length H) (n-k) + min n k * 28 29 | | _ => 0 30 | end + 96. 31 | 32 | #[export] 33 | Instance term_unfoldTailRecStep : computableTime' unfoldTailRecStep (fun x _ => (time_unfoldTailRecStep x,tt)). 34 | Proof. 35 | extract. unfold time_unfoldTailRecStep. solverec. 36 | all: unfold c__leb2, leb_time, c__leb, c__sub1, sub_time, c__sub. all: solverec. 37 | Qed. 38 | 39 | 40 | 41 | Definition unfoldBool_time lengthH largestVar := 42 | lookupTime lengthH largestVar * 7 + largestVar *196+ EqBool.c__eqbComp term * (size (enc (lam (lam # 0))) + size (enc (lam (lam # 1)))) + 1245. 43 | 44 | #[export] 45 | Instance term_unfoldBool : computableTime' unfoldBoolean 46 | (fun H _ => (1,fun q _ => (unfoldBool_time (length H) (max (largestVarH H) (largestVarC q)),tt))). 47 | Proof. 48 | unfold unfoldBoolean. 49 | unfold enc; cbn [encodable_bool_enc]. 50 | extract. 51 | recRel_prettify. 52 | intros H _. split. reflexivity. 53 | intros [s a] _. split. 2:now solverec. 54 | unshelve eassert (H':= time_loopSum_bound_onlyByN _ _ 55 | (f:=unfoldTailRecStep) 56 | (fT:=(fun (x0 : list task * list heapEntry * list term) (_ : unit) => (time_unfoldTailRecStep x0, tt))) 57 | (P:= fun n '(stack,H',res) => 58 | H' = H 59 | /\ largestVarState (stack,H',res) <= max (largestVarH H) (largestVar s) 60 | /\ (length res <= n)) 61 | (boundL := 96 + lookupTime (length H) (max (largestVarH H) (largestVar s)) + max (largestVarH H) (largestVar s) * 28) 62 | (boundR := fun n => 28*n) _). 63 | 64 | -intros n x. assert (H':=unfoldTailRecStep_largestVar_inv x). 65 | unfold unfoldTailRecStep in *. 66 | repeat (let eq := fresh "eq" in destruct _ eqn:eq). all:try congruence. all:subst. all:inv eq2. 67 | all:unfold time_unfoldTailRecStep. 68 | 69 | all:intros (->&H'1&?). 70 | all:try rewrite H',H'1. 71 | all:cbn [fst]. 72 | 73 | 74 | all:repeat match goal with 75 | H : _ <=? _ = true |- _ => apply Nat.leb_le in H 76 | | H : _ <=? _ = false |- _ => apply Nat.leb_gt in H 77 | | H : lookup _ _ _ = Some _ |- _ => apply lookup_size in H;cbn in H 78 | end. 79 | all:intuition (try eassumption;cbn [length];try Lia.nia;try eauto). 80 | 81 | 3:now cbn in *;Lia.nia. 82 | 1-3:assert (H'3 : n1 <= (Init.Nat.max (largestVarH H) (largestVar s))) by (cbn in *; Lia.nia). 83 | 1-3:rewrite lookupTime_mono with (n' := Init.Nat.max (largestVarH H) (largestVar s));[|reflexivity|try lia]. 84 | 1-3:cbn - [plus mult]in *. 85 | 1-3:Lia.lia. 86 | -rewrite H'. clear H'. 87 | 2:{ cbn. intuition idtac. all:Lia.lia. } 88 | ring_simplify. 89 | (* 90 | specialize @list_eqbTime_bound_r with (f:=fun x => 17 * sizeT x + 11) as H'1. 91 | *) 92 | destruct loopSum as [[]|]. 93 | cbn [size]. 94 | 95 | repeat destruct _. 96 | all:unfold unfoldBool_time, largestVarC, EqBool.eqbTime. all:cbn [fst snd]. 97 | all:try rewrite -> !Nat.le_min_r. all:lia. 98 | Qed. 99 | 100 | 101 | Lemma unfoldBool_time_mono l l' n n': 102 | l <= l' -> n <= n' -> unfoldBool_time l n <= unfoldBool_time l' n'. 103 | Proof. 104 | unfold unfoldBool_time. intros H1 H2. 105 | rewrite lookupTime_mono. 2,3:eassumption. rewrite H2. reflexivity. 106 | Qed. 107 | 108 | Lemma unfoldBool_time_leq lengthH largestVar : 109 | unfoldBool_time lengthH largestVar <= (largestVar + 1) * (lengthH * 15 + 41 + 28) * 7 + EqBool.c__eqbComp term * 46 + 1245. 110 | Proof. 111 | unfold unfoldBool_time. unfold lookupTime. 112 | unfold enc,encodable_term_enc. all:unfold enc;cbn. 113 | Lia.nia. 114 | Qed. 115 | 116 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/Computable/UnivDecTime.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L.Datatypes Require Import LNat LBool Lists LProd. 2 | From Undecidability.L Require Import Util.Subterm Tactics.LTactics Prelim.LoopSum Functions.UnboundIteration AbstractMachines.LargestVar. 3 | From Complexity.L Require Import AbstractMachines.Computable.Unfolding. 4 | From Complexity.L.AbstractMachines Require Import AbstractHeapMachine FunctionalDefinitions UnfoldHeap UnfoldTailRec. 5 | From Complexity.L.AbstractMachines.Computable Require Import Shared HeapMachine Unfolding. 6 | 7 | Definition univStep '(T,V,H) : _ + bool := 8 | match heapStep (T,V,H) with 9 | Some s' => inl s' 10 | | None => 11 | match T,V with 12 | [],[g] => match unfoldBoolean H g with 13 | Some b => inr b 14 | | None => inr false (* don't care *) 15 | end 16 | | _,_ => inr false (* don't care *) 17 | end 18 | end. 19 | Import Nat. Import ARS. 20 | #[export] 21 | Instance termT_univStep : computableTime' univStep (fun x _ => 22 | (let '(T,V,H):=x in 23 | heapStep_time T H + 24 | match heapStep x with 25 | Some _ => 0 26 | | _ => match T,V with 27 | [],[q] => unfoldBool_time (length H) (Init.Nat.max (largestVarH H) (largestVarC q)) 28 | | _,_ => 0 end 29 | end + 33,tt)). 30 | Proof. 31 | extract. solverec. 32 | Qed. 33 | 34 | Import HOAS_Notations L_Notations_app. 35 | Definition univDecTime :term := Eval cbn in [L_HOAS λ s , !!(uiter univStep) (!!(extT init) s)]. 36 | 37 | Definition univDecTime_time maxVar size n0 := 38 | 108 * size + (n0+2) * (heapStep_timeBound maxVar (n0+1) + 42) + unfoldBool_time (n0+1) maxVar +87. 39 | 40 | Lemma step_UC : uniform_confluent step. 41 | Proof. 42 | intros ? ? ? R1 R2;inv R1;inv R2. all:left;congruence. 43 | Qed. 44 | 45 | Lemma univDecTime_complete (s:term) (b:bool) k: 46 | closed s -> 47 | s ⇓(k) (enc b) -> 48 | univDecTime (enc s) ⇓(<= univDecTime_time (largestVar s) (size s) (k*4+1)) enc b. 49 | Proof. 50 | intros cs R. apply ResourceMeasures.timeBS_evalIn in R. 51 | apply correctTime in R as (g&H&rep&R). 2:easy. 52 | unfold univDecTime, univDecTime_time. 53 | eapply loopSum_sound_rel with (n:=1) (f:=univStep)in R as R'. 54 | 2:{ intros ? ? R'. unfold univStep. cbn. repeat (let eq := fresh in destruct _ eqn:eq);inv R';try congruence. } 55 | cbn [loopSum univStep heapStep] in R'. 56 | erewrite unfoldBoolean_complete in R'. 2:eassumption. 57 | eapply (uiter_sound (H1:=_)) in R'. 58 | cbn -[plus mult] in R'. 59 | remember (4*k+2) as n0. 60 | erewrite uiterTime_bound_recRel with 61 | (iterT := fun n _ => n* (heapStep_timeBound (largestVar s) n0 + 9 + 33) + unfoldBool_time n0 (largestVar s)) 62 | (P:= fun i x => i <= n0 /\ ARS.pow AbstractHeapMachineDef.step i (init s) x) 63 | (2:=le_n _) 64 | in R'. 65 | 2:{ 66 | intros n ((T&V)&Hp) [H1 H2]. 67 | specialize uniform_confluence_parameterized_terminal with (3:=R) (4:=H2) as (n'&R2&?). 68 | 1:exact step_UC. 69 | 1:now (intros ? H';inv H'). 70 | unfold univStep. cbn [fst snd]. 71 | specialize (subterm_property H2) as (st1&st2&st3). 72 | assert (largestVarH Hp <= largestVar s). 73 | { eapply largestVarH_bound. intros [] ? H'. cbn. eauto using subterm_lam_inv, subterm_largestVar. } 74 | destruct n'. 75 | -inversion R2. subst T V H. cbn [heapStep]. 76 | erewrite unfoldBoolean_complete. 2:eassumption. 77 | rewrite heapStep_timeBound_le. 2:now eauto. 78 | rewrite heapStep_timeBound_mono with (k':=n0). 2:eassumption. 79 | rewrite unfoldBool_time_mono with (l':= n0) (n':=largestVar s). 80 | *now Lia.nia. 81 | *rewrite <- H1. eapply length_H. eauto. 82 | *eapply Nat.max_case. easy. 83 | destruct g. cbn. eauto using subterm_lam_inv, subterm_largestVar. 84 | -change (S n') with (1+n') in R2. replace (S n) with (n+1) by lia. 85 | eapply pow_add with (R:=step) in R2 as (?&R2&R2'). 86 | eapply rcomp_1 with (R:=step) in R2. revert Heqn0. inv R2. all:intro. 87 | all: cbn [heapStep]. 88 | +rewrite H0. intuition idtac. 89 | *Lia.lia. 90 | *eapply pow_add with (R:=step). 91 | eexists;split. eassumption. apply (rcomp_1 step). now constructor. 92 | *rewrite heapStep_timeBound_le. 2:now eauto. 93 | rewrite heapStep_timeBound_mono with (k:=n). 2:eassumption. 94 | Lia.nia. 95 | +rewrite H9. intuition idtac. 96 | *Lia.lia. 97 | *eapply pow_add with (R:=step). 98 | eexists;split. eassumption. apply (rcomp_1 step). now constructor. 99 | *rewrite heapStep_timeBound_le. 2:now eauto. 100 | rewrite heapStep_timeBound_mono with (k:=n). 2:eassumption. 101 | Lia.nia. 102 | +rewrite H9. intuition idtac. 103 | *Lia.lia. 104 | *eapply pow_add with (R:=step). 105 | eexists;split. eassumption. apply (rcomp_1 step). now constructor. 106 | *rewrite heapStep_timeBound_le. 2:now eauto. 107 | rewrite heapStep_timeBound_mono with (k:=n). 2:eassumption. 108 | Lia.nia. 109 | +intuition idtac. 110 | *Lia.lia. 111 | *eapply pow_add with (R:=step). 112 | eexists;split. eassumption. apply (rcomp_1 step). now constructor. 113 | *rewrite heapStep_timeBound_le. 2:now eauto. 114 | rewrite heapStep_timeBound_mono with (k:=n). 2:eassumption. 115 | Lia.nia. 116 | } 117 | { 118 | subst n0. 119 | eapply evalIn_mono. 1:Lsimpl. exact R'. cbn [fst snd]. 120 | replace (k*4) with (4*k) by Lia.lia. replace (4*k +1+1) with (4*k+2) by Lia.lia. ring_simplify. 121 | Lia.nia. 122 | } 123 | rewrite !Nat.sub_diag. easy. 124 | Qed. 125 | 126 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/FlatPro/Computable/Compile.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L Tactics.LTactics Prelim.LoopSum Functions.LoopSum. 2 | From Undecidability.L.Datatypes Require Import LSum LBool LNat Lists LProd LTerm. 3 | 4 | From Undecidability.L.AbstractMachines Require Import FlatPro.Programs. 5 | From Complexity.L.AbstractMachines Require Import Computable.LPro. 6 | (* 7 | fix compile (s : term) : list Tok := 8 | match s with 9 | | # x => [varT x] 10 | | app s0 t => compile s0 ++ compile t ++ [appT] 11 | | lam s0 => lamT :: compile s0 ++ [retT] 12 | end 13 | *) 14 | 15 | Local Definition c__size := 22. 16 | 17 | Lemma compile_enc_size s: size (enc (compile s)) <= size s * c__size. 18 | Proof. 19 | rewrite size_list. unfold enc;cbn. 20 | induction s;cbn [compile]. 21 | all:repeat (cbn [map size sumn];autorewrite with list). 22 | all:ring_simplify. 23 | rewrite size_nat_enc. 24 | all:repeat first[rewrite <- IHs1,<- IHs2 | rewrite <- IHs]. all:ring_simplify. 25 | all:unfold c__size, c__natsizeS, c__natsizeO, c__listsizeCons, c__listsizeNil;nia. 26 | Qed. 27 | Import L. 28 | Definition compileTR' '(stack,res) : (list (term + bool) * list Tok) + list Tok := 29 | match stack with 30 | [] => inr res 31 | | inr true :: stack => inl (stack, retT::res) 32 | | inr false :: stack => inl (stack, appT::res) 33 | | inl s::stack => 34 | match s with 35 | var n => inl (stack,varT n :: res) 36 | | app s t => inl (inl s::inl t::inr false::stack,res) 37 | | lam s => inl (inl s::inr true::stack,lamT::res) 38 | end 39 | end. 40 | 41 | Fixpoint compileTR'_fuel (s:term) : nat := 42 | match s with 43 | var _ => 1 44 | | app s t => 1 + (compileTR'_fuel s + (compileTR'_fuel t + 1)) 45 | | lam s => 1 + (compileTR'_fuel s + 1) 46 | end. 47 | 48 | Lemma compileTR'_correct stack res s k: 49 | loopSum (compileTR'_fuel s + k) compileTR' (inl s::stack,res) 50 | = loopSum k compileTR' (stack,rev (compile s) ++ res). 51 | Proof. 52 | induction s in res,stack,k |- *. 53 | all:cbn. 54 | -reflexivity. 55 | -rewrite <- !Nat.add_assoc. cbn. 56 | erewrite IHs1, IHs2. cbn. now autorewrite with list. 57 | -rewrite <- !Nat.add_assoc. rewrite IHs. cbn. autorewrite with list. easy. 58 | Qed. 59 | 60 | Lemma compileTR_correct s: 61 | loopSum (compileTR'_fuel s + 1) compileTR' ([inl s],[]) = Some (rev (compile s)). 62 | Proof. 63 | rewrite compileTR'_correct. cbn. now autorewrite with list. 64 | Qed. 65 | 66 | Definition c__compileTR' := 32. 67 | #[export] 68 | Instance termT_compileTR' : computableTime' compileTR' 69 | (fun x _ => (c__compileTR',tt)). 70 | Proof. 71 | extract. unfold c__compileTR'. solverec. 72 | Qed. 73 | 74 | Lemma compileTR'_fuel_leq_size s : compileTR'_fuel s <= size s * 2. 75 | Proof. 76 | induction s;cbn [size compileTR'_fuel];try Lia.lia. 77 | Qed. 78 | 79 | 80 | From Undecidability Require Import Functions.UnboundIteration. 81 | 82 | 83 | Local Definition c1 := (c__compileTR' * 2 + 44 + 2 * c__rev). 84 | Local Definition c2 := 59 + c__rev. 85 | Definition time_compile x := c1*x +c2. 86 | 87 | #[export] 88 | Instance termT_compile : computableTime' compile (fun s _ => (time_compile (size s),tt)). 89 | Proof. 90 | evar (time : nat -> nat). [time]:intros n0. 91 | set (f:=(fun s : term => rev (compile s))). 92 | eassert (computableTime' f (fun s _ => (time (size s),tt))). 93 | eexists. 94 | eapply computesTime_timeLeq. 95 | 2:{ unshelve (eapply uiter_total_instanceTime with (1 := compileTR_correct) (preprocessT:=(fun _ _ => (6,tt)))). 96 | extract. solverec. 97 | } 98 | { 99 | intros s _;cbn [fst snd]. split. 2:easy. 100 | evar (c1 : nat). evar (c2 : nat). 101 | evar (perItem : term + bool -> nat). 102 | erewrite uiterTime_bound_recRel with (iterT := fun _ '(stack,_) => (sumn (map perItem stack) + 41)) 103 | (P:= fun n x => True). 104 | 4:easy. 3:reflexivity. 105 | 2:{ intros n ([|[[]|[]]]&res) _. 106 | all:cbn. 107 | easy. all:split;[easy|]. 108 | all:ring_simplify. 109 | [perItem]:refine (fun c => match c with 110 | | inr _ => c1 + c__compileTR' 111 | | inl s => (c2 + c__compileTR') * compileTR'_fuel s 112 | end). 113 | all:cbn [perItem compileTR'_fuel]. 114 | [c1]:exact 9. all:subst c1. 4-5:nia. 115 | all:ring_simplify. [c2]:exact 9. 116 | all:subst c2;nia. 117 | } subst c1 c2. 118 | cbn [sumn map perItem]. rewrite compileTR'_fuel_leq_size. set (size s). ring_simplify. unfold time. reflexivity. 119 | } 120 | eapply computableTimeExt with (x:= fun s => rev (f s)). 121 | 1:{ cbn;unfold f;intro. now autorewrite with list. } 122 | extract. solverec. unfold f, time. rewrite rev_length, length_compile_leq. 123 | ring_simplify. 124 | unfold time_compile, c1,c2. (*ring_simplify*) nia. 125 | Qed. 126 | 127 | 128 | Lemma sizeT_compile_list_bool: 129 | (fun bs : list bool => sumn (map sizeT (compile (enc (rev bs))))) <=c (fun bs => length bs + 1). 130 | Proof. 131 | evar (c:nat). exists c. intros xs. transitivity (sizeP (compile (enc (rev xs)))). 132 | now unfold sizeP. unfold sizeP;rewrite sizeP_size,Lists.size_list. 133 | rewrite map_rev,<-sumn_rev. rewrite MoreBase.sumn_le_bound. 134 | 2:{ intros ? ([]&<-&?)%in_map_iff. all:cbv. reflexivity. nia. } 135 | rewrite map_length. ring_simplify. [c]:exact (18 + 2 * c__listsizeNil). nia. 136 | Qed. 137 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/FlatPro/Computable/Decompile.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L Tactics.LTactics. 2 | From Undecidability.L.Datatypes Require Import LSum LBool LNat Lists. 3 | 4 | From Undecidability.L.AbstractMachines Require Import FlatPro.Programs. 5 | From Complexity.L.AbstractMachines Require Import Computable.LPro. 6 | 7 | Import L. 8 | Definition time_decompile := 9 | fix f (l:nat) (P:list Tok) A := 10 | match P with 11 | | [] => 0 12 | | varT n :: P0 => f l P0 (var n::A) 13 | | ProgramsDef.appT :: P0 => 14 | match A with 15 | | [] => 0 16 | | [t] => 0 17 | | t :: s :: A0 => f l P0 (app s t :: A0) 18 | end 19 | | ProgramsDef.lamT :: P0 => f (S l) P0 A 20 | | retT :: P0 => 21 | match l with 22 | | 0 => 0 23 | | S l0 => match A with 24 | | [] => 0 25 | | s :: A0 => f l0 P0 (lam s :: A0) 26 | end 27 | end 28 | end + 31. 29 | 30 | Definition time_decompile_nice n := (n +1) * 31. 31 | 32 | Lemma time_decompile_nice_leq l P A: 33 | time_decompile l P A <= time_decompile_nice (length P). 34 | Proof. 35 | unfold time_decompile_nice. 36 | induction P in l,A |-*;cbn. 37 | all:repeat destruct _. 38 | all:cbn. 39 | all:try rewrite IHP;nia. 40 | Qed. 41 | 42 | #[export] 43 | Instance term_decompile : computableTime' decompile (fun l _ => (5,fun P _ => (1, fun A _ => (time_decompile l P A,tt)))). 44 | Proof. 45 | extract. solverec. 46 | Qed. 47 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/FlatPro/Computable/HeapStep.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L Tactics.LTactics. 2 | From Undecidability.L.Datatypes Require Import LSum LBool LNat Lists LOptions. 3 | 4 | From Undecidability.L.AbstractMachines.FlatPro Require Import Programs LM_heap_def LPro JumpTarget. 5 | 6 | Definition lookup_time n l := (n+1)*(l*15 + 38). 7 | 8 | Definition c__tailRec := 10. 9 | 10 | 11 | Definition flatHeapStep_time : state -> nat := 12 | fun '(T,V,H) => 13 | match T with 14 | (_,varT n::_)::_ => lookup_time n (length H) 15 | | (_,lamT::l1)::_ => time_jumpTarget' 0 0 l1 16 | 17 | | (_,appT::_)::_ => 27 * length H 18 | | _ => 0 19 | end + 80 + c__tailRec. 20 | 21 | #[export] 22 | Instance term_lookup_fun : computableTime' lookup (fun H _ => (5,fun a _ => (1,fun n _ => (lookup_time n (length H),tt)))). 23 | Proof. 24 | unfold lookup,lookup_time. unfold Heap, HEntr, HClos,HAdd. 25 | extract. solverec. 26 | Qed. 27 | 28 | 29 | #[export] 30 | Instance term_tailRecursion_fun : computableTime' tailRecursion (fun _ _ => (5,fun _ _ => (c__tailRec, tt))). 31 | Proof. 32 | unfold tailRecursion. unfold Heap, HEntr, HClos,HAdd, c__tailRec. 33 | extract. solverec. 34 | Qed. 35 | 36 | #[export] 37 | Instance term_setp_fun : computableTime' step_fun (fun st _ => (flatHeapStep_time st,tt)). 38 | Proof. 39 | unfold step_fun,flatHeapStep_time. unfold state, put, Heap, HEntr, HClos,HAdd. 40 | extract. unfold state, put, Heap, HEntr, HClos,HAdd. solverec. 41 | Qed. 42 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/FlatPro/Computable/JumpTarget.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L Tactics.LTactics. 2 | From Undecidability.L.Datatypes Require Import LSum LBool LNat Lists. 3 | 4 | From Undecidability.L.AbstractMachines Require Import FlatPro.Programs FlatPro.LM_heap_def Computable.LPro. 5 | 6 | Local Fixpoint jumpTarget' (k:nat) (Q:Pro) (P:Pro) : option (Pro*Pro) := 7 | match P with 8 | | retT :: P' => match k with 9 | | 0 => Some (rev Q,P') 10 | | S k' => jumpTarget' k' (retT::Q) P' 11 | end 12 | | lamT :: P' => jumpTarget' (S k) (lamT::Q) P' 13 | | t :: P' => jumpTarget' k (t::Q) P' (* either [varT n] or [appT] *) 14 | | [] => None 15 | end. 16 | 17 | Local Lemma jumpTarget'_eq k Q P : 18 | jumpTarget k Q P = jumpTarget' k (rev Q) P. 19 | Proof. 20 | induction P in k,Q|-*;cbn;repeat destruct _. 21 | all:try rewrite IHP. 22 | all:autorewrite with list;cbn. all:try easy. 23 | Qed. 24 | 25 | Definition time_jumpTarget' := 26 | fix f (k : nat) q (P : list Tok) {struct P} : nat := 27 | match P with 28 | | [] => 0 29 | | varT _ as t :: P' | appT as t :: P' => f k (S q) P' 30 | | lamT :: P' => f (S k) (S q) P' 31 | | retT :: P' => match k with 32 | | 0 => q * 13 33 | | S k' => f k' (S q) P' 34 | end 35 | end + 27. 36 | 37 | (* 38 | Definition time_decompile_nice n := (n +1) * 31. 39 | 40 | Lemma time_decompile_nice_leq l P A: 41 | time_decompile l P A <= time_decompile_nice (length P). 42 | Proof. 43 | unfold time_decompile_nice. 44 | induction P in l,A |-*;cbn. 45 | all:repeat destruct _. 46 | all:cbn. 47 | all:try rewrite IHP;nia. 48 | Qed. *) 49 | 50 | 51 | #[export] 52 | Instance term_jumpTarget' : computableTime' jumpTarget' (fun k _ => (5,fun Q _ => (1,fun P _ => (time_jumpTarget' k (length Q) P,tt)))). 53 | Proof. 54 | extract. solverec. 55 | Qed. 56 | 57 | #[export] 58 | Instance term_jumpTarget : computableTime' (jumpTarget 0 []) (fun P _ => (time_jumpTarget' 0 0 P,tt)). 59 | Proof. 60 | apply computableTimeExt with (x:=fun x => jumpTarget' 0 [] x). now cbn;intros;rewrite jumpTarget'_eq. 61 | eexists. eapply computesTime_timeLeq. 2:now eapply extTCorrect. 62 | repeat intro;cbn. easy. 63 | Qed. 64 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/FlatPro/Computable/LPro.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L Tactics.LTactics. 2 | From Undecidability.L.AbstractMachines Require Import FlatPro.Programs. 3 | From Undecidability.L Require Import Tactics.GenEncode. 4 | 5 | From Undecidability.L.Datatypes Require Import LNat. 6 | 7 | 8 | MetaCoq Run (tmGenEncode "token_enc" Tok). 9 | #[export] 10 | Hint Resolve token_enc_correct : Lrewrite. 11 | 12 | #[export] 13 | Instance term_varT : computableTime' varT (fun _ _ => (1,tt)). 14 | extract constructor. solverec. 15 | Qed. 16 | (* Instance term_tok_eqb : computableTime' Tok_eqb (fun t _ => (1,fun t' _ => (min (sizeT t) (sizeT t') * 17 + 10,tt))). *) 17 | (* extract. solverec. *) 18 | (* Qed. *) 19 | 20 | 21 | Lemma size_Tok_enc_r t: sizeT t <= size (enc t). 22 | Proof. 23 | destruct t;cbn. 2-4:now cbv. 24 | unfold enc;cbn. now rewrite <- LNat.size_nat_enc_r. 25 | Qed. 26 | 27 | 28 | Lemma size_Tok_enc t: size (enc t) = 29 | match t with 30 | | varT n => 4*n+13 31 | | appT => 7 32 | | lamT => 6 33 | | retT => 5 34 | end. 35 | Proof. 36 | unfold enc;cbn. 37 | destruct t;cbn. rewrite size_nat_enc; unfold c__natsizeO, c__natsizeS. all:ring_simplify. all:easy. 38 | Qed. 39 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/FlatPro/SizeAnalysisStep.v: -------------------------------------------------------------------------------- 1 | From Undecidability Require Import TM.Util.TM_facts TM.Util.Relations. 2 | From Undecidability.L Require Import LM_heap_def. 3 | 4 | Set Default Proof Using "Type". 5 | Require Import FunInd. 6 | 7 | Lemma lookup_el H alpha x c: lookup H alpha x = Some c -> exists beta, Some (c,beta) el H. 8 | Proof. 9 | induction x in alpha, c|-*. 10 | all:cbn. all:destruct nth_error as [[[] | ]| ] eqn:eq. 11 | all:intros [= eq']. 12 | 1:subst. 13 | all:eauto using nth_error_In. 14 | Qed. 15 | 16 | Section Analysis. 17 | 18 | 19 | (*Variable s : term.*) 20 | (* Hypothesis cs : closed s.*) 21 | Variable T V : list HClos. 22 | Variable H H__init: list HEntr. 23 | 24 | Lemma jumpTarget_eq c c0 c1 c2: jumpTarget 0 c0 c = Some (c1,c2) -> c1++[retT]++c2=c0++c. 25 | Proof. 26 | generalize 0 as k. 27 | induction c as [ |[]] in c1,c2,c0|-*;cbn. congruence. 28 | all:intros ? H'. 29 | 4:destruct k;[inv H';congruence| ]. 30 | all:apply IHc in H'. 31 | all:autorewrite with list in *. 32 | all:now cbn in *. 33 | Qed. 34 | 35 | 36 | Lemma tailRecursion_incl P alpha T': tailRecursion (alpha,P) T' <<= (alpha,P)::T'. 37 | Proof. 38 | destruct P as [ |[]];cbn. all:eauto. 39 | Qed. 40 | 41 | Lemma tailRecursion_length P alpha T': | tailRecursion (alpha,P) T' | <= 1+ length T'. 42 | Proof. 43 | destruct P as [ |[]];cbn. all:eauto. 44 | Qed. 45 | 46 | 47 | Variable i : nat. 48 | 49 | Variable P0 : Pro. 50 | Hypothesis R: pow step i ([(0,P0)],[],H__init) (T,V,H). 51 | Hypothesis empty_H__init: forall c, c el H__init -> c = None. 52 | 53 | Import Lia. 54 | 55 | Lemma size_clos P a : ((a,P) el (T++V) -> sizeP P <= sizeP P0 /\ a <= length H /\ largestVarP P <= largestVarP P0) 56 | /\ (forall beta, Some ((a,P),beta) el H -> sizeP P <= sizeP P0 /\ a <= length H /\ beta <= length H /\ largestVarP P <= largestVarP P0). 57 | Proof using empty_H__init R. 58 | unfold sizeP. 59 | induction i in T,V,H,R,P,a|-*. 60 | -inv R. split. 61 | +intros [[= <- <-]|[]]. 62 | eauto using Nat.le_0_l. 63 | +intros ? ?%empty_H__init. easy. 64 | -replace (S n) with (n + 1) in R by lia. apply pow_add in R. destruct R as [[[T' V'] H'] [R1 R2]]. 65 | specialize (IHn _ _ _ R1). 66 | eapply rcomp_1 in R2. 67 | split. 68 | +intros Hel. 69 | apply in_app_or in Hel. 70 | inv R2. 71 | *apply jumpTarget_eq in H2. cbn in H2;inv H2. 72 | destruct Hel as [H1|[[= <- <-] | ]]. 73 | apply tailRecursion_incl in H1 as [[= <- <-]| ]. 74 | 75 | all:repeat (autorewrite with list in *;cbn in * ). 76 | 1:specialize (proj1 (IHn _ a0) ltac:(eauto)). 77 | 3:specialize (proj1 (IHn _ a0) ltac:(eauto)). 78 | 79 | 1,3:repeat (autorewrite with list in *;cbn in * ). 80 | 81 | 3:specialize (proj1 (IHn P a) ltac:(eauto)). 82 | 4:specialize (proj1 (IHn P a) ltac:(eauto)). 83 | 84 | 1,2:intros (?&?&H');rewrite maxl_app in H';cbn in H';unfold largestVarP in *. 85 | 86 | all:split;[|split];try lia. 87 | * inv H2. 88 | destruct Hel as [[[= <- <-] | ]| ]. 89 | 2:apply tailRecursion_incl in H as [[= <- <-]| ]. 90 | all:repeat ((try setoid_rewrite in_app_iff in IHn);cbn in IHn). 91 | --specialize (proj1(IHn Q _) ltac:(eauto)). 92 | repeat (autorewrite with list in *;cbn in * ). 93 | now lia. 94 | --specialize (proj1(IHn _ a0) ltac:(eauto)). 95 | repeat (autorewrite with list in *;cbn in * ). unfold largestVarP in *. 96 | now lia. 97 | --specialize (proj1(IHn P a) ltac:(eauto)). 98 | autorewrite with list in IHn. 99 | repeat (autorewrite with list in *;cbn in * ). 100 | now lia. 101 | --specialize (proj1(IHn P a) ltac:(eauto)). 102 | autorewrite with list in IHn. 103 | repeat (autorewrite with list in *;cbn in * ). 104 | try now lia. 105 | * destruct Hel as [ |[-> | ]]. 106 | apply tailRecursion_incl in H0 as [[= <- <-]| ]. 107 | all:repeat ((try setoid_rewrite in_app_iff in IHn);cbn in IHn). 108 | --specialize (proj1(IHn _ a0) ltac:(eauto)). 109 | repeat (autorewrite with list in *;cbn in * ). unfold largestVarP in *. 110 | now lia. 111 | --specialize (proj1(IHn _ a) ltac:(eauto)). 112 | repeat (autorewrite with list in *;cbn in * ). 113 | now lia. 114 | --apply lookup_el in H2 as (?&?). 115 | specialize (proj2 (IHn _ a) _ ltac:(eauto)). 116 | repeat (autorewrite with list in *;cbn in * ). 117 | now lia. 118 | --specialize (proj1(IHn _ a) ltac:(eauto)). 119 | repeat (autorewrite with list in *;cbn in * ). 120 | now lia. 121 | +intros ? Hel. inv R2. 122 | 1,3:now apply IHn. 123 | inv H2. 124 | apply in_app_or in Hel. 125 | edestruct Hel as [ |[[= -> ->]|[]]]. 126 | 1:specialize (proj2(IHn _ a) _ ltac:(eauto)). 127 | all:autorewrite with list;cbn. 128 | now lia. 129 | 1:specialize (proj1(IHn _ a) ltac:(eauto)). 130 | 1:specialize (proj1(IHn _ beta) ltac:(eauto)). 131 | lia. 132 | Qed. 133 | 134 | Lemma length_H : length H <= length H__init+i. 135 | Proof using empty_H__init R. 136 | induction i in T,V,H,R|-*. 137 | -inv R. cbn;lia. 138 | -replace (S n) with (n + 1) in R by lia. 139 | apply pow_add in R. destruct R as [[[T' V'] H'] [R1 R2]]. 140 | specialize (IHn _ _ _ R1). 141 | eapply rcomp_1 in R2. 142 | inv R2. 143 | 1,3:now lia. 144 | inv H2. autorewrite with list. cbn. lia. 145 | Qed. 146 | 147 | Lemma length_TV : length T + length V <= 1+i. 148 | Proof using empty_H__init R. 149 | induction i in T,V,H,R|-*. 150 | -inv R. cbn;lia. 151 | -replace (S n) with (n + 1) in R by lia. 152 | apply pow_add in R. destruct R as [[[T' V'] H'] [R1 R2]]. 153 | specialize (IHn _ _ _ R1). 154 | eapply rcomp_1 in R2. 155 | inv R2. 156 | all:cbn in *. 157 | specialize (tailRecursion_length P' a T0). 158 | 1,2:specialize (tailRecursion_length P a T0). all:unfold tailRecursion. 159 | 1,2:nia. 160 | destruct P. nia. cbn. nia. 161 | Qed. 162 | 163 | (* Damit: länge eines zustandes beschränkt durch (i+i)*(3*(i+1)+2*|s|)*) 164 | End Analysis. 165 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/LambdaDepth.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import List. 2 | Import ListNotations. 3 | From Undecidability.L Require Import MoreBase. 4 | From Undecidability.L Require Import L FlatPro.Programs Util.Subterm. 5 | 6 | Fixpoint lambdaDepth s := 7 | match s with 8 | | var _ => 0 9 | | lam s => S (lambdaDepth s) 10 | | app s t => max (lambdaDepth s) (lambdaDepth t) 11 | end. 12 | 13 | Fixpoint lambdaDepthP (k:nat) P := 14 | match P with 15 | | [] => k 16 | | lamT::P => lambdaDepthP (S k) P 17 | | retT::P => max k (lambdaDepthP (pred k) P) 18 | | _::P => lambdaDepthP k P 19 | end. 20 | 21 | Lemma lambdaDepthP_min k P: k <= lambdaDepthP k P. 22 | Proof. 23 | induction P as [|[]] in k|-*. 24 | all:cbn. 1,5:Lia.nia. all:rewrite <- IHP. all:lia. 25 | Qed. 26 | 27 | Lemma lambdaDepthP_compile' s P k : 28 | lambdaDepthP k (compile s++P) = max (lambdaDepth s + k) (lambdaDepthP k P). 29 | Proof. 30 | induction s in P,k|-*. all:cbn. 31 | -rewrite max_r. easy. apply lambdaDepthP_min. 32 | -autorewrite with list. rewrite IHs1,IHs2;cbn. nia. 33 | -autorewrite with list. rewrite IHs. cbn. 34 | destruct (lambdaDepthP k P); nia. 35 | Qed. 36 | 37 | 38 | Lemma lambdaDepthP_compile s k : 39 | lambdaDepthP k (compile s) = k + lambdaDepth s. 40 | Proof. 41 | specialize (lambdaDepthP_compile' s [] k) as H'. rewrite app_nil_r in H'. cbn in *. 42 | specialize (lambdaDepthP_min k (compile s)). nia. 43 | Qed. 44 | 45 | 46 | Lemma lambdaDepth_subterm s s' : 47 | subterm s s' -> lambdaDepth s <= lambdaDepth s'. 48 | Proof. 49 | induction 1;cbn. all:nia. 50 | Qed. 51 | 52 | Lemma lambdaDepth_size s : 53 | lambdaDepth s <= L_facts.size s. 54 | Proof. induction s;cbn. all:nia. Qed. 55 | 56 | Lemma lambdaDepthP_sizeP k P : 57 | lambdaDepthP k P <= (pred k) + sizeP P. 58 | Proof. unfold sizeP. induction P as [|[]] in k|-*;cbn. nia. all:rewrite IHP. all:nia. Qed. 59 | -------------------------------------------------------------------------------- /theories/L/AbstractMachines/UnfoldHeap.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L_facts. 2 | From Complexity Require Import AbstractMachines.AbstractHeapMachineDef. 3 | 4 | (** We define a function f to unfold a closure, needed for the Turing machine M_unf. *) 5 | 6 | Section UnfoldPro. 7 | 8 | Variable H : list heapEntry. 9 | 10 | Set Default Proof Using "Type". 11 | 12 | Import L_Notations. 13 | 14 | Fixpoint unfoldC fuel (s:term) a k {struct fuel}: option term := 15 | match fuel with 16 | 0 => None 17 | | S fuel => 18 | match s with 19 | | app s t => 20 | match unfoldC fuel s a k, unfoldC fuel t a k with 21 | Some s',Some t' => Some (s' t') 22 | | _,_ => None 23 | end 24 | | lam s => 25 | match unfoldC fuel s a (S k) with 26 | Some s' => Some (lam s') 27 | | _ => None 28 | end 29 | | var n => 30 | if leb k n then 31 | match lookup H a (n-k) with 32 | Some (s,b) => 33 | match unfoldC fuel s b 1 with 34 | Some s' => Some (lam s') 35 | | _ => None 36 | end 37 | | _ => None 38 | end 39 | else 40 | Some (var n) 41 | end 42 | end. 43 | 44 | Lemma unfoldC_mono s a k n n': 45 | n <= n' -> forall t, unfoldC n s a k = Some t -> unfoldC n' s a k = Some t. 46 | Proof. 47 | induction n in s,a,k,n'|-*. now cbn. 48 | destruct n'. now lia. 49 | intros leq%Peano.le_S_n t. 50 | specialize IHn with (1:=leq). clear leq. 51 | cbn in *. 52 | repeat (let eq := fresh "eq" in destruct _ eqn:eq);subst. 53 | all:try congruence. 54 | all: repeat match goal with 55 | H : (unfoldC ?n ?P ?a ?k = Some _) 56 | |- _ => progress eapply IHn in H 57 | end. 58 | all:try congruence. 59 | Qed. 60 | 61 | Fixpoint depth s : nat := 62 | match s with 63 | app s t => S (max (depth s) (depth t)) 64 | | lam s => S (depth s) 65 | | _ => 1 66 | end. 67 | 68 | Lemma unfoldC_correct a k s s': 69 | unfolds H a k s s' -> 70 | unfoldC (depth s') s a k = Some s'. 71 | Proof. 72 | induction 1. all:cbn. 73 | 1,2: (destruct (Nat.leb_spec0 k n); try lia);[]. 74 | - easy. 75 | -rewrite H1, IHunfolds. all:easy. 76 | -rewrite IHunfolds. easy. 77 | -unshelve erewrite (unfoldC_mono _ IHunfolds1). nia. 78 | unshelve erewrite (unfoldC_mono _ IHunfolds2). nia. easy. 79 | Qed. 80 | 81 | Lemma unfoldC_correct_final P a s: 82 | reprC H (P,a) s -> 83 | exists t, s = lam t /\ exists n, unfoldC n P a 1 = Some t. 84 | Proof. 85 | intros H'. inv H'. 86 | specialize (unfoldC_correct H5) as eq. eauto. 87 | Qed. 88 | 89 | Lemma unfoldsC_correct2 n s a k s': 90 | unfoldC n s a k = Some s' 91 | -> unfolds H a k s s'. 92 | Proof. 93 | induction n in a,s,s',k|-*. now inversion 1. 94 | cbn. 95 | destruct s. 1:destruct (Nat.leb_spec0 k n0). 96 | all:repeat (let eq := fresh "eq" in destruct _ eqn:eq);intros [= <-];subst. 97 | all: repeat lazymatch goal with 98 | H : (unfoldC ?n ?P ?a ?k = Some _) 99 | |- _ => apply IHn in H 100 | end. 101 | all:eauto using unfolds,not_ge. 102 | Qed. 103 | End UnfoldPro. 104 | 105 | Lemma unfolds_inj H k s a s1 s2 : 106 | unfolds H k s a s1 -> unfolds H k s a s2 -> s1=s2. 107 | Proof. 108 | (* intros (n1&eq1)%unfoldC_correct (n2&eq2)%unfoldC_correct. 109 | enough (unfoldC H a k s n1 = unfoldC H a k s n2) by congruence. 110 | specialize unfoldC_mono with (n':= max n1 n2) (n:= min n1 n2). 111 | eapply Max.max_case_strong;eapply Min.min_case_strong;intros ? ?. 112 | all:try (replace n2 with n1 in * by ;congruence). 113 | all:intros ->. all:easy. *) 114 | 115 | induction 1 in s2|-*;intros H';inv H';try congruence;try lia. 116 | -rewrite H1 in H5. inv H5. f_equal. eauto. 117 | -f_equal. eauto. 118 | -f_equal. all:auto. 119 | Qed. 120 | 121 | -------------------------------------------------------------------------------- /theories/L/Datatypes/LBinNums.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import Tactics.LTactics Datatypes.LUnit Datatypes.LBool Datatypes.LNat. 2 | Require Import BinNums. 3 | Require Import Undecidability.L.Tactics.GenEncode. 4 | 5 | (** ** Encoding of positive binary numbers *) 6 | MetaCoq Run (tmGenEncode "positive_enc" positive). 7 | #[export] 8 | Hint Resolve positive_enc_correct : Lrewrite. 9 | 10 | Global Instance termT_Pos_xI : computableTime' xI (fun x _ => (1,tt)). 11 | extract constructor. solverec. 12 | Qed. 13 | 14 | Global Instance termT_Pos_xO : computableTime' xO (fun x _ => (1,tt)). 15 | extract constructor. solverec. 16 | Qed. 17 | 18 | (** ** Encoding of natural binary numbers *) 19 | MetaCoq Run (tmGenEncode "N_enc" N). 20 | #[export] 21 | Hint Resolve N_enc_correct : Lrewrite. 22 | 23 | #[export] 24 | Instance termT_N_NPos : computableTime' Npos (fun x _ => (1,tt)). 25 | Proof. 26 | extract constructor. solverec. 27 | Qed. 28 | 29 | (** *** basic functions *) 30 | 31 | Lemma pos_size_eq_log2 n : Pos.size_nat n = Nat.log2 (Pos.to_nat n) + 1. 32 | Proof. 33 | induction n;cbn. 34 | 3:reflexivity. 35 | all:rewrite IHn. 36 | 2:{rewrite Pos2Nat.inj_xO. rewrite Nat.log2_double. 2:now apply Pos2Nat.is_pos. now Lia.lia. } 37 | {rewrite Pos2Nat.inj_xI. 38 | transitivity (S (S (Nat.log2 (Pos.to_nat n)))). Lia.lia. 39 | rewrite <- Nat.log2_succ_double. 2:now apply Pos2Nat.is_pos. rewrite Nat.add_1_r. Lia.nia. } 40 | Qed. 41 | 42 | Lemma pos_size_nat_eq n: Pos.size_nat n = Pos.to_nat (Pos.size n). 43 | Proof. 44 | induction n;cbn. 45 | 3:reflexivity. 46 | all:rewrite IHn. 47 | all:now rewrite Pos2Nat.inj_succ. 48 | Qed. 49 | 50 | Lemma pos_size_nat_leq n : Pos.size_nat n <= Pos.to_nat n. 51 | Proof. 52 | rewrite pos_size_nat_eq. apply Pos2Nat.inj_le. 53 | induction n;cbn. 3:reflexivity. all:Lia.lia. 54 | Qed. 55 | 56 | Lemma Pos_size_nat_leq p : (Pos.size p <= p)%positive. 57 | Proof. 58 | induction p. all:cbn. all:try Lia.lia. 59 | Qed. 60 | 61 | Lemma N_size_nat_leq' n : (N.size n <= n)%N. 62 | Proof. 63 | destruct n. now reflexivity. 64 | cbn. apply Pos_size_nat_leq. 65 | Qed. 66 | 67 | Lemma N_size_nat_eq n : N.size_nat n = N.to_nat (N.size n). 68 | Proof. 69 | destruct n. reflexivity. 70 | cbn. apply pos_size_nat_eq. 71 | Qed. 72 | 73 | Lemma N_size_nat_leq n : (N.size_nat (N.of_nat n)) <= n. 74 | Proof. 75 | rewrite N_size_nat_eq. 76 | etransitivity. 2:rewrite <- Nnat.Nat2N.id;reflexivity. 77 | eapply Nat.compare_le_iff. rewrite <- Nnat.N2Nat.inj_compare. apply N_size_nat_leq'. 78 | Qed. 79 | 80 | 81 | (* One probably could do better by repeated halving (O(n)) *) 82 | Definition time_N_of_nat n := n* 20 + n*Nat.log2 n*11. 83 | 84 | Local Arguments Nat.log2 : simpl never. 85 | 86 | 87 | Section pos. 88 | Import Pos. 89 | Global Instance termT_Pos_succ : computableTime' Pos.succ (fun x _ => (Pos.size_nat x*11,tt)). 90 | Proof. 91 | extract. solverec. 92 | Qed. 93 | 94 | 95 | Global Instance term_Pos_of_succ_nat : computableTime' Pos.of_succ_nat (fun n _ => (time_N_of_nat n +8,tt)). 96 | Proof. 97 | extract. solverec. fold Pos.of_succ_nat. unfold time_N_of_nat. 98 | rewrite pos_size_eq_log2,SuccNat2Pos.id_succ. 99 | change (1 + n) with (S n). 100 | rewrite (Nat.log2_le_mono n (S n)). all:Lia.nia. 101 | Qed. 102 | 103 | 104 | Import N. 105 | Global Instance term_N_of_nat : computableTime' N.of_nat (fun n _ => (time_N_of_nat n+ 4,tt)). 106 | Proof. 107 | extract. solverec. unfold time_N_of_nat. 108 | rewrite (Nat.log2_le_mono n (S n)). 109 | all:ring_simplify. all:Lia.nia. 110 | Qed. 111 | 112 | Arguments time_N_of_nat : simpl never. 113 | 114 | Import Pos. 115 | Global Instance term_N_succ : computableTime' N.succ (fun x _ => (N.size_nat x * 11 + 6,tt)). 116 | Proof. 117 | unfold N.succ. 118 | extract. solverec. 119 | Qed. 120 | 121 | End pos. 122 | 123 | Lemma N_size_nat_monotone n n' : (n <= n')%N -> N.size_nat n <= N.size_nat n'. 124 | Proof. 125 | intros ?. destruct (N.eqb_spec n n'). now subst. 126 | destruct n, n'. all:cbn in *. all:try Lia.lia. apply Pos.size_nat_monotone. Lia.lia. 127 | Qed. 128 | Lemma N_size_nat_add_leq x y : N.size_nat (x+y) <= 1 + max (N.size_nat x) (N.size_nat y). 129 | Proof. 130 | destruct x,y;cbn. 1-3:Lia.nia. 131 | rewrite !pos_size_eq_log2. 132 | destruct (@Pos.leb_spec0 p p0). 133 | 2:rename n into l;apply Pos.lt_nle,Pos.lt_le_incl in l. 134 | all:setoid_rewrite l at 1. 135 | replace (p0 + p0)%positive with (2*p0)%positive;[|Lia.lia]. 136 | 2: replace (p + p)%positive with (2*p)%positive;[|Lia.lia]. 137 | all:rewrite Pos2Nat.inj_mul. 138 | all:change (Pos.to_nat 2) with 2. 139 | all:rewrite Nat.log2_double;[|now eauto using Pos2Nat.is_pos]. all:Lia.lia. 140 | Qed. 141 | -------------------------------------------------------------------------------- /theories/L/Datatypes/LComparison.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import Tactics.LTactics. 2 | From Undecidability.L Require Import Tactics.GenEncode. 3 | 4 | (** *** Encoding for Comparisons *) 5 | 6 | MetaCoq Run (tmGenEncode "comparison_enc" comparison). 7 | #[export] 8 | Hint Resolve comparison_enc_correct : Lrewrite. 9 | 10 | 11 | -------------------------------------------------------------------------------- /theories/L/Datatypes/LDepPair.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L.Tactics Require Import LTactics GenEncode. 2 | 3 | Section sig. 4 | Context {A : Type} {reg_A : encodable A} {P: A -> Prop}. 5 | Import L_Notations. 6 | 7 | 8 | Global Instance encodable_sig : encodable(sig P). 9 | Proof using reg_A. 10 | apply (registerAs (proj1_sig (P:=P))). 11 | Defined. (* because encodable *) 12 | 13 | Lemma enc_sig_eq (x:sig P): 14 | enc x = enc (proj1_sig x). 15 | Proof. 16 | reflexivity. 17 | Qed. 18 | 19 | Lemma enc_sig_exist_eq x Hx : 20 | enc (exist P x Hx) = enc x. 21 | Proof. 22 | reflexivity. 23 | Qed. 24 | 25 | Global Instance termT_proj1_sig : computableTime' (proj1_sig (P:=P)) (fun _ _ => (1,tt)). 26 | Proof. 27 | apply cast_computableTime. 28 | Qed. 29 | 30 | 31 | 32 | End sig. 33 | 34 | 35 | 36 | 37 | 38 | (* 39 | Section sigT. 40 | Variable A : Type. 41 | Context `{reg_A : encodable A}. 42 | Variable P : A -> Type. 43 | Context `{reg_P : forall x, encodable(P x)}. 44 | Import L_Notations. 45 | 46 | Definition sigT_enc : encodable (sigT P) := 47 | fun '@existT _ _ x y => lam (0 (enc x) (enc y)). 48 | 49 | Global Instance encodable_sigT : encodable(sigT P). 50 | Proof. 51 | exists sigT_enc. 52 | -intros []. cbn. Lproc. 53 | -intros [] [] H. inv H. eapply inj_enc in H1. subst x. apply inj_enc in H2. subst p. easy. 54 | Defined. 55 | 56 | End sigT. 57 | *) -------------------------------------------------------------------------------- /theories/L/Datatypes/LNat.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L.Datatypes Require Export LNat. 2 | 3 | Definition c__sqrt_iter := 5. 4 | Definition sqrt_iter_time (k p q r: nat) := 4 + 20 * k. 5 | #[global] Instance termT_sqrt_iter: 6 | computableTime Nat.sqrt_iter 7 | (fun k _ => (c__sqrt_iter, (fun p _ => (1, (fun q _ => (1, (fun r _ => (sqrt_iter_time k p q r, tt)))))))). 8 | Proof. 9 | extract; solverec; try solve [reflexivity]. 10 | all: unfold sqrt_iter_time, c__sqrt_iter. 11 | - now ring_simplify. 12 | - lia. 13 | Qed. 14 | 15 | Definition sqrt_time n := c__sqrt_iter + sqrt_iter_time n 0 0 0 + 3. 16 | #[global] Instance termT_sqrt: 17 | computableTime Nat.sqrt (fun n _ => (sqrt_time n, tt)). 18 | Proof. now extract; solverec. Qed. -------------------------------------------------------------------------------- /theories/L/Functions/BinNums.v: -------------------------------------------------------------------------------- 1 | From Complexity.L.Functions Require Export BinNumsAdd BinNumsSub. 2 | 3 | -------------------------------------------------------------------------------- /theories/L/Functions/BinNumsAdd.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import Tactics.LTactics. 2 | Require Import Numbers.BinNums. 3 | 4 | From Undecidability.L.Datatypes Require Import LNat LBool. 5 | From Complexity.L Require Import LBinNums. 6 | 7 | (** *** Addition of binary numbers *) 8 | Fixpoint addC (c:bool) (x : positive) {struct x}: positive -> positive:= 9 | (if c then 10 | match x with 11 | | p~1 => fun y => match y with 12 | | q~1 => (addC true p q)~1 13 | | q~0 => (addC true p q)~0 14 | | 1 => (Pos.succ p)~1 15 | end 16 | | p~0 => fun y => match y with 17 | | q~1 => (addC true p q)~0 18 | | q~0 => (addC false p q)~1 19 | | 1 => (Pos.succ p)~0 20 | end 21 | | 1 => fun y => match y with 22 | | q~1 => (Pos.succ q)~1 23 | | q~0 => (Pos.succ q)~0 24 | | 1 => 3 25 | end 26 | end 27 | else 28 | match x with 29 | | p~1 => fun y => match y with 30 | | q~1 => (addC true p q)~0 31 | | q~0 => (addC false p q)~1 32 | | 1 => (Pos.succ p)~0 33 | end 34 | | p~0 => fun y => match y with 35 | | q~1 => (addC false p q)~1 36 | | q~0 => (addC false p q)~0 37 | | 1 => p~1 38 | end 39 | | 1 => fun y => match y with 40 | | q~1 => (Pos.succ q)~0 41 | | q~0 => q~1 42 | | 1 => 2 43 | end 44 | end)%positive. 45 | 46 | Lemma addC_ext_eq : extEq addC (fun b => if b then Pos.add_carry else Pos.add). 47 | Proof. 48 | intros b x y. induction x in b,y|-*;destruct b,y;cbn;try rewrite !IHx. all:reflexivity. 49 | Qed. 50 | 51 | Global Instance termT_Pos_addC: computableTime' addC (fun b _ => (5%nat,fun x _ => (11%nat,fun y _ => (12*(Pos.size_nat x + Pos.size_nat y),tt)))). 52 | Proof. 53 | extract. solverec. 54 | Qed. 55 | 56 | Global Instance termT_Pos_add: computableTime' Pos.add (fun x _ => (17%nat,fun y _ => (12*(Pos.size_nat x + Pos.size_nat y),tt))). 57 | Proof. 58 | eapply computableTimeExt with (x:= (fun x => addC false x)). 59 | -hnf;repeat intro;eapply addC_ext_eq. 60 | -extract. solverec. 61 | Qed. 62 | 63 | #[export] 64 | Instance termT_N_add: computableTime' N.add (fun x _ => (1,fun y _ => (12*(N.size_nat x + N.size_nat y) + 27 ,tt))). 65 | Proof. 66 | unfold N.add. 67 | extract. solverec. 68 | Qed. 69 | -------------------------------------------------------------------------------- /theories/L/Functions/BinNumsCompare.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import Tactics.LTactics. 2 | Require Import Numbers.BinNums. 3 | From Undecidability.L.Datatypes Require Import LNat LBool. 4 | From Complexity.L Require Import LBinNums LComparison. 5 | 6 | Import Nat. 7 | #[export] 8 | Instance termT_Pos_compare_cont : computableTime' Pos.compare_cont (fun _ _ => (5,fun x _ => (1,fun y _ => (min (Pos.size_nat x) (Pos.size_nat y)*17,tt)))). 9 | Proof. 10 | unfold Pos.compare_cont. 11 | extract. solverec. 12 | Qed. 13 | 14 | #[export] 15 | Instance term_Pos_compare : computableTime' Pos.compare (fun x _ => (7,fun y _ => (min (Pos.size_nat x) (Pos.size_nat y)*17,tt))). 16 | Proof. 17 | change Pos.compare with (fun x => Pos.compare x). unfold Pos.compare. set (WorkAround:=Pos.compare_cont). 18 | extract. solverec. 19 | Qed. 20 | 21 | #[export] 22 | Instance termT_N_compare : computableTime' N.compare (fun x _ => (1,fun y _ => (min (N.size_nat x) (N.size_nat y)*17+ 16,tt))). 23 | Proof. 24 | unfold N.compare. set (WorkAround:=Pos.compare). 25 | extract. solverec. 26 | Qed. 27 | 28 | Import N. 29 | #[export] 30 | Instance termT_N_leb : computableTime' N.leb (fun x _ => (1,fun y _ => (Nat.min (N.size_nat x) (N.size_nat y)*17+ 22,tt))). 31 | Proof. 32 | extract. solverec. 33 | Qed. 34 | 35 | #[export] 36 | Instance termT_N_ltb : computableTime' N.ltb (fun x _ => (1,fun y _ => (Nat.min (N.size_nat x) (N.size_nat y)*17+ 22,tt))). 37 | Proof. 38 | extract. solverec. 39 | Qed. 40 | 41 | #[export] 42 | Instance termT_N_eqb : computableTime' N.eqb (fun x _ => (1,fun y _ => (Nat.min (N.size_nat x) (N.size_nat y)*17+ 22,tt))). 43 | Proof. 44 | eapply computableTimeExt with (x:=fun x y : N => match (x ?= y)%N with 45 | | Eq => true 46 | | _ => false 47 | end). 48 | -repeat intro. hnf. now rewrite N.eqb_compare. 49 | -extract. solverec. 50 | Qed. 51 | -------------------------------------------------------------------------------- /theories/L/Functions/BinNumsSub.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import Tactics.LTactics. 2 | Require Import Numbers.BinNums. 3 | 4 | From Undecidability.L.Datatypes Require Import LNat LBool. 5 | From Complexity.L Require Import LBinNums. 6 | (** *** Subtraction of binary Numbers *) 7 | 8 | 9 | Import GenEncode. 10 | MetaCoq Run (tmGenEncode "mask_enc" Pos.mask). 11 | 12 | #[export] 13 | Hint Resolve mask_enc_correct : Lrewrite. 14 | 15 | Section pos_sub. 16 | 17 | Import Pos. 18 | 19 | Fixpoint sub_maskC (c:bool) (x y : positive) {struct y} : mask := 20 | (if negb c then 21 | match x with 22 | | p~1 => match y with 23 | | q~1 => double_mask (sub_maskC false p q) 24 | | q~0 => succ_double_mask (sub_maskC false p q) 25 | | 1 => IsPos p~0 26 | end 27 | | p~0 => match y with 28 | | q~1 => succ_double_mask (sub_maskC true p q) 29 | | q~0 => double_mask (sub_maskC false p q) 30 | | 1 => IsPos (pred_double p) 31 | end 32 | | 1 => match y with 33 | | 1 => IsNul 34 | | _ => IsNeg 35 | end 36 | end 37 | else 38 | match x with 39 | | p~1 => match y with 40 | | q~1 => succ_double_mask (sub_maskC true p q) 41 | | q~0 => double_mask (sub_maskC false p q) 42 | | 1 => IsPos (pred_double p) 43 | end 44 | | p~0 => match y with 45 | | q~1 => double_mask (sub_maskC true p q) 46 | | q~0 => succ_double_mask (sub_maskC true p q) 47 | | 1 => double_pred_mask p 48 | end 49 | | 1 => IsNeg 50 | end)%positive. 51 | 52 | Lemma sub_maskC_ext_eq : extEq sub_maskC (fun b => if b then sub_mask_carry else sub_mask). 53 | Proof. 54 | intros b x y. induction x in b,y|-*;destruct b,y;cbn;try rewrite !IHx. all:reflexivity. 55 | Qed. 56 | 57 | Global Instance termT_isPos : computableTime' IsPos (fun x _ => (1,tt)). 58 | Proof. 59 | extract constructor. solverec. 60 | Qed. 61 | 62 | 63 | Global Instance termT_Pos_double_mask: computableTime' double_mask (fun x _ => (8,tt)). 64 | Proof. 65 | extract. solverec. 66 | Qed. 67 | 68 | Global Instance termT_Pos_succ_double_mask: computableTime' succ_double_mask (fun x _ => (8,tt)). 69 | Proof. 70 | extract. solverec. 71 | Qed. 72 | 73 | Global Instance termT_Pos_pred_double: computableTime' pred_double (fun x _ => (size_nat x * 12 + 9,tt)). 74 | Proof. 75 | extract. solverec. 76 | Qed. 77 | 78 | Global Instance termT_Pos_double_pred_mask: computableTime' double_pred_mask (fun x _ => (size_nat x * 12 + 5,tt)). 79 | Proof. 80 | extract. solverec. 81 | Qed. 82 | 83 | Global Instance termT_Pos_pred : computableTime' pred (fun x _ => (size_nat x * 12 + 3,tt)). 84 | Proof. 85 | extract. solverec. 86 | Qed. 87 | 88 | Global Instance termT_Pos_predN : computableTime' pred_N (fun x _ => (size_nat x * 12 + 4,tt)). 89 | Proof. 90 | extract. solverec. 91 | Qed. 92 | 93 | Global Instance termT_Pos_sub_maskC: computableTime' sub_maskC (fun b _ => (5%nat,fun x _ => (1%nat,fun y _ => (size_nat x*32,tt)))). 94 | Proof. 95 | extract. solverec. 96 | Qed. 97 | 98 | Global Instance termT_Pos_sub_mask: computableTime' sub_mask (fun x _ => (7%nat,fun y _ => (size_nat x*32,tt))). 99 | Proof. 100 | eapply computableTimeExt with (x:= fun x => sub_maskC false x). 101 | -repeat intro. hnf. eapply sub_maskC_ext_eq. 102 | -extract. solverec. 103 | Qed. 104 | 105 | Global Instance termT_Pos_sub: computableTime' Pos.sub (fun x _ => (1%nat,fun y _ => (size_nat x*32 + 13,tt))). 106 | Proof. 107 | extract. solverec. 108 | Qed. 109 | 110 | End pos_sub. 111 | 112 | #[export] 113 | Instance termT_N_sub: computableTime' N.sub (fun x _ => (1,fun y _ => (N.size_nat x*32 + 22 ,tt))). 114 | Proof. 115 | extract. solverec. 116 | Qed. 117 | 118 | #[export] 119 | Instance termT_N_pred: computableTime' N.pred (fun x _ => (N.size_nat x*12 + 9 ,tt)). 120 | Proof. 121 | extract. solverec. 122 | Qed. 123 | -------------------------------------------------------------------------------- /theories/L/Functions/IterupN.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L.Datatypes Require Import LProd LOptions LBool. 2 | From Undecidability.L Require Import Tactics.LTactics. 3 | From Complexity.L Require Import Datatypes.LBinNums Functions.BinNums Functions.BinNumsCompare. 4 | 5 | 6 | Definition iterupN {X} i max x f := 7 | fst (@N.peano_rect (fun _ => X*N)%type (x,i%N) (fun _ '(x,i) => (f i x,N.succ i)) (max-i)). 8 | 9 | Lemma iterupN_eq {X} i max {x:X} f : 10 | iterupN i max x f = if (i = max)%N -> iterupN i max x f = x. 24 | Proof. 25 | intros. rewrite iterupN_eq. destruct (N.ltb_spec0 i max). all:easy. 26 | Qed. 27 | 28 | Lemma iterupN_lt {X} i max {x:X} f : 29 | (i < max)%N -> iterupN i max x f = iterupN (N.succ i) max (f i x) f. 30 | Proof. 31 | intros H. rewrite iterupN_eq. destruct (N.ltb_spec0 i max). all:easy. 32 | Qed. 33 | 34 | (* Instance term_iterupN X `{H:encodable X} : *) 35 | (* computableTime' (iterupN (X:=X)) (fun i (_:unit) => *) 36 | (* (5,fun max (_:unit) => *) 37 | (* (1,fun x (_:unit) => *) 38 | (* (1,fun f (fT: _ -> unit -> (nat * (_ -> unit -> (nat *unit)))) => (cnst (i,x),tt))))). *) 39 | (* Proof. *) 40 | (* pose (s := rho (λ F i max x f, (!!(extT N.ltb) i max) (λ _ , F (!!(extT N.succ) i) max (f i x) f) (λ _ , x) I)). *) 41 | (* cbv [convert TH minus] in s. *) 42 | 43 | (* exists s. unfold s. Intern.recRem P. *) 44 | (* eapply computesTimeExpStart. now Lproc. *) 45 | (* eexists. *) 46 | (* eapply computesTimeExpStep. 2:now Lsimpl. reflexivity. now Lproc. *) 47 | (* intros i iExt iT iExts. cbn in iExts. subst iExt. *) 48 | 49 | (* eexists. *) 50 | (* eapply computesTimeExpStep. *) 51 | (* 2:{Intern.recStepUnnamed. now Lsimpl. } *) 52 | (* reflexivity. now Lproc. *) 53 | (* intros max yExt yT yExts. cbn in yExts. subst yExt. *) 54 | (* cbn [fst snd]. *) 55 | 56 | (* remember ((max - i)%N) as d eqn:eqd. *) 57 | (* revert i max eqd. *) 58 | (* induction d using N.peano_rect. *) 59 | (* all:intros i max eqd. *) 60 | (* all:eexists. *) 61 | (* all:eapply computesTimeExpStep. *) 62 | (* 2,6:now Intern.recStepUnnamed; Lsimpl. *) 63 | (* 1,4:reflexivity. *) 64 | (* 1,3:Lproc. *) 65 | 66 | (* all:intros x xExt xT xExts. *) 67 | (* all:hnf in xExts; subst xExt. *) 68 | (* all:cbn [fst snd]. *) 69 | 70 | (* all:eexists. *) 71 | (* all:eapply computesTimeExpStep. *) 72 | (* 2,6:now Intern.recStepUnnamed; Lsimpl. *) 73 | (* 1,4:reflexivity. *) 74 | (* 1,3:Lproc. *) 75 | 76 | 77 | (* all:intros f fExt fT fExts. *) 78 | (* all:change fExt with (@extT _ _ f _ (Build_computableTime' fExts)). *) 79 | (* 2: apply f_equal with (f:=N.pred) in eqd;rewrite N.pred_succ,<- N.sub_succ_r in eqd. *) 80 | (* all:eexists;split. *) 81 | (* all:cbn [fst snd]. *) 82 | (* 1,2:assert (N.ltb i max = false) by (apply N.ltb_ge;Lia.lia). *) 83 | (* 1,3:eapply le_evalLe_proper;[ | reflexivity..| ]. *) 84 | (* 2:{ Intern.recStepUnnamed. Lsimpl. Intern.extractCorrectCrush_new. congruence. } *) 85 | (* {rewrite H2. cbn[fst snd]. ring_simplify. admit. } *) 86 | (* 2:{ Intern.recStepUnnamed. Lsimpl. Intern.extractCorrectCrush_new. } *) 87 | (* 2:{ rewrite H2. rewrite iterupN_geq. easy. Lia.lia. } *) 88 | (* 2:{ destruct (N.ltb_spec0 i max). *) 89 | (* -rewrite iterupN_lt. all:easy. *) 90 | (* -rewrite iterupN_geq. all:easy. *) 91 | (* } *) 92 | (* recRel_prettify2. *) 93 | (* all:cbn [fst snd]. *) 94 | (* :unfold iterupN. repeat Intern.cstep. *) 95 | (* 2,3:hnf. *) 96 | (* {rewrite } *) 97 | (* intros. *) 98 | (* destruct (NIntern.rexStepInit P. .ltb_spec0 i max). *) 99 | (* rewrite iterupN_lt. 2:easy. *) 100 | (* reflexivity. *) 101 | (* rewrite iterupN_geq. all:easy. *) 102 | (* Unshelve. all:now try constructor;try exact _;try eauto;try exact 0. *) 103 | (* Qed. *) 104 | 105 | Import HOAS_Notations. 106 | Import N. 107 | #[export] 108 | Instance term_iterupN X `{H:encodable X} : 109 | computable (iterupN (X:=X)). 110 | Proof. 111 | pose (s := rho [L_HOAS λ F i max x f, (!!(ext N.ltb) i max) (λ _ , F (!!(ext N.succ) i) max (f i x) f) (λ _ , x) !!I]). 112 | cbv [convert TH minus] in s. 113 | 114 | exists s. unfold s. Intern.recRem P. 115 | eapply computesExpStart. now Lproc. 116 | eexists. 117 | eapply computesExpStep. now Lreflexivity. now Lproc. 118 | intros i iExt iExts. cbn in iExts. subst iExt. 119 | 120 | eexists. 121 | eapply computesExpStep. Intern.recStepNew P. now Lsimpl. now Lproc. 122 | intros max yExt yExts. cbn in yExts. subst yExt. 123 | 124 | 125 | remember ((max - i)%N) as d eqn:eqd. 126 | revert i max eqd. 127 | induction d using N.peano_rect. 128 | all:intros i max eqd. 129 | all:eexists. 130 | all:split. 131 | 1,3:now Intern.recStepNew P;Intern.extractCorrectCrush. 132 | 133 | all:eapply computesTyArr;[Lproc| intros x xExt xExts]. 134 | all:change xExt with (@ext _ _ x (Build_computable xExts)). 135 | all:eexists;split. 136 | 1,3:Intern.extractCorrectCrush. 137 | all:intros. 138 | 139 | all:eapply computesTyArr;[Lproc| intros f fExt fExts]. 140 | all:change fExt with (@ext _ _ f (Build_computable fExts)). 141 | 2: apply f_equal with (f:=N.pred) in eqd;rewrite N.pred_succ,<- N.sub_succ_r in eqd. 142 | all:eexists;split. 143 | 1,2:assert (N.ltb i max = false) by (apply N.ltb_ge;Lia.lia). 144 | 1:{Intern.extractCorrectCrush. congruence. } 145 | {rewrite H3. rewrite iterupN_geq. 2:Lia.lia. reflexivity. } 146 | {Intern.extractCorrectCrush. } 147 | intros. 148 | destruct (N.ltb_spec0 i max). 149 | rewrite iterupN_lt. 2:easy. 150 | reflexivity. 151 | rewrite iterupN_geq. all:easy. 152 | Unshelve. all:now try constructor;try exact _;try eauto;try exact 0. 153 | Qed. 154 | -------------------------------------------------------------------------------- /theories/L/TM/TMflat.v: -------------------------------------------------------------------------------- 1 | From Undecidability Require Import TM.Util.TM_facts. 2 | Require Import Undecidability.Shared.Libs.PSL.FiniteTypes. 3 | 4 | (** A firstorder encoding and the connection to an arbitrary TM *) 5 | Inductive flatTM : Type := 6 | { sig : nat; 7 | tapes : nat; 8 | states : nat; 9 | trans : list ((nat * list (option nat)) * (nat * list (option nat * move))); 10 | start : nat; 11 | halt : list bool 12 | }. 13 | 14 | Inductive isFlatteningTransOf {st sig : finType} {n} 15 | (f:list (nat * list (option nat) * (nat * list (option nat * move)))) 16 | (f': st * Vector.t (option sig) n -> st * Vector.t (option sig * move) n): Prop := 17 | mkIsFlatteningTransOf 18 | (R__sound : 19 | (forall s s' v v', (((s,v),(s',v')) el f -> 20 | ((exists s0 s0' v0 v0', ( f' (s0,v0) = (s0', v0') 21 | /\ s = index s0 22 | /\ s' = index s0' 23 | /\ v = map (option_map index) (Vector.to_list v0) 24 | /\ v' = map (map_fst (option_map index)) (Vector.to_list v0'))))))) 25 | (R_complete : (forall s0 v0, let (s0',v0') := f' (s0,v0) 26 | in ((index s0,map (option_map index) (Vector.to_list v0)) 27 | ,(index s0',map (map_fst (option_map index)) (Vector.to_list v0'))) el f 28 | \/ (s0=s0' /\ v0' = Vector.const (None,TM.Nmove) n))) 29 | : isFlatteningTransOf f f'. 30 | 31 | Inductive isFlatteningHaltOf {st:finType} (f : list bool) (f' : st -> bool) : Prop := 32 | mkIsFlatteningHaltOf 33 | (R__halt : forall (p:st), 34 | nth (index p) f false = f' p) : isFlatteningHaltOf f f'. 35 | 36 | Inductive isFlatteningTMOf {sig' n} (M:flatTM) (M': TM sig' n) : Prop := 37 | mkIsFlatteningTMOf 38 | (eq__tapes : tapes M = n) 39 | (eq__sig : sig M = |elem sig'|) 40 | (eq__states : (states M) = |elem (TM.state M')| ) 41 | (R__trans : isFlatteningTransOf (trans M) (TM.trans (m:=M'))) 42 | (eq__start : start M = index (TM.start M')) 43 | (R__halt : isFlatteningHaltOf (halt M) (TM.halt (m:=M'))) 44 | : isFlatteningTMOf M M'. 45 | 46 | Inductive isFlatteningTapesOf {sig : finType} {n}: list (tape nat) -> Vector.t (tape sig) n -> Prop := 47 | mkIsFlatteningTapeOf t : isFlatteningTapesOf (Vector.to_list(mapTapes index t)) t. 48 | 49 | 50 | Lemma isFlatteningTapesOf_iff (sig : finType) (n : nat) y (t:Vector.t (tape sig) n): 51 | isFlatteningTapesOf y t <-> y = (Vector.to_list (mapTapes index t)). 52 | Proof. 53 | split. now inversion 1. intros ->;easy. 54 | Qed. 55 | 56 | Definition mconfigFlat :Type := nat * list (tape nat). 57 | Inductive isFlatteningConfigOf {st sig : finType} {n}: mconfigFlat -> mconfig st sig n -> Prop := 58 | mkisFlatteningConfigOf t c' (Ht:isFlatteningTapesOf t c'.(ctapes)) 59 | : isFlatteningConfigOf (index c'.(cstate),t) c'. 60 | 61 | 62 | Lemma isFlatteningConfigOf_iff {st sig : finType} n c (c' : mconfig st sig n): 63 | isFlatteningConfigOf c c' <-> exists t, isFlatteningTapesOf t c'.(ctapes) /\ c = (index c'.(cstate),t). 64 | Proof. 65 | split. inversion 1;subst. eauto. intros (?&?&->). easy. 66 | Qed. 67 | -------------------------------------------------------------------------------- /theories/L/TM/TMflatEnc.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L.Tactics Require Import LTactics GenEncode. 2 | From Undecidability.L.Datatypes Require Import LNat Lists LProd LOptions LBool. 3 | From Undecidability.L Require Import Functions.Decoding. 4 | 5 | 6 | From Complexity.L.TM Require Export TMflat. 7 | From Undecidability.L.TM Require Import TMEncoding. 8 | 9 | Import Nat TM_facts. 10 | Import TMflat. 11 | Import GenEncode. 12 | MetaCoq Run (tmGenEncode "flatTM_enc" flatTM). 13 | #[export] 14 | Hint Resolve flatTM_enc_correct : Lrewrite. 15 | 16 | 17 | #[export] 18 | Instance term_Build_TM : computableTime' (Build_flatTM) (fun _ _ => (1,fun _ _ => (1,fun _ _ => (1,fun _ _ => (1,fun _ _ => (1,fun _ _ => (1,tt))))))). 19 | Proof. 20 | extract constructor. solverec. 21 | Qed. 22 | 23 | #[export] 24 | Instance term_sig : computableTime' sig (fun _ _ => (9,tt)). 25 | Proof. 26 | extract. solverec. 27 | Qed. 28 | 29 | 30 | #[export] 31 | Instance term_tapes : computableTime' tapes (fun _ _ => (9,tt)). 32 | Proof. 33 | extract. solverec. 34 | Qed. 35 | 36 | #[export] 37 | Instance term_states : computableTime' states (fun _ _ => (9,tt)). 38 | Proof. 39 | extract. solverec. 40 | Qed. 41 | 42 | #[export] 43 | Instance term_trans : computableTime' trans (fun _ _ => (9,tt)). 44 | Proof. 45 | extract. solverec. 46 | Qed. 47 | 48 | #[export] 49 | Instance term_start : computableTime' start (fun _ _ => (9,tt)). 50 | Proof. 51 | extract. solverec. 52 | Qed. 53 | 54 | #[export] 55 | Instance term_halt : computableTime' halt (fun _ _ => (9,tt)). 56 | Proof. 57 | extract. solverec. 58 | Qed. 59 | 60 | 61 | (* 62 | Definition TM_decode (s : term) : option TM := 63 | match s with 64 | | lam (app(app(app(app(app (app O sig) tapes) states) trans) start) halt) => 65 | match decode nat sig,decode nat tapes, decode nat states, decode (list (nat * list (option nat) * (nat * list (option nat * TM.move)))) trans, decode nat start, decode (list bool) halt with 66 | Some sig, Some tapes, Some states, Some trans, Some start, Some halt => 67 | Some (Build_TM sig tapes states trans start halt) 68 | | _,_,_,_,_,_ => None 69 | end 70 | | _ => None 71 | end. 72 | 73 | Arguments list_decode : clear implicits. 74 | Arguments list_decode _ {_ _} _. 75 | 76 | #[export] 77 | Instance decode_TM : decodable TM. 78 | Proof. 79 | exists (list_decode X). 80 | all:unfold enc at 1. all:cbn. 81 | -induction x;cbn. 82 | +easy. 83 | +setoid_rewrite decode_correct. now rewrite IHx. 84 | -apply (size_induction (f := size) (p := (fun t => forall x, list_decode X t = Some x -> list_enc x = t))). intros t IHt s. 85 | destruct t eqn:eq. all:cbn. 86 | all:repeat let eq := fresh in destruct _ eqn:eq. all:try congruence. 87 | all:intros [= <-]. 88 | +easy. 89 | +cbn. change (match H with 90 | | @mk_encodable_ enc _ _ => enc 91 | end x) with (enc x). erewrite decode_correct2. 2:easy. 92 | erewrite IHt. 93 | *reflexivity. 94 | *cbn;lia. 95 | *easy. 96 | Qed. 97 | 98 | 99 | #[export] 100 | Instance linDec_TM : linTimeDecodable TM. 101 | Proof. 102 | exists c__encTM. 103 | eexists _. 104 | eapply computesTime_timeLeq. 105 | 2:now apply term_TM_enc. 106 | intros l _. split. 2:easy. 107 | cbn [fst]. reflexivity. 108 | Qed. 109 | 110 | *) 111 | 112 | Lemma size_TM (M:flatTM): 113 | size (enc M) = let (a,b,c,d,e,f) := M in size (enc a) + size (enc b) +size (enc c) +size (enc d) + size (enc e) + size (enc f) + 8. 114 | Proof. 115 | unfold enc;cbn. destruct M as []. cbn. solverec. 116 | Qed. 117 | 118 | From Complexity.Complexity Require Export EncodableP LinTimeDecodable. 119 | 120 | 121 | #[export] 122 | Instance term_move_enc 123 | :computableTime' (enc (X:=move)) (fun x _ => (15,tt)). 124 | Proof. 125 | unfold enc;cbn. extract. solverec. 126 | Qed. 127 | 128 | #[export] 129 | Instance regP_move : encodableP TM.move. 130 | Proof. 131 | evar (c:nat). 132 | exists c. 133 | eexists _. 134 | eapply computesTime_timeLeq. 135 | 2:now apply term_move_enc. 136 | intros l _. split. 2:easy. 137 | cbn. 138 | [c]:exact (4). unfold c. 139 | destruct l;cbv. all:lia. 140 | Qed. 141 | 142 | 143 | Definition c__encTM := max (c__regP (list (nat * list (option nat) * (nat * list (option nat * TM.move))))) (max (c__regP nat) (max (c__regP (list bool)) 4)). 144 | 145 | #[export] 146 | Instance term_TM_enc 147 | :computableTime' (enc (X:=flatTM)) (fun x _ => (size (enc x) * c__encTM,tt)). 148 | Proof. 149 | unfold enc;cbn. 150 | extract. 151 | intros _ M []. 152 | recRel_prettify2. cbn [size]. 153 | repeat (lazymatch goal with |- context C [ @size ?a] => generalize (@size a);intro end). 154 | assert (H':c__encTM <= c__encTM) by easy. 155 | repeat setoid_rewrite Nat.max_lub_iff in H'. 156 | destruct H' as (H1&H2&H3&H4). 157 | repeat rewrite H1. repeat rewrite H2. repeat rewrite H3. lia. 158 | Qed. 159 | 160 | #[export] 161 | Instance regP_TM : encodableP flatTM. 162 | Proof. 163 | exists c__encTM. 164 | eexists _. 165 | eapply computesTime_timeLeq. 166 | 2:now apply term_TM_enc. 167 | intros l _. split. 2:easy. 168 | cbn [fst]. reflexivity. 169 | Qed. 170 | -------------------------------------------------------------------------------- /theories/L/TM/TapeDecode.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L.Tactics Require Import LTactics GenEncode. 2 | From Undecidability.L.Datatypes Require Import LNat Lists LProd LFinType LOptions LTerm. 3 | From Undecidability.L Require Import TM.TMEncoding. 4 | 5 | From Undecidability Require Import TM.TM. 6 | 7 | From Undecidability.L Require Import Functions.Decoding. 8 | From Complexity.Complexity Require Import Definitions LinTimeDecodable. 9 | 10 | From Undecidability.L.Tactics Require Import LTactics GenEncode. 11 | From Undecidability.L.Datatypes Require Import LNat Lists LProd LFinType LVector. 12 | From Undecidability.L Require Import Functions.EqBool. 13 | 14 | From Undecidability Require Import TM.Util.VectorPrelim. 15 | 16 | 17 | From Undecidability Require Import TM.TM. 18 | Require Import Undecidability.Shared.Libs.PSL.FiniteTypes.FinTypes. 19 | 20 | Import L_Notations. 21 | 22 | From Undecidability Require Import TMEncoding. 23 | 24 | 25 | Import L. 26 | Definition tape_decode X `{decodable X} (s : term) : option (tape X) := 27 | match s with 28 | | lam (lam (lam (lam 3))) => Some (niltape _) 29 | | lam (lam (lam (lam (app ( app 2 c) r)))) => 30 | match decode X c,decode (list X) r with 31 | Some x, Some xs => Some (leftof x xs) 32 | | _,_ => None 33 | end 34 | | lam (lam (lam (lam (app ( app 1 c) l)))) => 35 | match decode X c,decode (list X) l with 36 | Some x, Some xs => Some (rightof x xs) 37 | | _,_ => None 38 | end 39 | | lam (lam (lam (lam (app ( app (app 0 l) c) r)))) => 40 | match decode X c,decode (list X) l,decode (list X) r with 41 | Some x, Some xs, Some r => Some (midtape xs x r) 42 | | _,_,_ => None 43 | end 44 | | _ => None 45 | end. 46 | 47 | Arguments tape_decode : clear implicits. 48 | Arguments tape_decode _ {_ _} _. 49 | 50 | #[export] 51 | Instance decode_tape X {Hreg:encodable X} {Hdec:decodable X}: decodable (tape X). 52 | Proof. 53 | exists (tape_decode X). 54 | all:unfold enc at 1. all:cbn. 55 | -destruct x;cbn. 56 | all:repeat setoid_rewrite decode_correct. all:easy. 57 | -destruct t eqn:eq. all:cbn. 58 | all:repeat let eq := fresh in destruct _ eqn:eq. all:try congruence. 59 | all:intros ? [= <-]. 60 | easy. 61 | all:cbn. 62 | all: (setoid_rewrite @decode_correct2;[ |try eassumption..]). 63 | all:reflexivity. 64 | Defined (*because instance*). 65 | 66 | 67 | #[export] 68 | Instance linDec_tape X `{_:linTimeDecodable X}: linTimeDecodable (tape X). 69 | Proof. 70 | evar (c:nat). exists c. 71 | unfold decode, decode_tape,tape_decode. 72 | extract. 73 | recRel_prettify2;cbn[size];ring_simplify. idtac. 74 | [c]:exact (max (c__linDec (list X)) (max (c__linDec (X)) 11)). 75 | all:unfold c;try nia. 76 | Qed. 77 | -------------------------------------------------------------------------------- /theories/Libs/CookPrelim/Tactics.v: -------------------------------------------------------------------------------- 1 | From Undecidability.Shared.Libs.PSL Require Import Base. 2 | Require Import Lia. 3 | Require Import ssrbool. 4 | 5 | Ltac simp_bool := repeat match goal with 6 | | [ H: negb (?b) = true , H' : ?b = true |- _] => rewrite negb_true_iff in H; congruence 7 | | [H : negb (?b) = false |- _] => apply ssrbool.negbFE in H; unfold is_true in H 8 | | [H : negb (?b) = true |- _] => apply ssrbool.negbTE in H 9 | | [ H : andb (?b1) (?b2) = true |- _] => apply andb_prop in H; 10 | let a := fresh "H" in 11 | let b := fresh "H" in 12 | destruct H as [a b] 13 | | [H : true = andb ?b1 ?b2 |- _ ] => symmetry in H; simp_bool 14 | | [H : andb (?b1) (?b2) = false |- _] => apply andb_false_elim in H; 15 | destruct H as [H | H] 16 | | [H : false = andb (?b1) (?b2) |- _] => symmetry in H; simp_bool 17 | | [ |- context[andb (?b1) (?b2) = false]] => rewrite andb_false_iff 18 | | [ |- andb (?b1) (?b2) = true] => apply andb_true_intro 19 | | [ H : context [orb (?b1) false] |- _] => rewrite orb_false_r in H 20 | | [ |- context [orb ?b1 false] ] => rewrite orb_false_r 21 | | [ |- context[negb ?b = true]] => rewrite negb_true_iff 22 | | [ |- context[negb ?b = false]] => rewrite negb_false_iff 23 | end; try congruence. 24 | 25 | Ltac simp_bool' := repeat (match goal with 26 | | [H : ?b = true |- _ ] => rewrite H in *; clear H 27 | | [H : ?b = false |- _] => rewrite H in *; clear H 28 | | [H : true = ?b |- _] => symmetry in H; simp_bool 29 | | [H : false = ?b |- _] => symmetry in H; simp_bool 30 | end; simp_bool). 31 | 32 | Local Lemma eqb_false_iff a b : Bool.eqb a b = false <-> a <> b. 33 | Proof. 34 | split. 35 | - intros H1 H2%eqb_true_iff; congruence. 36 | - intros H1; destruct (eqb a b) eqn:H2; try reflexivity. rewrite eqb_true_iff in H2; congruence. 37 | Qed. 38 | 39 | Ltac dec_bool := repeat match goal with 40 | | [ H : Bool.eqb ?b ?b0 = true |- _ ] => 41 | let h := fresh "H" in assert (Is_true (Bool.eqb b b0)) as h by firstorder; 42 | apply eqb_eq in h; clear H 43 | | [H : Bool.eqb ?b ?b0 = false |- _] => apply eqb_false_iff in H 44 | | [ H : Nat.eqb ?n ?n0 = true |- _] => apply Nat.eqb_eq in H 45 | | [ H : Nat.eqb ?n ?n0 = false |- _] => apply Nat.eqb_neq in H 46 | | [ |- Nat.eqb ?n ?n0 = true ] => apply Nat.eqb_eq 47 | | [ |- Nat.eqb ?n ?n0 = false] => apply Nat.eqb_neq 48 | | [ |- Bool.eqb ?n ?n0 = true] => apply eqb_true_iff 49 | | [ |- Bool.eqb ?n ?n0 = false] => apply eqb_false_iff 50 | | [ H : Nat.leb ?n ?n0 = true |- _] => apply leb_complete in H 51 | | [ H : Nat.leb ?n ?n0 = false |- _ ] => apply leb_complete_conv in H 52 | | [ |- Nat.leb ?n ?n0 = true ] => apply leb_correct 53 | | [ |- Nat.leb ?n ?n0 = false] => apply leb_correct_conv 54 | end; try congruence; try tauto. 55 | 56 | Lemma singleton_incl (X : Type) (a : X) (h : list X) : 57 | [a] <<= h <-> a el h. 58 | Proof. 59 | split; intros. 60 | - now apply H. 61 | - now intros a' [-> | []]. 62 | Qed. 63 | 64 | Ltac force_In := match goal with 65 | | [ |- ?a el ?a :: ?h] => left; reflexivity 66 | | [ |- ?a el ?b :: ?h] => right; force_In 67 | | [ |- [?a] <<= ?h] => apply singleton_incl; force_In 68 | end. 69 | 70 | Ltac destruct_or H := match type of H with 71 | | ?a \/ ?b => destruct H as [H | H]; try destruct_or H 72 | end. 73 | Lemma S_injective a b : S a = S b -> a = b. 74 | Proof. congruence. Qed. 75 | 76 | Ltac list_length_inv := repeat match goal with 77 | | [H : S _ = |?a| |- _] => is_var a; destruct a; cbn in H; [ congruence | apply S_injective in H] 78 | | [H : 0 = |?a| |- _] => is_var a; destruct a; cbn in H; [ clear H| congruence] 79 | | [H : |?a| = _ |- _] => symmetry in H 80 | | [H : S _ >= S _ |- _] => apply Peano.le_S_n in H 81 | | [H : S _ <= S _ |- _] => apply Peano.le_S_n in H 82 | | [H : |?a| >= S _ |- _] => is_var a; destruct a; cbn in H; [lia | ] 83 | | [H : S _ <= |?a| |- _] => is_var a; destruct a; cbn in H; [lia | ] 84 | end. 85 | 86 | Ltac discr_list := repeat match goal with 87 | | [ H : |[]| = |?x :: ?xs| |- _] => cbn in H; discriminate H 88 | | [ H : |?x :: ?xs| = |[]| |- _] => cbn in H; discriminate H 89 | | [H : |?x :: ?xs| = 0 |- _] => cbn in H; discriminate H 90 | | [H : 0 = |?x :: ?xs| |- _] => cbn in H; discriminate H 91 | | [H : |[]| = S ?z |- _] => cbn in H; discriminate H 92 | | [H : S ?z = |[]| |- _] => cbn in H; discriminate H 93 | end. 94 | Ltac inv_list := repeat match goal with 95 | | [H : |[]| = |?xs| |- _] => destruct xs; [ | discr_list]; cbn in H 96 | | [H : |?x :: ?xs| = |?ys| |- _] => destruct ys; [ discr_list | ]; cbn in H 97 | | [H : |?xs| = 0 |- _] => destruct xs; [ | discr_list ]; cbn in H 98 | | [H : 0 = |?xs| |- _] => destruct xs; [ | discr_list ]; cbn in H 99 | | [H : |?xs| = S ?z |- _] => destruct xs ; [ discr_list | ]; cbn in H 100 | | [H : S ?z = |?xs| |- _] => destruct xs; [ discr_list | ]; cbn in H 101 | end. 102 | 103 | 104 | Ltac simp_comp_arith := cbn -[Nat.add Nat.mul]; repeat change (fun x => ?h x) with h. 105 | -------------------------------------------------------------------------------- /theories/Libs/PSLCompat.v: -------------------------------------------------------------------------------- 1 | Require Export Undecidability.Shared.Libs.PSL.FiniteTypes. 2 | Require Import Undecidability.Shared.Libs.PSL.Vectors.Vectors. 3 | 4 | Lemma dupfree_elements (X: finType) : NoDup (elem X). 5 | Proof. 6 | apply (NoDup_count_occ' (@eqType_dec X)). intros x H. 7 | rewrite <- count_count_occ. 8 | apply enum_ok. 9 | Qed. 10 | 11 | (* From PSL/Lists/BaseLists.v *) 12 | Lemma map_repeat (X Y : Type) (f : X -> Y) (n : nat) (a : X) : 13 | map f (repeat a n) = repeat (f a) n. 14 | Proof. 15 | induction n as [|n IHn]. 16 | - reflexivity. 17 | - cbn. now rewrite IHn. 18 | Qed. 19 | 20 | Definition equi X (A B : list X) : Prop := incl A B /\ incl B A. 21 | Notation "A === B" := (equi A B) (at level 70). 22 | 23 | #[global] 24 | Instance equi_Equivalence X : 25 | Equivalence (@equi X). 26 | Proof. 27 | constructor; hnf; firstorder. 28 | Qed. 29 | 30 | #[global] 31 | Instance in_equi_proper X x : 32 | Proper (@equi X ==> iff) (@In X x). 33 | Proof. 34 | intros ???. firstorder. 35 | Qed. 36 | 37 | (* from PSL/Vectors/Vectors.v *) 38 | Lemma vector_to_list_inj (X : Type) (n : nat) (xs ys : Vector.t X n) : 39 | Vector.to_list xs = Vector.to_list ys -> xs = ys. 40 | Proof. 41 | revert ys. induction xs as [ | x n xs IH]; intros; cbn in *. 42 | - destruct_vector. reflexivity. 43 | - destruct_vector. cbn in *. inv H. f_equal. auto. 44 | Qed. 45 | 46 | (* From TM/Util/VectorPrelim.v *) 47 | Lemma nth_error_inj X (xs ys : list X) : 48 | (forall n, nth_error xs n = nth_error ys n) -> xs = ys. 49 | Proof. 50 | induction xs in ys|-*;destruct ys;cbn;intros H. 1:easy. 1-2:now specialize (H 0). 51 | generalize (H 0). intros [= ->]. erewrite IHxs. easy. intros n'. now specialize (H (S n')). 52 | Qed. 53 | 54 | Lemma vector_nth_error_nat X n' i (xs : Vector.t X n') : 55 | nth_error (Vector.to_list xs) i = match lt_dec i n' with 56 | Specif.left H => Some (Vector.nth xs (Fin.of_nat_lt H)) 57 | | _ => None 58 | end. 59 | Proof. 60 | clear. induction xs in i|-*. now destruct i. 61 | cbn in *. destruct i;cbn. easy. rewrite IHxs. do 2 destruct lt_dec. 4:easy. now symmetry;erewrite Fin.of_nat_ext. all:exfalso;Lia.nia. 62 | Qed. 63 | 64 | Lemma vector_to_list_cast (X : Type) (n1 n2 : nat) (H : n1 = n2) (v : Vector.t X n1) : 65 | Vector.to_list (Vector.cast v H) = Vector.to_list v. 66 | Proof. subst. rename n2 into n. induction v as [ | x n v IH]; cbn; f_equal; auto. Qed. 67 | 68 | (* From PSL/FiniteTypes/VectorFin.v *) 69 | Lemma Fin_cardinality n : | elem (finType_CS (Fin.t n)) | = n. 70 | Proof. 71 | apply VectorSpec.length_to_list. 72 | Qed. 73 | 74 | (* from PSL/FiniteTypes/FinTypes.v *) 75 | Lemma index_leq (A:finType) (x:A): index x <= length (elem A). 76 | Proof. apply Nat.lt_le_incl, index_le. Qed. 77 | -------------------------------------------------------------------------------- /theories/Libs/UniformHomomorphisms.v: -------------------------------------------------------------------------------- 1 | From Undecidability.Shared.Libs.PSL Require Import Base FiniteTypes. 2 | From Complexity.Libs Require Import MorePrelim. 3 | Require Import Lia. 4 | 5 | (** * Uniform homomorphisms *) 6 | 7 | (** We define uniform homomorphisms (of strings): Given strings of the same length, they output strings of the same length.*) 8 | Section fixX. 9 | Variable (X Y : Type). 10 | (** ** Homomorphisms *) 11 | 12 | Definition homomorphism (h : list X -> list Y) := forall x1 x2, h (x1 ++ x2) = h x1 ++ h x2. 13 | 14 | Lemma homo_nil h : homomorphism h -> h [] = []. 15 | Proof. 16 | intros. unfold homomorphism in H. specialize (H [] []). 17 | cbn in H; rewrite H. destruct (h []) eqn:Heqn; cbn; [ congruence | ]. 18 | assert (|y :: l| = |(y :: l) ++ y :: l|) as H0 by congruence. 19 | cbn in H0. rewrite app_length in H0. cbn in H0; lia. 20 | Qed. 21 | 22 | Lemma homo_cons h x l : homomorphism h -> h (x::l) = h [x] ++ h l. 23 | Proof. 24 | intros. replace (x :: l) with ([x] ++ l) by now cbn. apply H. 25 | Qed. 26 | 27 | Lemma homo_concat h : homomorphism h -> forall x, h (concat x) = concat (map h x). 28 | Proof. 29 | intros. induction x. 30 | - cbn. apply homo_nil, H. 31 | - cbn. rewrite H. now rewrite IHx. 32 | Qed. 33 | 34 | (** Given an arbitrary function mapping elements of X into strings over Y, we can derive a homomorphism in a canonical way*) 35 | Definition canonicalHom (h' : X -> list Y) := fun (l : list X) => concat (map h' l). 36 | Lemma canonicalHom_is_homomorphism h' : homomorphism (canonicalHom h'). 37 | Proof. 38 | unfold homomorphism. intros. unfold canonicalHom. 39 | now rewrite map_app, concat_app. 40 | Qed. 41 | 42 | Lemma canonicalHom_is_unique h' : forall h'', homomorphism h'' -> (forall x, h'' [x] = h' x) -> forall x, h'' x = canonicalHom h' x. 43 | Proof. 44 | intros. induction x. 45 | - cbn. erewrite homo_nil; easy. 46 | - erewrite homo_cons; [ | easy]; cbn. rewrite IHx. now rewrite H0. 47 | Qed. 48 | 49 | (** ** Uniform Homomorphisms *) 50 | 51 | (** A uniform homomorphism is ε-free and maps all strings of the same length to strings of the same length, 52 | (stated differently: |h x| = n * |x| for n > 0) *) 53 | Definition uniform_homomorphism (h : list X -> list Y) := 54 | homomorphism h 55 | /\ (forall x y, |h [x]| = |h [y]|) 56 | /\ (forall x, |h[x]| >= 1). 57 | 58 | Lemma unif_homo_length h x y : uniform_homomorphism h -> |x| = |y| -> |h x| = |h y|. 59 | Proof. 60 | intros (H1 & H2 & _). 61 | revert y. induction x; intros. 62 | - destruct y; cbn in *; [ | congruence]. now cbn. 63 | - destruct y; cbn in *; [ congruence | ]. 64 | replace (a :: x) with ([a] ++ x) by now cbn. replace (x0 :: y) with ([x0] ++ y) by now cbn. 65 | rewrite !H1. rewrite !app_length. erewrite H2 with (y := x0). 66 | rewrite IHx with (y := y); eauto. 67 | Qed. 68 | 69 | Lemma unif_homo_eps_free h : uniform_homomorphism h -> forall x, h x = [] -> x = []. 70 | Proof. 71 | intros (H1 & H2 & H3) x H. 72 | destruct x as [ | x y]; [easy | ]. rewrite homo_cons in H by easy. 73 | apply (f_equal (@length _)) in H. rewrite app_length in H. cbn in H. 74 | specialize (H3 x); lia. 75 | Qed. 76 | 77 | Lemma canonical_uniform_homo f k : (forall x, |f x| = k) -> k > 0 -> uniform_homomorphism (canonicalHom f). 78 | Proof. 79 | intros H1 H2. repeat split. 80 | - apply canonicalHom_is_homomorphism. 81 | - intros x y. cbn. now rewrite !app_nil_r, !H1. 82 | - intros x. cbn. rewrite !app_nil_r, H1. lia. 83 | Qed. 84 | 85 | Variable (h : list X -> list Y). 86 | Context (h_unifHom : uniform_homomorphism h). 87 | Lemma h_nil_cons x l : not (|h []| = |h (x :: l)|). 88 | Proof. 89 | intros H. replace (x ::l) with ([x] ++ l) in H by now cbn. 90 | rewrite (proj1 h_unifHom) in H. rewrite (homo_nil (proj1 h_unifHom)) in H. 91 | rewrite !app_length in H. cbn in H. 92 | specialize (proj2 (proj2 h_unifHom) x). lia. 93 | Qed. 94 | 95 | Lemma h_length_inv l1 l2 : |h l1| = |h l2| -> |l1| = |l2|. 96 | Proof. 97 | revert l2. induction l1; intros. 98 | + destruct l2; [easy | now apply h_nil_cons in H]. 99 | + destruct l2; [ symmetry in H; now apply h_nil_cons in H | ]. 100 | cbn. f_equal. apply IHl1. 101 | rewrite homo_cons in H; [ | apply h_unifHom]. 102 | rewrite homo_cons with (x := x) in H; [ | apply h_unifHom]. 103 | rewrite !app_length in H. 104 | rewrite (proj1 (proj2 h_unifHom)) with (y := x) in H. lia. 105 | Qed. 106 | 107 | Lemma h_length_inv' l1 l2 : h l1 = h l2 -> |l1| = |l2|. 108 | Proof. intros; now apply h_length_inv. Qed. 109 | 110 | Lemma h_nil_inv a : h a = [] -> a = []. 111 | Proof. 112 | intros H. destruct a; [ easy | ]. replace (x ::a) with ([x] ++ a) in H by now cbn. 113 | rewrite (proj1 h_unifHom) in H. apply (f_equal (@length Y)) in H. rewrite app_length in H. 114 | specialize (proj2 (proj2 h_unifHom) x). cbn in H; lia. 115 | Qed. 116 | 117 | End fixX. 118 | 119 | Lemma h_length_multiply (X : finType) (Y : Type) (h : list X -> list Y) : uniform_homomorphism h -> { k : nat & forall x, |h x| = k * |x| }. 120 | Proof. 121 | intros (H1 & H2 & H3). 122 | destruct (elem X) eqn:H4 . 123 | - exists 42. intros []. 124 | + rewrite homo_nil by auto. easy. 125 | + specialize (elem_spec e) as H5. rewrite H4 in H5. destruct H5. 126 | - exists (|h [e]|). 127 | induction x as [ | a x IH]. 128 | + rewrite homo_nil by auto; easy. 129 | + rewrite homo_cons by auto. rewrite app_length, IH. cbn. enough (|h[a]| = |h[e]|) as -> by lia. 130 | apply H2. 131 | Defined. (* because informative ? *) -------------------------------------------------------------------------------- /theories/NP/Clique/Clique.v: -------------------------------------------------------------------------------- 1 | From Undecidability.Shared.Libs.PSL Require Import FinTypes. 2 | From Complexity.NP.Clique Require Import UGraph. 3 | Require Import Lia. 4 | 5 | Section fixGraph. 6 | Variable (g : UGraph). 7 | Notation V := (V g). 8 | Notation E := (@E g). 9 | 10 | Definition isClique (l : list V) := (forall v1 v2, v1 el l -> v2 el l -> v1 <> v2 -> E (v1, v2)) /\ dupfree l. 11 | Definition isKClique k (l : list V) := |l| = k /\ isClique l. 12 | 13 | (** an alternative inductive characterisation *) 14 | Inductive indKClique : nat -> list V -> Prop := 15 | | indKCliqueNil : indKClique 0 [] 16 | | indKCliqueS L v k : indKClique k L -> not (v el L) -> (forall v', v' el L -> E (v, v')) -> indKClique (S k) (v :: L). 17 | Hint Constructors indKClique : core. 18 | 19 | Lemma indKClique_iff k L: isKClique k L <-> indKClique k L. 20 | Proof. 21 | split. 22 | - intros [H1 [H2 H3]]. revert L H1 H2 H3. induction k; intros. 23 | + destruct L; cbn in H1; [ eauto | congruence]. 24 | + destruct L; cbn in *; [congruence | ]. 25 | constructor. 26 | * apply IHk; [lia | intros; apply H2; eauto | now inv H3]. 27 | * now inv H3. 28 | * intros v' Hel. apply H2; [eauto | eauto | ]. inv H3. intros ->. congruence. 29 | - induction 1 as [ | ? ? ? ? IH]. 30 | + split; [ | split]; [now cbn | intros ? ? [] | constructor]. 31 | + destruct IH as (IH1 & IH2 & IH3). split; [ | split]. 32 | * cbn. lia. 33 | * intros v1 v2 [-> | H2] [-> | H3] H4; try congruence. 34 | -- now apply H1. 35 | -- apply E_symm. now apply H1. 36 | -- now apply IH2. 37 | * now constructor. 38 | Qed. 39 | End fixGraph. 40 | 41 | Definition Clique (i : UGraph * nat) := let (g, k) := i in exists l, @isKClique g k l. 42 | 43 | 44 | 45 | -------------------------------------------------------------------------------- /theories/NP/Clique/FlatUGraph.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L. 2 | From Undecidability.L.Tactics Require Import LTactics GenEncode. 3 | From Undecidability.L.Datatypes Require Import Lists LNat LProd. 4 | From Undecidability.Shared.Libs.PSL Require Import FinTypes. 5 | From Complexity.NP.Clique Require Import UGraph. 6 | From Complexity.Libs.CookPrelim Require Import FlatFinTypes. 7 | 8 | (** * Flat representation of an undirected graph. *) 9 | 10 | (** We represent graphs using a number, denoting the number of nodes, and a list of edges. *) 11 | Notation fvertex := (nat) (only parsing). 12 | Notation fedge := ((fvertex * fvertex)%type) (only parsing). 13 | Notation fgraph := ((nat * list fedge)%type) (only parsing). 14 | 15 | Implicit Types (e : fedge) (E : list fedge) (G : fgraph) (V v: fvertex). 16 | 17 | (** We require the list of edges to be symmetric and to only mention nodes which actually exist. *) 18 | Definition fedges_symmetric (E : list fedge) := forall V1 V2, (V1, V2) el E -> (V2, V1) el E. 19 | Definition fedge_wf n e := match e with (V1, V2) => V1 < n /\ V2 < n end. 20 | Definition fedges_wf n (E : list fedge) := forall e, e el E -> fedge_wf n e. 21 | 22 | Definition fgraph_wf G := match G with (V, E) => fedges_symmetric E /\ fedges_wf V E end. 23 | 24 | Definition fedge_eqb := prod_eqb Nat.eqb Nat.eqb. 25 | Definition fedges_edge_in_decb E e := list_in_decb fedge_eqb E e. 26 | Definition fgraph_edge_in_decb G e := match G with (V, E) => fedges_edge_in_decb E e end. 27 | 28 | Definition isfVertex (V : fvertex) (v : fvertex) := ofFlatType V v. 29 | 30 | (** Boolean deciders for some of the above definitions*) 31 | Definition fedges_symmetric_decb (E : list fedge) := 32 | forallb (fun e => let (v1, v2) := e in fedges_edge_in_decb E (v2, v1)) E. 33 | 34 | Definition fedge_wf_decb n e := let (v1, v2) := e in Nat.ltb v1 n && Nat.ltb v2 n. 35 | Definition fedges_wf_decb n E := forallb (fedge_wf_decb n) E. 36 | 37 | Definition fgraph_wf_decb G := let (V, E) := G in fedges_symmetric_decb E && fedges_wf_decb V E. 38 | 39 | Definition isfVertex_decb V v := ofFlatType_dec V v. 40 | 41 | Proposition fedge_eqb_spec e1 e2 : reflect (e1 = e2) (fedge_eqb e1 e2). 42 | Proof. 43 | unfold fedge_eqb. apply prod_eqb_spec; apply Nat.eqb_spec. 44 | Qed. 45 | 46 | Corollary fedge_eqb_iff e1 e2 : e1 = e2 <-> fedge_eqb e1 e2 = true. 47 | Proof. 48 | apply reflect_iff, fedge_eqb_spec. 49 | Qed. 50 | 51 | Proposition fedges_edge_in_decb_iff E e: fedges_edge_in_decb E e = true <-> e el E. 52 | Proof. 53 | apply list_in_decb_iff, fedge_eqb_iff. 54 | Qed. 55 | 56 | Proposition fedge_wf_decb_iff n e : fedge_wf_decb n e = true <-> fedge_wf n e. 57 | Proof. 58 | unfold fedge_wf_decb, fedge_wf. destruct e. 59 | rewrite andb_true_iff, !Nat.ltb_lt. easy. 60 | Qed. 61 | 62 | Proposition fedges_symmetric_decb_iff E : fedges_symmetric_decb E = true <-> fedges_symmetric E. 63 | Proof. 64 | unfold fedges_symmetric_decb, fedges_symmetric. 65 | rewrite forallb_forall. split; intros H. 66 | - intros v1 v2 H1. apply fedges_edge_in_decb_iff, (H (v1, v2)), H1. 67 | - intros [v1 v2] H1. apply fedges_edge_in_decb_iff, H, H1. 68 | Qed. 69 | 70 | Proposition fedges_wf_decb_iff n E : fedges_wf_decb n E = true <-> fedges_wf n E. 71 | Proof. 72 | unfold fedges_wf_decb, fedges_wf. rewrite forallb_forall. setoid_rewrite fedge_wf_decb_iff. easy. 73 | Qed. 74 | 75 | Proposition fgraph_wf_decb_iff G : fgraph_wf_decb G = true <-> fgraph_wf G. 76 | Proof. 77 | unfold fgraph_wf_decb, fgraph_wf. 78 | destruct G. rewrite andb_true_iff, fedges_symmetric_decb_iff, fedges_wf_decb_iff. 79 | easy. 80 | Qed. 81 | 82 | Proposition isfVertex_decb_iff V v : isfVertex_decb V v = true <-> isfVertex V v. 83 | Proof. 84 | unfold isfVertex_decb, isfVertex. apply Nat.ltb_lt. 85 | Qed. 86 | 87 | (** We relate UGraph and fgraph instances in the following way *) 88 | Definition isFlatVerticesOf V (finV : finType) := finRepr finV V. 89 | Definition isFlatVertexOf (finV : finType) V (v : finV):= finReprEl' V v. 90 | 91 | Inductive isFlatEdgesOf E V (finV : finType) (finE : finV * finV -> Prop) : Prop := 92 | mkIsFlatEdgesOf 93 | (R__edgesSound : forall v1 v2, (v1, v2) el E -> fedge_wf V (v1, v2) /\ 94 | exists (V1 V2 : finV), finE (V1, V2) /\ isFlatVertexOf v1 V1 /\ isFlatVertexOf v2 V2) 95 | (R__edgesComplete : forall (v1 v2 : finV), finE (v1, v2) -> (index v1, index v2) el E) 96 | : isFlatEdgesOf E V finE. 97 | 98 | Definition isFlatGraphOf (g : fgraph) (UG : UGraph) := 99 | let (fV, fE) := g in isFlatVerticesOf fV (V UG) /\ isFlatEdgesOf fE fV (@E UG). 100 | 101 | Lemma isFlatGraphOf_wf g (G : UGraph) : isFlatGraphOf g G -> fgraph_wf g. 102 | Proof. 103 | destruct g as (fV & fE). intros [H1 H2]. 104 | unfold fgraph_wf. inv H2. split. 105 | - intros v1 v2 Hel%R__edgesSound. destruct Hel as (H2 & (V1 & V2 & Hel & H3 & H4 )). 106 | unfold isFlatVertexOf, finReprEl' in *. rewrite <- H3, <- H4. apply R__edgesComplete. 107 | apply G, Hel. 108 | - intros (v1 & v2) Hel%R__edgesSound. apply Hel. 109 | Qed. 110 | 111 | Fact isFlatEdgesOf_fedges_wf E V (finV : finType) (finE : finV * finV -> Prop) : isFlatEdgesOf E V finE -> fedges_wf V E. 112 | Proof. 113 | intros H. destruct H. 114 | unfold fedges_wf. intros (e1& e2) Hel. 115 | apply R__edgesSound, Hel. 116 | Qed. 117 | -------------------------------------------------------------------------------- /theories/NP/Clique/UGraph.v: -------------------------------------------------------------------------------- 1 | From Undecidability.Shared.Libs.PSL Require Import FinTypes. 2 | 3 | (** * Plain undirected graphs *) 4 | 5 | Record UGraph := 6 | { 7 | V : finType; 8 | E : V * V -> Prop; 9 | E_dec : forall v1 v2, {E (v1, v2)} + {~ E (v1, v2)}; 10 | E_symm: forall v1 v2, E (v1, v2) <-> E (v2, v1) 11 | }. 12 | -------------------------------------------------------------------------------- /theories/NP/L/CanEnumTerm_def.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L LTactics. 2 | From Complexity.Complexity Require Import NP Definitions Monotonic. 3 | 4 | Record canEnumTerms (X__cert : Type) `{R__cert : encodable X__cert} : Type := 5 | { 6 | f__toTerm : X__cert -> term; 7 | comp__toTerm :> polyTimeComputable f__toTerm; 8 | inSize__toTerm : nat -> nat; 9 | complete__toTerm : (forall s:term, exists x:X__cert, f__toTerm x = s /\ size (enc x) <= inSize__toTerm (size (enc s))); 10 | polyIn__toTerm : inOPoly inSize__toTerm; 11 | monoIn__toTerm : monotonic inSize__toTerm; 12 | }. 13 | 14 | Arguments canEnumTerms : clear implicits. 15 | Arguments canEnumTerms _ {_}. 16 | 17 | #[export] 18 | Hint Extern 2 (computableTime (f__toTerm _) _) => unshelve (simple apply @comp__polyTC);simple apply @comp__toTerm :typeclass_instances. 19 | Smpl Add 10 (simple apply polyIn__toTerm) : inO. 20 | Smpl Add 10 (simple apply monoIn__toTerm) : inO. 21 | 22 | Lemma canEnumTerms_compPoly (X__cert : Type) `{R__cert : encodable X__cert}: 23 | canEnumTerms X__cert -> exists H : canEnumTerms X__cert, inhabited (polyTimeComputable (time__polyTC H)) 24 | /\ inhabited (polyTimeComputable (inSize__toTerm H)) 25 | /\ inhabited (polyTimeComputable (resSize__rSP H)). 26 | Proof. 27 | intros Hin. 28 | destruct (polyTimeComputable_compTime (comp__toTerm Hin)) as (?&?). 29 | destruct (inOPoly_computable (polyIn__toTerm Hin)) as (p'&?&Hbounds&?&?). 30 | unshelve eexists. eexists (f__toTerm Hin) p'. 5:cbn. 31 | 1,3,4,5:now eauto using comp__toTerm. 32 | intros s. destruct (complete__toTerm Hin s) as (c&<-&Hc). 33 | eexists;split. easy. now rewrite <- Hbounds. 34 | Qed. 35 | -------------------------------------------------------------------------------- /theories/NP/L/GenNP.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L. 2 | From Undecidability.L.Datatypes Require Import LProd LTerm LBool. 3 | From Complexity.Complexity Require Import NP Definitions Monotonic Subtypes. 4 | From Undecidability.L.Functions Require Import Size. 5 | 6 | Local Unset Implicit Arguments. 7 | Import L_Notations. 8 | 9 | Section GenNP. 10 | Context (X__cert : Type) `{R__cert : encodable X__cert}. 11 | 12 | 13 | Definition GenNP' : term*nat*nat -> Prop := 14 | (fun '(s, maxSize, steps (*in unary*)) => 15 | exists (c:X__cert), size (enc c) <= maxSize 16 | /\ exists t, app s (enc c) ⇓(<=steps) t). 17 | 18 | 19 | (* This subset is the one that is already NP-hard: 20 | procedures such that: 21 | - if any certificate is valid, then a small one is valid 22 | - For small certificates, we do not need much time *) 23 | Definition LHaltsOrDiverges : term*nat*nat -> Prop := 24 | fun '(s, maxSize, steps (*in unary*)) => 25 | proc s 26 | /\ (forall (c:X__cert) k t, s (enc c) ⇓(k) t -> exists (c':X__cert), size (enc c') <= maxSize /\ s (enc c') ⇓ t) 27 | /\ (forall (c:X__cert), size (enc c) <= maxSize -> forall k t, s (enc c) ⇓(k) t -> k <= steps). 28 | 29 | Definition GenNP : {x | LHaltsOrDiverges x} -> Prop := 30 | restrictBy LHaltsOrDiverges GenNP'. 31 | 32 | End GenNP. 33 | 34 | -------------------------------------------------------------------------------- /theories/NP/L/LMGenNP.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import Tactics.LTactics Prelim.MoreList Prelim.MoreBase. 2 | From Complexity.Complexity Require Import Definitions Subtypes. 3 | 4 | From Undecidability.L Require Import LM_heap_def. 5 | 6 | (** The halting formulation of the generic NP-complete problem for the abstract machine executing L-terms. 7 | This is usefull as we have a Turing machine that simulates this abstract machine. *) 8 | 9 | Definition initLMGen s c : (list (nat*list Tok)*list (nat*list Tok)*list (option ((nat * list Tok) * nat))) 10 | := ([(0,s++c++[appT])],[],[]). 11 | 12 | Section fixX. 13 | Local Unset Implicit Arguments. 14 | Context (X:Type) `{R__X : encodable X}. 15 | 16 | Definition LMGenNP' : list Tok*nat*nat -> Prop:= 17 | (fun '(P, maxSize, k (*in unary*)) => 18 | exists (c:X), size (enc c) <= maxSize /\ (exists sigma k', k' <= k /\ evaluatesIn step k' (initLMGen P (compile (enc c))) sigma)). 19 | 20 | 21 | 22 | (* This subset is the one that is already NP-hard *) 23 | Definition LMHaltsOrDiverges : list Tok*nat*nat -> Prop := 24 | fun '(P, maxSize, steps (*in unary*)) => 25 | (exists s, P = compile s /\ proc s) 26 | /\ (forall (c:X) k sigma, evaluatesIn step k (initLMGen P (compile (enc c))) sigma 27 | -> exists (c':X) sigma', size (enc c') <= maxSize 28 | /\ evaluates step (initLMGen P (compile (enc c'))) sigma') 29 | /\ forall (c : X), size (enc c) <= maxSize -> forall k sigma, evaluatesIn step k (initLMGen P (compile (enc c))) sigma -> k <= steps. 30 | 31 | Definition LMGenNP : {x | LMHaltsOrDiverges x} -> Prop := 32 | restrictBy LMHaltsOrDiverges LMGenNP'. 33 | End fixX. 34 | 35 | -------------------------------------------------------------------------------- /theories/NP/SAT/CookLevin.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L.Tactics Require Import LTactics GenEncode Computable. 2 | From Undecidability.L Require Import FinTypeLookup LFinType LSum. 3 | From Undecidability.Shared.Libs.PSL Require Import FinTypes. 4 | 5 | From Complexity.NP Require Import FSAT_to_SAT kSAT_to_SAT kSAT_to_FlatClique. 6 | From Complexity.NP.SAT.CookLevin.Subproblems Require Import FlatCC SingleTMGenNP BinaryCC. 7 | From Complexity.NP.SAT.CookLevin.Subproblems Require FlatTCC. 8 | From Complexity.NP Require Import SAT FSAT kSAT FlatClique. 9 | From Complexity.NP.SAT.CookLevin Require Import FlatSingleTMGenNP_to_FlatTCC FlatTCC_to_FlatCC FlatCC_to_BinaryCC BinaryCC_to_FSAT. 10 | 11 | Require Import Complexity.NP.SAT.CookLevin.Reductions.TMGenNP_fixed_singleTapeTM_to_FlatFunSingleTMGenNP. 12 | From Complexity.NP.TM Require Import IntermediateProblems. 13 | 14 | From Undecidability.TM Require Import TM_facts CodeTM. 15 | 16 | From Complexity Require Import L_to_LM LM_to_mTM mTM_to_singleTapeTM TMGenNP_fixed_mTM. 17 | From Undecidability.L Require Import Prelim.MoreList Prelim.MoreBase. 18 | From Complexity.Complexity Require Import NP Definitions Subtypes. 19 | From Complexity.NP Require Import GenNP. 20 | 21 | From Complexity Require GenNP_is_hard CanEnumTerm. 22 | 23 | (** * Overview of the results proved in the paper. *) 24 | 25 | Import LNat. 26 | Lemma GenNP_to_LMGenNP : 27 | GenNP (list bool) ⪯p LMGenNP.LMGenNP (list bool). 28 | Proof. 29 | apply GenNP_to_LMGenNP. 30 | Qed. 31 | 32 | Lemma LMGenNP_to_TMGenNP : 33 | LMGenNP.LMGenNP (list bool) ⪯p mTMGenNP_fixed (projT1 M.M). 34 | Proof. 35 | apply LMGenNP_to_TMGenNP_mTM. 36 | Qed. 37 | 38 | Lemma TMGenNP_to_TMGenNP_fixed_singleTapeTM : 39 | mTMGenNP_fixed (projT1 M.M) ⪯p TMGenNP_fixed (projT1 (M_multi2mono.M__mono (projT1 M.M))). 40 | Proof. 41 | apply TMGenNP_mTM_to_TMGenNP_singleTM. 42 | Qed. 43 | 44 | 45 | (* reduce to the formulation of SingleTMGenNP where the TM is not fixed *) 46 | Import Specif. 47 | Lemma fixedTM_to_FlatSingleTMGenNP (sig : finType) (M : TM sig 1) 48 | (reg__sig : encodable sig) (index__comp : {c & computableTime' (index (F:=sig)) (fun _ _ => (c,tt))}): 49 | TMGenNP_fixed M ⪯p FlatSingleTMGenNP. 50 | Proof. 51 | eapply reducesPolyMO_transitive with (Q := FlatFunSingleTMGenNP). 52 | apply (TMGenNP_fixed_singleTapeTM_to_FlatFunSingleTMGenNP M). eassumption. 53 | eapply reducesPolyMO_intro with (f := id). 54 | - exists (fun _ => 1). 55 | + extract. solverec. 56 | + smpl_inO. 57 | + smpl_inO. 58 | + exists (fun n => n). 2, 3: smpl_inO. 59 | intros x. now cbn. 60 | - intros (((? & ?) & ?) & ?). apply FlatFunSingleTMGenNP_FlatSingleTMGenNP_equiv. 61 | Qed. 62 | 63 | Corollary GenNP_to_SingleTMGenNP : 64 | GenNP (list bool) ⪯p FlatSingleTMGenNP. 65 | Proof. 66 | eapply reducesPolyMO_transitive. 67 | apply GenNP_to_LMGenNP. 68 | eapply reducesPolyMO_transitive. 69 | apply LMGenNP_to_TMGenNP. 70 | eapply reducesPolyMO_transitive. 71 | apply TMGenNP_to_TMGenNP_fixed_singleTapeTM. 72 | apply fixedTM_to_FlatSingleTMGenNP. 73 | eapply finFun_computableTime_const. 2:exact 0. 74 | exact _. 75 | Qed. 76 | 77 | 78 | (** reduction from TM to SAT *) 79 | Lemma FlatSingleTMGenNP_to_FlatTCC : FlatSingleTMGenNP ⪯p FlatTCC.FlatTCCLang. 80 | Proof. 81 | exact FlatSingleTMGenNP_to_FlatTCCLang_poly. 82 | Qed. 83 | 84 | Lemma FlatTCC_to_FlatCC : FlatTCC.FlatTCCLang ⪯p FlatCCLang. 85 | Proof. 86 | exact FlatTCC_to_FlatCC_poly. 87 | Qed. 88 | 89 | Lemma FlatCC_to_BinaryCC : FlatCCLang ⪯p BinaryCCLang. 90 | Proof. 91 | exact FlatCC_to_BinaryCC_poly. 92 | Qed. 93 | 94 | Lemma BinaryCC_to_FSAT : BinaryCCLang ⪯p FSAT. 95 | Proof. 96 | exact BinaryCC_to_FSAT_poly. 97 | Qed. 98 | 99 | Lemma FSAT_to_SAT : FSAT ⪯p SAT. 100 | Proof. 101 | exact FSAT_to_SAT_poly. 102 | Qed. 103 | 104 | Lemma FSAT_to_3SAT : FSAT ⪯p kSAT 3. 105 | Proof. 106 | exact FSAT_to_3SAT_poly. 107 | Qed. 108 | 109 | Lemma kSAT_to_FlatClique k: kSAT k ⪯p FlatClique. 110 | Proof. 111 | apply kSAT_to_FlatClique_poly. 112 | Qed. 113 | 114 | Corollary FlatSingleTMGenNP_to_3SAT : FlatSingleTMGenNP ⪯p kSAT 3. 115 | Proof. 116 | eapply reducesPolyMO_transitive. 117 | 2: apply FSAT_to_3SAT. 118 | eapply reducesPolyMO_transitive. 119 | 2: apply BinaryCC_to_FSAT. 120 | eapply reducesPolyMO_transitive. 121 | 2: apply FlatCC_to_BinaryCC. 122 | eapply reducesPolyMO_transitive. 123 | 2: apply FlatTCC_to_FlatCC. 124 | apply FlatSingleTMGenNP_to_FlatTCC. 125 | Qed. 126 | 127 | Corollary GenNP_to_3SAT : GenNP (list bool) ⪯p kSAT 3. 128 | Proof. 129 | eapply reducesPolyMO_transitive. 130 | apply GenNP_to_SingleTMGenNP. 131 | apply FlatSingleTMGenNP_to_3SAT. 132 | Qed. 133 | 134 | Import GenNP_is_hard CanEnumTerm. 135 | (** even 3-SAT is already NP-complete. *) 136 | Lemma CookLevin0 : NPcomplete (kSAT 3). 137 | Proof. 138 | split. 2:apply inNP_kSAT. 139 | eapply red_NPhard. apply GenNP_to_3SAT. 140 | apply NPhard_GenNP. 141 | eapply boollist_enum.boollists_enum_term. 142 | Qed. 143 | 144 | (** The Cook-Levin-Theorem: SAT is NP-complete. *) 145 | Lemma CookLevin : NPcomplete SAT. 146 | Proof. 147 | split. 2:apply SAT_inNP.sat_NP. 148 | eapply red_NPhard. eapply kSAT_to_SAT. apply CookLevin0. 149 | Qed. 150 | 151 | (** The Clique problem is also NP-complete *) 152 | Lemma Clique_complete : NPcomplete FlatClique. 153 | Proof. 154 | split. 155 | - eapply red_NPhard; [apply kSAT_to_FlatClique | apply CookLevin0]. 156 | - apply FlatClique_in_NP. 157 | Qed. 158 | 159 | 160 | (*Print Assumptions CookLevin. *) 161 | (* Closed under the global context *) 162 | -------------------------------------------------------------------------------- /theories/NP/SAT/CookLevin/Reductions/TCC_to_CC.v: -------------------------------------------------------------------------------- 1 | From Undecidability.Shared.Libs.PSL Require Import Base FinTypes. 2 | From Complexity.NP.SAT.CookLevin Require Import TCC CC. 3 | From Complexity.Libs.CookPrelim Require Import MorePrelim. 4 | Require Import Lia. 5 | 6 | (** * Reduction of 3-CC to CC. *) 7 | (*Apart from syntactical differences, this is just a simple embedding. *) 8 | 9 | Section fixInstance. 10 | (*We do not directly fix a TCC instance since we do not actually require the alphabet to be finite for the reduction *) 11 | Variable (FSigma : Type). 12 | Variable (Finit : list FSigma). 13 | Variable (Fcards : list (TCCCard FSigma)). 14 | Variable (Ffinal : list (list FSigma)). 15 | Variable (Fsteps : nat). 16 | 17 | Definition TCCCard_to_CCCard (X : Type) (card : TCCCard X) := 18 | Build_CCCard (TCCCardP_to_list (TCC.prem card)) (TCCCardP_to_list (TCC.conc card)). 19 | 20 | Definition CC_cards := map (@TCCCard_to_CCCard FSigma) Fcards. 21 | 22 | Hint Constructors CC.valid : core. 23 | Hint Constructors TCC.valid : core. 24 | 25 | (*We show agreement for valid and satFinal *) 26 | Lemma valid_agree (s1 s2 : list FSigma) : 27 | |s1| >= 3 -> TCC.valid (coversHeadList Fcards) s1 s2 <-> CC.valid 1 3 CC_cards s1 s2. 28 | Proof. 29 | intros; split. 30 | - induction 1 as [ | a b x y H0 IH H1 | a b x y H0 IH H1]. 31 | + eauto. 32 | + cbn in H; lia. 33 | + replace (x :: a) with ([x] ++ a) by now cbn. replace (y :: b) with ([y] ++ b) by now cbn. 34 | destruct H1 as (card & H3 & H4). 35 | destruct (le_lt_dec 3 (|a|)) as [H2 | H2]. 36 | * econstructor 3; [apply IH; lia | easy | easy | apply in_map_iff | ]. 37 | -- exists card. split; [reflexivity | easy]. 38 | -- unfold coversHead. cbn. easy. 39 | * assert (|a| = 2) as H1 by now cbn in H. clear H2 H IH. 40 | apply TCC.valid_length_inv in H0. rewrite H1 in H0. 41 | list_length_inv. econstructor 3; [ eapply valid_vacuous with (m := 2); cbn; eauto | easy | easy | | ]. 42 | -- apply in_map_iff. exists card; split; [ reflexivity | easy]. 43 | -- destruct H4. cbn; split; eauto. 44 | - induction 1 as [ | a b u v H0 IH H1 H2 H3 | a b u v card H0 IH H1 H2 H3 H4]. 45 | + eauto. 46 | + rewrite app_length in H; lia. 47 | + list_length_inv. cbn in *. unfold CC_cards in H3. apply in_map_iff in H3 as (card' & <- & H3). 48 | destruct (le_lt_dec 3 (|a|)) as [H1 | H1]. 49 | * econstructor 3; [ apply IH; lia | exists card'; split; [ apply H3 | ]]. 50 | destruct H4; split; eauto. 51 | * assert (|a| = 2) by lia. clear IH H1 H. apply valid_length_inv in H0. rewrite H2 in H0. 52 | list_length_inv. constructor 3; [ apply TCC.valid_vacuous; cbn; eauto| ]. 53 | exists card'; split; [apply H3 | ]. destruct H4; split; eauto. 54 | Qed. 55 | 56 | Lemma relpower_valid_agree k (s1 s2 : list FSigma) : 57 | |s1| >= 3 -> relpower (TCC.valid (coversHeadList Fcards)) k s1 s2 <-> relpower (CC.valid 1 3 CC_cards) k s1 s2. 58 | Proof. 59 | intros; split; induction 1 as [? | ? ? ? ? H0 H1 IH]; [ eauto | | eauto | ]. 60 | - econstructor; [ apply valid_agree; [apply H | apply H0] | apply IH]. 61 | apply TCC.valid_length_inv in H0; lia. 62 | - econstructor; [ apply valid_agree; [ apply H | apply H0] | apply IH]. 63 | apply valid_length_inv in H0; lia. 64 | Qed. 65 | 66 | Lemma final_agree (s : list FSigma) : |s| = |Finit| -> TCC.satFinal Ffinal s <-> CC.satFinal 1 (length Finit) Ffinal s. 67 | Proof. 68 | unfold TCC.satFinal, satFinal. setoid_rewrite Nat.mul_1_r. split; intros. 69 | - destruct H0 as (subs & H1 & H2). exists subs. 70 | destruct H2 as (b1 & b2 & ->). 71 | exists (|b1|). split; [ apply H1 | ]. 72 | rewrite skipn_app; [ | easy]. 73 | split; [ rewrite !app_length in H; lia | now exists b2]. 74 | - destruct H0 as (subs & k & H1 & H2 & (b & H3)). exists subs. split; [ apply H1 | ]. 75 | unfold substring. 76 | setoid_rewrite <- (firstn_skipn k s). setoid_rewrite H3. 77 | exists (firstn k s), b. easy. 78 | Qed. 79 | End fixInstance. 80 | 81 | (*The reduction is now straightforward. *) 82 | Definition CC_instance (tpr : TCC) := Build_CC 1 3 (TCC.init tpr) (CC_cards (TCC.cards tpr)) (TCC.final tpr) (TCC.steps tpr). 83 | 84 | Lemma TCC_to_CC (tpr : TCC) : TCCLang tpr <-> CCLang (CC_instance tpr). 85 | Proof. 86 | split; intros. 87 | - destruct H as (H & sf & H1 & H2). split; [ | exists sf; repeat split]. 88 | + repeat split; cbn in *; [ lia | lia | exists 3; split; lia | apply H | | | ]. 89 | * unfold CC_cards in *. apply in_map_iff in H0 as (card' & <- & H0). cbn. destruct card', prem, conc; now cbn. 90 | * unfold CC_cards in *. apply in_map_iff in H0 as (card' & <- & H0). cbn. destruct card', prem, conc; now cbn. 91 | * setoid_rewrite Nat.mul_1_r. eauto. 92 | + apply relpower_valid_agree, H1. apply H. 93 | + apply final_agree, H2. apply TCC.relpower_valid_length_inv in H1; cbn. lia. 94 | - destruct H as (H1 & sf & H2 & H3). split; [ | exists sf; repeat split]; cbn in *. 95 | + destruct H1 as (_ & _ & _ & H1 &_). cbn in H1. apply H1. 96 | + apply relpower_valid_agree; [ apply H1 | apply H2]. 97 | + eapply final_agree, H3. apply relpower_valid_length_inv in H2. lia. 98 | Qed. 99 | -------------------------------------------------------------------------------- /theories/NP/SAT/CookLevin/Reductions/TMGenNP_fixed_singleTapeTM_to_FlatFunSingleTMGenNP.v: -------------------------------------------------------------------------------- 1 | From Undecidability.TM Require Import TM_facts. 2 | From Undecidability.L.TM Require Import TMEncoding. 3 | From Complexity.L.TM Require Import TMflat TMflatEnc TMflatFun TapeDecode TMunflatten TMflatten. 4 | From Complexity.NP Require Import TMGenNP_fixed_mTM SingleTMGenNP. 5 | From Undecidability.L.Functions Require Import EqBool. 6 | 7 | From Undecidability.L.Tactics Require Import LTactics GenEncode. 8 | From Complexity.Libs.CookPrelim Require Import PolyBounds FlatFinTypes MorePrelim. 9 | From Undecidability.L.Datatypes Require Import LProd LOptions LBool LSum LNat Lists LFinType. 10 | 11 | (** * Reduction of TMGenNP with fixed TM to TMGenNP with variable TM *) 12 | 13 | Lemma execFlatTM_isValidFlatTapes M tp steps c' tp' : 14 | execFlatTM M tp steps = Some (c', tp') -> isValidFlatTapes (sig M) (tapes M) tp' = true. 15 | Proof. 16 | intros H%execFlatTM_correct. 17 | destruct H as (sig & n & M' & c0 & c0' & H0 & H1 & H2 & H). 18 | inv H. apply flatteningTapeIsValid in Ht. 19 | destruct H0. rewrite eq__tapes, eq__sig. apply Ht. 20 | Qed. 21 | 22 | Section fixTM. 23 | Variable (sig : finType). 24 | Variable (M : TM sig 1). 25 | 26 | Variable (reg__sig : encodable sig). 27 | Variable (index__comp : {c & computableTime' (index (F:=sig)) (fun _ _ => (c,tt))}). 28 | 29 | Definition index_const_Time : computableTime _ _:= projT2 index__comp. 30 | #[export] 31 | Existing Instance index_const_Time. 32 | 33 | Definition flatM := flattenTM M. 34 | 35 | Definition reduction (p : list sig * nat * nat) := 36 | let '(ts, maxSize, steps) := p in (flatM, map index (ts : list sig), maxSize, steps). 37 | 38 | Definition c__reduction := (16 + c__map + projT1 index__comp). 39 | Definition reduction_time (ts : list sig) := (|ts| + 1) * c__reduction. 40 | #[export] 41 | Instance term_reduction : computableTime' reduction (fun p _ => (let '(ts, maxSize, steps) := p in reduction_time ts, tt)). 42 | Proof. 43 | extract. solverec. 44 | rewrite map_time_const. unfold reduction_time, c__reduction. ring_simplify. nia. 45 | Qed. 46 | 47 | Lemma reduction_correct p : TMGenNP_fixed M p <-> FlatFunSingleTMGenNP (reduction p). 48 | Proof. 49 | unfold TMGenNP_fixed, FlatFunSingleTMGenNP. destruct p as ((ts & maxSize) & steps). split. 50 | - intros (certfin & H1 & (res & H2)). 51 | cbn. split; [ | split; [easy | ]]. 52 | { unfold list_ofFlatType. intros a (a' & <- & H4)%in_map_iff. apply index_le. } 53 | unfold execTM in H2. 54 | destruct loopM eqn:H3; [ | cbn in H2; congruence]. 55 | exists (map index certfin), (flattenConfig m). split; [ |split]. 56 | + intros a (a' & <- & H4)%in_map_iff. apply index_le. 57 | + now rewrite map_length. 58 | + apply execFlatTM_correct. 59 | exists sig, 1, M, (initc M [|initTape_singleTapeTM (ts ++ certfin)|]), m. 60 | split; [apply flattenTM_isFlatteningTMOf | split; [ | split; [apply H3 | apply flattenConfig_isFlatteningConfigOf]]]. 61 | rewrite <- map_app. apply isFlatteningConfigOf_iff. 62 | exists [initTape_singleTapeTM (map index (ts ++ certfin))]. split. 63 | * apply isFlatteningTapesOf_iff. cbn. generalize (ts ++ certfin). intros l. destruct l; cbn; easy. 64 | * cbn. easy. 65 | - cbn. intros (_ & _ & (cert & f & H1 & H2 & H3)). 66 | destruct (finRepr_exists_list ltac:(reflexivity) H1) as (fincert & H4). 67 | exists fincert. split. 68 | { rewrite H4, map_length in H2. apply H2. } 69 | unfold execFlatTM in H3. destruct isValidFlatTM, isValidFlatTapes; cbn in H3; try congruence. 70 | assert (isFlatteningConfigOf (index (TM.start M), [initTape_singleTapeTM (map index ts ++ cert)]) (initc M [|initTape_singleTapeTM (ts ++ fincert)|])) as Hconf. 71 | { 72 | apply isFlatteningConfigOf_iff. 73 | exists [initTape_singleTapeTM (map index ts ++ cert)]. cbn. split; [ | easy]. 74 | apply isFlatteningTapesOf_iff. cbn. rewrite H4, <- map_app. 75 | generalize (ts ++ fincert). intros l. destruct l; cbn; easy. 76 | } 77 | specialize (loopMflat_correct steps (flattenTM_isFlatteningTMOf M) Hconf) as H5. 78 | unfold flatM in H3. rewrite H3 in H5. 79 | destruct loopM eqn:H6; [ | cbn in H5; tauto]. 80 | exists (ctapes m). unfold execTM. rewrite H6. cbn. easy. 81 | Qed. 82 | 83 | (*We use that the finType is constant so that only the length of ts is relevant for our analysis. *) 84 | Definition c__sizeInputIndex := ((|elem sig|) * c__natsizeS + c__natsizeO + c__listsizeCons). 85 | Proposition size_input_index (ts : list sig) : size (enc (map index ts)) <= c__sizeInputIndex * size (enc ts) + c__listsizeNil. 86 | Proof. 87 | rewrite list_size_of_el. 88 | 2: { intros a (a' & <- & H)%in_map_iff. rewrite size_nat_enc. rewrite index_leq. reflexivity. } 89 | rewrite map_length. setoid_rewrite list_size_length at 2. setoid_rewrite list_size_length at 2. 90 | unfold c__sizeInputIndex. nia. 91 | Qed. 92 | 93 | Lemma TMGenNP_fixed_singleTapeTM_to_FlatFunSingleTMGenNP : 94 | TMGenNP_fixed M ⪯p FlatFunSingleTMGenNP. 95 | Proof using index__comp. 96 | apply reducesPolyMO_intro with (f := reduction). 97 | - evar (f : nat -> nat). exists f. 98 | + eexists. eapply computesTime_timeLeq. 2: apply term_reduction. 99 | cbn. intros ((ts & ?) & ?) _. split; [ | easy]. 100 | unfold reduction_time. rewrite list_size_length. 101 | replace_le (size (enc ts)) with (size (enc (ts, n, n0))) by (rewrite !size_prod; cbn; nia). 102 | generalize (size (enc (ts, n, n0))). intros n'. 103 | [f]: intros n. subst f. cbn. reflexivity. 104 | + subst f. smpl_inO. 105 | + subst f. smpl_inO. 106 | + evar (g : nat -> nat). exists g. 107 | * intros ((ts & maxSize) & steps). cbn. 108 | rewrite !size_prod. cbn. rewrite size_input_index. 109 | instantiate (g := fun n => size (enc flatM) + c__listsizeNil + 8 + (c__sizeInputIndex + 1) * n). 110 | subst g. cbn. nia. 111 | * subst g. smpl_inO. 112 | * subst g. smpl_inO. 113 | - apply reduction_correct. 114 | Qed. 115 | End fixTM. 116 | 117 | -------------------------------------------------------------------------------- /theories/NP/SAT/CookLevin/Subproblems/BinaryCC.v: -------------------------------------------------------------------------------- 1 | From Undecidability.Shared.Libs.PSL Require Import Base. 2 | Require Import Lia. 3 | From Complexity.Libs Require Import MorePrelim. 4 | From Complexity.NP.SAT.CookLevin.Subproblems Require Export CC. 5 | From Complexity.NP.SAT.CookLevin.Subproblems Require Import FlatCC. 6 | 7 | (** * BinaryCC: Parallel Rewriting restricted to a binary alphabet *) 8 | (** ** Definition *) 9 | 10 | (** Note that BinaryCC is syntactially flat as we need not artificially restrict 𝔹 to be a finite type*) 11 | Inductive BinaryCC := { 12 | offset : nat; 13 | width : nat; 14 | init : list bool; 15 | cards : list (CCCard bool); 16 | final : list (list bool); 17 | steps : nat 18 | }. 19 | 20 | (** the same well-formedness conditions as for Parallel Rewriting *) 21 | Definition BinaryCC_wellformed (c : BinaryCC) := 22 | width c > 0 23 | /\ offset c > 0 24 | /\ (exists k, k > 0 /\ width c = k * offset c) 25 | /\ length (init c) >= width c 26 | /\ (forall card, card el cards c -> CCCard_of_size card (width c)) 27 | /\ (exists k, length (init c) = k * offset c). 28 | 29 | Definition BinaryCCLang (C : BinaryCC) := 30 | BinaryCC_wellformed C 31 | /\ exists (sf : list bool), relpower (valid (offset C) (width C) (cards C)) (steps C) (init C) sf 32 | /\ satFinal (offset C) (length (init C)) (final C) sf. 33 | 34 | 35 | (** extraction *) 36 | From Undecidability.L.Tactics Require Import LTactics GenEncode. 37 | From Undecidability.L.Datatypes Require Import LProd LOptions. 38 | 39 | MetaCoq Run (tmGenEncode "BinaryCC_enc" (BinaryCC)). 40 | #[export] 41 | Hint Resolve BinaryCC_enc_correct : Lrewrite. 42 | 43 | From Complexity.Libs.CookPrelim Require Import PolyBounds. 44 | 45 | #[export] 46 | Instance term_Build_BinaryCC : computableTime' Build_BinaryCC (fun _ _ => (1, fun _ _ => (1, fun _ _ => (1, fun _ _ => (1, fun _ _ => (1, fun _ _ => (1, tt))))))). 47 | Proof. 48 | extract constructor. solverec. 49 | Qed. 50 | 51 | Definition c__offset := 9. 52 | #[export] 53 | Instance term_BinaryCC_offset : computableTime' offset (fun _ _ => (c__offset, tt)). 54 | Proof. 55 | extract. unfold c__offset. solverec. 56 | Qed. 57 | 58 | Definition c__width := 9. 59 | #[export] 60 | Instance term_BinaryCC_width : computableTime' width (fun _ _ => (c__width, tt)). 61 | Proof. 62 | extract. unfold c__width. solverec. 63 | Qed. 64 | 65 | Definition c__init := 9. 66 | #[export] 67 | Instance term_BinaryCC_init : computableTime' init (fun _ _ => (c__init, tt)). 68 | Proof. 69 | extract. unfold c__init. solverec. 70 | Qed. 71 | 72 | Definition c__cards := 9. 73 | #[export] 74 | Instance term_BinaryCC_cards : computableTime' cards (fun _ _ => (c__cards, tt)). 75 | Proof. 76 | extract. unfold c__cards. solverec. 77 | Qed. 78 | 79 | Definition c__final := 9. 80 | #[export] 81 | Instance term_BinaryCC_final : computableTime' final (fun _ _ => (c__final, tt)). 82 | Proof. 83 | extract. unfold c__final. solverec. 84 | Qed. 85 | 86 | Definition c__steps := 9. 87 | #[export] 88 | Instance term_BinaryCC_steps : computableTime' steps (fun _ _ => (c__steps, tt)). 89 | Proof. 90 | extract. unfold c__steps. solverec. 91 | Qed. 92 | 93 | Lemma BinaryCC_enc_size (fpr : BinaryCC) : size (enc fpr) = size(enc (offset fpr)) + size (enc (width fpr)) + size (enc (init fpr)) + size (enc (cards fpr)) + size (enc (final fpr)) + size (enc (steps fpr)) + 8. 94 | Proof. 95 | destruct fpr. cbn. unfold enc at 1;cbn. nia. 96 | Qed. 97 | 98 | 99 | -------------------------------------------------------------------------------- /theories/NP/SAT/CookLevin/Subproblems/SingleTMGenNP.v: -------------------------------------------------------------------------------- 1 | From Undecidability.TM Require Import TM_facts. 2 | From Undecidability.L.TM Require Import TMEncoding. 3 | From Complexity.L.TM Require Import TMflat TMflatFun TMunflatten TMflatten. 4 | From Complexity.Libs.CookPrelim Require Import FlatFinTypes MorePrelim. 5 | From Complexity.NP Require Export TMGenNP_fixed_mTM. 6 | 7 | (** * Definition of a generic problem for single-tape Turing machines *) 8 | 9 | Definition isValidCert (sig : finType) k' (c : list sig) := |c| <= k'. 10 | Definition isValidInput (sig : finType) s k' (inp : list sig) := exists c, isValidCert k' c /\ inp = s ++ c. 11 | 12 | (** generic problem for single-tape machine whose head will always start at the leftmost position (i.e. initial tapes are niltape or leftof) *) 13 | (** the alphabet is part of the instance, not a parameter *) 14 | Definition SingleTMGenNP (i : { sig : finType & (TM sig 1 * list sig * nat * nat)%type } ) : Prop := 15 | match i with existT sig (tm, s, k', t) => exists cert, |cert| <= k' 16 | /\ exists f, loopM (initc tm ([|initTape_singleTapeTM (s ++ cert)|])) t = Some f 17 | end. 18 | 19 | (** a flat version defined via the non-flat one *) 20 | Definition FlatSingleTMGenNP : flatTM * list nat * nat * nat -> Prop := 21 | fun '(M,s,maxSize, steps (*in unary*)) => 22 | exists sig (M':TM sig 1) sfin, isFlatteningTMOf M M' /\ isFlatListOf s sfin /\ SingleTMGenNP (existT _ _ (M', sfin, maxSize, steps)). 23 | 24 | (** another definition via the flat semantics *) 25 | Definition FlatFunSingleTMGenNP : flatTM * list nat * nat * nat -> Prop := 26 | fun '(M, s, maxSize, steps) => 27 | list_ofFlatType (sig M) s /\ tapes M = 1 28 | /\ exists cert f, list_ofFlatType (sig M) cert /\ |cert| <= maxSize /\ execFlatTM M [initTape_singleTapeTM (s ++ cert)] steps = Some f. 29 | 30 | 31 | (** the two definitions reduce to each other via the identity function *) 32 | 33 | Lemma vec_case1 (X : Type) (v : Vector.t X 1) : exists x, v = [|x|]. 34 | Proof. 35 | eapply Vector.caseS' with (v:=v). 36 | intros. revert t. apply Vector.case0. easy. 37 | Qed. 38 | 39 | Proposition initTape_mapTape_index (sig : finType) (tp : tape sig) s: 40 | mapTape index tp = initTape_singleTapeTM s 41 | -> exists s', tp = initTape_singleTapeTM s' /\ isFlatListOf s s'. 42 | Proof. 43 | intros H. destruct s; cbn in H. 44 | - destruct tp; cbn in H; inv H. now exists []. 45 | - destruct tp; cbn in H; inv H. now exists (e :: l). 46 | Qed. 47 | 48 | Lemma initTape_isFlatteningConfigOf (sig states : finType) (s : list nat) s0 (c0 : mconfig sig states 1): 49 | isFlatteningConfigOf (s0, [initTape_singleTapeTM s]) c0 50 | -> exists s0' s', index s0' = s0 /\ isFlatListOf s s' /\ c0 = mk_mconfig s0' [|initTape_singleTapeTM s'|]. 51 | Proof. 52 | intros H. inv H. inv Ht. destruct c0. cbn -[mapTapes] in H0. 53 | specialize (vec_case1 ctapes) as (tp & ->). cbn in H0. 54 | inv H0. apply initTape_mapTape_index in H1 as (s' & -> & H1). 55 | cbn. exists cstate, s'. easy. 56 | Qed. 57 | 58 | Fact isFlatListOf_app_inv (f : finType) s1 s2 (s : list f): 59 | isFlatListOf (s1 ++ s2) s 60 | -> exists s1' s2', s = s1' ++ s2' /\ isFlatListOf s1 s1' /\ isFlatListOf s2 s2'. 61 | Proof. 62 | unfold isFlatListOf. 63 | intros H. 64 | symmetry in H. apply map_eq_app in H as (s1' & s2' & -> & -> & ->). eauto. 65 | Qed. 66 | 67 | Lemma FlatFunSingleTMGenNP_FlatSingleTMGenNP_equiv M s maxSize steps: 68 | FlatFunSingleTMGenNP (M, s, maxSize, steps) <-> FlatSingleTMGenNP (M, s, maxSize, steps). 69 | Proof. 70 | split. 71 | - intros (H1 & H2 & (cert & f & H3 & H4 & H5)). 72 | specialize (proj1 (execFlatTM_correct _ _ _ _) H5) as (fsig & n & M' & c0 & c' & F1 & F2 & F3). 73 | destruct F1. 74 | rewrite H2 in eq__tapes. subst. 75 | exists fsig, M'. specialize (initTape_isFlatteningConfigOf F2) as (s0' & s' & F5 & F4 & ->). 76 | apply isFlatListOf_app_inv in F4 as (s'' & cert' & -> & F6 & F7). 77 | exists s''. split; [constructor; eauto | split; [apply F6 | ]]. 78 | cbn. exists cert'. 79 | split. 80 | { unfold isFlatListOf in F7. apply (f_equal (@length _)) in F7. rewrite map_length in F7. now rewrite <- F7. } 81 | exists c'. unfold initc. enough (TM.start M' = s0') by easy. 82 | rewrite <- F5 in eq__start. now apply injective_index in eq__start. 83 | - intros (fsig & M' & sfin & F1 & F2 & (certfin & F3 & (f & F4))). 84 | split. 85 | { destruct F1. rewrite eq__sig. eapply isFlatListOf_list_ofFlatType, F2. } 86 | split. 87 | { destruct F1. apply eq__tapes. } 88 | exists (map index certfin), (flattenConfig f). 89 | split. 90 | { destruct F1. rewrite eq__sig. eapply isFlatListOf_list_ofFlatType. reflexivity. } 91 | split; [now rewrite map_length | ]. 92 | apply execFlatTM_correct. 93 | exists fsig, 1, M', (initc M' [|initTape_singleTapeTM (sfin ++ certfin)|]), f. 94 | split; [ apply F1 | split; [ | split; [apply F4 | apply flattenConfig_isFlatteningConfigOf]]]. 95 | rewrite isFlatteningConfigOf_iff. 96 | exists [initTape_singleTapeTM (s ++ map index certfin)]. 97 | destruct F1. 98 | rewrite eq__start. 99 | cbn. split; [ | reflexivity]. 100 | apply isFlatteningTapesOf_iff. 101 | cbn. rewrite F2, <- map_app. generalize (sfin ++ certfin). intros l. 102 | destruct l; cbn; easy. 103 | Qed. 104 | -------------------------------------------------------------------------------- /theories/NP/SAT/SAT.v: -------------------------------------------------------------------------------- 1 | From Complexity.NP.SAT Require Export SharedSAT. 2 | Require Import Lia. 3 | 4 | From Undecidability.L.Tactics Require Import LTactics GenEncode. 5 | From Undecidability.L.Datatypes Require Import LProd LOptions LBool LNat Lists LUnit. 6 | From Undecidability.L.Functions Require Import EqBool. 7 | From Complexity.Complexity Require Import UpToCPoly. 8 | From Complexity.Libs.CookPrelim Require Import MorePrelim. 9 | 10 | (** * SAT: Satisfiability of CNFs *) 11 | 12 | (** ** Definition of SAT *) 13 | (** Conjunctive normal forms (need not be canonical)*) 14 | (* We use notations instead of definitions because the extraction mechanism does not cope well with aliases *) 15 | Notation var := (nat) (only parsing). 16 | Notation literal := ((bool * var)%type) (only parsing). 17 | Notation clause := (list literal) (only parsing). 18 | Notation cnf := (list clause) (only parsing). 19 | 20 | (** Assignments as lists of natural numbers: contain the indices of variables that are mapped to true *) 21 | Implicit Types (a : assgn) (N : cnf) (C : clause) (l :literal). 22 | 23 | (** just a notation here; the definition is shared with FSAT *) 24 | Notation evalVar := evalVar. 25 | 26 | Definition evalLiteral a l : bool := match l with 27 | | (s, v) => Bool.eqb (evalVar a v) s 28 | end. 29 | 30 | (**Empty disjunction evaluates to false*) 31 | Definition evalClause a C := existsb (evalLiteral a) C. 32 | 33 | (**Empty conjunction evaluates to true *) 34 | Definition evalCnf a N := forallb (evalClause a) N. 35 | 36 | (** Some helpful properties *) 37 | (** A characterisation of one processing step of evaluation *) 38 | Lemma evalClause_step_inv a C l b : 39 | evalClause a (l::C) = b <-> exists b1 b2, evalClause a C = b2 /\ evalLiteral a l = b1 /\ b = b1 || b2. 40 | Proof. 41 | cbn. split; intros. 42 | - rewrite <- H. eauto. 43 | - destruct H as (b1 & b2 & <- & <- & ->). eauto. 44 | Qed. 45 | 46 | Lemma evalCnf_step_inv a N C b : 47 | evalCnf a (C :: N) = b <-> exists b1 b2, evalCnf a N = b2 /\ evalClause a C = b1 /\ b = b1 && b2. 48 | Proof. 49 | cbn. split; intros. 50 | - rewrite <- H. eauto. 51 | - destruct H as (b1 & b2 & <- & <- & ->). eauto. 52 | Qed. 53 | 54 | Lemma evalLiteral_var_iff a b v : 55 | evalLiteral a (b, v) = true <-> evalVar a v = b. 56 | Proof. 57 | unfold evalLiteral. destruct b, evalVar; cbn; firstorder. 58 | Qed. 59 | 60 | Lemma evalClause_literal_iff a C : 61 | evalClause a C = true <-> (exists l, l el C /\ evalLiteral a l = true). 62 | Proof. apply existsb_exists. Qed. 63 | 64 | Corollary evalClause_app a C1 C2 : 65 | evalClause a (C1 ++ C2) = true <-> (evalClause a C1 = true \/ evalClause a C2 = true). 66 | Proof. 67 | rewrite !evalClause_literal_iff. setoid_rewrite in_app_iff. firstorder. 68 | Qed. 69 | 70 | Lemma evalCnf_clause_iff a N : 71 | evalCnf a N = true <-> (forall C, C el N -> evalClause a C = true). 72 | Proof. apply forallb_forall. Qed. 73 | 74 | Corollary evalCnf_app_iff a N1 N2 : 75 | evalCnf a (N1 ++ N2) = true <-> (evalCnf a N1 = true /\ evalCnf a N2 = true). 76 | Proof. 77 | rewrite !evalCnf_clause_iff. setoid_rewrite in_app_iff. firstorder. 78 | Qed. 79 | 80 | Definition satisfies a N := evalCnf a N = true. 81 | Definition SAT N : Prop := exists (a : assgn), satisfies a N. 82 | 83 | Lemma evalLiteral_assgn_equiv a1 a2 l : a1 === a2 -> evalLiteral a1 l = evalLiteral a2 l. 84 | Proof. 85 | intros [H1 H2]. destruct l as (b & v). unfold evalLiteral. destruct (evalVar a1 v) eqn:Hev1. 86 | - apply (evalVar_monotonic H1) in Hev1. easy. 87 | - destruct (evalVar a2 v) eqn:Hev2; [ | easy]. 88 | apply (evalVar_monotonic H2) in Hev2. congruence. 89 | Qed. 90 | 91 | Lemma evalClause_assgn_equiv a1 a2 C : a1 === a2 -> evalClause a1 C = evalClause a2 C. 92 | Proof. 93 | intros H. enough (evalClause a1 C = true <-> evalClause a2 C = true). 94 | - destruct evalClause; destruct evalClause; firstorder; easy. 95 | - rewrite !evalClause_literal_iff. now setoid_rewrite (evalLiteral_assgn_equiv _ H). 96 | Qed. 97 | 98 | Lemma evalCnf_assgn_equiv a1 a2 N : a1 === a2 -> evalCnf a1 N = evalCnf a2 N. 99 | Proof. 100 | intros H. enough (evalCnf a1 N = true <-> evalCnf a2 N = true). 101 | - destruct evalCnf; destruct evalCnf; firstorder; easy. 102 | - rewrite !evalCnf_clause_iff. now setoid_rewrite (evalClause_assgn_equiv _ H). 103 | Qed. 104 | 105 | (** Bounds on the number of used variables*) 106 | Definition varInLiteral v (l : literal) := exists b, l = (b, v). 107 | Definition varInClause v c := exists l, l el c /\ varInLiteral v l. 108 | Definition varInCnf v cn := exists cl, cl el cn /\ varInClause v cl. 109 | 110 | Definition clause_varsIn (p : nat -> Prop) c := forall v, varInClause v c -> p v. 111 | Definition cnf_varsIn (p : nat -> Prop) c := forall v, varInCnf v c -> p v. 112 | 113 | Lemma cnf_varsIn_app c1 c2 p : cnf_varsIn p (c1 ++ c2) <-> cnf_varsIn p c1 /\ cnf_varsIn p c2. 114 | Proof. 115 | unfold cnf_varsIn. unfold varInCnf. setoid_rewrite in_app_iff. split; [intros H |intros [H1 H2]]. 116 | - split; intros v [cl [H3 H4]]; apply H; eauto. 117 | - intros v [cl [[H3 | H3] H4]]; [apply H1 | apply H2]; eauto. 118 | Qed. 119 | 120 | Lemma cnf_varsIn_monotonic (p1 p2 : nat -> Prop) c : (forall n, p1 n -> p2 n) -> cnf_varsIn p1 c -> cnf_varsIn p2 c. 121 | Proof. 122 | intros H H1 v H2. apply H, H1, H2. 123 | Qed. 124 | 125 | (** size of CNF in terms of number of operators *) 126 | Definition size_clause C := length C. (*we should subtract 1 here, but this would only complicate things *) 127 | Definition size_cnf N := sumn (map size_clause N) + length N. 128 | 129 | Lemma size_clause_app C1 C2 : size_clause (C1 ++ C2) = size_clause C1 + size_clause C2. 130 | Proof. 131 | unfold size_clause. now rewrite app_length. 132 | Qed. 133 | 134 | Lemma size_cnf_app N1 N2 : size_cnf (N1 ++ N2) = size_cnf N1 + size_cnf N2. 135 | Proof. 136 | unfold size_cnf. rewrite map_app, sumn_app, app_length. lia. 137 | Qed. 138 | -------------------------------------------------------------------------------- /theories/NP/SAT/SharedSAT.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import L. 2 | From Undecidability.L.Datatypes Require Import Lists LNat. 3 | From Complexity.Libs Require Export PSLCompat. 4 | Require Import Lia. 5 | 6 | (** * Shared Definitions for SAT and FSAT *) 7 | 8 | Notation var := (nat) (only parsing). 9 | Notation assgn := (list var). 10 | 11 | Definition evalVar a v := list_in_decb Nat.eqb a v. 12 | 13 | Lemma evalVar_in_iff a v : evalVar a v = true <-> v el a. 14 | Proof. 15 | unfold evalVar. rewrite list_in_decb_iff; [easy | symmetry; apply Nat.eqb_eq]. 16 | Qed. 17 | 18 | Lemma evalVar_monotonic a a' v : a <<= a' -> evalVar a v = true -> evalVar a' v = true. 19 | Proof. 20 | intros H1 H2. rewrite evalVar_in_iff in *. firstorder. 21 | Qed. 22 | 23 | Lemma evalVar_assgn_equiv a a' v : a === a' -> evalVar a v = evalVar a' v. 24 | Proof. 25 | intros H. enough (evalVar a v = true <-> evalVar a' v = true). 26 | { destruct evalVar, evalVar; firstorder. } 27 | split; apply evalVar_monotonic; apply H. 28 | Qed. 29 | 30 | 31 | -------------------------------------------------------------------------------- /theories/NP/SAT/kSAT.v: -------------------------------------------------------------------------------- 1 | From Complexity.NP.SAT Require Export SAT. 2 | From Undecidability.L.Datatypes Require Import LProd LTerm LNat Lists LOptions. 3 | From Undecidability.L.Functions Require Import EqBool. 4 | 5 | (** * k-SAT *) 6 | (** A CNF is a k-CNF if each of its clauses has exactly k literals. k-SAT is SAT restricted to k-CNFs. *) 7 | 8 | Inductive kCNF (k : nat) : cnf -> Prop := 9 | | kCNFB : kCNF k [] 10 | | kCNFS (N : cnf) (C : clause) : (|C|) = k -> kCNF k N -> kCNF k (C :: N). 11 | 12 | #[export] 13 | Hint Constructors kCNF : core. 14 | 15 | Lemma kCNF_clause_length (k : nat) (N : cnf) : kCNF k N <-> forall C, C el N -> |C| =k. 16 | Proof. 17 | split. 18 | - induction 1. 19 | + intros C []. 20 | + intros C' [-> | Hel]; [assumption | now apply IHkCNF]. 21 | - intros H. induction N; [eauto | ]. 22 | constructor; [now apply H | apply IHN; eauto]. 23 | Qed. 24 | 25 | Lemma kCNF_app (k : nat) (N1 N2 : cnf) : kCNF k (N1 ++ N2) <-> kCNF k N1 /\ kCNF k N2. 26 | Proof. 27 | induction N1; cbn; split. 28 | - eauto. 29 | - tauto. 30 | - intros H. inv H. apply IHN1 in H3 as (H3 & H4). split; eauto. 31 | - intros [H1 H2]. inv H1. constructor; [easy | ]. now apply IHN1. 32 | Qed. 33 | 34 | Definition kSAT (k : nat) (N : cnf) : Prop := k > 0 /\ kCNF k N /\ SAT N. 35 | 36 | (** boolean decider for kCNF *) 37 | Definition clause_length_decb (k : nat) := (fun (C : clause) => Nat.eqb k (|C|)). 38 | Definition kCNF_decb (k : nat) (N : cnf) := forallb (clause_length_decb k) N. 39 | 40 | Lemma kCNF_decb_iff (k : nat) (N : cnf) : kCNF_decb k N = true <-> kCNF k N. 41 | Proof. 42 | rewrite kCNF_clause_length. unfold kCNF_decb, clause_length_decb. 43 | rewrite forallb_forall. setoid_rewrite Nat.eqb_eq. firstorder. 44 | Qed. 45 | 46 | (** extraction of decider *) 47 | From Undecidability.L.Tactics Require Import LTactics GenEncode. 48 | From Complexity.Libs.CookPrelim Require Import PolyBounds. 49 | 50 | Definition c__clauseLengthDecb := c__length + 5 + 1. 51 | Definition clause_length_decb_time (k : nat) (C : clause) := c__length * (|C|) + eqbTime (X := nat) (size (enc k)) (size (enc (|C|))) + c__clauseLengthDecb. 52 | #[export] 53 | Instance term_clause_length_decb : computableTime' clause_length_decb (fun k _ => (1, fun C _ => (clause_length_decb_time k C, tt))). 54 | Proof. 55 | extract. solverec. unfold clause_length_decb_time, c__clauseLengthDecb. solverec. 56 | Qed. 57 | 58 | Definition c__kCNFDecb := 3. 59 | Definition kCNF_decb_time (k : nat) (N : cnf) := forallb_time (fun C => clause_length_decb_time k C) N + c__kCNFDecb. 60 | #[export] 61 | Instance term_kCNF_decb : computableTime' kCNF_decb (fun k _ => (1, fun N _ => (kCNF_decb_time k N, tt))). 62 | Proof. 63 | extract. solverec. unfold kCNF_decb_time, c__kCNFDecb. solverec. 64 | Qed. 65 | 66 | Definition c__kCNFDecbBound1 := c__length + c__eqbComp nat. 67 | Definition c__kCNFDecbBound2 := c__clauseLengthDecb + c__forallb + c__kCNFDecb. 68 | Definition poly__kCNFDecb n := (n + 1) * (c__kCNFDecbBound1 * (n + 1) + c__kCNFDecbBound2). 69 | Lemma kCNF_decb_time_bound k N : kCNF_decb_time k N <= poly__kCNFDecb (size (enc N) + size (enc k)). 70 | Proof. 71 | unfold kCNF_decb_time. rewrite forallb_time_bound_env. 72 | 2: { 73 | split. 74 | - intros C n. unfold clause_length_decb_time. 75 | rewrite eqbTime_le_r. rewrite list_size_length at 1. rewrite list_size_enc_length. 76 | instantiate (1 := encodable_nat_enc). 77 | instantiate (1 := fun n => (c__length + c__eqbComp nat) * (n + 1) + c__clauseLengthDecb). 78 | cbn -[Nat.add Nat.mul]. solverec. 79 | - smpl_inO. 80 | } 81 | rewrite list_size_length. 82 | unfold poly__kCNFDecb, c__kCNFDecbBound1, c__kCNFDecbBound2. lia. 83 | Qed. 84 | Lemma kCNF_decb_poly : monotonic poly__kCNFDecb /\ inOPoly poly__kCNFDecb. 85 | Proof. 86 | unfold poly__kCNFDecb. split; smpl_inO. 87 | Qed. 88 | -------------------------------------------------------------------------------- /theories/NP/SAT/kSAT_to_SAT.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import Tactics.LTactics. 2 | From Complexity Require Import SAT SAT_inNP kSAT CookPrelim.PolyBounds Complexity.NP Complexity.Definitions. 3 | From Undecidability.L.Datatypes Require Import LBool LNat Lists LProd. 4 | 5 | Lemma kSAT_to_SAT (k : nat): reducesPolyMO (kSAT k) SAT. 6 | Proof. 7 | destruct k. 8 | { (* always return a trivial no-instance if k = 0 *) 9 | apply reducesPolyMO_intro with (f := fun N => [[(true, 0)]; [(false, 0)]]). 10 | - exists (fun n => 13). 11 | + extract. solverec. 12 | + smpl_inO. 13 | + smpl_inO. 14 | + exists (fun n => size (enc [[(true, 0)]; [(false, 0)]])); [solverec | smpl_inO | smpl_inO]. 15 | - intros N. cbn. unfold kSAT. 16 | split; [lia | ]. intros [a H]. 17 | unfold satisfies, evalCnf in H; cbn in H. 18 | destruct evalVar; cbn in H; congruence. 19 | } 20 | 21 | (*check if it is a kCNF. if so, the reduction the SAT instance is the identity. otherwise, return a negative SAT instance*) 22 | apply reducesPolyMO_intro with (f := fun N => if kCNF_decb (S k) N then N else [[(true, 0)]; [(false, 0)]]) . 23 | - evar (f : nat -> nat). exists f. 24 | + extract. solverec. 25 | all: rewrite kCNF_decb_time_bound. 26 | instantiate (f := fun n => poly__kCNFDecb (n + size (enc (S k))) + 18). 27 | all: subst f; solverec. 28 | + subst f; smpl_inO. apply inOPoly_comp; smpl_inO; apply kCNF_decb_poly. 29 | + subst f; smpl_inO. apply kCNF_decb_poly. 30 | + evar (g : nat -> nat). exists g. 31 | * intros N. destruct kCNF_decb. 32 | instantiate (g := fun n => n + size (enc [[(true, 0)]; [(false, 0)]])). 33 | all: subst g; solverec. 34 | * subst g; smpl_inO. 35 | * subst g; smpl_inO. 36 | - intros N. split. 37 | + intros [H1 [H2 H3]]. 38 | apply kCNF_decb_iff in H2. rewrite H2. apply H3. 39 | + destruct kCNF_decb eqn:H1. 40 | * apply kCNF_decb_iff in H1. intros H2. split; [lia | split; easy]. 41 | * intros [a H]. unfold satisfies, evalCnf in H; cbn in H. 42 | destruct evalVar; cbn in H; congruence. 43 | Qed. 44 | 45 | Lemma inNP_kSAT (k : nat) : inNP (kSAT k). 46 | Proof. 47 | eapply red_inNP with (Q := SAT). 48 | - apply kSAT_to_SAT. 49 | - apply sat_NP. 50 | Qed. 51 | -------------------------------------------------------------------------------- /theories/NP/TM/IntermediateProblems.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import Tactics.LTactics Prelim.MoreList Prelim.MoreBase. 2 | From Complexity.Complexity Require Import NP Definitions Monotonic. 3 | From Complexity.NP Require Import L.GenNP. 4 | 5 | 6 | (** * From L to TMs *) 7 | 8 | (** Start: *) 9 | (** * This start might be bad, as we need to check the bound explicitly, e.g. count the beta-steps during the simulation. *) 10 | (** * But we can choose the bound large enough such that the term we simulate halts in the bound or always diverges *) 11 | (** * We might want to simulate some L term that always halts *) 12 | (** * But that means we need to distinguish true/false in the representation. *) 13 | 14 | (** * Eventuell moechten wir nicht mit einem "einfachen" problem starten, sondern erst eienn lambda-trm scheiben, der decider für eine lang genuge zeit simulirt und dann hält oder divergiert, je nachdem ob der Decider wahr oder falsch sagt *) 15 | (** * Divergenz ist ein schlechter Problem, wenn man von divergens reduziert, da man häufig nur obere schranken für die Laufzeit der Simulatoren hat. 16 | 17 | Da der simulierte Term evtl aber mit groesserer Schranke haelt muesste man dann schritte mitzählen. *) 18 | 19 | (* Weitere Idee: Prädikat nutzen, um Probleminstanzen weiter einzuschränken? *) 20 | 21 | From Undecidability.TM Require Import TM CodeTM. 22 | From Undecidability Require Import LFinType. 23 | 24 | From Complexity Require Import NP L_to_LM LM_to_mTM mTM_to_singleTapeTM TMGenNP_fixed_mTM Subtypes. 25 | 26 | Import LNat. 27 | Lemma GenNP_to_TMGenNP: 28 | GenNP (list bool) ⪯p TMGenNP_fixed (projT1 (M_multi2mono.M__mono (projT1 M.M))). 29 | Proof. 30 | eapply reducesPolyMO_transitive. now apply GenNP_to_LMGenNP. 31 | eapply reducesPolyMO_transitive. now apply LMGenNP_to_TMGenNP_mTM. 32 | now apply TMGenNP_mTM_to_TMGenNP_singleTM. 33 | Qed. 34 | 35 | (* 36 | Print Assumptions GenNP_to_TMGenNP. 37 | *) 38 | (** Not Complete: nice form of Time bound *) 39 | (*From Undecidability.L.AbstractMachines.TM_LHeapInterpreter Require TM.LMBounds. *) 40 | 41 | 42 | (** Approach: simulate step-indexed L interpreter inside TM *) 43 | (** Problems: Well-formedness of certificate-input? *) 44 | 45 | (** Maybe intermediate problem in terms of Heap-Machine? *) 46 | -------------------------------------------------------------------------------- /theories/NP/TM/L_to_LM.v: -------------------------------------------------------------------------------- 1 | From Undecidability.L Require Import Tactics.LTactics Prelim.MoreList Prelim.MoreBase. 2 | From Complexity.Complexity Require Import NP Definitions Monotonic Subtypes. 3 | From Complexity.NP.L Require Import GenNP LMGenNP. 4 | 5 | From Undecidability.L Require Import LM_heap_def LM_heap_correct LBool ResourceMeasures LNat LTerm LProd. 6 | From Complexity.L Require Import Compile. 7 | 8 | Import Nat. 9 | Lemma GenNP_to_LMGenNP (X:Type) `{R__X : encodable X}: 10 | GenNP X ⪯p LMGenNP X. 11 | Proof. 12 | evar (f__steps : nat -> nat). [f__steps]:intros n0. 13 | pose (f := (fun '(s, maxSize, steps) => (compile s,maxSize : nat, f__steps steps))). 14 | eapply reducesPolyMO_intro_restrictBy_both with (f:=f). 15 | 2:{ 16 | intros [[s' maxSize] steps]. 17 | intros (cs&Hsmall&Hk). assert (lambda s') as [s0 eq] by Lproc. set (s:=lam s0) in *. subst s'. 18 | split. 19 | -hnf. repeat simple apply conj. 20 | +easy. 21 | +intros c k sigma R__M. 22 | eapply soundnessTime with (s:=(L.app s (@enc _ R__X c))) in R__M as (g&H'&t&n&eq__sigma&Rs%timeBS_evalIn&_&eq). 2:Lproc. 23 | subst k. apply Hsmall in Rs as (c'&k'&Hsize_c'&Hk'). 24 | edestruct completeness as (?&?&?&HM'). 1:{split. exact Hsize_c'. Lproc. } 25 | 1:now Lproc. 26 | do 2 eexists. repeat simple apply conj. 2:split. 27 | 1,2:eassumption. inversion 1. 28 | +intros c H k sigma' R__M. unfold initLMGen in R__M. 29 | eapply soundnessTime with (s:=(L.app s (@enc _ R__X c))) in R__M as (g&H'&t&n&eq__sigma&Rs%timeBS_evalIn&_&eq). 2:Lproc. 30 | subst k. apply Hk in Rs. rewrite Rs. unfold f__steps. reflexivity. easy. 31 | -apply Morphisms_Prop.ex_iff_morphism. intros c. 32 | apply Morphisms_Prop.and_iff_morphism_obligation_1. easy. 33 | split. 34 | +intros (?&(?&?&Ev)%evalLe_evalIn). eapply timeBS_evalIn,completenessTime in Ev. 2:Lproc. 35 | destruct Ev as (g&Heap&?&Rs). 36 | eexists _,_. split. 2:split. 2:exact Rs. now cbn; lia. now intros ? ?. 37 | +intros (?&?&?&R__M). 38 | eapply soundnessTime with (s:=(L.app s (@enc _ R__X c))) in R__M as (g&H'&t&n&eq__sigma&Rs%timeBS_evalIn&_&eq). 2:Lproc. 39 | eexists. eapply evalIn_evalLe. 2:easy. cbn in H;nia. 40 | } 41 | subst f__steps;cbn beta in f. 42 | evar (time : nat -> nat). [time]:intros n0. 43 | exists time. 44 | { unfold f. extract. 45 | solverec. 46 | set (n0:=(size (enc (a0, b0, b)))). 47 | eassert (b <= n0) as H. 48 | {subst n0. rewrite !LProd.size_prod;cbn [fst snd]. now rewrite size_nat_enc_r at 1. } 49 | unfold time_compile. 50 | eassert (size a0 <= n0) as ->. 51 | {subst n0. rewrite !LProd.size_prod;cbn [fst snd]. now rewrite LTerm.size_term_enc_r at 1. } 52 | unfold time. unfold add_time, mult_time. rewrite H . reflexivity. 53 | } 54 | 1,2:now unfold time;smpl_inO. 55 | {unfold f. evar (resSize : nat -> nat). [resSize]:intros n0. eexists resSize. 56 | {intros [[x mSize] steps]. 57 | set(n0:=size (enc (x, mSize, steps))). 58 | rewrite !LProd.size_prod;cbn [fst snd]. 59 | setoid_rewrite size_nat_enc at 2. 60 | eassert (steps <= n0) as ->. 61 | {subst n0. rewrite !LProd.size_prod;cbn [fst snd]. now rewrite size_nat_enc_r at 1. } 62 | eassert (size (enc mSize) <= n0) as ->. 63 | {subst n0. rewrite !LProd.size_prod;cbn [fst snd]. easy. } 64 | rewrite compile_enc_size. 65 | eassert (size x <= n0) as ->. 66 | {subst n0. rewrite !LProd.size_prod;cbn [fst snd]. now rewrite size_term_enc_r at 1. } 67 | unfold resSize. reflexivity. 68 | } 69 | 1,2:unfold resSize;smpl_inO. 70 | } 71 | Qed. 72 | 73 | (* 74 | Lemma NPhard_LMGenNP X__cert `{R__cert : encodable X__cert}: 75 | canEnumTerms X__cert-> NPhard (LMGenNP X__cert). 76 | Proof. 77 | intros ?%NPhard_GenNP. now eapply (red_NPhard GenNP_to_LMGenNP). 78 | Qed. 79 | *) 80 | -------------------------------------------------------------------------------- /theories/NP/TM/TMGenNP.v: -------------------------------------------------------------------------------- 1 | From Undecidability.TM Require Import TM_facts. 2 | From Undecidability.L.TM Require Import TMEncoding. 3 | From Complexity.L.TM Require Import TMflat TMflatEnc TMflatFun TapeDecode TMunflatten. 4 | From Undecidability.L.Datatypes Require Import LNat LProd Lists. 5 | From Complexity.Complexity Require Import NP LinTimeDecodable ONotation. 6 | From Undecidability.L Require Import Tactics.LTactics. 7 | From Undecidability.L Require Import Functions.Decoding. 8 | From Complexity.L Require Import TMflatFun TMflatComp. 9 | From Undecidability Require Import L.Functions.EqBool. 10 | From Undecidability Require Import L.Datatypes.LNat. 11 | 12 | (** Using this problem to establish NP-hardness as by Cook-levin would require us to construct TMs from L-terms. We don't want to do this. Instead, we define another problem (GenNPHalt_fixed_mTM) where the machine itself and some tape content is fixed, but a single tape has arbitrary content on it. *) 13 | 14 | (* Factorise proof over GenNP? *) 15 | Definition TMGenNP' sig n : TM sig n * nat * nat -> Prop := 16 | fun '(M, k, steps) => 17 | exists tp, sizeOfmTapes tp <= k 18 | /\ exists f, loopM (initc M tp) steps = Some f. 19 | 20 | Definition TMGenNP: flatTM*nat*nat -> Prop:= 21 | fun '(M,maxSize, steps (*in unary*)) => 22 | (exists sig n (M':TM sig n), isFlatteningTMOf M M' /\ TMGenNP' (M',maxSize,steps)). 23 | 24 | Definition TM1GenNP : {'(M,_,_) | M.(TMflat.tapes) = 1} -> Prop := 25 | (fun '(exist (M,maxSize, steps (*in unary*)) _) => exists sig (M':TM sig 1), isFlatteningTMOf M M' /\ TMGenNP' (M', maxSize, steps)). 26 | 27 | Lemma inNP_TMgenericNPCompleteProblem: inNP TMGenNP. 28 | Proof. 29 | pose (R := fun '(M,maxSize, steps (*in unary*)) t => 30 | sizeOfmTapesFlat t <= maxSize /\ 31 | exists sig n (M':TM sig n), 32 | isFlatteningTMOf M M' 33 | /\ exists t', isFlatteningTapesOf t t' 34 | /\ (exists f, loopM (initc M' t') steps = Some f)). 35 | apply inNP_intro with (R:= R). 36 | now apply linDec_polyTimeComputable. 37 | -destruct execFlat_poly as (f''&Hf''&polyf''&monof''). 38 | evar (f':nat -> nat). [f']:intro x. 39 | exists f'. repeat eapply conj. 40 | { split. cbn. 41 | eexists (fun '((M,maxSize,steps),t) => 42 | if (sizeOfmTapesFlat t <=? maxSize) 43 | then match execFlatTM M t steps with 44 | Some _ => true 45 | | _ => false 46 | end 47 | else false). 48 | repeat eapply conj. 49 | 2:{intros [[[M maxSize] steps] t]. cbn. 50 | destruct (Nat.leb_spec0 (sizeOfmTapesFlat t) (maxSize));cbn [negb andb]. 51 | 2:{ split. 2:easy. intros (?&?&?&?&?&?&?&?). easy. } 52 | specialize (execFlatTM_correct M t steps) as H. 53 | destruct execFlatTM as [c| ] eqn:Hexec. all:split. 1,4:easy. 54 | -intros. specialize (H c). destruct H as [H _]. specialize H with (1:= Logic.eq_refl) as (?&?&?&?&?&?&Hc&?&?). 55 | split. easy. 56 | do 4 esplit. eauto. 57 | inv Hc. cbn in *. 58 | do 2 esplit. eauto. 59 | destruct x2. cbn in *. 60 | eexists. rewrite <- H1. unfold initc. repeat f_equal. inv H. apply injective_index. congruence. 61 | -intros (?&?&?&?&?&?&?&?&?). exfalso. 62 | edestruct H as [_ H']. discriminate H'. 63 | do 6 eexists. now eauto. 64 | split. now eauto using initFlat_correct. 65 | split. eauto. instantiate (1 := (_,_)). 66 | split;cbn. constructor. 67 | } 68 | extract. 69 | recRel_prettify. 70 | intros [[[M maxSize] steps] t] []. 71 | split;[ |now repeat destruct _]. 72 | rewrite sizeOfmTapesFlat_timeBySize. 73 | unfold leb_time. rewrite Nat.le_min_r. 74 | unfold sizeOfmTapesFlat_timeSize. 75 | remember (size (enc (M, maxSize, steps, t))) as x. 76 | 77 | assert (Ht : size (enc t) <= x). 78 | { subst x. rewrite !size_prod. cbn [fst snd]. lia. } 79 | rewrite Ht. 80 | 81 | assert (Hms : maxSize <= x). 82 | { subst x. rewrite !size_prod. cbn [fst snd]. rewrite <- size_nat_enc_r. lia. } 83 | rewrite Hms at 1. 84 | 85 | 86 | destruct (Nat.leb_spec (sizeOfmTapesFlat t) maxSize). 87 | rewrite Hf''. hnf in monof''. rewrite monof'' with (x':=x). 88 | 2:{rewrite H. subst x. rewrite !size_prod. cbn [fst snd]. rewrite <- !size_nat_enc_r. lia. } 89 | destruct execFlatTM. 90 | all:unfold f'. 91 | reflexivity. 92 | all:lia. 93 | } 94 | all:unfold f'. 95 | all:smpl_inO. 96 | -evar (f:nat -> nat). [f]:intro x. 97 | exists f. 98 | +intros [[TM maxSize] steps] y. cbn. 99 | intros (?&sig&n&M'&HM&t' & Ht' & HHalt) . 100 | eexists _,_,_. split. easy. eexists. split. now erewrite <- sizeOfmTapesFlat_eq. easy. 101 | +intros [[TM maxSize] steps]. cbn. 102 | intros (sig&n&M'&HM&t' & Ht' & HHalt) . 103 | eexists _. split. 104 | *split. now erewrite sizeOfmTapesFlat_eq. 105 | eauto 10 using mkIsFlatteningTapeOf. 106 | *remember (size (enc (TM, maxSize, steps))) as x eqn:Hn. 107 | rewrite size_flatTapes. 2:now apply mkIsFlatteningTapeOf. 108 | rewrite Ht'. 109 | assert (n <= x /\ maxSize <= x /\ | elem sig | <= x) as (->&->&->). 110 | {inv HM;destruct TM; cbn in *. rewrite !size_prod,size_TM;cbn [fst snd]. 111 | repeat apply conj. 112 | all:rewrite size_nat_enc_r at 1; subst;nia. 113 | } 114 | unfold f;reflexivity. 115 | +unfold f;smpl_inO. 116 | +unfold f;smpl_inO. 117 | Qed. 118 | -------------------------------------------------------------------------------- /theories/NP/TM/TMGenNP_fixed_mTM.v: -------------------------------------------------------------------------------- 1 | From Undecidability.TM Require Import TM_facts. 2 | From Undecidability.L.TM Require Import TMEncoding. 3 | From Complexity.Complexity Require Import NP Subtypes. 4 | From Undecidability.L Require Import Tactics.LTactics. 5 | 6 | (** For each Machine M (with n+1 tapes), we define this problem: 7 | Given n tapes and a sizeBound and a step bound, does there exist a (small enough) first tape such that the machine halts on the resulting n+1 tapes in fewer steps than the step bound? *) 8 | 9 | (** We contain this on haltsOrDiverges as our MutiTape2SingleTape-translation probably only knows upper bounds of the step count. *) 10 | Section mTM. 11 | Context {sig : finType} {n} (M : TM sig (S n)). 12 | 13 | Definition HaltsOrDiverges_mTM_fixed : Vector.t (tape sig) n * nat * nat -> Prop := 14 | fun '(ts, maxSize, steps) => 15 | forall t__cert' k res', loopM (initc M (t__cert':::ts)) k = Some res' 16 | -> exists t__cert res, sizeOfTape t__cert <= maxSize 17 | /\ loopM (initc M (t__cert:::ts)) steps = Some res. 18 | 19 | Definition mTMGenNP_fixed' := (fun '(ts, maxSize, steps) => 20 | exists t1, sizeOfTape t1 <= maxSize /\ exists f, loopM (initc M (t1:::ts)) steps = Some f). 21 | 22 | Definition mTMGenNP_fixed : {x | HaltsOrDiverges_mTM_fixed x} -> Prop := 23 | restrictBy HaltsOrDiverges_mTM_fixed mTMGenNP_fixed'. 24 | 25 | End mTM. 26 | 27 | Arguments mTMGenNP_fixed {_ _} _. 28 | 29 | 30 | Definition initTape_singleTapeTM (sig : Type) (s : list sig) := 31 | match s with 32 | | [] => niltape sig 33 | | x::s => @leftof sig x s 34 | end. 35 | 36 | Definition TMGenNP_fixed {sig : finType} (M : TM sig 1) 37 | := (fun '(ts, maxSize, steps) => 38 | exists (cert : list sig), length cert <= maxSize 39 | /\ exists res, execTM M [|initTape_singleTapeTM (ts++cert)|] steps = Some res). 40 | 41 | -------------------------------------------------------------------------------- /theories/TM/Code/DecodeBool.v: -------------------------------------------------------------------------------- 1 | From Undecidability.TM Require Import TM ProgrammingTools. 2 | From Complexity.TM Require Import Code.Decode. 3 | 4 | Require Import Lia Ring Arith Program.Wf. 5 | 6 | Lemma bool_encode_injective (t t' : bool): encode t = encode t' -> t = t'. 7 | Proof. 8 | destruct t,t';cbn. all:easy. 9 | Qed. 10 | 11 | Lemma bool_encode_prefixInjective: prefixInjective Encode_bool. 12 | Proof. 13 | unfold encode;cbn. 14 | intros [] [];cbn. all:congruence. 15 | Qed. 16 | 17 | Module CheckEncodesBool. 18 | Section checkEncodesBool. 19 | 20 | Import Mono Multi Copy Switch If Combinators. 21 | 22 | Context (sig : Type) (tau:finType) {I : Retract bool tau}. 23 | 24 | Local Remove Hints Retract_id : typeclass_instances. 25 | 26 | Let Rel : pRel tau bool 1 := ContainsEncoding.Rel (Encode_bool) Retr_f. 27 | 28 | Definition M : pTM tau bool 1:= 29 | Relabel ReadChar (fun c => Option.apply (fun _ => true) false (Option.bind (rT:=bool) Retr_g c)). 30 | 31 | Lemma RealisesIn : M ⊨c(1) (fun tin out => Rel tin out /\ tin = snd out). 32 | Proof. 33 | eapply RealiseIn_monotone. 34 | { unfold M. TM_Correct. } easy. 35 | hnf;cbn. 36 | intros t (?&?) (?&->&->&->). hnf. 37 | split. 2:easy. split. 2:now eexists 0. 38 | destruct Option.bind as [b | ] eqn:H;cbn. 39 | 2:{ intros ? ? ?. erewrite tape_local_current_cons in H. 2:eassumption. cbn in H. now retract_adjoint. } 40 | exists b. rewrite tape_local_cons_iff. 41 | destruct current eqn:H'. all:cbn in H. 2:easy. 42 | apply retract_g_inv in H as ->. rewrite tape_local_l_cons_iff. intuition congruence. 43 | Qed. 44 | 45 | Lemma RealisesIn' : M ⊨c(1) Rel. 46 | Proof. 47 | eapply RealiseIn_monotone. apply RealisesIn. easy. firstorder. 48 | Qed. 49 | 50 | End checkEncodesBool. 51 | End CheckEncodesBool. 52 | 53 | 54 | -------------------------------------------------------------------------------- /theories/TM/Compound/MoveToSymbol_niceSpec.v: -------------------------------------------------------------------------------- 1 | From Undecidability Require Import TM.Util.Prelim. 2 | From Undecidability Require Import TM.Util.TM_facts TM.Compound.MoveToSymbol. 3 | 4 | Require Import ssrbool Lia. 5 | Lemma last_not_default X (d d':X) A : 6 | A <> [] -> last A d = last A d'. 7 | Proof. induction A. easy. destruct A;cbn. easy. intros ?. now apply IHA. Qed. 8 | 9 | 10 | Lemma removelast_as_tail X (x:list X): removelast x = rev (tail (rev x)). 11 | Proof. 12 | rewrite tl_rev. symmetry. apply rev_involutive. 13 | Qed. 14 | 15 | Local Arguments removelast : simpl nomatch. 16 | Local Arguments last : simpl nomatch. 17 | 18 | (** TIPP: Look in ./Copy.v **) 19 | (** I have no Idea anymore why i called this nicer ... *) 20 | 21 | Definition MoveToSymbol_Rel_nice (sig':finType) (f:sig' -> bool) (g:sig' -> sig') t t' := 22 | ((current t = None /\ t = t') 23 | \/ (exists t__L c t__R1 t__R2, 24 | t = midtape t__L c (t__R1++t__R2) 25 | /\ (forall x, x el (removelast (c::t__R1)) -> f x = false) 26 | /\ f (last (c::t__R1) c) = ssrbool.isSome (current t') 27 | /\ (t' = midtape (rev (map g (removelast (c::t__R1)))++t__L) (g (last (c::t__R1) c)) t__R2 28 | \/ (t' = rightof (g (last (c::t__R1) c)) (rev (map g (removelast (c::t__R1)))++t__L) /\ t__R2 = [])))). 29 | 30 | Lemma MoveToSymbol_Fun_nice (sig':finType) (f:sig' -> bool) (g:sig' -> sig') t t' : 31 | MoveToSymbol_Fun f g t = t' <-> MoveToSymbol_Rel_nice f g t t'. 32 | Proof. 33 | remember (tape_local t) as A eqn:eqA. 34 | revert t t' eqA. unfold MoveToSymbol_Rel_nice. 35 | induction A using (size_induction (f:=@length sig'));intros t t' eqA. 36 | rewrite MoveToSymbol_Fun_equation. destruct current eqn:eq. 37 | 2:{ split. now left. intros [ | H']. easy. destruct H' as (?&?&?&?&->&?). easy. } 38 | destruct f eqn:Hf. 39 | { destruct t;inv eq. all:cbn. split. 40 | -intros <-. right. eexists _,_,[],_. 41 | repeat split;eauto. 42 | intros x Hx. destruct Hx. 43 | -intros [ | (t__L&c&t__R1&t__R2&[= -> -> -> ]&Hfalse&Hc&H'')];[ easy | ]. 44 | destruct t__R1 as [ | c__R t__R1]. 45 | 2:{exfalso. cbn in *. rewrite Hfalse in Hf;auto. } 46 | cbn in *. 47 | destruct H'' as [-> | [-> -> ]]. all:cbn in *;now eauto + congruence. 48 | } 49 | destruct t. all:inv eq. destruct l0. all:cbn - [removelast]. 50 | all:rewrite H;[ | | reflexivity];[cbn | cbn;nia]. 51 | - cbn. split. 52 | +intros [(_&<-)| (?&?&?&?&[=]&?)];[]. right. 53 | eexists _,_,[],[]. split;[reflexivity| ]. split;[easy| ]. unfold last, removelast;cbn. eauto. 54 | +intros [([=]&?)|(t__L&c&t__R1&t__R2&[= <- <- H__nil]&Hfalse&Hc&H'')];[]. 55 | destruct t__R1;[ |now inv H__nil]. destruct t__R2;[ |now inv H__nil]. clear H__nil. 56 | cbn in H''|-*. destruct H'' as [-> | [-> _ ]]. 2:now left. now unfold last in Hc;cbn in Hc;congruence. 57 | -eapply Morphisms_Prop.or_iff_morphism. easy. 58 | split. all:intros (t__L&c&t__R1&t__R2&Heq&Hfalse&Hc&H');revert Heq. 59 | +intros [= <- -> ->]. eexists _,_,(_::_),_. split. reflexivity. 60 | cbn. split. now intros ? [-> | ];eauto. 61 | autorewrite with list in |-*;cbn. erewrite last_not_default. split;now eauto. easy. 62 | +intros [= -> -> Heq]. destruct t__R1. 63 | {cbn in *. destruct H' as [ -> | [-> ->]]. all: now cbn in *;congruence. } 64 | revert Heq;intros [= -> ->]. 65 | eexists (_::_),_,_,_. split. reflexivity. cbn in *. 66 | split. now eauto. autorewrite with list in H';cbn. erewrite last_not_default. 2:easy. split;now eauto. 67 | Qed. 68 | 69 | Lemma MoveToSymbol_Fun_is_rel (sig':finType) (f:sig' -> bool) (g:sig' -> sig') t : 70 | MoveToSymbol_Rel_nice f g t (MoveToSymbol_Fun f g t). 71 | Proof. 72 | now rewrite <- MoveToSymbol_Fun_nice. 73 | Qed. 74 | -------------------------------------------------------------------------------- /theories/TM/PrettyBounds/SizeBounds.v: -------------------------------------------------------------------------------- 1 | From Undecidability Require Import MaxList. 2 | From Undecidability Require Import TM.Util.TM_facts TM.Code.CodeTM. 3 | 4 | From Undecidability Require Import TM.Util.VectorPrelim. 5 | 6 | (* MOVE : this file contains general lemmas from is all over the place... *) 7 | 8 | 9 | Lemma max_list_rec_eq_foldl (a : nat) (xs : list nat) : 10 | fold_left max xs a = max_list_rec a xs. 11 | Proof. 12 | revert a. induction xs as [ | x xs IH]; intros; cbn in *. 13 | - reflexivity. 14 | - rewrite IH. rewrite !max_list_rec_max. nia. 15 | Qed. 16 | 17 | Lemma sizeOfmTapes_max_list_map (sig : Type) (n : nat) (T : tapes sig n) : 18 | sizeOfmTapes T = max_list_map (@sizeOfTape _) (vector_to_list T). 19 | Proof. 20 | unfold sizeOfmTapes. 21 | rewrite fold_left_vector_to_list. 22 | rewrite Vector.to_list_map. 23 | unfold max_list_map, max_list. 24 | apply max_list_rec_eq_foldl. 25 | Qed. 26 | 27 | Lemma sizeOfmTapes_upperBound (sig : Type) (n : nat) (tps : tapes sig n) : 28 | forall t, Vector.In t tps -> sizeOfTape t <= sizeOfmTapes tps. 29 | Proof. 30 | intros. rewrite sizeOfmTapes_max_list_map. 31 | apply max_list_map_ge. 32 | now apply Vector.to_list_In. 33 | Qed. 34 | 35 | Lemma right_sizeOfTape sig' (t:tape sig') : 36 | length (right t) <= sizeOfTape t. 37 | Proof. 38 | destruct t;cbn. all:autorewrite with list;cbn. all:nia. 39 | Qed. 40 | 41 | Lemma length_tape_local_right sig' (t:tape sig') : 42 | length (tape_local (tape_move_right t)) <= sizeOfTape t. 43 | Proof. 44 | destruct t;cbn. 1-3:nia. rewrite tape_local_move_right'. autorewrite with list;cbn. all:nia. 45 | Qed. 46 | 47 | From Undecidability.L Require Import Prelim.MoreList. 48 | Import MaxList. 49 | 50 | Lemma max_list_sumn l : max_list l <= sumn l. 51 | Proof. 52 | unfold max_list. 53 | induction l. 54 | - constructor. 55 | - cbn. rewrite max_list_rec_max'. lia. 56 | Qed. -------------------------------------------------------------------------------- /theories/TM/PrettyBounds/SpaceBounds.v: -------------------------------------------------------------------------------- 1 | From Complexity Require Export PrettyBounds. 2 | 3 | From Undecidability Require Export Code.CaseNat. 4 | From Undecidability Require Export Code.CasePair. 5 | 6 | From Undecidability Require Export TM.Code.CodeTM TM.Code.Copy. 7 | 8 | 9 | (* This definition doesn't work, because we need the quantifier for all values after [(s: nat)] *) 10 | (* 11 | Definition dominatedWith_vec (n : nat) (f : Vector.t (nat->nat) n) (g : Vector.t (nat->nat) n) := 12 | { c | forall (i : Fin.t n) (s : nat), f @>i s <=(c[@i]) g @>i s }. 13 | *) 14 | 15 | 16 | From Undecidability Require Import ListTM CaseList. 17 | 18 | From Undecidability Require Export MaxList. 19 | 20 | 21 | Fixpoint sum_list_rec (s : nat) (xs : list nat) := 22 | match xs with 23 | | nil => s 24 | | x :: xs' => sum_list_rec (s + x) xs' 25 | end. 26 | 27 | Lemma sum_list_rec_plus (s1 s2 : nat) (xs : list nat) : 28 | sum_list_rec (s1 + s2) xs = s1 + sum_list_rec s2 xs. 29 | Proof. 30 | revert s1 s2. induction xs as [ | x xs IH]; intros; cbn in *. 31 | - reflexivity. 32 | - rewrite IH. rewrite IH. lia. 33 | Qed. 34 | 35 | Lemma sum_list_rec_S (s : nat) (xs : list nat) : 36 | sum_list_rec (S s) xs = S (sum_list_rec s xs). 37 | Proof. change (S s) with (1 + s). apply sum_list_rec_plus. Qed. 38 | 39 | Lemma sum_list_rec_ge (s : nat) (xs : list nat) : 40 | s <= sum_list_rec s xs. 41 | Proof. 42 | induction xs as [ | x xs]; cbn in *. 43 | - reflexivity. 44 | - rewrite sum_list_rec_plus. lia. 45 | Qed. 46 | 47 | 48 | (* 49 | Lemma Constr_pair_size_nice : 50 | { c | forall (s : nat) Constr_pair_size 51 | *) 52 | 53 | Global Arguments Encode_list_size {sigX X cX}. 54 | Global Arguments size : simpl never. 55 | 56 | 57 | (** Do something with the [k]th element in a chain of conjunctions *) 58 | Ltac projk_fix C H k := 59 | lazymatch k with 60 | | 0 => C (proj1 H) + C H 61 | | 1 => projk_fix C (proj2 H) 0 62 | | S ?k' => projk_fix C (proj2 H) k' 63 | end. 64 | 65 | (** Try to do something with every element in the chain of conjunctions *) 66 | Ltac proj_fix C H := 67 | lazymatch type of H with 68 | | ?P1 /\ ?P2 => C (proj1 H) + proj_fix C (proj2 H) 69 | | _ => C H 70 | end. 71 | 72 | Tactic Notation "projk_rewrite" constr(H) constr(k) := projk_fix ltac:(fun c => erewrite c) H k. 73 | Tactic Notation "projk_rewrite" "->" constr(H) constr(k) := projk_fix ltac:(fun c => erewrite <- c) H k. 74 | Tactic Notation "projk_rewrite" "<-" constr(H) constr(k) := projk_fix ltac:(fun c => erewrite <- c) H k. 75 | 76 | (** If we leave out the number, just try every proposition in the conjunction chain *) 77 | Tactic Notation "projk_rewrite" constr(H) := proj_fix ltac:(fun c => erewrite c) H. 78 | Tactic Notation "projk_rewrite" "->" constr(H) := proj_fix ltac:(fun c => erewrite -> c) H. 79 | Tactic Notation "projk_rewrite" "<-" constr(H) := proj_fix ltac:(fun c => erewrite <- c) H. 80 | -------------------------------------------------------------------------------- /theories/TM/Single/EncodeTapesInvariants.v: -------------------------------------------------------------------------------- 1 | From Undecidability.TM Require Import TM ProgrammingTools Single.EncodeTapes. 2 | 3 | Import Lia. 4 | 5 | From Undecidability.Shared.Libs.PSL Require Prelim. 6 | 7 | #[export] 8 | Hint Rewrite filter_app : list. 9 | Lemma filter_rev (A : Type) (f : A -> bool) (l : list A): filter f (rev l) = rev (filter f l). 10 | Proof. 11 | induction l;cbn in *. easy. autorewrite with list. cbn;destruct f. all:cbn;now autorewrite with list;congruence. 12 | Qed. 13 | #[export] 14 | Hint Rewrite filter_rev : list. 15 | 16 | 17 | Lemma encode_tape_invariants sig t0 : 18 | t0 = (@niltape _) 19 | \/ exists b__L b__R t, encode_tape t0 = LeftBlank b__L :: t ++[RightBlank b__R] 20 | /\ (forall x, x el t -> isSymbol x = true) 21 | /\ length (filter (@isMarked sig) (encode_tape t0)) = 1 22 | /\ t <> nil. 23 | Proof. 24 | assert (H' : forall l x, x el map UnmarkedSymbol l -> (@isSymbol sig) x = true). 25 | { intros ? ? (?&<-&?)%in_map_iff. easy. } 26 | assert (H1' : forall l, filter (@isMarked sig) (map UnmarkedSymbol l) = []). 1:{induction l;cbn. all:easy. } 27 | 28 | destruct t0;cbn. now left. 29 | all:right. all:eexists _,_. 30 | 3:eexists (_++[_]++_). 2:eexists (_++[_]). 1:eexists (_::_). 31 | all:split;[cbn;autorewrite with list;reflexivity | ]. 32 | all:cbn in *;repeat setoid_rewrite in_app_iff;cbn. all:split;[now intuition (subst;eauto 3) | ]. 33 | all:repeat (repeat rewrite map_rev;autorewrite with list;cbn). 34 | all:repeat rewrite H1'. all:split;[easy | ]. all:now length_not_eq. 35 | Qed. 36 | 37 | 38 | Lemma last_app_eq X A B (a:X) b : 39 | A++[a] = B++[b] -> A = B /\ a = b. 40 | Proof. 41 | intros H%(f_equal (@rev X)). rewrite !rev_app_distr in H. split. 42 | - inv H. apply (f_equal (@rev X)) in H2. now rewrite !rev_involutive in H2. 43 | - now inv H. 44 | Qed. 45 | 46 | Lemma encode_tape_invariants_partial sig (x:tape sig) b t t__R: 47 | encode_tape x = LeftBlank b :: t ++t__R 48 | -> (forall x, x el t -> isSymbol x = true) 49 | -> (exists init__R b', 50 | t__R = init__R++[RightBlank b'] 51 | /\ (forall c , c el init__R -> isSymbol c = true)) 52 | /\ (length (filter (@isMarked _) (t__R++t++[LeftBlank b])) = 1) 53 | /\ length (t++t__R) > 1. 54 | Proof. 55 | destruct (encode_tape_invariants x) as [-> | (b__L&b__R&t'&Hx&Hsymb&Hmarked&Hnnil)]. 56 | {cbn;congruence. } 57 | rewrite Hx. intros [= <- Ht'] Hall. 58 | assert (H__R : t__R <> []). 1:{ destruct t__R. 2:easy. rewrite app_nil_r in Ht'. subst t. ediscriminate (Hall (RightBlank _)). now eauto. } 59 | apply exists_last in H__R as (init__R&last__R&->). 60 | rewrite !app_assoc in Ht';apply last_app_eq in Ht' as [-> [= <-]]. 61 | split. 1:{ eexists _, _;split. reflexivity. intros. apply Hsymb. eauto. } 62 | destruct x;cbn in Hx,Hmarked;autorewrite with list in Hmarked,Hx;revert Hx. easy. 63 | all:intros [= <- H];revert H. 64 | 2:rewrite (app_comm_cons' _ _ (UnmarkedSymbol _)). 65 | all:rewrite ?app_comm_cons, <- !app_assoc_reverse. all:intros [H <-]%last_app_eq;revert H. 66 | all:intros H%(f_equal (fun l => length (filter (isMarked (sig:=sig)) l) )). 67 | all:repeat (autorewrite with list in Hmarked,H|-*;cbn in Hmarked,H|-* ). 68 | all:split;[ | now destruct t;[destruct init__R| ];cbn in *;try congruence;nia]. 69 | all:nia. 70 | Qed. 71 | 72 | Lemma invert_symbols_0_marked sig t: 73 | length (filter (@isMarked sig) t ) = 0 74 | -> (forall x, x el t -> isSymbol x = true) 75 | -> exists s : list sig, t = map UnmarkedSymbol s. 76 | Proof. 77 | induction t. now eexists []. 78 | cbn. intros H1 H2. destruct a eqn:H';cbn in *. 79 | 1,2,3:now specialize (H2 a);subst a;discriminate H2;eauto. 80 | -nia. 81 | -edestruct IHt as (?&->). 3:now eexists (_::_). all:eauto;easy. 82 | Qed. 83 | 84 | Lemma invert_symbols_1_marked sig t: 85 | length (filter (@isMarked sig) t ) = 1 86 | -> (forall x , x el t -> isSymbol x = true) 87 | -> exists s1 c (s2 : list sig), t = map UnmarkedSymbol s1 ++ (MarkedSymbol c :: map UnmarkedSymbol s2). 88 | Proof. 89 | induction t. now inversion 1. 90 | cbn. intros H1 H2. destruct a eqn:H';cbn in *. 91 | 1,2,3:now specialize (H2 a);subst a;discriminate H2;eauto. 92 | -edestruct @invert_symbols_0_marked with (t:=t) as (?&->). 1,2:eauto;easy. 93 | eexists [],_,_. reflexivity. 94 | -edestruct IHt as (?&?&?&->). 3:now eexists (_::_),_,_. all:eauto;easy. 95 | Qed. 96 | -------------------------------------------------------------------------------- /website/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /website/config.js: -------------------------------------------------------------------------------- 1 | var coqdocjs = coqdocjs || {}; 2 | 3 | coqdocjs.repl = { 4 | "fun": "λ", 5 | "forall": "∀", 6 | "exists": "∃", 7 | "~": "¬", 8 | "/\\": "∧", 9 | "\\/": "∨", 10 | "->": "→", 11 | "<-": "←", 12 | "<->": "↔", 13 | "=>": "⇒", 14 | "<>": "≠", 15 | "<=": "≤", 16 | ">=": "≥", 17 | "el": "∈", 18 | "nel": "∉", 19 | "<<=": "⊆", 20 | "<<": "⊂", 21 | "|-": "⊢", 22 | "++": "⧺", 23 | "===": "≡", 24 | "=/=": "≢", 25 | "=~=": "≅", 26 | "==>": "⟹", 27 | "lhd": "⊲", 28 | "rhd": "⊳", 29 | "nat": "ℕ", 30 | "alpha": "α", 31 | "beta": "β", 32 | "gamma": "γ", 33 | "delta": "δ", 34 | "epsilon": "ε", 35 | "eta": "η", 36 | "iota": "ι", 37 | "kappa": "κ", 38 | "lambda": "λ", 39 | "mu": "μ", 40 | "nu": "ν", 41 | "lia": "ω", 42 | "phi": "ϕ", 43 | "pi": "π", 44 | "psi": "ψ", 45 | "rho": "ρ", 46 | "sigma": "σ", 47 | "tau": "τ", 48 | "theta": "θ", 49 | "xi": "ξ", 50 | "zeta": "ζ", 51 | "Delta": "Δ", 52 | "Gamma": "Γ", 53 | "Pi": "Π", 54 | "Sigma": "Σ", 55 | "Lia": "Ω", 56 | "Xi": "Ξ" 57 | }; 58 | 59 | coqdocjs.subscr = { 60 | "0" : "₀", 61 | "1" : "₁", 62 | "2" : "₂", 63 | "3" : "₃", 64 | "4" : "₄", 65 | "5" : "₅", 66 | "6" : "₆", 67 | "7" : "₇", 68 | "8" : "₈", 69 | "9" : "₉", 70 | }; 71 | 72 | coqdocjs.replInText = ["==>","<=>", "=>", "->", "<-", ":="]; 73 | -------------------------------------------------------------------------------- /website/coqdoc.css: -------------------------------------------------------------------------------- 1 | body{ 2 | font-family: 'Open Sans', sans-serif; 3 | font-size: 14px; 4 | color: #2D2D2D 5 | } 6 | 7 | a { 8 | text-decoration: none; 9 | border-radius: 3px; 10 | padding-left: 3px; 11 | padding-right: 3px; 12 | margin-left: -3px; 13 | margin-right: -3px; 14 | color: inherit; 15 | font-weight: bold; 16 | } 17 | 18 | #main .code a, #main .inlinecode a, #toc a { 19 | font-weight: inherit; 20 | } 21 | 22 | a[href]:hover, [clickable]:hover{ 23 | background-color: rgba(0,0,0,0.1); 24 | cursor: pointer; 25 | } 26 | 27 | h, h1, h2, h3, h4, h5 { 28 | line-height: 1; 29 | color: black; 30 | text-rendering: optimizeLegibility; 31 | font-weight: normal; 32 | letter-spacing: 0.1em; 33 | text-align: left; 34 | } 35 | 36 | div + br { 37 | display: none; 38 | } 39 | 40 | div:empty{ display: none;} 41 | 42 | #main h1 { 43 | font-size: 2em; 44 | } 45 | 46 | #main h2 { 47 | font-size: 1.667rem; 48 | } 49 | 50 | #main h3 { 51 | font-size: 1.333em; 52 | } 53 | 54 | #main h4, #main h5, #main h6 { 55 | font-size: 1em; 56 | } 57 | 58 | #toc h2 { 59 | padding-bottom: 0; 60 | } 61 | 62 | #main .doc { 63 | margin: 0; 64 | text-align: justify; 65 | } 66 | 67 | .inlinecode, .code, #main pre { 68 | font-family: monospace; 69 | } 70 | 71 | .code > br:first-child { 72 | display: none; 73 | } 74 | 75 | .doc + .code{ 76 | margin-top:0.5em; 77 | } 78 | 79 | .block{ 80 | display: block; 81 | margin-top: 5px; 82 | margin-bottom: 5px; 83 | padding: 10px; 84 | text-align: center; 85 | } 86 | 87 | .block img{ 88 | margin: 15px; 89 | } 90 | 91 | table.infrule { 92 | border: 0px; 93 | margin-left: 50px; 94 | margin-top: 10px; 95 | margin-bottom: 10px; 96 | } 97 | 98 | td.infrule { 99 | font-family: monospace; 100 | text-align: center; 101 | padding: 0; 102 | line-height: 1; 103 | } 104 | 105 | tr.infrulemiddle hr { 106 | margin: 1px 0 1px 0; 107 | } 108 | 109 | .infrulenamecol { 110 | color: rgb(60%,60%,60%); 111 | padding-left: 1em; 112 | padding-bottom: 0.1em 113 | } 114 | 115 | .id[type="constructor"], 116 | .id[type="projection"], 117 | .id[type="method"], 118 | .id[type="inductive"], 119 | .id[type="definition"], 120 | .id[type="abbreviation"], 121 | .id[title="constructor"], 122 | .id[title="projection"], 123 | .id[title="method"], 124 | .id[title="inductive"], 125 | .id[title="definition"], 126 | .id[title="abbreviation"] { 127 | color : #2874AE; 128 | } 129 | 130 | .id[type="var"], .id[type="variable"], .id[type="notation"], 131 | .id[title="var"], .id[title="variable"], .id[title="notation"] { 132 | color: inherit; 133 | } 134 | 135 | .id[type="record"], .id[type="class"], .id[type="instance"], .id[type="library"], 136 | .id[title="record"], .id[title="class"], .id[title="instance"], .id[title="library"] { 137 | color: inherit; 138 | } 139 | 140 | .id[type="lemma"], 141 | .id[title="lemma"] { 142 | color: #A30E16; 143 | } 144 | 145 | .id[type="keyword"], 146 | .id[title="keyword"]{ 147 | color: #188B0C; 148 | } 149 | 150 | .comment { 151 | color: #808080; 152 | } 153 | 154 | /* TOC */ 155 | 156 | #toc h2{ 157 | letter-spacing: 0; 158 | font-size: 1.333em; 159 | } 160 | 161 | /* Index */ 162 | 163 | #index { 164 | margin: 0; 165 | padding: 0; 166 | width: 100%; 167 | } 168 | 169 | #index #frontispiece { 170 | margin: 1em auto; 171 | padding: 1em; 172 | width: 60%; 173 | } 174 | 175 | .booktitle { font-size : 140% } 176 | .authors { font-size : 90%; 177 | line-height: 115%; } 178 | .moreauthors { font-size : 60% } 179 | 180 | #index #entrance { 181 | text-align: center; 182 | } 183 | 184 | #index #entrance .spacer { 185 | margin: 0 30px 0 30px; 186 | } 187 | 188 | ul.doclist { 189 | margin-top: 0em; 190 | margin-bottom: 0em; 191 | } 192 | 193 | #toc > * { 194 | clear: both; 195 | } 196 | 197 | #toc > a { 198 | display: block; 199 | float: left; 200 | margin-top: 1em; 201 | } 202 | 203 | #toc a h2{ 204 | display: inline; 205 | } 206 | -------------------------------------------------------------------------------- /website/coqdocjs.css: -------------------------------------------------------------------------------- 1 | /* replace unicode */ 2 | 3 | .id[repl] .hidden { 4 | font-size: 0; 5 | } 6 | 7 | .id[repl]:before{ 8 | content: attr(repl); 9 | } 10 | 11 | /* folding proofs */ 12 | 13 | @keyframes show-proof { 14 | 0% { 15 | max-height: 1.2em; 16 | opacity: 1; 17 | } 18 | 99% { 19 | max-height: 1000em; 20 | } 21 | 100%{ 22 | } 23 | } 24 | 25 | @keyframes hide-proof { 26 | from { 27 | visibility: visible; 28 | max-height: 10em; 29 | opacity: 1; 30 | } 31 | to { 32 | max-height: 1.2em; 33 | } 34 | } 35 | 36 | .proof { 37 | cursor: pointer; 38 | } 39 | .proof * { 40 | cursor: pointer; 41 | } 42 | 43 | .proof { 44 | overflow: hidden; 45 | position: relative; 46 | transition: opacity 1s; 47 | display: inline-block; 48 | } 49 | 50 | .proof[show="false"] { 51 | max-height: 1.2em; 52 | visibility: visible; 53 | opacity: 0.3; 54 | } 55 | 56 | .proof[show="false"][animate] { 57 | animation-name: hide-proof; 58 | animation-duration: 0.25s; 59 | } 60 | 61 | .proof[show=true] { 62 | animation-name: show-proof; 63 | animation-duration: 10s; 64 | } 65 | 66 | .proof[show="false"]:before { 67 | position: absolute; 68 | visibility: visible; 69 | width: 100%; 70 | height: 100%; 71 | display: block; 72 | opacity: 0; 73 | content: "M"; 74 | } 75 | .proof[show="false"]:hover:before { 76 | content: ""; 77 | } 78 | 79 | .proof[show="false"] + br + br { 80 | display: none; 81 | } 82 | 83 | .proof[show="false"]:hover { 84 | visibility: visible; 85 | opacity: 0.5; 86 | } 87 | 88 | #toggle-proofs[proof-status="no-proofs"] { 89 | display: none; 90 | } 91 | 92 | #toggle-proofs[proof-status="some-hidden"]:before { 93 | content: "Show Proofs"; 94 | } 95 | 96 | #toggle-proofs[proof-status="all-shown"]:before { 97 | content: "Hide Proofs"; 98 | } 99 | 100 | 101 | /* page layout */ 102 | 103 | html, body { 104 | height: 100%; 105 | margin:0; 106 | padding:0; 107 | } 108 | 109 | body { 110 | display: flex; 111 | flex-direction: column 112 | } 113 | 114 | #content { 115 | flex: 1; 116 | overflow: auto; 117 | display: flex; 118 | flex-direction: column; 119 | } 120 | #content:focus { 121 | outline: none; /* prevent glow in OS X */ 122 | } 123 | 124 | #main { 125 | display: block; 126 | padding: 16px; 127 | padding-top: 1em; 128 | padding-bottom: 2em; 129 | margin-left: auto; 130 | margin-right: auto; 131 | max-width: 60em; 132 | flex: 1 0 auto; 133 | } 134 | 135 | .libtitle { 136 | display: none; 137 | } 138 | 139 | /* header */ 140 | #header { 141 | width:100%; 142 | padding: 0; 143 | margin: 0; 144 | display: flex; 145 | align-items: center; 146 | background-color: rgb(21,57,105); 147 | color: white; 148 | font-weight: bold; 149 | overflow: hidden; 150 | } 151 | 152 | 153 | .button { 154 | cursor: pointer; 155 | } 156 | 157 | #header * { 158 | text-decoration: none; 159 | vertical-align: middle; 160 | margin-left: 15px; 161 | margin-right: 15px; 162 | } 163 | 164 | #header > .right, #header > .left { 165 | display: flex; 166 | flex: 1; 167 | align-items: center; 168 | } 169 | #header > .left { 170 | text-align: left; 171 | } 172 | #header > .right { 173 | flex-direction: row-reverse; 174 | } 175 | 176 | #header a, #header .button { 177 | color: white; 178 | box-sizing: border-box; 179 | } 180 | 181 | #header a { 182 | border-radius: 0; 183 | padding: 0.2em; 184 | } 185 | 186 | #header .button { 187 | background-color: rgb(63, 103, 156); 188 | border-radius: 1em; 189 | padding-left: 0.5em; 190 | padding-right: 0.5em; 191 | margin: 0.2em; 192 | } 193 | 194 | #header a:hover, #header .button:hover { 195 | background-color: rgb(181, 213, 255); 196 | color: black; 197 | } 198 | 199 | #header h1 { padding: 0; 200 | margin: 0;} 201 | 202 | /* footer */ 203 | #footer { 204 | text-align: center; 205 | opacity: 0.5; 206 | font-size: 75%; 207 | } 208 | 209 | /* hyperlinks */ 210 | 211 | @keyframes highlight { 212 | 50%{ 213 | background-color: black; 214 | } 215 | } 216 | 217 | :target * { 218 | animation-name: highlight; 219 | animation-duration: 1s; 220 | } 221 | 222 | a[name]:empty { 223 | float: right; 224 | } 225 | -------------------------------------------------------------------------------- /website/resources/footer.html: -------------------------------------------------------------------------------- 1 | 2 | 5 | 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /website/resources/header.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 26 |
27 |
28 | --------------------------------------------------------------------------------