├── .github └── workflows │ └── docker-action.yml ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── _CoqProject ├── coq-hanoi.opam ├── extra.v ├── gdist.v ├── ghanoi.v ├── ghanoi3.v ├── ghanoi4.v ├── lhanoi3.v ├── meta.yml ├── phi.v ├── psi.v ├── rhanoi3.v ├── rhanoi4.v ├── shanoi.v ├── shanoi4.v ├── star.v └── triangular.v /.github/workflows/docker-action.yml: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | name: Docker CI 4 | 5 | on: 6 | push: 7 | branches: 8 | - master 9 | pull_request: 10 | branches: 11 | - '**' 12 | 13 | jobs: 14 | build: 15 | # the OS must be GNU/Linux to be able to use the docker-coq-action 16 | runs-on: ubuntu-latest 17 | strategy: 18 | matrix: 19 | image: 20 | - 'mathcomp/mathcomp:2.4.0-rocq-prover-9.0' 21 | fail-fast: false 22 | steps: 23 | - uses: actions/checkout@v4 24 | - uses: coq-community/docker-coq-action@v1 25 | with: 26 | opam_file: 'coq-hanoi.opam' 27 | custom_image: ${{ matrix.image }} 28 | 29 | 30 | # See also: 31 | # https://github.com/coq-community/docker-coq-action#readme 32 | # https://github.com/erikmd/docker-coq-github-action-demo 33 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.d 2 | *.vo 3 | *.vos 4 | *.vok 5 | *.glob 6 | *.aux 7 | .coq-native/ 8 | .csdp.cache 9 | .lia.cache 10 | .nia.cache 11 | .nlia.cache 12 | .nra.cache 13 | /Makefile.conf 14 | /Makefile.coq.conf 15 | /Makefile.coq 16 | *~ 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Yves Bertot 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ifeq "$(COQBIN)" "" 2 | COQBIN=$(dir $(shell which coqtop))/ 3 | endif 4 | 5 | %: Makefile.coq 6 | 7 | Makefile.coq: _CoqProject 8 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 9 | 10 | tests: all 11 | @$(MAKE) -C tests -s clean 12 | @$(MAKE) -C tests -s all 13 | 14 | -include Makefile.coq 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 5 | # hanoi 6 | 7 | [![Docker CI][docker-action-shield]][docker-action-link] 8 | 9 | [docker-action-shield]: https://github.com/thery/hanoi/actions/workflows/docker-action.yml/badge.svg?branch=master 10 | [docker-action-link]: https://github.com/thery/hanoi/actions/workflows/docker-action.yml 11 | 12 | 13 | 14 | 15 | Hanoi tower in Coq 16 | 17 | 18 | | File | Content | 19 | | --------------------------------- | -----------------------------------------| 20 | | [extra](./extra.v) | Extra theorems from the standard library | 21 | | [gdist](./gdist.v) | Distance in a graph | 22 | | [ghanoi](./ghanoi.v) | General Hanoi framework | 23 | | [ghanoi3](./ghanoi3.v) | General Hanoi framework with 3 pegs | 24 | | [lhanoi3](./lhanoi3.v) | Linear Hanoi tower with 3 pegs | 25 | | [rhanoi3](./rhanoi3.v) | Regular Hanoi tower with 3 pegs | 26 | | [triangular](./triangular.v) | Theorems about triangular numbers | 27 | | [phi](./phi.v) | Theorems about the Φ function | 28 | | [psi](./psi.v) | Theorems about the Ψ function | 29 | | [ghanoi4](./ghanoi4.v) | General Hanoi framework with 4 pegs | 30 | | [rhanoi4](./rhanoi4.v) | Regular Hanoi tower with 4 pegs | 31 | | [star](./star.v) | Some maths for the shanoi | 32 | | [shanoi](./shanoi.v) | Hanoi tower in star | 33 | | [shanoi4](./shanoi4.v) | Hanoi tower with 4 pegs in star | 34 | 35 | A note about this development is available 36 | [here](https://hal.inria.fr/hal-02903548). 37 | 38 | An interactive version of the library is available 39 | [here](https://thery.github.io/hanoi/index.html). 40 | 41 | ## Meta 42 | 43 | - Author(s): 44 | - Laurent Théry 45 | - License: [MIT License](LICENSE) 46 | - Compatible Coq versions: 9.0 or later 47 | - Additional dependencies: 48 | - [MathComp ssreflect 2.4 or later](https://math-comp.github.io) 49 | - [MathComp algebra 2.4 or later](https://math-comp.github.io) 50 | - [MathComp finmap 2.2.1 or later](https://github.com/math-comp/finmap) 51 | - Coq namespace: `hanoi` 52 | - Related publication(s): none 53 | 54 | ## Building and installation instructions 55 | 56 | To build and install manually, do: 57 | 58 | ``` shell 59 | git clone https://github.com/thery/hanoi.git 60 | cd hanoi 61 | make # or make -j 62 | make install 63 | ``` 64 | 65 | 66 | 67 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R . hanoi 2 | -arg -w -arg -notation-overridden 3 | 4 | extra.v 5 | gdist.v 6 | ghanoi.v 7 | ghanoi3.v 8 | ghanoi4.v 9 | lhanoi3.v 10 | rhanoi3.v 11 | triangular.v 12 | phi.v 13 | psi.v 14 | rhanoi4.v 15 | star.v 16 | shanoi.v 17 | shanoi4.v 18 | 19 | -------------------------------------------------------------------------------- /coq-hanoi.opam: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | 4 | opam-version: "2.0" 5 | maintainer: "thery@sophia.inria.fr" 6 | version: "dev" 7 | 8 | homepage: "https://github.com/thery/hanoi" 9 | dev-repo: "git+https://github.com/thery/hanoi.git" 10 | bug-reports: "https://github.com/thery/hanoi/issues" 11 | license: "MIT" 12 | 13 | synopsis: "Hanoi tower in Coq" 14 | description: """ 15 | Hanoi tower in Coq 16 | 17 | 18 | | File | Content | 19 | | --------------------------------- | -----------------------------------------| 20 | | [extra](./extra.v) | Extra theorems from the standard library | 21 | | [gdist](./gdist.v) | Distance in a graph | 22 | | [ghanoi](./ghanoi.v) | General Hanoi framework | 23 | | [ghanoi3](./ghanoi3.v) | General Hanoi framework with 3 pegs | 24 | | [lhanoi3](./lhanoi3.v) | Linear Hanoi tower with 3 pegs | 25 | | [rhanoi3](./rhanoi3.v) | Regular Hanoi tower with 3 pegs | 26 | | [triangular](./triangular.v) | Theorems about triangular numbers | 27 | | [phi](./phi.v) | Theorems about the Φ function | 28 | | [psi](./psi.v) | Theorems about the Ψ function | 29 | | [ghanoi4](./ghanoi4.v) | General Hanoi framework with 4 pegs | 30 | | [rhanoi4](./rhanoi4.v) | Regular Hanoi tower with 4 pegs | 31 | | [star](./star.v) | Some maths for the shanoi | 32 | | [shanoi](./shanoi.v) | Hanoi tower in star | 33 | | [shanoi4](./shanoi4.v) | Hanoi tower with 4 pegs in star | 34 | 35 | A note about this development is available 36 | [here](https://hal.inria.fr/hal-02903548). 37 | 38 | An interactive version of the library is available 39 | [here](https://thery.github.io/hanoi/index.html).""" 40 | 41 | build: [make "-j%{jobs}%"] 42 | install: [make "install"] 43 | depends: [ 44 | "coq" {(>= "9.0")} 45 | "coq-mathcomp-ssreflect" {(>= "2.4.0")} 46 | "coq-mathcomp-algebra" {(>= "2.4.0")} 47 | "coq-mathcomp-finmap" {(>= "2.2.1")} 48 | ] 49 | 50 | tags: [ 51 | "keyword:hanoi tower" 52 | "logpath:hanoi" 53 | ] 54 | authors: [ 55 | "Laurent Théry" 56 | ] 57 | -------------------------------------------------------------------------------- /extra.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* *) 3 | (* Extra theorems and definitions *) 4 | (* *) 5 | (******************************************************************************) 6 | 7 | From Stdlib Require Import ArithRing. 8 | From mathcomp Require Import all_ssreflect finmap. 9 | 10 | Set Implicit Arguments. 11 | Unset Strict Implicit. 12 | 13 | 14 | (******************************************************************************) 15 | (* *) 16 | (* Extra theorems about lists *) 17 | (* *) 18 | (******************************************************************************) 19 | 20 | 21 | Lemma rcons_injl (A : Type) (a: seq A) : injective (rcons a). 22 | Proof. by elim: a => /= [s1 s2 /= [] | b l IH s1 s2 [] /IH]. Qed. 23 | 24 | Lemma rcons_injr (A : Type) (a: A) : injective (rcons ^~a). 25 | Proof. 26 | elim => [ [|b [|c]] //= | b s1 IH /= [/= [] -> |c s2 [] -> /IH-> //]]. 27 | by case: (s1) => // [] []. 28 | Qed. 29 | 30 | Lemma cat_injl (A : Type) (a: seq A) : injective (cat a). 31 | Proof. by elim: a => // b l IH s1 s2 /= [] /IH. Qed. 32 | 33 | Lemma cat_injr (A : Type) (a: seq A) : injective (cat ^~a). 34 | Proof. 35 | elim: a => [s1 s2 |b l IH s1 s2]; first by rewrite !cats0. 36 | by rewrite -!cat_rcons => /IH; apply: rcons_injr. 37 | Qed. 38 | 39 | Lemma in_split (A : eqType) (a : A) l : 40 | a \in l -> exists l1, exists l2, l = l1 ++ a :: l2. 41 | Proof. 42 | elim: l => //= b l IH; rewrite inE => /orP[/eqP<-|aIl]. 43 | by exists [::]; exists l. 44 | case: (IH aIl) => l1 [l2 lE]. 45 | by exists (b :: l1); exists l2; rewrite /= lE. 46 | Qed. 47 | 48 | Lemma split_first (A : eqType) (l : seq A) (P : pred A) : 49 | ~~ all [predC P] l -> {bl1l2 : (A * seq A * seq A) | 50 | [/\ all [predC P] bl1l2.1.2, P bl1l2.1.1 & 51 | l = bl1l2.1.2 ++ bl1l2.1.1 :: bl1l2.2]}. 52 | Proof. 53 | elim: l => //= b l IH. 54 | rewrite negb_and negbK; case: (boolP (b \in P)) => 55 | [bIP _| bNIP /= /IH [[[c l1] l2] [H1 H2 ->]]]. 56 | by exists (b, [::], l); split. 57 | by exists (c, b :: l1, l2); split; rewrite /= ?bNIP. 58 | Qed. 59 | 60 | Lemma split_last (A : eqType) (l : seq A) (P : pred A) : 61 | ~~ all [predC P] l -> 62 | {bl1l2 | [/\ P bl1l2.1.1, all [predC P] bl1l2.2 & 63 | l = bl1l2.1.2 ++ bl1l2.1.1 :: bl1l2.2]}. 64 | Proof. 65 | move=> lA. 66 | case: (@split_first _ (rev l) P); first by rewrite all_rev. 67 | move=> [[b l1] l2] [H1 H2 H3]. 68 | exists (b, rev l2, rev l1); split => //; first by rewrite all_rev. 69 | by rewrite -{1}[l]revK H3 rev_cat /= rev_cons cat_rcons. 70 | Qed. 71 | 72 | Lemma split_head (A : eqType) (a b : A) l1 l2 l3 l4 : 73 | l1 ++ a :: l2 = l3 ++ b :: l4 -> 74 | [\/ [/\ l1 = l3, a = b & l2 = l4], 75 | exists l5, l3 = l1 ++ a :: l5 | 76 | exists l5, l1 = l3 ++ b :: l5]. 77 | Proof. 78 | elim: l1 l3 => /= [[[<- <-]|c l3 [<- ->]] /= | c l1 IH [[<- <-]|d l3 /= [<-]]]. 79 | - by apply: Or31. 80 | - by apply: Or32; exists l3. 81 | - by apply: Or33; exists l1. 82 | move=> /IH[[<- <- <-]|[l5 ->]|]. 83 | - by apply: Or31. 84 | - by apply: Or32; exists l5. 85 | by case=> l5 ->; apply: Or33; exists l5. 86 | Qed. 87 | 88 | Lemma split_tail (A : eqType) (a b : A) l1 l2 l3 l4 : 89 | l1 ++ a :: l2 = l3 ++ b :: l4 -> 90 | [\/ [/\ l1 = l3, a = b & l2 = l4], 91 | exists l5, l4 = l5 ++ a :: l2 | 92 | exists l5, l2 = l5 ++ b :: l4]. 93 | Proof. 94 | elim/last_ind : l2 l4 => [l4|l2 c IH l4]. 95 | case: (lastP l4) => /= [|l5 c]. 96 | rewrite !cats1 => /rcons_inj[<- <-]. 97 | by apply: Or31. 98 | rewrite cats1 -rcons_cons -rcons_cat => /rcons_inj[-> <-]. 99 | by apply: Or32; exists l5; rewrite cats1. 100 | case: (lastP l4) => /= [|l5 d]. 101 | rewrite cats1 -rcons_cons -rcons_cat => /rcons_inj[<- ->]. 102 | by apply: Or33; exists l2; rewrite cats1. 103 | rewrite -!rcons_cons -!rcons_cat => 104 | /rcons_inj[/IH [[<- <- <-]|[l6 ->]|[l6 ->]]] <-. 105 | - by apply: Or31. 106 | - by apply: Or32; exists l6; rewrite -rcons_cat. 107 | by apply: Or33; exists l6; rewrite -rcons_cat. 108 | Qed. 109 | 110 | (******************************************************************************) 111 | (* We develop a twisted version of split that fills 'I_{m + n} with *) 112 | (* first the element of 'I_n (x -> x) then the element of m (x -> x + n) *) 113 | (* This is mostly motivated to naturally get an element of 'I_n from 'I_n.+1 *) 114 | (* by removing max_ord *) 115 | (******************************************************************************) 116 | 117 | Lemma tlshift_subproof m n (i : 'I_m) : i + n < m + n. 118 | Proof. by rewrite ltn_add2r. Qed. 119 | Lemma trshift_subproof m n (i : 'I_n) : i < m + n. 120 | Proof. by apply: leq_trans (valP i) _; apply: leq_addl. Qed. 121 | 122 | Definition tlshift m n (i : 'I_m) := Ordinal (tlshift_subproof n i). 123 | Definition trshift m n (i : 'I_n) := Ordinal (trshift_subproof m i). 124 | 125 | Lemma tlshift_inj m n : injective (@tlshift m n). 126 | Proof. by move=> ? ? /(f_equal val) /addIn /val_inj. Qed. 127 | 128 | Lemma trshift_inj m n : injective (@trshift m n). 129 | Proof. by move=> ? ? /(f_equal val) /= /val_inj. Qed. 130 | 131 | Lemma trshift_lift n (i : 'I_ n) : trshift 1 i = lift ord_max i. 132 | Proof. by apply/val_eqP; rewrite /= /bump leqNgt ltn_ord. Qed. 133 | 134 | Lemma tsplit_subproof m n (i : 'I_(m + n)) : i >= n -> i - n < m. 135 | Proof. by move/subSn <-; rewrite leq_subLR [n + m]addnC. Qed. 136 | 137 | Definition tsplit {m n} (i : 'I_(m + n)) : 'I_m + 'I_n := 138 | match ltnP (i) n with 139 | | LtnNotGeq lt_i_n => inr _ (Ordinal lt_i_n) 140 | | GeqNotLtn ge_i_n => inl _ (Ordinal (tsplit_subproof ge_i_n)) 141 | end. 142 | 143 | Variant tsplit_spec m n (i : 'I_(m + n)) : 'I_m + 'I_n -> bool -> Type := 144 | | TSplitLo (j : 'I_n) of i = j :> nat : tsplit_spec i (inr _ j) true 145 | | TSplitHi (k : 'I_m) of i = k + n :> nat : tsplit_spec i (inl _ k) false. 146 | 147 | Lemma tsplitP m n (i : 'I_(m + n)) : tsplit_spec i (tsplit i) (i < n). 148 | Proof. 149 | set lt_i_n := i < n; rewrite /tsplit. 150 | by case: {-}_ lt_i_n / ltnP; [left |right; rewrite subnK]. 151 | Qed. 152 | 153 | Definition tunsplit {m n} (jk : 'I_m + 'I_n) := 154 | match jk with inl j => tlshift n j | inr k => trshift m k end. 155 | 156 | 157 | Lemma ltn_tunsplit m n (jk : 'I_m + 'I_n) : (n <= tunsplit jk) = jk. 158 | Proof. 159 | by case: jk => [j|k]; rewrite /= ?ltn_ord ?leq_addl // leqNgt ltn_ord. 160 | Qed. 161 | 162 | Lemma tsplitK {m n} : cancel (@tsplit m n) tunsplit. 163 | Proof. by move=> i; apply: val_inj; case: tsplitP. Qed. 164 | 165 | Lemma tunsplitK {m n} : cancel (@tunsplit m n) tsplit. 166 | Proof. 167 | move=> jk; have:= ltn_tunsplit jk; rewrite leqNgt. 168 | by do [case: tsplitP; case: jk => //= i j] => [|/addIn] => /ord_inj->. 169 | Qed. 170 | 171 | (******************************************************************************) 172 | (* *) 173 | (* Extra theorems about fset *) 174 | (* *) 175 | (******************************************************************************) 176 | 177 | Open Scope fset_scope. 178 | 179 | Definition sint a b : {fset nat} := 180 | [fset @nat_of_ord _ i | i in 'I_b & a <= i]. 181 | 182 | Lemma mem_sint a b i : i \in sint a b = (a <= i < b). 183 | Proof. 184 | apply/imfsetP/idP => [[j /= aLj ->]|/andP[aLi iLb]]. 185 | by rewrite ltn_ord andbT. 186 | by exists (Ordinal iLb). 187 | Qed. 188 | 189 | Lemma sint_sub a b c : a <= c -> 190 | [fset i in (sint a b) | c <= i] = sint c b. 191 | Proof. 192 | move=> aLc. 193 | apply/fsetP => i. 194 | rewrite mem_sint. 195 | apply/imfsetP/idP => [[j /=]|/andP[cLi iLb]]. 196 | rewrite inE mem_sint => /andP[/andP[aLj jLb] cLj] ->. 197 | by rewrite cLj. 198 | by exists i; rewrite //= inE mem_sint cLi iLb (leq_trans aLc). 199 | Qed. 200 | 201 | Lemma sintSl a b : sint a.+1 b = sint a b `\ a. 202 | Proof. 203 | apply/fsetP => /= i; rewrite !inE !mem_sint. 204 | by do 2 case: ltngtP. 205 | Qed. 206 | 207 | Lemma sintSr a b : sint a b.+1 `\ b = sint a b. 208 | Proof. 209 | apply/fsetP => /= i; rewrite !inE !mem_sint ltnS. 210 | by do 2 case: ltngtP. 211 | Qed. 212 | 213 | Lemma sint_split a b : sint a b = sint 0 b `\` sint 0 a. 214 | Proof. 215 | by apply/fsetP => /= i; rewrite !inE !mem_sint /= -leqNgt. 216 | Qed. 217 | 218 | Lemma card_sint a b : #|`sint a b| = (b - a). 219 | Proof. 220 | elim: b => [|b IH]. 221 | apply/eqP; rewrite cardfs_eq0; apply/eqP/fsetP=> i. 222 | by rewrite mem_sint andbF inE. 223 | have [aLb|bLa] := leqP a b; last first. 224 | rewrite (_ : _ - _ = 0); last first. 225 | by apply/eqP; rewrite subn_eq0. 226 | apply/eqP; rewrite cardfs_eq0; apply/eqP/fsetP=> i; rewrite mem_sint inE ltnS. 227 | by apply/idP => /andP[H1 /(leq_trans H1)]; rewrite leqNgt bLa. 228 | rewrite (cardfsD1 b) (_ : _ \in _); last by rewrite mem_sint aLb /=. 229 | by rewrite sintSr IH subSn. 230 | Qed. 231 | 232 | Notation "`[ n ]" := (sint 0 n) (format "`[ n ]"). 233 | 234 | Lemma sint0_set0 : `[0] = fset0. 235 | Proof. by apply/fsetP=> i; rewrite mem_sint inE; case: ltngtP. Qed. 236 | 237 | Definition s2f n (s : {set 'I_n}) := [fset nat_of_ord i | i in s]. 238 | 239 | Lemma mem_s2f n (s : {set 'I_n}) (i : 'I_n) : (i : nat) \in s2f s = (i \in s). 240 | Proof. 241 | apply/imfsetP/idP => /= [[j jIs iEj]|iIs]; last by exists i. 242 | by rewrite (_ : i = j) //; apply: val_inj. 243 | Qed. 244 | 245 | Lemma s2f_set0 n : s2f (set0 : {set 'I_n}) = fset0. 246 | Proof. 247 | apply/fsetP => i; rewrite inE. 248 | by apply/idP => /imfsetP[j /=]; rewrite inE. 249 | Qed. 250 | 251 | Lemma s2f_setT n : s2f (setT : {set 'I_n}) = sint 0 n. 252 | Proof. 253 | apply/fsetP => i; rewrite mem_sint /=. 254 | apply/imfsetP/idP => /= [[j _ -> //]| iLn]. 255 | by exists (Ordinal iLn); rewrite //= inE. 256 | Qed. 257 | 258 | Lemma s2fD n (s1 s2 : {set 'I_n}) : s2f (s1 :\: s2) = s2f s1 `\` s2f s2. 259 | Proof. 260 | apply/fsetP => j; rewrite !inE. 261 | apply/imfsetP/andP => /= [[k]|[jDi /imfsetP[/= k kIs jEk]]]. 262 | by rewrite !inE -!mem_s2f => /andP[kDi kIs] ->. 263 | by exists k => //; rewrite !inE kIs -mem_s2f -jEk jDi. 264 | Qed. 265 | 266 | Lemma s2fU n (s1 s2 : {set 'I_n}) : s2f (s1 :|: s2) = s2f s1 `|` s2f s2. 267 | Proof. 268 | apply/fsetP => j; rewrite !inE. 269 | apply/imfsetP/orP => /= [[k]|[] /imfsetP[/= k]]. 270 | - by rewrite !inE -!mem_s2f => /orP[] kIs ->; [left|right]. 271 | - by move => kIs1 ->; exists k; rewrite // inE kIs1. 272 | by move => kIs2 ->; exists k; rewrite // inE kIs2 orbT. 273 | Qed. 274 | 275 | Lemma s2fI n (s1 s2 : {set 'I_n}) : s2f (s1 :&: s2) = s2f s1 `&` s2f s2. 276 | Proof. 277 | apply/fsetP => j; rewrite !inE. 278 | apply/imfsetP/andP => /= [[k]|[jDi /imfsetP[/= k kIs jEk]]]. 279 | by rewrite !inE -!mem_s2f => /andP[kDi kIs] ->. 280 | by exists k => //; rewrite !inE kIs -mem_s2f -jEk jDi. 281 | Qed. 282 | 283 | Lemma s2f1 n (i : 'I_n) : s2f [set i] = [fset (nat_of_ord i)]. 284 | Proof. 285 | apply/fsetP => j; rewrite !inE. 286 | apply/imfsetP/eqP => /= [[k]|->]; first by rewrite inE => /eqP ->. 287 | by exists i; rewrite ?inE. 288 | Qed. 289 | 290 | Lemma s2f_pred n (s : {set 'I_n}) (P : pred nat) : 291 | s2f [set i in s | P i] = [fset i in (s2f s) | P i]. 292 | Proof. 293 | apply/fsetP=> i; rewrite !inE /=. 294 | apply/imfsetP/andP => /= [[j]|]. 295 | rewrite !inE => /andP[jIs jP] ->; split => //. 296 | by apply/imfsetP; exists j. 297 | move=> [/imfsetP[/= j jIs ->] jP]; exists j => //. 298 | by rewrite inE jIs. 299 | Qed. 300 | 301 | Lemma s2fD1 n (s : {set 'I_n}) i : s2f (s :\ i) = s2f s `\ (nat_of_ord i). 302 | Proof. by rewrite s2fD s2f1. Qed. 303 | 304 | Lemma card_s2f n (s : {set 'I_n}) : #|` s2f s| = #|s|. 305 | Proof. 306 | have [m sLm] := ubnP #|s|; elim: m => // m IH s sLm in s sLm *. 307 | case: (set_0Vmem s) => [->|[i iIs]]; first by rewrite s2f_set0 cards0. 308 | rewrite (cardsD1 i) iIs /= -IH //; last first. 309 | by move: sLm; rewrite (cardsD1 i) iIs. 310 | rewrite [LHS](cardfsD1 (nat_of_ord i)) (_ : _ \in _); last first. 311 | by rewrite mem_s2f. 312 | by rewrite s2fD1. 313 | Qed. 314 | 315 | (* initial section of an ordinal *) 316 | Definition isO n t := [set i | (i : 'I_n) < t]. 317 | 318 | Lemma isOE n t : t <= n -> s2f (isO n t) = sint 0 t. 319 | Proof. 320 | move=> tLn. 321 | apply/fsetP => i; rewrite mem_sint. 322 | apply/imfsetP/idP => /= [[j]|iLt]; first by rewrite inE => jLt ->. 323 | have iLn : i < n by apply: leq_trans tLn. 324 | by exists (Ordinal iLn); rewrite // inE. 325 | Qed. 326 | 327 | Lemma mem_isO n t i : (i \in isO n t) = (i < t). 328 | Proof. by rewrite inE. Qed. 329 | 330 | Lemma isOE_ge n t : n <= t -> isO n t = setT. 331 | Proof. 332 | by move=> nLt; apply/setP => í; rewrite !inE (leq_trans _ nLt). 333 | Qed. 334 | 335 | Lemma isOE_le n t : t < n.+1 -> isO n.+1 t = [set inord i | i : 'I_t]. 336 | Proof. 337 | move=> tLn; apply/setP=> i; rewrite !inE. 338 | apply/idP/imsetP => [iLt| [j _ ->]]. 339 | by exists (Ordinal iLt); rewrite //=; apply/val_eqP; rewrite /= inordK. 340 | by rewrite inordK // (leq_trans _ tLn) // ltnS // ltnW. 341 | Qed. 342 | 343 | Lemma card_isO n t : #|isO n t| = minn n t. 344 | Proof. 345 | apply/sym_equal. 346 | case: (leqP n t) => [nLt|tLn]. 347 | by rewrite isOE_ge //= cardsT card_ord. 348 | case: n tLn => // n tLn. 349 | rewrite isOE_le // card_imset // => [|i j /val_eqP/eqP /=]. 350 | by rewrite card_ord. 351 | by rewrite !inordK ?(leq_trans _ tLn) ?ltnS 1?ltnW // => /eqP/val_eqP. 352 | Qed. 353 | 354 | Lemma s2fD_isO n (s : {set 'I_n}) t : s2f (s :\: isO n t) = s2f s `\` sint 0 t. 355 | Proof. 356 | apply/fsetP => j; rewrite !inE. 357 | apply/imfsetP/andP => /= [[k]|[jDi /imfsetP[/= k kIs jEk]]]. 358 | by rewrite !inE -!mem_s2f mem_sint /= => /andP[kDi kIs] ->. 359 | move: jDi; rewrite mem_sint /= -leqNgt => jDi. 360 | by exists k; rewrite // !inE -leqNgt kIs -jEk jDi. 361 | Qed. 362 | 363 | (******************************************************************************) 364 | (* *) 365 | (* Specific theorems for shanoi *) 366 | (* *) 367 | (******************************************************************************) 368 | 369 | Open Scope nat_scope. 370 | 371 | Lemma codom_subC (A : finType) (B : finType) (f : {ffun A -> B}) 372 | (p1 p2 : B) : 373 | (codom f \subset [:: p1; p2]) = (codom f \subset [:: p2; p1]). 374 | Proof. 375 | by apply/subsetP/subsetP; move => sB i /sB; rewrite !inE orbC. 376 | Qed. 377 | 378 | Lemma inord_eq0 n k : k = 0 -> inord k = ord0 :> 'I_n.+1. 379 | Proof. by move=> -> /=; apply/val_eqP; rewrite /= inordK. Qed. 380 | 381 | Lemma mod3_0 a : (3 * a) %% 3 = 0. 382 | Proof. by rewrite modnMr. Qed. 383 | 384 | Lemma mod3_1 a : (3 * a).+1 %% 3 = 1. 385 | Proof. by rewrite mulnC -addn1 modnMDl. Qed. 386 | 387 | Lemma mod3_2 a : (3 * a).+2 %% 3 = 2. 388 | Proof. by rewrite mulnC -addn2 modnMDl. Qed. 389 | 390 | Definition mod3E := (mod3_0, mod3_1, mod3_2). 391 | 392 | Lemma div3_0 a : (3 * a) %/ 3 = a. 393 | Proof. by rewrite mulKn. Qed. 394 | 395 | Lemma div3_1 a : (3 * a).+1 %/ 3 = a. 396 | Proof. by rewrite mulnC -addn1 divnMDl // divn_small // addn0. Qed. 397 | 398 | Lemma div3_2 a : (3 * a).+2 %/ 3 = a. 399 | Proof. by rewrite mulnC -addn2 divnMDl // divn_small // addn0. Qed. 400 | 401 | Definition div3E := (div3_0, div3_1, div3_2). 402 | 403 | Lemma sum3E n (f : nat -> nat) : 404 | \sum_(i < 3 * n) f i = 405 | \sum_(i < n) (f (3 * i) + f (3 * i).+1 + f (3 * i).+2). 406 | Proof. 407 | elim: n => [|n IH]; first by rewrite !big_ord0. 408 | by rewrite mulnS !big_ord_recr /= IH !addnA. 409 | Qed. 410 | 411 | Lemma Ival_eq n (x y : 'I_n) : (x == y) = (val x == val y). 412 | Proof. by apply/eqP/val_eqP. Qed. 413 | 414 | Lemma oddS n : odd n.+1 = ~~ odd n. 415 | Proof. by []. Qed. 416 | 417 | Lemma even_halfMl k m : 418 | ~~ odd m -> (k * m)./2 = k * m./2. 419 | Proof. 420 | move=> mE. 421 | have := odd_double_half m; rewrite (negPf mE) add0n => {1}<-. 422 | by rewrite -doubleMr doubleK. 423 | Qed. 424 | 425 | Lemma even_halfMr k m : 426 | ~~ odd m -> (m * k)./2 = m./2 * k. 427 | Proof. 428 | move=> mE. 429 | have := odd_double_half m; rewrite (negPf mE) add0n => {1}<-. 430 | by rewrite -doubleMl doubleK. 431 | Qed. 432 | 433 | Lemma even_halfD m n : 434 | ~~ odd m -> ~~ odd n -> (m + n)./2 = (m./2 + n./2). 435 | Proof. 436 | move=> mE nE. 437 | have := odd_double_half m; rewrite (negPf mE) add0n => {1}<-. 438 | have := odd_double_half n; rewrite (negPf nE) add0n => {1}<-. 439 | by rewrite -doubleD doubleK. 440 | Qed. 441 | 442 | Lemma even_halfB m n : 443 | ~~ odd m -> ~~ odd n -> (m - n)./2 = m./2 - n./2. 444 | Proof. 445 | move=> mE nE. 446 | have := odd_double_half m; rewrite (negPf mE) add0n => {1}<-. 447 | have := odd_double_half n; rewrite (negPf nE) add0n => {1}<-. 448 | by rewrite -doubleB doubleK. 449 | Qed. 450 | 451 | Lemma leq_pred2 m n : m <= n -> m.-1 <= n.-1. 452 | Proof. by case: m; case: n => //=. Qed. 453 | 454 | Lemma subn_minr : left_distributive subn minn. 455 | Proof. 456 | move=> m n p; rewrite /minn; case: leqP => [nLm|mLn]. 457 | by rewrite ltnNge leq_sub2r. 458 | have [nLp|pLn] := leqP n p; last by rewrite ltn_sub2r. 459 | apply/eqP; move: (nLp); rewrite -subn_eq0 => /eqP->. 460 | by rewrite ltnNge //= subn_eq0 (leq_trans (ltnW mLn)). 461 | Qed. 462 | 463 | Lemma subn_maxr : left_distributive subn maxn. 464 | Proof. 465 | move=> m n p; rewrite /maxn; case: leqP => [nLm|mLn]. 466 | by rewrite ltnNge leq_sub2r. 467 | have [nLp|pLn] := leqP n p; last by rewrite ltn_sub2r. 468 | apply/eqP; move: (nLp); rewrite -subn_eq0 => /eqP->. 469 | by rewrite ltnNge //= eq_sym subn_eq0 (leq_trans (ltnW mLn)). 470 | Qed. 471 | 472 | Lemma leq_minn2r m n p : m <= n -> minn m p <= minn n p. 473 | Proof. 474 | move=> mLn; rewrite /minn. 475 | case: leqP => pLm; case: leqP => //. 476 | by rewrite ltnNge (leq_trans pLm). 477 | by move=> _; rewrite ltnW. 478 | Qed. 479 | 480 | Lemma leq_minn2l m n p : m <= n -> minn p m <= minn p n. 481 | Proof. 482 | move=> mLn; rewrite /minn. 483 | case: leqP => pLm; case: leqP => //. 484 | by move=> _; rewrite (leq_trans (ltnW pLm)). 485 | Qed. 486 | 487 | (******************************************************************************) 488 | (* Definiion of discrete convex and concave version *) 489 | (* it contains just what is needed for shanoi4 *) 490 | (******************************************************************************) 491 | 492 | Section Convex. 493 | 494 | Definition increasing (f : nat -> nat) := forall n, f n <= f n.+1. 495 | 496 | Definition decreasing (f : nat -> nat) := forall n, f n.+1 <= f n. 497 | 498 | Lemma increasing_ext f1 f2 : f1 =1 f2 -> increasing f1 -> increasing f2. 499 | Proof. by move=> fE fI i; rewrite -!fE. Qed. 500 | 501 | Lemma increasingE f m n : increasing f -> m <= n -> f m <= f n. 502 | Proof. 503 | move=> fI mLn; rewrite -(subnK mLn). 504 | elim: (_ - _) => //= d fL. 505 | by apply: leq_trans (fI (d + m)). 506 | Qed. 507 | 508 | Lemma decreasingE f m n : decreasing f -> m <= n -> f n <= f m. 509 | Proof. 510 | move=> fI mLn; rewrite -(subnK mLn). 511 | elim: (_ - _) => //= d fL. 512 | by apply: leq_trans (fI _) fL. 513 | Qed. 514 | 515 | Definition delta (f : nat -> nat) n := f n.+1 - f n. 516 | 517 | Lemma delta_ext f1 f2 : f1 =1 f2 -> delta f1 =1 delta f2. 518 | Proof. by move=> fE i; rewrite /delta !fE. Qed. 519 | 520 | Definition fnorm (f : nat -> nat) n := f n - f 0. 521 | 522 | Lemma increasing_fnorm f : increasing f -> increasing (fnorm f). 523 | Proof. by move=> fI n; rewrite leq_sub2r. Qed. 524 | 525 | Lemma delta_fnorm f n : increasing f -> delta (fnorm f) n = delta f n. 526 | Proof. 527 | by move=> fI; rewrite /delta /fnorm -subnDA addnC subnK // increasingE. 528 | Qed. 529 | 530 | Lemma sum_delta f n : 531 | increasing f -> fnorm f n = \sum_(i < n) delta (fnorm f) i. 532 | Proof. 533 | move=> iF. 534 | elim: n => [|n IH]; first by rewrite [LHS]subnn big_ord0. 535 | by rewrite big_ord_recr /= -IH addnC subnK // increasing_fnorm. 536 | Qed. 537 | 538 | (* we restrict this to increasing function because of the behavior -*) 539 | Definition convex f := 540 | increasing f /\ increasing (delta f). 541 | 542 | (* we restrict this to increasing function because of the behavior -*) 543 | Definition concave f := 544 | increasing f /\ decreasing (delta f). 545 | 546 | Lemma concaveE f : 547 | increasing f -> (forall i, f i + f i.+2 <= (f i.+1).*2) -> concave f. 548 | Proof. 549 | move=> fI fH; split => // i. 550 | rewrite /delta. 551 | rewrite -(leq_add2r (f i.+1 + f i)) addnA subnK // addnCA subnK //. 552 | by rewrite addnn addnC. 553 | Qed. 554 | 555 | Lemma concaveEk f i k : 556 | concave f -> k <= i -> f (i - k) + f (i + k) <= (f i).*2. 557 | Proof. 558 | move=> [fI dfD]. 559 | elim: k => /= [kLi|k IH kLi]; first by rewrite subn0 addn0 addnn. 560 | have H : i - k.+1 <= i + k. 561 | by apply: leq_trans (leq_subr _ _) (leq_addr _ _). 562 | have fk1Lfk : f (i - k.+1) <= f (i - k). 563 | by apply/(increasingE fI)/leq_sub2l. 564 | have := leq_add (decreasingE dfD H) (IH (ltnW kLi)). 565 | rewrite /delta [f (i - k) + _]addnC addnA subnK ?fU // addnC. 566 | rewrite -subSn // subSS addnBAC // leq_subRL. 567 | by rewrite addnCA leq_add2l addnS. 568 | by apply: leq_trans fk1Lfk (leq_addr _ _). 569 | Qed. 570 | 571 | Lemma concaveEk1 (f : nat -> nat) (i k1 k2 : nat) : 572 | concave f -> f (i + k1 + k2) + f i <= f (i + k2) + f (i + k1). 573 | Proof. 574 | move=> fC; have [fI dfD] := fC. 575 | elim: k2 k1 i => [k1 i|k2 IHH k1 i]; first by rewrite !addn0 addnC. 576 | rewrite !addnS -(subnK (fI _)) -[X in _ <= X + _](subnK (fI _)). 577 | rewrite -addnA -[X in _ <= X]addnA leq_add //. 578 | by apply: (decreasingE dfD); rewrite addnAC leq_addr. 579 | Qed. 580 | 581 | Lemma convexE f : 582 | increasing f -> (forall i, (f i.+1).*2 <= f i + f i.+2) -> convex f. 583 | Proof. 584 | move=> fI fH; split => // i. 585 | rewrite /delta. 586 | rewrite -(leq_add2r (f i.+1 + f i)) [_ + f i]addnC addnA subnK //. 587 | by rewrite addnn [f i + _]addnC addnA subnK // addnC. 588 | Qed. 589 | 590 | Lemma convexEk f i k : 591 | convex f -> k <= i -> (f i).*2 <= f (i - k) + f (i + k). 592 | Proof. 593 | move=> [fI dfI]. 594 | elim: k => /= [kLi|k IH kLi]; first by rewrite subn0 addn0 addnn. 595 | have H : i - k.+1 <= i + k. 596 | by apply: leq_trans (leq_subr _ _) (leq_addr _ _). 597 | have fk1Lfk : f (i - k.+1) <= f (i - k). 598 | by apply/(increasingE fI)/leq_sub2l. 599 | have := leq_add (increasingE dfI H) (IH (ltnW kLi)). 600 | rewrite /delta [f (i - k) + _]addnC addnA subnK ?fU // addnC. 601 | by rewrite -subSn // subSS addnS addnBA // leq_subLR addnA leq_add2r. 602 | Qed. 603 | 604 | (* Ad-hoc bigmin operator *) 605 | 606 | Fixpoint bigmin f n := 607 | if n is n1.+1 then minn (f n) (bigmin f n1) 608 | else f 0. 609 | 610 | Notation "\min_ ( i <= n ) F" := (bigmin (fun i => F) n) 611 | (at level 41, F at level 41, i, n at level 50, 612 | format "\min_ ( i <= n ) F"). 613 | 614 | Lemma bigmin_constD f n k : 615 | \min_(i <= n) (f i + k) = (\min_(i <= n) f i) + k. 616 | Proof. by elim: n => //= n ->; rewrite addn_minl. Qed. 617 | 618 | Lemma bigmin_constB f n k : 619 | \min_(i <= n) (f i - k) = (\min_(i <= n) f i) - k. 620 | Proof. by elim: n => //= n ->; rewrite subn_minr. Qed. 621 | 622 | Lemma eq_bigmin f n : {i0 : 'I_n.+1 | \min_(i <= n) f i = f i0}. 623 | Proof. 624 | elim: n => /= [|n [i ->]]; first by exists ord0. 625 | rewrite /minn; case: leqP => H. 626 | by exists (inord i); rewrite inordK // (leq_trans (ltn_ord i)). 627 | by exists ord_max. 628 | Qed. 629 | 630 | Lemma bigmin_leqP f n m : 631 | reflect (forall i, i <= n -> m <= f i) 632 | (m <= \min_(i <= n) f i). 633 | Proof. 634 | elim: n => /= [|n IH]. 635 | by apply: (iffP idP) => [mLf0 [|i] //|->]. 636 | apply: (iffP idP) => [|H]. 637 | rewrite leq_min => /andP[mLf mLmin] i. 638 | case: ltngtP => // [iLn _|-> _ //]. 639 | by rewrite ltnS in iLn; move: i iLn; apply/IH. 640 | rewrite leq_min H //=. 641 | by apply/IH => i iLn; rewrite H // (leq_trans iLn). 642 | Qed. 643 | 644 | Lemma bigmin_inf f n i0 m : 645 | i0 <= n -> f i0 <= m -> \min_(i <= n) f i <= m. 646 | Proof. 647 | move=> i0Ln fi0Lm; apply: leq_trans fi0Lm. 648 | elim: n i0Ln => /= [|n IH]; first by case: i0. 649 | by case: ltngtP => // [i0Ln _| -> _]; rewrite geq_min ?leqnn ?IH ?orbT. 650 | Qed. 651 | 652 | Lemma bigmin_fnorm f n : \min_(i <= n) fnorm f i = fnorm (bigmin f) n. 653 | Proof. by elim: n => //= n ->; rewrite -subn_minr. Qed. 654 | 655 | Lemma bigmin_ext f1 f2 n : 656 | (forall i, i <= n -> f1 i = f2 i) -> \min_(i <= n) f1 i = \min_(i <= n) f2 i. 657 | Proof. 658 | elim: n => /= [->//|n IH H]. 659 | by rewrite H // IH // => i iH; rewrite H // (leq_trans iH). 660 | Qed. 661 | 662 | Lemma bigminMr f n k : 663 | \min_(i <= n) (f i * k) = (\min_(i <= n) f i) * k. 664 | Proof. by elim: n => //= n ->; rewrite minnMl. Qed. 665 | 666 | (* Convolution *) 667 | 668 | Definition conv (f g : nat -> nat) n := 669 | \min_(i <= n) (f i + g (n - i)). 670 | 671 | Lemma conv0 f g : conv f g 0 = f 0 + g 0. 672 | Proof. by []. Qed. 673 | 674 | Lemma conv1 f g : 675 | conv f g 1 = minn (f 1 + g 0) (f 0 + g 1). 676 | Proof. by []. Qed. 677 | 678 | Lemma conv_fnorm f g : 679 | increasing f -> increasing g -> 680 | conv (fnorm f) (fnorm g) =1 fnorm (conv f g). 681 | Proof. 682 | move=> fI gI i. 683 | rewrite /fnorm /conv /= -bigmin_constB subnn. 684 | apply: bigmin_ext => j. 685 | by rewrite addnBA ?increasingE // addnBAC ?increasingE // subnDA. 686 | Qed. 687 | 688 | Lemma conv_ext f1 g1 f2 g2 : f1 =1 f2 -> g1 =1 g2 -> conv f1 g1 =1 conv f2 g2. 689 | Proof. by move=> fE gE i; apply: bigmin_ext => j; rewrite fE gE. Qed. 690 | 691 | Lemma convC f g : conv f g =1 conv g f. 692 | Proof. 693 | move=> n; apply/eqP; rewrite /conv eqn_leq; apply/andP; split. 694 | apply/bigmin_leqP => i iLn. 695 | rewrite -{1}(subKn iLn) addnC. 696 | by apply: bigmin_inf (leq_subr _ _) (leqnn _). 697 | apply/bigmin_leqP => i iLn. 698 | rewrite -{1}(subKn iLn) addnC. 699 | by apply: bigmin_inf (leq_subr _ _) (leqnn _). 700 | Qed. 701 | 702 | Lemma increasing_conv f g : 703 | increasing f -> increasing g -> increasing (conv f g). 704 | Proof. 705 | move=> fI gI i. 706 | apply/bigmin_leqP => j. 707 | case: ltngtP => // [jLi | ->] _. 708 | by apply: bigmin_inf (_ : j <= i) _; rewrite // leq_add2l subSn. 709 | rewrite subnn. 710 | by apply: bigmin_inf (leqnn i) _; rewrite subnn leq_add2r. 711 | Qed. 712 | 713 | (* merging increasing functions *) 714 | 715 | Fixpoint fmerge_aux (f g : nat -> nat) i j n := 716 | if n is n1.+1 then 717 | if f i < g j then fmerge_aux f g i.+1 j n1 718 | else fmerge_aux f g i j.+1 n1 719 | else minn (f i) (g j). 720 | 721 | Definition fmerge f g n := fmerge_aux f g 0 0 n. 722 | 723 | Lemma fmerge_aux_ext f1 f2 g1 g2 i j : f1 =1 f2 -> g1 =1 g2 -> 724 | fmerge_aux f1 g1 i j =1 fmerge_aux f2 g2 i j. 725 | Proof. 726 | move=> fE gE n; elim: n i j => /= [i1 j1|n IH i j]; first by rewrite fE gE. 727 | by rewrite !(fE, gE, IH). 728 | Qed. 729 | 730 | Lemma fmerge_ext f1 f2 g1 g2 : f1 =1 f2 -> g1 =1 g2 -> 731 | fmerge f1 g1 =1 fmerge f2 g2. 732 | Proof. by move=> fE gE n; apply: fmerge_aux_ext. Qed. 733 | 734 | Lemma fmerge_aux_correct f g i j n : 735 | increasing f -> increasing g -> 736 | (forall k, k <= n -> 737 | minn (f (i + k)) (g (j + (n - k))) <= 738 | fmerge_aux f g i j n). 739 | Proof. 740 | move=> fI gI. 741 | elim: n i j => /= [i j [|] // _|n IH i j k kLn]. 742 | by rewrite !addn0. 743 | case: leqP => [gLf|fLg]. 744 | move: kLn; rewrite leq_eqVlt => /orP[/eqP->|kLn]. 745 | rewrite subnn addn0 (minn_idPr _); last first. 746 | by rewrite (leq_trans gLf) // increasingE // leq_addr. 747 | apply: leq_trans (IH _ _ _ (leqnn _)). 748 | rewrite subnn addn0 leq_min increasingE // andbT (leq_trans gLf) //. 749 | by rewrite increasingE // leq_addr. 750 | by rewrite subSn // -addSnnS IH. 751 | case: k kLn => [_ | k kLn]. 752 | rewrite addn0 subn0 (minn_idPl _); last first. 753 | by rewrite (leq_trans (ltnW fLg)) // increasingE // leq_addr. 754 | apply: leq_trans (IH i.+1 j 0 isT). 755 | rewrite addn0 leq_min increasingE //= (leq_trans (ltnW fLg)) //. 756 | by rewrite increasingE // leq_addr. 757 | by rewrite subSS -addSnnS IH. 758 | Qed. 759 | 760 | Lemma fmerge_aux_exist f g i j n : 761 | exists2 k, k <= n & fmerge_aux f g i j n = minn (f (i + k)) (g (j + (n - k))). 762 | Proof. 763 | elim: n i j => /= [i j | n IH i j]; first by exists 0; rewrite //= !addn0. 764 | case: (leqP (g j) (f i)) => [gLf|fLg]; last first. 765 | by case: (IH i.+1 j) => k kLn ->; exists k.+1; rewrite // addnS subSS. 766 | case: (IH i j.+1) => [] [|k] kLn ->. 767 | by exists 0; rewrite // addn0 !subn0 addnS. 768 | by exists k.+1; rewrite ?(leq_trans kLn) // addSnnS -subSn. 769 | Qed. 770 | 771 | Lemma fmergeE (f g : nat -> nat) n : 772 | increasing f -> increasing g -> 773 | fmerge f g n = \max_(i < n.+1) minn (f i) (g (n - i)). 774 | Proof. 775 | move=> fI gI. 776 | apply/eqP; rewrite /fmerge eqn_leq; apply/andP; split. 777 | case: (@fmerge_aux_exist f g 0 0 n) => // i1 i1Ln ->. 778 | by apply: (@leq_bigmax_cond _ _ _ (Ordinal (i1Ln : i1 < n.+1))). 779 | apply/bigmax_leqP => /= i _. 780 | by apply: fmerge_aux_correct; rewrite -1?ltnS. 781 | Qed. 782 | 783 | Lemma increasing_fmerge f g : 784 | increasing f -> increasing g -> increasing (fmerge f g). 785 | Proof. 786 | move=> fI gI n; rewrite !fmergeE //. 787 | apply/bigmax_leqP => /= i _. 788 | apply: leq_trans (leq_bigmax_cond _ (isT : xpredT (inord i : 'I_n.+2))). 789 | rewrite inordK ?(leq_trans (ltn_ord _)) //. 790 | rewrite leq_min geq_minl /= (leq_trans (geq_minr _ _)) //. 791 | apply: increasingE gI _. 792 | by rewrite leq_sub2r. 793 | Qed. 794 | 795 | Lemma fmerge0 f g : fmerge f g 0 = minn (f 0) (g 0). 796 | Proof. by []. Qed. 797 | 798 | Fixpoint sum_fmerge_aux (f g : nat -> nat) i j n := 799 | if n is n1.+1 then 800 | if f i < g j then f i + sum_fmerge_aux f g i.+1 j n1 801 | else g j + sum_fmerge_aux f g i j.+1 n1 802 | else minn (f i) (g j). 803 | 804 | Definition sum_fmerge f g n := sum_fmerge_aux f g 0 0 n. 805 | 806 | Lemma sum_fmerge_aux_correct f g n i j : 807 | sum_fmerge_aux f g i j n = \sum_(k < n.+1) fmerge_aux f g i j k. 808 | Proof. 809 | elim: n i j => //= [i j|n IH i j]; first by rewrite big_ord_recr big_ord0. 810 | by rewrite big_ord_recl /= /minn; case: leqP; rewrite IH. 811 | Qed. 812 | 813 | Lemma sum_fmerge_correct f g n : 814 | sum_fmerge f g n = \sum_(k < n.+1) fmerge f g k. 815 | Proof. by apply: sum_fmerge_aux_correct. Qed. 816 | 817 | Lemma sum_fmerge_aux_conv_correct f g i j n : 818 | increasing f -> increasing g -> 819 | (forall k, k <= n.+1 -> 820 | sum_fmerge_aux f g i j n <= 821 | \sum_(l < k) f (i + l) + \sum_(l < n.+1 - k) g (j + l)). 822 | Proof. 823 | move=> fI gI. 824 | elim: n i j => /= [i j [_|[_|]]//|n IH i j k kLn]. 825 | - by rewrite big_ord_recr !big_ord0 /= !addn0 !add0n geq_minr. 826 | - by rewrite big_ord_recr !big_ord0 /= !addn0 !add0n geq_minl. 827 | case: leqP => [gLf|fLg]. 828 | move: kLn; case: ltngtP => // [kLn _ |-> _]; last first. 829 | rewrite subnn big_ord0 addn0 big_ord_recl addn0 /=. 830 | apply: leq_add => //. 831 | rewrite /bump /=. 832 | apply: leq_trans (IH _ _ _ (leqnn _)) _. 833 | rewrite subnn big_ord0 addn0 leq_sum // => l _. 834 | by apply: increasingE; rewrite // addnCA leq_addl. 835 | rewrite subSn // big_ord_recl addn0 addnCA leq_add2l. 836 | apply: leq_trans (IH _ _ _ (kLn : k <= n.+1)) _. 837 | rewrite leq_add2l leq_sum // => l _. 838 | by rewrite increasingE //= /bump addnCA add1n. 839 | move: kLn; case: ltngtP => // [kLn _ |-> _]; last first. 840 | rewrite subnn big_ord0 addn0 big_ord_recl addn0 /= leq_add2l /bump /=. 841 | apply: leq_trans (IH _ _ _ (leqnn _)) _. 842 | rewrite subnn big_ord0 addn0 leq_sum // => l _. 843 | by rewrite increasingE // addnCA add1n. 844 | case: k kLn => [_|k kLn]; last first. 845 | rewrite subSS. 846 | apply: leq_trans (leq_add (leqnn _) (IH i.+1 j k _)) _ . 847 | by rewrite -ltnS ltnW. 848 | rewrite addnA leq_add2r big_ord_recl addn0 leq_add2l leq_sum // => l _. 849 | by rewrite addnCA. 850 | rewrite big_ord0 add0n subn0. 851 | apply: leq_trans (leq_add (leqnn _) (IH i.+1 j 0 isT)) _ . 852 | rewrite big_ord0 add0n subn0 [X in _ <= X]big_ord_recr addnC leq_add //. 853 | apply: leq_trans (ltnW fLg) _. 854 | by rewrite increasingE // leq_addr. 855 | Qed. 856 | 857 | Lemma leq_sum_fmerge_conv f g k n : 858 | increasing f -> increasing g -> k <= n -> 859 | \sum_(i < n) fmerge f g i <= \sum_(i < k) f i + \sum_(i < n - k) g i. 860 | Proof. 861 | move=> fI gI; case: n => [|n kLn]. 862 | by case: k; rewrite // !big_ord0. 863 | rewrite -sum_fmerge_correct. 864 | exact: (sum_fmerge_aux_conv_correct 0 0 fI gI kLn). 865 | Qed. 866 | 867 | Lemma sum_fmerge_aux_exist f g i j n : 868 | exists2 k, k <= n.+1 & 869 | sum_fmerge_aux f g i j n = 870 | \sum_(l < k) f (i + l) + \sum_(l < n.+1 - k) g (j + l). 871 | Proof. 872 | elim: n i j => /= [i j | n IH i j]. 873 | rewrite /minn; case: leqP => [gLf|fLg]. 874 | by exists 0; rewrite // big_ord_recl !big_ord0 !(add0n, addn0). 875 | by exists 1; rewrite // subnn big_ord_recl !big_ord0 !(add0n, addn0). 876 | case: (leqP (g j) (f i)) => [gLf|fLg]. 877 | case: (IH i j.+1) => k kLn ->. 878 | exists k; first by apply: leq_trans kLn _. 879 | rewrite (subSn kLn) big_ord_recl addn0 addnCA. 880 | by congr (_ + (_ + _)); apply: eq_bigr => l _; rewrite addnCA. 881 | case: (IH i.+1 j) => k kLn ->; exists k.+1; first by apply: leq_trans kLn _. 882 | rewrite big_ord_recl addn0 subSS -addnA. 883 | by congr (_ + (_ + _)); apply: eq_bigr => l _; rewrite addnCA. 884 | Qed. 885 | 886 | Lemma sum_fmerge_exist f g n : 887 | exists2 k, k <= n & 888 | \sum_(i < n) fmerge f g i = \sum_(i < k) f i + \sum_(i < n - k) g i. 889 | Proof. 890 | case: n => [|n]; first by exists 0; rewrite // !big_ord0. 891 | case: (sum_fmerge_aux_exist f g 0 0 n) => k kLn sE. 892 | by exists k; rewrite // -sum_fmerge_correct [LHS]sE. 893 | Qed. 894 | 895 | Lemma sum_fmerge_conv f g n : 896 | increasing f -> increasing g -> 897 | \sum_(i < n) (fmerge f g) i = 898 | conv (fun n => \sum_(i < n) f i) (fun n => \sum_(i < n) g i) n. 899 | Proof. 900 | move=> fI gI. 901 | apply/eqP; rewrite eqn_leq; apply/andP; split; last first. 902 | case: (sum_fmerge_exist f g n) => k kLn ->. 903 | by apply: (bigmin_inf _ (leqnn _)). 904 | apply/bigmin_leqP => k kLn. 905 | by apply: leq_sum_fmerge_conv. 906 | Qed. 907 | 908 | (* This is 3.2 *) 909 | Lemma delta_conv f g : 910 | convex f -> convex g -> delta (conv f g) =1 fmerge (delta f) (delta g). 911 | Proof. 912 | move=> [fI dfI] [gI dgI] n. 913 | rewrite -delta_fnorm; last by apply: increasing_conv. 914 | rewrite -(delta_ext (conv_fnorm _ _)) //. 915 | have/delta_ext-> : conv (fnorm f) (fnorm g) =1 916 | conv (fun n => \sum_(i < n) (delta (fnorm f)) i) 917 | (fun n => \sum_(i < n) (delta (fnorm g)) i). 918 | by apply: conv_ext => i; apply: sum_delta. 919 | have/delta_ext-> : 920 | (conv (fun n : nat => \sum_(i < n) delta (fnorm f) i) 921 | (fun n : nat => \sum_(i < n) delta (fnorm g) i)) =1 922 | (fun n => \sum_(i < n) (fmerge (delta (fnorm f)) (delta (fnorm g))) i). 923 | move=> k; rewrite -sum_fmerge_conv //. 924 | by apply: increasing_ext dfI => i; rewrite delta_fnorm. 925 | by apply: increasing_ext dgI => i; rewrite delta_fnorm. 926 | rewrite /delta big_ord_recr /= addnC addnK. 927 | by apply: fmerge_aux_ext => i; apply: delta_fnorm. 928 | Qed. 929 | 930 | Lemma convex_conv f g : convex f -> convex g -> convex (conv f g). 931 | Proof. 932 | move=> [fI dfI] [gI dgI]; split; first by apply: increasing_conv. 933 | apply: increasing_ext => [i|]; first by apply/sym_equal/delta_conv. 934 | by apply: increasing_fmerge. 935 | Qed. 936 | 937 | End Convex. 938 | 939 | Notation "\min_ ( i <= n ) F" := (bigmin (fun i => F) n) 940 | (at level 41, F at level 41, i, n at level 50, 941 | format "\min_ ( i <= n ) F"). 942 | 943 | 944 | (* Mimic AC match for leq_trans *) 945 | Ltac is_num term := 946 | match term with 947 | | 0 => true 948 | | S ?X => is_num X 949 | | _ => false 950 | end. 951 | 952 | Ltac split_term term := 953 | match term with 954 | | ?X * ?Y => match is_num X with true => constr:((X, Y)) 955 | | false => 956 | let v := once (split_term X) in constr:((fst v, snd v * Y)) 957 | end 958 | | ?X => match is_num X with true => constr:((X, 1)) 959 | | _ => constr:((1, X)) end 960 | | _ => false 961 | end. 962 | 963 | 964 | Ltac delta_term n1 n2 t2 := 965 | let n := constr:(n1 - n2) in 966 | let n1 := eval compute in n in 967 | let vt2 := eval lazy delta [fst snd] iota beta in t2 in 968 | let r := 969 | match n1 with 970 | | 0 => constr:(0) 971 | | 1 => constr:(t2) 972 | | ?X => 973 | match vt2 with | 1 => X | _ => constr:(X * vt2) end 974 | end in 975 | eval lazy delta [fst snd] iota beta in r. 976 | 977 | Ltac delta_lterm2 n1 t1 lt2 := 978 | match lt2 with 979 | | ?X2 + ?Y2 => 980 | let v2 := split_term Y2 in 981 | let n2 := constr:(fst v2) in 982 | let t2 := constr:(snd v2) in 983 | let t := constr:((t1, t2)) in 984 | let vt := eval lazy delta [fst snd] iota beta in t in 985 | match vt with 986 | | (?X, ?X) => delta_term n1 n2 t2 987 | | _ => delta_lterm2 n1 t1 X2 988 | end 989 | | ?Y2 => 990 | let v2 := split_term Y2 in 991 | let n2 := constr:(fst v2) in 992 | let t2 := constr:(snd v2) in 993 | let t := constr:((t1, t2)) in 994 | let vt := eval lazy delta [fst snd] iota beta in t in 995 | match vt with 996 | | (?X, ?X) => delta_term n1 n2 t2 997 | | _ => delta_term n1 0 t1 998 | end 999 | end. 1000 | 1001 | Ltac make_sum t1 t2 := 1002 | match t1 with 0 => t2 | _ => 1003 | match t2 with 0 => t1 | _ => constr:(t1 + t2) end end. 1004 | 1005 | Ltac delta_lterm1 lt1 lt2 := 1006 | match lt1 with 1007 | | ?X1 + ?Y1 => 1008 | let v1 := split_term Y1 in 1009 | let n1 := constr:(fst v1) in 1010 | let t1 := constr:(snd v1) in 1011 | let r1 := delta_lterm1 X1 lt2 in 1012 | let r2 := delta_lterm2 n1 t1 lt2 in make_sum r1 r2 1013 | 1014 | | ?Y1 => 1015 | let v1 := split_term Y1 in 1016 | let n1 := constr:(fst v1) in 1017 | let t1 := constr:(snd v1) in delta_lterm2 n1 t1 lt2 1018 | end. 1019 | 1020 | Ltac test t1 t2 := let xx := delta_lterm1 t1 t2 in pose kk := xx. 1021 | 1022 | 1023 | Ltac ring_preprocess := rewrite -?mul2n -?[addn]/Nat.add -?[muln]/Nat.mul. 1024 | Ltac ring_postprocess := 1025 | rewrite ?[nat_of_bin _]/= -?[Nat.add]/addn -?[Nat.mul]/muln ?add1n ?add2n. 1026 | Ltac hyp_ring_preprocess H := rewrite -?mul2n -?[addn]/Nat.add -?[muln]/Nat.mul in H |- *. 1027 | Ltac hyp_ring_postprocess H := 1028 | rewrite ?[nat_of_bin _]/= -?[Nat.add]/addn -?[Nat.mul]/muln ?add1n ?add2n in H |-*. 1029 | 1030 | Ltac nat_ring := ring_preprocess; ring. 1031 | 1032 | Ltac applyr H := 1033 | hyp_ring_preprocess H; 1034 | match goal with 1035 | H: is_true (leq _ ?X) |- is_true (leq _ ?Y) => 1036 | ring_simplify X Y in H; 1037 | ring_simplify X Y; rewrite ?[nat_of_bin _]/= in H |- * 1038 | end; 1039 | hyp_ring_postprocess H; 1040 | let Z := fresh "Z" in 1041 | match goal with 1042 | H: is_true (leq _ ?X1) |- is_true (leq _ ?Y1) => 1043 | let v := delta_lterm1 Y1 X1 in 1044 | (try (rewrite [Z in _ <= Z](_ : _ = v + X1))); 1045 | [ apply: leq_trans (leq_add (leqnn _) H); rewrite {H}// ?(add0n,addn0) 1046 | | nat_ring] 1047 | end. 1048 | 1049 | Ltac applyl H := 1050 | hyp_ring_preprocess H; 1051 | match goal with 1052 | H: is_true (leq ?X _) |- is_true (leq ?Y _) => 1053 | ring_simplify X Y; ring_simplify X Y in H 1054 | end; 1055 | hyp_ring_postprocess H; 1056 | let Z := fresh "Z" in 1057 | match goal with 1058 | H: is_true (leq ?X1 _) |- is_true (leq ?Y1 _) => 1059 | let v := delta_lterm1 Y1 X1 in 1060 | (try rewrite [Z in Z <= _](_ : Y1 = v + X1)); 1061 | [apply: leq_trans (leq_add (leqnn _) H) _; 1062 | rewrite {H}// ?(add0n,addn0) | nat_ring] 1063 | end. 1064 | 1065 | Ltac gsimpl := 1066 | ring_preprocess; 1067 | match goal with 1068 | |- is_true (leq ?X ?Y) => ring_simplify X Y 1069 | end; 1070 | ring_postprocess; 1071 | let Z := fresh "Z" in 1072 | match goal with 1073 | |- is_true (leq ?X1 ?Y1) => 1074 | let v := delta_lterm1 Y1 X1 in 1075 | match v with 1076 | | 0 => 1077 | let v := delta_lterm1 X1 Y1 in 1078 | let v1 := delta_lterm1 X1 v in 1079 | let v2 := delta_lterm1 Y1 v1 in 1080 | (try (rewrite [Z in _ <= Z](_ : Y1 = v2 + v1); last by nat_ring)); 1081 | (try (rewrite [Z in Z <= _](_ : X1 = v + v1); last by nat_ring)); 1082 | rewrite ?leq_add2r 1083 | | _ => 1084 | let v1 := delta_lterm1 Y1 v in 1085 | let v2 := delta_lterm1 X1 v1 in 1086 | (try (rewrite [Z in _ <= Z](_ : Y1 = v + v1); last by nat_ring)); 1087 | (try (rewrite [Z in Z <= _](_ : X1 = v2 + v1); last by nat_ring)); 1088 | rewrite ?leq_add2r 1089 | end 1090 | end. 1091 | 1092 | Ltac changel t := 1093 | let X := fresh "X" in 1094 | rewrite [X in X <= _](_ : _ = t); last by (ring || nat_ring). 1095 | Ltac changer t := 1096 | let X := fresh "X" in 1097 | rewrite [X in _ <= X](_ : _ = t); last by (ring || nat_ring). 1098 | -------------------------------------------------------------------------------- /gdist.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | 3 | (******************************************************************************) 4 | (* Definition of a distance on graph *) 5 | (* connectn r n x == the set of all the elements connected to x in n steps *) 6 | (* *) 7 | (* `d[t1, t2]_r == the distance between t1 and t2 in r *) 8 | (* if they are not connected returns the cardinal of the *) 9 | (* the subtype *) 10 | (******************************************************************************) 11 | 12 | Set Implicit Arguments. 13 | Unset Strict Implicit. 14 | Unset Printing Implicit Defensive. 15 | 16 | Section gdist. 17 | 18 | Variable T : finType. 19 | Variable r : rel T. 20 | 21 | Fixpoint connectn n x := 22 | if n is n1.+1 then \bigcup_(y in (rgraph r x)) connectn n1 y 23 | else [set x]. 24 | 25 | Lemma connectnP n x y : 26 | reflect 27 | (exists p : seq T, [/\ path r x p, last x p = y & size p = n]) 28 | (y \in connectn n x). 29 | Proof. 30 | elim: n x y => [x y|n IH x y /=]. 31 | rewrite inE; apply: (iffP idP) => [/eqP->|[[|a l] [] //= _ ->//]]. 32 | by exists [::]. 33 | apply: (iffP idP) => [/bigcupP[i]|[[|i p]//= [H1 H2 H3]]]. 34 | - rewrite [i \in _]rgraphK => iRk /IH [p [H1 H2 H3]]. 35 | by exists (i :: p); split; rewrite /= ?(iRk, H3). 36 | - by []. 37 | case/andP: H1 => H11 H12. 38 | have F : i \in rgraph r x by rewrite [_ \in _]rgraphK. 39 | apply: (subsetP (bigcup_sup _ F)). 40 | by apply/IH; exists p; split => //; case: H3. 41 | Qed. 42 | 43 | Definition gdist t1 t2 := 44 | find (fun n => t2 \in connectn n t1) (iota 0 #|T|). 45 | 46 | Local Notation " `d[ t1 , t2 ] " := (gdist t1 t2) 47 | (format " `d[ t1 , t2 ] "). 48 | 49 | Lemma gdist_eq0 t1 t2 : (`d[t1, t2] == 0) = (t1 == t2). 50 | Proof. 51 | have tG : #|T| > 0 by rewrite (cardD1 t1). 52 | rewrite /gdist. 53 | case: #|_| tG => // n _. 54 | rewrite (iotaD _ 1) /= inE [t2 == _]eq_sym. 55 | by case: (t1 =P t2). 56 | Qed. 57 | 58 | Lemma gdist_gt0 t1 t2 : (0 < `d[t1, t2]) = (t1 != t2). 59 | Proof. by rewrite ltnNge leqn0 gdist_eq0. Qed. 60 | 61 | Lemma gdist0 t : `d[t, t] = 0. 62 | Proof. by apply/eqP; rewrite gdist_eq0. Qed. 63 | 64 | Lemma gdist_card_le t1 t2 : `d[t1, t2] <= #|T|. 65 | Proof. 66 | rewrite -[#|T|](size_iota 0). 67 | apply: find_size. 68 | Qed. 69 | 70 | Lemma gdist_path_le t1 t2 p : 71 | path r t1 p -> last t1 p = t2 -> `d[t1, t2] <= size p. 72 | Proof. 73 | move=> Hp Hl. 74 | have [tLp|pLt] := leqP #|T| (size p). 75 | apply: leq_trans tLp. 76 | by apply: gdist_card_le. 77 | have F : t2 \in connectn (size p) t1. 78 | by apply/connectnP; exists p. 79 | case: leqP => // /(before_find _) // /(_ 0). 80 | by rewrite seq.nth_iota // F. 81 | Qed. 82 | 83 | Lemma gdist_connect t1 t2 : connect r t1 t2 = (`d[t1,t2] < #|T|). 84 | Proof. 85 | apply/connectP/idP=> [[p /shortenP[p' Hp' Hu _ Ht]]|]. 86 | apply: leq_trans (_ : size p' < _). 87 | by apply: gdist_path_le. 88 | rewrite -[_.+1]/(size (t1 :: p')) cardE. 89 | apply: uniq_leq_size => // i. 90 | by rewrite mem_enum. 91 | rewrite -[#|_|](size_iota 0) -has_find. 92 | move => /hasP[n _ /connectnP [p [H1p H2p H3p]]]. 93 | by exists p. 94 | Qed. 95 | 96 | Lemma gdist_nconnect t1 t2 : ~~ connect r t1 t2 -> `d[t1,t2] = #|T|. 97 | Proof. 98 | move=> H; apply/eqP. 99 | have := gdist_card_le t1 t2. 100 | by rewrite leq_eqVlt -gdist_connect (negPf H) orbF. 101 | Qed. 102 | 103 | (* geodesic path *) 104 | Definition gpath t1 t2 p := 105 | [&& path r t1 p, last t1 p == t2 & `d[t1, t2] == size p]. 106 | 107 | Lemma gpathP t1 t2 p : 108 | reflect ([/\ path r t1 p, last t1 p = t2 & `d[t1, t2] = size p]) 109 | (gpath t1 t2 p). 110 | Proof. 111 | apply: (iffP and3P) => [[t1Pp /eqP t1pLt2 /eqP t1t2D]| 112 | [t1Pp t1pLt2 t1t2D]]; first by split. 113 | by split => //; apply/eqP. 114 | Qed. 115 | 116 | Lemma gpath_connect t1 t2 : connect r t1 t2 -> {p | gpath t1 t2 p}. 117 | Proof. 118 | move=> t1Ct2. 119 | case: (pickP [pred p | gpath t1 t2 (p : `d[t1, t2].-tuple T)]) => [p Hp|HC]. 120 | by exists p. 121 | move: (t1Ct2); rewrite gdist_connect => dLT. 122 | absurd False => //. 123 | move: (dLT); rewrite -[#|_|](size_iota 0) -has_find. 124 | move => /(nth_find 0). 125 | rewrite -[find _ _]/`d[t1, t2]. 126 | rewrite nth_iota // add0n => /connectnP[p [H1p H2p /eqP H3p]]. 127 | have /idP[] := HC (Tuple H3p). 128 | by apply/and3P; split=> //=; apply/eqP=> //; rewrite (eqP H3p). 129 | Qed. 130 | 131 | Lemma gpath_last t1 t2 p : gpath t1 t2 p -> last t1 p = t2. 132 | Proof. by case/gpathP. Qed. 133 | 134 | Lemma gpath_dist t1 t2 p : gpath t1 t2 p -> `d[t1, t2] = size p. 135 | Proof. by case/gpathP. Qed. 136 | 137 | Lemma gpath_path t1 t2 p : gpath t1 t2 p -> path r t1 p. 138 | Proof. by case/gpathP. Qed. 139 | 140 | Lemma last_take (A : Type) (p : seq A) t t1 j : 141 | j <= size p -> last t1 (take j p) = nth t (t1 :: p) j. 142 | Proof. 143 | elim: p t1 j => [t1 [|] //| a l IH t1 [|j]] //= H. 144 | by apply: IH. 145 | Qed. 146 | 147 | (* ugly proof !! *) 148 | Lemma gpath_uniq t1 t2 p : gpath t1 t2 p -> uniq (t1 :: p). 149 | Proof. 150 | move=> gH; apply/(uniqP t1) => i j iH jH. 151 | wlog : i j iH jH / i <= j. 152 | move=> H; case: (leqP i j) => [iLj|jLi]; first by apply: H. 153 | by move=> /(@sym_equal _ _ _) /H->; rewrite // ltnW. 154 | rewrite leq_eqVlt => /orP[/eqP->//|iLj]. 155 | case/gpathP : gH => t1Pp t1pLt2 dt1t2E. 156 | case: j jH iLj => j // jH iLj. 157 | case: i iH iLj => [_ _ t1E | ] //. 158 | pose p1 := drop j.+1 p. 159 | have t1Pp1 : path r t1 p1. 160 | move: (t1Pp); rewrite -[p](cat_take_drop j.+1) cat_path. 161 | rewrite /= in t1E. 162 | by rewrite (last_take t1) //= -t1E => /andP[]. 163 | have t1p1L : last t1 p1 = t2. 164 | move: (t1pLt2); rewrite -[p](cat_take_drop j.+1) last_cat. 165 | rewrite /= in t1E. 166 | by rewrite (last_take t1) //= -t1E. 167 | have [] := boolP (`d[t1, t2] <= size p1) => [|/negP[]]; last first. 168 | by apply: gdist_path_le. 169 | rewrite leqNgt => /negP[]. 170 | rewrite size_drop dt1t2E. 171 | rewrite /= in t1E. 172 | by rewrite -{2}[size p](subnK (_ : j < size p)) // addnS ltnS leq_addr. 173 | move=> i iH; rewrite ltnS => iLj nE. 174 | pose p1 := take i.+1 p ++ drop j.+1 p. 175 | have [] := boolP (`d[t1, t2] <= size p1) => [|/negP[]]. 176 | rewrite leqNgt => /negP[]. 177 | rewrite size_cat size_take size_drop ifT //; last first. 178 | by rewrite -ltnS in iLj; apply: leq_trans iLj _. 179 | rewrite dt1t2E -{2}[size p](subnK (_ : j < size _)) //. 180 | by rewrite addnC ltn_add2l. 181 | apply: gdist_path_le. 182 | move: t1Pp; rewrite -[p](cat_take_drop i.+1). 183 | rewrite -[drop _ _](cat_take_drop (j - i)) !cat_path. 184 | case/and3P => [-> _] /=. 185 | rewrite !(last_take t1) /=; last first. 186 | - rewrite size_drop -subSS. 187 | by apply: leq_sub2r. 188 | - by apply: leq_trans iLj _; rewrite ltnW //. 189 | rewrite drop_drop addnS subnK; last by rewrite ltnW. 190 | congr path. 191 | move: (nE) => /= ->. 192 | rewrite -[j - i]prednK //. 193 | by rewrite /= nth_drop -subnS addnC subnK //. 194 | by rewrite subn_gt0. 195 | rewrite last_cat (last_take t1) // nE. 196 | by rewrite -t1pLt2 -{3}[p](cat_take_drop j.+1) last_cat (last_take t1). 197 | Qed. 198 | 199 | 200 | Lemma gpath_catl t1 t2 p1 p2 : 201 | gpath t1 t2 (p1 ++ p2) -> gpath t1 (last t1 p1) p1. 202 | Proof. 203 | move=> /gpathP[]. 204 | rewrite cat_path last_cat => /andP[t1Pp1 t1p1LPp2] t1p1Lp2Lt2 dt1t2E. 205 | apply/gpathP; split => //. 206 | have : `d[t1, last t1 p1] <= size p1 by rewrite gdist_path_le. 207 | rewrite leq_eqVlt => /orP[/eqP//|dLSp1]. 208 | have /gpath_connect[p3 /gpathP[H1 H2 H3]] : 209 | connect r t1 (last t1 p1) by apply/connectP; exists p1. 210 | have : size (p3 ++ p2) < `d[t1, t2] by rewrite dt1t2E !size_cat -H3 ltn_add2r. 211 | rewrite ltnNge => /negP[]. 212 | apply: gdist_path_le; first by rewrite cat_path H1 // H2. 213 | by rewrite last_cat H2. 214 | Qed. 215 | 216 | Lemma gpath_catr t1 t2 p1 p2 : 217 | gpath t1 t2 (p1 ++ p2) -> gpath (last t1 p1) t2 p2. 218 | Proof. 219 | move=> /gpathP[]. 220 | rewrite cat_path last_cat => /andP[t1Pp1 t1p1LPp2] t1p1Lp2Lt2 dt1t2E. 221 | apply/gpathP; split => //. 222 | have : `d[last t1 p1, t2] <= size p2 by rewrite gdist_path_le. 223 | rewrite leq_eqVlt => /orP[/eqP//|dLSp1]. 224 | have /gpath_connect[p3 /gpathP[H1 H2 H3]] : 225 | connect r (last t1 p1) t2 by apply/connectP; exists p2. 226 | have : size (p1 ++ p3) < `d[t1, t2] by rewrite dt1t2E !size_cat -H3 ltn_add2l. 227 | rewrite ltnNge => /negP[]. 228 | apply: gdist_path_le; first by rewrite cat_path H1 andbT. 229 | by rewrite last_cat. 230 | Qed. 231 | 232 | Lemma gdist_cat t1 t2 p1 p2 : 233 | gpath t1 t2 (p1 ++ p2) -> 234 | `d[t1,t2] = `d[t1, last t1 p1] + `d[last t1 p1, t2]. 235 | Proof. 236 | move=> gH. 237 | rewrite (gpath_dist gH). 238 | rewrite (gpath_dist (gpath_catl gH)) (gpath_dist (gpath_catr gH)) //. 239 | by rewrite size_cat. 240 | Qed. 241 | 242 | Lemma gpath_consl t1 t2 t3 p : gpath t1 t2 (t3 :: p) -> `d[t1, t3] = 1. 243 | Proof. by move=> /(@gpath_catl _ _ [::t3]) /= /gpathP[]. Qed. 244 | 245 | Lemma gpath_consr t1 t2 t3 p : gpath t1 t2 (t3 :: p) -> gpath t3 t2 p. 246 | Proof. by move=> /(@gpath_catr _ _ [::t3]). Qed. 247 | 248 | Lemma gdist_cons t1 t2 t3 p : 249 | gpath t1 t2 (t3 :: p) -> `d[t1,t2] = `d[t3, t2].+1. 250 | Proof. 251 | move=> gH. 252 | by rewrite (@gdist_cat _ _ [::t3] p) // (gpath_consl gH). 253 | Qed. 254 | 255 | Lemma gdist_triangular t1 t2 t3 : `d[t1, t2] <= `d[t1, t3] + `d[t3, t2]. 256 | Proof. 257 | have [/gpath_connect[p pH]|/gdist_nconnect->] 258 | := boolP (connect r t1 t3); last first. 259 | by apply: leq_trans (gdist_card_le _ _) (leq_addr _ _). 260 | have [/gpath_connect [p2 p2H] |/gdist_nconnect->] 261 | := boolP (connect r t3 t2); last first. 262 | by apply: leq_trans (gdist_card_le _ _) (leq_addl _ _). 263 | rewrite (gpath_dist pH) (gpath_dist p2H) -size_cat. 264 | apply: gdist_path_le. 265 | rewrite cat_path (gpath_path pH). 266 | by rewrite (gpath_last pH) (gpath_path p2H). 267 | by rewrite last_cat (gpath_last pH) (gpath_last p2H). 268 | Qed. 269 | 270 | Lemma gdist1 t1 t2 : r t1 t2 -> `d[t1, t2] = (t1 != t2). 271 | Proof. 272 | move=> Hr; apply/eqP. 273 | case: (t1 =P t2) => [<-|/eqP HE]; first by rewrite gdist_eq0. 274 | rewrite eqn_leq -{1}[nat_of_bool _]/(size [::t2]) gdist_path_le /= ?andbT //. 275 | by case: gdist (gdist_eq0 t1 t2); rewrite (negPf HE) . 276 | Qed. 277 | 278 | Lemma gdist_succ t1 t2 : 279 | 0 < `d[t1, t2] < #|T| -> {t3 | r t1 t3 /\ `d[t3, t2] = `d[t1, t2].-1}. 280 | Proof. 281 | case/andP => dP dT. 282 | move: dT dP. 283 | rewrite -gdist_connect => /gpath_connect[[|t3 p] pH]. 284 | by rewrite (gpath_dist pH). 285 | exists t3; split. 286 | by have /andP[] := gpath_path (@gpath_catl _ _ [::t3] _ pH). 287 | by rewrite (gdist_cons pH). 288 | Qed. 289 | 290 | Lemma gdist_neighboor t1 t2 t3 : r t1 t2 -> 291 | r t2 t1 -> [|| `d[t2, t3] == `d[t1, t3].-1, 292 | `d[t2, t3] == `d[t1, t3] | 293 | `d[t2, t3] == `d[t1, t3].+1]. 294 | Proof. 295 | move=> t1Rt2 t2Rt1. 296 | have : `d[t1, t3] - `d[t1, t2] <= `d[t2, t3] <= `d[t2, t1] + `d[t1, t3]. 297 | by rewrite leq_subLR !gdist_triangular. 298 | rewrite (gdist1 t1Rt2) (gdist1 t2Rt1). 299 | (do 2 case: eqP) => //= E1 E2; rewrite ?subn0. 300 | - by rewrite -eqn_leq => /eqP->; rewrite eqxx orbT. 301 | - case/andP=> E3. 302 | rewrite leq_eqVlt => /orP[/eqP->|]. 303 | by rewrite eqxx !orbT. 304 | rewrite ltnS => E4. 305 | by rewrite [`d[_, _] == `d[_, _]]eqn_leq E3 E4 orbT. 306 | - case/andP=> E3. 307 | rewrite leq_eqVlt => /orP[/eqP->|]. 308 | by rewrite eqxx !orbT. 309 | case: (`d[t1, t3]) E3 => //= d. 310 | rewrite subSS subn0 ltnS => E3 E4. 311 | by rewrite [_ == d]eqn_leq E3 E4. 312 | case/andP=> E3. 313 | rewrite leq_eqVlt => /orP[/eqP->|]. 314 | by rewrite eqxx !orbT. 315 | rewrite ltnS leq_eqVlt => /orP[/eqP->|]. 316 | by rewrite eqxx !orbT. 317 | case: (`d[t1, t3]) E3 => //= d. 318 | rewrite subSS subn0 ltnS => E3 E4. 319 | by rewrite [_ == d]eqn_leq E3 E4. 320 | Qed. 321 | 322 | End gdist. 323 | 324 | Notation " `d[ t1 , t2 ]_ r " := (gdist r t1 t2) (at level 10, 325 | format "`d[ t1 , t2 ]_ r"). 326 | 327 | Section gdistProp. 328 | 329 | Variable T : finType. 330 | Variable r : rel T. 331 | 332 | Lemma eq_connectn (r1 r2 : rel T) : r1 =2 r2 -> connectn r1 =2 connectn r2. 333 | Proof. 334 | move=> r1Er2. 335 | elim => //= n IH y; apply: eq_big => // i. 336 | by rewrite ![_ \in _]rgraphK r1Er2. 337 | Qed. 338 | 339 | Lemma eq_dist (r1 r2 : rel T) : r1 =2 r2 -> gdist r1 =2 gdist r2. 340 | Proof. 341 | move=> r1Er2 t1 t2. 342 | apply: eq_find => n. 343 | by rewrite (eq_connectn r1Er2). 344 | Qed. 345 | 346 | Lemma gdist_sym t1 t2 : 347 | `d[t1, t2]_r = `d[t2, t1]_(fun z : T => r^~ z). 348 | Proof. 349 | apply: eq_find => i. 350 | apply/connectnP/connectnP => /= [] [p [H1p H2p H3p]]. 351 | exists (rev (belast t1 p)); split => //. 352 | - by rewrite -H2p rev_path. 353 | - rewrite -H2p; case: (p) => //= a p1. 354 | by rewrite rev_cons last_rcons. 355 | by rewrite size_rev size_belast. 356 | exists (rev (belast t2 p)); split => //. 357 | - by rewrite -H2p rev_path. 358 | - rewrite -H2p; case: (p) => //= a p1. 359 | by rewrite rev_cons last_rcons. 360 | by rewrite size_rev size_belast. 361 | Qed. 362 | 363 | Lemma gpath_rev t1 t2 p : gpath r t1 t2 p -> gpath (fun z : T => r^~ z) t2 t1 (rev (belast t1 p)). 364 | Proof. 365 | move=> /gpathP[H1 H2] H3. 366 | apply/gpathP; split => //. 367 | - by rewrite -rev_path H2 in H1. 368 | - case: (p) H2 => //= a p1. 369 | by rewrite /= rev_cons last_rcons. 370 | by rewrite size_rev size_belast -gdist_sym. 371 | Qed. 372 | 373 | Lemma gdistC t1 t2 : symmetric r -> `d[t1, t2]_r = `d[t2, t1]_r. 374 | Proof. 375 | move=> rSym; rewrite gdist_sym. 376 | by apply: eq_dist. 377 | Qed. 378 | 379 | Lemma eq_gpath (e1 e2 : rel T) t1 t2 c : 380 | e1 =2 e2 -> gpath e1 t1 t2 c = gpath e2 t1 t2 c. 381 | Proof. 382 | by move=> e1Ee2; apply/gpathP/gpathP; rewrite (eq_path e1Ee2) (eq_dist e1Ee2). 383 | Qed. 384 | 385 | Lemma gpathC t1 t2 p : 386 | symmetric r -> gpath r t1 t2 p -> gpath r t2 t1 (rev (belast t1 p)). 387 | Proof. 388 | move=> hIrr /gpath_rev. 389 | by rewrite (@eq_gpath _ _ _ _ _ (_ : _ =2 r)). 390 | Qed. 391 | 392 | End gdistProp. 393 | -------------------------------------------------------------------------------- /ghanoi3.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From hanoi Require Import ghanoi gdist. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | (******************************************************************************) 9 | (* *) 10 | (* Generalised Hanoi Problem with only 3 pegs *) 11 | (* *) 12 | (******************************************************************************) 13 | 14 | 15 | Section GHanoi3. 16 | 17 | (******************************************************************************) 18 | (* The pegs are the three elements of 'I_3 *) 19 | (******************************************************************************) 20 | 21 | Implicit Type p : peg 3. 22 | Let peg1 : peg 3 := ord0. 23 | Let peg2 : peg 3 := inord 1. 24 | Let peg3 : peg 3 := inord 2. 25 | 26 | Lemma peg3E p : [\/ p = peg1, p = peg2 | p = peg3]. 27 | Proof. 28 | by case: p => [] [|[|[|]]] // H; [apply: Or31|apply: Or32|apply: Or33]; 29 | apply/val_eqP; rewrite //= inordK. 30 | Qed. 31 | 32 | (* Finding the free peg that differs from p1 and p2 *) 33 | 34 | Lemma opeg3E p p1 p2 : p1 != p2 -> (`p[p1, p2] == p) = ((p1 != p) && (p2 != p)). 35 | Proof. 36 | move=> p1Dp2. 37 | have D p3 p4 : (p3 == p4) = (val p3 == val p4). 38 | by apply/eqP/idP => /val_eqP. 39 | move: p1Dp2 (opegDl p1 p2) (opegDr p1 p2). 40 | by case: (peg3E (opeg p1 p2)) => ->; 41 | case: (peg3E p1) => ->; 42 | case: (peg3E p2) => ->; 43 | case: (peg3E p) => ->; 44 | rewrite !D /peg1 /peg2 /peg3 /= ?inordK. 45 | Qed. 46 | 47 | Lemma opeg3Kl p p1 p2 : p1 != p2 -> `p[`p[p1, p2], p1] = p2. 48 | Proof. 49 | move=> p1Dp2; apply/eqP. 50 | by rewrite !opeg3E ?(eqxx, p1Dp2) // [in p2 != p1]eq_sym p1Dp2. 51 | Qed. 52 | 53 | Lemma opeg3Kr p p1 p2 : p1 != p2 -> `p[`p[p1, p2], p2] = p1. 54 | Proof. 55 | move=> p1Dp2; apply/eqP. 56 | by rewrite !opeg3E ?(eqxx, p1Dp2) // [in p2 != p1]eq_sym p1Dp2. 57 | Qed. 58 | 59 | Variable hrel : rel (peg 3). 60 | Hypothesis hirr : irreflexive hrel. 61 | Hypothesis hsym : symmetric hrel. 62 | 63 | Let hmove {n} := @move 3 hrel n. 64 | Let hmove_sym n (c1 c2 : configuration 3 n) : hmove c1 c2 = hmove c2 c1 65 | := move_sym hsym c1 c2. 66 | Let hconnect n := connect (@hmove n). 67 | 68 | Local Notation "c1 `--> c2" := (hmove c1 c2) 69 | (format "c1 `--> c2", at level 60). 70 | Local Notation "c1 `-->* c2" := (hconnect c1 c2) 71 | (format "c1 `-->* c2", at level 60). 72 | 73 | (* In a move the largest disk has moved, all the smaller disks are pilled up *) 74 | Lemma move_perfectr n (c1 c2 : configuration 3 n.+1) : 75 | c1 `--> c2 -> c1 ldisk != c2 ldisk -> ↓[c2] = `c[`p[c1 ldisk, c2 ldisk]]. 76 | Proof. 77 | move=> c1Mc2 c1lDc2l. 78 | apply/ffunP => i; rewrite !ffunE. 79 | have /ffunP/(_ i) := move_ldisk c1Mc2 c1lDc2l; rewrite !ffunE => c1Ec2. 80 | apply/sym_equal/eqP; rewrite opeg3E //; apply/andP; split. 81 | rewrite -c1Ec2 /=; apply/eqP => c1lEc1r. 82 | have /on_topP /(_ _ c1lEc1r) := move_on_topl c1Mc2 c1lDc2l. 83 | by rewrite /= leqNgt ltn_ord. 84 | apply/eqP => c2lEc2r. 85 | have /on_topP /(_ _ c2lEc2r):= move_on_topr c1Mc2 c1lDc2l. 86 | by rewrite /= leqNgt ltn_ord. 87 | Qed. 88 | 89 | Lemma move_perfectl n (c1 c2 : configuration 3 n.+1) : 90 | c1 `--> c2 -> c1 ldisk != c2 ldisk -> 91 | ↓[c1] = `c[`p[c1 ldisk, c2 ldisk]]. 92 | Proof. 93 | rewrite hmove_sym eq_sym opeg_sym. 94 | exact: move_perfectr. 95 | Qed. 96 | 97 | Inductive path3S_spec (n : nat) (c : configuration 3 n.+1) 98 | (cs : seq (configuration 3 n.+1)) : 99 | forall (b : bool), Type := 100 | | path3S_specW : 101 | forall (c' := ↓[c]) (cs' := [seq ↓[i] | i <- cs]) (p := c ldisk), 102 | cs = [seq ↑[i]_p | i <- cs'] -> 103 | path hmove c' cs' -> path3S_spec c cs true 104 | | path3S_spec_move : 105 | forall cs1 cs2 106 | (p1 := c ldisk) p2 (p3 :=`p[p1, p2]) 107 | (c1 := ↓[c]) 108 | (c2 := ↑[`c[p3]]_p2), 109 | p1 != p2 -> hrel p1 p2 -> 110 | last c1 cs1 = `c[p3] -> 111 | cs = [seq ↑[i]_p1 | i <- cs1] ++ c2 :: cs2 -> 112 | path hmove c1 cs1 -> path hmove c2 cs2 -> 113 | path3S_spec c cs true | 114 | path3S_spec_false : path3S_spec c cs false. 115 | 116 | (* Inversion theorem on a path for disk n.+1 *) 117 | Lemma path3SP n (c : _ _ n.+1) cs : path3S_spec c cs (path hmove c cs). 118 | Proof. 119 | case: pathSP=> //; try by constructor. 120 | move=> p1 p2 cs1 cs2 c1 c2 p1Dp2 p1Rp2 csE c1Pcs1 lMc2 c2Pcs2. 121 | have lc1cs1E : last c1 cs1 = `c[`p[p1, p2]]. 122 | have := move_perfectl lMc2. 123 | by rewrite !cliftr_ldisk cliftrK; apply. 124 | apply: path3S_spec_move (lc1cs1E) _ _ _ => //. 125 | - by rewrite csE; congr (_ ++ cliftr _ _ :: _). 126 | by rewrite -lc1cs1E. 127 | Qed. 128 | 129 | End GHanoi3. -------------------------------------------------------------------------------- /ghanoi4.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From hanoi Require Import ghanoi gdist. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | (******************************************************************************) 9 | (* *) 10 | (* Generalised Hanoi Problem with only 4 pegs *) 11 | (* *) 12 | (******************************************************************************) 13 | 14 | 15 | Section GHanoi4. 16 | 17 | (*****************************************************************************) 18 | (* The pegs are the four elements of 'I_4 *) 19 | (*****************************************************************************) 20 | 21 | Implicit Type p : peg 4. 22 | 23 | Let peg0 : peg 4 := ord0. 24 | Let peg1 : peg 4 := inord 1. 25 | Let peg2 : peg 4 := inord 2. 26 | Let peg3 : peg 4 := inord 3. 27 | 28 | Lemma peg4E p : [\/ p = peg0, p = peg1, p = peg2 | p = peg3]. 29 | Proof. 30 | by case: p => [] [|[|[|[|]]]] // H; 31 | [apply: Or41|apply: Or42|apply: Or43|apply: Or44]; 32 | apply/val_eqP; rewrite //= inordK. 33 | Qed. 34 | 35 | Ltac comp2_tac peg2 peg3 := 36 | let p := fresh "p" in 37 | exists peg2; exists peg3; repeat split; 38 | try (by apply/eqP/val_eqP; rewrite /= !inordK); 39 | move=> p; case: (peg4E p)=>->; 40 | ((by apply/Or41/val_eqP; rewrite /= ?inordK) || 41 | (by apply/Or42/val_eqP; rewrite /= ?inordK) || 42 | (by apply/Or43/val_eqP; rewrite /= ?inordK) || 43 | (by apply/Or44/val_eqP; rewrite /= ?inordK)). 44 | 45 | 46 | Lemma peg4comp2 p1 p2 : 47 | p1 != p2 -> exists p3, exists p4, 48 | [/\ [/\ p4 != p3, p4 != p2 & p4 != p1], 49 | [/\ p3 != p2 & p3 != p1] & 50 | (forall p, [\/ p = p1, p = p2, p = p3 | p = p4])]. 51 | Proof. 52 | case: (peg4E p1)=>->; case: (peg4E p2)=>->; rewrite ?eqxx // => _. 53 | comp2_tac peg2 peg3. 54 | comp2_tac peg1 peg3. 55 | comp2_tac peg1 peg2. 56 | comp2_tac peg2 peg3. 57 | comp2_tac peg0 peg3. 58 | comp2_tac peg0 peg2. 59 | comp2_tac peg1 peg3. 60 | comp2_tac peg0 peg3. 61 | comp2_tac peg0 peg1. 62 | comp2_tac peg1 peg2. 63 | comp2_tac peg0 peg2. 64 | comp2_tac peg0 peg1. 65 | Qed. 66 | 67 | Ltac comp3_tac peg0 := 68 | let p := fresh "p" in 69 | exists peg0; (repeat split) => [|||p]; 70 | try (apply/eqP/val_eqP; rewrite /= ?inordK //); 71 | case: (peg4E p)=>->; 72 | ((by apply/Or41/val_eqP; rewrite /= ?inordK) || 73 | (by apply/Or42/val_eqP; rewrite /= ?inordK) || 74 | (by apply/Or43/val_eqP; rewrite /= ?inordK) || 75 | (by apply/Or44/val_eqP; rewrite /= ?inordK)). 76 | 77 | Lemma peg4comp3 p1 p2 p3 : 78 | p1 != p2 -> p1 != p3 -> p2 != p3 -> 79 | exists p4, [/\ p4 != p3, p4 != p2 & p4 != p1] /\ 80 | (forall p, [\/ p = p1, p = p2, p = p3 | p = p4]). 81 | Proof. 82 | case: (peg4E p1)=>->; case: (peg4E p2)=>->; 83 | case: (peg4E p3)=>->; rewrite ?eqxx // => _ _ _; 84 | (comp3_tac peg0 || comp3_tac peg1 || comp3_tac peg2 || comp3_tac peg3). 85 | Qed. 86 | 87 | End GHanoi4. -------------------------------------------------------------------------------- /lhanoi3.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From hanoi Require Import gdist ghanoi ghanoi3. 3 | 4 | (******************************************************************************) 5 | (* *) 6 | (* Linear Hanoi Problem with 3 pegs *) 7 | (* *) 8 | (******************************************************************************) 9 | 10 | Set Implicit Arguments. 11 | Unset Strict Implicit. 12 | Unset Printing Implicit Defensive. 13 | 14 | Section LHanoi3. 15 | 16 | Lemma lrel3D (p1 p2 : peg 3) : p1 != p2 -> lrel p1 p2 || lrel p1 `p[p1, p2]. 17 | Proof. 18 | move=> p1Dp2. 19 | have D p3 p4 : (p3 == p4) = (val p3 == val p4). 20 | by apply/eqP/idP => /val_eqP. 21 | move: p1Dp2 (opegDl p1 p2) (opegDr p1 p2). 22 | by case: (peg3E `p[p1, p2]) => ->; 23 | case: (peg3E p1) => ->; 24 | case: (peg3E p2) => ->; 25 | rewrite !D /lrel /= ?inordK. 26 | Qed. 27 | 28 | Lemma lrel3B (p1 p2 : peg 3) : p1 != p2 -> 29 | ~~ [&& lrel p1 p2, lrel p1 `p[p1, p2] & lrel p2 `p[p1, p2]]. 30 | Proof. 31 | have D p3 p4 : (p3 == p4) = (val p3 == val p4). 32 | by apply/eqP/idP => /val_eqP. 33 | move: (opegDl p1 p2) (opegDr p1 p2). 34 | by case: (peg3E `p[p1, p2]) => ->; 35 | case: (peg3E p1) => ->; 36 | case: (peg3E p2) => ->; 37 | rewrite !D /lrel /= ?inordK. 38 | Qed. 39 | 40 | Lemma lrel3O (p1 p2 : peg 3) : p1 != p2 -> 41 | ~~ lrel p1 p2 -> lrel p1 `p[p1, p2]. 42 | Proof. by move/lrel3D; case: lrel. Qed. 43 | 44 | Lemma lrel3ON (p1 p2 : peg 3) : p1 != p2 -> 45 | lrel p1 p2 -> ~~ lrel p1 `p[p1, p2] -> lrel p2 `p[p1, p2]. 46 | Proof. 47 | have D p3 p4 : (p3 == p4) = (val p3 == val p4). 48 | by apply/eqP/idP => /val_eqP. 49 | move: (opegDl p1 p2) (opegDr p1 p2). 50 | by case: (peg3E `p[p1, p2]) => ->; 51 | case: (peg3E p1) => ->; 52 | case: (peg3E p2) => ->; 53 | rewrite !D /lrel /= ?inordK. 54 | Qed. 55 | 56 | Lemma lrel3ON4 (p1 p2 p3 p4 : peg 3) : 57 | p1 != p2 -> p1 != p3 -> p2 != p3 -> 58 | lrel p1 p2 -> lrel p1 p3 -> lrel p3 p4 -> p4 = p1. 59 | Proof. 60 | have D p5 p6 : (p5 == p6) = (val p5 == val p6). 61 | by apply/eqP/idP => /val_eqP. 62 | by case: (peg3E p1) => ->; 63 | case: (peg3E p2) => ->; 64 | case: (peg3E p3) => ->; 65 | case: (peg3E p4) => ->; 66 | rewrite !D /lrel /= ?inordK. 67 | Qed. 68 | 69 | Local Notation "c1 `-->_r c2" := (lmove c1 c2) 70 | (format "c1 `-->_r c2", at level 60). 71 | Local Notation "c1 `-->*_r c2" := (connect lmove c1 c2) 72 | (format "c1 `-->*_r c2", at level 60). 73 | 74 | (******************************************************************************) 75 | (* Function that builds a path from a configuration to a peg *) 76 | (******************************************************************************) 77 | 78 | Fixpoint lhanoi3 {n : nat} : configuration 3 n -> configuration _ n -> _ := 79 | match n with 80 | | 0 => fun _ _ => [::] : seq (configuration _ 0) 81 | | _.+1 => 82 | fun c1 c2 => 83 | let p1 := c1 ldisk in 84 | let p2 := c2 ldisk in 85 | if p1 == p2 then [seq ↑[i]_p2 | i <- lhanoi3 ↓[c1] ↓[c2]] else 86 | let p3 := `p[p1, p2] in 87 | if lrel p1 p2 then 88 | [seq ↑[i]_p1 | i <- lhanoi3 ↓[c1] `c[p3]] ++ 89 | [seq ↑[i]_p2 | i <- `c[p3] :: lhanoi3 `c[p3] ↓[c2]] 90 | else 91 | [seq ↑[i]_p1 | i <- lhanoi3 ↓[c1] `c[p2]] ++ 92 | [seq ↑[i]_p3 | i <- `c[p2] :: lhanoi3 `c[p2] `c[p1]] ++ 93 | [seq ↑[i]_p2 | i <- `c[p1] :: lhanoi3 `c[p1] ↓[c2]] 94 | end. 95 | 96 | Lemma lhanoi3_nil_inv n (c1 c2 : _ _ n) : lhanoi3 c1 c2 = [::] -> c1 = c2. 97 | Proof. 98 | elim: n c1 c2 => [c1 c2 _|n IH c1 c2] /=; first by apply/ffunP=> [] []. 99 | case: eqP => [H | H] //=; last by case: lrel; case: map. 100 | rewrite -{2}[c1]cunliftrK -{3}[c2]cunliftrK. 101 | case: lhanoi3 (IH ↓[c1] ↓[c2]) => //= -> // _. 102 | by rewrite H. 103 | Qed. 104 | 105 | Lemma last_lhanoi3 n (c1 c2 : _ _ n) (cs := lhanoi3 c1 c2) : 106 | last c1 cs = c2. 107 | Proof. 108 | have HH := @lirr 3. 109 | rewrite /cs; elim: n c1 c2 {cs} => /= [c1 c2| n IH c1 c2]. 110 | by apply/ffunP=> [] []. 111 | case: eqP => [Ho|/eqP Do]. 112 | by rewrite -{1}[c1](cunliftrK) Ho last_map IH // cunliftrK. 113 | set p1 := _ ldisk; set p2 := opeg _ _. 114 | set cp2 := `c[_]; set cp := `c[_]; set cp1 := `c[_]. 115 | case: (boolP (lrel _ _)) => [Hrel|Hrel]. 116 | by rewrite last_cat /= last_map IH cunliftrK. 117 | by rewrite last_cat /= last_cat /= last_map IH cunliftrK. 118 | Qed. 119 | 120 | Lemma path_lhanoi3 n (c1 c2 : _ _ n) (cs := lhanoi3 c1 c2) : 121 | path lmove c1 cs. 122 | Proof. 123 | have HH := @lirr 3. 124 | rewrite /cs; elim: n c1 c2 {cs} => //= n IH c1 c2. 125 | case: eqP => [Ho|/eqP Do]. 126 | by rewrite -{1}[c1](cunliftrK) Ho path_liftr. 127 | set p1 := _ ldisk; set p2 := opeg _ _. 128 | set cp2 := `c[_]; set cp := `c[_]; set cp1 := `c[_]. 129 | case: (boolP (lrel _ _)) => [Hrel|Hrel]. 130 | rewrite cat_path /=; apply/and3P; repeat split. 131 | - by rewrite -{1}[c1]cunliftrK path_liftr. 132 | - rewrite -{1}[c1]cunliftrK last_map last_lhanoi3. 133 | by apply: move_liftr_perfect; rewrite // eq_sym (opegDl, opegDr). 134 | by rewrite path_liftr. 135 | rewrite cat_path /= cat_path /=; apply/and5P; split. 136 | - by rewrite -{1}[c1]cunliftrK /= path_liftr. 137 | - rewrite -{1}[c1]cunliftrK /= last_map last_lhanoi3. 138 | - apply: move_liftr_perfect => //; first by apply: lrel3O. 139 | by rewrite opegDr. 140 | - by rewrite path_liftr. 141 | - rewrite last_map last_lhanoi3. 142 | apply: move_liftr_perfect => //. 143 | - rewrite /p2 opeg_sym lsym lrel3O ?opegDl //; first by rewrite eq_sym. 144 | by rewrite lsym. 145 | - by rewrite opegDl. 146 | by rewrite eq_sym. 147 | by rewrite path_liftr. 148 | Qed. 149 | 150 | (* Two configurations are always connected *) 151 | Lemma move_lconnect3 n (c1 c2 : configuration 3 n) : c1 `-->*_r c2. 152 | Proof. 153 | apply/connectP; exists (lhanoi3 c1 c2); first by apply: path_lhanoi3. 154 | by rewrite last_lhanoi3. 155 | Qed. 156 | 157 | (* lhanoi gives the smallest path connecting c1 to c2 *) 158 | (* This path is unique *) 159 | Lemma lhanoi3_min n (c1 c2 : configuration 3 n) cs : 160 | path lmove c1 cs -> last c1 cs = c2 -> 161 | size (lhanoi3 c1 c2) <= size cs ?= iff (cs == lhanoi3 c1 c2). 162 | Proof. 163 | (* we adapt the proof for the standard ha 164 | noi problem 165 | surely a shorter proof exists *) 166 | have [m sLm] := ubnP (size cs); elim: m => // m IHm in n c1 c2 cs sLm *. 167 | (* The usual induction on the number of disks *) 168 | elim : n c1 c2 cs sLm => [c1 p [|] //=|n IH c1 c cs Scs c1Pcs lc1csEp /=]. 169 | set (p := c ldisk). 170 | rewrite !fun_if !size_cat /= !size_cat /= !size_map. 171 | case: (c1 _ =P p) => [lc1Ep |/eqP lc1Dp]. 172 | (* the largest disk is already well-placed *) 173 | have [cs1 [c1'Pcs1 lc1'csElc1cs' /leqifP]] := 174 | pathS_restrict (@lirr 3) c1Pcs. 175 | have lc1'cs1E : last ↓[c1] cs1 = ↓[c]. 176 | by rewrite lc1'csElc1cs'; congr cunliftr. 177 | case: eqP=> [csEcs1 /eqP<- |/eqP csDcs1 scs1L]. 178 | rewrite csEcs1 lc1Ep eq_map_liftr. 179 | apply: IH => //. 180 | by move: Scs; rewrite csEcs1 size_map. 181 | apply/leqifP; case: eqP => [->//|_]. 182 | by rewrite size_map. 183 | apply: leq_ltn_trans (scs1L). 184 | apply: IH => //. 185 | by apply: ltn_trans Scs. 186 | pose f (c : configuration 3 n.+1) := c ldisk. 187 | have HHr := @lirr 3. 188 | have HHs := @lsym 3. 189 | (* We need to move the largest disk *) 190 | case: path3SP c1Pcs => // [c1' cs' p1 csE c1'Ecs1'| 191 | cs1 cs2 p1 p2 p3 c1' c2 p1Dp2 p1Rp2 192 | lc1'cs1Epp3 csE c1'Pcs1 c2Pcs2 _]. 193 | (* this case is impossible the largest disk has to move *) 194 | case/eqP: lc1Dp. 195 | move: lc1csEp => /(congr1 f). 196 | by rewrite /f csE -{1}[c1]cunliftrK last_map cliftr_ldisk. 197 | (* c4 is the first configuration when the largest disk has moved *) 198 | rewrite csE size_cat -/p1. 199 | have Scs1 : size cs1 < m.+1. 200 | apply: ltn_trans Scs. 201 | by rewrite csE size_cat /= size_map addnS ltnS leq_addr. 202 | have Scs2 : size cs2 < m.+1. 203 | apply: ltn_trans Scs. 204 | by rewrite csE size_cat /= size_map addnS ltnS leq_addl. 205 | have [p1Rp| p1NRp] := boolP (lrel p1 p). 206 | case: (p2 =P p) => [p2Ep|/eqP p2Dp]. 207 | (* the first moves of largest disk of cs is the right one *) 208 | rewrite -p2Ep -/p3 size_map /=. 209 | have/(pathS_restrict (@lirr 3))[cs2' [c2'Pcs2' lc2'cs2'E cs2'L]] := c2Pcs2. 210 | have Scs2' : size cs2' < m.+1. 211 | by apply: leq_ltn_trans Scs2; rewrite cs2'L. 212 | have /IH := lc1'cs1Epp3 => // /(_ Scs1 c1'Pcs1) IHc1. 213 | have /IH : last ↓[c2] cs2' = ↓[c] 214 | => [| /(_ Scs2' c2'Pcs2') IHc2]. 215 | rewrite lc2'cs2'E; congr cunliftr. 216 | by move: lc1csEp; rewrite csE last_cat /= => ->. 217 | rewrite cliftrK in IHc2. 218 | move /leqifP : cs2'L. 219 | case: eqP => [cs2E _ | /eqP cs2D Lcs2]. 220 | (* there is only one move of the largest disk in cs *) 221 | rewrite cs2E size_map cliftr_ldisk /=. 222 | have /leqifP := IHc1; case: eqP => [->_ |_ Lc1]. 223 | (* the first part of cs is perfect *) 224 | have /leqifP := IHc2; case: eqP => [->_ |_ Lc2]. 225 | (* the second part of cs is perfect, only case of equality *) 226 | apply/leqifP; case: eqP => [/(congr1 size)|[]]. 227 | by rewrite !size_cat /= !size_map => ->. 228 | by congr (_ ++ _ :: _); rewrite !cliftK. 229 | apply/leqifP; case: eqP => [/(congr1 size)|_]. 230 | by rewrite size_cat /= size_cat /= !size_map => ->. 231 | by rewrite ltn_add2l ltnS. 232 | apply/leqifP; case: eqP => [/(congr1 size)|_]. 233 | by rewrite !size_cat /= !size_map => ->. 234 | by rewrite -addSn leq_add // ltnS IHc2. 235 | apply/leqifP; case: eqP => [/(congr1 size)|_]. 236 | by rewrite !size_cat /= !size_map => ->. 237 | rewrite -addnS leq_add //= ?ltnS. 238 | by rewrite IHc1. 239 | by apply: leq_ltn_trans Lcs2; rewrite IHc2. 240 | (* The largest disk jumped to an intermediate peg *) 241 | have p3Ep : p3 = p by apply/eqP; rewrite opeg3E // lc1Dp. 242 | have p1Dp : p1 != p by rewrite eq_sym -p3Ep opeg3E // eqxx. 243 | (* cs cannot be optimal *) 244 | apply/leqifP; case: eqP => [/(congr1 size)|_]. 245 | by rewrite !size_cat /= !size_map => ->. 246 | case: path3SP c2Pcs2 => // [c2' cs2' p2' cs2E c2'Pcs2' _| 247 | cs3 cs4 p4 p5 p6 c2' c3 248 | p4Dp5 p4Rp5 lc2'cs3Epp6 cs2E c2'Pcs3 c3Pcs4 _]. 249 | (* this is impossible we need another move of the largest disk *) 250 | case/eqP: p2Dp. 251 | have := lc1csEp. 252 | rewrite csE last_cat /= cs2E -[c2]cunliftrK last_map => /(congr1 f). 253 | by rewrite /f !cliftr_ldisk. 254 | (* cs has a duplicate *) 255 | have p4Ep2 : p4 = p2 by rewrite /p4 !cliftr_ldisk. 256 | have p5Ep1: p5 = p1. 257 | apply: (@lrel3ON4 p1 p p2 p5) => //; first by rewrite eq_sym. 258 | by rewrite -p4Ep2. 259 | have p6Ep3 : p6 = p3. 260 | by apply/eqP; rewrite /p6 opeg3E // p4Ep2 p5Ep1 p3Ep p2Dp. 261 | (* exhibit a shortest path *) 262 | pose cs5 := [seq ↑[i]_p1 | i <- cs1] ++ cs4. 263 | have scs5Lscs : size cs5 < size cs. 264 | rewrite /cs5 csE cs2E !size_cat /= !size_cat /= !size_map. 265 | by rewrite ltn_add2l // !addnS! ltnS -addSn leq_addl. 266 | have c1Mcs5 : path lmove c1 cs5. 267 | rewrite cat_path -{1}[c1]cunliftrK /= !path_liftr //=. 268 | rewrite c1'Pcs1. 269 | rewrite -{1}[c1]cunliftrK last_map lc1'cs1Epp3 //. 270 | by rewrite -p6Ep3 -/p1 -p5Ep1. 271 | have lc1cs5E : last c1 cs5 = c. 272 | rewrite last_cat. 273 | rewrite -[c1]cunliftrK last_map lc1'cs1Epp3 //. 274 | rewrite -p6Ep3 -/p1 -p5Ep1 //. 275 | have := lc1csEp. 276 | by rewrite csE cs2E last_cat /= last_cat. 277 | apply: leq_trans (_ : size cs5 < _); last first. 278 | by rewrite cs2E /= !size_cat /= !size_map ltn_add2l //= 279 | ltnS -addSnnS leq_addl. 280 | rewrite ltnS. 281 | have /IHm : size cs5 < m. 282 | rewrite -ltnS. 283 | by apply: leq_ltn_trans Scs. 284 | move=> /(_ c1 c c1Mcs5 lc1cs5E) /=. 285 | by rewrite /= (negPf lc1Dp) p1Rp -/p1 size_cat /= !size_map => ->. 286 | have p2Dp : p2 != p by apply: contra p1NRp => /eqP<-. 287 | have p3Ep : p3 = p. 288 | by apply/eqP; rewrite opeg3E // lc1Dp. 289 | case: path3SP c2Pcs2 => // [c2' cs2' p2' cs2E c2'Pcs2' _| 290 | cs3 cs4 p4 p5 p6 c2' c3 291 | p4Dp5 p4Rp5 lc2'cs3Epp6 cs2E c2'Pcs3 c3Pcs4 _]. 292 | (* this is impossible at least two moves to reach p *) 293 | case/eqP: p2Dp. 294 | move: lc1csEp. 295 | rewrite csE cs2E last_cat /= -[c2]cunliftrK last_map !cliftr_ldisk. 296 | by move => /(congr1 f); rewrite /f !cliftr_ldisk. 297 | rewrite cs2E /= size_cat !size_map /=. 298 | have Scs3 : size cs3 < m.+1. 299 | by apply: leq_trans Scs2; rewrite ltnS cs2E size_cat /= size_map leq_addr. 300 | have Scs4 : size cs4 < m.+1. 301 | by apply: leq_trans Scs2; rewrite ltnS cs2E size_cat /= -addSnnS leq_addl. 302 | have p4Ep2 : p4 = p2 by rewrite [LHS]cliftr_ldisk. 303 | case: (p5 =P p1) => [p5Ep1|/eqP p5Dp1]. 304 | (* cs has a duplicate *) 305 | apply/leqifP; case: eqP => [/(congr1 size)|_]. 306 | rewrite !size_cat /= size_cat !size_map size_cat /= !size_map => ->. 307 | by rewrite !(addSn, addnS) addnA. 308 | have p6Ep3 : p6 = p3. 309 | by rewrite /p6 /p3 opeg_sym; congr opeg. 310 | have lc1'cs1Ec3 : cliftr p1 (last c1' cs1) = c3. 311 | by rewrite lc1'cs1Epp3 -p6Ep3 -p5Ep1. 312 | (* exhibit a shortest path *) 313 | pose cs5 := [seq ↑[i]_p1 | i <- cs1] ++ cs4. 314 | have scs5Lscs : size cs5 < size cs. 315 | rewrite /cs5 csE cs2E !size_cat /= !size_cat /= !size_map. 316 | by rewrite ltn_add2l // addnS !ltnS -addSn leq_addl. 317 | have c1Mcs5 : path lmove c1 cs5. 318 | rewrite cat_path -{1}[c1]cunliftrK /= !path_liftr //=. 319 | rewrite c1'Pcs1. 320 | rewrite -{1}[c1]cunliftrK last_map lc1'cs1Epp3 //. 321 | by rewrite -p6Ep3 -/p1 -p5Ep1. 322 | have lc1cs5E : last c1 cs5 = c. 323 | rewrite last_cat. 324 | rewrite -[c1]cunliftrK last_map lc1'cs1Epp3 //. 325 | rewrite -p6Ep3 -/p1 -p5Ep1 //. 326 | have := lc1csEp. 327 | by rewrite csE cs2E last_cat /= last_cat. 328 | apply: leq_trans (_ : size cs5 < _); last first. 329 | by rewrite !size_cat /= !size_map ltn_add2l //= ltnS -addSnnS leq_addl. 330 | have /IHm : size cs5 < m. 331 | rewrite -ltnS. 332 | by apply: leq_ltn_trans Scs. 333 | move=> /(_ c1 c c1Mcs5 lc1cs5E) /=. 334 | rewrite /= (negPf lc1Dp) (negPf p1NRp) -/p1 ltnS. 335 | by rewrite !size_cat /= size_cat /= !size_map => ->. 336 | have p5Ep : p5 = p. 337 | by apply/eqP; rewrite eq_sym -p3Ep opeg3E // eq_sym p5Dp1 -p4Ep2. 338 | have p2Ep1p : p2 = opeg p1 p. 339 | by apply/eqP; rewrite eq_sym opeg3E // p1Dp2 eq_sym p2Dp. 340 | have p6Ep1 : p6 = p1. 341 | by apply/eqP; rewrite opeg3E // p4Ep2 eq_sym p1Dp2. 342 | case: path3SP c3Pcs4 => // [c3' cs4' p8 cs4E c3'Pcs4' _| 343 | cs5 cs6 p8 p9 p10 c3' c4 344 | p8Dp9 p8Rp9 lc3'cs5Epp10 cs4E c3'Pcs5 c4Pcs6 _]. 345 | have Scs4' : size cs4' < m.+1 by rewrite cs4E size_map in Scs4. 346 | rewrite cs4E size_map. 347 | rewrite csE cs2E last_cat /= last_cat /= 348 | -[c3]cunliftrK cs4E last_map in lc1csEp. 349 | have /(congr1 cunliftr) := lc1csEp. 350 | rewrite cliftrK => lc3'cs4'Ec'. 351 | have /IH := c1'Pcs1 => /(_ _ Scs1 lc1'cs1Epp3) IH1. 352 | rewrite p3Ep in IH1. 353 | have /IH := c2'Pcs3 => /(_ _ Scs3 lc2'cs3Epp6) IH2. 354 | rewrite [c2']cliftrK p3Ep p6Ep1 in IH2. 355 | have /IH := c3'Pcs4' => /(_ _ Scs4' lc3'cs4'Ec') IH3. 356 | rewrite [c3']cliftrK p6Ep1 in IH3. 357 | move /leqifP : IH1. 358 | case: eqP => [E1 _ | /eqP cs1D Lcs1]. 359 | (* the first part cs1 is perfect *) 360 | have /leqifP := IH2; case: eqP => [E2 _ |_ Lc1]. 361 | (* the second part cs3 is perfect *) 362 | have /leqifP := IH3; case: eqP => [E3 _ |_ Lc2]. 363 | (* the third part cs4 is perfect, only case of equality *) 364 | apply/leqifP; case: eqP => [/(congr1 size)|[]]. 365 | rewrite !size_cat /= size_cat /= size_cat /= !size_map => ->. 366 | by rewrite !(addSn, addnS) addnA. 367 | congr (_ ++ _ :: _ ++ _ :: _). 368 | - by rewrite E1. 369 | - by rewrite /c2 p3Ep p2Ep1p. 370 | - by rewrite p4Ep2 -p2Ep1p E2. 371 | - by rewrite /c3 p6Ep1 p5Ep. 372 | - congr (map (cliftr _) _). 373 | by rewrite /p8 !cliftr_ldisk. 374 | by []. 375 | apply/leqifP; case: eqP => [/(congr1 size)|_]. 376 | rewrite !size_cat /= !size_cat /= !size_map => ->. 377 | by rewrite !(addSn, addnS) addnA. 378 | by rewrite E1 E2 !(addSn, addnS) !ltnS !ltn_add2l. 379 | apply/leqifP; case: eqP => [/(congr1 size)|_]. 380 | rewrite !size_cat /= !size_cat /= !size_map => ->. 381 | by rewrite !(addSn, addnS) addnA. 382 | rewrite E1 !(addSn, addnS) !ltnS !ltn_add2l. 383 | apply: leq_ltn_trans (_ : _ <= size (lhanoi3 `c[p, n] `c[p1]) 384 | + size cs4') _. 385 | by rewrite leq_add2l IH3. 386 | by rewrite ltn_add2r. 387 | apply/leqifP; case: eqP => [/(congr1 size)|_]. 388 | rewrite !size_cat /= !size_cat /= !size_map => ->. 389 | by rewrite !(addSn, addnS). 390 | by rewrite !(addSn, addnS) !ltnS -addSn !leq_add ?IH2 ?IH3. 391 | (* three moves in a row -> duplicate *) 392 | have p8Ep : p8 = p by rewrite [LHS]cliftr_ldisk. 393 | have p9Ep2 : p9 = p2. 394 | apply: lrel3ON4 p8Rp9. 395 | - by rewrite eq_sym; exact: p1Dp2. 396 | - by rewrite p8Ep. 397 | - by rewrite p8Ep. 398 | - by rewrite lsym. 399 | by rewrite p8Ep -p4Ep2 -p5Ep. 400 | have p10Ep1 : p10 = p1. 401 | by apply/eqP; rewrite opeg3E // p8Ep eq_sym lc1Dp p9Ep2 eq_sym. 402 | have cc : cliftr p2 (last c2' cs3) = c4. 403 | by rewrite /c4 lc2'cs3Epp6 p6Ep1 p10Ep1 p9Ep2. 404 | apply/leqifP; case: eqP => [/(congr1 size)|_]. 405 | rewrite !size_cat /= size_cat !size_map size_cat /= !size_map => ->. 406 | by rewrite !(addSn, addnS). 407 | (* exhibit a shortest path *) 408 | pose cs7 := [seq ↑[i]_p1 | i <- cs1] ++ c2 :: [seq ↑[i]_p4 | i <- cs3] ++ cs6. 409 | have scs7Lscs7: size cs7 < size cs. 410 | rewrite /cs7 csE cs2E cs4E. 411 | rewrite size_cat /= size_cat /= size_cat /= size_cat /= size_cat /= !size_map. 412 | by rewrite !addnS ltnS -!addnS !leq_add2l addnS ltnS -addSnnS leq_addl. 413 | have c1Mcs7 : path lmove c1 cs7. 414 | rewrite cat_path -{1}[c1]cunliftrK /= !path_liftr //=. 415 | rewrite c1'Pcs1. 416 | rewrite -{1}[c1]cunliftrK last_map lc1'cs1Epp3 //. 417 | rewrite p4Ep2 cat_path /c2 -/p1 /=. 418 | apply/and3P; split => //. 419 | - apply: move_liftr_perfect => //. 420 | by rewrite eq_sym opegDl. 421 | by rewrite eq_sym opegDr. 422 | by rewrite path_liftr //; rewrite [c2']cliftrK in c2'Pcs3. 423 | by rewrite last_map; rewrite [c2']cliftrK in cc; rewrite cc. 424 | have lc1cs7E : last c1 cs7 = c. 425 | rewrite last_cat /= last_cat p4Ep2. 426 | rewrite -[c2]cunliftrK !cliftr_ldisk. 427 | rewrite last_map lc2'cs3Epp6. 428 | have := lc1csEp. 429 | rewrite csE cs2E cs4E last_cat /= last_cat /= last_cat /=. 430 | by rewrite /c4 p10Ep1 p6Ep1 p9Ep2. 431 | apply: leq_trans (_ : size cs7 < _); last first. 432 | rewrite !size_cat /= size_cat /= !size_map ltn_add2l //=. 433 | rewrite cs4E size_cat /= size_map !addnS !ltnS -addnS -addSn. 434 | by rewrite leq_add2l leq_addl. 435 | have /IHm : size cs7 < m. 436 | rewrite -ltnS. 437 | by apply: leq_ltn_trans Scs. 438 | move=> /(_ c1 c c1Mcs7 lc1cs7E) /=. 439 | rewrite /= (negPf lc1Dp) (negPf p1NRp) -/p1 ltnS. 440 | by rewrite size_cat /= size_cat /= !size_map => ->. 441 | Qed. 442 | 443 | (* size on a perfect configuration depends which peg we consider *) 444 | Lemma size_app_lhanoi3_p n p1 p2 : 445 | size (lhanoi3 `c[p1, n] `c[p2]) = 446 | if lrel p1 p2 then (3 ^ n).-1./2 else (3 ^ n).-1 * (p1 != p2). 447 | Proof. 448 | elim: n p1 p2 => [p1 p2|n IH p1 p2] /=; first by rewrite if_same. 449 | rewrite !ffunE; case: eqP => [p1Ep2|/eqP p1Dp2]. 450 | by rewrite !perfect_unliftr size_map IH p1Ep2 eqxx lirr !muln0. 451 | rewrite !perfect_unliftr !fun_if !size_cat /= !size_cat /= !size_map. 452 | rewrite !IH eq_sym opegDl // opegDr //= !muln1. 453 | have Hd : (3 ^ n.+1).-1 = (3 ^ n).-1 + (3 ^ n).*2. 454 | rewrite expnS -[3 ^n]prednK ?expn_gt0 //. 455 | by rewrite mulnS /= doubleS !addnS mulSn mul2n. 456 | rewrite ![lrel p2 _]lsym. 457 | case: (boolP (lrel _ _)) => [Hrel1|Hrel1]; last first. 458 | rewrite [p2 == _]eq_sym p1Dp2 !muln1. 459 | rewrite expnS !mulSn addn0. 460 | by case: expn (expn_gt0 3 n) => // k _; rewrite !addnS addnA. 461 | case: (boolP (lrel _ _)) => [Hrel2|Hrel2]. 462 | rewrite !ifN. 463 | by rewrite Hd halfD /= odd_double andbF add0n doubleK prednK ?expn_gt0. 464 | by have := lrel3B p1Dp2; rewrite Hrel1 Hrel2 lsym. 465 | rewrite ifT; last by rewrite lsym; apply: lrel3ON. 466 | rewrite Hd halfD /= odd_double andbF add0n doubleK -addSnnS addnC. 467 | by rewrite prednK // expn_gt0. 468 | Qed. 469 | 470 | Fixpoint size_lhanoi3 {n : nat} : configuration 3 n -> configuration 3 n -> _ := 471 | match n with 472 | | 0 => fun _ _ => 0 473 | | n1.+1 => 474 | fun c1 c2 => 475 | let p1 := c1 ldisk in 476 | let p2 := c2 ldisk in 477 | if p1 == p2 then size_lhanoi3 ↓[c1] ↓[c2] else 478 | let p3 := `p[p1, p2] in 479 | if lrel p1 p2 then 480 | (size_lhanoi3 ↓[c1] `c[p3] + size_lhanoi3 `c[p3] ↓[c2]).+1 481 | else 482 | (size_lhanoi3 ↓[c1] `c[p2] + 483 | (3 ^ n1).-1 + 484 | size_lhanoi3 `c[p1] ↓[c2]).+2 485 | end. 486 | 487 | Lemma size_lhanoi3E n (c1 c2 : _ _ n) : 488 | size_lhanoi3 c1 c2 = size (lhanoi3 c1 c2). 489 | Proof. 490 | elim: n c1 c2 => //= n IH c1 c2. 491 | case: eqP => [lc1Elc2|/eqP lc1Dlc2]. 492 | by rewrite size_map IH. 493 | case: (boolP (lrel _ _)) => [lc1Rlc2|lc1NRlc2]. 494 | by rewrite size_cat /= !size_map !IH addnS. 495 | rewrite size_cat /= size_cat /= !size_map size_app_lhanoi3_p 496 | lsym (negPf lc1NRlc2). 497 | by rewrite eq_sym (negPf lc1Dlc2) muln1 !addnS addnA !IH. 498 | Qed. 499 | 500 | (* size on a perfect configuration depends which peg we consider *) 501 | Lemma size_lhanoi3_p n p1 p2 : 502 | size_lhanoi3 `c[p1, n] `c[p2] = 503 | if lrel p1 p2 then (3 ^ n).-1./2 else (3 ^ n).-1 * (p1 != p2). 504 | Proof. by rewrite size_lhanoi3E size_app_lhanoi3_p. Qed. 505 | 506 | Lemma gdist_lhanoi3_size n (c1 c2 : _ _ n) : 507 | `d[c1, c2]_lmove = size_lhanoi3 c1 c2. 508 | Proof. 509 | apply/eqP; rewrite eqn_leq [size_lhanoi3 _ _]size_lhanoi3E. 510 | rewrite gdist_path_le //=; last 2 first. 511 | - by apply: path_lhanoi3. 512 | - by apply: last_lhanoi3. 513 | have /gpath_connect[p1 p1H] : connect lmove c1 c2 by apply: move_lconnect3. 514 | rewrite (gpath_dist p1H) lhanoi3_min //; first by apply: gpath_path p1H. 515 | by apply: gpath_last p1H. 516 | Qed. 517 | 518 | Lemma gdist_lhanoi3p n (p1 p2 : peg 3) : 519 | `d[`c[p1, n], `c[p2, n]]_lmove = 520 | if lrel p1 p2 then (3 ^ n).-1./2 else (3 ^ n).-1 * (p1 != p2). 521 | Proof. by rewrite gdist_lhanoi3_size size_lhanoi3_p. Qed. 522 | 523 | End LHanoi3. 524 | -------------------------------------------------------------------------------- /meta.yml: -------------------------------------------------------------------------------- 1 | --- 2 | fullname: hanoi 3 | shortname: hanoi 4 | organization: thery 5 | community: false 6 | dune: false 7 | action: true 8 | 9 | synopsis: Hanoi tower in Coq 10 | 11 | description: |- 12 | Hanoi tower in Coq 13 | 14 | 15 | | File | Content | 16 | | --------------------------------- | -----------------------------------------| 17 | | [extra](./extra.v) | Extra theorems from the standard library | 18 | | [gdist](./gdist.v) | Distance in a graph | 19 | | [ghanoi](./ghanoi.v) | General Hanoi framework | 20 | | [ghanoi3](./ghanoi3.v) | General Hanoi framework with 3 pegs | 21 | | [lhanoi3](./lhanoi3.v) | Linear Hanoi tower with 3 pegs | 22 | | [rhanoi3](./rhanoi3.v) | Regular Hanoi tower with 3 pegs | 23 | | [triangular](./triangular.v) | Theorems about triangular numbers | 24 | | [phi](./phi.v) | Theorems about the Φ function | 25 | | [psi](./psi.v) | Theorems about the Ψ function | 26 | | [ghanoi4](./ghanoi4.v) | General Hanoi framework with 4 pegs | 27 | | [rhanoi4](./rhanoi4.v) | Regular Hanoi tower with 4 pegs | 28 | | [star](./star.v) | Some maths for the shanoi | 29 | | [shanoi](./shanoi.v) | Hanoi tower in star | 30 | | [shanoi4](./shanoi4.v) | Hanoi tower with 4 pegs in star | 31 | 32 | A note about this development is available 33 | [here](https://hal.inria.fr/hal-02903548). 34 | 35 | An interactive version of the library is available 36 | [here](https://thery.github.io/hanoi/index.html). 37 | 38 | 39 | authors: 40 | - name: Laurent Théry 41 | 42 | maintainers: 43 | - name: Laurent Théry 44 | nickname: thery 45 | 46 | opam-file-maintainer: thery@sophia.inria.fr 47 | 48 | license: 49 | fullname: MIT License 50 | identifier: MIT 51 | 52 | supported_coq_versions: 53 | text: '9.0 or later' 54 | opam: '{(>= "9.0")}' 55 | 56 | dependencies: 57 | - opam: 58 | name: coq-mathcomp-ssreflect 59 | version: '{(>= "2.4.0")}' 60 | description: |- 61 | [MathComp ssreflect 2.4 or later](https://math-comp.github.io) 62 | - opam: 63 | name: coq-mathcomp-algebra 64 | version: '{(>= "2.4.0")}' 65 | description: |- 66 | [MathComp algebra 2.4 or later](https://math-comp.github.io) 67 | - opam: 68 | name: coq-mathcomp-finmap 69 | version: '{(>= "2.2.1")}' 70 | description: |- 71 | [MathComp finmap 2.2.1 or later](https://github.com/math-comp/finmap) 72 | 73 | 74 | tested_coq_opam_versions: 75 | - version: '2.4.0-rocq-prover-9.0' 76 | repo: 'mathcomp/mathcomp' 77 | 78 | namespace: hanoi 79 | 80 | keywords: 81 | - name: hanoi tower 82 | 83 | 84 | --- -------------------------------------------------------------------------------- /phi.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* *) 3 | (* PHI *) 4 | (* *) 5 | (* phi n = \sum_(i < n) 2 ^ troot n *) 6 | (* *) 7 | (* *) 8 | (******************************************************************************) 9 | 10 | From mathcomp Require Import all_ssreflect. 11 | From hanoi Require Import triangular. 12 | 13 | Set Implicit Arguments. 14 | Unset Strict Implicit. 15 | Unset Printing Implicit Defensive. 16 | 17 | Definition phi n := foldr (addn \o (fun i => 2 ^ troot i)) 0 (iota 0 n). 18 | 19 | Notation "'ϕ' n" := (phi n) (format "'ϕ' n", at level 0). 20 | 21 | Compute zip (iota 0 11) (map phi (iota 0 11)). 22 | 23 | Lemma phiE n : phi n = \sum_(i < n) 2 ^ troot i. 24 | Proof. 25 | rewrite -(@big_mkord _ _ _ _ predT (fun i => 2 ^ (troot i))). 26 | rewrite unlock /reducebig /phi. 27 | by rewrite /index_iota subn0. 28 | Qed. 29 | 30 | Lemma phiS n : phi n.+1 = phi n + 2 ^ (troot n). 31 | Proof. by rewrite !phiE big_ord_recr. Qed. 32 | 33 | Lemma phi_le m n : m <= n -> phi m <= phi n. 34 | Proof. 35 | elim: n m => [[] //|n IH m]. 36 | rewrite leq_eqVlt => /orP[/eqP->//|/IH /leq_trans->//]. 37 | by rewrite phiS leq_addr. 38 | Qed. 39 | 40 | Lemma phi_gt0 n : (0 < phi n) = (0 < n). 41 | Proof. by case: n. Qed. 42 | 43 | Lemma phi_deltaD n p : 44 | p <= n.+1 -> phi (delta n + p) = 1 + (n + p) * 2 ^ n - 2 ^ n. 45 | Proof. 46 | elim: n p => [|n IHn]; first by case => // [] [|p]. 47 | elim => [_|p IHp pLn]. 48 | rewrite !addn0 deltaS IHn // -addnBA; last first. 49 | by rewrite -[X in X <= _]mul1n leq_mul2r addnS orbT. 50 | rewrite -[X in _ + (_ - X)]mul1n -mulnBl addnS subn1 /=. 51 | rewrite addnn -muln2 -mulnA -expnS. 52 | rewrite -{1}[n]subn0 -subSS mulnBl mul1n addnBA //. 53 | by rewrite -[X in X <= _]mul1n leq_mul2r orbT. 54 | rewrite addnS phiS IHp 1?ltnW //. 55 | rewrite (_ : troot _ = n.+1). 56 | rewrite subnK. 57 | by rewrite addnS mulSn [X in _ = _ + X - _]addnC addnA addnK. 58 | by rewrite [_ + p]addSn mulSn addnC -addnA leq_addr. 59 | by apply/eqP; rewrite trootE leq_addr [delta _.+2]deltaS ltn_add2l. 60 | Qed. 61 | 62 | Fact phi_simpl a n p q : 63 | 0 < n -> a + (n + p) * 2 ^ q - 2 ^ q = a + (n.-1 + p) * 2 ^ q. 64 | Proof. 65 | case: n => // n _. 66 | rewrite -addnBA; last by rewrite addSn mulSn leq_addr. 67 | by rewrite [_ + p]addSn mulSn [2 ^ _ + _]addnC addnK. 68 | Qed. 69 | 70 | Fact phi_simpr a n p q : 71 | 0 < p -> a + (n + p) * 2 ^ q - 2 ^ q = a + (n + p.-1) * 2 ^ q. 72 | Proof. by move=> H; rewrite ![n + _]addnC phi_simpl. Qed. 73 | 74 | Lemma phi_modE n : 75 | phi n = 1 + (troot n + tmod n) * 2 ^ (troot n) - 2 ^ (troot n). 76 | Proof. by rewrite {1}[n]tmodE phi_deltaD // ltnW // ltnS tmod_le. Qed. 77 | 78 | Lemma phi_deltaE n : 79 | phi (delta n) = 1 + n * 2 ^ n - 2 ^ n. 80 | Proof. by rewrite phi_modE troot_delta tmod_delta addn0. Qed. 81 | 82 | Lemma phi_modSE n : 83 | phi n.+1 = 1 + (troot n + tmod n) * 2 ^ (troot n). 84 | Proof. 85 | rewrite phi_modE. 86 | have /orP[/andP[/eqP-> /eqP->]| 87 | /and3P[/eqP->/eqP->/eqP]->] := troot_mod_case n. 88 | by rewrite addnS mulSn addnCA [2 ^ _ + _]addnC addnK. 89 | rewrite addn0 mulSn addnCA [2 ^ _ + _]addnC addnK. 90 | by rewrite expnS addnn -mul2n mulnCA mulnA. 91 | Qed. 92 | 93 | Lemma phi_odd n : odd (phi n) = (0 < n). 94 | Proof. 95 | case: n => // [] [|n] //. 96 | rewrite phi_modSE oddD oddM oddX orbF. 97 | case: troot (troot_gt0 (isT : 0 < n.+1)) => // k. 98 | by rewrite andbF. 99 | Qed. 100 | 101 | Definition g n m := (phi m).*2 + (2 ^ (n - m)).-1. 102 | 103 | Definition gmin n := delta (troot n).-1 + tmod n. 104 | 105 | Lemma gmin_gt0 n : 1 < n -> 0 < gmin n. 106 | Proof. 107 | case: n => [|[|[|n _]]] //. 108 | apply: leq_trans (leq_addr _ _). 109 | have /troot_le : 3 <= n.+3 by []. 110 | rewrite -[troot 3]/(2). 111 | case: troot => //= m. 112 | by rewrite ltnS => /delta_le. 113 | Qed. 114 | 115 | Lemma gminE n : n = gmin n + troot n. 116 | Proof. 117 | case: n => //= n. 118 | rewrite {1}[n.+1]tmodE /gmin. 119 | case: troot (troot_gt0 (isT : 0 < n.+1)) => // t _. 120 | by rewrite deltaS addnAC. 121 | Qed. 122 | 123 | Lemma gmin_le n : gmin n <= n. 124 | Proof. by rewrite {2}[n]gminE leq_addr. Qed. 125 | 126 | Lemma gmin_lt n : 0 < n -> gmin n < n. 127 | Proof. 128 | case: n => // n _. 129 | rewrite {2}[n.+1]gminE -[X in X < _]addn0 ltn_add2l. 130 | by apply: troot_gt0. 131 | Qed. 132 | 133 | Lemma gmin_root n : troot (gmin n) = troot n - (tmod n != troot n). 134 | Proof. 135 | have [/eqP mEt|mDt] := boolP (tmod n == troot n). 136 | rewrite /gmin -mEt subn0. 137 | by case: tmod => //= t; rewrite -deltaS troot_delta. 138 | have mLt : tmod n < troot n by rewrite ltn_neqAle mDt tmod_le. 139 | rewrite subn1. 140 | apply/eqP; rewrite /gmin trootE. 141 | case: n {mDt}mLt => // [] [|] // n mLt. 142 | case: troot mLt => // t mLt. 143 | by rewrite leq_addr deltaS ltn_add2l. 144 | Qed. 145 | 146 | Lemma gmin_mod n : tmod (gmin n) = (tmod n != troot n) * tmod n. 147 | Proof. 148 | have [/eqP mEt|mDt] := boolP (tmod n == troot n). 149 | rewrite mul0n /gmin -mEt. 150 | case: (tmod n) => // t. 151 | by rewrite -deltaS tmod_delta. 152 | have mLt : tmod n < troot n by rewrite ltn_neqAle mDt tmod_le. 153 | by rewrite mul1n /tmod {1}/gmin gmin_root mDt subn1 addnC addnK. 154 | Qed. 155 | 156 | Lemma gmin_root_lt m n : m < gmin n -> troot m < troot n. 157 | Proof. 158 | move=> mLg. 159 | have nP : 0 < n by case: n mLg. 160 | case: leqP => //; rewrite leq_eqVlt => /orP[/eqP tnEtm| /ltn_root]; last first. 161 | by rewrite ltnNge (leq_trans _ (gmin_le _)) // ltnW. 162 | have /eqP tnEtg : troot n == troot (gmin n). 163 | by rewrite eqn_leq {1}tnEtm !troot_le // ?gmin_le // ltnW. 164 | have: tmod m < tmod (gmin n) by rewrite ltn_mod // -tnEtg. 165 | suff : tmod (gmin n) = 0 by move->. 166 | rewrite gmin_mod. 167 | have := gmin_root n; case: eqP => //. 168 | rewrite -tnEtg subn1 => _ F. 169 | have := ltnn (troot n). 170 | by rewrite -{2}(prednK (troot_gt0 nP)) -F leqnn. 171 | Qed. 172 | 173 | Lemma phi_gmin n : phi n = g n (gmin n). 174 | Proof. 175 | case: n => // n. 176 | rewrite {1}phi_modE /g /gmin. 177 | rewrite phi_deltaD; last by rewrite prednK // tmod_le. 178 | set x := troot _; set y := tmod _. 179 | rewrite phi_simpl //. 180 | rewrite doubleB doubleD -!muln2 -!mulnA -!expnSr !prednK //. 181 | have ->: n.+1 = delta x.-1 + x + y. 182 | by rewrite -{2}[x]prednK // -deltaS prednK // -tmodE. 183 | rewrite [_ + x + y]addnAC [_ + x]addnC addnK. 184 | rewrite {}/x {}/y. 185 | case: n => // [] [|n] //. 186 | rewrite phi_simpl //. 187 | rewrite -[_.-1]prednK // addSn. 188 | case: expn (expn_gt0 2 (troot n.+3)) => // u __. 189 | by rewrite addSn mulSn add0n -addSn addnAC. 190 | Qed. 191 | 192 | Lemma gS n m : m.+1 < n -> g n m.+1 + 2 ^ (n - m.+1) = g n m + 2 ^ (troot m).+1. 193 | Proof. 194 | move=> H; rewrite /g !phi_modE. 195 | rewrite phi_simpl; last by rewrite troot_gt0. 196 | rewrite -[n - m]prednK; last first. 197 | by rewrite subn_gt0 (leq_trans _ H). 198 | rewrite -subnS expnS mul2n -[(2 ^ _).*2]addnn. 199 | have := troot_mod_case m. 200 | case/orP=> [/andP[/eqP H1 /eqP H2]|/and3P[/eqP H1 /eqP H2 /eqP H3]]. 201 | rewrite /g H1 H2 phi_simpl; last by rewrite -H1 troot_gt0. 202 | rewrite addnS mulSnr !addnA doubleD -!addnA; congr (_ + _). 203 | rewrite -mul2n -expnS addnC; congr (_ + _). 204 | by case: (_ ^ _). 205 | rewrite H1 H2 H3 addnn addn0 /=. 206 | set x := troot _; set y := n - _. 207 | rewrite doubleB [in RHS]addnAC -[(2 ^ _).*2]mul2n -expnS subnK; last first. 208 | rewrite expnS mul2n leq_double. 209 | by case: x => //= x; rewrite doubleS mulSnr addnA leq_addl. 210 | rewrite -[x.*2]muln2 -mulnA -expnS -addnA; congr (_ +_). 211 | by case: expn (expn_gt0 2 y). 212 | Qed. 213 | 214 | Lemma gS_minl n m : m < gmin n -> g n m.+1 <= g n m. 215 | Proof. 216 | case: n => // n mLg. 217 | have mLn : m < n. 218 | by rewrite -ltnS; apply: leq_trans (gmin_lt _). 219 | suff mtLm : m.+1 + troot m <= n. 220 | rewrite -(leq_add2r (2 ^ (n.+1 - m.+1))) (gS _) //. 221 | by rewrite leq_add2l leq_pexp2l // ltn_subRL. 222 | rewrite (leq_trans (_ : _ <= gmin n.+1 + troot m)) //. 223 | by rewrite leq_add2r. 224 | rewrite -ltnS -addnS. 225 | rewrite /gmin {3}[n.+1]tmodE addnAC leq_add2r. 226 | have : 0 < troot n.+1 by apply troot_gt0. 227 | case E : troot => [|t] _ //; rewrite [X in X <= _]/=. 228 | rewrite deltaS -E leq_add2l. 229 | by apply: gmin_root_lt. 230 | Qed. 231 | 232 | Lemma gS_minr n m : gmin n <= m -> m.+1 < n -> g n m <= g n m.+1. 233 | Proof. 234 | move=> gLm mLn. 235 | suff mtLm : n <= m.+1 + (troot m).+1. 236 | rewrite -(leq_add2r (2 ^ (n - m.+1))) (gS _) //. 237 | by rewrite leq_add2l leq_pexp2l // leq_subLR. 238 | rewrite [n]gminE addSnnS leq_add //. 239 | apply: leq_trans (_ : (troot (gmin n)).+2 <= _). 240 | rewrite gmin_root; case: eqP; first by rewrite subn0 ltnW. 241 | by rewrite subn1; case: troot. 242 | by rewrite !ltnS troot_le. 243 | Qed. 244 | 245 | Lemma gmin_min n m : m < n -> g n (gmin n) <= g n m. 246 | Proof. 247 | move=> mLn. 248 | have [gLm|mLg] := leqP (gmin n) m. 249 | move: mLn; rewrite -(subnK gLm). 250 | elim: subn => // k IH H1. 251 | rewrite addSn (leq_trans (IH _) (gS_minr _ _)) ?leq_addl //. 252 | by apply: leq_trans H1; rewrite ltnS addSnnS leq_add2l. 253 | rewrite -(subKn (ltnW mLg)). 254 | elim: (gmin n - m) (leq_subr m (gmin n)) => [|k IH kLm]. 255 | by rewrite subn0. 256 | apply: leq_trans (IH (ltnW kLm)) _. 257 | rewrite -subSS subSn //. 258 | by rewrite gS_minl // -subSn // subSS leq_subr. 259 | Qed. 260 | 261 | (* This is (2.1) *) 262 | Lemma phi_leD a b : phi (a + b) <= (phi a).*2 + (2 ^ b).-1. 263 | Proof. 264 | case: b => [|b]; first by rewrite !addn0 -addnn leq_addr. 265 | rewrite phi_gmin -{3}[b.+1](addnK a _) [b.+1 + a]addnC. 266 | apply: gmin_min. 267 | by rewrite -addSnnS leq_addr. 268 | Qed. 269 | -------------------------------------------------------------------------------- /psi.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* *) 3 | (* PSI *) 4 | (* psi n = the psi function *) 5 | (* *) 6 | (* *) 7 | (* *) 8 | (******************************************************************************) 9 | 10 | From mathcomp Require Import all_ssreflect all_algebra finmap. 11 | From hanoi Require Import extra triangular phi. 12 | 13 | 14 | Set Implicit Arguments. 15 | Unset Strict Implicit. 16 | Unset Printing Implicit Defensive. 17 | Open Scope fset_scope. 18 | Open Scope nat_scope. 19 | 20 | 21 | Section BigFSetAux. 22 | 23 | Variable (R : Type) (idx : R) (op : Monoid.com_law idx). 24 | Variable (I J : choiceType). 25 | 26 | Lemma fsum_nat_const (e : {fset I}) a : \sum_(i <- e) a = #|` e| * a. 27 | Proof. by rewrite big_const_seq count_predT iter_addn_0 mulnC. Qed. 28 | 29 | Lemma diff_fset0_elem (e : {fset I}) : e != fset0 -> {i : I | i \in e}. 30 | Proof. 31 | by case: e => [] [|i l] iH //=; exists i; rewrite inE eqxx. 32 | Qed. 33 | 34 | (* Should be reworked *) 35 | Lemma eq_fbigmax (e : {fset I}) (F : I -> nat) : 36 | 0 < #|`e| -> {i0 : I | i0 \in e /\ \max_(i <- e) F i = F i0}. 37 | Proof. 38 | have [n cI] := ubnP #|`e|; elim: n => // n IH e cI in e cI *. 39 | rewrite cardfs_gt0 => /diff_fset0_elem[i iH]. 40 | have [|H] := leqP #|`(e `\ i)| 0. 41 | rewrite leqn0 cardfs_eq0 => /eqP eZ. 42 | exists i; split => //. 43 | rewrite (big_fsetD1 i) //= eZ big1_fset => [|j]; last by rewrite inE. 44 | by apply/maxn_idPl. 45 | case: (IH (e `\ i)) => // [|j [jIe jH]]. 46 | by move: cI; rewrite (cardfsD1 i) iH. 47 | have [FiLFj|FjLFi] := leqP (F i) (F j). 48 | exists j; split => //. 49 | by move: jIe; rewrite !inE => /andP[]. 50 | rewrite (big_fsetD1 i) //= jH. 51 | by apply/maxn_idPr. 52 | exists i; split. 53 | by move: jIe; rewrite !inE => /andP[]. 54 | rewrite (big_fsetD1 i) //= jH. 55 | by apply/maxn_idPl/ltnW. 56 | Qed. 57 | 58 | Lemma big_fsetD1cond (a : I) (A : {fset I}) (P : pred I) (F : I -> R) : 59 | a \in A -> P a -> 60 | \big[op/idx]_(i <- A | P i) F i = 61 | op (F a) (\big[op/idx]_(i <- A `\ a | P i) F i). 62 | Proof. 63 | move=> aA aP; rewrite (big_fsetIDcond _ (mem [fset a])). 64 | congr (op _ _); last first. 65 | by apply: eq_fbigl_cond => i; rewrite !inE /= [_ && (_ != _)]andbC. 66 | rewrite (_ : [fset _ | _ in _ & _] = [fset a]). 67 | rewrite big_seq_fsetE /= /index_enum /= -enumT enum_fset1 /=. 68 | by rewrite unlock /= aP Monoid.Theory.mulm1. 69 | by apply/fsetP=> i; rewrite !inE /= andbC; case: eqP => //->. 70 | Qed. 71 | 72 | End BigFSetAux. 73 | 74 | Section BigFSetAux. 75 | 76 | Variable (R : Type) (idx : R) (op : Monoid.com_law idx). 77 | Variable (I J : choiceType). 78 | 79 | Lemma bigfmax_leqP (P : pred I) (m : nat) (e : {fset I}) (F : I -> nat) : 80 | reflect (forall i : I, i \in e -> P i -> F i <= m) 81 | (\max_(i <- e | P i) F i <= m). 82 | Proof. 83 | apply: (iffP idP) => leFm => [i iIe Pi|]. 84 | move: leFm. 85 | rewrite (big_fsetD1cond _ _ _ Pi) //= => /(leq_trans _)-> //. 86 | by apply: leq_maxl. 87 | rewrite big_seq_cond. 88 | elim/big_ind: _ => //= [m1 m2 m1Lm m2Ln | i /andP[]]. 89 | by rewrite geq_max m1Lm. 90 | by apply: leFm. 91 | Qed. 92 | 93 | Lemma leq_bigfmax (e : {fset I}) (F : I -> nat) i : 94 | i \in e -> F i <= \max_(i <- e) F i. 95 | Proof. 96 | move=> iIe. 97 | have : i \in enum_fset e by []. 98 | elim: enum_fset => //= a l IH. 99 | rewrite inE big_cons => /orP[/eqP<-|/IH H]; first by apply: leq_maxl. 100 | by apply: leq_trans H _; apply: leq_maxr. 101 | Qed. 102 | 103 | End BigFSetAux. 104 | 105 | Section PsiDef. 106 | 107 | Implicit Type e : {fset nat}. 108 | 109 | Import Order.TTheory GRing.Theory Num.Theory. 110 | 111 | 112 | Open Scope fset_scope. 113 | 114 | Definition psi_aux l e : int := 115 | ((2 ^ l).-1 + (\sum_(i <- e) 2 ^ (minn (troot i) l)))%:R - (l * 2 ^ l)%:R. 116 | 117 | Notation "'ψ'' n" := (psi_aux n) (format "'ψ'' n", at level 0). 118 | 119 | Lemma psi_aux_0_ge0 e : (0 <= psi_aux 0 e)%R. 120 | Proof. by rewrite /psi_aux add0n mul0n subr0 (ler_nat _ 0). Qed. 121 | Lemma psi_aux_sub l e1 e2 : e1 `<=` e2 -> (psi_aux l e1 <= psi_aux l e2)%R. 122 | Proof. 123 | move=> e1Se2. 124 | apply: lerB => //. 125 | rewrite ler_nat. 126 | rewrite leq_add2l //. 127 | rewrite [X in _ <= X](bigID (fun i => i \in e1)) /=. 128 | suff iH : [fset x in e1 | xpredT x] =i [fset i in e2 | i \in e1]. 129 | by rewrite (eq_fbigl_cond _ _ iH) /= leq_addr. 130 | move=> i; rewrite !inE /=. 131 | have /fsubsetP/(_ i) := e1Se2. 132 | by case: (i \in e1) => [->//|]; rewrite andbF. 133 | Qed. 134 | 135 | Lemma psi_auxE_le l e : 136 | psi_aux l e = 137 | (((2 ^ l * #|`[fset i in e | (l <= troot i)%nat]|.+1).-1 138 | + (\sum_(i <- e | (troot i < l)%nat) 2 ^ troot i))%:R - (l * 2 ^ l)%:R)%R. 139 | Proof. 140 | rewrite /psi_aux. 141 | congr (_%:R - _%:R)%R. 142 | rewrite (big_fsetID _ [pred i | l <= ∇i]) /=. 143 | rewrite (@eq_fbigr _ _ _ _ _ _ _ (fun i => 2 ^ l)) /=; last first. 144 | by move=> i; rewrite !inE => /andP[_ /minn_idPr->]. 145 | rewrite fsum_nat_const. 146 | rewrite (@eq_fbigr _ _ _ _ _ _ _ (fun i => 2 ^ (troot i))) /=; last first. 147 | move=> i; rewrite !inE => /andP[_ H] _. 148 | suff /minn_idPl-> : troot i <= l by []. 149 | by rewrite ltnW // ltnNge. 150 | rewrite addnA; congr (_ + _)%nat. 151 | rewrite mulnS [_ ^ _ * #|`_|]mulnC. 152 | by case: (2 ^ l) (expn_gt0 2 l). 153 | by apply: eq_fbigl_cond => i; rewrite !inE ltnNge andbT. 154 | Qed. 155 | 156 | Lemma psi_auxE_lt l e : 157 | psi_aux l e = 158 | (((2 ^ l * #|`[fset i in e | (l < troot i)%nat]|.+1).-1 159 | + (\sum_(i <- e | (troot i <= l)%nat) 2 ^ troot i))%:R - (l * 2 ^ l)%:R)%R. 160 | Proof. 161 | rewrite /psi_aux. 162 | congr (_%:R - _%:R)%R. 163 | rewrite (big_fsetID _ [pred i | l < troot i]) /=. 164 | rewrite (@eq_fbigr _ _ _ _ _ _ _ (fun => 2 ^ l)) /=; last first. 165 | by move=> i; rewrite !inE => /andP[_ /ltnW/minn_idPr ->]. 166 | rewrite fsum_nat_const. 167 | rewrite (@eq_fbigr _ _ _ _ _ _ _ (fun i => 2 ^ troot i)) /=; last first. 168 | move=> i; rewrite !inE /= => /andP[_ H] _. 169 | suff /minn_idPl-> : troot i <= l by []. 170 | by rewrite leqNgt. 171 | rewrite addnA; congr (_ + _)%nat. 172 | rewrite mulnS [_ ^ _ * #|`_|]mulnC. 173 | by case: (2 ^ l) (expn_gt0 2 l). 174 | by apply: eq_fbigl_cond => i; rewrite !inE ltnNge andbT negbK. 175 | Qed. 176 | 177 | Definition psi_auxb e := (maxn #|`e| (\max_(i <- e) troot i)).+1. 178 | 179 | Notation "'ψ_b' n" := (psi_auxb n) (format "'ψ_b' n", at level 0). 180 | 181 | Lemma psi_aux_psib l e : psi_auxb e <= l -> (psi_aux l e <= 0)%R. 182 | Proof. 183 | rewrite /psi_auxb; case: l => // l. 184 | rewrite ltnS /psi_aux geq_max => /andP[eLl maxLl]. 185 | rewrite mulSn -{2}[_ ^ _]prednK ?expn_gt0 // addSnnS. 186 | rewrite !natrD [(_%:R + _)%R]addrC opprD addrA addrK. 187 | rewrite subr_le0 ler_nat. 188 | apply: leq_trans (leqnSn _). 189 | apply: leq_trans (_ : #|`e| * 2 ^ l.+1 <= _); last first. 190 | by rewrite leq_mul2r eLl orbT. 191 | rewrite -fsum_nat_const. 192 | apply: leq_sum => i iIe. 193 | apply: leq_pexp2l => //. 194 | by apply geq_minr. 195 | Qed. 196 | 197 | Definition rnz (z : int) := `|Num.max 0%R z|. 198 | 199 | Lemma rnz_ler0 z : (z <= 0)%R -> rnz z = 0. 200 | Proof. by move=> zN; rewrite /rnz max_l. Qed. 201 | 202 | Lemma rnz_ger0 z : (0 <= z)%R -> (z = (rnz z)%:R)%R. 203 | Proof. by move=> zP; rewrite /rnz max_r // natz gez0_abs. Qed. 204 | 205 | Lemma ler_rnz z : (z <= rnz z)%R. 206 | Proof. by rewrite /rnz; case: ler0P => //= zP; rewrite gtz0_abs. Qed. 207 | 208 | Lemma rnz_ler z1 z2 : (z1 <= z2)%R -> rnz z1 <= rnz z2. 209 | Proof. 210 | rewrite /rnz; case: ler0P => // z1_gt0 z1Lz2; case: ler0P => //= [|z2_gt0]. 211 | by rewrite leNgt => /negP[]; apply: lt_le_trans z1Lz2. 212 | by rewrite -lez_nat !gtz0_abs. 213 | Qed. 214 | 215 | Definition psi e := \max_(l < psi_auxb e) rnz (psi_aux l e). 216 | 217 | Notation "'ψ' n" := (psi n) (format "'ψ' n", at level 0). 218 | 219 | Lemma psiE_leq e n : 220 | psi_auxb e <= n -> psi e = \max_(l < n) rnz (psi_aux l e). 221 | Proof. 222 | move=> pLn. 223 | rewrite /psi. 224 | rewrite (big_ord_widen_cond _ xpredT (fun i => rnz (psi_aux i e)) pLn). 225 | rewrite [RHS](bigID (fun i : 'I_n => i < psi_auxb e)) /=. 226 | rewrite [X in _ = maxn _ X]big1 ?maxn0 // => i. 227 | rewrite -leqNgt => /psi_aux_psib. 228 | exact: rnz_ler0. 229 | Qed. 230 | 231 | Lemma psi_max e l : (psi_aux l e <= (psi e)%:R)%R. 232 | Proof. 233 | pose n := maxn (psi_auxb e) l.+1. 234 | have /psiE_leq-> : psi_auxb e <= n by apply: leq_maxl. 235 | have O : l < n by apply: leq_maxr. 236 | have [/le_trans->//|/ltW/rnz_ger0->] := lerP (psi_aux l e) 0. 237 | rewrite ler_nat. 238 | by rewrite (bigD1 (Ordinal O)) //= leq_maxl. 239 | Qed. 240 | 241 | Lemma psi_ler l e : 242 | (((2 ^ l).-1 + \sum_(i <- e) 2 ^ (minn (troot i) l))%:R - (l * 2 ^ l)%:R 243 | <= ((psi e)%:R : int))%R. 244 | Proof. 245 | have [/psi_aux_psib/le_trans->//|lLp] := leqP (psi_auxb e) l. 246 | rewrite [X in (_ <= X%:R)%R](bigD1 (Ordinal lLp)) //=. 247 | apply: le_trans (ler_rnz _) _. 248 | rewrite -natz ler_nat. 249 | apply: leq_maxl. 250 | Qed. 251 | 252 | Lemma psiE e : {l | ((psi e)%:R = psi_aux l e)%R}. 253 | Proof. 254 | have [l] : {l : 'I_(psi_auxb e) | psi e = rnz (psi_aux l e)}. 255 | apply bigop.eq_bigmax. 256 | by rewrite card_ord. 257 | rewrite /rnz; case: ler0P => [pG pE|pP ->]; last first. 258 | by exists l; rewrite natz gtz0_abs. 259 | by exists 0; apply/eqP; rewrite eq_le {1}pE psi_aux_0_ge0 psi_max. 260 | Qed. 261 | 262 | Lemma psi_sub e1 e2 : e1 `<=` e2 -> psi e1 <= psi e2. 263 | Proof. 264 | move=> e1Se2. 265 | rewrite (psiE_leq (leq_maxl (psi_auxb e1) (psi_auxb e2))). 266 | rewrite (psiE_leq (leq_maxl (psi_auxb e2) (psi_auxb e1))). 267 | rewrite maxnC. 268 | elim/big_ind2: _ => // [x1 x2 y1 y2 x2Lx1 y2Ly1 | i _]. 269 | rewrite geq_max (leq_trans x2Lx1 (leq_maxl _ _)). 270 | by rewrite (leq_trans y2Ly1 (leq_maxr _ _)). 271 | apply: rnz_ler. 272 | by apply: psi_aux_sub. 273 | Qed. 274 | 275 | Lemma psi_aux_le_psi e1 e2 : 276 | (forall l, (psi_aux l e1 <= psi_aux l e2)%R) -> psi e1 <= psi e2. 277 | Proof. 278 | move=> H. 279 | pose e := maxn (psi_auxb e1) (psi_auxb e2). 280 | rewrite (psiE_leq (leq_maxl _ _ : _ <= e)). 281 | rewrite (psiE_leq (leq_maxr _ _ : _ <= e)). 282 | elim: e => [|e IH]; first by rewrite !big_ord0. 283 | by rewrite !big_ord_recr /= geq_max !leq_max IH /= rnz_ler // orbT. 284 | Qed. 285 | 286 | Lemma psi_auxb_sint n : psi_auxb `[n] = n.+1. 287 | Proof. 288 | congr (_.+1). 289 | rewrite /psi_auxb. 290 | rewrite card_sint ?geq_minr // subn0. 291 | apply/eqP. 292 | rewrite eqn_leq leq_maxl andbT geq_max leqnn andTb. 293 | apply/bigfmax_leqP => i; rewrite mem_sint /= => iLn _. 294 | by apply: leq_trans (leq_rootnn _) (ltnW _). 295 | Qed. 296 | 297 | Lemma psi_aux_sintE n l : 298 | psi_aux l `[n] = 299 | (((2 ^ l).-1 + \sum_(0 <= i < n) 2 ^ minn (∇i) l)%:R - 300 | (l * 2 ^ l)%:R)%R. 301 | Proof. 302 | congr ((_ + _)%:R - _%:R)%R. 303 | elim: n => [|n IH]; first by rewrite sint0_set0 /= big_nil. 304 | rewrite (big_fsetD1 n) /=; last by rewrite mem_sint andTb. 305 | by rewrite sintSr IH !big_mkord big_ord_recr /= addnC. 306 | Qed. 307 | 308 | Lemma psi_auxb_set0 : psi_auxb fset0 = 1. 309 | Proof. by rewrite /psi_auxb cardfs0 max0n big_seq_cond big1. Qed. 310 | 311 | Lemma psi_set0 : psi fset0 = 0. 312 | Proof. 313 | rewrite /psi psi_auxb_set0. 314 | rewrite !big_ord_recr /= big_ord0 /= max0n. 315 | by rewrite /psi_aux /= big_seq_cond big1. 316 | Qed. 317 | 318 | Lemma psi_eq0 e : (psi e == 0) = (e == fset0). 319 | Proof. 320 | have [->|[x]] := fset_0Vmem e; first by rewrite psi_set0 !eqxx. 321 | have [->|_] := e =P fset0; first by rewrite inE. 322 | move=> xIe. 323 | suff : psi e > 0 by case: psi. 324 | rewrite -(ltr_nat (Num.NumDomain.clone _ int)). 325 | apply: lt_le_trans (psi_max _ 0). 326 | by rewrite /psi_aux add0n subr0 ltr_nat (big_fsetD1 x). 327 | Qed. 328 | 329 | Lemma psi_sint0 : psi `[0] = 0. 330 | Proof. by rewrite sint0_set0 psi_set0. Qed. 331 | 332 | Lemma psi_sint1 : psi `[1] = 1. 333 | Proof. 334 | rewrite /psi psi_auxb_sint. 335 | rewrite -(big_mkord xpredT (fun l => rnz (psi_aux l _))). 336 | pose f l := 337 | rnz (((2 ^ l).-1 + \sum_(0 <= i < 1) 2 ^ minn (∇i) l)%:R - 338 | (l * 2 ^ l)%:R). 339 | rewrite (eq_bigr f) => [|i _]; last by rewrite psi_aux_sintE. 340 | by rewrite /f /= unlock. 341 | Qed. 342 | 343 | Lemma psi_sint2 : psi `[2] = 2. 344 | Proof. 345 | rewrite /psi psi_auxb_sint. 346 | rewrite -(big_mkord xpredT (fun l => rnz (psi_aux l _))). 347 | pose f l := 348 | rnz (((2 ^ l).-1 + \sum_(0 <= i < 2) 2 ^ minn (∇i) l)%:R - 349 | (l * 2 ^ l)%:R). 350 | rewrite (eq_bigr f) => [|i _]; last by rewrite psi_aux_sintE. 351 | by rewrite /f /= unlock. 352 | Qed. 353 | 354 | Lemma psi_sint3 : psi `[3] = 4. 355 | Proof. 356 | rewrite /psi psi_auxb_sint. 357 | rewrite -(big_mkord xpredT (fun l => rnz (psi_aux l _))). 358 | pose f l := 359 | rnz (((2 ^ l).-1 + \sum_(0 <= i < 3) 2 ^ minn (∇i) l)%:R - 360 | (l * 2 ^ l)%:R). 361 | rewrite (eq_bigr f) => [|i _]; last by rewrite psi_aux_sintE. 362 | by rewrite /f /= unlock. 363 | Qed. 364 | 365 | Lemma psi_aux_incr n l : 366 | l < (troot n).-1 -> (psi_aux l `[n] <= psi_aux l.+1 `[n])%R. 367 | Proof. 368 | move=> lLr. 369 | have dlLn : delta l.+2 <= n. 370 | rewrite -root_delta_le -subn_gt0. 371 | by rewrite -[l.+1]addn1 addnC subnDA subn_gt0 subn1. 372 | rewrite psi_auxE_lt psi_auxE_le. 373 | set s := \sum_(_ <- _ | _) _. 374 | have -> : [fset i in `[n] | l < troot i] = [fset i in `[n] | delta l.+1 <= i]. 375 | by apply/fsetP => i; rewrite !inE root_delta_le. 376 | have /(sint_sub n)-> : 0 <= delta l.+1 by apply: delta_le (_ : 0 <= l.+1). 377 | rewrite card_sint //. 378 | set c := n - _. 379 | rewrite expnS mulnAC [2 * _ * _]mulnC. 380 | rewrite mul2n mulnA muln2 -!addnn -[(_ + l.+1)%nat]addSnnS. 381 | rewrite mulnDl mulnDr prednDr ?(muln_gt0, expn_gt0) //. 382 | set x := 2 ^ _ * _. 383 | rewrite -[(_ + _ + s)%nat]addnA [(x + _)%nat]addnC. 384 | rewrite [((_ + _ * _)%:R)%R]natrD opprD addrA lerB //. 385 | rewrite lerBrDr [((_ + x)%:R)%R]natrD lerD //. 386 | rewrite ler_nat. 387 | rewrite mulnC leq_mul2l. 388 | rewrite -subSn; last first. 389 | apply: leq_trans (_ : delta l.+2 <= _); first by by apply: delta_le. 390 | by apply: leq_trans dlLn _. 391 | by rewrite ltn_subRL -addnS -deltaS (leq_trans dlLn) ?orbT. 392 | Qed. 393 | 394 | Lemma psi_aux_decr n l : 395 | (troot n).-1 <= l -> (psi_aux l.+1 `[n] <= psi_aux l `[n])%R. 396 | Proof. 397 | move=> rLl. 398 | have dlLn : n < delta l.+2. 399 | rewrite ltnNge -root_delta_le -subn_gt0. 400 | by rewrite -[l.+1]addn1 addnC subnDA subn_gt0 subn1 -ltnNge. 401 | rewrite psi_auxE_le. 402 | rewrite psi_auxE_lt. 403 | set s := \sum_(_ <- _ | _) _. 404 | have -> : [fset i in `[n] | l < troot i] = 405 | [fset i in `[n] | delta l.+1 <= i]. 406 | by apply/fsetP => i; rewrite !inE root_delta_le. 407 | have /(sint_sub n)-> : 0 <= delta l.+1 by apply: delta_le (_ : 0 <= l.+1). 408 | rewrite card_sint //. 409 | set c := n - _. 410 | rewrite expnS mulnAC [2 * _ * _]mulnC. 411 | rewrite mul2n mulnA muln2 -!addnn -[(_ + l.+1)%nat]addSnnS. 412 | rewrite mulnDl mulnDr prednDr ?(muln_gt0, expn_gt0) //. 413 | set x := 2 ^ _ * _. 414 | rewrite -[(_ + s)%nat]addnA [(x + _)%nat]addnC. 415 | rewrite [((_ + _ * _)%:R)%R]natrD opprD addrA lerB //. 416 | rewrite lerBlDr [((_ + x)%:R)%R]natrD lerD //. 417 | rewrite ler_nat. 418 | rewrite mulnC leq_mul2l. 419 | rewrite -[l.+2](addnK (delta l.+1)) addnC -deltaS. 420 | rewrite ltn_sub2r ?orbT // [X in _ < X]deltaS //. 421 | by rewrite addnS ltnS leq_addr. 422 | Qed. 423 | 424 | Lemma psi_aux_sint n : ((psi `[n])%:R)%R = psi_aux (troot n).-1 `[n]. 425 | Proof. 426 | apply/eqP. 427 | rewrite eq_le psi_max andbT. 428 | case: (psiE `[n]) => l ->. 429 | have [E|E] := leqP (troot n).-1 l. 430 | rewrite -(subnK E). 431 | elim: (_ - _) => [|k IH] //. 432 | apply: le_trans IH. 433 | rewrite addSn. 434 | apply: psi_aux_decr => //. 435 | by rewrite leq_addl. 436 | rewrite -(subKn (ltnW E)). 437 | elim: (_ - l) => [|k IH]. 438 | by rewrite subn0. 439 | apply: le_trans IH. 440 | rewrite subnS. 441 | have [|E1] := leqP (troot n).-1 k. 442 | by rewrite -subn_eq0 => /eqP->. 443 | rewrite -{2}[_-_]prednK ?subn_gt0 //. 444 | apply: psi_aux_incr => //. 445 | case: _.-1 E1 => // u _; case: k => // k. 446 | apply: leq_trans (_ : u.+1.-1 < u.+1) => //. 447 | by rewrite ltnS -!subn1 leq_sub2r // leq_subr. 448 | Qed. 449 | 450 | (* This is 2.2 *) 451 | Lemma psi_sint_phi n : (psi `[n]).*2 = (phi n.+1).-1. 452 | Proof. 453 | have [|nP] := leqP n 0; first by case: (n)=> //; rewrite psi_sint0. 454 | apply/eqP; rewrite -(eqr_nat (Num.NumDomain.clone _ int)). 455 | rewrite -muln2 natrM mulr_natr. 456 | rewrite psi_aux_sint // psi_auxE_lt. 457 | rewrite (_ : [fset _ in _ | _] = [fset i in `[n] | delta (troot n) <= i]); 458 | last first. 459 | apply/fsetP=> i; rewrite !inE; congr (_ && _). 460 | by rewrite prednK ?troot_gt0 // root_delta_le. 461 | rewrite sint_sub ?delta_gt0 ?troot_gt0 // card_sint //. 462 | rewrite (_ : \sum_(i <- _ | _) _ = phi (delta (troot n))); last first. 463 | rewrite phiE. 464 | rewrite [RHS](eq_bigl 465 | (fun i : 'I_ _ => (i : nat) \in (enum_fset `[n]))); last first. 466 | move=> i. 467 | by rewrite mem_sint leq0n (leq_trans (ltn_ord _)) // delta_root_le. 468 | elim: enum_fset (fset_uniq `[n]) => /= [_|a l IH /andP[aNIl lU]]. 469 | by rewrite big_nil big1. 470 | rewrite big_cons /= IH //; case: leqP => aLb; last first. 471 | rewrite prednK ?troot_gt0 // in aLb. 472 | apply: eq_bigl => i; rewrite inE eqn_leq [a <= i]leqNgt. 473 | by rewrite (leq_trans (ltn_ord i)) ?andbF // -root_delta_le. 474 | have aLn : a < Δ(∇n). 475 | by rewrite -root_delta_lt -[troot n]prednK // troot_gt0. 476 | rewrite [RHS](bigD1 (Ordinal aLn)) ?(inE, eqxx) //=. 477 | congr ((_ + _)%nat). 478 | apply: eq_bigl => i; rewrite inE -val_eqE /=. 479 | by case: (_ =P _); rewrite ?andbT // => ->; rewrite (negPf aNIl). 480 | set m := troot n. 481 | rewrite -[n - _]/(tmod n). 482 | set p := tmod n. 483 | rewrite phi_deltaE. 484 | (* taking care of m * 2 ^ m - 2 ^ m *) 485 | rewrite -{2}[m]prednK ?troot_gt0 //. 486 | rewrite mulSn addnCA [(2 ^ _ + _)%nat]addnC addnK add1n. 487 | rewrite addnS -addSn prednK; last first. 488 | by rewrite muln_gt0 expn_gt0. 489 | (* taking care of m.-1 * 2 ^ m - m.-1 * 2 ^ m.-1 *) 490 | rewrite -{3}[m]prednK ?troot_gt0 //. 491 | rewrite expnS mul2n -addnn mulnDr addnA natrD addrK. 492 | rewrite mulnC -mulnDl addSnnS prednK ?troot_gt0 //. 493 | rewrite -mulr_natr -natrM muln2 eqr_nat. 494 | rewrite phi_modSE -/m -/p. 495 | rewrite add1n -pred_Sn addnC -{4}[m]prednK ?troot_gt0 //. 496 | by rewrite expnS mulnCA mul2n. 497 | Qed. 498 | 499 | Lemma psi_sint_leq a b : a <= b -> psi `[a] <= psi `[b]. 500 | Proof. 501 | move=> aLb; apply: psi_sub; apply/fsubsetP=> i. 502 | by rewrite !mem_sint /= => iLa; apply: leq_trans aLb. 503 | Qed. 504 | 505 | Lemma psi_sintS n : (psi `[n.+1] = psi `[n] + 2 ^ (troot n.+1).-1)%nat. 506 | Proof. 507 | have F : 0 < phi n.+1 by apply: phi_le (_ : 1 <= _). 508 | apply: double_inj; rewrite doubleD. 509 | rewrite !psi_sint_phi //. 510 | rewrite -mul2n -expnS prednK ?troot_gt0 //. 511 | by rewrite phiE big_ord_recr -phiE prednDl. 512 | Qed. 513 | 514 | (* This is 2.2 *) 515 | Lemma psi_leD a b : psi `[a + b] <= (psi `[a]).*2 + 2 ^ (b.-1). 516 | Proof. 517 | case: b => [|b]; first by rewrite addn0 -addnn -addnA leq_addr. 518 | rewrite -leq_double doubleD [_.+1.-1]/=. 519 | rewrite !psi_sint_phi -addSn -ltnS prednK ?phi_gt0 //. 520 | apply: leq_trans (phi_leD _ _) _. 521 | rewrite -{1}[phi (a.+1)]prednK ?phi_gt0 // doubleS. 522 | by rewrite expnS mul2n -prednDr ?double_gt0 ?expn_gt0. 523 | Qed. 524 | 525 | (* This is 2.3 *) 526 | Lemma psi_SS_le n : psi `[n.+2] >= 2 ^(troot n).+1. 527 | Proof. 528 | case: n => [|n]; first by rewrite psi_sint2. 529 | have /psi_sint_leq/(leq_trans _)->// : (delta (troot n.+1)).+2 <= n.+3. 530 | by rewrite !ltnS -root_delta_le. 531 | set s := troot _. 532 | have [|tLs] := leqP s 1. 533 | case: s => [|[|]] //; first by rewrite psi_sint2 ?(leq_trans _ thLN). 534 | by rewrite psi_sint3. 535 | rewrite -leq_double psi_sint_phi phi_modSE. 536 | have tE : troot (delta s).+2 = s. 537 | by apply/eqP; rewrite trootE deltaS ltnW //= -addn2 addSnnS leq_add2l. 538 | rewrite tE. 539 | have->: tmod (delta s).+2 = 2 by rewrite /tmod tE -addn2 addnC addnK. 540 | by rewrite -mul2n expnS mulnA /= leq_mul2r (leq_add2r 2 2) tLs orbT. 541 | Qed. 542 | 543 | Lemma psi_aux0_sint n : psi_aux 0 `[n] = n. 544 | Proof. 545 | rewrite /psi_aux add0n subr0. 546 | apply/eqP; rewrite -natz eqr_nat; apply/eqP. 547 | rewrite (eq_bigr (fun => 1)) => [|i _]. 548 | by rewrite fsum_nat_const card_sint // subn0 muln1. 549 | by rewrite minn0. 550 | Qed. 551 | 552 | (* This is 2.4.1 *) 553 | Lemma psi_sint_min n : n <= psi `[n]. 554 | Proof. 555 | rewrite -(ler_nat (Num.NumDomain.clone _ int)). 556 | rewrite natz -[X in (X <= _)%R]psi_aux0_sint. 557 | by apply: psi_max. 558 | Qed. 559 | 560 | Lemma sum_sint (F : nat -> nat) n : 561 | \sum_(i <- `[n]) F i = \sum_(i < n) F i. 562 | Proof. 563 | rewrite big_seq_cond. 564 | rewrite [LHS](eq_bigl (fun i => (i < n))); last first. 565 | by move=> i; rewrite mem_sint andbT. 566 | rewrite [RHS](eq_bigl 567 | (fun i : 'I_ _ => ((i : nat) \in (enum_fset `[n])))); last first. 568 | by move=> i; rewrite mem_sint ltn_ord. 569 | elim: enum_fset (fset_uniq `[n]) => /= [_|a l IH /andP[aNIl lU]]. 570 | by rewrite big_nil big1. 571 | rewrite big_cons /= IH //; case: (boolP (a < n)) => aLn; last first. 572 | apply: eq_bigl => i; move: (ltn_ord i); rewrite inE; case: eqP => [->| //]. 573 | by rewrite (negPf aLn). 574 | rewrite [RHS](bigD1 (Ordinal aLn)) ?(inE, eqxx) //=. 575 | congr ((_ + _)%nat). 576 | apply: eq_bigl => i; rewrite inE -val_eqE /=. 577 | by case: (_ =P _); rewrite ?andbT // => ->; rewrite (negPf aNIl). 578 | Qed. 579 | 580 | Lemma max_set_nat (e : {fset nat}) : #|`e|.-1 <= \max_(i <- e) i. 581 | Proof. 582 | have [n cI] := ubnP #|`e|; elim: n => // [] [|n] IH e cI in e cI *. 583 | by move: cI; rewrite ltnS leqn0 => /eqP->. 584 | move: cI; rewrite leq_eqVlt => /orP[/eqP eC|]; last first. 585 | by apply: IH. 586 | have /(eq_fbigmax id)[/= i [iIe iM]] : 0 < #|`e| by rewrite -ltnS eC. 587 | have eE : #|` e| = #|` e `\ i|.+1 by rewrite (cardfsD1 i) iIe. 588 | have /IH H : #|`e `\ i| < n.+1 by rewrite -eE -ltnS eC. 589 | rewrite eE /=. 590 | case eIE : (#|` e `\ i|) => [//|k]. 591 | have /(eq_fbigmax id)[j []] : 0 < #|` e `\ i| by rewrite eIE. 592 | rewrite !inE => /andP[jDi jIe] jM. 593 | move: H; rewrite eIE => H. 594 | apply: leq_ltn_trans H _; rewrite iM jM. 595 | have : j <= i by rewrite -iM; apply: leq_bigfmax. 596 | by rewrite leq_eqVlt (negPf jDi). 597 | Qed. 598 | 599 | Lemma psi_aux_card_le l e : (psi_aux l `[#|`e|] <= psi_aux l e)%R. 600 | Proof. 601 | rewrite lerB // ler_nat leq_add2l. 602 | rewrite (sum_sint (fun i => 2 ^ minn (∇i) l)) //. 603 | have [n cI] := ubnP #|`e|; elim: n => // [] [|n] IH e cI in e cI *. 604 | by move: cI; rewrite ltnS leqn0 => /eqP-> ; rewrite big_ord0. 605 | move: cI; rewrite leq_eqVlt => /orP[/eqP [] eC|]; last first. 606 | by apply: IH. 607 | have /(eq_fbigmax id)[/= i [iIe iM]] : 0 < #|`e| by rewrite -ltnS eC. 608 | have eE : #|` e| = #|` e `\ i|.+1 by rewrite (cardfsD1 i) iIe. 609 | rewrite eE big_ord_recr /= (big_fsetD1 i) //= addnC. 610 | apply: leq_add; last by apply: IH; rewrite -eC eE. 611 | rewrite leq_exp2l // leq_min geq_minr andbT. 612 | apply: leq_trans (geq_minl _ _) _. 613 | apply: troot_le. 614 | rewrite -{2}iM -ltnS -eE -[#|`_|]prednK; last by rewrite eC. 615 | by apply: max_set_nat. 616 | Qed. 617 | 618 | (* This is 2.4.2 *) 619 | Lemma psi_card_le e : psi `[#|`e|] <= psi e. 620 | Proof. 621 | apply: psi_aux_le_psi => l. 622 | by apply: psi_aux_card_le. 623 | Qed. 624 | 625 | (* This is 2.4.3 *) 626 | Lemma psi_exp e : psi e <= (2 ^ #|`e|).-1. 627 | Proof. 628 | rewrite -(ler_nat (Num.NumDomain.clone _ int)). 629 | have [l ->] := psiE e. 630 | apply: le_trans (_ : ((2 ^ l).-1 + \sum_(i <- e) 2 ^ l)%:R - 631 | (l * 2 ^ l)%:R <= _)%R. 632 | apply: lerB => //. 633 | rewrite ler_nat leq_add2l. 634 | apply: leq_sum => i Hi. 635 | by rewrite leq_exp2l // geq_minr. 636 | rewrite fsum_nat_const lerBlDr -natrD ler_nat [X in _ <= X]addnC. 637 | rewrite -prednDl ?expn_gt0 // -prednDr ?expn_gt0 //. 638 | rewrite -!subn1 leq_sub2r //. 639 | have [E|E] := leqP #|`e| l. 640 | rewrite -(subnK E). 641 | set u := _ - _. 642 | rewrite expnD !mulnDl addnAC leq_add2r. 643 | case: u => [|u]; first by rewrite mul1n. 644 | by rewrite mulSn -addnA leq_addr. 645 | rewrite -(subnK (ltnW E)). 646 | set u := _ - _. 647 | rewrite expnD !mulnDl addnA addnC leq_add2l. 648 | by rewrite -mulSn leq_mul2r ltn_expl // orbT. 649 | Qed. 650 | 651 | (* This is 2.5 *) 652 | Lemma psi_diff e1 e2 : psi e1 - psi e2 <= \sum_(i <- e1 `\` e2) 2 ^ troot i. 653 | Proof. 654 | rewrite leq_subLR -(ler_nat (Num.NumDomain.clone _ int)) natrD addrC -lerBlDr. 655 | have [l ->] := psiE e1. 656 | apply: le_trans (lerB (lexx _) (psi_max _ l)) _. 657 | rewrite /psi_aux opprB addrA subrK addnC !natrD opprD addrA addrK. 658 | rewrite lerBlDr -natrD ler_nat addnC -leq_subLR. 659 | set s1 := \sum_(_ <- _) _; set s2 := \sum_(_ <- _) _; set s3 := \sum_(_ <- _) _. 660 | pose f i := 2 ^ minn (troot i) l. 661 | apply: leq_trans (_ : \sum_(i <- e1 `\` e2) f i <= _); last first. 662 | by apply: leq_sum => i _; rewrite leq_exp2l // geq_minl. 663 | rewrite leq_subLR. 664 | rewrite [s1](big_fsetID _ (fun i => i \in e2)) //=. 665 | apply: leq_add. 666 | rewrite [s2](big_fsetID _ (fun i => i \in e1)) //=. 667 | apply: leq_trans (leq_addr _ _). 668 | rewrite leq_eqVlt; apply/orP; left; apply/eqP. 669 | by apply: eq_fbigl => i; rewrite !inE andbC. 670 | rewrite leq_eqVlt; apply/orP; left; apply/eqP. 671 | by apply: eq_fbigl => i; rewrite !inE andbC. 672 | Qed. 673 | 674 | (* This is 2.6 *) 675 | 676 | Lemma psi_delta e s a : 677 | #|` e `\` `[delta s]| <= s -> a \in e -> psi e - psi (e `\ a) <= 2 ^ s.-1. 678 | Proof. 679 | move=> CLs aIe. 680 | rewrite leq_subLR -(ler_nat (Num.NumDomain.clone _ int)) natrD addrC -lerBlDr. 681 | have [l Hl] := psiE e. 682 | have F l1 : s <= l1.+1 -> (psi_aux l1.+1 e <= psi_aux l1 e)%R. 683 | move=> sLl1. 684 | rewrite psi_auxE_le. 685 | rewrite psi_auxE_lt. 686 | set s1 := \sum_(_ <- _ | _) _. 687 | have -> : [fset i in e | l1 < troot i] = [fset i in e | delta l1.+1 <= i]. 688 | by apply/fsetP => i; rewrite !inE root_delta_le. 689 | set c := #|`_|. 690 | have Hc : c <= s. 691 | apply: leq_trans CLs. 692 | apply: fsubset_leq_card. 693 | apply/fsubsetP=> i. 694 | rewrite !inE => /andP[-> H]. 695 | rewrite andbT mem_sint -leqNgt (leq_trans _ H) //. 696 | by apply: delta_le. 697 | rewrite expnS mulnAC [2 * _ * _]mulnC. 698 | rewrite mul2n mulnA muln2 -!addnn -[(_ + l1.+1)%N]addSnnS. 699 | rewrite mulnDl mulnDr prednDr ?(muln_gt0, expn_gt0) //. 700 | set x := 2 ^ _ * _. 701 | rewrite -[(_ + s1)%N]addnA [(x + _)%N]addnC. 702 | rewrite [X in (_ - X <= _)%R]natrD opprD addrA lerD //. 703 | rewrite lerBlDr natrD lerD // ler_nat. 704 | by rewrite mulnC leq_mul2l ltnS (leq_trans _ sLl1) ?orbT. 705 | pose l1 := minn l s.-1. 706 | have -> : ((psi e)%:R = psi_aux l1 e)%R. 707 | have [/minn_idPl U|E] := leqP l s.-1; first by rewrite [l1]U. 708 | have /ltnW/minn_idPr U := E. 709 | rewrite [l1]U. 710 | apply/eqP; rewrite eq_le psi_max andbT Hl. 711 | rewrite -(subnK (ltnW E)). 712 | elim: (_ - _) => [|k IH] //. 713 | apply: le_trans IH. 714 | rewrite addSn. 715 | apply: F => //. 716 | case: (s) => // s1. 717 | by rewrite ltnS /= leq_addl. 718 | apply: le_trans (lerB (lexx _) (psi_max _ l1)) _. 719 | rewrite /psi_aux opprB addrA subrK addnC !natrD opprD addrA addrK. 720 | rewrite lerBlDr -natrD ler_nat addnC -leq_subLR. 721 | rewrite (big_fsetD1 a) //= addnK leq_exp2l //. 722 | by apply: leq_trans (geq_minr _ _) (geq_minr _ _). 723 | Qed. 724 | 725 | (* This is 2.7 *) 726 | Lemma psi_add n s e1 e2 : 727 | e1 `<=` `[n] -> n >= delta (s.-1) -> #|`e2| <= s -> 728 | psi (e1 `|` e2) - psi (e1) <= psi `[n + s] - psi `[n]. 729 | Proof. 730 | move=> e1Sn. 731 | elim: s e2 => [e2 _|s IH e2 dLn Ce2]. 732 | rewrite leqn0 cardfs_eq0 => /eqP->. 733 | by rewrite fsetU0 subnn. 734 | have [->|[x xIe2]] := fset_0Vmem e2. 735 | by rewrite fsetU0 subnn. 736 | have dLn1 : delta (s.-1) <= n. 737 | apply: leq_trans dLn. 738 | by apply: delta_le; case: (s) => // s1 /=. 739 | pose e3 := e2 `\ x. 740 | have Ce3 : #|` e3| <= s. 741 | by move: Ce2; rewrite (cardfsD1 x) xIe2 ltnS. 742 | apply: leq_trans (leq_sub_add (psi (e1 `|` e3)) _ _) _. 743 | rewrite addnS psi_sintS. 744 | rewrite [X in _ <= X - _]addnC -addnBA; last first. 745 | by apply: psi_sint_leq; rewrite leq_addr. 746 | apply: leq_add; last by apply: IH. 747 | have [xIe1|xNIe1] := boolP (x \in e1). 748 | have -> : e1 `|` e2 = e1 `|` e3. 749 | apply/fsetP=> i; rewrite !inE. 750 | by case: eqP => // ->; rewrite xIe1. 751 | by rewrite subnn. 752 | have -> : e1 `|` e3 = (e1 `|` e2) `\ x. 753 | apply/fsetP=> i; rewrite !inE. 754 | case: eqP => // ->. 755 | by rewrite (negPf xNIe1). 756 | apply: psi_delta; last first. 757 | by rewrite !inE xIe2 orbT. 758 | rewrite -addnS. 759 | set t := s.+1. 760 | set g := troot (n + t). 761 | apply: leq_trans (_ : #|` e2 `|` (e1 `\` `[delta g])| <= _). 762 | apply: fsubset_leq_card. 763 | apply/fsubsetP=> i. 764 | rewrite !inE. 765 | by do 2 case: (_ \in _); rewrite ?(orbT, orbF). 766 | apply: leq_trans (_ : #|` e2| + #|` e1 `\` `[delta g]| <= _). 767 | by rewrite -cardfsUI leq_addr. 768 | apply: leq_trans (_ : t + #|` e1 `\` `[delta g]| <= _). 769 | by rewrite leq_add2r. 770 | apply: leq_trans (_ : t + #|` sint (delta g) n| <= _). 771 | rewrite leq_add2l. 772 | apply: fsubset_leq_card. 773 | apply/fsubsetP=> i. 774 | rewrite !(inE, mem_sint) /= -leqNgt => /andP[-> /(fsubsetP e1Sn)]. 775 | by rewrite mem_sint. 776 | rewrite card_sint. 777 | have [|E] := leqP n (delta g); last first. 778 | rewrite addnBA; last by apply: ltnW. 779 | rewrite leq_subLR addnC. 780 | by rewrite -ltnS -!addnS -deltaS addnS -root_delta_lt. 781 | move/eqP->; rewrite addn0. 782 | by rewrite root_delta_le deltaS leq_add2r. 783 | Qed. 784 | 785 | (* This is 2.8 *) 786 | Lemma psi_cap_ge e1 e2 : phi (#|` e1 `|` e2|.+3) <= (psi e1 + psi e2).*2.*2 + 5. 787 | Proof. 788 | rewrite -(ler_nat (Num.NumDomain.clone _ int)) natrD. 789 | rewrite -!muln2 !natrM !mulr_natr -mulrnA natrD. 790 | set n := #|`_|. 791 | pose m := troot (n.+3). 792 | pose p := tmod (n.+3). 793 | pose l := m.-2. 794 | have mG2 : m >= 2 by rewrite root_delta_le. 795 | have pLm : p <= m. 796 | by rewrite leq_subLR -ltnS -[X in _ < X]addnS -deltaS -root_delta_lt ltnS. 797 | have nG : n >= delta l. 798 | rewrite -[n]/(n.+3.-2.-1) [n.+3]tmodE /l -/m. 799 | case: (m) mG2 => // [] [|] // m1 _. 800 | by rewrite deltaS deltaS /= !(addSn, addnS, subSS, subn0) -!addnA leq_addr. 801 | apply: le_trans (_ : ((psi_aux l `[0] + psi_aux l `[n]) *+ 4 + 5%:R <= _))%R; 802 | last first. 803 | rewrite lerD2r lerMn2r orFb. 804 | apply: le_trans (_ : psi_aux l e1 + psi_aux l e2 <= _)%R; last first. 805 | by apply: lerD; apply: psi_max. 806 | apply: le_trans (_ : psi_aux l (e1 `&` e2) + psi_aux l (e1 `|` e2) <= _)%R. 807 | apply: lerD; last by apply: psi_aux_card_le. 808 | apply: psi_aux_sub; rewrite sint0_set0. 809 | by apply/fsubsetP=> i; rewrite inE. 810 | rewrite /psi_aux. 811 | rewrite !natrD !addrA lerD // -!addrA lerD //. 812 | rewrite addrCA [X in (_ <= X)%R]addrCA lerD //. 813 | rewrite addrCA [X in (_ <= X)%R]addrCA lerD //. 814 | rewrite -!natrD ler_nat. 815 | rewrite [X in _ <= X + _](bigID (fun i => i \in e2)) /=. 816 | rewrite -!addnA leq_add //. 817 | rewrite leq_eqVlt; apply/orP; left; apply/eqP. 818 | by apply: eq_fbigl_cond => i; rewrite !inE /= andbT. 819 | rewrite [X in X <= _](bigID (fun i => i \in e2)) /=. 820 | rewrite addnC leq_add //. 821 | rewrite leq_eqVlt; apply/orP; left; apply/eqP. 822 | apply: eq_fbigl_cond => i; rewrite !inE /=. 823 | by case: (_ \in e2); rewrite ?(andbT, orbT, andbF, orbF). 824 | rewrite leq_eqVlt; apply/orP; left; apply/eqP. 825 | apply: eq_fbigl_cond => i; rewrite !inE /=. 826 | by case: (_ \in e2); rewrite /= ?(andbT, orbT, andbF, orbF). 827 | have pE : phi (n.+3) = ((m + p - 1) * 2 ^ m).+1. 828 | rewrite phi_modE -/m -/p -{1 4}[m]prednK 1?ltnW //. 829 | rewrite [(_ + p)%N]addSn mulSn [(2 ^ _ + _)%nat]addnC addnA addnK. 830 | by rewrite -subn1 -[(_ + _).+1]addn1 addnK. 831 | have pdE : ((phi (delta l))%:R = 1 + (l%:R - 1) * (2 ^ l)%:R :> int)%R. 832 | rewrite phi_deltaE natrB; last first. 833 | by case: (l) => // l1; rewrite mulSn addnCA leq_addr. 834 | by rewrite natrD /= mulrBl mul1r addrA -natrM. 835 | rewrite le_eqVlt; apply/orP; left; apply/eqP. 836 | (* right part *) 837 | rewrite psi_aux_sintE // psi_auxE_le. 838 | pose f i := 2 ^ minn (∇i) l. 839 | rewrite !(big_mkord _ f) big_ord0 addn0. 840 | have -> : [fset i in `[n] | l <= troot i] = [fset i in `[n] | delta l <= i]. 841 | by apply/fsetP=> i; rewrite !inE root_delta_le. 842 | have /(sint_sub n)-> : 0 <= delta l. 843 | by apply: (@delta_le 0). 844 | rewrite card_sint //. 845 | rewrite (_ : \sum_(_ <- _ | _) _ = phi (delta l)); last first. 846 | rewrite phiE. 847 | rewrite [LHS](eq_bigl (fun i => (i < n) && (∇i < l))); last first. 848 | move=> i; case: leqP; rewrite ?(andbT, andbF) // root_delta_lt. 849 | by move/(leq_trans)->. 850 | rewrite [RHS](eq_bigl 851 | (fun i : 'I_ _ => ((i : nat) \in (enum_fset `[n])))); last first. 852 | by move=> i; rewrite mem_sint (leq_trans (ltn_ord _)). 853 | elim: enum_fset (fset_uniq `[n]) => /= [_|a l1 IH /andP[aNIl lU]]. 854 | by rewrite big_nil big1. 855 | rewrite big_cons /= IH //; case: (boolP (a < n)) => aLn /=; last first. 856 | apply: eq_bigl => i; move: (ltn_ord i); rewrite inE; case: eqP => [->| //]. 857 | by move=> /leq_trans/(_ nG); rewrite (negPf aLn). 858 | case: leqP => aLl. 859 | apply: eq_bigl => i; move: (ltn_ord i); rewrite inE; case: eqP => [->| //]. 860 | by rewrite -root_delta_lt ltnNge aLl. 861 | rewrite root_delta_lt in aLl. 862 | rewrite [RHS](bigD1 (Ordinal aLl)); apply/eqP; last by rewrite inE eqxx. 863 | rewrite /= eqn_add2l; apply/eqP. 864 | apply: eq_bigl => i; rewrite !inE /= -val_eqE /=. 865 | by case: eqP (ltn_ord i) => [->|]; rewrite?(andbT, negPf aNIl). 866 | (* right part *) 867 | apply: etrans 868 | (_ : ((2 ^ l)%:R * (m.-1 + p)%:R - 1%:R) *+4 + 5%:R = _)%R; last first. 869 | congr (_ *+ _ + _)%R. 870 | rewrite -!subn1 ![in RHS](natrD, natrM, natrB) ?muln_gt0 ?expn_gt0 //. 871 | rewrite pdE !addrA addrK; set u := (2 ^ l)%:R%R. 872 | rewrite [(u - 1)%R]addrC -![in RHS]addrA [RHS]addrC; congr (_ - _)%R. 873 | rewrite -{2}[u]mul1r ![(u * _)%R]mulrC -![(-(_ * u))%R]mulNr -!mulrDl. 874 | congr (_ * _)%R. 875 | rewrite {u}!addrA addrAC addrK. 876 | rewrite -[(_ - _).+1]addn1 [in RHS]natrD !addrA addrK. 877 | rewrite -[n]/(n.+3.-2.-1) [n.+3]tmodE -/m -/p. 878 | rewrite -[in RHS](subnK mG2) ![in RHS](addnS, addn0) !deltaS !(subnS, subn0). 879 | rewrite ![in RHS](addnS, addSn) -!addnA [(delta _ + _)%nat]addnC addnK -/l. 880 | by rewrite ![in RHS]natrD !addrA subrK /l -(natrD _ 1%nat) -natrD. 881 | (* left part *) 882 | rewrite pE /l. 883 | case: (m) mG2 => // [] [|m1] //= _. 884 | rewrite addSn subn1 /=. 885 | rewrite (_ : 5%:R = 1 *+ 4 + 1)%R // addrA -mulrnDl. 886 | rewrite subrK -addn1 natrD; congr (_ + _)%R. 887 | rewrite -[in RHS]mulr_natr -!natrM [in RHS]mulnAC mulnC. 888 | congr (_ * _)%:R%R. 889 | by rewrite mulnC !expnS !mulnA. 890 | Qed. 891 | 892 | Lemma phi_3_5_4_phi n : phi (n.+3) = (psi `[n.+2]).*2.+1. 893 | Proof. by rewrite psi_sint_phi prednK ?phi_gt0. Qed. 894 | 895 | Lemma phi_3_5_4_sum n : 896 | phi (n.+3) = (\sum_(1 <= i < n.+3) 2 ^ troot i).+1. 897 | Proof. 898 | rewrite phiE. 899 | rewrite -(big_mkord xpredT (fun i => 2 ^ troot i)). 900 | rewrite (big_cat_nat (_ : 0 <= 1)) //=. 901 | by rewrite big_nat_recl //= big_mkord big_ord0 addn0 add1n. 902 | Qed. 903 | 904 | End PsiDef. 905 | 906 | Lemma ltn_diff_ord_max n (i : 'I_n.+2) : i != ord_max -> i < n.+1. 907 | Proof. 908 | move/eqP/val_eqP. 909 | by have := ltn_ord i; rewrite ltnS leq_eqVlt => /orP[->|]. 910 | Qed. 911 | 912 | Lemma lift_diff_ord_max n (i : 'I_n.+2) : 913 | i != ord_max -> lift ord_max (inord i) = i. 914 | Proof. 915 | move=> iDm. 916 | apply/val_eqP; rewrite [val (lift _ _)]lift_max /= ?inordK //. 917 | by apply: ltn_diff_ord_max. 918 | Qed. 919 | 920 | Lemma set_ord_max_lift n (e : {set 'I_n.+2}) : 921 | e :\ ord_max = [set lift ord_max x | x in [set i | lift ord_max i \in e]]. 922 | Proof. 923 | apply/setP => i; rewrite !inE /=. 924 | apply/andP/imsetP => [[iH iIe]|[j //]]. 925 | exists (inord i). 926 | by rewrite inE lift_diff_ord_max. 927 | by rewrite lift_diff_ord_max. 928 | rewrite inE => kH ->; split => //. 929 | apply/eqP/val_eqP. 930 | by rewrite [val (lift _ _)]lift_max /= neq_ltn ltn_ord. 931 | Qed. -------------------------------------------------------------------------------- /rhanoi3.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From hanoi Require Import extra gdist ghanoi ghanoi3. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | Section Hanoi3. 9 | 10 | (*****************************************************************************) 11 | (* The pegs are the three elements of 'I_3 *) 12 | (*****************************************************************************) 13 | 14 | Implicit Type p : peg 3. 15 | 16 | Local Notation "c1 `-->_r c2" := (rmove c1 c2) 17 | (format "c1 `-->_r c2", at level 60). 18 | Local Notation "c1 `-->*_r c2" := (connect rmove c1 c2) 19 | (format "c1 `-->*_r c2", at level 60). 20 | 21 | (******************************************************************************) 22 | (* Function that builds a path from peg to peg *) 23 | (******************************************************************************) 24 | 25 | Fixpoint ppeg {n : nat} p1 p2 := 26 | if n isn't n1.+1 return seq (configuration 3 n) then [::] else 27 | let p3 := `p[p1, p2] in 28 | [seq ↑[i]_p1 | i <- ppeg p1 p3] ++ 29 | [seq ↑[i]_p2 | i <- `c[p3] :: ppeg p3 p2]. 30 | 31 | Lemma size_ppeg n p1 p2 : 32 | size (ppeg p1 p2 : seq (configuration 3 n)) = (2^ n).-1. 33 | Proof. 34 | elim: n p1 p2 => //= n IH p1 p2. 35 | rewrite size_cat /= !size_map !IH expnS mul2n -addnn. 36 | by rewrite -(prednK (_ : 0 < 2 ^ n)) // expn_gt0. 37 | Qed. 38 | 39 | Lemma last_ppeg n p1 p2 c (cs := ppeg p1 p2 : seq (configuration 3 n)) : 40 | last c cs = `c[p2]. 41 | Proof. 42 | have HH := @rirr 3. 43 | rewrite /cs; elim: n p1 p2 c {cs} => //= [_ p2 c | n IH p1 p2 c]. 44 | by apply/ffunP=> [] []. 45 | by rewrite last_cat /= last_map IH perfect_liftr. 46 | Qed. 47 | 48 | Lemma path_ppeg n p1 p2 (cs := ppeg p1 p2 : seq (configuration 3 n)) : 49 | p1 != p2 -> path rmove `c[p1] cs. 50 | Proof. 51 | have HH := @rirr 3. 52 | rewrite /cs; elim: n p1 p2 {cs} => //= n IH p1 p2 p1Dp2. 53 | set p3 := `p[_,_]. 54 | have p1Dp3 : p1 != p3 by rewrite eq_sym opegDl. 55 | have p3Dp2 : p3 != p2 by rewrite opegDr. 56 | rewrite cat_path /= -{1}[`c[p1]]cunliftrK ffunE !path_liftr // perfect_unliftr. 57 | rewrite !IH // ?andbT /=. 58 | rewrite -{1}[`c[_]]cunliftrK ffunE last_map perfect_unliftr last_ppeg. 59 | by apply: move_liftr_perfect; rewrite // eq_sym opegDr. 60 | Qed. 61 | 62 | (* We can go from any perfect configuration to a perfect configuration *) 63 | Lemma move_connect_ppeg n p1 p2 : `c[p1, n] `-->*_r `c[p2]. 64 | Proof. 65 | case: (p1 =P p2) => [->|/eqP p1Dp2] //. 66 | apply/connectP; exists (ppeg p1 p2); first by apply: path_ppeg. 67 | by rewrite last_ppeg. 68 | Qed. 69 | 70 | (* The proof is done by inspecting the moves that the last disk is doing in cs*) 71 | (* We use a double induction : *) 72 | (* The first induction is used when the path has duplicates *) 73 | (* The second induction is on n and to bound recursive call *) 74 | Lemma ppeg_min n p1 p2 (cs : seq (configuration 3 n)) : 75 | p1 != p2 -> path rmove `c[p1] cs -> last `c[p1] cs = `c[p2] -> 76 | (2^ n).-1 <= size cs ?= iff (cs == ppeg p1 p2). 77 | Proof. 78 | have irrH := @rirr 3; have symH := @rsym 3. 79 | (* The first induction is used when the path has duplicates (1 case) *) 80 | have [m sLm] := ubnP (size cs); elim: m => // m IHm in n p1 p2 cs sLm *. 81 | elim: n p1 p2 cs sLm => /= [p1 p2 [|] //|]n IH p1 p2 cs sLm p1Dp2. 82 | have /= := size_ppeg n.+1 p1 p2. 83 | (* Is there a move of the last first disk *) 84 | case: path3SP => //. 85 | (* No move : impossible since p1 != p2 *) 86 | case: cs sLm => /= [_ _ _ _ _ /ffunP /(_ ldisk)/eqP|a cs sLm]. 87 | by rewrite !ffunE (negPf p1Dp2). 88 | rewrite !ffunE => acsE _ _ _ lacsE. 89 | have := mem_last a cs. 90 | rewrite acsE lacsE inE => /orP[/eqP/ffunP/(_ ldisk)/eqP|]. 91 | by rewrite cliftr_ldisk !ffunE eq_sym (negPf p1Dp2). 92 | case/mapP => c _ /ffunP /(_ ldisk)/eqP. 93 | by rewrite cliftr_ldisk ffunE eq_sym (negPf p1Dp2). 94 | (* There is a move from p1 to p3 *) 95 | rewrite !ffunE perfect_unliftr /= => cs1 cs2 p3 p1Dp3 _. 96 | move=> p1cs1Lp1p3 csE p1Pcs1. 97 | have Scs1 : size cs1 < m.+1. 98 | by apply: leq_trans sLm; rewrite csE size_cat size_map ltnS leq_addr. 99 | have p1Dp1p3 : p1 != `p[p1, p3] by rewrite eq_sym opegDl. 100 | (* After the first move, last disk is on p3, the other disk is `p[p1, p3] *) 101 | have HL1 := IH _ _ _ Scs1 p1Dp1p3 p1Pcs1 p1cs1Lp1p3. 102 | have n2E : (2 ^ n.+1).-1 = (2 ^ n).-1 + (2 ^ n).-1.+1. 103 | by rewrite expnS mul2n -addnn -[2 ^ n]prednK ?expn_gt0. 104 | (* Is there another move *) 105 | case: path3SP => //=. 106 | (* there is no move so p3 = p2 and simple induction should make it *) 107 | rewrite cliftr_ldisk cliftrK /=. 108 | move=> cs2E p1p3Pcs2 _ sH _ p1csLp2. 109 | have p3E : p3 = p2. 110 | move: p1csLp2; rewrite csE cs2E last_cat /= last_map. 111 | by move=> /ffunP /(_ ldisk); rewrite cliftr_ldisk ffunE. 112 | rewrite p3E in p1cs1Lp1p3 csE HL1 cs2E p1p3Pcs2. 113 | have Scs2 : size [seq ↓[i] | i <- cs2] < m.+1. 114 | apply: leq_trans sLm. 115 | by rewrite csE size_cat !size_map /= ltnS -addSnnS leq_addl. 116 | have p1p2Lcs2 : last `c[`p[p1, p2]] [seq ↓[i] | i <- cs2] = `c[p2]. 117 | rewrite -[`c[_]](cliftrK p2) last_map. 118 | by have := p1csLp2; rewrite csE last_cat /= => ->; rewrite perfect_unliftr. 119 | have HL2 := IH _ _ _ Scs2 (opegDr _ _) p1p3Pcs2 p1p2Lcs2. 120 | move/leqifP : HL1; case: eqP => [<- /eqP HL1|_ HL1]. 121 | move/leqifP : HL2; case: eqP => [<- /eqP HL2|_ HL2]. 122 | rewrite size_map in HL2. 123 | rewrite csE size_cat /= size_map -HL1 -HL2 -cs2E eqxx //= n2E. 124 | by apply/leqifP. 125 | apply/leqifP; case: eqP => [/(congr1 size)->|_]. 126 | by rewrite -sH !size_cat /= !size_map -HL1 size_ppeg. 127 | rewrite csE size_cat /= !size_map in HL2 *. 128 | by rewrite -HL1 n2E ltn_add2l. 129 | apply/leqifP; case: eqP => [/(congr1 size)->|_]; first by rewrite -sH. 130 | rewrite csE size_cat /= !size_map in HL2 *. 131 | by rewrite n2E -addSn leq_add // ltnS HL2. 132 | move=> cs3 cs4 p4; rewrite -!/rmove !cliftr_ldisk cliftrK. 133 | move => p3Dp4 _ p1p3cs3Lp3p4 cs2E p1p3Pcs3 p3p4Pcs4 _ sH _ p1csLp2. 134 | (* we did two moves of the largest disk so we cannot be = *) 135 | apply/leqifP; case: eqP => [/(congr1 size)|_]. 136 | by rewrite size_cat /= !size_map !size_ppeg n2E => ->. 137 | (* Did we come back to p1 *) 138 | case: (p4 =P p1) => [p4Ep1 | /eqP p4Dp1]. 139 | rewrite p4Ep1 in p3Dp4 p1p3cs3Lp3p4 cs2E p3p4Pcs4. 140 | (* if so cs has a repetition so we can use IHm *) 141 | pose cs' := [seq ↑[i]_p1 | i <- cs1] ++ cs4. 142 | have Scs' : size cs' < size cs. 143 | rewrite csE /cs' cs2E !size_cat /= size_cat !size_map /=. 144 | by rewrite ltn_add2l -!addSnnS ltnS leq_addl. 145 | apply: leq_trans (Scs'); rewrite ltnS. 146 | rewrite (IHm _ p1 p2) //; first by rewrite (leq_trans Scs'). 147 | rewrite cat_path /= -[`c[_]](cunliftrK) ffunE perfect_unliftr. 148 | by rewrite path_liftr // p1Pcs1 /= last_map p1cs1Lp1p3 opeg_sym. 149 | rewrite last_cat /= -[`c[_]](cunliftrK) ffunE perfect_unliftr. 150 | rewrite last_map p1cs1Lp1p3. 151 | have := p1csLp2. 152 | by rewrite csE cs2E !last_cat /= last_cat /= opeg_sym. 153 | rewrite csE cs2E size_cat /= size_cat /= !size_map n2E !addnS !ltnS addnA. 154 | apply: leq_trans (leq_add _ _) (leq_addr _ _); first by rewrite HL1. 155 | have Scs3 : size cs3 < m.+1. 156 | apply: leq_trans sLm. 157 | rewrite csE cs2E size_cat /= size_cat /= !size_map addnC ltnS addnS !addSnnS. 158 | by rewrite -addnA leq_addr. 159 | rewrite (IH _ _ _ Scs3 _ p1p3Pcs3 p1p3cs3Lp3p4) //. 160 | by rewrite opeg3E // eq_sym opeg3E // eq_sym p1Dp3 p4Dp1 eq_sym opegDl. 161 | Qed. 162 | 163 | Lemma gdist_rhanoi3p n p1 p2 : 164 | `d[`c[p1, n], `c[p2]]_rmove = (2^ n).-1 * (p1 != p2). 165 | Proof. 166 | case: eqP => [<-|/eqP p1Dp2]; first by rewrite muln0 gdist0. 167 | rewrite muln1. 168 | apply/eqP; rewrite eqn_leq -(size_ppeg n p1 p2). 169 | rewrite gdist_path_le //=; last 2 first. 170 | - by apply: path_ppeg. 171 | - by rewrite last_ppeg. 172 | have /gpath_connect [cs csH] : connect rmove `c[p1, n] `c[p2]. 173 | by apply: move_connect_ppeg. 174 | rewrite size_ppeg (gpath_dist csH) /=. 175 | apply: ppeg_min p1Dp2 (gpath_path csH) _ => //. 176 | by apply: gpath_last csH. 177 | Qed. 178 | 179 | (*****************************************************************************) 180 | (* Function that builds a path from a configuration to a peg *) 181 | (*****************************************************************************) 182 | 183 | Fixpoint rpeg {n : nat} := 184 | if n is n1.+1 return configuration 3 n -> peg 3 -> seq (configuration 3 n) 185 | then 186 | fun c p => 187 | let p1 := c ldisk in 188 | if p1 == p then [seq ↑[i]_p | i <- rpeg ↓[c] p] else 189 | let p2 := `p[p1, p] in 190 | [seq ↑[i]_p1 | i <- rpeg ↓[c] p2] ++ 191 | [seq ↑[i]_p | i <- `c[p2] :: ppeg p2 p] 192 | else fun _ _ => [::]. 193 | 194 | Lemma rpeg_perfect n p : rpeg (`c[p]) p = [::] :> seq (configuration 3 n). 195 | Proof. 196 | elim: n => //= n IH. 197 | by rewrite ffunE eqxx perfect_unliftr IH. 198 | Qed. 199 | 200 | Lemma rpeg_nil_inv n c p : rpeg c p = [::] -> c = `c[p] :> configuration _ n. 201 | Proof. 202 | elim: n c => [c _|n IH c] /=; first by apply/ffunP=> [] []. 203 | case: eqP => [H | H] //=; last by case: map. 204 | rewrite -{2}[c]cunliftrK. 205 | case: rpeg (IH (↓[c])) => // -> // _. 206 | by rewrite H perfect_liftr. 207 | Qed. 208 | 209 | Lemma rpeg_ppeg n p1 p2 : p1 != p2 -> rpeg `c[p1, n] p2 = ppeg p1 p2. 210 | Proof. 211 | elim: n p1 p2 => //= n IH p1 p2 p1Dp2. 212 | by rewrite ffunE perfect_unliftr (negPf p1Dp2) !IH // eq_sym opegDl. 213 | Qed. 214 | 215 | Lemma last_rpeg n (c : configuration 3 n) p (cs := rpeg c p) : 216 | last c cs = `c[p]. 217 | Proof. 218 | rewrite /cs; elim: n c p {cs} => /= [c p| n IH c p]. 219 | by apply/ffunP=> [] []. 220 | case: eqP => [Ho|/eqP Do]. 221 | by rewrite -{1}[c](cunliftrK) Ho last_map IH perfect_liftr. 222 | by rewrite last_cat /= last_map last_ppeg perfect_liftr. 223 | Qed. 224 | 225 | Lemma path_rpeg n (c : configuration 3 n) p (cs := rpeg c p) : 226 | path rmove c cs. 227 | Proof. 228 | have HH := @rirr 3. 229 | rewrite /cs; elim: n c p {cs} => //= n IH c p. 230 | case: eqP => [Ho|/eqP Do]. 231 | by rewrite -{1}[c](cunliftrK) Ho path_liftr. 232 | set c2 := `c[_]. 233 | rewrite cat_path /= -{1}[c]cunliftrK !path_liftr // IH path_ppeg ?opegDr //. 234 | rewrite andbT /=. 235 | rewrite -{1}[c]cunliftrK last_map last_rpeg -/c2. 236 | apply: move_liftr_perfect => //; first by rewrite eq_sym (opegDl _). 237 | by rewrite eq_sym (opegDr _). 238 | Qed. 239 | 240 | (* We can go from any configuration to a perfect configuration *) 241 | Lemma move_connect_rpeg n (c : configuration _ n) p : c `-->*_r `c[p]. 242 | Proof. 243 | apply/connectP; exists (rpeg c p); first by apply: path_rpeg. 244 | by rewrite last_rpeg. 245 | Qed. 246 | 247 | (* So we can also from a perfect configuration c to any configuration *) 248 | Lemma move_connect_lpeg n (c : configuration _ n) p : `c[p] `-->*_r c. 249 | Proof. 250 | rewrite [connect _ _ _]connect_sym //. 251 | by apply: move_connect_rpeg. 252 | by exact: rsym. 253 | Qed. 254 | 255 | (* Two configurations are always connected *) 256 | Lemma move_connect n (c1 c2 : configuration 3 n) : c1 `-->*_r c2. 257 | Proof. 258 | by apply: connect_trans (move_connect_rpeg c1 (inord 1)) 259 | (move_connect_lpeg c2 (inord 1)). 260 | Qed. 261 | 262 | (******************************************************************************) 263 | (* Function that builds a path from a configuration to a peg *) 264 | (******************************************************************************) 265 | 266 | 267 | (*****************************************************************************) 268 | (* Computes the size of rpeg *) 269 | (*****************************************************************************) 270 | 271 | Fixpoint size_rpeg {n : nat} : (configuration _ n) -> _ -> nat := 272 | match n with 273 | | 0 => fun _ _ => 0 274 | | n1.+1 => 275 | fun c p => 276 | let p1 := c ldisk in 277 | if p1 == p then size_rpeg ↓[c] p else 278 | let p2 := `p[p1, p] in size_rpeg ↓[c] p2 + 2 ^ n1 279 | end. 280 | 281 | Lemma size_rpegE n p (c : _ _ n) : size_rpeg c p = size (rpeg c p). 282 | Proof. 283 | elim: n p c => //= n IH p c. 284 | case: eqP => [clEp|/eqP clDp]; first by rewrite size_map IH. 285 | by rewrite size_cat /= !size_map size_ppeg prednK ?expn_gt0 // IH. 286 | Qed. 287 | 288 | (* Upper bound on the size *) 289 | Lemma size_rpeg_up n (c : _ _ n) p : size_rpeg c p <= (2^ n).-1. 290 | Proof. 291 | elim: n c p => //= n IH c p. 292 | case: eqP => _. 293 | apply: (leq_trans (IH _ _)). 294 | case: (_ ^ _) (expn_eq0 2 n) (expn_eq0 2 n.+1) 295 | (leq_pexp2l (isT: 0 < 2) (ltnW (leqnn n.+1))) => //= n1 _. 296 | by case: (_ ^ _). 297 | apply: leq_trans (_ : (2^n).-1 + (2^n) <= _). 298 | by rewrite leq_add2r IH. 299 | rewrite expnS mul2n -addnn. 300 | by case: (2 ^ n) (expn_eq0 2 n) => [|n1]; rewrite ?addn0. 301 | Qed. 302 | 303 | (* rpeg gives the smallest path to a perfect configuration. *) 304 | (* This path is unique *) 305 | Lemma rpeg_min n (c : configuration 3 n) p cs : 306 | path rmove c cs -> last c cs = `c[p] -> 307 | size_rpeg c p <= size cs ?= iff (cs == rpeg c p). 308 | Proof. 309 | (* As we want this statememnt to hold for any configuration c1 *) 310 | (* and not just for initial perfect configuration the proof is more *) 311 | (* intricate. We need a double induction : *) 312 | (* The first induction is used when the path has duplicates (1 case) *) 313 | have [m sLm] := ubnP (size cs); elim: m => // m IHm in n c p cs sLm *. 314 | (* The usual induction on the number of disks *) 315 | elim : n c p cs sLm => [c1 p [|] //=|n IH c1 p cs Scs c1Pcs lc1csEp /=]. 316 | case: (_ =P p) => [c1nEp |/eqP c1nDp]. 317 | (* the largest disk is already well-placed *) 318 | have lcsnEc1n : last c1 cs ldisk = c1 ldisk. 319 | by rewrite lc1csEp !ffunE. 320 | have [cs1 [c1Pcs1 lcsElcs1 /leqifP]] := 321 | pathS_restrict (@rirr 3) c1Pcs. 322 | have lcs1P : last (↓[c1]) cs1 = `c[p]. 323 | by rewrite lcsElcs1 lc1csEp perfect_unliftr. 324 | case: eqP=> [csEcs1 /eqP<- |/eqP csDcs1 scs1L]. 325 | rewrite csEcs1 c1nEp eq_map_liftr. 326 | apply: IH => //. 327 | by move: Scs; rewrite csEcs1 size_map. 328 | apply/leqifP; case: eqP => [->|_]. 329 | by rewrite size_map size_rpegE. 330 | apply: leq_ltn_trans (scs1L). 331 | apply: IH => //. 332 | by apply: ltn_trans Scs. 333 | pose f (c : configuration 3 n.+1) := c ldisk. 334 | have HHr := @rirr 3. 335 | have HHs := @rsym 3. 336 | (* We need to move the largest disk *) 337 | case: path3SP c1Pcs => // [c1' cs' p1 csE c1'Pcs' _| 338 | cs1 cs2 p1 p2 p3 c1' c2 339 | p1Dp2 p1Rp2 lc1'cs1Epp3 csE c1'Pcs1 c2Pcs2 _]. 340 | (* this case is impossible the largest disk has to move *) 341 | case/eqP: c1nDp. 342 | move : lc1csEp; rewrite csE -[c1](cunliftrK) last_map => /(congr1 f). 343 | by rewrite /f !cliftr_ldisk !ffunE. 344 | (* c2 is the first configuration when the largest disk has moved *) 345 | rewrite csE size_cat -/p1. 346 | have p1Dp : p1 != p by []. 347 | have Scs1 : size cs1 < m.+1. 348 | apply: ltn_trans Scs. 349 | by rewrite csE size_cat /= size_map addnS ltnS leq_addr. 350 | have Scs2 : size cs2 < m.+1. 351 | apply: ltn_trans Scs. 352 | by rewrite csE size_cat /= size_map addnS ltnS leq_addl. 353 | case: (p2 =P p) => [p2Ep|/eqP p2Dp]. 354 | pose c2' := ↓[c2]. 355 | have c2'Epp3 : c2' = `c[`p[p1, p2]] by rewrite [LHS]cliftrK. 356 | (* the first moves of largest disk of cs is the right one *) 357 | have/(pathS_restrict HHr)[cs2' [c2'Pcs2' lc2'cs2'E cs2'L]] := c2Pcs2. 358 | have Scs2' : size cs2' < m.+1. 359 | by apply: leq_ltn_trans Scs2; rewrite cs2'L. 360 | have /IH := lc1'cs1Epp3 => // /(_ Scs1 c1'Pcs1) IHc1. 361 | have /IH : last c2' cs2' = `c[p] => [| /(_ Scs2' c2'Pcs2') IHc2]. 362 | rewrite lc2'cs2'E -perfect_unliftr. 363 | by move: lc1csEp; rewrite csE last_cat /= => ->. 364 | rewrite -p2Ep in IHc2. 365 | move /leqifP : cs2'L. 366 | case: eqP => [cs2E _ | /eqP cs2D Lcs2]. 367 | (* there is only one move of the largest disk in cs *) 368 | rewrite cs2E size_map -p2Ep -/p3. 369 | have /leqifP := IHc1; case: eqP => [->_ |_ Lc1]. 370 | (* the first part of cs is perfect *) 371 | have /leqifP := IHc2; case: eqP => [->_ |_ Lc2]. 372 | (* the second part of cs is perfect, only case of equality *) 373 | apply/leqifP; case: eqP => [/(congr1 size)|[]]. 374 | rewrite !size_cat /= !size_map !addnS !size_rpegE c2'Epp3. 375 | by rewrite !rpeg_ppeg ?opegDr // size_ppeg -addnS prednK ?expn_gt0. 376 | congr (_ ++ _ :: _). 377 | by rewrite /c2' /c2 cliftrK cliftr_ldisk rpeg_ppeg // opegDr. 378 | apply/leqifP; case: eqP => [/(congr1 size)|_]. 379 | rewrite !size_cat /= !size_map !size_rpegE. 380 | by rewrite size_ppeg prednK ?expn_gt0 // => ->. 381 | rewrite /= size_rpegE ltn_add2l ltnS size_map. 382 | rewrite c2'Epp3 size_rpegE rpeg_ppeg ?opegDr // size_ppeg in Lc2. 383 | by rewrite prednK // expn_gt0 in Lc2. 384 | apply/leqifP; case: eqP => [/(congr1 size)|_]. 385 | rewrite !size_cat /= !size_map !size_rpegE => ->. 386 | by rewrite size_ppeg prednK // expn_gt0. 387 | rewrite /= -addSn leq_add // size_map -[_ ^ _]prednK ?expn_gt0 // ltnS. 388 | have := IHc2; rewrite c2'Epp3 size_rpegE rpeg_ppeg ?opegDr // size_ppeg. 389 | by move=>->. 390 | apply/leqifP; case: eqP => [/(congr1 size)|_]. 391 | rewrite !size_cat /= !size_map !size_rpegE. 392 | by rewrite size_ppeg prednK ?expn_gt0 // => ->. 393 | rewrite -addnS leq_add //= ?ltnS -?p2Ep. 394 | by rewrite size_map IHc1. 395 | rewrite -[_ ^ _]prednK ?expn_gt0 //. 396 | apply: leq_ltn_trans Lcs2. 397 | have := IHc2. 398 | by rewrite c2'Epp3 size_rpegE rpeg_ppeg ?opegDr // size_ppeg => ->. 399 | (* The largest disk jumped to an intermediate peg *) 400 | have p3Ep : p3 = p. 401 | by apply/eqP; rewrite opeg3E // p1Dp. 402 | (* cs cannot be optimal *) 403 | apply/leqifP; case: eqP => [/(congr1 size)|_]. 404 | rewrite !size_cat /= !size_map !size_rpegE. 405 | by rewrite size_ppeg prednK ?expn_gt0 // => ->. 406 | case: path3SP c2Pcs2 => // [c2' cs2'|cs3 cs4]. 407 | (* this is impossible we need another move of the largest disk *) 408 | rewrite !cliftr_ldisk /= => cs2E c2'Pcs2'. 409 | case/eqP: p2Dp. 410 | have := lc1csEp. 411 | rewrite csE last_cat /= => /(congr1 f). 412 | by rewrite /f cs2E last_map !cliftr_ldisk !ffunE. 413 | rewrite !cliftr_ldisk => p2'. 414 | rewrite {}/p2' => p4. 415 | set p5 := `p[p2, p4]; set c2' := ↓[c2]. 416 | move=> p2Dp4 p2Rp4 c2'cs5Epp5 cs2E c2'Pcs3 pp5p4Pcs4 _. 417 | case: (p5 =P p3) => [p5Ep3 /= | /eqP p5Dp3]. 418 | (* the path has a duplicate use the induction hypothesis *) 419 | have p4Ep1: p4 = p1. 420 | move/eqP : p5Ep3; rewrite eq_sym // opeg3E // eq_sym //. 421 | by rewrite opeg3E // negb_and !negbK eq_sym (negPf p1Dp2) 422 | => /andP[/eqP] . 423 | pose cs5 := [seq ↑[i]_p1 | i <- cs1] ++ cs4. 424 | have scs5Lscs : size cs5 < size cs. 425 | rewrite /cs5 csE cs2E !size_cat /= !size_cat /= !size_map. 426 | rewrite ltn_add2l // !addnS! ltnS -addSn leq_addl //. 427 | have c1Mcs5 : path rmove c1 cs5. 428 | rewrite cat_path -[c1](cunliftrK) !path_liftr //=. 429 | rewrite c1'Pcs1. 430 | by rewrite last_map lc1'cs1Epp3 -/p1 -p5Ep3 -p4Ep1. 431 | have lc1cs5E : last c1 cs5 = `c[p]. 432 | rewrite last_cat -[c1](cunliftrK) last_map lc1'cs1Epp3. 433 | rewrite -lc1csEp csE cs2E last_cat /= last_cat /= -/p1. 434 | by rewrite p5Ep3 p4Ep1. 435 | apply: leq_trans (_ : size cs5 < _); last first. 436 | by rewrite cs2E /= !size_cat !size_map /= 437 | ltn_add2l // ltnS -addSnnS leq_addl. 438 | rewrite ltnS. 439 | have /IHm : size cs5 < m. 440 | rewrite -ltnS. 441 | by apply: leq_ltn_trans Scs. 442 | move=> /(_ c1 p c1Mcs5 lc1cs5E) /=. 443 | by rewrite -/p1 (negPf p1Dp) => ->. 444 | (* now we just need to use the induction principle on the two subpath *) 445 | have [cs4' [pp5p4Pcs4' lpp5p4cs4'Elpp5p4cs4 scs4'L]] := 446 | pathS_restrict HHr pp5p4Pcs4. 447 | rewrite cliftrK in lpp5p4cs4'Elpp5p4cs4 pp5p4Pcs4'. 448 | have Scs3 : size cs3 < m.+1. 449 | apply: ltn_trans Scs2. 450 | by rewrite cs2E size_cat /= size_map addnS ltnS leq_addr. 451 | have Scs4 : size cs4 < m.+1. 452 | apply: ltn_trans Scs2. 453 | by rewrite cs2E size_cat /= size_map addnS ltnS leq_addl. 454 | have Scs4' : size cs4' < m.+1. 455 | by apply: leq_ltn_trans Scs4; rewrite scs4'L. 456 | rewrite cs2E /= size_cat /= !size_map. 457 | have /IH := c2'cs5Epp5 => /(_ Scs3 c2'Pcs3) IHc1. 458 | have c2'E : c2' = `c[p3] by rewrite [LHS]cliftrK. 459 | rewrite c2'E size_rpegE rpeg_ppeg // in IHc1; last by rewrite eq_sym. 460 | rewrite size_ppeg in IHc1. 461 | have p6Dp : p5 != p. 462 | by apply: contra p5Dp3 => /eqP->; apply/eqP. 463 | move: lc1csEp; rewrite csE cs2E. 464 | rewrite last_cat /= last_cat /= => lpp5p4cs4Epp. 465 | have lpp5cs4'Epp : last `c[p5] cs4' = `c[p]. 466 | by rewrite lpp5p4cs4'Elpp5p4cs4 lpp5p4cs4Epp perfect_unliftr. 467 | have /IH : last `c[p5] cs4' = `c[p] => [//| /(_ Scs4' pp5p4Pcs4') IHc2]. 468 | rewrite size_rpegE rpeg_ppeg // size_ppeg in IHc2. 469 | rewrite -[2 ^ n]prednK ?expn_gt0 //. 470 | rewrite !addnS !ltnS. 471 | apply: leq_trans (leq_addl _ _). 472 | apply: leq_add. 473 | by apply: leq_trans (size_rpeg_up _ _) _; rewrite IHc1. 474 | apply: leq_trans scs4'L. 475 | by rewrite IHc2. 476 | Qed. 477 | 478 | Lemma gdist_size_rpeg n (c1 : _ _ n) p : `d[c1, `c[p]]_rmove = size_rpeg c1 p. 479 | Proof. 480 | apply/eqP; rewrite eqn_leq [size_rpeg _ _]size_rpegE. 481 | rewrite gdist_path_le; last 2 first. 482 | - by apply: path_rpeg. 483 | - by rewrite last_rpeg. 484 | have /gpath_connect [p1 p1H] : connect rmove c1 `c[p]. 485 | by apply: move_connect_rpeg. 486 | rewrite -size_rpegE (gpath_dist p1H) /=. 487 | apply: (rpeg_min (gpath_path p1H)) => //. 488 | by apply: gpath_last p1H. 489 | Qed. 490 | 491 | Lemma gdist_perfect_le n (c : configuration 3 n) p : 492 | `d[c, `c[p]]_rmove <= (2^ n).-1. 493 | Proof. by rewrite gdist_size_rpeg; apply: size_rpeg_up. Qed. 494 | 495 | (******************************************************************************) 496 | (* Function that builds a path from a peg to a configuration *) 497 | (******************************************************************************) 498 | 499 | Definition lpeg n p (c : _ _ n) := rev (belast c (rpeg c p)). 500 | 501 | Lemma lpeg_perfect n p : lpeg p `c[p, n] = [::]. 502 | Proof. by rewrite /lpeg rpeg_perfect. Qed. 503 | 504 | Lemma lpeg_nil_inv n c p : 505 | lpeg p c = [::] -> c = `c[p] :> configuration _ n. 506 | Proof. 507 | have := @rpeg_nil_inv _ c p. 508 | rewrite /lpeg; case: rpeg => //= a l. 509 | by rewrite rev_cons; case: rev. 510 | Qed. 511 | 512 | Lemma path_lpeg n (c : configuration 3 n) p (cs := lpeg p c) : 513 | path rmove `c[p] cs. 514 | Proof. 515 | have HHs := @rsym 3. 516 | rewrite {}/cs /lpeg -(last_rpeg c) path_move_rev //. 517 | by apply: path_rpeg. 518 | Qed. 519 | 520 | Lemma last_lpeg n (c : configuration 3 n) p (cs := lpeg p c) : 521 | last `c[p] cs = c. 522 | Proof. 523 | have HHs := @rsym 3; have := last_rpeg c p. 524 | rewrite {}/cs /lpeg; case: rpeg => //= c1 cs. 525 | by rewrite rev_cons last_rcons. 526 | Qed. 527 | 528 | Lemma size_lpegE n (c : _ _ n) p : 529 | size_rpeg c p = size (lpeg p c). 530 | Proof. by rewrite size_rev size_belast size_rpegE. Qed. 531 | 532 | Lemma lpeg_min n (c : configuration 3 n) p cs : 533 | path rmove `c[p] cs -> last `c[p] cs = c -> 534 | size_rpeg c p <= size cs ?= iff (cs == lpeg p c). 535 | Proof. 536 | (* why this is so complicated???? *) 537 | move=> pPcs lccsEc. 538 | have HHs := @rsym 3. 539 | have cPr : path rmove c (rev (belast `c[p] cs)). 540 | by rewrite -{1}lccsEc path_move_rev. 541 | have lcrEp : last c (rev (belast `c[p] cs)) = `c[p]. 542 | rewrite -lccsEc; case: (cs)=> //= c3 cs1. 543 | by rewrite rev_cons last_rcons. 544 | have := rpeg_min cPr lcrEp. 545 | rewrite /lpeg size_rev size_belast. 546 | set u := rev _ ; set v := rpeg _ _. 547 | have -> : (u == v) = (rev (c :: u) == rev (c :: v)). 548 | rewrite !rev_cons eqseq_rcons eqxx andbT. 549 | apply/eqP/eqP=> [->//|]. 550 | by rewrite -{2}[u]revK => ->; rewrite revK. 551 | rewrite [c :: v]lastI -/v rev_rcons. 552 | rewrite rev_cons revK -{2}lccsEc -lastI eqseq_cons andbC. 553 | case: eqP=> //; case: eqP => // pDl Hcs; case: pDl. 554 | by rewrite last_rpeg. 555 | Qed. 556 | 557 | Fixpoint rhanoi3 {n : nat} := 558 | if n is n1.+1 return configuration 3 n -> configuration 3 n -> _ 559 | _ then 560 | fun c1 c2 => 561 | let p1 := c1 ldisk in 562 | let p2 := c2 ldisk in 563 | let c1' := ↓[c1] in 564 | let c2' := ↓[c2] in 565 | if p1 == p2 then [seq ↑[i]_p1 | i <- rhanoi3 c1' c2'] else 566 | let p := `p[p1, p2] in 567 | (* one jump *) 568 | let m1 := size_rpeg c1' p + size_rpeg c2' p in 569 | (* two jumps *) 570 | let m2 := size_rpeg c1' p2 + 2 ^ n1 + size_rpeg c2' p1 571 | in if m1 <= m2 then 572 | [seq ↑[i]_p1 | i <- rpeg c1' p] ++ 573 | [seq ↑[i]_p2 | i <- `c[p] :: lpeg p c2'] 574 | else 575 | [seq ↑[i]_p1 | i <- rpeg c1' p2] ++ 576 | [seq ↑[i]_p | i <- `c[p2] :: ppeg p2 p1] ++ 577 | [seq ↑[i]_p2 | i <- `c[p1] :: lpeg p1 c2'] 578 | else fun _ _ => [::]. 579 | 580 | Lemma last_rhanoi3 n (c1 c2 : _ _ n) (cs := rhanoi3 c1 c2) : 581 | last c1 cs = c2. 582 | Proof. 583 | have HHr := @rirr 3. 584 | rewrite {}/cs. 585 | elim: n c1 c2 => /= [c1 c2 |n IH c1 c2]; first by apply/ffunP=> [] []. 586 | set p1 := _ ldisk; set p2 := _ ldisk. 587 | set c3 := cliftr _ _; set c4 := cliftr _ _; set c5 := cliftr _ _. 588 | set p := `p[_, _]. 589 | case: eqP => [p1Ep2|/eqP p1Dp2]. 590 | by rewrite -{1}[c1]cunliftrK last_map IH [c1 _]p1Ep2 cunliftrK. 591 | case: leqP => _; first by rewrite last_cat /= last_map last_lpeg cunliftrK. 592 | by rewrite last_cat /= last_cat /= last_map last_lpeg cunliftrK. 593 | Qed. 594 | 595 | Lemma path_rhanoi3 n (c1 c2 : _ _ n) (cs := rhanoi3 c1 c2) : 596 | path rmove c1 cs. 597 | Proof. 598 | have HHr := @rirr 3. 599 | rewrite {}/cs. 600 | elim: n c1 c2 => //= n IH c1 c2. 601 | set p1 := _ ldisk; set p2 := _ ldisk. 602 | set c3 := cliftr _ _; set c4 := cliftr _ _; set c5 := cliftr _ _. 603 | set p := `p[_, _]. 604 | case: eqP => [p1Ep2|/eqP p1Dp2]. 605 | by rewrite -{1}[c1]cunliftrK path_liftr. 606 | case: leqP => _; rewrite !cat_path /=; apply/and3P; split. 607 | - by rewrite -{1}[c1]cunliftrK path_liftr // path_rpeg. 608 | - rewrite -{1}[c1]cunliftrK last_map last_rpeg. 609 | apply/moveP; exists ldisk. 610 | split => // [|d dmDd||]. 611 | - by rewrite !cliftr_ldisk. 612 | - rewrite !ffunE; case: tsplitP => [j|j jE]; first by rewrite !ffunE. 613 | by case/eqP: dmDd; apply/val_eqP; rewrite /= jE; case: (j) => [] []. 614 | - apply/on_topP=> d; rewrite !cliftr_ldisk !ffunE. 615 | case: tsplitP => [j _ /eqP|j jE]. 616 | by rewrite !ffunE -/p1 eq_sym (negPf (opegDl _ _)). 617 | by rewrite /= !ffunE jE /= leq_addl. 618 | apply/on_topP=> d; rewrite /= !cliftr_ldisk !ffunE. 619 | case: tsplitP => [j _ /eqP|j ->]; last by case: j => [] []. 620 | by rewrite !ffunE eq_sym (negPf (opegDr _ _)). 621 | - by rewrite -[c3]cunliftrK !cliftr_ldisk /= path_liftr // cliftrK path_lpeg. 622 | - by rewrite -{1}[c1]cunliftrK path_liftr // path_rpeg. 623 | - rewrite -{1}[c1]cunliftrK last_map last_rpeg. 624 | apply/moveP; exists ldisk; split => // [|d2||]; 625 | rewrite ?cliftr_ldisk ?ffunE //=. 626 | - by rewrite /rrel /= eq_sym opegDl. 627 | - case: tsplitP => //= j d2E /eqP[]. 628 | by apply/val_eqP; rewrite /= d2E; case: (j) => [] []. 629 | - apply/on_topP=> d2. 630 | rewrite cliftr_ldisk /= !ffunE. 631 | case: tsplitP => [k _ /eqP | [[]] // j -> //]. 632 | by rewrite ?ffunE (negPf p1Dp2). 633 | apply/on_topP=> d2. 634 | rewrite cliftr_ldisk /= !ffunE. 635 | case: tsplitP => [k _ /eqP | [[]] // j -> //]. 636 | by rewrite !ffunE (negPf (opegDr _ _)). 637 | rewrite cat_path /=; apply/and3P; split => //. 638 | - rewrite -[c4]cunliftrK cliftr_ldisk -/p path_liftr // cliftrK // path_ppeg //. 639 | by rewrite eq_sym. 640 | - rewrite -[c4]cunliftrK cliftr_ldisk -/p last_map cliftrK // last_ppeg //. 641 | apply/moveP; exists ldisk; split => // [|d2||]; 642 | rewrite ?cliftr_ldisk ?ffunE /=. 643 | - by rewrite /rrel /= opegDr. 644 | - case: tsplitP => [j | j d2E /eqP[]] //=. 645 | by apply/val_eqP => /=; rewrite d2E; case: (j) => [] []. 646 | - apply/on_topP=> d2. 647 | rewrite cliftr_ldisk /= !ffunE. 648 | case: tsplitP => [k _ /eqP | [[]] // j -> //]. 649 | by rewrite !ffunE (negPf (opegDl _ _)). 650 | apply/on_topP=> d2. 651 | rewrite cliftr_ldisk /= !ffunE. 652 | case: tsplitP => [k _ /eqP | [[]] // j -> //]. 653 | by rewrite !ffunE eq_sym (negPf p1Dp2). 654 | by rewrite path_liftr // path_lpeg. 655 | Qed. 656 | 657 | Lemma rhanoi3_min n (c1 c2 : configuration 3 n) cs : 658 | path rmove c1 cs -> last c1 cs = c2 -> 659 | size (rhanoi3 c1 c2) <= size cs. 660 | Proof. 661 | have HHr := @rirr 3. 662 | have HHs := @rsym 3. 663 | elim: n c1 c2 cs => [p c1 [|]//|n IH c1 c2 cs /=]. 664 | set p := `p[_, _]; set p1 := _ ldisk; set p2 := _ ldisk. 665 | case: eqP => [p1Ep2 c1Pcs lc1csEc2|/eqP p1Dp2 c1Pcs lc1csEc2]. 666 | have lcsmEc1m : last c1 cs ldisk = p1 by rewrite lc1csEc2. 667 | have [cs1 [c1Pcs1 lc1csElcs1 /leq_of_leqif/(leq_trans _)->//]] := 668 | pathS_restrict (@rirr 3) c1Pcs. 669 | by rewrite size_map IH // lc1csElcs1 lc1csEc2. 670 | set u := _ + _; set v := _ + _. 671 | suff : minn u v < size cs. 672 | rewrite minnC /minn; case: (leqP u) => H1; 673 | rewrite !size_cat /= ?size_cat /= !addnS ?ltnS 674 | !size_map -size_rpegE -size_lpegE -/u => Lscs. 675 | by apply: leq_trans Lscs. 676 | apply: leq_ltn_trans _ Lscs. 677 | rewrite -addnS -addSn !addnA !leq_add //. 678 | by rewrite -[2 ^ _]prednK ?expn_gt0 // ltnS size_ppeg. 679 | pose f (c : configuration 3 n.+1) := c ldisk. 680 | have [m Lcs] := ubnP (size cs); elim: m => // m IH1 in cs Lcs c1Pcs lc1csEc2 *. 681 | case: path3SP c1Pcs => // [c1' cs' /= csE c1'Pcs' _| 682 | cs1 cs2 p1' p3 p4 c1' c3 p1Dp3 p1Rp3 lc1'cs1Epp4 csE 683 | c1'Pcs1 c3Pcs2 _]. 684 | case/eqP: p1Dp2. 685 | have := congr1 f lc1csEc2. 686 | rewrite /f csE -{1}[c1](cunliftrK) last_map. 687 | by rewrite !cliftr_ldisk. 688 | have p1'Ep1 : p1' = p1 by []. 689 | move: Lcs; rewrite csE size_cat size_map /= addnS ltnS => Lcs. 690 | move: lc1csEc2; rewrite csE last_cat /= => lc3cs2Ec2. 691 | have [/eqP p3Ep2 | p3Dp2] := boolP (p3 == p2). 692 | have p4Ep : p4 = p. 693 | apply/eqP; rewrite opeg3E // eq_sym opeg3E // negb_and !negbK eqxx /=. 694 | by rewrite eq_sym opeg3E // p1Dp3 eq_sym p3Ep2 eqxx. 695 | have [cs2' [pp4Pcs2' pp4cs2'E scs2'Lscs2]]:= pathS_restrict HHr c3Pcs2. 696 | rewrite cliftrK in pp4Pcs2' pp4cs2'E. 697 | apply: leq_trans (leq_add (leqnn _) scs2'Lscs2). 698 | apply: leq_trans (geq_minl _ _) _. 699 | apply: leq_add. 700 | apply: leq_of_leqif (rpeg_min _ _ ) => //. 701 | by rewrite lc1'cs1Epp4; congr `c[`p[_, _]]. 702 | apply: leq_of_leqif (lpeg_min _ _ ); rewrite -p4Ep //. 703 | by rewrite pp4cs2'E lc3cs2Ec2. 704 | have p3Ep : p3 = p. 705 | by apply/eqP; rewrite eq_sym opeg3E // -/p1 -p1'Ep1 p1Dp3 eq_sym. 706 | have p4Ep2 : p4 = p2. 707 | apply/eqP. 708 | rewrite /p4 p3Ep /p -/p1 -/p2 p1'Ep1 !opeg3E //. 709 | by rewrite p1Dp2 negbK eqxx. 710 | by rewrite eq_sym opeg3E // eqxx eq_sym. 711 | case: path3SP c3Pcs2=> // [c3' cs2' p5 cs2E c3'Pcs2' _| 712 | cs3 cs4 p5 p6 p7 c3' c4 p5Dp6 p5p6 713 | c3'cs3Epp7 cs2E c3'Pcs3 c4Pcs4 _]. 714 | have := congr1 f lc3cs2Ec2. 715 | rewrite cs2E /f -[c3]cunliftrK last_map !cliftr_ldisk -/p2 /= 716 | => p3Ep2. 717 | by case/eqP: p3Dp2. 718 | have p5Ep: p5 = p by rewrite /p5 /c3 !cliftr_ldisk. 719 | move: lc3cs2Ec2 Lcs; rewrite cs2E last_cat /= size_cat /= size_map => 720 | lc6cs4Ec2 Lcs. 721 | rewrite -addSnnS ltnS. 722 | have [/eqP p6Ep1|p6Dp1] := boolP (p6 == p1). 723 | have p7Ep2 : p7 = p2. 724 | apply/eqP. 725 | by rewrite opeg3E // p5Ep p6Ep1 opeg3E // p1Dp2 eqxx. 726 | apply: leq_trans (_ : size (map (cliftr p1) cs1 ++ cs4) <= _). 727 | apply/ltnW/IH1. 728 | - by rewrite size_cat !size_map (leq_trans _ Lcs) // ltnS; 729 | rewrite leq_add2l -addSnnS leq_addl. 730 | - rewrite cat_path -{1}[c1]cunliftrK path_liftr //=. 731 | rewrite c1'Pcs1. 732 | by rewrite -{1}[c1]cunliftrK last_map lc1'cs1Epp4 733 | -/p1 -p6Ep1 p4Ep2 -p7Ep2. 734 | rewrite last_cat -{1}[c1]cunliftrK last_map. 735 | by rewrite lc1'cs1Epp4 -/p1 -p6Ep1 p4Ep2 -p7Ep2. 736 | by rewrite size_cat size_map leq_add2l leq_addl. 737 | have p6Ep2 : p6 = p2. 738 | case: (p6 =P p2) => // /eqP p6Dp2. 739 | case/negP: p5Dp6. 740 | by rewrite p5Ep opeg3E // eq_sym p6Dp1 eq_sym. 741 | have p7Ep1 : p7 = p1. 742 | apply/eqP. 743 | by rewrite opeg3E // p5Ep opeg3E // eqxx. 744 | apply: leq_trans (geq_minr _ _) _. 745 | rewrite -[v]addnA leq_add //. 746 | apply: leq_of_leqif (rpeg_min _ _ ) => //. 747 | by rewrite lc1'cs1Epp4 p4Ep2. 748 | apply: leq_add. 749 | rewrite -[2 ^ _]prednK ?expn_gt0 // ltnS. 750 | have <-: size_rpeg (↓[c3]) p1 = (2 ^ n).-1. 751 | by rewrite cliftrK size_rpegE rpeg_ppeg ?opegDl // size_ppeg. 752 | apply: leq_of_leqif (rpeg_min _ _) => //. 753 | by rewrite c3'cs3Epp7 p7Ep1. 754 | have [cs4' [c4'Pcs4' lc4'cs4'Elc4cs4 /leq_of_leqif Lcs4']] := 755 | pathS_restrict HHr c4Pcs4. 756 | rewrite cliftrK p7Ep1 in c4'Pcs4'. 757 | rewrite cliftrK p7Ep1 in lc4'cs4'Elc4cs4. 758 | apply: leq_trans Lcs4'. 759 | apply: leq_of_leqif (lpeg_min _ _) => //. 760 | by rewrite lc4'cs4'Elc4cs4 lc6cs4Ec2. 761 | Qed. 762 | 763 | Fixpoint size_rhanoi3 {n : nat} : _ _ n -> _ _ n -> nat := 764 | if n is n1.+1 then 765 | fun c1 c2 : configuration 3 n1.+1 => 766 | let p1 := c1 ldisk in 767 | let p2 := c2 ldisk in 768 | let c1' := ↓[c1] in 769 | let c2' := ↓[c2] in 770 | if p1 == p2 then size_rhanoi3 c1' c2' else 771 | (* one jump *) 772 | let p := `p[p1, p2] in 773 | let m1 := size_rpeg c1' p + size_rpeg c2' p in 774 | (* two jumps *) 775 | let m2 := size_rpeg c1' p2 + 2 ^ n1 + size_rpeg c2' p1 776 | in (minn m1 m2).+1 777 | else fun _ _ => 0. 778 | 779 | (* size computes the size *) 780 | Lemma size_rhanoi3E n (c1 c2 : _ _ n) : size_rhanoi3 c1 c2 = size (rhanoi3 c1 c2). 781 | Proof. 782 | elim: n c1 c2 => //= n IH c1 c2. 783 | case: eqP => [E|/eqP NE]. 784 | by rewrite size_map; apply: IH. 785 | set p := `p[_, _]. 786 | set x := size_rpeg _ _; set y := size_rpeg _ _. 787 | set z := size_rpeg _ _; set t := size_rpeg _ _. 788 | rewrite fun_if. 789 | rewrite size_cat /= size_cat /= size_cat /= !size_map. 790 | rewrite -!(size_rpegE, size_lpegE) /=. 791 | rewrite -/x -/y -/z -/t. 792 | rewrite size_ppeg -[_ + t.+1]addSnnS prednK ?expn_gt0 //. 793 | rewrite !addnS. 794 | rewrite /minn !addnA. 795 | case: leqP => LL1; case: leqP => LL2 //. 796 | by congr (_.+1); apply/eqP; rewrite eqn_leq LL1. 797 | by congr (_.+1); apply/eqP; rewrite eqn_leq ltnW // ltnW. 798 | Qed. 799 | 800 | Lemma gdist_rhanoi3 n (c1 c2 : _ _ n) : `d[c1, c2]_rmove = size_rhanoi3 c1 c2. 801 | Proof. 802 | apply/eqP; rewrite eqn_leq. 803 | rewrite [size_rhanoi3 _ _]size_rhanoi3E gdist_path_le //=; last 2 first. 804 | - by apply: path_rhanoi3. 805 | - by apply: last_rhanoi3. 806 | have /gpath_connect [p1 p1H] : connect rmove c1 c2 by apply: move_connect. 807 | rewrite (gpath_dist p1H) rhanoi3_min //; first apply: gpath_path p1H. 808 | by apply: gpath_last p1H. 809 | Qed. 810 | 811 | End Hanoi3. -------------------------------------------------------------------------------- /shanoi.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From hanoi Require Import gdist ghanoi. 3 | 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | 10 | Section sHanoi. 11 | 12 | (*****************************************************************************) 13 | (* The pegs are the elements of 'I_n.+3 *) 14 | (*****************************************************************************) 15 | 16 | Variable m : nat. 17 | Implicit Type p : peg m.+3. 18 | 19 | Local Notation "c1 `--> c2" := (smove c1 c2) 20 | (format "c1 `--> c2", at level 60). 21 | Local Notation "c1 `-->* c2" := (connect smove c1 c2) 22 | (format "c1 `-->* c2", at level 60). 23 | 24 | Let p0 : peg m.+3 := ord0. 25 | 26 | Definition so1 p : (peg m.+3) := if (p == inord 1) then inord 2 else inord 1. 27 | 28 | Lemma so1_cor p : so1 p != p0 /\ so1 p != p. 29 | Proof. 30 | rewrite /so1; case: (p =P _) => [->|/eqP pD1]; split. 31 | - by apply/eqP/val_eqP; rewrite /= !inordK. 32 | - by apply/eqP/val_eqP; rewrite /= !inordK. 33 | - by apply/eqP/val_eqP; rewrite /= !inordK. 34 | by rewrite eq_sym. 35 | Qed. 36 | 37 | Definition so2 p1 p2 : (peg m.+3) := 38 | if (p1 == inord 1) then 39 | if (p2 == inord 2) then inord 3 else inord 2 40 | else 41 | if (p2 == inord 1) then 42 | if (p1 == inord 2) then inord 3 else inord 2 43 | else inord 1. 44 | 45 | Lemma so2_cor p1 p2 : 46 | 0 < m -> 47 | [/\ so2 p1 p2 != p0, so2 p1 p2 != p1 & so2 p1 p2 != p2]. 48 | Proof. 49 | move=> m_gt0. 50 | rewrite /so2; case: (p1 =P _) => [->|/eqP p1D1]; 51 | rewrite /so2; case: (p2 =P _) => [->|/eqP p2D]. 52 | - by split; apply/eqP/val_eqP; rewrite /= !inordK. 53 | - by split; try (by rewrite eq_sym); apply/eqP/val_eqP; rewrite /= !inordK. 54 | - case: (p1 =P _) => [->|/eqP p1D2]. 55 | by split; apply/eqP/val_eqP; rewrite /= !inordK. 56 | by split; try (by rewrite eq_sym); apply/eqP/val_eqP; rewrite /= !inordK. 57 | by split; try (by rewrite eq_sym); apply/eqP/val_eqP; rewrite /= !inordK. 58 | Qed. 59 | 60 | Lemma shanoi_connect_perfect n (c : configuration _ n) p : c `-->* `c[p]. 61 | Proof. 62 | have sirr := @sirr m.+3. 63 | elim: n c p => [c p | n IH c p]; first by apply/eq_connect0/ffunP=> [] [[]]. 64 | pose p1 := c ldisk. 65 | rewrite -[c]cunliftrK -/p1 -[perfect p]cunliftrK perfect_unliftr ffunE. 66 | have [<-|/eqP pDp1] := p =P p1; first by apply/connect_liftr/IH. 67 | have [p1Ep0|/eqP p1Dp0] := p1 =P p0. 68 | rewrite p1Ep0. 69 | case: (so1_cor p) => sDp0 sDp. 70 | apply: connect_trans (_ : connect _ ↑[`c[so1 p]]_p _); last first. 71 | by apply/connect_liftr/IH. 72 | apply: connect_trans (_ : connect _ ↑[`c[so1 p]]_p0 _). 73 | by apply/connect_liftr/IH. 74 | apply/connect1/move_liftr_perfect; try by rewrite eq_sym. 75 | by rewrite /srel /= eq_sym -p1Ep0 pDp1. 76 | have [pEp0|/eqP pDp0] := p =P p0. 77 | case: (so1_cor p1) => sDp0 sDp1. 78 | apply: connect_trans (_ : connect _ ↑[`c[so1 p1]]_p1 _). 79 | by apply/connect_liftr/IH. 80 | apply: connect_trans (_ : connect _ ↑[`c[so1 p1]]_p _). 81 | apply/connect1/move_liftr_perfect; try by rewrite eq_sym. 82 | by rewrite /srel /= eq_sym pDp1 pEp0 muln0. 83 | by rewrite eq_sym pEp0. 84 | by apply/connect_liftr/IH. 85 | apply: connect_trans (_ : connect _ ↑[`c[p]]_p1 _). 86 | by apply/connect_liftr/IH. 87 | apply: connect_trans (_ : connect _ ↑[`c[p]]_p0 _). 88 | apply/connect1/move_liftr_perfect; try by rewrite eq_sym. 89 | by rewrite /srel /= p1Dp0 muln0. 90 | apply: connect_trans (_ : connect _ ↑[`c[p1]]_p0 _). 91 | by apply/connect_liftr/IH. 92 | apply: connect_trans (_ : connect _ ↑[`c[p1]]_p _). 93 | apply/connect1/move_liftr_perfect; try by rewrite // eq_sym. 94 | by rewrite /srel /= eq_sym pDp0. 95 | by apply/connect_liftr/IH. 96 | Qed. 97 | 98 | Lemma shanoi_connect n (c1 c2 : configuration m.+3 n) : c1 `-->* c2. 99 | Proof. 100 | apply: connect_trans (shanoi_connect_perfect _ p0) _. 101 | rewrite (connect_sym (@ssym m.+3)). 102 | apply: shanoi_connect_perfect. 103 | Qed. 104 | 105 | End sHanoi. -------------------------------------------------------------------------------- /triangular.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* *) 3 | (* Triangular number *) 4 | (* *) 5 | (******************************************************************************) 6 | (* *) 7 | (* delta n = the n^th triangular number *) 8 | (* troot n = the triangular root of n *) 9 | (* tmod n = the triangular modulo of n *) 10 | (* *) 11 | (* *) 12 | (******************************************************************************) 13 | 14 | From mathcomp Require Import all_ssreflect. 15 | 16 | Set Implicit Arguments. 17 | Unset Strict Implicit. 18 | Unset Printing Implicit Defensive. 19 | 20 | Lemma prednDl m n : 0 < m -> (m + n).-1 = m.-1 + n. 21 | Proof. by case: m. Qed. 22 | 23 | Lemma prednDr m n : 0 < n -> (m + n).-1 = m + n.-1. 24 | Proof. by case: n => // n; rewrite addnS. Qed. 25 | 26 | Lemma leq_sub_sub a b c : ((a - b) - (c - b)) <= a - c. 27 | Proof. 28 | have [aLb|bLa] := leqP b a; last first. 29 | rewrite (_ : a - _ = 0) ?sub0n //. 30 | by apply/eqP; rewrite subn_eq0 ltnW. 31 | have [cLb|bLc] := leqP c b; last first. 32 | by rewrite subnBA ?subnK // ltnW. 33 | rewrite (_ : c - _ = 0); last by apply/eqP; rewrite subn_eq0. 34 | by rewrite subn0 leq_sub2l. 35 | Qed. 36 | 37 | Lemma leq_sub_add b a c : a - c <= (a - b) + (b - c). 38 | Proof. 39 | rewrite leq_subLR addnC -addnA. 40 | have [/subnK->|H] := leqP c b. 41 | have [/subnK->//|H] := leqP b a. 42 | apply: leq_trans (ltnW H) _. 43 | by apply: leq_addl. 44 | have := ltnW H. 45 | rewrite -subn_eq0 => /eqP->. 46 | rewrite addnC -leq_subLR. 47 | by apply: leq_sub2l; apply: ltnW. 48 | Qed. 49 | 50 | (******************************************************************************) 51 | (* *) 52 | (* Triangular number *) 53 | (* *) 54 | (******************************************************************************) 55 | 56 | Definition delta n := (n.+1 * n)./2. 57 | 58 | Notation "'Δ' n " := (delta n) (format "'Δ' n", at level 10). 59 | 60 | Compute zip (iota 1 20) (map delta (iota 1 20)). 61 | 62 | Lemma deltaS n : delta n.+1 = delta n + n.+1. 63 | Proof. 64 | rewrite /delta -addn2 mulnDl mulnC halfD. 65 | rewrite !oddM andbF add0n mul2n. 66 | by rewrite -{4}(half_bit_double n.+1 false). 67 | Qed. 68 | 69 | Lemma delta_gt0 n : 0 < n -> 0 < delta n. 70 | Proof. by case: n => // n _; rewrite deltaS addnS ltnS leq_addr. Qed. 71 | 72 | Lemma deltaE n : delta n = \sum_(i < n.+1) i. 73 | Proof. 74 | elim: n => [|n IH]; first by rewrite big_ord_recl big_ord0. 75 | by rewrite big_ord_recr -IH deltaS. 76 | Qed. 77 | 78 | Compute zip (iota 0 11) (map delta (iota 0 11)). 79 | 80 | Lemma delta_le m n : m <= n -> delta m <= delta n. 81 | Proof. by move=> H; apply/half_leq/leq_mul. Qed. 82 | 83 | Lemma delta_square n : (8 * delta n).+1 = n.*2.+1 ^ 2. 84 | Proof. 85 | elim: n => // n IH. 86 | rewrite deltaS mulnDr -addSn IH. 87 | rewrite doubleS -addn1 -addnS -addSn addn1. 88 | rewrite sqrnD -addnA /=. 89 | congr (_ + _). 90 | rewrite mulnS. 91 | rewrite [_ * 2]mulSn mulnDr addnA. 92 | congr (_ + _). 93 | by rewrite mulnCA -muln2 -!mulnA mulnC. 94 | Qed. 95 | 96 | Lemma geq_deltann n : n <= delta n. 97 | Proof. 98 | by case: n => // n; rewrite deltaS addnS ltnS leq_addl. 99 | Qed. 100 | 101 | (******************************************************************************) 102 | (* *) 103 | (* Triangular root *) 104 | (* *) 105 | (******************************************************************************) 106 | 107 | Definition troot n := 108 | let l := iota 0 n.+2 in 109 | (find (fun x => n < delta x) l).-1. 110 | 111 | Notation "∇ n" := (troot n) (format "∇ n", at level 10). 112 | 113 | Compute zip (iota 0 11) (map troot (iota 0 11)). 114 | 115 | Lemma troot_gt0 n : 0 < n -> 0 < troot n. 116 | Proof. by case: n. Qed. 117 | 118 | Lemma delta_root_le m : delta (troot m) <= m. 119 | Proof. 120 | rewrite /troot leqNgt. 121 | set l := iota _ _; set f := (fun _ => _). 122 | case E : _.-1 => [|n] //. 123 | have /(before_find 0) : 124 | (find f l).-1 < find f l by rewrite prednK // E. 125 | rewrite E nth_iota // /f => [->//|]. 126 | rewrite -[m.+2](size_iota 0) -E prednK; first by apply: find_size. 127 | by case: find E. 128 | Qed. 129 | 130 | Lemma delta_root_gt m : m < delta (troot m).+1. 131 | Proof. 132 | rewrite /troot leqNgt. 133 | set l := iota _ _; set f := (fun _ => _). 134 | have Hfl : has f l. 135 | apply/hasP; exists m.+1; first by rewrite mem_iota leq0n leqnn. 136 | rewrite /f /delta -{1}[m.+1](half_bit_double _ false). 137 | by apply/half_leq; rewrite add0n -mul2n leq_mul2r orbT. 138 | have := nth_find 0 Hfl; rewrite {1}/f. 139 | case E : _.-1 => [|n] //. 140 | case: find E => // [] [|n] //. 141 | by rewrite nth_iota //=; case: (m). 142 | rewrite nth_iota. 143 | by rewrite -E prednK // ltnNge ltnS. 144 | by rewrite -(size_iota 0 m.+2) -has_find. 145 | Qed. 146 | 147 | (* Galois connection *) 148 | Lemma root_delta_le m n : (n <= troot m) = (delta n <= m). 149 | Proof. 150 | case: leqP => [/delta_le/leq_trans->//|dmLn]. 151 | apply: delta_root_le. 152 | apply/sym_equal/idP/negP. 153 | rewrite -ltnNge. 154 | by apply: leq_trans (delta_root_gt _) (delta_le dmLn). 155 | Qed. 156 | 157 | Lemma root_delta_lt m n : (troot m < n) = (m < delta n). 158 | Proof. by rewrite ltnNge root_delta_le -ltnNge. Qed. 159 | 160 | Lemma troot_le m n : m <= n -> troot m <= troot n. 161 | Proof. 162 | by move=> mLn; rewrite root_delta_le (leq_trans (delta_root_le _)). 163 | Qed. 164 | 165 | Lemma trootE m n : (troot m == n) = (delta n <= m < delta n.+1). 166 | Proof. 167 | rewrite ltnNge -!root_delta_le -ltnNge. 168 | by rewrite ltnS -eqn_leq. 169 | Qed. 170 | 171 | Lemma troot_delta n : troot (delta n) = n. 172 | Proof. by apply/eqP; rewrite trootE leqnn deltaS -addn1 leq_add2l. Qed. 173 | 174 | Lemma leq_rootnn n : troot n <= n. 175 | Proof. 176 | by rewrite -{2}[n]troot_delta troot_le // geq_deltann. 177 | Qed. 178 | 179 | (******************************************************************************) 180 | (* *) 181 | (* Triangular modulo *) 182 | (* *) 183 | (******************************************************************************) 184 | 185 | Definition tmod n := n - delta (troot n). 186 | 187 | Lemma tmod_delta n : tmod (delta n) = 0. 188 | Proof. by rewrite /tmod troot_delta subnn. Qed. 189 | 190 | Lemma tmodE n : n = delta (troot n) + tmod n. 191 | Proof. by rewrite addnC (subnK (delta_root_le _)). Qed. 192 | 193 | Lemma tmod_le n : tmod n <= troot n. 194 | Proof. by rewrite leq_subLR -ltnS -addnS -deltaS delta_root_gt. Qed. 195 | 196 | 197 | Lemma ltn_root m n : troot m < troot n -> m < n. 198 | Proof. 199 | rewrite root_delta_le deltaS => /(leq_trans _) -> //. 200 | by rewrite {1}[m]tmodE ltn_add2l ltnS tmod_le. 201 | Qed. 202 | 203 | Lemma leq_mod m n : troot m = troot n -> (tmod m <= tmod n) = (m <= n). 204 | Proof. 205 | by move=> tmEtn; rewrite {2}[m]tmodE {2}[n]tmodE tmEtn leq_add2l. 206 | Qed. 207 | 208 | Lemma ltn_mod m n : troot m = troot n -> (tmod m < tmod n) = (m < n). 209 | Proof. 210 | by move=> tmEtn; rewrite {2}[m]tmodE {2}[n]tmodE tmEtn ltn_add2l. 211 | Qed. 212 | 213 | Lemma troot_mod_case m : 214 | ((troot m.+1 == troot m) && (tmod m.+1 == (tmod m).+1)) 215 | || 216 | [&& troot m.+1 == (troot m).+1, tmod m.+1 == 0 & tmod m == troot m]. 217 | Proof. 218 | have := troot_le (leqnSn m). 219 | rewrite leq_eqVlt => /orP[/eqP He|He]. 220 | by rewrite /tmod -He subSn ?eqxx // {2}[m]tmodE leq_addr. 221 | rewrite orbC. 222 | have: troot m.+1 == (troot m).+1. 223 | rewrite trootE (leq_trans (delta_le He)) //; last first. 224 | by rewrite {2}[m.+1]tmodE leq_addr. 225 | rewrite !deltaS {1}[m]tmodE -addnS -addnS -addnA. 226 | by rewrite leq_add2l (leq_trans _ (leq_addl _ _)) // !ltnS tmod_le. 227 | move/eqP=> He1. 228 | rewrite He1 eqxx. 229 | have := eqxx m.+1. 230 | rewrite {1}[m]tmodE {1}[m.+1]tmodE He1 deltaS -addnS. 231 | rewrite -!addnA eqn_add2l addSn eqSS => /eqP He2. 232 | have := tmod_le m. 233 | rewrite leq_eqVlt => /orP[/eqP He3|]; last first. 234 | by rewrite He2 ltnNge leq_addr. 235 | rewrite He3 -(eqn_add2l (tmod m)) {1}He3 -He2 addn0. 236 | by rewrite !eqxx. 237 | Qed. 238 | 239 | Lemma troot_mod_le m n : 240 | m <= n = 241 | ((troot m < troot n) || ((troot m == troot n) && (tmod m <= tmod n))). 242 | Proof. 243 | case: leqP => [|dmGdn] /= ; last first. 244 | apply/idP. 245 | apply: (leq_trans (_ : _ <= delta (troot m).+1)). 246 | by rewrite ltnW // delta_root_gt. 247 | apply: (leq_trans (_ : _ <= delta (troot n))). 248 | by apply: delta_le. 249 | by apply: delta_root_le. 250 | rewrite leq_eqVlt => /orP[/eqP dnEdm|dmLdn]. 251 | rewrite dnEdm eqxx /=. 252 | by rewrite {1}[m]tmodE {1}[n]tmodE dnEdm leq_add2l. 253 | rewrite (gtn_eqF dmLdn) /=. 254 | apply/idP/negP. 255 | rewrite -ltnNge. 256 | apply: (leq_trans (delta_root_gt _)). 257 | apply: (leq_trans _ (delta_root_le _)). 258 | by apply: delta_le. 259 | Qed. 260 | 261 | Lemma troot_mod_lt m n : 262 | m < n = 263 | ((troot m < troot n) || ((troot m == troot n) && (tmod m < tmod n))). 264 | Proof. 265 | case: (leqP (troot n) (troot m)) => [|dmGdn] /= ; last first. 266 | apply/idP. 267 | apply: (leq_trans (delta_root_gt _)). 268 | apply: (leq_trans (delta_le dmGdn)). 269 | by apply: delta_root_le. 270 | rewrite leq_eqVlt => /orP[/eqP dnEdm|dmLdn]. 271 | rewrite dnEdm eqxx /=. 272 | by rewrite {1}[m]tmodE {1}[n]tmodE dnEdm ltn_add2l. 273 | rewrite (gtn_eqF dmLdn) /=. 274 | apply/idP/negP. 275 | rewrite -ltnNge ltnS ltnW //. 276 | apply: (leq_trans (delta_root_gt _)). 277 | apply: (leq_trans _ (delta_root_le _)). 278 | by apply: delta_le. 279 | Qed. 280 | 281 | (******************************************************************************) 282 | (* *) 283 | (* Correspondence between N and N x N *) 284 | (* *) 285 | (******************************************************************************) 286 | 287 | (* An explicit definition of N <-> N * N *) 288 | Definition tpair n := (troot n - tmod n, tmod n). 289 | 290 | Compute zip (iota 0 20) (map tpair (iota 0 20)). 291 | 292 | Definition pairt p := delta (p.1 + p.2) + p.2. 293 | 294 | Lemma tpairt n : pairt (tpair n) = n. 295 | Proof. 296 | rewrite /tpair /pairt /= (subnK (tmod_le _)). 297 | by rewrite /tmod addnC subnK // delta_root_le. 298 | Qed. 299 | 300 | Lemma tpairt_inv p : tpair (pairt p) = p. 301 | Proof. 302 | case: p => a b. 303 | rewrite /tpair /pairt /= /tmod. 304 | have ->: ∇(Δ(a + b) + b) = a + b. 305 | apply/eqP. 306 | rewrite trootE leq_addr deltaS. 307 | by rewrite addnS ltnS addnCA leq_addl. 308 | by rewrite [delta _ + _]addnC !addnK. 309 | Qed. 310 | --------------------------------------------------------------------------------