Require Import Coq.Lists.List.

Definition Forallb {A} (P : A -> bool) (ls : list A) : bool
  := List.fold_right andb true (List.map P ls).

Lemma unfold_Forallb {A P} ls
  : @Forallb A P ls
    = match ls with
      | nil => true
      | cons x xs => andb (P x) (Forallb P xs)
      end.
Proof. destruct ls; reflexivity. Qed.

Lemma Forall_Forallb_iff {A} (P : A -> bool) (Q : A -> Prop) (ls : list A)
      (H : forall x, In x ls -> P x = true <-> Q x)
  : Forallb P ls = true <-> Forall Q ls.
Proof.
  induction ls as [|x xs IHxs]; simpl; rewrite unfold_Forallb.
  { intuition. }
  { simpl in *.
    rewrite Bool.andb_true_iff, IHxs
      by (intros; apply H; eauto).
    split; intro H'; inversion H'; subst; constructor; intuition;
      apply H; eauto. }
Qed.


Require Import list.
Require Import In.
Require Import disjoint.

Example test_nodup1 : nodup [1,2,3,4].
Proof.
    apply nodup_cons.
    - apply nodup_cons.
        + apply nodup_cons.
            { apply nodup_cons.
                { apply nodup_nil. }
                { intro H. exact H. }
            }
            { intros [H|H].
                { inversion H. }
                { exact H. }
            }
        + intros [H|[H|H]].
            { inversion H. }
            { inversion H. }
            { exact H. }
    - intros [H|[H|[H|H]]].
        + inversion H.
        + inversion H.
        + inversion H.
        + exact H.
Qed.

Example test_nodup2 : @nodup bool [].
Proof. apply nodup_nil. Qed.

Example test_nodup3 : ~ nodup [1,2,1].
Proof.
    intros H. inversion H as [H0|l n H1 H2 H3].
    apply H2. right. left. reflexivity.
Qed.

Example test_nodup4 : ~ nodup [true,true].
Proof.
    intros H. inversion H as [H0|l b H1 H2 H3].
    apply H2. left. reflexivity.
Qed.

Example test_nostutter1 : nostutter [3,1,4,1,5,6].
Proof.
    apply nostutter_double.
    - apply nostutter_double.
        + apply nostutter_double.
            { apply nostutter_double.
                { apply nostutter_double.
                    { apply nostutter_single. }
                    { intros H. inversion H. }
                }
                { intros H. inversion H. }
            }
            { intros H. inversion H. }
        + intros H. inversion H.
    - intros H. inversion H.
Qed.

Example test_nostutter2 : nostutter (@nil nat).
Proof. apply nostutter_nil. Qed.

Example test_nostutter3 : nostutter [5].
Proof. apply nostutter_single. Qed.

(* fails on version 8.4
Example test_nostutter4 : ~ nostutter [3,1,1,4].
Proof.
    intros H. inversion H as [x|x|x y l H0 H1 H2].
    inversion H0 as [z|z|z t k H6 H7 H8].
    apply H7. reflexivity.
Qed.
*)


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

(* ** Matric computation *)

Require Import Arith ZArith.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac gcd prime binomial sums.

Set Implicit Arguments.

Set Default Proof Using "Type".

Section rings.

  Variable (R : Type) (Rzero Rone : R) (Rplus Rmult Rminus : R -> R -> R) (Ropp : R -> R)
           (R_is_ring : ring_theory Rzero Rone Rplus Rmult Rminus Ropp eq).

  Infix "⊕" := Rplus (at level 50, left associativity).
  Infix "⊗" := Rmult (at level 40, left associativity).

  Notation z := Rzero.
  Notation o := Rone.
  Notation "∸" := Ropp.

  (* ⊕  ⊗  ∸ *)

  (* We use the magical parameterized ring tactic *)

  Add Ring Rring : R_is_ring.

  (* ⊕  ⊗  ∸ *)

  (*   ( a b )   <-> (a,b,c,d)
       ( c d )                    *)

  Definition M22 := (R * R * R * R)%type.
  Definition ID_22 : M22 := (o,z,z,o).
  Definition ZE_22 : M22 := (z,z,z,z).

  Definition PL22 : M22 -> M22 -> M22.
  Proof using Rplus.
    intros (((a,b),c),d) (((a',b'),c'),d').
    exact (a⊕a',b⊕b',
           c⊕c',d⊕d').
  Defined.

  Local Infix "⊞" := PL22 (at level 50, left associativity).

  Definition MI22 : M22 -> M22.
  Proof using Ropp.
    intros (((a,b),c),d).
    exact (∸a,∸b,
           ∸c,∸d).
  Defined.

  Local Notation "⊟" := MI22.

  Fact M22_equal (a b c d a' b' c' d' : R) : a = a' -> b = b' -> c = c' -> d = d' -> (a,b,c,d) = (a',b',c',d').
  Proof. intros; subst; trivial. Qed.

  Fact M22plus_zero : forall m, ZE_22 ⊞ m = m.
  Proof using R_is_ring.
    intros (((a,b),c),d); apply M22_equal; ring.
  Qed.

  Fact M22plus_comm  : forall x y, x ⊞ y = y ⊞ x.
  Proof using R_is_ring.
    intros (((a,b),c),d) (((a',b'),c'),d'); apply M22_equal; ring.
  Qed.

  Fact M22plus_assoc  : forall x y u, x ⊞ (y ⊞ u) = x ⊞ y ⊞ u.
  Proof using R_is_ring.
    intros (((a,b),c),d) (((a',b'),c'),d') (((a'',b''),c''),d''); simpl; apply M22_equal; ring.
  Qed.

  Fact M22minus : forall x, x ⊞ ⊟ x = ZE_22.
  Proof using R_is_ring.
    intros (((a,b),c),d); apply M22_equal; ring.
  Qed.

  Fact M22plus_cancel : forall x a b, x ⊞ a = x ⊞ b -> a = b.
  Proof using R_is_ring.
    intros x a b H.
    rewrite <- (M22plus_zero a), <- (M22minus x), (M22plus_comm x),
            <- M22plus_assoc, H, M22plus_assoc,
            (M22plus_comm _ x), M22minus, M22plus_zero.
    trivial.
  Qed.

  Theorem M22plus_monoid : monoid_theory PL22 ZE_22.
  Proof using R_is_ring.
    exists.
    + apply M22plus_zero.
    + intro; rewrite M22plus_comm; apply M22plus_zero.
    + intros; apply M22plus_assoc.
  Qed.

  Definition MU22 : M22 -> M22 -> M22.
  Proof using Rplus Rmult.
    intros (((a,b),c),d) (((a',b'),c'),d').
    exact (a⊗a' ⊕ b⊗c' , a⊗b' ⊕ b⊗d',
           c⊗a' ⊕ d⊗c' , c⊗b' ⊕ d⊗d' ).
  Defined.

  Local Infix "⊠" := MU22 (at level 40, left associativity).

  Tactic Notation "myauto" integer(n) := do n intros (((?&?)&?)&?); apply M22_equal; ring.

  Fact M22mult_one_l : forall x, ID_22 ⊠ x = x.
  Proof using R_is_ring. myauto 1. Qed.

  Fact M22mult_one_r : forall x, x ⊠ ID_22 = x.
  Proof using R_is_ring. myauto 1. Qed.

  Fact M22mult_assoc : forall x y u, x ⊠ (y ⊠ u) = x ⊠ y ⊠ u.
  Proof using R_is_ring. myauto 3. Qed.

  Fact M22_mult_distr_l : forall x y u, x ⊠ (y⊞u) = x⊠y ⊞ x⊠u.
  Proof using R_is_ring. myauto 3. Qed.

  Fact M22_mult_distr_r : forall x y u, (y⊞u) ⊠ x = y⊠x ⊞ u⊠x.
  Proof using R_is_ring. myauto 3. Qed.

  Theorem M22mult_monoid : monoid_theory MU22 ID_22.
  Proof using R_is_ring.
    exists.
    + apply M22mult_one_l.
    + apply M22mult_one_r.
    + apply M22mult_assoc.
  Qed.

  Fact M22_opp_mult_l : forall x y, (⊟ x) ⊠ y = ⊟ (x ⊠ y).
  Proof using R_is_ring. myauto 2. Qed.

  Fact M22_opp_mult_r : forall x y, x ⊠ (⊟y) = ⊟ (x ⊠ y).
  Proof using R_is_ring. myauto 2. Qed.

  Definition M22scal (k : R) : M22 -> M22.
  Proof using Rmult.
    intros (((u,v),w),z).
    exact (k⊗u,k⊗v,k⊗w,k⊗z).
  Defined.

  Fact M22scal_mult k1 k2 : forall x, M22scal k1 (M22scal k2 x) = M22scal (k1⊗k2) x.
  Proof using R_is_ring. myauto 1. Qed.

  Fact M22scal_PL22 k : forall x y, M22scal k (x ⊞ y) = M22scal k x ⊞ M22scal k y.
  Proof using R_is_ring. myauto 2. Qed.

  Fact M22scal_MI22 : forall x, M22scal (∸o) x = ⊟x.
  Proof using R_is_ring. myauto 1. Qed.

  Fact M22scal_zero : forall x, M22scal z x = ZE_22.
  Proof using R_is_ring. myauto 1. Qed.

  Fact M22scal_MU22_l k : forall x y, M22scal k (x ⊠ y) = M22scal k x ⊠ y.
  Proof using R_is_ring. myauto 2. Qed.

  Fact M22scal_MU22_r k : forall x y, M22scal k (x ⊠ y) = x ⊠ M22scal k y.
  Proof using R_is_ring. myauto 2. Qed.

  Fact mscal_M22scal n x : mscal PL22 ZE_22 n x = M22scal (mscal Rplus Rzero n Rone) x.
  Proof using R_is_ring.
    induction n as [ | n IHn ].
    + do 2 rewrite mscal_0; revert x; myauto 1.
    + do 2 rewrite mscal_S.
      rewrite IHn; clear IHn.
      revert x; myauto 1.
  Qed.

  (* M22 is NOT a ring because mult is not commutative *)

  (* ⊕  ⊗  ∸    ⊞ ⊠ ⊟ *)

  Definition Det22 : M22 -> R.
  Proof using Rplus Rmult Ropp.
    intros (((a,b),c),d).
    exact (a⊗d ⊕ ∸(b⊗c)).
  Defined.

  Fact Det22_scal k : forall x, Det22 (M22scal k x) = (k ⊗ k) ⊗ Det22 x.
  Proof using R_is_ring. intros (((?,?),?),?); simpl; ring. Qed.

  Fact Det22_mult : forall x y, Det22 (x⊠y) = Det22 x ⊗ Det22 y.
  Proof using R_is_ring. intros (((?,?),?),?) (((?,?),?),?); simpl; ring. Qed.

  Notation expo22 := (mscal MU22 ID_22).
  Notation expoR := (mscal Rmult o).

  Fact expo22_scal k n U : expo22 n (M22scal k U) = M22scal (expoR n k) (expo22 n U).
  Proof using R_is_ring.
    induction n as [ | n IHn ].
    + do 3 rewrite mscal_0; apply M22_equal; ring.
    + do 3 rewrite mscal_S.
      rewrite IHn.
      rewrite <- M22scal_MU22_l, <- M22scal_MU22_r.
      rewrite M22scal_mult; auto.
  Qed.

  Fact Det22_expo n x : Det22 (expo22 n x) = expoR n (Det22 x).
  Proof using R_is_ring.
    induction n as [ | n IHn ].
    + do 2 rewrite mscal_0; simpl; ring.
    + do 2 rewrite mscal_S.
      rewrite Det22_mult, IHn; ring.
  Qed.

  Fact Diag22_expo n x y : expo22 n (x,z,z,y) = (expoR n x,Rzero,Rzero,expoR n y).
  Proof using R_is_ring.
    induction n as [ | n IHn ]; try (simpl; auto; fail).
    do 3 rewrite mscal_S; rewrite IHn.
    apply M22_equal; ring.
  Qed.

  Fact MU22_Diag22 a b c d x y : (a,b,c,d) ⊠ (x,z,z,y) = (a⊗x,b⊗y,c⊗x,d⊗y).
  Proof using R_is_ring. apply M22_equal; ring. Qed.

  (* We also the to lift the Z -> Zp morphism to M22 matrices *)

  Fact M22_proj12 a1 b1 c1 d1 a2 b2 c2 d2 : (a1,b1,c1,d1) = (a2,b2,c2,d2) :> M22 -> c1 = c2.
  Proof. inversion 1; auto. Qed.

End rings.

Section ring_morphism.

  Variable (X : Type) (zX oX : X) (pX mX : X -> X -> X) (oppX : X -> X)
           (Y : Type) (zY oY : Y) (pY mY : Y -> Y -> Y) (oppY : Y -> Y).

  Variable phi : X -> Y.

  Local Notation "〚 x 〛" := (phi x).

  Record ring_morphism : Prop := mk_ring_morph {
    morph_z : 〚 zX 〛= zY;
    morph_o : 〚 oX 〛= oY;
    morph_plus : forall x y, 〚 pX x y 〛= pY 〚 x 〛〚 y 〛;
    morph_mult : forall x y, 〚 mX x y 〛= mY 〚 x 〛〚 y 〛;
    morph_opp : forall x, 〚 oppX x 〛= oppY 〚 x 〛;
  }.

  Hypothesis Hphi : ring_morphism.

  Definition morph22 : M22 X -> M22 Y.
  Proof using phi.
    intros (((a,b),c),d).
    exact (〚 a 〛, 〚 b 〛,
           〚 c 〛, 〚 d 〛).
  Defined.

  Tactic Notation "myauto" integer(n) := do n intros (((?&?)&?)&?); apply M22_equal; ring.

  Fact PL22_morph : forall x y, morph22 (PL22 pX x y) = PL22 pY (morph22 x) (morph22 y).
  Proof using Hphi.
    destruct Hphi.
    do 2 intros (((?&?)&?)&?); apply M22_equal; auto.
  Qed.

  Fact MU22_morph : forall x y, morph22 (MU22 pX mX x y) = MU22 pY mY (morph22 x) (morph22 y).
  Proof using Hphi.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    do 2 intros (((?&?)&?)&?); apply M22_equal;
      repeat rewrite G3; repeat rewrite G4; auto.
  Qed.

  Fact MI22_morph : forall x, morph22 (MI22 oppX x) = MI22 oppY (morph22 x).
  Proof using Hphi.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    do 1 intros (((?&?)&?)&?); apply M22_equal;
      repeat rewrite G3; repeat rewrite G4; auto.
  Qed.

  Fact M22scal_morph : forall k x, morph22 (M22scal mX k x) = M22scal mY 〚 k 〛 (morph22 x).
  Proof using Hphi.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    intros k (((?&?)&?)&?); apply M22_equal; auto.
  Qed.

  Fact Det22_morph : forall x, 〚 Det22 pX mX oppX x 〛= Det22 pY mY oppY (morph22 x).
  Proof using Hphi.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    intros (((?&?)&?)&?); simpl.
    rewrite G3, G6, G4, G4; auto.
  Qed.

  Fact expo22_morph n x : morph22 (mscal (MU22 pX mX) (ID_22 zX oX) n x)
                        = mscal (MU22 pY mY) (ID_22 zY oY) n (morph22 x).
  Proof using Hphi.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    induction n as [ | n IHn ].
    + do 2 rewrite mscal_0; apply M22_equal; auto.
    + do 2 rewrite mscal_S.
      rewrite MU22_morph, IHn; auto.
  Qed.

End ring_morphism.


(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) languages square, prime and anbncn are not context-free;
   (ii) context-free languages are not closed under intersection.

   More information can be found in the paper "Some Applications of the
   Formalization of the Pumping Lemma for Context-Free Languages",
   submitted to LSFA 2018 by Marcus Vinícius Midena Ramos, Ruy J. G. B.
   de Queiroz, Nelma Moreira and José Carlos Bacelar Almeida.
   Also, in the thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md describes the contents of each file and
   provides instructions on how to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* BASIC LEMMAS                                                          *)
(* --------------------------------------------------------------------- *)

Require Import Ring.
Require Import Omega.
Require Import NPeano.
Require Import Even.
Require Import NZPow.

Lemma lep1m2_ltp1:
forall i x: nat, i <= x + 1 - 2 -> i < x + 1.
Proof.
intros i x H.
omega.
Qed.

Lemma lep1m2_lt:
forall i x: nat, x > 0 -> i <= x + 1 - 2 -> i < x.
Proof.
intros i x H1 H2.
omega.
Qed.

Lemma gt_any_gt_0:
forall i j: nat,
i > j -> i > 0.
Proof.
intros i j H.
destruct i.
- apply lt_n_0 in H.
  contradiction.
- apply gt_Sn_O.
Qed.

Lemma lt_1_eq_0:
forall i: nat,
i < 1 -> i = 0.
Proof.
intros i H.
destruct i.
- reflexivity.
- apply lt_S_n in H.
  apply lt_n_0 in H.
  contradiction.
Qed.

Lemma n_minus_1:
forall n: nat,
n <> 0 -> n-1 < n.
Proof.
intros n H.
destruct n.
- omega.
- omega.
Qed.

Lemma gt_zero_exists:
forall i: nat,
i > 0 ->
exists j: nat, i = S j.
Proof.
intros i H.
destruct i.
- omega.
- exists i.
  reflexivity.
Qed.

Lemma max_n_n:
forall n: nat,
max n n = n.
Proof.
induction n.
- simpl.
  reflexivity.
- simpl.
  rewrite IHn.
  reflexivity.
Qed.

Lemma max_n_0:
forall n: nat,
max n 0 = n.
Proof.
destruct n.
- simpl.
  reflexivity.
- simpl.
  reflexivity.
Qed.

Definition injective (A B: Type) (f: A -> B): Prop:=
forall e1 e2: A,
f e1 = f e2 -> e1 = e2.

Lemma odd_1:
odd 1.
Proof.
apply odd_S.
apply even_O.
Qed.

Lemma pow_le:
forall n n1 n2: nat,
n > 0 ->
n1 <= n2 ->
n ^ n1 <= n ^ n2.
Proof.
intros n n1 n2 H1 H2.
apply Nat.pow_le_mono_r.
- omega.
- exact H2.
Qed.

Lemma pow_lt:
forall n n1 n2: nat,
n > 1 ->
n1 < n2 ->
n ^ n1 < n ^ n2.
Proof.
intros n n1 n2 H1 H2.
apply Nat.pow_lt_mono_r.
- exact H1.
- exact H2.
Qed.

Lemma nat_struct:
forall n: nat,
n = 0 \/ exists n': nat, n = S n'.
destruct n.
- left.
  reflexivity.
- right.
  exists n.
  reflexivity.
Qed.

Lemma sum_double:
forall n: nat,
n + n = 2 * n.
Proof.
induction n.
- simpl.
  reflexivity.
- rewrite plus_Sn_m.
  rewrite plus_comm.
  rewrite plus_Sn_m.
  rewrite IHn.
  simpl.
  repeat rewrite plus_0_r.
  symmetry.
  rewrite plus_comm.
  rewrite plus_Sn_m.
  reflexivity.
Qed.

Lemma add_exp:
forall n: nat,
n >= 1 -> 2 * 2 ^ (n - 1) = 2 ^ n.
Proof.
destruct n.
- intros H.
  omega.
- intros H.
  assert (H1: n = 0 \/ n >= 1) by omega.
  destruct H1 as [H1 | H1].
  + subst.
    simpl.
    reflexivity.
  + simpl.
    rewrite <- minus_n_O.
    rewrite <- plus_n_O.
    reflexivity.
Qed.

Lemma ge_exists:
forall x y: nat,
x >= y ->
exists z: nat,
x = z + y.
Proof.
induction y.
- intros H.
  exists x.
  rewrite plus_0_r.
  reflexivity.
- intros H.
  assert (H1: x >= y) by omega.
  specialize (IHy H1).
  destruct IHy as [z IHy].
  rewrite IHy.
  exists (z - 1).
  assert (H2: z >= 1) by omega.
  omega.
Qed.

Lemma pow_2_gt_0:
forall n: nat,
2 ^ n > 0.
Proof.
induction n.
- simpl.
  omega.
- simpl.
  omega.
Qed.

Lemma prod_eq:
forall n: nat,
n * n + n + n + 1 = S n * S n.
Proof.
intros n.
simpl.
rewrite <- mult_n_Sm.
omega.
Qed.

Lemma mult_ge:
forall n: nat, n*n >= n.
Proof.
induction n.
- simpl.
  omega.
- rewrite <- prod_eq.
  omega.
Qed.


Load "MyLists".

Inductive natoption : Type :=
  | Some : nat -> natoption
  | None : natoption.

Definition option_elim (d : nat) (o : natoption) : nat :=
  match o with
  | Some n' => n'
  | None    => d
  end.

Definition hd_error (l:natlist) : natoption :=
  match l with
  | []         => None
  | (cons x _) => Some x
  end.

Example test_hd_error1 : hd_error [] = None.
Proof.
  simpl. reflexivity.
Qed.

Example test_hd_error2 : hd_error [1] = Some 1.
Proof.
  simpl. reflexivity.
Qed.

Example test_hd_error3 : hd_error [5;6] = Some 5.
Proof.
  simpl. reflexivity.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Export ZLt.

Module ZAddOrderProp (Import Z : ZAxiomsMiniSig').
Include ZOrderProp Z.

(** Theorems that are either not valid on N or have different proofs
    on N and Z *)

Theorem add_neg_neg : forall n m, n < 0 -> m < 0 -> n + m < 0.
Proof.
intros. rewrite <- (add_0_l 0). now apply add_lt_mono.
Qed.

Theorem add_neg_nonpos : forall n m, n < 0 -> m <= 0 -> n + m < 0.
Proof.
intros. rewrite <- (add_0_l 0). now apply add_lt_le_mono.
Qed.

Theorem add_nonpos_neg : forall n m, n <= 0 -> m < 0 -> n + m < 0.
Proof.
intros. rewrite <- (add_0_l 0). now apply add_le_lt_mono.
Qed.

Theorem add_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> n + m <= 0.
Proof.
intros. rewrite <- (add_0_l 0). now apply add_le_mono.
Qed.

(** Sub and order *)

Theorem lt_0_sub : forall n m, 0 < m - n <-> n < m.
Proof.
intros n m. now rewrite (add_lt_mono_r _ _ n), add_0_l, sub_simpl_r.
Qed.

Notation sub_pos := lt_0_sub (only parsing).

Theorem le_0_sub : forall n m, 0 <= m - n <-> n <= m.
Proof.
intros n m. now rewrite (add_le_mono_r _ _ n), add_0_l, sub_simpl_r.
Qed.

Notation sub_nonneg := le_0_sub (only parsing).

Theorem lt_sub_0 : forall n m, n - m < 0 <-> n < m.
Proof.
intros n m. now rewrite (add_lt_mono_r _ _ m), add_0_l, sub_simpl_r.
Qed.

Notation sub_neg := lt_sub_0 (only parsing).

Theorem le_sub_0 : forall n m, n - m <= 0 <-> n <= m.
Proof.
intros n m. now rewrite (add_le_mono_r _ _ m), add_0_l, sub_simpl_r.
Qed.

Notation sub_nonpos := le_sub_0 (only parsing).

Theorem opp_lt_mono : forall n m, n < m <-> - m < - n.
Proof.
intros n m. now rewrite <- lt_0_sub, <- add_opp_l, <- sub_opp_r, lt_0_sub.
Qed.

Theorem opp_le_mono : forall n m, n <= m <-> - m <= - n.
Proof.
intros n m. now rewrite <- le_0_sub, <- add_opp_l, <- sub_opp_r, le_0_sub.
Qed.

Theorem opp_pos_neg : forall n, 0 < - n <-> n < 0.
Proof.
intro n; now rewrite (opp_lt_mono n 0), opp_0.
Qed.

Theorem opp_neg_pos : forall n, - n < 0 <-> 0 < n.
Proof.
intro n. now rewrite (opp_lt_mono 0 n), opp_0.
Qed.

Theorem opp_nonneg_nonpos : forall n, 0 <= - n <-> n <= 0.
Proof.
intro n; now rewrite (opp_le_mono n 0), opp_0.
Qed.

Theorem opp_nonpos_nonneg : forall n, - n <= 0 <-> 0 <= n.
Proof.
intro n. now rewrite (opp_le_mono 0 n), opp_0.
Qed.

Theorem lt_m1_0 : -1 < 0.
Proof.
apply opp_neg_pos, lt_0_1.
Qed.

Theorem sub_lt_mono_l : forall n m p, n < m <-> p - m < p - n.
Proof.
intros. now rewrite <- 2 add_opp_r, <- add_lt_mono_l, opp_lt_mono.
Qed.

Theorem sub_lt_mono_r : forall n m p, n < m <-> n - p < m - p.
Proof.
intros. now rewrite <- 2 add_opp_r, add_lt_mono_r.
Qed.

Theorem sub_lt_mono : forall n m p q, n < m -> q < p -> n - p < m - q.
Proof.
intros n m p q H1 H2.
apply lt_trans with (m - p);
[now apply sub_lt_mono_r | now apply sub_lt_mono_l].
Qed.

Theorem sub_le_mono_l : forall n m p, n <= m <-> p - m <= p - n.
Proof.
intros. now rewrite <- 2 add_opp_r, <- add_le_mono_l, opp_le_mono.
Qed.

Theorem sub_le_mono_r : forall n m p, n <= m <-> n - p <= m - p.
Proof.
intros. now rewrite <- 2 add_opp_r, add_le_mono_r.
Qed.

Theorem sub_le_mono : forall n m p q, n <= m -> q <= p -> n - p <= m - q.
Proof.
intros n m p q H1 H2.
apply le_trans with (m - p);
[now apply sub_le_mono_r | now apply sub_le_mono_l].
Qed.

Theorem sub_lt_le_mono : forall n m p q, n < m -> q <= p -> n - p < m - q.
Proof.
intros n m p q H1 H2.
apply lt_le_trans with (m - p);
[now apply sub_lt_mono_r | now apply sub_le_mono_l].
Qed.

Theorem sub_le_lt_mono : forall n m p q, n <= m -> q < p -> n - p < m - q.
Proof.
intros n m p q H1 H2.
apply le_lt_trans with (m - p);
[now apply sub_le_mono_r | now apply sub_lt_mono_l].
Qed.

Theorem le_lt_sub_lt : forall n m p q, n <= m -> p - n < q - m -> p < q.
Proof.
intros n m p q H1 H2. apply (le_lt_add_lt (- m) (- n));
[now apply -> opp_le_mono | now rewrite 2 add_opp_r].
Qed.

Theorem lt_le_sub_lt : forall n m p q, n < m -> p - n <= q - m -> p < q.
Proof.
intros n m p q H1 H2. apply (lt_le_add_lt (- m) (- n));
[now apply -> opp_lt_mono | now rewrite 2 add_opp_r].
Qed.

Theorem le_le_sub_lt : forall n m p q, n <= m -> p - n <= q - m -> p <= q.
Proof.
intros n m p q H1 H2. apply (le_le_add_le (- m) (- n));
[now apply -> opp_le_mono | now rewrite 2 add_opp_r].
Qed.

Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p.
Proof.
intros n m p. now rewrite (sub_lt_mono_r _ _ p), add_simpl_r.
Qed.

Theorem le_add_le_sub_r : forall n m p, n + p <= m <-> n <= m - p.
Proof.
intros n m p. now rewrite (sub_le_mono_r _ _ p), add_simpl_r.
Qed.

Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n.
Proof.
intros n m p. rewrite add_comm; apply lt_add_lt_sub_r.
Qed.

Theorem le_add_le_sub_l : forall n m p, n + p <= m <-> p <= m - n.
Proof.
intros n m p. rewrite add_comm; apply le_add_le_sub_r.
Qed.

Theorem lt_sub_lt_add_r : forall n m p, n - p < m <-> n < m + p.
Proof.
intros n m p. now rewrite (add_lt_mono_r _ _ p), sub_simpl_r.
Qed.

Theorem le_sub_le_add_r : forall n m p, n - p <= m <-> n <= m + p.
Proof.
intros n m p. now rewrite (add_le_mono_r _ _ p), sub_simpl_r.
Qed.

Theorem lt_sub_lt_add_l : forall n m p, n - m < p <-> n < m + p.
Proof.
intros n m p. rewrite add_comm; apply lt_sub_lt_add_r.
Qed.

Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p.
Proof.
intros n m p. rewrite add_comm; apply le_sub_le_add_r.
Qed.

Theorem lt_sub_lt_add : forall n m p q, n - m < p - q <-> n + q < m + p.
Proof.
intros n m p q. now rewrite lt_sub_lt_add_l, add_sub_assoc, <- lt_add_lt_sub_r.
Qed.

Theorem le_sub_le_add : forall n m p q, n - m <= p - q <-> n + q <= m + p.
Proof.
intros n m p q. now rewrite le_sub_le_add_l, add_sub_assoc, <- le_add_le_sub_r.
Qed.

Theorem lt_sub_pos : forall n m, 0 < m <-> n - m < n.
Proof.
intros n m. now rewrite (sub_lt_mono_l _ _ n), sub_0_r.
Qed.

Theorem le_sub_nonneg : forall n m, 0 <= m <-> n - m <= n.
Proof.
intros n m. now rewrite (sub_le_mono_l _ _ n), sub_0_r.
Qed.

Theorem sub_lt_cases : forall n m p q, n - m < p - q -> n < m \/ q < p.
Proof.
intros. now apply add_lt_cases, lt_sub_lt_add.
Qed.

Theorem sub_le_cases : forall n m p q, n - m <= p - q -> n <= m \/ q <= p.
Proof.
intros. now apply add_le_cases, le_sub_le_add.
Qed.

Theorem sub_neg_cases : forall n m, n - m < 0 -> n < 0 \/ 0 < m.
Proof.
intros.
rewrite <- (opp_neg_pos m). apply add_neg_cases. now rewrite add_opp_r.
Qed.

Theorem sub_pos_cases : forall n m, 0 < n - m -> 0 < n \/ m < 0.
Proof.
intros.
rewrite <- (opp_pos_neg m). apply add_pos_cases. now rewrite add_opp_r.
Qed.

Theorem sub_nonpos_cases : forall n m, n - m <= 0 -> n <= 0 \/ 0 <= m.
Proof.
intros.
rewrite <- (opp_nonpos_nonneg m). apply add_nonpos_cases. now rewrite add_opp_r.
Qed.

Theorem sub_nonneg_cases : forall n m, 0 <= n - m -> 0 <= n \/ m <= 0.
Proof.
intros.
rewrite <- (opp_nonneg_nonpos m). apply add_nonneg_cases. now rewrite add_opp_r.
Qed.

Section PosNeg.

Variable P : Z.t -> Prop.
Hypothesis P_wd : Proper (eq ==> iff) P.

Theorem zero_pos_neg :
  P 0 -> (forall n, 0 < n -> P n /\ P (- n)) -> forall n, P n.
Proof.
intros H1 H2 n. destruct (lt_trichotomy n 0) as [H3 | [H3 | H3]].
apply opp_pos_neg, H2 in H3. destruct H3 as [_ H3].
now rewrite opp_involutive in H3.
now rewrite H3.
apply H2 in H3; now destruct H3.
Qed.

End PosNeg.

Ltac zero_pos_neg n := induction_maker n ltac:(apply zero_pos_neg).

End ZAddOrderProp.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Coq.Strings.String.
Require Import Tactical.

Import ListNotations.

Set Printing Parentheses.

(** * Types

[type] is:

- [Int] is integer type
- [Top] is top type (supertype of all types)
- [Arr] is function type
- [And] is intersection type

*)

Definition label := nat.

Inductive type : Set :=
| Int : type
| Top : type
| Arr : type -> type -> type
| And : type -> type -> type
| Rcd : label -> type -> type.

Hint Constructors type : core.

(** Notation is only used for prettifying goals, we never explicity write customized notation *)

Notation "A → B" := (Arr A B) (at level 20).
Notation "A & B" := (And A B) (at level 20).
Notation "{ l : A }" := (Rcd l A) (at level 20).

(** coerce atom x to (Fvar x) *)

(** * Size of types *)

(** [size_type] and [size_term] are defined for more powerful induction principle: induction on size *)

Fixpoint size_type (A : type) {struct A} : nat :=
  match A with
  | Int => 1
  | Top => 1
  | Arr A B => 1 + (size_type A) + (size_type B)
  | And A B => 1 + (size_type A) + (size_type B)
  | Rcd l A => 1 + (size_type A)
  end.

(** induction on size *)

Ltac ind_type_size s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with
         | [ h : type |- _ ] => (gen h)
         end;
  induction i as [|i IH]; [
      intros; match goal with
              | [ H : _ < 0 |- _ ] => (dependent destruction H)
              end
    | intros ].


Require Import Util CSet Var VarsUpTo.

Set Implicit Arguments.

Section FreshList.
  Variable V : Type.
  Context `{OrderedType V}.
  Variable fresh : set V -> V.

  Fixpoint fresh_list (G:set V) (n:nat) : list V :=
    match n with
      | 0 => nil
      | (S n) => let y := fresh G in y::fresh_list {y;G} n
    end.

  Lemma fresh_list_length (G:set V) n
  : length (fresh_list G n) = n.
  Proof.
    general induction n; eauto. simpl. f_equal; eauto.
  Qed.

  Hypothesis fresh_spec : forall G, fresh G ∉ G.

  Definition fresh_set (G:set V) L : set V :=
    of_list (fresh_list G L).

  Lemma fresh_list_spec : forall (G:set V) n, disj (of_list (fresh_list G n)) G.
  Proof.
    intros. general induction n; simpl; intros; eauto.
    - hnf; intros. cset_tac'.
      + rewrite <- H2 in H1. eauto.
      + specialize (H0 ({fresh G; G})).
        eapply H0; eauto.
        cset_tac.
  Qed.

  Lemma fresh_set_spec
  : forall (G:set V) L, disj (fresh_set G L) G.
  Proof.
    unfold fresh_set. eapply fresh_list_spec.
  Qed.

  Lemma fresh_list_nodup (G: set V) n
    : NoDupA eq (fresh_list G n).
  Proof.
    general induction n; simpl; eauto.
    econstructor; eauto. intro.
    eapply fresh_list_spec.
    eapply InA_eq_of_list; eauto.
    cset_tac.
  Qed.

  Lemma fresh_list_ext n G G'
    : (forall G G', G [=] G' -> fresh G = fresh G')
      -> G [=] G'
      -> fresh_list G n = fresh_list G' n.
  Proof.
    intros EXT EQ. general induction n; simpl.
    - reflexivity.
    - f_equal. eauto.
      eapply IHn; eauto.
      erewrite EXT, EQ; eauto; reflexivity.
  Qed.

End FreshList.

Hint Resolve fresh_list_length : len.

Smpl Add match goal with
          | [ H : context [ ❬@fresh_list ?V ?OT ?f ?G ?n❭ ] |- _ ] =>
            rewrite (@fresh_list_length V OT f G n) in H
          | [ |- context [ ❬@fresh_list ?V ?OT ?f ?G ?n❭ ] ] =>
            rewrite (@fresh_list_length V OT f G n)
          end : len.


Require Import OrderedTypeEx FSetFacts FSetProperties.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Standard Proposition Elimination Names.

Module UsualFacts (E:UsualOrderedType)(M:S with Module E:=E).
Module ME := OrderedTypeFacts E.
Module MF := FSetFacts.Facts M.
Module MP := FSetProperties.Properties M.
Import ME.
Import MF.
Import M.
Import Logic. (* to unmask [eq] *)
Import Peano. (* to unmask [lt] *)

(** * Specifications written using equivalences *)

Section IffSpec.
Variable s s' s'' : t.
Variable x y z : elt.

Lemma singleton_iff : In y (singleton x) <-> x=y.
Proof. apply singleton_iff. Qed.

Lemma add_iff : In y (add x s) <-> x=y \/ In y s.
Proof. apply add_iff. Qed.

Lemma add_neq_iff : x<>y -> (In y (add x s)  <-> In y s).
Proof. apply add_neq_iff. Qed.

Lemma remove_iff : In y (remove x s) <-> In y s /\ x<>y.
Proof. apply remove_iff. Qed.

Lemma remove_neq_iff : x<>y -> (In y (remove x s) <-> In y s).
Proof. apply remove_neq_iff. Qed.

Variable f : elt->bool.

Lemma filter_iff :  In x (filter f s) <-> In x s /\ f x = true.
Proof. apply filter_iff; congruence. Qed.

Lemma for_all_iff :
  For_all (fun x => f x = true) s <-> for_all f s = true.
Proof. apply for_all_iff; congruence. Qed.

Lemma exists_iff :
  Exists (fun x => f x = true) s <-> exists_ f s = true.
Proof. apply exists_iff; congruence. Qed.

Lemma elements_iff : In x s <-> List.In x (elements s).
Proof.
rewrite elements_iff.
rewrite SetoidList.InA_alt.
split; intros.
destruct H as (u,(H1,H2)); compute in H1; subst; auto.
exists x; split; compute; auto.
Qed.

End IffSpec.

(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *)

Ltac set_iff :=
 repeat (progress (
  rewrite add_iff || rewrite remove_iff || rewrite singleton_iff
  || rewrite union_iff || rewrite inter_iff || rewrite diff_iff
  || rewrite empty_iff)).

(** Two equivalent sorted lists are in fact equal. *)

Definition equivlist (l l':list elt) := forall x, List.In x l <-> List.In x l'.

Lemma list_unique : forall l l',
 sort E.lt l -> sort E.lt l' -> equivlist l l' -> l=l'.
Proof.
induction l; destruct l'; simpl; auto; intros.
elimtype False; rewrite (H1 t0); simpl; auto.
elimtype False; rewrite <- (H1 a); simpl; auto.
inversion_clear H; inversion_clear H0.
assert (forall y, List.In y l -> E.lt a y).
 intros; eapply Sort_Inf_In with (l:=l); eauto.
assert (forall y, List.In y l' -> E.lt t0 y).
 intros; eapply Sort_Inf_In with (l:=l'); eauto.
clear H3 H4.
assert (a=t0).
 destruct (H1 a).
 destruct (H1 t0).
 simpl in H3; destruct H3; auto.
 simpl in H7; destruct H7; auto.
 elimtype False; generalize (H5 _ H3) (H0 _ H7).
 ME.order.
f_equal; auto.
apply IHl; auto.
split; intros.
destruct (H1 x).
destruct H6; simpl; auto.
elimtype False; generalize (H0 _ H4); subst a; subst x; ME.order.
destruct (H1 x).
destruct H7; simpl; auto.
elimtype False; generalize (H5 _ H4); subst a; subst x; ME.order.
Qed.

Lemma Equal_elements_equivlist :
 forall s s', s[=]s' <-> equivlist (elements s) (elements s').
Proof.
unfold Equal; split; intros.
red; intros.
do 2 rewrite <- elements_iff; auto.
do 2 rewrite elements_iff; auto.
Qed.

Lemma Equal_eq_elements :
 forall s s', s[=]s' <-> elements s = elements s'.
Proof.
split; intros.
apply list_unique; auto with set.
rewrite <- Equal_elements_equivlist; auto.
red; intros; do 2 rewrite elements_iff; auto.
rewrite H; split; auto.
Qed.

Lemma elements_min : forall s x,
 min_elt s = Some x ->
 elements s = x::elements (remove x s).
Proof.
intros.
apply list_unique; auto with set.
constructor; auto with set.
rewrite Inf_alt; auto with set; intros.
rewrite <- MF.elements_iff in H0.
assert (H1:=@min_elt_2 _ _ y H).
destruct (E.compare x y); auto.
elim (remove_1 e H0).
elim H1; auto.
eapply remove_3; eauto.

red; intros; simpl.
do 2 rewrite <- elements_iff; set_iff; intuition.
destruct (E.eq_dec x x0); unfold E.eq; intuition.
subst x0.
apply min_elt_1; auto.
Qed.

Lemma elements_max : forall s x,
 max_elt s = Some x ->
 elements s = elements (remove x s)++x::nil.
Proof.
intros.
apply list_unique; auto with set.
apply SortA_app with M.E.eq; try red; auto with *.
intros z y H0; revert y; rewrite <- Inf_alt; auto; constructor.
rewrite <- MF.elements_iff in H0.
assert (H1:=@max_elt_2 _ _ z H).
destruct (E.compare x z); auto.
elim H1; auto.
eapply remove_3; eauto.
elim (remove_1 e H0).

split; intros.
apply in_or_app; simpl.
intros; rewrite <- elements_iff in *.
destruct (E.eq_dec x x0); auto with set.
destruct (in_app_or _ _ _ H0); clear H0.
intros; rewrite <- elements_iff in *; eauto with set.
simpl in H1; inversion H1; subst; auto.
intros; rewrite <- elements_iff in *; auto with set.
contradiction.
Qed.

End UsualFacts.

Module FoldEquiv (E:UsualOrderedType)(M:S with Module E:=E).
Module UF := UsualFacts E M.
Import UF M.
Section Fold.

Variable A:Type.
Variable f:elt->A->A.

(** a few definitions equivalent to fold *)

Fixpoint fold_direct (n:nat)(s:t)(i:A) { struct n } : A :=
 match n with
  | O => i
  | S n => match max_elt s with
           | None => i
           | Some x => f x (fold_direct n (remove x s) i)
           end
  end.

Fixpoint fold_tail (n:nat)(s:t)(i:A) { struct n } : A :=
 match n with
  | O => i
  | S n => match min_elt s with
           | None => i
           | Some x => fold_tail n (remove x s) (f x i)
           end
  end.

Lemma fold_direct_1 :
 forall s i, fold_direct (cardinal s) s i = fold f s i.
Proof.
intros s; remember (cardinal s) as n; revert s Heqn; induction n; simpl; intros.
rewrite fold_1.
rewrite cardinal_1 in Heqn.
destruct (elements s); [clear Heqn|inversion Heqn]; simpl; auto.
rewrite fold_1.
case_eq (max_elt s); intros.
rewrite (elements_max H).
rewrite fold_left_app.
simpl; f_equal.
rewrite <- fold_1.
apply IHn.
assert (S (cardinal (remove e s)) = S n).
 rewrite Heqn.
 apply MP.remove_cardinal_1.
 apply max_elt_1; auto.
inversion H0; auto.
rewrite (MP.cardinal_1 (max_elt_3 H)) in Heqn; inversion Heqn.
Qed.

Lemma fold_tail_1_aux :
 forall n l s s' i, n = cardinal s' ->
  elements s = l++elements s' ->
  fold_tail n s' (fold_left (fun x y => f y x) l i) = fold f s i.
Proof.
induction n.
simpl.
intros; rewrite fold_1.
rewrite cardinal_1 in H.
destruct (elements s'); [clear H|inversion H]; simpl; auto.
rewrite <- app_nil_end in H0; subst l; auto.

simpl; intros.
case_eq (min_elt s'); intros.
rewrite (elements_min H1) in H0.
rewrite <- (IHn (l++e::nil) s (remove e s')).
rewrite fold_left_app; simpl; auto.
assert (S (cardinal (remove e s')) = S n).
 rewrite H.
 apply MP.remove_cardinal_1.
 apply min_elt_1; auto.
inversion H2; auto.

rewrite app_ass; simpl; auto.

rewrite (MP.cardinal_1 (min_elt_3 H1)) in H; inversion H.
Qed.

Lemma fold_tail_1 : forall s i,
 fold_tail (cardinal s) s i = fold f s i.
Proof.
intros; apply (@fold_tail_1_aux (cardinal s) nil s s i); auto.
Qed.

End Fold.
End FoldEquiv.

(* Beware: a Program version needs extensionnality! *)
Require Import Program.
Import WfExtensionality.

Module FoldProgram (E:UsualOrderedType)(M:S with Module E:=E).
Module UF := UsualFacts E M.
Import UF M.
Section Fold.

Variable A:Type.
Variable f:elt->A->A.

Program Fixpoint fold_direct_prog (s:t)(i:A)
 { measure (cardinal s) } : A :=
  match max_elt s with
  | None => i
  | Some x => f x (fold_direct_prog (remove x s) i)
  end.

Next Obligation.
 symmetry in Heq_anonymous.
 rewrite <- (@MP.remove_cardinal_1 s x); auto with arith set.
Qed.

Program Fixpoint fold_tail_prog (s:t)(i:A)
 { measure (cardinal s) } : A :=
  match min_elt s with
  | None => i
  | Some x => fold_tail_prog (remove x s) (f x i)
  end.

Next Obligation.
 symmetry in Heq_anonymous.
 rewrite <- (@MP.remove_cardinal_1 s x); auto with arith set.
Qed.

Lemma fold_direct_prog_1 :
 forall s i, fold_direct_prog s i = fold f s i.
Proof.
intros s; remember (cardinal s) as n; revert s Heqn.
induction n using Wf_nat.lt_wf_ind; intros.
unfold fold_direct_prog, fold_direct_prog_func.
rewrite fix_sub_eq_ext; auto.
simpl.
generalize (@max_elt_1 s) (@max_elt_2 s) (@max_elt_3 s) (@elements_max s).
destruct (max_elt s); intros.
change (f e (fold_direct_prog (remove e s) i) = fold f s i).
rewrite fold_1.
rewrite (H3 e); auto.
rewrite fold_left_app; simpl; f_equal.
rewrite <- fold_1.
assert (S (cardinal (remove e s)) = n).
 rewrite Heqn.
 apply MP.remove_cardinal_1; auto.
apply H with (cardinal (remove e s)); auto.
rewrite <- H4; auto with arith.

rewrite fold_1.
generalize (cardinal_1 s).
rewrite MP.cardinal_1; auto.
destruct (elements s); simpl; auto; inversion 1.
Qed.

Lemma fold_tail_prog_1_aux :
 forall n l s s' i, n = cardinal s' ->
  elements s = l++elements s' ->
  fold_tail_prog s' (fold_left (fun x y => f y x) l i) = fold f s i.
Proof.
induction n using Wf_nat.lt_wf_ind; intros.
unfold fold_tail_prog, fold_tail_prog_func.
rewrite fix_sub_eq_ext; auto.
simpl.
generalize (@min_elt_1 s') (@min_elt_2 s') (@min_elt_3 s') (@elements_min s').
destruct (min_elt s'); intros.
change (fold_tail_prog (remove e s') (f e (fold_left (fun x y => f y x) l i))
        = fold f s i).
rewrite (H5 e) in H1; auto.
assert (S (cardinal (remove e s')) = n).
 rewrite H0.
 apply MP.remove_cardinal_1; auto.
assert (cardinal (remove e s') < n).
 rewrite <- H6; auto.
rewrite <- (@H _ H7 (l++e::nil) s (remove e s')); auto.
rewrite fold_left_app; simpl; auto.

rewrite app_ass; simpl; auto.

rewrite fold_1.
generalize (cardinal_1 s').
rewrite MP.cardinal_1; auto.
destruct (elements s'); simpl; auto; inversion 1.
rewrite <- app_nil_end in H1; subst l; auto.
Qed.

Lemma fold_tail_prog_1 : forall s i,
 fold_tail_prog s i = fold f s i.
Proof.
intros; apply (@fold_tail_prog_1_aux (cardinal s) nil s s i); auto.
Qed.

End Fold.
End FoldProgram.

Require Import Recdef.

Module FoldFunction (E:UsualOrderedType)(M:S with Module E:=E).
Module Import P := Properties M.
Module Import F := FoldEquiv E M.
Import M.
Section Fold.

Variable A:Type.
Variable f:elt->A->A.

Function fold_direct_fun (s:t)(i:A) { measure cardinal s } : A :=
  match max_elt s with
  | None => i
  | Some x => f x (fold_direct_fun (remove x s) i)
  end.
Proof.
 intros.
 rewrite <- (@P.remove_cardinal_1 s x); auto with arith set.
Defined.

Function fold_tail_fun (s:t)(i:A) { measure cardinal s } : A :=
  match min_elt s with
  | None => i
  | Some x => fold_tail_fun (remove x s) (f x i)
  end.
Proof.
 intros.
 rewrite <- (@P.remove_cardinal_1 s x); auto with arith set.
Defined.

Lemma fold_direct_fun_1 :
 forall s i, fold_direct_fun s i = fold f s i.
Proof.
intros s i.
rewrite <- F.fold_direct_1.
functional induction fold_direct_fun s i; simpl; auto.
rewrite P.cardinal_1; simpl; auto with set.
rewrite <- P.remove_cardinal_1 with s x; auto with set.
simpl; auto.
rewrite e; simpl.
congruence.
Qed.

Lemma fold_tail_prog_1 : forall s i,
 fold_tail_fun s i = fold f s i.
Proof.
intros s i.
rewrite <- F.fold_tail_1.
functional induction fold_tail_fun s i; simpl; auto.
rewrite P.cardinal_1; simpl; auto with set.
rewrite <- P.remove_cardinal_1 with s x; auto with set.
simpl; auto.
rewrite e; simpl; auto.
Qed.

End Fold.
End FoldFunction.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Basic_Cons.CCC Basic_Cons.LCCC Basic_Cons.PullBack.
Require Import Ext_Cons.Comma.
Require Import Coq_Cats.Type_Cat.Type_Cat Coq_Cats.Type_Cat.PullBack.
Require Import Archetypal.Discr.Discr.
Require Import Functor.Functor_Ops Functor.Const_Func.

(** Type_Cat is locally cartesian closed. *)
Section CCC_Slice_A.
  Context {A : Type}.

  (** Notation for creating objects of slice out of arrows to A. *)
  Local Notation CO z :=
    (
      @Build_Comma_Obj
        Type_Cat
        Type_Cat
        1
        (Functor_id Type_Cat)
        (@Const_Func 1 Type_Cat A)
        _
        tt
        z
    ) (only parsing).

  (** The slice has products because Type_Cat has pullbacks. *)
  Definition Type_Cat_Slice_Prod :
    Has_Products (Slice Type_Cat A) :=
    @Has_PullBack_Slice_Has_Prod Type_Cat Type_Cat_Has_PullBacks A
  .

  (** Here we show that slices have exponentials. *)

  (** Given two arrows f : Y → A and g : Y → A, the exponential gᶠ is an arrow from
       {(z, u)| z : A, u : (f⁻¹ z) → (g⁻¹ z)}
to A that maps a pair (z, u) to z.

Intuitively, exponentials are representatives of the set of morphisms between objects.
Recall thatin a slice, a morphism from f : X → A to g : Y → A is a morphism h : X → Y
that makes the following diagram commute.

         h
    X ——————–> Y
    |         /
    |       /
  f |     / g
    |   /
    ↓ ↙
    A

Therefore, for any element z : A, arrows from (f⁻¹ z) to (g⁻¹ z) are precisely those
that make the diagram commute.

*)

  Context (f g : Slice Type_Cat A).

  Definition Pre_Image {X : Type} (f : X → A) (z : A) := {y : X| f y = z}.

  Local Notation EXP :=
    (
      CO
        (
          fun m : {x : A & (Pre_Image (CMO_hom f) x) → (Pre_Image (CMO_hom g) x)} =>
            projT1 m
        )
    ) (only parsing).

  Local Obligation Tactic := idtac.

  Program Definition Type_Cat_LExp : @Exponential (Slice Type_Cat A) Type_Cat_Slice_Prod f g :=
    {|
      exponential := EXP;
      eval :=
        @Build_Comma_Hom
          Type_Cat
          Type_Cat
          1
          (Functor_id Type_Cat)
          (@Const_Func 1 Type_Cat A)
          _
          _
          (fun w => proj1_sig ((projT2 (fst (proj1_sig w))) (exist _ (snd (proj1_sig w)) _)))
          tt
          _
      ;
      Exp_morph_ex :=
        fun z h =>
          @Build_Comma_Hom
            Type_Cat
            Type_Cat
            1
            (Functor_id Type_Cat)
            (@Const_Func 1 Type_Cat A)
            z
            EXP
            (fun w =>
               existT
                 _
                 (CMO_hom z w)
                 (fun v => exist _ (CMH_left h (exist _ (w, proj1_sig v) _)) _)
            )
            tt
            _
    |}.

  Next Obligation.
  Proof.
    intros w.
    exact (eq_sym (proj2_sig w)).
  Qed.

  Next Obligation.
  Proof.
    extensionality w.
    destruct w as [[[x h] z] H]; cbn in *.
    match goal with
      [|- _ = CMO_hom g (proj1_sig ?A)] =>
      destruct A as [a H1]; cbn; auto
    end.
  Qed.

  Next Obligation.
  Proof.
    intros z h w v.
    symmetry.
    apply (proj2_sig v).
  Qed.

  Next Obligation.
  Proof.
    intros z h w v.
    symmetry.
    exact (equal_f (CMH_com h) (exist _ (w, proj1_sig v) (Type_Cat_LExp_obligation_3 z h w v))).
  Qed.

  Next Obligation.
  Proof.
    trivial.
  Qed.

  Next Obligation.
  Proof.
    intros z h.
    apply Comma_Hom_eq_simplify;
      [
        extensionality x |
        match goal with
          [|- ?A = ?B] =>
          destruct A; destruct B; trivial
        end
      ].
    cbn in *.
    apply f_equal.
    destruct x as [x H].
    apply sig_proof_irrelevance; trivial.
  Qed.

  Next Obligation.
  Proof.
    intros z h u u' H1 H2.
    rewrite H1 in H2; clear H1.
    apply Comma_Hom_eq_simplify;
      [extensionality x|
       match goal with
         [|- ?A = ?B] =>
         destruct A; destruct B; trivial
       end
      ].
    set (Hp1 :=
           equal_f
             (eq_trans (eq_sym (CMH_com u)) (CMH_com u'))
             x
        ); clearbody Hp1; cbn in Hp1.
    match goal with
      [|- ?A = ?B] =>
      cut (match Hp1 in _ = y return
                 Pre_Image (CMO_hom f) y → Pre_Image (CMO_hom g) y
           with
             eq_refl => projT2 A
           end = projT2 B
          );
        [intros Hp2; destruct A as [za Fa]; destruct B as [zb Fb]|]
    end.
    {
      cbn in Hp1, Hp2.
      destruct Hp1; destruct Hp2; trivial.
    }
    {
      extensionality v.
      transitivity
        (match Hp1 in _ = y return
               Pre_Image (CMO_hom g) y
         with
           eq_refl =>
           projT2
             (CMH_left u x)
             (match eq_sym Hp1 in _ = y return
                    Pre_Image (CMO_hom f) y
              with
                eq_refl => v
              end)
         end
        ).
      {
        destruct Hp1; trivial.
      }
      set (M :=
             exist
               (fun w => CMO_hom z (fst w) = CMO_hom f (snd w))
               (x, proj1_sig v)
               (eq_trans
                  (equal_f (CMH_com u') x)
                  (eq_sym (proj2_sig v))
               )
          ).
      set (H2' := (equal_f (f_equal CMH_left H2) M));clearbody H2'; clear H2.
      cbn in H2'.
      match type of H2' with
        proj1_sig (projT2 (CMH_left u x) ?w) = proj1_sig (projT2 (CMH_left u' x) ?w') =>
        cutrewrite
          (w =
           (
             match eq_sym Hp1 in _ = y return
                   Pre_Image (CMO_hom f) y
             with
               eq_refl => v
             end
           )
          ) in H2'; [cutrewrite (w' = v) in H2' |]
      end.
      {
        apply sig_proof_irrelevance.
        etransitivity; [|apply H2'].
        generalize (
            (
              match eq_sym Hp1 in (_ = y) return
                    (Pre_Image (CMO_hom f) y)
              with
                eq_refl => v
              end
            )
          ) as p.
        intros p.
        clear.
        destruct Hp1.
        trivial.
      }
      {
        clear.
        apply sig_proof_irrelevance; trivial.
      }
      {
        clear.
        apply sig_proof_irrelevance; cbn.
        destruct (eq_sym Hp1); trivial.
      }
    }
  Qed.

End CCC_Slice_A.

(** Type_Cat is locally cartesian closed. *)
Instance Type_Cat_LCCC : LCCC Type_Cat :=
  fun A =>
    {|
      CCC_term := Slice_Terminal Type_Cat A;
      CCC_HP := Type_Cat_Slice_Prod;
      CCC_HEXP := Type_Cat_LExp
    |}.


Module Quotient.

Require Import Coq.ZArith.ZArith.
Require Import Coq.ZArith.Zcompare.
Print Z.
Inductive Quot : Type :=
    | quot : Z -> positive -> Quot.

Definition qplus (a b: Quot) : Quot :=
    match a, b with
    | (quot na da), (quot nb db) =>
        quot (na * (Zpos db) + nb * (Zpos da)) (da * db)
        end.

Definition qmultply (a b: Quot) : Quot :=
    match a, b with
    | (quot na da) , (quot nb db) =>
        quot (na * nb) (da * db)
    end.

Definition qneg (a : Quot) : Quot :=
    match a with
    | (quot na da) =>
        quot (-na) da
        end.

Inductive iszero : Quot -> Prop :=
    | eq0 : forall p, iszero (quot Z0 p).

Definition qinv (a : Quot) (p : (~(iszero a))) : Quot.
    refine
    ((match a as a' return (a = a' -> Quot) with
    | (quot na da) =>
        ((match na as na' return (na = na' -> a = _ -> Quot) with
            | Zneg na0 => fun _ => fun _ => quot (Zneg da) na0
            | Zpos na0 => fun _ => fun _ => quot (Zpos da) na0
            | Z0 => _
        end) _)
    end) _);
    intros;[
    subst na; subst a;destruct (p (eq0 da)) | auto | auto].
Defined.

Print Z.mul.

Open Scope Z_scope.

(*
Inductive Qgt : Quot -> Quot ->  Type :=
    | qgt : forall (na nb : Z) (da db : positive),
                (na * (Z.pos db)) > (nb * (Z.pos da)) ->
                Qgt (quot na da) (quot nb db).

*)

Print Zgt_compare.
Print Z.gtb.
Definition qgt (a b: Quot) : bool :=
    match a, b with
    | (quot na da), (quot nb db) =>
            Z.gtb (na * (Zpos db)) (nb * (Zpos da))
    end.

Definition qlt (a b: Quot) : bool :=
    qgt b a.

SearchPattern (bool -> bool).
Print negb.

Definition qge (a b: Quot) : bool :=
    negb (qlt a b).

Definition qle (a b :Quot) : bool :=
    negb (qgt a b).

Definition qcomp (a b:Quot) : Quot :=
    if (qgt a b)
    then (quot 1 1)
    else if (qlt a b)
         then (quot (-1) 1)
         else (quot 0 1).

Theorem qinv_det :
    forall a p1 p2,
        qinv a p1 = qinv a p2.

    intros a;
    induction a.
    intros. destruct z; auto.
    destruct (p1 (eq0 _)).
Qed.

End Quotient.


Inductive nostutter {X:Type} : list X -> Prop :=
| nostutter_nil: nostutter []
| nostutter_cons: forall (x:X), nostutter (x :: [])
| nostutter_xy: forall (x y: X) (l: list X),
    x <> y -> nostutter (y :: l) -> nostutter (x :: y :: l).

Example test_nostutter_1: nostutter [3;1;4;1;5;6].
Proof.
Abort.

Example test_nostutter_2: nostutter (@nil nat).
Proof.
  repeat constructor.
Qed.

Example test_nostutter_3: nostutter [5].
Proof.
  repeat constructor.
Qed.

Example test_nostutter_4: not (nostutter [3;1;1;4]).
  Proof. intro.
  repeat match goal with
    h: nostutter _ |- _ => inversion h; clear h; subst
  end.
  contradiction H1; auto.
Qed.


From mathcomp Require Import all_ssreflect.
From hanoi Require Import extra gdist ghanoi ghanoi3.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Hanoi3.

(*****************************************************************************)
(*  The pegs are the three elements of 'I_3                                  *)
(*****************************************************************************)

Implicit Type p : peg 3.

Local Notation "c1 `-->_r c2" := (rmove c1 c2)
    (format "c1  `-->_r  c2", at level 60).
Local Notation "c1 `-->*_r c2" := (connect rmove c1 c2)
    (format "c1  `-->*_r  c2", at level 60).

(******************************************************************************)
(* Function that builds a path from peg to peg                                *)
(******************************************************************************)

Fixpoint ppeg {n : nat} p1 p2 :=
  if n isn't n1.+1 return seq (configuration 3 n) then [::] else
    let p3 := `p[p1, p2] in
    [seq ↑[i]_p1 | i <- ppeg p1 p3] ++
    [seq ↑[i]_p2 | i <- `c[p3] :: ppeg p3 p2].

Lemma size_ppeg n p1 p2 :
   size (ppeg p1 p2 : seq (configuration 3 n)) = (2^ n).-1.
Proof.
elim: n p1 p2 => //= n IH p1 p2.
rewrite size_cat /= !size_map !IH  expnS mul2n -addnn.
by rewrite -(prednK (_ : 0 < 2 ^ n)) // expn_gt0.
Qed.

Lemma last_ppeg n p1 p2 c (cs := ppeg p1 p2 : seq (configuration 3 n)) :
   last c cs = `c[p2].
Proof.
have HH := @rirr 3.
rewrite /cs; elim: n p1 p2 c {cs} => //= [_ p2 c | n IH p1 p2 c].
  by apply/ffunP=> [] [].
by rewrite last_cat /= last_map IH perfect_liftr.
Qed.

Lemma path_ppeg n p1 p2 (cs := ppeg p1 p2 : seq (configuration 3 n)) :
  p1 != p2 -> path rmove `c[p1] cs.
Proof.
have HH := @rirr 3.
rewrite /cs; elim: n p1 p2 {cs} => //= n IH p1 p2 p1Dp2.
set p3 := `p[_,_].
have p1Dp3 : p1 != p3 by rewrite eq_sym opegDl.
have p3Dp2 : p3 != p2 by rewrite opegDr.
rewrite cat_path /= -{1}[`c[p1]]cunliftrK ffunE !path_liftr // perfect_unliftr.
rewrite !IH // ?andbT /=.
rewrite -{1}[`c[_]]cunliftrK ffunE last_map perfect_unliftr last_ppeg.
by apply: move_liftr_perfect; rewrite // eq_sym opegDr.
Qed.

(* We can go from any perfect configuration to a perfect configuration *)
Lemma move_connect_ppeg n p1 p2 : `c[p1, n] `-->*_r `c[p2].
Proof.
case: (p1 =P p2) => [->|/eqP p1Dp2] //.
apply/connectP; exists (ppeg p1 p2); first by apply: path_ppeg.
by rewrite last_ppeg.
Qed.

(* The proof is done by inspecting the moves that the last disk is doing in cs*)
(* We use a double  induction :                                               *)
(* The first induction is used when the path has duplicates                   *)
(* The second induction is on n and to bound recursive call                   *)
Lemma ppeg_min n p1 p2 (cs : seq (configuration 3 n)) :
  p1 != p2 -> path rmove `c[p1] cs -> last `c[p1] cs = `c[p2] ->
  (2^ n).-1 <= size cs ?= iff (cs == ppeg p1 p2).
Proof.
have irrH := @rirr 3; have symH := @rsym 3.
(* The first induction is used when the path has duplicates (1 case) *)
have [m sLm] := ubnP (size cs); elim: m => // m IHm in n p1 p2 cs sLm *.
elim: n p1 p2 cs sLm => /= [p1 p2 [|] //|]n IH p1 p2 cs sLm p1Dp2.
have /= := size_ppeg n.+1 p1 p2.
(* Is there a move of the last first disk *)
case:  path3SP => //.
  (* No move : impossible since p1 != p2 *)
  case: cs sLm => /= [_ _ _ _  _ /ffunP /(_ ldisk)/eqP|a cs sLm].
    by rewrite !ffunE (negPf p1Dp2).
  rewrite !ffunE => acsE _ _ _ lacsE.
  have := mem_last a cs.
  rewrite acsE lacsE inE => /orP[/eqP/ffunP/(_ ldisk)/eqP|].
    by rewrite cliftr_ldisk !ffunE eq_sym (negPf p1Dp2).
  case/mapP => c _ /ffunP /(_ ldisk)/eqP.
  by rewrite cliftr_ldisk ffunE eq_sym (negPf p1Dp2).
(* There is a move from p1 to p3 *)
rewrite !ffunE perfect_unliftr /= => cs1 cs2 p3 p1Dp3 _.
move=> p1cs1Lp1p3 csE p1Pcs1.
have Scs1 : size cs1 < m.+1.
  by apply: leq_trans sLm; rewrite csE size_cat size_map ltnS leq_addr.
have p1Dp1p3 : p1 != `p[p1, p3] by rewrite eq_sym opegDl.
(* After the first move, last disk is on p3, the other disk is `p[p1, p3] *)
have HL1 := IH _ _ _ Scs1 p1Dp1p3 p1Pcs1 p1cs1Lp1p3.
have n2E : (2 ^ n.+1).-1 = (2 ^ n).-1 + (2 ^ n).-1.+1.
  by rewrite expnS mul2n -addnn -[2 ^ n]prednK ?expn_gt0.
(* Is there another move *)
case:  path3SP => //=.
  (* there is no move so p3 = p2 and simple induction should make it *)
  rewrite cliftr_ldisk cliftrK /=.
  move=> cs2E p1p3Pcs2 _ sH _ p1csLp2.
  have p3E : p3 = p2.
    move: p1csLp2; rewrite csE cs2E last_cat /= last_map.
    by move=> /ffunP /(_ ldisk); rewrite cliftr_ldisk ffunE.
  rewrite p3E in p1cs1Lp1p3 csE HL1 cs2E p1p3Pcs2.
  have Scs2 : size [seq ↓[i] | i <- cs2] < m.+1.
    apply: leq_trans sLm.
    by rewrite csE size_cat !size_map /= ltnS -addSnnS leq_addl.
  have p1p2Lcs2 : last `c[`p[p1, p2]] [seq ↓[i] | i <- cs2] = `c[p2].
    rewrite -[`c[_]](cliftrK p2) last_map.
    by have := p1csLp2; rewrite csE last_cat /= => ->; rewrite perfect_unliftr.
  have HL2 := IH _ _ _ Scs2 (opegDr _ _) p1p3Pcs2 p1p2Lcs2.
  move/leqifP : HL1; case: eqP => [<- /eqP HL1|_ HL1].
    move/leqifP : HL2; case: eqP => [<- /eqP HL2|_ HL2].
      rewrite size_map in HL2.
      rewrite csE size_cat /= size_map -HL1 -HL2 -cs2E eqxx //= n2E.
      by apply/leqifP.
    apply/leqifP; case: eqP => [/(congr1 size)->|_].
      by rewrite -sH !size_cat /= !size_map -HL1 size_ppeg.
    rewrite csE size_cat /= !size_map in HL2 *.
    by rewrite -HL1 n2E ltn_add2l.
  apply/leqifP; case: eqP => [/(congr1 size)->|_]; first by rewrite -sH.
  rewrite csE size_cat /= !size_map in HL2 *.
  by rewrite n2E -addSn leq_add // ltnS HL2.
move=> cs3 cs4 p4; rewrite -!/rmove !cliftr_ldisk cliftrK.
move => p3Dp4 _ p1p3cs3Lp3p4 cs2E p1p3Pcs3 p3p4Pcs4 _ sH _ p1csLp2.
(* we did two moves of the largest disk so we cannot be = *)
apply/leqifP; case: eqP => [/(congr1 size)|_].
  by rewrite size_cat /= !size_map !size_ppeg n2E => ->.
(* Did we come back to p1 *)
case: (p4 =P p1) => [p4Ep1 | /eqP p4Dp1].
  rewrite p4Ep1 in p3Dp4 p1p3cs3Lp3p4 cs2E p3p4Pcs4.
  (* if so cs has a repetition so we can use IHm *)
  pose cs' := [seq ↑[i]_p1 | i <- cs1] ++ cs4.
  have Scs' : size cs' < size cs.
    rewrite csE /cs' cs2E !size_cat /= size_cat !size_map /=.
    by rewrite ltn_add2l -!addSnnS ltnS leq_addl.
  apply: leq_trans (Scs'); rewrite ltnS.
  rewrite (IHm _ p1 p2) //; first by rewrite (leq_trans Scs').
    rewrite cat_path /= -[`c[_]](cunliftrK) ffunE perfect_unliftr.
    by rewrite path_liftr // p1Pcs1 /= last_map p1cs1Lp1p3 opeg_sym.
  rewrite last_cat /= -[`c[_]](cunliftrK) ffunE perfect_unliftr.
  rewrite last_map p1cs1Lp1p3.
  have := p1csLp2.
  by rewrite csE cs2E !last_cat /= last_cat /= opeg_sym.
rewrite csE cs2E size_cat /= size_cat /= !size_map n2E !addnS !ltnS addnA.
apply: leq_trans (leq_add _ _) (leq_addr _ _); first by rewrite HL1.
have Scs3 : size cs3 < m.+1.
  apply: leq_trans sLm.
  rewrite csE cs2E size_cat /= size_cat /= !size_map addnC ltnS addnS !addSnnS.
  by rewrite -addnA leq_addr.
rewrite (IH _ _ _ Scs3 _ p1p3Pcs3 p1p3cs3Lp3p4) //.
by rewrite opeg3E // eq_sym opeg3E // eq_sym p1Dp3 p4Dp1 eq_sym opegDl.
Qed.

Lemma gdist_rhanoi3p n p1 p2 :
  `d[`c[p1, n], `c[p2]]_rmove = (2^ n).-1 * (p1 != p2).
Proof.
case: eqP => [<-|/eqP p1Dp2]; first by rewrite muln0 gdist0.
rewrite muln1.
apply/eqP; rewrite eqn_leq -(size_ppeg n p1 p2).
rewrite gdist_path_le //=; last 2 first.
- by apply: path_ppeg.
- by rewrite last_ppeg.
have /gpath_connect [cs csH] : connect rmove `c[p1, n] `c[p2].
  by apply: move_connect_ppeg.
rewrite size_ppeg (gpath_dist csH) /=.
apply: ppeg_min p1Dp2 (gpath_path csH) _ => //.
by apply: gpath_last csH.
Qed.

(*****************************************************************************)
(* Function that builds a path from a configuration to a peg                 *)
(*****************************************************************************)

Fixpoint rpeg {n : nat} :=
  if n is n1.+1 return configuration 3 n -> peg 3 -> seq (configuration 3 n)
  then
    fun c p =>
    let p1 := c ldisk in
    if p1 == p then [seq ↑[i]_p | i <- rpeg ↓[c] p] else
    let p2 := `p[p1, p] in
    [seq ↑[i]_p1 | i <- rpeg ↓[c] p2] ++
    [seq ↑[i]_p | i <- `c[p2] :: ppeg p2 p]
  else fun _ _ => [::].

Lemma rpeg_perfect n p : rpeg (`c[p]) p = [::] :> seq (configuration 3 n).
Proof.
elim: n => //= n IH.
by rewrite ffunE eqxx perfect_unliftr IH.
Qed.

Lemma rpeg_nil_inv n c p : rpeg c p = [::] -> c = `c[p] :> configuration _ n.
Proof.
elim: n c => [c _|n IH c] /=; first by apply/ffunP=> [] [].
case: eqP => [H | H] //=; last by case: map.
rewrite -{2}[c]cunliftrK.
case: rpeg (IH (↓[c])) => // -> // _.
by rewrite H perfect_liftr.
Qed.

Lemma rpeg_ppeg n p1 p2 : p1 != p2 -> rpeg `c[p1, n] p2  = ppeg p1 p2.
Proof.
elim: n p1 p2 => //= n IH p1 p2 p1Dp2.
by rewrite ffunE perfect_unliftr (negPf p1Dp2) !IH // eq_sym opegDl.
Qed.

Lemma last_rpeg n (c : configuration 3 n) p (cs := rpeg c p) :
  last c cs = `c[p].
Proof.
rewrite /cs; elim: n c p {cs} => /= [c p| n IH c p].
  by apply/ffunP=> [] [].
case: eqP => [Ho|/eqP Do].
  by rewrite -{1}[c](cunliftrK) Ho last_map IH perfect_liftr.
by rewrite last_cat /= last_map last_ppeg perfect_liftr.
Qed.

Lemma path_rpeg n (c : configuration 3 n) p (cs := rpeg c p) :
  path rmove c cs.
Proof.
have HH := @rirr 3.
rewrite /cs; elim: n c p {cs} => //= n IH c p.
case: eqP => [Ho|/eqP Do].
  by rewrite -{1}[c](cunliftrK) Ho path_liftr.
set c2 := `c[_].
rewrite cat_path /= -{1}[c]cunliftrK !path_liftr // IH path_ppeg ?opegDr //.
rewrite andbT /=.
rewrite -{1}[c]cunliftrK last_map last_rpeg -/c2.
apply: move_liftr_perfect => //; first by rewrite eq_sym (opegDl _).
by rewrite eq_sym (opegDr _).
Qed.

(* We can go from any configuration to a perfect configuration *)
Lemma move_connect_rpeg n (c : configuration _ n) p : c `-->*_r `c[p].
Proof.
apply/connectP; exists (rpeg c p); first by apply: path_rpeg.
by rewrite last_rpeg.
Qed.

(* So we can also from a perfect configuration c to any configuration *)
Lemma move_connect_lpeg n (c : configuration _ n) p : `c[p] `-->*_r c.
Proof.
rewrite [connect _ _ _]connect_sym //.
  by apply: move_connect_rpeg.
by exact: rsym.
Qed.

(* Two configurations are always connected *)
Lemma move_connect n (c1 c2 : configuration 3 n) : c1 `-->*_r c2.
Proof.
by apply: connect_trans (move_connect_rpeg c1 (inord 1))
         (move_connect_lpeg c2 (inord 1)).
Qed.

(******************************************************************************)
(* Function that builds a path from a configuration to a peg                  *)
(******************************************************************************)

(*****************************************************************************)
(* Computes the size of rpeg                                                 *)
(*****************************************************************************)

Fixpoint size_rpeg {n : nat} : (configuration _ n) -> _ -> nat :=
  match n with
  | 0 => fun _ _ => 0
  | n1.+1 =>
      fun c p =>
        let p1 := c ldisk in
        if p1 == p then size_rpeg ↓[c] p else
        let p2 := `p[p1, p] in size_rpeg ↓[c] p2 + 2 ^ n1
  end.

Lemma size_rpegE n p (c : _ _ n) : size_rpeg c p = size (rpeg c p).
Proof.
elim: n p c => //= n IH p c.
case: eqP => [clEp|/eqP clDp]; first by rewrite size_map IH.
by rewrite size_cat /= !size_map size_ppeg prednK ?expn_gt0 // IH.
Qed.

(* Upper bound on the size *)
Lemma size_rpeg_up n (c : _ _ n) p : size_rpeg c p <= (2^ n).-1.
Proof.
elim: n c p => //= n IH c p.
case: eqP => _.
  apply: (leq_trans (IH _ _)).
  case: (_ ^ _) (expn_eq0 2 n) (expn_eq0 2 n.+1)
              (leq_pexp2l (isT: 0 < 2) (ltnW (leqnn n.+1))) => //= n1 _.
  by case: (_ ^ _).
apply: leq_trans (_ : (2^n).-1 + (2^n)  <= _).
  by rewrite leq_add2r IH.
rewrite expnS mul2n -addnn.
by case: (2 ^ n)  (expn_eq0 2 n)  => [|n1]; rewrite ?addn0.
Qed.

(* rpeg gives the smallest path to a perfect configuration.                   *)
(* This path is unique                                                        *)
Lemma rpeg_min n (c : configuration 3 n) p cs :
  path rmove c cs -> last c cs = `c[p] ->
  size_rpeg c p <= size cs ?= iff (cs == rpeg c p).
Proof.
(* As we want this statememnt to hold for any configuration c1       *)
(* and not just for initial perfect configuration the proof is more  *)
(* intricate. We need a double  induction :                          *)
(* The first induction is used when the path has duplicates (1 case) *)
have [m sLm] := ubnP (size cs); elim: m => // m IHm in n c p cs sLm *.
(* The usual induction on the number of disks                       *)
elim : n c p cs sLm => [c1 p [|] //=|n IH c1 p cs Scs c1Pcs lc1csEp /=].
case: (_ =P p) => [c1nEp |/eqP c1nDp].
  (* the largest disk is already well-placed *)
  have lcsnEc1n : last c1 cs ldisk = c1 ldisk.
    by rewrite lc1csEp !ffunE.
  have [cs1 [c1Pcs1 lcsElcs1 /leqifP]] :=
    pathS_restrict (@rirr 3) c1Pcs.
  have lcs1P : last (↓[c1]) cs1 = `c[p].
    by rewrite lcsElcs1 lc1csEp perfect_unliftr.
  case: eqP=> [csEcs1 /eqP<- |/eqP csDcs1 scs1L].
    rewrite csEcs1 c1nEp eq_map_liftr.
    apply: IH => //.
    by move: Scs; rewrite csEcs1 size_map.
  apply/leqifP; case: eqP => [->|_].
    by rewrite size_map size_rpegE.
  apply: leq_ltn_trans (scs1L).
  apply: IH => //.
  by apply: ltn_trans Scs.
pose f (c : configuration 3 n.+1) := c ldisk.
have HHr := @rirr 3.
have HHs := @rsym 3.
(* We need to move the largest disk *)
case: path3SP c1Pcs => // [c1' cs' p1 csE c1'Pcs' _|
                           cs1 cs2 p1 p2 p3 c1' c2
                           p1Dp2 p1Rp2 lc1'cs1Epp3 csE c1'Pcs1 c2Pcs2 _].
  (* this case is impossible the largest disk has to move *)
  case/eqP: c1nDp.
  move : lc1csEp; rewrite csE -[c1](cunliftrK) last_map => /(congr1 f).
  by rewrite /f !cliftr_ldisk !ffunE.
(* c2 is the first configuration when the largest disk has moved *)
rewrite csE size_cat -/p1.
have p1Dp : p1 != p by [].
have Scs1 : size cs1 < m.+1.
  apply: ltn_trans Scs.
  by rewrite csE size_cat /= size_map addnS ltnS leq_addr.
have Scs2 : size cs2 < m.+1.
  apply: ltn_trans Scs.
  by rewrite csE size_cat /= size_map addnS ltnS leq_addl.
case: (p2 =P p) => [p2Ep|/eqP p2Dp].
  pose c2' := ↓[c2].
  have c2'Epp3 : c2' = `c[`p[p1, p2]] by rewrite [LHS]cliftrK.
  (* the first moves of largest disk of cs is the right one *)
  have/(pathS_restrict HHr)[cs2' [c2'Pcs2' lc2'cs2'E cs2'L]] := c2Pcs2.
  have Scs2' : size cs2' < m.+1.
    by apply: leq_ltn_trans Scs2; rewrite cs2'L.
  have /IH := lc1'cs1Epp3 => // /(_ Scs1 c1'Pcs1) IHc1.
  have /IH : last c2' cs2' = `c[p] => [| /(_ Scs2' c2'Pcs2') IHc2].
    rewrite lc2'cs2'E -perfect_unliftr.
    by move: lc1csEp; rewrite csE last_cat /= => ->.
  rewrite -p2Ep in IHc2.
  move /leqifP : cs2'L.
  case: eqP => [cs2E _ | /eqP cs2D Lcs2].
    (* there is only one move of the largest disk in cs *)
    rewrite cs2E size_map -p2Ep -/p3.
    have /leqifP := IHc1; case: eqP => [->_ |_ Lc1].
      (* the first part of cs is perfect *)
      have /leqifP := IHc2; case: eqP => [->_ |_ Lc2].
      (* the second part of cs is perfect, only case of equality *)
        apply/leqifP; case: eqP => [/(congr1 size)|[]].
          rewrite !size_cat /= !size_map !addnS !size_rpegE c2'Epp3.
          by rewrite !rpeg_ppeg ?opegDr // size_ppeg -addnS prednK ?expn_gt0.
        congr (_ ++ _ :: _).
        by rewrite /c2' /c2 cliftrK cliftr_ldisk rpeg_ppeg // opegDr.
      apply/leqifP; case: eqP => [/(congr1 size)|_].
        rewrite !size_cat /= !size_map !size_rpegE.
        by rewrite size_ppeg prednK ?expn_gt0 // => ->.
      rewrite /= size_rpegE ltn_add2l ltnS size_map.
      rewrite c2'Epp3 size_rpegE rpeg_ppeg ?opegDr // size_ppeg in Lc2.
      by rewrite prednK // expn_gt0 in Lc2.
    apply/leqifP; case: eqP => [/(congr1 size)|_].
      rewrite !size_cat /= !size_map !size_rpegE => ->.
      by rewrite size_ppeg prednK // expn_gt0.
    rewrite /= -addSn leq_add // size_map -[_ ^ _]prednK ?expn_gt0 // ltnS.
    have := IHc2; rewrite c2'Epp3 size_rpegE rpeg_ppeg ?opegDr // size_ppeg.
    by move=>->.
  apply/leqifP; case: eqP => [/(congr1 size)|_].
    rewrite !size_cat /= !size_map !size_rpegE.
    by rewrite size_ppeg prednK ?expn_gt0 // => ->.
  rewrite -addnS leq_add //= ?ltnS -?p2Ep.
    by rewrite size_map IHc1.
  rewrite -[_ ^ _]prednK ?expn_gt0 //.
  apply: leq_ltn_trans Lcs2.
  have := IHc2.
  by rewrite c2'Epp3 size_rpegE rpeg_ppeg ?opegDr // size_ppeg => ->.
(* The largest disk jumped to an intermediate peg *)
have p3Ep : p3 = p.
  by apply/eqP; rewrite opeg3E // p1Dp.
(* cs cannot be optimal *)
apply/leqifP; case: eqP => [/(congr1 size)|_].
  rewrite !size_cat /= !size_map !size_rpegE.
  by rewrite size_ppeg prednK ?expn_gt0 // => ->.
case: path3SP c2Pcs2 => // [c2' cs2'|cs3 cs4].
  (* this is impossible we need another move of the largest disk *)
  rewrite !cliftr_ldisk /= => cs2E c2'Pcs2'.
  case/eqP: p2Dp.
  have := lc1csEp.
  rewrite csE last_cat /= => /(congr1 f).
  by rewrite /f cs2E last_map !cliftr_ldisk !ffunE.
rewrite !cliftr_ldisk => p2'.
rewrite {}/p2' => p4.
set p5 := `p[p2, p4]; set c2' := ↓[c2].
move=> p2Dp4 p2Rp4 c2'cs5Epp5 cs2E c2'Pcs3 pp5p4Pcs4 _.
case: (p5 =P p3) => [p5Ep3 /= | /eqP p5Dp3].
  (* the path has a duplicate use the induction hypothesis *)
  have p4Ep1: p4 = p1.
    move/eqP : p5Ep3; rewrite eq_sym // opeg3E // eq_sym //.
    by rewrite opeg3E  // negb_and !negbK eq_sym (negPf p1Dp2)
          => /andP[/eqP] .
  pose cs5 := [seq ↑[i]_p1 | i <- cs1] ++ cs4.
  have scs5Lscs : size cs5 < size cs.
    rewrite /cs5 csE cs2E !size_cat /= !size_cat /= !size_map.
    rewrite ltn_add2l // !addnS! ltnS -addSn leq_addl //.
  have c1Mcs5 : path rmove c1 cs5.
    rewrite cat_path -[c1](cunliftrK) !path_liftr //=.
    rewrite c1'Pcs1.
    by rewrite last_map lc1'cs1Epp3 -/p1 -p5Ep3 -p4Ep1.
  have lc1cs5E : last c1 cs5 = `c[p].
    rewrite last_cat -[c1](cunliftrK) last_map lc1'cs1Epp3.
    rewrite -lc1csEp csE cs2E last_cat /= last_cat /= -/p1.
    by rewrite p5Ep3 p4Ep1.
  apply: leq_trans (_ : size cs5 < _); last first.
    by rewrite cs2E /= !size_cat !size_map /=
               ltn_add2l // ltnS -addSnnS leq_addl.
  rewrite ltnS.
  have /IHm : size cs5 < m.
    rewrite -ltnS.
    by apply: leq_ltn_trans Scs.
  move=> /(_ c1 p c1Mcs5 lc1cs5E) /=.
  by rewrite -/p1 (negPf p1Dp) => ->.
(* now we just need to use the induction principle on the two subpath        *)
have [cs4' [pp5p4Pcs4' lpp5p4cs4'Elpp5p4cs4 scs4'L]] :=
  pathS_restrict HHr pp5p4Pcs4.
rewrite cliftrK in lpp5p4cs4'Elpp5p4cs4 pp5p4Pcs4'.
have Scs3 : size cs3 < m.+1.
  apply: ltn_trans Scs2.
  by rewrite cs2E size_cat /= size_map addnS ltnS leq_addr.
have Scs4 : size cs4 < m.+1.
  apply: ltn_trans Scs2.
  by rewrite cs2E size_cat /= size_map addnS ltnS leq_addl.
have Scs4' : size cs4' < m.+1.
  by apply: leq_ltn_trans Scs4; rewrite scs4'L.
rewrite cs2E /= size_cat /= !size_map.
have /IH := c2'cs5Epp5 => /(_ Scs3 c2'Pcs3) IHc1.
have c2'E : c2' = `c[p3] by rewrite [LHS]cliftrK.
rewrite c2'E size_rpegE rpeg_ppeg // in IHc1; last by rewrite eq_sym.
rewrite size_ppeg in IHc1.
have p6Dp : p5 != p.
  by apply: contra p5Dp3 => /eqP->; apply/eqP.
move: lc1csEp; rewrite csE cs2E.
rewrite last_cat /= last_cat /= => lpp5p4cs4Epp.
have lpp5cs4'Epp : last `c[p5] cs4' = `c[p].
  by rewrite lpp5p4cs4'Elpp5p4cs4 lpp5p4cs4Epp perfect_unliftr.
have /IH : last `c[p5] cs4' = `c[p] =>  [//| /(_ Scs4' pp5p4Pcs4') IHc2].
rewrite size_rpegE rpeg_ppeg // size_ppeg in IHc2.
rewrite -[2 ^ n]prednK ?expn_gt0 //.
rewrite !addnS !ltnS.
apply: leq_trans (leq_addl _ _).
apply: leq_add.
  by apply: leq_trans (size_rpeg_up _ _) _; rewrite IHc1.
apply: leq_trans scs4'L.
by rewrite IHc2.
Qed.

Lemma gdist_size_rpeg n (c1 : _ _ n) p :  `d[c1, `c[p]]_rmove = size_rpeg c1 p.
Proof.
apply/eqP; rewrite eqn_leq [size_rpeg _ _]size_rpegE.
rewrite gdist_path_le; last 2 first.
- by apply: path_rpeg.
- by rewrite last_rpeg.
have /gpath_connect [p1 p1H] : connect rmove c1 `c[p].
  by apply: move_connect_rpeg.
rewrite -size_rpegE (gpath_dist p1H) /=.
apply: (rpeg_min (gpath_path p1H)) => //.
by apply: gpath_last p1H.
Qed.

Lemma gdist_perfect_le n (c : configuration 3 n) p :
   `d[c, `c[p]]_rmove <= (2^ n).-1.
Proof. by rewrite gdist_size_rpeg; apply: size_rpeg_up. Qed.

(******************************************************************************)
(* Function that builds a path from a peg to a configuration                  *)
(******************************************************************************)

Definition lpeg n p (c : _ _ n) := rev (belast c (rpeg c p)).

Lemma lpeg_perfect n p : lpeg p `c[p, n]  = [::].
Proof. by rewrite /lpeg rpeg_perfect. Qed.

Lemma lpeg_nil_inv n c p :
  lpeg p c = [::] -> c = `c[p] :> configuration _ n.
Proof.
have := @rpeg_nil_inv _ c p.
rewrite /lpeg; case: rpeg => //= a l.
by rewrite rev_cons; case: rev.
Qed.

Lemma path_lpeg n (c : configuration 3 n) p (cs := lpeg p c) :
  path rmove `c[p] cs.
Proof.
have HHs := @rsym 3.
rewrite {}/cs /lpeg -(last_rpeg c) path_move_rev //.
by apply: path_rpeg.
Qed.

Lemma last_lpeg n (c : configuration 3 n) p (cs := lpeg p c) :
  last `c[p] cs = c.
Proof.
have HHs := @rsym 3; have := last_rpeg c p.
rewrite {}/cs /lpeg; case: rpeg => //= c1 cs.
by rewrite rev_cons last_rcons.
Qed.

Lemma size_lpegE n (c : _ _ n) p :
  size_rpeg c p = size (lpeg p c).
Proof. by rewrite size_rev size_belast size_rpegE. Qed.

Lemma lpeg_min n (c : configuration 3 n) p cs :
  path rmove `c[p] cs -> last `c[p] cs = c ->
  size_rpeg c p <= size cs ?= iff (cs == lpeg p c).
Proof.
(* why this is so complicated???? *)
move=> pPcs lccsEc.
have HHs := @rsym 3.
have cPr : path rmove c (rev (belast `c[p] cs)).
  by rewrite -{1}lccsEc path_move_rev.
have lcrEp : last c (rev (belast `c[p] cs)) = `c[p].
  rewrite -lccsEc; case: (cs)=> //= c3 cs1.
  by rewrite rev_cons last_rcons.
have := rpeg_min cPr lcrEp.
rewrite /lpeg size_rev size_belast.
set u := rev _ ; set v := rpeg _ _.
have -> : (u == v) = (rev (c :: u) == rev (c :: v)).
  rewrite !rev_cons eqseq_rcons eqxx andbT.
  apply/eqP/eqP=> [->//|].
  by rewrite -{2}[u]revK => ->; rewrite revK.
rewrite [c :: v]lastI -/v rev_rcons.
rewrite rev_cons revK -{2}lccsEc -lastI eqseq_cons andbC.
case: eqP=> //; case: eqP => // pDl Hcs; case: pDl.
by rewrite last_rpeg.
Qed.

Fixpoint rhanoi3 {n : nat} :=
  if n is n1.+1 return configuration 3 n -> configuration 3 n -> _
  _  then
      fun c1 c2 =>
       let p1 := c1 ldisk in
       let p2 := c2 ldisk in
       let c1' := ↓[c1] in
       let c2' := ↓[c2] in
       if p1 == p2 then [seq ↑[i]_p1 | i <- rhanoi3 c1' c2'] else
       let p := `p[p1, p2] in
       (* one jump *)
       let m1 := size_rpeg c1' p + size_rpeg c2' p in
       (* two jumps *)
       let m2 := size_rpeg c1' p2 + 2 ^ n1 + size_rpeg c2' p1
       in if m1 <= m2 then
            [seq ↑[i]_p1 | i <- rpeg c1' p] ++
            [seq ↑[i]_p2 | i <- `c[p] :: lpeg p c2']
          else
            [seq ↑[i]_p1 | i <- rpeg c1' p2] ++
            [seq ↑[i]_p | i <- `c[p2] :: ppeg p2 p1] ++
            [seq ↑[i]_p2 | i <- `c[p1] :: lpeg p1 c2']
  else fun _ _ => [::].

Lemma last_rhanoi3 n (c1 c2 : _ _ n) (cs := rhanoi3 c1 c2) :
  last c1 cs = c2.
Proof.
have HHr := @rirr 3.
rewrite {}/cs.
elim: n c1 c2 => /= [c1 c2 |n IH c1 c2]; first by apply/ffunP=> [] [].
set p1 := _ ldisk; set p2 := _ ldisk.
set c3 := cliftr _ _; set c4 := cliftr _ _; set c5 := cliftr _ _.
set p := `p[_, _].
case: eqP => [p1Ep2|/eqP p1Dp2].
  by rewrite -{1}[c1]cunliftrK last_map IH [c1 _]p1Ep2 cunliftrK.
case: leqP => _; first by rewrite last_cat /= last_map last_lpeg cunliftrK.
by rewrite last_cat /= last_cat /= last_map last_lpeg cunliftrK.
Qed.

Lemma path_rhanoi3 n (c1 c2 : _ _ n) (cs := rhanoi3 c1 c2) :
  path rmove c1 cs.
Proof.
have HHr := @rirr 3.
rewrite {}/cs.
elim: n c1 c2 => //= n IH c1 c2.
set p1 := _ ldisk; set p2 := _ ldisk.
set c3 := cliftr _ _; set c4 := cliftr _ _; set c5 := cliftr _ _.
set p := `p[_, _].
case: eqP => [p1Ep2|/eqP p1Dp2].
  by rewrite -{1}[c1]cunliftrK path_liftr.
case: leqP => _; rewrite !cat_path /=; apply/and3P; split.
- by rewrite -{1}[c1]cunliftrK path_liftr // path_rpeg.
- rewrite -{1}[c1]cunliftrK last_map last_rpeg.
  apply/moveP; exists ldisk.
  split => // [|d dmDd||].
  - by rewrite !cliftr_ldisk.
  - rewrite !ffunE; case: tsplitP => [j|j jE]; first by rewrite !ffunE.
    by case/eqP: dmDd; apply/val_eqP; rewrite /= jE; case: (j) => [] [].
  - apply/on_topP=> d; rewrite !cliftr_ldisk !ffunE.
    case: tsplitP => [j _ /eqP|j jE].
      by rewrite !ffunE -/p1 eq_sym (negPf (opegDl _ _)).
    by rewrite /= !ffunE jE /= leq_addl.
  apply/on_topP=> d; rewrite /= !cliftr_ldisk !ffunE.
  case: tsplitP => [j _ /eqP|j ->]; last by case: j => [] [].
  by rewrite !ffunE eq_sym (negPf (opegDr _ _)).
- by rewrite -[c3]cunliftrK !cliftr_ldisk /= path_liftr // cliftrK path_lpeg.
- by rewrite -{1}[c1]cunliftrK path_liftr // path_rpeg.
- rewrite -{1}[c1]cunliftrK last_map last_rpeg.
  apply/moveP; exists ldisk; split => // [|d2||];
         rewrite ?cliftr_ldisk ?ffunE //=.
  - by rewrite /rrel /= eq_sym opegDl.
  - case: tsplitP => //= j d2E /eqP[].
    by apply/val_eqP; rewrite /= d2E; case: (j) => [] [].
  - apply/on_topP=> d2.
    rewrite cliftr_ldisk /= !ffunE.
    case: tsplitP => [k _ /eqP | [[]] // j -> //].
    by rewrite ?ffunE (negPf p1Dp2).
  apply/on_topP=> d2.
  rewrite cliftr_ldisk /= !ffunE.
  case: tsplitP => [k _ /eqP | [[]] // j -> //].
  by rewrite !ffunE (negPf (opegDr _ _)).
rewrite cat_path /=; apply/and3P; split => //.
- rewrite -[c4]cunliftrK cliftr_ldisk -/p path_liftr // cliftrK // path_ppeg //.
  by rewrite eq_sym.
- rewrite -[c4]cunliftrK cliftr_ldisk -/p last_map cliftrK // last_ppeg //.
  apply/moveP; exists ldisk; split => // [|d2||];
         rewrite ?cliftr_ldisk ?ffunE /=.
  - by rewrite /rrel /= opegDr.
  - case: tsplitP => [j | j d2E /eqP[]] //=.
    by apply/val_eqP => /=; rewrite d2E; case: (j) => [] [].
  - apply/on_topP=> d2.
    rewrite cliftr_ldisk /= !ffunE.
    case: tsplitP => [k _ /eqP | [[]] // j -> //].
    by rewrite !ffunE (negPf (opegDl _ _)).
  apply/on_topP=> d2.
  rewrite cliftr_ldisk /= !ffunE.
  case: tsplitP => [k _ /eqP | [[]] // j -> //].
  by rewrite !ffunE eq_sym (negPf p1Dp2).
by rewrite path_liftr // path_lpeg.
Qed.

Lemma rhanoi3_min n (c1 c2 : configuration 3 n) cs :
  path rmove c1 cs -> last c1 cs = c2 ->
  size (rhanoi3 c1 c2) <= size cs.
Proof.
have HHr := @rirr 3.
have HHs := @rsym 3.
elim: n c1 c2 cs => [p c1 [|]//|n IH c1 c2 cs /=].
set p := `p[_, _]; set p1 := _ ldisk; set p2 := _ ldisk.
case: eqP => [p1Ep2 c1Pcs lc1csEc2|/eqP p1Dp2 c1Pcs lc1csEc2].
  have lcsmEc1m : last c1 cs ldisk = p1 by rewrite lc1csEc2.
  have [cs1 [c1Pcs1 lc1csElcs1 /leq_of_leqif/(leq_trans _)->//]] :=
      pathS_restrict (@rirr 3) c1Pcs.
  by rewrite size_map IH // lc1csElcs1 lc1csEc2.
set u := _ + _; set v := _ + _.
suff : minn u v < size cs.
  rewrite minnC /minn; case: (leqP u) => H1;
      rewrite !size_cat /= ?size_cat /= !addnS ?ltnS
              !size_map -size_rpegE -size_lpegE -/u => Lscs.
    by apply: leq_trans Lscs.
  apply: leq_ltn_trans _ Lscs.
  rewrite -addnS -addSn !addnA !leq_add //.
  by rewrite -[2 ^ _]prednK ?expn_gt0 // ltnS size_ppeg.
pose f (c : configuration 3 n.+1) := c ldisk.
have [m Lcs] := ubnP (size cs); elim: m => // m IH1 in cs Lcs c1Pcs lc1csEc2 *.
case: path3SP c1Pcs => // [c1' cs' /= csE c1'Pcs' _|
                           cs1 cs2 p1' p3 p4 c1' c3 p1Dp3 p1Rp3 lc1'cs1Epp4 csE
                          c1'Pcs1 c3Pcs2 _].
  case/eqP: p1Dp2.
  have := congr1 f lc1csEc2.
  rewrite /f  csE -{1}[c1](cunliftrK) last_map.
  by rewrite !cliftr_ldisk.
have p1'Ep1 : p1' = p1 by [].
move: Lcs; rewrite csE size_cat size_map /= addnS ltnS => Lcs.
move: lc1csEc2; rewrite csE last_cat /= => lc3cs2Ec2.
have [/eqP p3Ep2 | p3Dp2] := boolP (p3 == p2).
  have p4Ep : p4 = p.
    apply/eqP; rewrite opeg3E // eq_sym opeg3E // negb_and !negbK eqxx /=.
    by rewrite eq_sym opeg3E // p1Dp3 eq_sym p3Ep2 eqxx.
  have [cs2' [pp4Pcs2' pp4cs2'E scs2'Lscs2]]:= pathS_restrict HHr c3Pcs2.
  rewrite cliftrK in pp4Pcs2' pp4cs2'E.
  apply: leq_trans (leq_add (leqnn _) scs2'Lscs2).
  apply: leq_trans (geq_minl _ _) _.
  apply: leq_add.
    apply: leq_of_leqif (rpeg_min _ _ ) => //.
      by rewrite lc1'cs1Epp4; congr `c[`p[_, _]].
  apply: leq_of_leqif (lpeg_min _ _ ); rewrite -p4Ep //.
  by rewrite pp4cs2'E lc3cs2Ec2.
have p3Ep : p3 = p.
  by apply/eqP; rewrite eq_sym opeg3E // -/p1 -p1'Ep1 p1Dp3 eq_sym.
have p4Ep2 : p4 = p2.
  apply/eqP.
  rewrite /p4 p3Ep /p -/p1 -/p2 p1'Ep1 !opeg3E //.
    by rewrite p1Dp2 negbK eqxx.
  by rewrite eq_sym opeg3E // eqxx eq_sym.
case: path3SP c3Pcs2=> // [c3' cs2' p5 cs2E c3'Pcs2' _|
                          cs3 cs4 p5 p6 p7 c3' c4 p5Dp6 p5p6
                          c3'cs3Epp7 cs2E c3'Pcs3 c4Pcs4 _].
  have  := congr1 f lc3cs2Ec2.
  rewrite cs2E /f -[c3]cunliftrK last_map !cliftr_ldisk -/p2 /=
        => p3Ep2.
  by case/eqP: p3Dp2.
have p5Ep: p5 = p by rewrite /p5 /c3 !cliftr_ldisk.
move: lc3cs2Ec2 Lcs; rewrite cs2E last_cat /= size_cat /= size_map =>
           lc6cs4Ec2 Lcs.
rewrite -addSnnS ltnS.
have [/eqP p6Ep1|p6Dp1] := boolP (p6 == p1).
  have p7Ep2 : p7 = p2.
    apply/eqP.
    by rewrite opeg3E // p5Ep p6Ep1 opeg3E // p1Dp2 eqxx.
  apply: leq_trans (_ : size (map (cliftr p1) cs1 ++ cs4) <= _).
    apply/ltnW/IH1.
    - by rewrite size_cat !size_map (leq_trans _ Lcs) // ltnS;
         rewrite leq_add2l -addSnnS leq_addl.
    - rewrite cat_path -{1}[c1]cunliftrK path_liftr //=.
      rewrite c1'Pcs1.
      by rewrite -{1}[c1]cunliftrK last_map lc1'cs1Epp4
                 -/p1 -p6Ep1 p4Ep2 -p7Ep2.
    rewrite last_cat -{1}[c1]cunliftrK last_map.
    by rewrite lc1'cs1Epp4 -/p1 -p6Ep1 p4Ep2 -p7Ep2.
  by rewrite size_cat size_map leq_add2l leq_addl.
have p6Ep2 : p6 = p2.
  case: (p6 =P p2) => // /eqP p6Dp2.
  case/negP:  p5Dp6.
  by rewrite p5Ep opeg3E // eq_sym p6Dp1 eq_sym.
have p7Ep1 : p7 = p1.
  apply/eqP.
  by rewrite opeg3E // p5Ep opeg3E // eqxx.
apply: leq_trans (geq_minr _ _) _.
rewrite -[v]addnA leq_add //.
  apply: leq_of_leqif (rpeg_min _ _ ) => //.
  by rewrite lc1'cs1Epp4 p4Ep2.
apply: leq_add.
  rewrite -[2 ^ _]prednK ?expn_gt0 // ltnS.
  have <-: size_rpeg (↓[c3]) p1 = (2 ^ n).-1.
    by rewrite cliftrK size_rpegE rpeg_ppeg ?opegDl // size_ppeg.
  apply: leq_of_leqif (rpeg_min _ _) => //.
  by rewrite c3'cs3Epp7 p7Ep1.
have [cs4' [c4'Pcs4' lc4'cs4'Elc4cs4 /leq_of_leqif Lcs4']] :=
      pathS_restrict HHr c4Pcs4.
rewrite cliftrK p7Ep1 in c4'Pcs4'.
rewrite cliftrK p7Ep1 in lc4'cs4'Elc4cs4.
apply: leq_trans Lcs4'.
apply: leq_of_leqif (lpeg_min _ _) => //.
by rewrite lc4'cs4'Elc4cs4 lc6cs4Ec2.
Qed.

Fixpoint size_rhanoi3 {n : nat} : _ _ n -> _ _ n ->  nat :=
  if n is n1.+1 then
      fun c1 c2 : configuration 3 n1.+1 =>
       let p1 := c1 ldisk in
       let p2 := c2 ldisk in
       let c1' := ↓[c1] in
       let c2' := ↓[c2] in
       if p1 == p2 then size_rhanoi3 c1' c2' else
       (* one jump *)
       let p := `p[p1, p2] in
       let m1 := size_rpeg c1' p + size_rpeg c2' p in
       (* two jumps *)
       let m2 := size_rpeg c1' p2 + 2 ^ n1 + size_rpeg c2' p1
       in (minn m1 m2).+1
  else fun _ _ => 0.

(* size computes the size *)
Lemma size_rhanoi3E n (c1 c2 : _ _ n) : size_rhanoi3 c1 c2 = size (rhanoi3 c1 c2).
Proof.
elim: n c1 c2 => //= n IH c1 c2.
case: eqP => [E|/eqP NE].
  by rewrite size_map; apply: IH.
set p := `p[_, _].
set x := size_rpeg _ _; set y := size_rpeg _ _.
set z := size_rpeg _ _; set t := size_rpeg _ _.
rewrite fun_if.
rewrite size_cat /= size_cat /= size_cat /= !size_map.
rewrite -!(size_rpegE, size_lpegE) /=.
rewrite -/x -/y -/z -/t.
rewrite size_ppeg -[_ + t.+1]addSnnS prednK ?expn_gt0 //.
rewrite !addnS.
rewrite /minn !addnA.
case: leqP => LL1; case: leqP => LL2 //.
  by congr (_.+1); apply/eqP; rewrite eqn_leq LL1.
by congr (_.+1); apply/eqP; rewrite eqn_leq ltnW // ltnW.
Qed.

Lemma gdist_rhanoi3 n (c1 c2 : _ _ n) : `d[c1, c2]_rmove = size_rhanoi3 c1 c2.
Proof.
apply/eqP; rewrite eqn_leq.
rewrite [size_rhanoi3 _ _]size_rhanoi3E gdist_path_le //=; last 2 first.
- by apply: path_rhanoi3.
- by apply: last_rhanoi3.
have /gpath_connect [p1 p1H] : connect rmove c1 c2 by apply:  move_connect.
rewrite (gpath_dist p1H) rhanoi3_min //; first apply: gpath_path p1H.
by apply: gpath_last p1H.
Qed.

End Hanoi3.


Definition sum_5( a b c d e : nat ) := a + b + c + d + e.
Section sum_5'.
  Variable a b c d e : nat.
  Definition sum_5' := a + b + c + d + e.
End sum_5'.
Require Import ZArith.
Open Scope Z_scope.
Definition poly x := 2 * x * x + 3 * x + 3.
Section poly'.
  Variable x : Z.
  Definition poly' := 2 * x * x + 3 * x + 3.
End poly'.


Require Import
  Coq.Program.Wf
  Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.eqtype
  Ssreflect.ssrnat Ssreflect.seq MathComp.div
  FormalPS.stdlib_ext FormalPS.Core FormalPS.Template FormalPS.Bool.

Set Implicit Arguments.

Set Printing Width 51.

(*
instnat_spec:
  自然数の仕様。
*)
Definition instnat_spec (n : nat) (i1 : inst) : Prop :=
  forall i2 vs cs, (i2 :: vs, i1 :: cs) |=>* (instnseqc n i2 :: vs, cs).

(*
exists_instnat:
  自然数の仕様を満たす命令。
*)
Lemma exists_instnat : forall n, { i : inst | instnat_spec n i }.
Proof.
  elim => [| n [i H]]; eexists => i2 vs cs /=.
  - evalpartial' evalpop.
    evalpartial evalpush.
    evalauto.
  - evalpartial' evalcopy.
    evalpartial' H.
    apply evalsnoc.
Defined.

Notation instnat n := (proj1_sig (exists_instnat n)).
Notation eval_instnat n := (proj2_sig (exists_instnat n)).

Hint Resolve ((fun n => eval_instnat n) : forall n, instnat_spec n (instnat n)).

(*
inst_repeatn:
  繰り返しの命令。
*)
Lemma exists_inst_repeatn :
  { inst_repeatn : inst |
    forall n i1 i2 vs cs, instnat_spec n i2 ->
    (i1 :: vs, i2 :: inst_repeatn :: cs) |=>* (vs, nseq n i1 ++ cs) }.
Proof.
  eexists => n i1 i2 vs cs H.
  evalpartial H.
  evalpartial evalexec.
  apply evalnseqc.
Defined.

Notation inst_repeatn := (proj1_sig exists_inst_repeatn).
Notation eval_inst_repeatn := (proj2_sig exists_inst_repeatn).

(*
instnat_eqmap:
  任意の自然数 n, m と任意の命令 i について、i が自然数 n, m としての仕様を同時
  に満たしていれば、必ず n = m である。
  よって、n /= m であればある命令が自然数 n, m としての仕様を同時に満たすことは
*)
Lemma instnat_eqmap :
  forall n m i, instnat_spec n i -> instnat_spec m i -> n = m.
Proof.
  move => n m i1 H0 H1.
  rewrite -(size_nseq n instpop) -(size_nseq m instpop); f_equal.
  have: (([::], nseq n instpop) |=>* ([::], nseq m instpop) \/
    ([::], nseq m instpop) |=>* ([::], nseq n instpop))
    by apply (@eval_semi_uniqueness ([:: instpop], [:: i1; instexec]));
      rewrite -[nseq _ _]cats0; apply eval_inst_repeatn.
  by case: n m {H0 H1} => [| n]; case => [| m]; case => H //=;
    inversion H; try inversion H0.
Qed.

(*
inst_succn:
  後者関数。
*)
Lemma exists_inst_succn :
  { inst_succn : inst |
    forall n i1 vs cs, instnat_spec n i1 ->
    exists i2 : inst, instnat_spec n.+1 i2 /\
    (i1 :: vs, inst_succn :: cs) |=>* (i2 :: vs, cs) }.
Proof.
  eexists => n i1 vs cs H; eexists; split.
  - move => i2 vs' cs'.
    evalpartial' evalcopy.
    evalpartial' H.
    apply evalsnoc.
  - evaltemplate 1
      [:: insttpair insttcopy
        (insttpair (instthole 0) (insttpair insttswap insttcons))]
      (Nil instt).
    evalauto.
Defined.

Notation inst_succn := (proj1_sig exists_inst_succn).
Notation inst_succn_proof := (proj2_sig exists_inst_succn).

(*
inst_addn:
  加算命令。
*)
Lemma exists_inst_addn :
  { inst_addn : inst |
    forall n m i1 i2 vs cs, instnat_spec n i1 -> instnat_spec m i2 ->
    exists i3 : inst, instnat_spec (n + m) i3 /\
    (i2 :: i1 :: vs, inst_addn :: cs) |=>* (i3 :: vs, cs) }.
Proof.
  eexists => n m i1 i2 vs cs H H0.
  evalpartial' evalswap.
  evalpartial' evalpush.
  evalpartial' evalswap.
  evalpartial' evalexec.
  evalpartial (eval_inst_repeatn n).
  elim: n m i2 H0 {i1 H} => [ | n IH] m i1 H /=.
  - by evalauto.
  - edestruct (inst_succn_proof m i1) as [i2 [H1 H2]]; auto.
    evalpartial H2.
    by rewrite addSnnS; apply IH.
Defined.

Notation inst_addn := (proj1_sig exists_inst_addn).
Notation inst_addn_proof := (proj2_sig exists_inst_addn).

(*
inst_muln:
  乗算命令。
*)

Lemma exists_inst_muln_tail :
  { inst_muln_tail : inst |
    forall n m i1 i2 vs cs, instnat_spec n i1 -> instnat_spec m i2 ->
    exists i3 : inst, instnat_spec (NatTrec.add_mul n m 0) i3 /\
    (i2 :: i1 :: vs, inst_muln_tail :: cs) |=>* (i3 :: vs, cs) }.
Proof.
  move: (0) (instnat 0) (eval_instnat 0) => o i1 H.
  eexists => n m i2 i3 vs cs H0 H1.
  do 2 evalpartial' evalpush.
  evaltemplate' 4
    [:: insttpair (insttpush (instthole 2)) (instthole 1); instthole 0]
    [:: instthole 3].
  evalpartial (eval_inst_repeatn n).
  elim: n o i1 i3 H H1 {i2 H0} => [ | n IH] o i1 i2 H H0 /=.
  - evalauto; apply H.
  - evalauto.
    evalpartial' evalswap.
    edestruct (@inst_addn_proof m o i2 i1) as [i3 [H1 H2]]; auto.
    evalpartial H2.
    rewrite NatTrec.addE.
    auto.
Defined.

Notation inst_muln := (proj1_sig exists_inst_muln_tail).
Notation inst_muln_proof_tail := (proj2_sig exists_inst_muln_tail).

Lemma inst_muln_proof :
  forall n m i1 i2 vs cs, instnat_spec n i1 -> instnat_spec m i2 ->
  exists i3 : inst, instnat_spec (n * m) i3 /\
  (i2 :: i1 :: vs, inst_muln :: cs) |=>* (i3 :: vs, cs).
Proof.
  move => n m.
  replace (n * m) with (NatTrec.add_mul n m 0) by ssromega.
  apply inst_muln_proof_tail.
Defined.

(*
inst_even:
  偶奇判定の命令。
*)
Lemma exists_inst_even_tail :
  { inst_even_tail : inst |
    forall (b : bool) n i1 i2 vs cs, instbool_spec b i1 -> instnat_spec n i2 ->
    exists i3 : inst, instbool_spec (if odd n then ~~ b else b) i3 /\
    (i2 :: i1 :: vs, inst_even_tail :: cs) |=>* (i3 :: vs, cs) }.
Proof.
  eexists => b n i1 i2 vs cs H H0.
  evalpartial' evalpush.
  evalpartial' evalswap.
  evalpartial' evalexec.
  evalpartial (eval_inst_repeatn n).
  elim: n b i1 H {i2 H0} => [ | n IH] b i1 H.
  - by evalauto.
  - edestruct (evalnot b i1) as [i2 [H0 H1]]; auto.
    evalpartial H1; clear i1 H H1.
    edestruct (IH (negb b) i2) as [i1 [H H1]]; auto.
    evalpartial H1; clear IH H0 H1.
    evalauto.
    move: H => //=.
    case: b; case: (odd n) => //=.
Defined.

Notation inst_even_tail := (proj1_sig exists_inst_even_tail).
Notation inst_even_proof_tail := (proj2_sig exists_inst_even_tail).

Lemma exists_inst_even :
  { inst_even : inst |
    forall n i1 vs cs, instnat_spec n i1 ->
    exists i2 : inst, instbool_spec (~~ odd n) i2 /\
    (i1 :: vs, inst_even :: cs) |=>* (i2 :: vs, cs) }.
Proof.
  eexists => n i1 vs cs H.
  evalpartial' evalpush.
  evalpartial' evalswap.
  edestruct (inst_even_proof_tail true n) as [i2 [H0 H1]]; eauto.
Defined.

Notation inst_even := (proj1_sig exists_inst_even).
Notation inst_even_proof := (proj2_sig exists_inst_even).

(*
inst_iszero:
  ゼロとの比較をする命令。
*)
Lemma exists_inst_iszero :
  { inst_iszero : inst |
    forall n i1 vs cs, instnat_spec n i1 ->
    exists i2 : inst,
    instbool_spec (n == 0) i2 /\
    (i1 :: vs, inst_iszero :: cs) |=>* (i2 :: vs, cs) }.
Proof.
  eexists => n i1 vs cs H.
  exists (instbool (n == 0)); split.
  - case (n == 0); auto.
  - evalpartial' (evalpush (instbool true)).
    evalpartial' evalswap.
    evalpartial' evalpush.
    evalpartial' evalswap.
    evalpartial' evalexec.
    evalpartial (eval_inst_repeatn n).
    case: n {i1 H} => //=; first evalauto.
    move => n.
    evalpartial' evalpop.
    evalpartial (evalpush (instbool false)).
    elim: n => [| n IHn] /=; evalauto.
    apply IHn.
Defined.

Notation inst_iszero := (proj1_sig exists_inst_iszero).
Notation inst_iszero_proof := (proj2_sig exists_inst_iszero).

(*
inst_predn:
  前者関数。ただし元の数が0である場合の結果は0である。
*)
Lemma exists_inst_predn_tail :
  { inst_predn_tail : inst |
    forall n m i1 i2 i3 vs cs,
    instnat_spec n i1 -> instnat_spec (n - 1) i2 -> instnat_spec m i3 ->
    exists i4 : inst, instnat_spec (n + m - 1) i4 /\
    (i3 :: i2 :: i1 :: vs, inst_predn_tail :: cs) |=>* (i4 :: vs, cs) }.
Proof.
  eexists => n m i1 i2 i3 vs cs H H0 H1.
  evalpartial' evalpush.
  evalpartial' evalswap.
  evalpartial evalpair.
  evalpartial' evalexec.
  evalpartial (eval_inst_repeatn m).
  elim: m n i1 i2 H H0 {i3 H1} => [ | m IH] n i1 i2 H H0 /=.
  - evalpartial' evalswap.
    evalpartial evalpop.
    evalauto.
    by rewrite addn0.
  - evalpartial' evalpop; clear i2 H0.
    evalpartial' evalcopy.
    edestruct (inst_succn_proof n i1) as [i2 [H0 H1]]; auto.
    evalpartial' H1; clear H1.
    evalpartial evalswap.
    replace (n + m.+1 - 1) with (n.+1 + m - 1) by ssromega.
    by apply IH; replace (n.+1 - 1) with n by ssromega.
Defined.

Notation inst_predn_tail := (proj1_sig exists_inst_predn_tail).
Notation inst_predn_proof_tail := (proj2_sig exists_inst_predn_tail).

Lemma exists_inst_predn :
  { inst_predn : inst |
    forall n i1 vs cs, instnat_spec n i1 ->
    exists i2 : inst, instnat_spec (n - 1) i2 /\
    (i1 :: vs, inst_predn :: cs) |=>* (i2 :: vs, cs) }.
Proof.
  eexists => n i1 vs cs H.
  do 2 (evalpartial' evalpush; evalpartial' evalswap).
  edestruct (inst_predn_proof_tail 0 n) as [i2 [H0 H1]]; eauto.
Defined.

Notation inst_predn := (proj1_sig exists_inst_predn).
Notation inst_predn_proof := (proj2_sig exists_inst_predn).

(*
inst_subn:
  減算命令。
*)
Lemma exists_inst_subn :
  { inst_subn : inst |
    forall n m i1 i2 vs cs, instnat_spec n i1 -> instnat_spec m i2 ->
    exists i3 : inst, instnat_spec (n - m) i3 /\
    (i2 :: i1 :: vs, inst_subn :: cs) |=>* (i3 :: vs, cs) }.
Proof.
  eexists => n m i1 i2 vs cs H H0.
  evalpartial' evalpush.
  evalpartial' evalswap.
  evalpartial' evalexec.
  evalpartial (eval_inst_repeatn m).
  elim: m n i1 H {i2 H0} => [ | m IH] n i1 H /=.
  - evalauto.
    by rewrite subn0.
  - edestruct (inst_predn_proof n i1) as [i2 [H1 H2]]; auto.
    evalpartial H2; clear H2.
    edestruct (IH (n - 1) i2) as [i3 [H2 H3]]; auto.
    evalpartial H3.
    evalauto.
    by rewrite (subnDA 1 n m).
Defined.

Notation inst_subn := (proj1_sig exists_inst_subn).
Notation inst_subn_proof := (proj2_sig exists_inst_subn).

(*
inst_leqn:
  大小比較。
*)
Lemma exists_inst_leqn :
  { inst_leqn : inst |
    forall n m i1 i2 vs cs, instnat_spec n i1 -> instnat_spec m i2 ->
    exists i3 : inst, instbool_spec (n <= m) i3 /\
    (i2 :: i1 :: vs, inst_leqn :: cs) |=>* (i3 :: vs, cs) }.
Proof.
  eexists => n m i1 i2 vs cs H H0.
  edestruct (inst_subn_proof n m i1 i2) as [i3 [H1 H2]]; auto.
  evalpartial' H2; clear i1 i2 H H0 H2.
  edestruct (inst_iszero_proof (n - m) i3) as [i1 [H H0]]; auto.
  evalpartial H0; clear i3 H0 H1.
  evalauto.
  by move: H; rewrite /leq; case: (n - m).
Defined.

Notation inst_leqn := (proj1_sig exists_inst_leqn).
Notation inst_leqn_proof := (proj2_sig exists_inst_leqn).

(*
inst_divmodn:
  割り算を行い、商と余りを計算する命令。
*)
Lemma exists_inst_divmodn_part :
  { inst_divmodn_part : inst |
    forall n m q i1 i2 i3 i4 vs cs,
    instnat_spec n i1 -> instnat_spec m.+1 i2 -> instnat_spec q i3 ->
    exists i1' : inst, instnat_spec (n - m.+1) i1' /\
    exists i3' : inst, instnat_spec q.+1 i3' /\
    (i4 :: i3 :: i2 :: i1 :: vs, inst_divmodn_part :: cs) |=>*
    (if m < n
      then (i4 :: i3' :: i2 :: i1' :: vs, i4 :: cs)
      else (i1 :: i3 :: vs, cs))
  }.
Proof.
  eexists => n m q i1 i2 i3 i4 vs cs H H0 H1.
  evaltemplate' 4
    [:: instthole 3; instthole 2;
        instthole 0; instthole 1; instthole 2; instthole 3 ]
    (Nil instt).
  edestruct (inst_leqn_proof m.+1 n i2 i1) as [i5 [H2 H3]]; auto.
  evalpartial' H3; clear H3.
  do 2 evalpartial' evalpush.
  evalpartial (evalexecif (m.+1 <= n) i5).
  clear i5 H2.
  case: (m < n).
  - evaltemplate' 4
      [:: instthole 2; instthole 3; instthole 0; instthole 1; instthole 2 ]
      (Nil instt).
    edestruct (inst_subn_proof n m.+1 i1 i2) as [i1' [H2 H3]]; auto.
    evalpartial' H3; clear i1 H H0 H3.
    evaltemplate' 4
      [:: instthole 2; instthole 1; instthole 3; instthole 0 ]
      (Nil instt).
    edestruct (inst_succn_proof q i3) as [i3' [H3 H4]]; auto.
    evalpartial' H4.
    clear i3 H1 H4.
    evalpartial' evalswap.
    evalpartial' evalcopy.
    evalpartial evalexec.
    by evalauto.
  - evalpartial' evalpop.
    evalpartial' evalswap.
    evalpartial' evalpop.
    evalpartial evalswap.
    evalauto; eauto.
Defined.

Lemma exists_inst_divmodn_tail :
  { inst_divmodn : inst |
    forall n m q i1 i2 i3 vs cs,
    instnat_spec n i1 -> instnat_spec m.+1 i2 -> instnat_spec q i3 ->
    exists i4 : inst, instnat_spec (q + n %/ m.+1) i4 /\
    exists i5 : inst, instnat_spec (n %% m.+1) i5 /\
    (i3 :: i2 :: i1 :: vs, inst_divmodn :: cs) |=>* (i5 :: i4 :: vs, cs) }.
Proof.
  eexists => n m q i1 i2 i3 vs cs H H0 H1.
  evalpartial' evalpush.
  evalpartial' evalcopy.
  evalpartial evalexec.
  move: n i1 H q i3 H1.
  refine (well_founded_ind well_founded_lt _ _).
  move => n IHn i1 H q i3 H1.
  edestruct (proj2_sig exists_inst_divmodn_part n m q i1 i2 i3)
    as [i4 [H2 [i5 [H3 H4]]]]; auto.
  evalpartial H4.
  clear H4.
  case: ifP => H4.
  - clear i1 i3 H H0 H1.
    have H5: (n > n - m.+1) by ssromega.
    edestruct (IHn (n - m.+1) H5 i4 H2 q.+1 i5 H3) as [i6 [H6 [i7 [H7 H8]]]].
    evalpartial H8.
    clear i2 i4 i5 H2 H3 H8 IHn.
    replace n with (1 * m.+1 + (n - m.+1)) by ssromega.
    evalauto.
    - by rewrite divnMDl // add1n -addSnnS.
    - by rewrite modnMDl.
  - clear i2 i4 i5 H0 H2 H3 IHn.
    evalauto.
    - rewrite leqNgt in H4.
      by rewrite (divn_small (negbFE H4)) addn0.
    - rewrite modn_small //; ssromega.
Defined.

Lemma exists_inst_divmodn :
  { inst_divmodn : inst |
    forall n m i1 i2 vs cs,
    instnat_spec n i1 -> instnat_spec m.+1 i2 ->
    exists i3 : inst, instnat_spec (n %/ m.+1) i3 /\
    exists i4 : inst, instnat_spec (n %% m.+1) i4 /\
    (i2 :: i1 :: vs, inst_divmodn :: cs) |=>* (i4 :: i3 :: vs, cs) }.
Proof.
  eexists => n m i1 i2 vs cs H H0.
  evalpartial' evalpush.
  edestruct (proj2_sig exists_inst_divmodn_tail n m 0 i1 i2)
    as [i3 [H1 [i4 [H2 H3]]]]; auto.
  evalpartial H3.
  by evalauto.
Defined.

Notation inst_divmodn := (proj1_sig exists_inst_divmodn).
Notation inst_divmodn_proof := (proj2_sig exists_inst_divmodn).

(*
inst_gcdn:
  ユークリッドの互除法によって最大公約数を計算する。
*)
Lemma exists_inst_gcdn_iter :
  { inst_gcdn_iter : inst |
    forall n m i1 i2 i3 vs cs,
    instnat_spec n i1 -> instnat_spec m i2 ->
    exists i4 : inst, instnat_spec (n %% m) i4 /\
    (i3 :: i2 :: i1 :: vs, inst_gcdn_iter :: cs) |=>*
    (if m == 0 then (i1 :: vs, cs) else (i3 :: i4 :: i2 :: vs, i3 :: cs)) }.
Proof.
  eexists => n m i1 i2 i3 vs cs H H0.
  evalpartial' evalswap.
  evalpartial' evalcopy.
  edestruct (inst_iszero_proof m i2) as [i4 [H1 H2]]; auto.
  evalpartial' H2; clear H2.
  do 2 evalpartial' evalpush.
  evalpartial (evalexecif (m == 0) i4).
  move: m i2 i4 H0 H1.
  case => /= [ | m] i2 _ H0 _.
  - evalpartial' evalpop.
    evalpartial evalpop.
    by evalauto.
  - evaltemplate' 3
      [:: instthole 0; instthole 2; instthole 0; instthole 1]
      (Nil instt).
    edestruct (inst_divmodn_proof n m i1 i2) as [i4 [H1 [i5 [H2 H3]]]]; auto.
    evalpartial' H3; clear H3.
    evaltemplate 4 [:: instthole 3; instthole 0; instthole 2] [:: instthole 3].
    by evalauto.
Defined.

Lemma exists_inst_gcdn :
  { inst_gcdn : inst |
    forall n m i1 i2 vs cs,
    instnat_spec n i1 -> instnat_spec m i2 ->
    exists i3 : inst, instnat_spec (gcdn n m) i3 /\
    (i2 :: i1 :: vs, inst_gcdn :: cs) |=>* (i3 :: vs, cs) }.
Proof.
  eexists => n m i1 i2 vs cs H H0.
  evalpartial' evalpush.
  evalpartial' evalcopy.
  evalpartial evalexec.
  move: i1 i2 vs cs H H0.
  set m' := m.
  rewrite -/(n, m).1 -/(n, m').2.
  subst m'.
  move: (n, m); clear.
  refine (well_founded_ind (measure_wf well_founded_lt
    (fun p => (if p.1 <= p.2 then 1 else 0) + p.1 + p.2)) _ _).
  rewrite /MR; case => n m /= IH i1 i2 vs cs H H0.
  edestruct (proj2_sig exists_inst_gcdn_iter n m i1 i2) as [i3 [H1 H2]]; auto.
  evalpartial H2; clear H2.
  move: m IH H0 H1.
  rewrite (lock exists_inst_gcdn_iter); case => /=.
  - move => IH H0 H1.
    evalauto.
    by rewrite gcdn0.
  - move => m IH H0 H1.
    edestruct (IH (m.+1, n %% m.+1)) as [i4 [H2 H3]] => /=; try eassumption.
    - clear; case: ifP.
      - move: (ltn_pmod n (ltn0Sn m)) => H H0.
        ssromega.
      - case: ifP => H _.
        - rewrite add0n -addnA add1n -addSn -addnS (addnC n) leq_add2l.
          apply leq_mod.
        - rewrite leqNgt in H.
          move: (negbFE H) => H0.
          have H1: n = 1 * m.+1 + (n - m.+1) by ssromega.
          rewrite !add0n (addnC n) ltn_add2l {1}H1 modnMDl.
          apply (leq_ltn_trans (leq_mod (n - m.+1) m.+1)).
          ssromega.
    - evalpartial H3.
      evalauto.
      move: H2 => /=.
      by rewrite gcdn_modr gcdnC.
Defined.

Notation inst_gcdn := (proj1_sig exists_inst_gcdn).
Notation inst_gcdn_proof := (proj2_sig exists_inst_gcdn).