Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e510m290x2e496m1_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__betweennotequal.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export lemma__lessthancongruence.
Require Export lemma__lessthancongruence2.
Require Export logic.
Definition lemma__TGflip : forall A B C a b c, (euclidean__defs.TG A a B b C c) -> ((euclidean__defs.TG a A B b C c) /\ (euclidean__defs.TG A a B b c C)).
Proof.
intro A.
intro B.
intro C.
intro a.
intro b.
intro c.
intro H.
assert (exists H0, (euclidean__axioms.BetS A a H0) /\ ((euclidean__axioms.Cong a H0 B b) /\ (euclidean__defs.Lt C c A H0))) as H0 by exact H.
destruct H0 as [H1 H2].
destruct H2 as [H3 H4].
destruct H4 as [H5 H6].
assert (* Cut *) (euclidean__axioms.neq A a) as H7.
- assert (* Cut *) ((euclidean__axioms.neq a H1) /\ ((euclidean__axioms.neq A a) /\ (euclidean__axioms.neq A H1))) as H7.
-- apply (@lemma__betweennotequal.lemma__betweennotequal A a H1 H3).
-- destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
exact H10.
- assert (* Cut *) (euclidean__axioms.neq a A) as H8.
-- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A a H7).
-- assert (* Cut *) (euclidean__axioms.neq a H1) as H9.
--- assert (* Cut *) ((euclidean__axioms.neq a H1) /\ ((euclidean__axioms.neq A a) /\ (euclidean__axioms.neq A H1))) as H9.
---- apply (@lemma__betweennotequal.lemma__betweennotequal A a H1 H3).
---- destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
exact H10.
--- assert (* Cut *) (euclidean__axioms.neq B b) as H10.
---- apply (@euclidean__axioms.axiom__nocollapse a H1 B b H9 H5).
---- assert (* Cut *) (exists h, (euclidean__axioms.BetS a A h) /\ (euclidean__axioms.Cong A h B b)) as H11.
----- apply (@lemma__extension.lemma__extension a A B b H8 H10).
----- destruct H11 as [h H12].
destruct H12 as [H13 H14].
assert (* Cut *) (euclidean__axioms.Cong A a a A) as H15.
------ apply (@euclidean__axioms.cn__equalityreverse A a).
------ assert (* Cut *) (euclidean__axioms.Cong B b A h) as H16.
------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B A h b H14).
------- assert (* Cut *) (euclidean__axioms.Cong a H1 A h) as H17.
-------- apply (@lemma__congruencetransitive.lemma__congruencetransitive a H1 B b A h H5 H16).
-------- assert (* Cut *) (euclidean__axioms.Cong A H1 a h) as H18.
--------- apply (@euclidean__axioms.cn__sumofparts A a H1 a A h H15 H17 H3 H13).
--------- assert (* Cut *) (euclidean__defs.Lt C c a h) as H19.
---------- apply (@lemma__lessthancongruence.lemma__lessthancongruence C c A H1 a h H6 H18).
---------- assert (* Cut *) (euclidean__defs.TG a A B b C c) as H20.
----------- exists h.
split.
------------ exact H13.
------------ split.
------------- exact H14.
------------- exact H19.
----------- assert (* Cut *) (euclidean__axioms.Cong C c c C) as H21.
------------ apply (@euclidean__axioms.cn__equalityreverse C c).
------------ assert (* Cut *) (euclidean__defs.Lt c C A H1) as H22.
------------- apply (@lemma__lessthancongruence2.lemma__lessthancongruence2 C c A H1 c C H6 H21).
------------- assert (* Cut *) (euclidean__defs.TG A a B b c C) as H23.
-------------- exists H1.
split.
--------------- exact H3.
--------------- split.
---------------- exact H5.
---------------- exact H22.
-------------- assert (euclidean__defs.Lt C c a h) as H24 by exact H19.
split.
--------------- exact H20.
--------------- exact H23.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e382m105_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


(*  Définition de l'éliminateur dépendant en coq [elimin_term] du HIIT suivant :

constructors
  Con  : U;
  Ty   : Con → U;
  nil  : Con;
  cons : (Γ : Con) → Ty Γ → Con;
  u    : (Γ : Con) → Ty Γ;
  π    : (Γ : Con)(A : Ty Γ) → Ty (cons Γ A) → Ty Γ;
 *)
(* Pour dependent destruction *)
Require Import Coq.Program.Equality.

Require Import DepInd.lib.

Set Implicit Arguments.

(* Syntaxe non typée *)

Inductive Con :=
  nil
| cons : Con -> Ty -> Con
with Ty :=
       unitt : Ty
     | prod : Ty -> Ty -> Ty .

Inductive Conᵂ : Con -> Type :=
  nilᵂ : Conᵂ nil
| consᵂ Γ (A : Ty) : Conᵂ Γ -> Tyᵂ Γ A ->
                     Conᵂ (cons Γ A)
with Tyᵂ : Con -> Ty -> Type :=
       unittᵂ Γ : Conᵂ Γ -> Tyᵂ Γ unitt
     | prodᵂ Γ A B : Tyᵂ Γ A -> Tyᵂ (cons Γ A) B ->
                     Tyᵂ Γ (prod A B)
                         .

Lemma Conᵂ_hp Γ (Γᵂ : Conᵂ Γ) : is_center Γᵂ
with Tyᵂ_hp Γ A (Aᵂ : Tyᵂ Γ A) : is_center Aᵂ.
  - destruct Γᵂ.
    + intro nil'.
      now  dependent destruction nil'.
    + rename t into Aᵂ.
      assert (IΓ := Conᵂ_hp _ Γᵂ).
      assert (IA := Tyᵂ_hp _ _ Aᵂ).
      clear Tyᵂ_hp Conᵂ_hp.
      intros Γ'.
      dependent destruction Γ'.
      f_equal.
      * apply  IΓ.
      * apply IA.
  - destruct Aᵂ.
    + rename c into Γᵂ.
      assert (IΓ := Conᵂ_hp _ Γᵂ).
      intro Γ'.
      dependent destruction Γ'.
      f_equal.
      apply IΓ.
    + rename Aᵂ2 into Bᵂ.
      rename Aᵂ1 into Aᵂ.
      assert (hA := Tyᵂ_hp _ _ Aᵂ).
      assert (hB := Tyᵂ_hp _ _ Bᵂ).
      intro p'.
      dependent destruction p'.
      f_equal; apply Tyᵂ_hp.
Qed.

Local Notation U := Type.
Class methods :=
  { Conᴹ : forall (c : Con), Conᵂ c  -> Type ;
    Tyᴹ : forall (c : Con) A (wc : Conᵂ c) (Aᵂ : Tyᵂ c A)
      (cᴹ : Conᴹ  wc) , U  ;
  nilᴹ : Conᴹ  nilᵂ ;
  consᴹ : forall (Γ : Con  )(Γᵂ : Conᵂ Γ)
            (Γᴹ : Conᴹ  Γᵂ)
            (A : Ty )(Aᵂ : Tyᵂ Γ A) ,
      Tyᴹ   Aᵂ Γᴹ
            -> Conᴹ
                    (consᵂ  Γᵂ Aᵂ) ;
  uᴹ : forall (Γ : Con ) (Γᵂ : Conᵂ Γ) (Γᴹ : Conᴹ  Γᵂ) ,
         Tyᴹ  (unittᵂ  Γᵂ) Γᴹ ;
  πᴹ : forall (Γ : Con) (Γᵂ : Conᵂ Γ) (Γᴹ : Conᴹ  Γᵂ)
         (B : Ty) (Bᵂ : Tyᵂ Γ B)
         (Bᴹ : Tyᴹ  Bᵂ Γᴹ )
         (C : Ty) (Cᵂ : Tyᵂ (cons Γ B) C)
         (Cᴹ : Tyᴹ   Cᵂ
                   (consᴹ    Bᴹ) ),
      Tyᴹ
          (prodᵂ  Bᵂ Cᵂ)
          Γᴹ  }.

Section meth.
 Context{d : methods}.

 (* eliminateur (déterminé à partir du programme Haskell d'Ambruse *)
Record elimin  :=
  {
    Conᴱ : forall c (x' : Conᵂ c) , Conᴹ  x';

    Tyᴱ : forall Γ (Γᵂ : Conᵂ Γ)
            B (Bᵂ : Tyᵂ Γ B),
              Tyᴹ Γᵂ Bᵂ (Conᴱ  Γᵂ)
    ;
    nilᴱ : Conᴱ nilᵂ = nilᴹ ;

    consᴱ :
       forall Γ (Γᵂ : Conᵂ Γ)
           B (Bᵂ : Tyᵂ Γ B),
         Conᴱ  (consᵂ  Γᵂ Bᵂ) =
              consᴹ Γᵂ (Conᴱ  Γᵂ)  Bᵂ
              (Tyᴱ  Γᵂ  Bᵂ);
    uᴱ : forall Γ (Γᵂ : Conᵂ Γ) ,
           Tyᴱ  Γᵂ  (unittᵂ Γᵂ) = uᴹ  Γᵂ (Conᴱ Γᵂ);
    πᴱ :
      forall (Γ : Con)(Γᵂ : Conᵂ Γ)
               (A : Ty )(Aᵂ : Tyᵂ Γ A)
               (B : Ty )
               (Bᵂ : Tyᵂ (cons Γ A) B),
       Tyᴱ Γᵂ (prodᵂ  Aᵂ Bᵂ) = πᴹ Γᵂ (Conᴱ Γᵂ) Aᵂ (Tyᴱ Γᵂ Aᵂ) Bᵂ
                                  ((tr (fun uᴹ' =>
                                          forall (x' : Ty) (x'ᵂ : Tyᵂ (cons Γ A) x')  ,
                                            Tyᴹ (consᵂ Γᵂ Aᵂ) x'ᵂ uᴹ' ) (consᴱ Γᵂ Aᵂ) (Tyᴱ (consᵂ Γᵂ Aᵂ))) B Bᵂ)
  }.

 (* description de la relation fonctionnelle *)
Inductive Conᶠ  : forall Γ (Γᵂ : Conᵂ Γ), Conᴹ Γᵂ -> Type :=
  nilᶠ  :  Conᶠ   nilᵂ nilᴹ
| consᶠ :
       forall Γ (Γᵂ : Conᵂ Γ) Γᴹ (* redondant avec Bᶠ *) (Γᶠ : Conᶠ _ Γᴹ)
           B (Bᵂ : Tyᵂ Γ B) (Bᴹ : Tyᴹ _ Bᵂ Γᴹ) (Bᶠ : Tyᶠ  _ _ _ Bᴹ),
         Conᶠ  _ (consᴹ Γᵂ Γᴹ  Bᵂ Bᴹ)
with Tyᶠ  : forall Γ (Γᵂ : Conᵂ Γ) B (Bᵂ : Tyᵂ Γ B)(Γᴱ : Conᴹ Γᵂ),
    Tyᴹ Γᵂ Bᵂ Γᴱ -> Type :=
     | uᶠ Γ (Γᵂ : Conᵂ Γ) (Γᴹ : Conᴹ Γᵂ) (Γᶠ : Conᶠ  _ Γᴹ) :
         Tyᶠ  _ _ _ (uᴹ Γᵂ Γᴹ)
     | πᶠ   (Γ : Con)(Γᵂ : Conᵂ Γ)(Γᴹ : Conᴹ Γᵂ) (* redondant avec Aᶠ *) (* (Γᶠ : Conᶠ _ Γᴹ) *)
               (A : Ty )(Aᵂ : Tyᵂ Γ A)(Aᴹ : Tyᴹ _ Aᵂ Γᴹ) (Aᶠ : Tyᶠ  _ _ _ Aᴹ)
               (B : Ty ) (Bᵂ : Tyᵂ (cons Γ A) B)(Bᴹ : Tyᴹ _ Bᵂ (consᴹ Γᵂ Γᴹ Aᵂ Aᴹ))
               (Bᶠ : Tyᶠ  _ _ _ Bᴹ) :
         Tyᶠ  _ _ _ (πᴹ Γᵂ  Γᴹ Aᵂ Aᴹ Bᵂ Bᴹ)
         .

  (* invariants d'induction *)
 Record ConR  (Γ : Con) (Γᵂ : Conᵂ Γ) :=
  { ConR_carrier : Conᴹ Γᵂ;
    ConR_carrierᶠ : Conᶠ _ ConR_carrier }.

 Record TyR  (Γ : Con) (Γᵂ : Conᵂ Γ) A (Aᵂ : Tyᵂ Γ A) :=
   { TyR_ConR :> ConR Γᵂ;
     TyR_carrier : Tyᴹ _ Aᵂ (ConR_carrier TyR_ConR);
     TyR_carrierᶠ :  Tyᶠ _ _ _ TyR_carrier
     }.

Lemma Con_is_subCenter  Γ (Γᵂ : Conᵂ Γ) (Γᴹ : Conᴹ Γᵂ)
      (Γᶠ : Conᶠ Γᵂ Γᴹ)
           : is_subCenter ( Conᶠ Γᵂ) Γᴹ
with Ty_is_subCenter  Γ (Γᵂ : Conᵂ Γ) (Γᴹ : Conᴹ Γᵂ)
                (* (Γᶠ : Conᶠ _ Γᴹ) *)
               A (Aᵂ : Tyᵂ Γ A) (Aᴹ : Tyᴹ _ Aᵂ Γᴹ)
               (Aᶠ : Tyᶠ Γᵂ Aᵂ Γᴹ Aᴹ)
     : is_subCenter ( Tyᶠ Γᵂ Aᵂ Γᴹ) Aᴹ.
Proof.
  - destruct Γᶠ.
    + intros nil' nil'ᶠ.
      dependent destruction nil'ᶠ.
      reflexivity.
    + assert(IB := Ty_is_subCenter Γ Γᵂ Γᴹ B Bᵂ Bᴹ Bᶠ).
      assert(IΓ := Con_is_subCenter Γ Γᵂ Γᴹ Γᶠ ).
      intros Γe' Γe'ᶠ.
      abstract(
      dependent destruction Γe'ᶠ;
      (* revert Bᶠ0. *)
      assert (eΓ := (IΓ _ Γe'ᶠ));
      destruct eΓ;
      f_equal;
      now apply IB).
  - destruct Aᶠ.
    + intros u' u'ᶠ.
      clear -u'ᶠ.
      dependent destruction u'ᶠ.
      reflexivity.
    +
      rename Aᶠ2 into Bᶠ.
      rename Aᶠ1 into Aᶠ.
      assert (IA := Ty_is_subCenter Γ Γᵂ Γᴹ A Aᵂ Aᴹ Aᶠ).
      assert (IB := Ty_is_subCenter _ _  _  _ _  _  Bᶠ).
      intros p' p'ᶠ.
      abstract(
      dependent destruction p'ᶠ;
      assert (eA : Aᴹ = Aᴹ0)by ( now apply IA);
      destruct eA;
      f_equal;
      now apply IB).
Qed.

(* uip is used by dependent destruction *)
Print Assumptions Ty_is_subCenter.

 Fixpoint Ty_Conᶠ  Γ (Γᵂ : Conᵂ Γ) (Γᴹ : Conᴹ Γᵂ)
               A (Aᵂ : Tyᵂ Γ A) (Aᴹ : Tyᴹ _ Aᵂ Γᴹ)
               (Aᶠ : Tyᶠ Γᵂ Aᵂ Γᴹ Aᴹ)  : Conᶠ Γᵂ Γᴹ.
 Proof.
   - destruct Aᶠ.
     + assumption.
     + eapply Ty_Conᶠ.
       eassumption.
 Defined.

 (* On habite par récurrence l'éliminateur *)
Fixpoint build_ConR (Γ : Con) (Γᵂ : Conᵂ Γ) {struct Γᵂ} : ConR Γᵂ
with build_TyR (Γ : Con) (Γᵂ : Conᵂ Γ) (A : Ty) (Aᵂ : Tyᵂ Γ A) {struct Aᵂ} : TyR  Γᵂ Aᵂ.
- destruct Γᵂ.
  + econstructor.
    constructor.
  + assert (h := build_TyR _ Γᵂ _ t).
    econstructor.
    assert (hA := TyR_carrierᶠ (build_TyR _ Γᵂ _ t)).
    constructor.
    * eapply Ty_Conᶠ; exact hA.
    * exact hA.
- destruct Aᵂ.
  + assert (IΓ := build_ConR _ c).
    assert (h : Γᵂ = c) by apply Conᵂ_hp.
    subst.
    econstructor.
    constructor.
    apply ConR_carrierᶠ.
    Unshelve.
    assumption.
  + rename Aᵂ2 into Bᵂ.
    rename Aᵂ1 into Aᵂ.
    assert (IA := build_TyR Γ Γᵂ A Aᵂ).
    assert (IB := build_TyR _ (consᵂ Γᵂ Aᵂ) B Bᵂ).
    assert (h1 : (ConR_carrier IB) =  consᴹ Γᵂ (ConR_carrier IA) Aᵂ (TyR_carrier IA) ).
    {
      apply Con_is_subCenter.
      - apply ConR_carrierᶠ.
      - constructor.
        * eapply Ty_Conᶠ; apply TyR_carrierᶠ.
        * apply TyR_carrierᶠ.
    }
    econstructor.
    constructor.
    *  unshelve apply TyR_carrierᶠ.
       assumption.
    * assert (Bᶠ := TyR_carrierᶠ IB).
      assert (Bᶠ' : Tyᶠ (consᵂ Γᵂ Aᵂ) Bᵂ (consᴹ Γᵂ (ConR_carrier IA) Aᵂ (TyR_carrier IA))
                        (tr (Tyᴹ _ _)  h1 (TyR_carrier IB))
             ).
      {
        now destruct h1.
      }
      exact Bᶠ'.
Defined.

Lemma build_TyR_ConR (Γ : Con) (Γᵂ : Conᵂ Γ)  (A : Ty) (Aᵂ : Tyᵂ Γ A) :
  ConR_carrier (build_TyR  Γᵂ Aᵂ) = ConR_carrier (build_ConR Γᵂ) .
Proof.
  apply Con_is_subCenter; apply ConR_carrierᶠ.
Defined.

Definition elimin_term : elimin.
  unshelve refine(
  {| Conᴱ := fun Γ Γᵂ => ConR_carrier ( build_ConR Γᵂ);
     Tyᴱ := fun  (Γ : Con) (Γᵂ : Conᵂ Γ) (A : Ty) (Aᵂ : Tyᵂ Γ A) => tr (Tyᴹ _ _) (build_TyR_ConR Γᵂ Aᵂ)
             (TyR_carrier (@build_TyR Γ Γᵂ A Aᵂ));

  |}).
  - intros.
    apply Con_is_subCenter.
    + apply ConR_carrierᶠ.
    + set (e := build_TyR_ConR _ _).
      set (T := build_TyR _ _) in *.
      assert (h := TyR_carrierᶠ T).
      constructor.
      * apply ConR_carrierᶠ.
      * now destruct e .
  - reflexivity.
  - intros ??.
    apply Ty_is_subCenter.
    +
      set (e := build_TyR_ConR _ _).
      set (unitRR := build_TyR _ _) in *.
      assert (h := TyR_carrierᶠ unitRR).
      now destruct e .
    + constructor.
      apply ConR_carrierᶠ.
  - intros.
    apply Ty_is_subCenter.
    + set (e := build_TyR_ConR _ _).
      set (T := build_TyR _ _) in *.
      assert (h := TyR_carrierᶠ T).
      now destruct e  .
    + constructor.
      * set (e := build_TyR_ConR _ _).
        set (T := build_TyR _ _) in *.
        assert (h := TyR_carrierᶠ T).
        now destruct e    .
      * cbn.
        set (e := build_TyR_ConR _ _).
        set (TA := build_TyR _ _) in *.
        (* revert h. *)
        set (e' := Con_is_subCenter _ _).
        generalize e'; clear e'.
        destruct e .
        cbn .
        intro e'.
        rewrite (K e').
        cbn.
        clear e'.

        fold TA.
        set (TB := build_TyR _ _) .
        set (e := build_TyR_ConR _ _).
        fold TB in  e.
        set (eΓB :=  e:  (ConR_carrier TB) = (consᴹ Γᵂ (ConR_carrier TA) Aᵂ (TyR_carrier TA)) ).
        generalize (TyR_carrierᶠ TB).
        case eΓB.
        easy.
Defined.

Print Assumptions elimin_term.

End meth.


(* Copyright 2021 Joshua M. Cohen

Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License.
*)

(** Generic Results about mathcomp and ssreflect functions, some used in multiple places*)
Require Import Coq.Lists.List.
From mathcomp Require Import all_ssreflect.
Require Import mathcomp.algebra.matrix.
Require Import mathcomp.algebra.ssralg.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

(*Used only for other tactics*)
Ltac case_view E P H :=
  destruct E eqn : H; [ apply (elimT P) in H | apply (elimF P) in H].

(** Lemmas about Nats*)

Lemma ltn_total: forall (n1 n2: nat),
  (n1 < n2) || (n1 == n2) || (n2 < n1).
Proof.
  move => n1 n2. case: (orP (leq_total n1 n2)); rewrite leq_eqVlt.
  - move => le_n12; case (orP le_n12) => [Heq | Hlt].  rewrite Heq /=.
    by rewrite orbT orTb. by rewrite Hlt !orTb.
  - move => le_n21; case (orP le_n21) => [Heq | Hlt]. rewrite eq_sym Heq /=.
    by rewrite orbT orTb. by rewrite Hlt !orbT.
Qed.

Lemma ltn_leq_trans: forall [n m p : nat], m < n -> n <= p -> m < p.
Proof.
  move => m n p Hmn. rewrite leq_eqVlt => /orP[/eqP Hmp | Hmp]. by subst.
  move : Hmn Hmp. apply ltn_trans.
Qed.

Lemma ltn_pred: forall m n,
  0 < n ->
  (m < n) = (m <= n.-1).
Proof.
  move => m n Hpos. have: n.-1 == (n - 1)%N by rewrite eq_sym subn1. move => /eqP Hn1. by rewrite Hn1 leq_subRL.
Qed.

Lemma pred_lt: forall n, 0 < n -> n.-1 < n.
Proof.
  move => n Hn. by rewrite ltn_predL.
Qed.

Lemma ltn_leq_total: forall n m,
  (n < m) || (m <= n).
Proof.
  move => m n.
  pose proof (ltn_total m n). move : H => /orP[/orP[Hlt | Heq] | Hgt].
  + by rewrite Hlt.
  + by rewrite (leq_eqVlt n) eq_sym Heq orbT.
  + by rewrite (leq_eqVlt n) Hgt !orbT.
Qed.

Lemma ltn_add2rl: forall n1 n2 m1 m2,
  n1 < n2 ->
  m1 < m2 ->
  n1 + m1 < n2 + m2.
Proof.
  move => n1 n2 m1 m2 Hn Hm. have Hleft: n1 + m1 < n1 + m2 by rewrite ltn_add2l.
  have Hright: n1 + m2 < n2 + m2 by rewrite ltn_add2r. by apply (ltn_trans Hleft Hright).
Qed.

Lemma pred_leq: forall (n m: nat),
  (n.-1 <= m) = (n <= m.+1).
Proof.
  move => n m. by rewrite -subn1 -addn1 add0n leq_subLR addnC addn1.
Qed.

(** Lemmas about Ordinals*)

Definition pred_ord (n: nat) (Hn: 0 < n) : 'I_n := Ordinal (pred_lt Hn).

(*Working with enums of ordinals*)
Lemma ordinal_enum_size: forall n,
  size (Finite.enum (ordinal_finType n)) = n.
Proof.
  move => n. have: size ([seq val i | i <- enum 'I_n]) = n. rewrite val_enum_ord. by apply: size_iota.
  rewrite size_map. unfold enum. rewrite size_map //.
Qed.

Lemma ordinal_enum: forall {n: nat} (x: 'I_n) y,
  nth y (Finite.enum (ordinal_finType n)) x = x.
Proof.
  move => n x y. have nth_ord := (nth_ord_enum y x). unfold enum in nth_ord. move: nth_ord.
  rewrite (@nth_map _ y) //. by rewrite ordinal_enum_size.
Qed.

Lemma size_ord_enum: forall n, size (ord_enum n) = n.
Proof.
  move => n.
  have : size (ord_enum n) = size ([seq val i | i <- ord_enum n]) by rewrite size_map.
  by rewrite val_ord_enum size_iota.
Qed.

Lemma nth_ord_enum: forall n (i: 'I_n) x, nth x (ord_enum n) i = i.
Proof.
  move => n i x. have Hv := val_ord_enum n.  have Hmap :=  @nth_map 'I_n x nat x val i (ord_enum n).
  move : Hmap. rewrite Hv size_ord_enum nth_iota =>[//=|//]. rewrite add0n. move => H.
  (*some annoying stuff about equality of ordinals vs nats*)
  have : nat_of_ord ( nth x (ord_enum n) i) == nat_of_ord i. rewrite {2}H. by []. by [].
  move => Hnatord. have : nth x (ord_enum n) i == i by [].
  by move => /eqP Heq.
Qed.

Lemma index_ord_enum: forall (n: nat), (index_enum (ordinal_finType n)) = ord_enum n.
Proof.
  move => n. have: 0 <= n by []. rewrite leq_eqVlt => /orP[/eqP Hn0 | Hnpos].
  - subst. rewrite /ord_enum /= /index_enum /=. apply size0nil. apply ordinal_enum_size.
  - apply (eq_from_nth (x0:=pred_ord Hnpos)).
    + by rewrite ordinal_enum_size size_ord_enum.
    + move => i. rewrite ordinal_enum_size => Hi.
      have->: i = nat_of_ord (Ordinal Hi) by [].
      by rewrite ordinal_enum nth_ord_enum.
Qed.

(*If an 'I_m exists, then 0 < m*)
Lemma ord_nonzero {m} (r: 'I_m) : 0 < m.
Proof.
  case : r. move => m'. case (orP (ltn_total m 0)) => [/orP[Hlt // | /eqP Heq] | Hgt //].
  by subst.
Qed.

Lemma remove_widen: forall {m n} (x: 'I_m) (H: m <= n),
  nat_of_ord (widen_ord H x) = nat_of_ord x.
Proof.
  by [].
Qed.

Lemma widen_ord_inj: forall {m n: nat} (H: m <= n) x y, widen_ord H x = widen_ord H y -> x = y.
Proof.
  move => m n H x y Hw. apply (elimT eqP).
  have: nat_of_ord (widen_ord H x) == x by []. have: nat_of_ord (widen_ord H y) == y by [].
  move => /eqP Hy /eqP Hx. rewrite Hw in Hx. have: nat_of_ord x == nat_of_ord y by rewrite -Hx -Hy. by [].
Qed.

Lemma eq_leqn: forall m n,
  m = n ->
  (m <= n)%N.
Proof.
  move => m n ->. by rewrite leqnn.
Qed.

Definition eq_ord m n (Hmn: m = n) (x: 'I_m) : 'I_n  := widen_ord (eq_leqn Hmn) x.

Lemma nat_of_ord_eq: forall n (x y : 'I_n),
  (nat_of_ord x == nat_of_ord y) = (x == y).
Proof.
  move => n x y. case Hxy: (x == y).
  apply (elimT eqP) in Hxy. by rewrite Hxy eq_refl.
  case Hxynat: (nat_of_ord x == nat_of_ord y) =>[|//]. apply (elimT eqP) in Hxynat.
  have: x == y by (apply /eqP; apply ord_inj). by rewrite Hxy.
Qed.

Lemma nat_of_ord_neq: forall {m} (x y : 'I_m),
  x != y ->
  nat_of_ord x != nat_of_ord y.
Proof.
  move => m x y Hxy. by rewrite nat_of_ord_eq.
Qed.

(** Lemmas about [iota]*)

Lemma iota_plus_1: forall x y,
  iota x (y.+1) = iota x y ++ [ :: (x + y)%N].
Proof.
  move => x y. by rewrite -addn1 iotaD /=.
Qed.

Lemma last_iota: forall n m k,
  (0 < n)%N ->
  last k (iota m n) = (m+n).-1.
Proof.
  move => n. elim : n => [/= m k | /=n IH m k Hn].
  - by rewrite ltnn.
  - apply ltnSE in Hn. move: Hn; rewrite leq_eqVlt => /orP[/eqP Hn0 | Hnpos].
    + by rewrite -Hn0 /= addn1 -pred_Sn.
    + by rewrite IH // addSnnS.
Qed.

(** Other lemmas*)

Lemma rwN: forall [P: Prop] [b: bool], reflect P b -> ~ P <-> ~~ b.
Proof.
  move => P b Hr. split. by apply introN. by apply elimN.
Qed.

Lemma rem_impl: forall b : Prop,
  (true -> b) -> b.
Proof.
  move => b. move => H. by apply H.
Qed.

Lemma isSome_none: forall {T: eqType} (o: option T),
  ~~ (isSome o) = (o == None).
Proof.
  move => T o. by case : o.
Qed.

(*The lemma in the ssreflect library is not generic enough*)
Lemma some_inj: forall {A: Type},
  injective (@Some A).
Proof.
  move => A x y Hop. by case : Hop.
Qed.

(** Lemmas about [find] *)

(*Results about [find] that mostly put the library lemmas into a more convenient form*)

Lemma find_iff: forall {T: eqType} (a: pred T) (s: seq T) (r : nat) (t: T),
  r < size s ->
  find a s = r <-> (forall x, a (nth x s r)) /\ forall x y, y < r -> (a (nth x s y) = false).
Proof.
  move => T a s r t Hsz. split.
  - move => Hfind. subst. split. move => x. apply nth_find. by rewrite has_find.
    move => x. apply before_find.
  - move => [Ha Hbef]. have Hfind := (findP a s). case : Hfind.
    + move => Hhas. have H := (rwN (@hasP T a s)). rewrite Hhas in H.
      have:~ (exists2 x : T, x \in s & a x) by rewrite H. move : H => H{H} Hex.
      have : nth t s r \in s by apply mem_nth. move => Hnthin.
      have: (exists2 x : T, x \in s & a x) by exists (nth t s r). by [].
    + move => i Hisz Hanth Hprev.
      have Hlt := ltn_total i r. move : Hlt => /orP[H1 | Hgt].
      move : H1 => /orP[Hlt | /eqP Heq].
      * have : a (nth t s i) by apply Hanth. by rewrite Hbef.
      * by subst.
      * have : a (nth t s r) by apply Ha. by rewrite Hprev.
Qed.

(*Similar for None case*)
Lemma find_none_iff: forall {T: eqType} (a: pred T) (s: seq T),
  find a s = size s <-> (forall x, x \in s -> ~~ (a x)).
Proof.
  move => T a s. split.
  - move => Hfind. have: ~~ has a s. case Hhas : (has a s).
    move : Hhas. rewrite has_find Hfind ltnn. by []. by [].
    move => Hhas. by apply (elimT hasPn).
  - move => Hnotin. apply hasNfind. apply (introT hasPn). move => x. apply Hnotin.
Qed.

(** [find] but for values rather than indices*)

Definition find_val_option {T: Type} (p: pred T) (s: seq T) : option T :=
  match (filter p s) with
  | nil => None
  | h :: _ => Some h
  end.

Definition find_val {T: Type} (p: pred T) (s: seq T) (d: T) : T :=
  match (find_val_option p s) with
  | None => d
  | Some h => h
  end.

Lemma find_val_option_none: forall {T: Type} (p: pred T) s,
  all (fun x => ~~ p x) s = ~~ (isSome (find_val_option p s)).
Proof.
  move => T p s. elim : s => [//= | h t /=].
  rewrite /find_val_option /= => IH.
  case Hh: (p h) =>[//|/=].
  by rewrite IH.
Qed.

Lemma find_val_none: forall {T: Type} (p: pred T) s d,
  all (fun x => ~~ p x) s ->
  find_val p s d = d.
Proof.
  move => T p s d. rewrite find_val_option_none /find_val.
  by case (find_val_option).
Qed.

Lemma find_val_option_some_in: forall {T: eqType} (p: pred T) s h,
  (find_val_option p s) = Some h ->
  h \in s.
Proof.
  move => T p s. elim : s =>[// | x t /=].
  rewrite /find_val_option/= => IH h. case Hx: (p x) => [/= |/=].
  move => [Hxh]. subst. by rewrite in_cons eq_refl. move => Hh. apply IH in Hh.
  by rewrite in_cons Hh orbT.
Qed.

Lemma find_val_option_some: forall {T: Type} (p: pred T) s h,
  (find_val_option p s) = Some h ->
  p h.
Proof.
  move => T p s. elim : s =>[// | x t /=].
  rewrite /find_val_option/= => IH h. case Hx: (p x) => [/= |/=].
  move => [Hxh]. by subst. apply IH.
Qed.

Lemma find_val_option_exists: forall {T: eqType} (p: pred T) s,
  (exists x, (x \in s) && p x) ->
  exists h, ((find_val_option p s == Some h) && p h).
Proof.
  move => T p s. elim : s => [//= | h t /=].
  rewrite /find_val_option/= => IH [x /andP[Hin Hpx]].
  move: Hin; rewrite in_cons => /orP[/eqP Hxh | Hxt].
  - subst. rewrite Hpx. exists h. by rewrite Hpx eq_refl.
  - case Hh: (p h). exists h. by rewrite Hh eq_refl. apply IH.
    exists x. by rewrite Hxt Hpx.
Qed.

Lemma find_val_exists: forall {T: eqType} (p: pred T) s d,
  (exists x, (x \in s) && p x) ->
  p (find_val p s d).
Proof.
  move => T p s d Hex. rewrite /find_val. apply find_val_option_exists in Hex.
  case : Hex => [h /andP[/eqP Hfind Hph]]. by rewrite Hfind Hph.
Qed.

(** Lemmas about [all]*)

Lemma all_in: forall {A: eqType} (l: seq A) (p: pred A),
  all p l <-> forall x, x \in l -> p x.
Proof.
  move => A l. elim: l =>[p // | h t IH p /=].
  split. move => /andP[Hh Htl x]. rewrite in_cons => /orP[/eqP Hxh | Hxt].
  by subst. by apply IH.
  move => Hall. rewrite Hall. rewrite IH. move => x Hint. apply Hall. by rewrite in_cons Hint orbT.
  by rewrite in_cons eq_refl.
Qed.

(** Lemmas about [rem]*)
Lemma rem_in_neq: forall {A: eqType} (l : seq A) (y: A) (x: A),
  x != y ->
  (x \in (rem y l)) = (x \in l).
Proof.
  move => A l y x Hxy. elim : l => [//= | h t IH /=].
  case: (h == y) /eqP => Hhy.
  - rewrite in_cons. subst. have->: (x == y = false). move : Hxy. by case (x == y).
    by [].
  - rewrite !in_cons. by rewrite IH.
Qed.

(** Lemmas about [pmap]*)
Lemma nth_pmap: forall (aT rT: eqType) (f: aT -> option rT) (s: seq aT) (i: nat) (a: aT) (r: rT),
  all f s ->
  (i < size s)%N ->
  Some (nth r (pmap f s) i) = f (nth a s i).
Proof.
  move => aT rT f s i a r. move: i. elim : s =>[//= | h t /= IH i /andP[Hh Hall]]. rewrite ltnS => Hi.
  move : Hh. case Hh: (f h) => [h' /= | //=]. move => Htriv.
  have: (0 <= i)%N by []. rewrite leq_eqVlt => /orP[/eqP Hi0 | Hi'].
  - subst. by rewrite /= Hh.
  - have->: (i = (i.-1).+1)%N by rewrite (ltn_predK Hi'). rewrite /=. rewrite IH //.
    have Hi1: (i.-1 < i)%N by apply pred_lt. by apply (ltn_leq_trans Hi1).
Qed.

Lemma index_pmap: forall (aT rT: eqType) (f: aT -> option rT) (g: rT -> aT) (s: seq aT) (x: rT),
  pcancel g f ->
  (forall x x' y, f x = Some y -> f x' = Some y -> x = x') ->
  all f s ->
  index (g x) s = index x (pmap f s).
Proof.
  move => aT rT f g s x Hcancel Hinj. elim : s => [//= | h t /= IH /andP[Hh Hall]].
  move: Hh. case Hfh : (f h) => [o /= | //]. move => _.
  case : (h == g x) /eqP => [Hhg | Hhg].
  - rewrite Hhg in Hfh. rewrite Hcancel in Hfh. case : Hfh => [->]. by rewrite eq_refl.
  - case: (o == x) /eqP => [Hox /= | Hox /=].
    + subst. have: h = g x. apply (Hinj _ _ x). by []. apply Hcancel. by [].
    + by rewrite IH.
Qed.

Lemma rev_pmap: forall {aT rT} (f: aT -> option rT) (s: seq aT),
  rev (pmap f s) = pmap f (rev s).
Proof.
  move => aT rT f s. elim : s => [// | h t /= IH].
  rewrite rev_cons -cats1 pmap_cat /= -IH.
  case Hf: (f h) =>[/= u|/=].
  - by rewrite rev_cons -cats1.
  - by rewrite cats0.
Qed.

(** Lemmas about [index]*)

Lemma index_notin: forall {T: eqType} (x: T) (s: seq T), (index x s == size s) = (x \notin s).
Proof.
  move => T x s. case Hin: (x \in s).
  - move: Hin. rewrite -index_mem. case : (index x s == size s) /eqP => [->// |//]. by rewrite ltnn.
  - rewrite memNindex. by rewrite eq_refl. by rewrite Hin.
Qed.

(*Don't need f to be injective fully, only on some predicate that encompases list and x (for us,
  dealing with only positive integers)*)
Lemma index_map': forall [T1 T2 : eqType] [f : T1 -> T2] (s: seq T1) (a: pred T1),
  (forall x y, a x -> a y -> f x = f y -> x = y) ->
  all a s ->
  forall (x : T1), a x -> index (f x) [seq f i | i <- s] = index x s.
Proof.
  move => T1 T2 f s a Hinj Hall x Hx. move: Hinj Hall. elim : s => [//= | h t /= IH Hinj /andP[Hah Hat]].
  case : (h == x) /eqP => [Hhx/= | Hhx/=].
  - subst. by rewrite eq_refl.
  - case : (f h == f x) /eqP => [Hfxh /= | Hfxh /=].
    + have: h = x. by apply Hinj. by [].
    + by rewrite IH.
Qed.

(** Relating ssreflect and standard library functions*)

Lemma in_mem_In: forall {A: eqType} (l: list A) x,
  x \in l <-> In x l.
Proof.
  move => A l x. elim: l => [//| h t IH /=].
  rewrite in_cons -IH eq_sym. split => [/orP[/eqP Hx | Ht]| [Hx | Hlt]]. by left. by right.
  subst. by rewrite eq_refl. by rewrite Hlt orbT.
Qed.

Lemma uniq_NoDup: forall {A: eqType} (l: list A),
  uniq l <-> NoDup l.
Proof.
  move => A l. elim : l => [//=|h t IH].
  - split =>[H{H}|//]. by apply NoDup_nil.
  - rewrite /=. split => [/andP[Hnotin Hun]| ].
    constructor. rewrite -in_mem_In. move => Hin. by move : Hin Hnotin ->.
    by apply IH.
    move => Hnod. inversion Hnod as [|x l Hnotin Hnodup] ; subst.
    have->: h \notin t. case Hin: (h\in t). have: h\in t by []. by rewrite in_mem_In =>{} Hin.
    by []. by rewrite IH.
Qed.

Lemma size_length: forall {A : Type} (l: list A),
  size l = Datatypes.length l.
Proof.
  move => A l. elim: l => [//|h t IH /=].
  by rewrite IH.
Qed.

Lemma nth_nth: forall {A: Type} (d: A) (l: seq A) (n: nat),
  nth d l n = List.nth n l d.
Proof.
  move => A d l. elim : l => [//= n | //= h t IH n].
  - by case : n.
  - case: n. by []. move => n. by rewrite /= IH.
Qed.

Lemma concat_flatten: forall {A: Type} (l: seq (seq A)),
  concat l = flatten l.
Proof.
  move => A l. by [].
Qed.

Lemma rev_rev: forall {A: Type} (s: seq A),
  rev s = List.rev s.
Proof.
  move => A s. elim : s => [// | h t /= IH].
  by rewrite rev_cons IH -cats1.
Qed.

Lemma map_map_equiv: forall {A B: Type} (f: A -> B) (s: seq A),
  map f s = List.map f s.
Proof.
  by [].
Qed.

Lemma filter_filter: forall {A: Type} (f: A -> bool) (s: seq A),
  filter f s = List.filter f s.
Proof.
  by [].
Qed.

(** Other list lemmas*)

Lemma cat_extra: forall {A: Type} (s1 s2 : seq A),
  s1 ++ s2 = s1 ->
  s2 = [::].
Proof.
  move => A s1 s2. elim : s1 => [//= | /= h t IH [Happ]]. by apply IH.
Qed.

Lemma size_not_nil: forall {A: Type} (l: seq A),
  (0 < size l) = ~~ (nilp l).
Proof.
  move => A l. case Hsz: (size l) => [/= | n /=].
  - apply size0nil in Hsz. by subst.
  - move: Hsz. by case : l.
Qed.

Lemma larger_not_nil: forall {A: Type} (l1 l2: seq A),
  ~~ nilp l2 ->
  (size l1 < size l2) = false ->
  ~~ nilp l1.
Proof.
  move => A l1 l2 Hl2 Hsz. rewrite ltnNge in Hsz. apply negbFE in Hsz. move : Hl2;
  rewrite -!size_not_nil => Hl2. by apply (ltn_leq_trans Hl2).
Qed.

(** Stuff about finTypes*)

Lemma bijective_card: forall {T T': finType} (f: T -> T'),
  bijective f ->
  #|T| = #|T'|.
Proof.
  move => T T' f Hb. have Htt': #|T| <= #|T'|. apply (leq_card f). by apply bij_inj.
  case : Hb => g Hfg Hgf. have Htt'': #|T'| <= #|T|. apply (leq_card g). apply (can_inj Hgf).
  apply /eqP. by rewrite eqn_leq Htt' Htt''.
Qed.

Lemma tuple_eq: forall {A: Type} (n: nat) (t1 t2: n.-tuple A),
  tval t1 = tval t2 ->
  t1 = t2.
Proof.
  move => A n [l1 Hl1] [l2 Hl2]. rewrite /= => Hl12. subst. f_equal. apply bool_irrelevance.
Qed.

Lemma in_enum: forall {T: finType} (x: T),
  x \in (enum T).
Proof.
  move => T x. rewrite enumT. pose proof (@enumP T) as Hfin. move: Hfin; rewrite /Finite.axiom => /(_ x) Hx.
  case Hin: (x \in Finite.enum T) => [// | ].
  have / count_memPn Hnotin: (x \notin Finite.enum T) by rewrite Hin. by rewrite Hnotin in Hx.
Qed.

(** Seqs of subTypes *)

(*We want to transform a seq T into a seq sT if we know that all elements in s satisfy the predicate P.
  We can do so with the following function, which is computable, unlike [pmap insub]*)

Lemma all_cons_hd: forall {T: Type} (P: pred T) (h: T) t,
  all P (h :: t) ->
  P h.
Proof.
  by move => T P h t /= /andP[Hh Ht].
Qed.

Lemma all_cons_tl: forall {T: Type} (P: pred T) (h: T) t,
  all P (h :: t) ->
  all P t.
Proof.
  by move => T P h t /= /andP[Hh Ht].
Qed.

Definition sub_seq {T: Type} (P: pred T) (st: subType P) (s: seq T) (Hs: all P s) : seq st.
move: Hs; elim s => [Hall | h t /= IH Hall].
apply nil.
apply cons. apply (Sub h (all_cons_hd Hall)). apply (IH (all_cons_tl Hall)).
Defined.

Lemma sub_seq_in: forall {T: eqType} (P: pred T) (st: subType P) (s: seq T) (Hs: all P s) (x: st),
  x \in (sub_seq st Hs) = ((val x) \in s).
Proof.
  move => T P st s Hs x. move: Hs. elim : s => [//= | h t /= IH Hs].
  rewrite !in_cons /=. f_equal.
  - by rewrite -val_eqE /= SubK.
  - apply IH.
Qed.

(** [dropWhileEnd - remove all elts from end that satisfy predicate (from Haskell)*)

(* function (from Haskell) to remove all values from end of list that satisfy a predicate. *)
Definition dropWhileEnd {A: Type} (p: pred A) (l: seq A) : seq A :=
  foldr (fun x acc => if (nilp acc) && (p x) then nil else x :: acc) nil l.

Lemma dropWhileEnd_nil: forall {A} p (l: seq A),
  reflect (dropWhileEnd p l = nil) (all p l).
Proof.
  move => A p l. apply Bool.iff_reflect. elim : l => [//= | h t /= IH].
  case Hnil: (nilp (dropWhileEnd p t)) => [/= | /=].
  - case Hp: (p h) => [//= | //=]. rewrite -IH. apply (elimT nilP) in Hnil. by rewrite Hnil.
  - split; move => Hcon.
    + by [].
    + move: Hcon => /andP[Hph Ht]. have: all p t = true by rewrite Ht. rewrite -IH => Htl.
      by rewrite Htl in Hnil.
Qed.

Lemma dropWhileEnd_end: forall {A: Type} p (l1 l2: seq A),
  all p l2 ->
  dropWhileEnd p (l1 ++ l2) = dropWhileEnd p l1.
Proof.
  move => A p l1. elim : l1 => [//= l2 Hall | h t /= IH l2 Hall].
  - by apply /dropWhileEnd_nil.
  - by rewrite IH.
Qed.

Lemma dropWhileEnd_spec: forall {A: eqType} p (l: seq A) (x: A) res,
  dropWhileEnd p l = res <->
  (exists l1, l = res ++ l1 /\ forall x, x \in l1 -> p x) /\ (~~nilp res -> ~~p(last x res)).
Proof.
  move => A p l x. elim : l => [//= | h t /= IH res]; split.
  - move <-. split. by exists nil. by [].
  - move => [[l1 [Hl1 Hall]] Hlast]. move: Hl1 Hlast. by case : res.
  - case Hdrop: (nilp (dropWhileEnd p t)) => [//= | //=].
    + case Hph : ( p h) => [/= | /=].
      * move <-. rewrite /=. split. exists (h :: t). split. by [].
        have Ht: forall x, x \in t -> p x. apply all_in. apply /dropWhileEnd_nil. by apply /nilP.
        move => y. rewrite in_cons => /orP[/eqP Hyh | Hyt]. by subst. by apply Ht. by [].
      * case : res => [// | r1 t1 /= [Hhr1 Htl]]. rewrite Hhr1. move: Htl; rewrite IH => [[[l1 [Hl1 Hinl1]] Hlast]].
        subst. split. by exists l1. move => {Hdrop} {IH}. move: Hlast. case : t1 => [//= | //=].
        move => Htriv Htriv1. by rewrite Hph.
    + case : res => [//= | r1 t1 /= [Hhr1 Hdt1]]. rewrite Hhr1.
      move: Hdt1; rewrite IH => [[[l1 [Hl1 Hinl1]] Hlast]]. subst. split. by exists l1.
      move: Hdrop. rewrite dropWhileEnd_end. move : Hlast => {IH}. by case : t1. by rewrite all_in.
  - move => [[l1 [Hl1 Hinl1]] Hlast]. move: Hl1 Hlast. case : res => [//= Hl1 | r1 t1 /=[Hhr1 Ht]].
    + subst. move => Htriv. rewrite Hinl1. rewrite andbT.
      have->: nilp (dropWhileEnd p t). apply /nilP. apply /dropWhileEnd_nil. rewrite all_in.
      move => y Hy. apply Hinl1. by rewrite in_cons Hy orbT. by []. by rewrite in_cons eq_refl.
    + move => Hlast. subst. have Hdrop: dropWhileEnd p (t1 ++ l1) = t1. apply IH. split.
      by exists l1. move: Hlast {IH}. by case : t1.
      rewrite Hdrop. case Hnil: (nilp t1) => [/= | //=].
      * apply (elimT nilP) in Hnil. subst. move: Hlast; rewrite /= => Hpr1.
        have->: p r1 = false. apply (elimT negPf). by apply Hpr1. by [].
Qed.

Lemma dropWhileEnd_size: forall {A: eqType} (p: pred A) (l: seq A),
  size (dropWhileEnd p l) <= size l.
Proof.
  move => A pr l. elim : l => [//= | h t /= IH ].
  case : (nilp (dropWhileEnd pr t) && pr h) => [//|/=].
  by rewrite ltnS.
Qed.

Lemma dropWhileEnd_last: forall {A: eqType} (p: pred A) (l: seq A) (x: A),
  ~~ p (last x l) ->
  dropWhileEnd p l = l.
Proof.
  move => A pr l x Hlast. rewrite (dropWhileEnd_spec pr l x). split. exists nil. split. by rewrite cats0.
  by []. by rewrite Hlast.
Qed.

Require Import mathcomp.algebra.poly.

(** [remTrailZeroes] - used for polynomial construction*)
Section RemZeroes.

Variable F : fieldType.

Local Open Scope ring_scope.

Definition rem_trail_zero (s: seq F) : seq F := dropWhileEnd (fun x => x == 0) s.

Lemma rem_trail_zero_wf: forall s,
  last 1 (rem_trail_zero s) != 0.
Proof.
  move => s. rewrite /rem_trail_zero.
  have: (dropWhileEnd (eq_op^~ 0) s) = (dropWhileEnd (eq_op^~ 0) s) by [].
  rewrite (dropWhileEnd_spec _ _ 1) => [[[l1 [Hl1 Hinl1]] Hlast]].
  case Hdrop: (dropWhileEnd (eq_op^~ 0) s) => [/= | h t /=].
  - apply GRing.oner_neq0.
  - rewrite Hdrop in Hlast. by apply Hlast.
Qed.

Lemma rem_trail_zero_nth: forall s i,
  nth 0 s i = nth 0 (rem_trail_zero s) i.
Proof.
  move => s i. rewrite /rem_trail_zero.
  have: (dropWhileEnd (eq_op^~ 0) s) = (dropWhileEnd (eq_op^~ 0) s) by [].
  rewrite (dropWhileEnd_spec _ _ 1) => [[[l1 [Hl1 Hinl1]] Hlast]].
  rewrite {1}Hl1 nth_cat.
  case Hi: (i < size (dropWhileEnd (eq_op^~ 0) s)).
  - by [].
  - rewrite (@nth_default _ 0 (dropWhileEnd (eq_op^~ 0) s) i).
    case Hi': (i - size (dropWhileEnd (eq_op^~ 0) s) < size l1).
    + move: Hinl1. rewrite -all_in => /all_nthP Hall. apply /eqP. by apply Hall.
    + by rewrite nth_default // leqNgt Hi'.
    + by rewrite leqNgt Hi.
Qed.

Lemma rem_trail_zero_polyseq: forall (l: seq F),
  polyseq (Poly (rem_trail_zero l)) = (rem_trail_zero l).
Proof.
  move => l. have: polyseq (Poly (Polynomial (rem_trail_zero_wf l))) = rem_trail_zero l by rewrite polyseqK /=.
  by [].
Qed.

Lemma rem_trail_zero_size: forall (l: seq F),
  size (rem_trail_zero l) <= size l.
Proof.
  move => l. apply dropWhileEnd_size.
Qed.

End RemZeroes.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

(*i $Id: ZLt.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export ZMul.

Module ZOrderPropFunct (Import Z : ZAxiomsSig').
Include ZMulPropFunct Z.

(** Instances of earlier theorems for m == 0 *)

Theorem neg_pos_cases : forall n, n ~= 0 <-> n < 0 \/ n > 0.
Proof.
intro; apply lt_gt_cases.
Qed.

Theorem nonpos_pos_cases : forall n, n <= 0 \/ n > 0.
Proof.
intro; apply le_gt_cases.
Qed.

Theorem neg_nonneg_cases : forall n, n < 0 \/ n >= 0.
Proof.
intro; apply lt_ge_cases.
Qed.

Theorem nonpos_nonneg_cases : forall n, n <= 0 \/ n >= 0.
Proof.
intro; apply le_ge_cases.
Qed.

Ltac zinduct n := induction_maker n ltac:(apply order_induction_0).

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

Theorem lt_pred_l : forall n, P n < n.
Proof.
intro n; rewrite <- (succ_pred n) at 2; apply lt_succ_diag_r.
Qed.

Theorem le_pred_l : forall n, P n <= n.
Proof.
intro; apply lt_le_incl; apply lt_pred_l.
Qed.

Theorem lt_le_pred : forall n m, n < m <-> n <= P m.
Proof.
intros n m; rewrite <- (succ_pred m); rewrite pred_succ. apply lt_succ_r.
Qed.

Theorem nle_pred_r : forall n, ~ n <= P n.
Proof.
intro; rewrite <- lt_le_pred; apply lt_irrefl.
Qed.

Theorem lt_pred_le : forall n m, P n < m <-> n <= m.
Proof.
intros n m; rewrite <- (succ_pred n) at 2.
symmetry; apply le_succ_l.
Qed.

Theorem lt_lt_pred : forall n m, n < m -> P n < m.
Proof.
intros; apply <- lt_pred_le; now apply lt_le_incl.
Qed.

Theorem le_le_pred : forall n m, n <= m -> P n <= m.
Proof.
intros; apply lt_le_incl; now apply <- lt_pred_le.
Qed.

Theorem lt_pred_lt : forall n m, n < P m -> n < m.
Proof.
intros n m H; apply lt_trans with (P m); [assumption | apply lt_pred_l].
Qed.

Theorem le_pred_lt : forall n m, n <= P m -> n <= m.
Proof.
intros; apply lt_le_incl; now apply <- lt_le_pred.
Qed.

Theorem pred_lt_mono : forall n m, n < m <-> P n < P m.
Proof.
intros; rewrite lt_le_pred; symmetry; apply lt_pred_le.
Qed.

Theorem pred_le_mono : forall n m, n <= m <-> P n <= P m.
Proof.
intros; rewrite <- lt_pred_le; now rewrite lt_le_pred.
Qed.

Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m.
Proof.
intros n m; now rewrite (pred_lt_mono (S n) m), pred_succ.
Qed.

Theorem le_succ_le_pred : forall n m, S n <= m <-> n <= P m.
Proof.
intros n m; now rewrite (pred_le_mono (S n) m), pred_succ.
Qed.

Theorem lt_pred_lt_succ : forall n m, P n < m <-> n < S m.
Proof.
intros; rewrite lt_pred_le; symmetry; apply lt_succ_r.
Qed.

Theorem le_pred_lt_succ : forall n m, P n <= m <-> n <= S m.
Proof.
intros n m; now rewrite (pred_le_mono n (S m)), pred_succ.
Qed.

Theorem neq_pred_l : forall n, P n ~= n.
Proof.
intro; apply lt_neq; apply lt_pred_l.
Qed.

Theorem lt_n1_r : forall n m, n < m -> m < 0 -> n < -(1).
Proof.
intros n m H1 H2. apply -> lt_le_pred in H2.
setoid_replace (P 0) with (-(1)) in H2. now apply lt_le_trans with m.
apply <- eq_opp_r. now rewrite opp_pred, opp_0.
Qed.

End ZOrderPropFunct.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require HighOrd.
Require bool.Bool.
Require map.Map.

(* Why3 assumption *)
Definition set (a:Type) := a -> bool.

(* Why3 assumption *)
Definition mem {a:Type} {a_WT:WhyType a} (x:a) (s:a -> bool) : Prop :=
  ((s x) = true).

(* Why3 assumption *)
Definition empty {a:Type} {a_WT:WhyType a} : a -> bool :=
  fun (us:a) => false.

(* Why3 assumption *)
Definition is_empty {a:Type} {a_WT:WhyType a} (s:a -> bool) : Prop :=
  forall (x:a), ~ (mem x s).

Parameter union:
  forall {a:Type} {a_WT:WhyType a}, (a -> bool) -> (a -> bool) -> a -> bool.

Axiom Union_def :
  forall {a:Type} {a_WT:WhyType a},
  forall (s1:a -> bool) (s2:a -> bool), forall (x:a),
  (((union s1 s2) x) = (Init.Datatypes.orb (s1 x) (s2 x))).

Parameter inter:
  forall {a:Type} {a_WT:WhyType a}, (a -> bool) -> (a -> bool) -> a -> bool.

Axiom Inter_def :
  forall {a:Type} {a_WT:WhyType a},
  forall (s1:a -> bool) (s2:a -> bool), forall (x:a),
  (((inter s1 s2) x) = (Init.Datatypes.andb (s1 x) (s2 x))).

Parameter diff:
  forall {a:Type} {a_WT:WhyType a}, (a -> bool) -> (a -> bool) -> a -> bool.

Axiom Diff_def1 :
  forall {a:Type} {a_WT:WhyType a},
  forall (s1:a -> bool) (s2:a -> bool), forall (x:a),
  (((diff s1 s2) x) =
   (Init.Datatypes.andb (s1 x) (Init.Datatypes.negb (s2 x)))).

(* Why3 assumption *)
Definition equal {a:Type} {a_WT:WhyType a} (s1:a -> bool) (s2:a -> bool) :
    Prop :=
  forall (x:a), ((s1 x) = (s2 x)).

Axiom Equal_is_eq :
  forall {a:Type} {a_WT:WhyType a},
  forall (s1:a -> bool) (s2:a -> bool), (equal s1 s2) -> (s1 = s2).

(* Why3 assumption *)
Definition subset {a:Type} {a_WT:WhyType a} (s1:a -> bool) (s2:a -> bool) :
    Prop :=
  forall (x:a), (mem x s1) -> mem x s2.

Parameter complement:
  forall {a:Type} {a_WT:WhyType a}, (a -> bool) -> a -> bool.

Axiom Complement_def :
  forall {a:Type} {a_WT:WhyType a},
  forall (s:a -> bool), forall (x:a),
  (((complement s) x) = (Init.Datatypes.negb (s x))).


Module Dictionary.

Add LoadPath "../Basics".
Add LoadPath "../Induction".
Require Import EnumTypes.
Require Import Induction.
Require Import NamingCases.
Require Import Lists.
Require Import Reasoning.
Require Import Options.

(** Definition of a simple [dictionary] type *)
Inductive dictionary : Type :=
   | empty : dictionary
   | record : nat -> nat -> dictionary -> dictionary.

(** An [insert] function for the dictionary *)
Definition insert (key value : nat) (d : dictionary) : dictionary :=
   (record key value d).

(** A [find] function to search for a certain [key] *)
Fixpoint find (key : nat) (d: dictionary) : natoption :=
   match d with
   | empty => None
   | record k v d' => if (beq_nat key k)
                      then (Some v)
                      else (find key d')
   end.

(** EXERCISE [*]: Complete the following proof. *)
Theorem dictionary_invariant1' : forall (d:dictionary) (k v : nat),
   (find k (insert k v d)) = Some v.

Proof.
   intros d k v. simpl. rewrite -> beq_nat_refl. reflexivity. Qed.

(** EXERCISE [*]: Complete the following proof. *)
Theorem dictionary_invariant2' : forall (d:dictionary) (m n o:nat),
   beq_nat m n = false -> find m d = find m (insert n o d).

Proof.
   intros d m n o.
   intro H. simpl. rewrite -> H. reflexivity. Qed.

End Dictionary.


(*
Copyright © 2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Require Export CoRN.metric2.ProductMetric.
Require Export CoRN.metric2.Complete.

Set Implicit Arguments.

Section CompleteProduct.
(**
*** Completion of product spaces.
This section develops the strong monad properties of the Completion
operation with respect to the product operation.
*)
Variable X Y:MetricSpace.
Let XY := ProductMS X Y.

(** The projection operations are uniformly continuous *)
Lemma fst_uc : is_UniformlyContinuousFunction (fun p:XY => fst p) Qpos2QposInf.
Proof.
 intros e a b [H _].
 assumption.
Qed.

Local Open Scope uc_scope.

Definition pi1 : XY --> X :=
Build_UniformlyContinuousFunction fst_uc.

Lemma snd_uc : is_UniformlyContinuousFunction (fun p:XY => snd p) Qpos2QposInf.
Proof.
 intros e a b [_ H].
 assumption.
Qed.

Definition pi2 : XY --> Y :=
Build_UniformlyContinuousFunction snd_uc.

Definition Cfst_raw (p:Complete XY) (e:QposInf) : X :=
(fst (approximate p e)).

Definition Csnd_raw (p:Complete XY) (e:QposInf) : Y :=
(snd (approximate p e)).

Lemma Cfst_prf : forall p, is_RegularFunction (@ball X) (Cfst_raw p).
Proof.
 intros p e1 e2.
 destruct (regFun_prf p e1 e2).
 auto.
Qed.

Lemma Csnd_prf : forall p, is_RegularFunction (@ball Y) (Csnd_raw p).
Proof.
 intros p e1 e2.
 destruct (regFun_prf p e1 e2).
 auto.
Qed.

Definition Cfst_fun (p:Complete XY) : Complete X :=
Build_RegularFunction (Cfst_prf p).

Definition Csnd_fun (p:Complete XY) : Complete Y :=
Build_RegularFunction (Csnd_prf p).

Lemma Cfst_uc : is_UniformlyContinuousFunction Cfst_fun Qpos2QposInf.
Proof.
 intros e a b H e1 e2.
 destruct (H e1 e2).
 auto.
Qed.

Lemma Csnd_uc : is_UniformlyContinuousFunction Csnd_fun Qpos2QposInf.
Proof.
 intros e a b H e1 e2.
 destruct (H e1 e2).
 auto.
Qed.

Definition Cfst : Complete XY --> Complete X :=
Build_UniformlyContinuousFunction Cfst_uc.

Definition Csnd : Complete XY --> Complete Y :=
Build_UniformlyContinuousFunction Csnd_uc.

(** The pairing function is uniformly continuous *)
Lemma pair_uc_l : forall y:Y, @is_UniformlyContinuousFunction X XY (fun x => (x,y)) Qpos2QposInf.
Proof.
 intros y e a b H.
 split; auto.
 apply ball_refl.
 apply QposMinMax.Qpos_nonneg.
Qed.

Lemma pair_uc_r : forall x:X, @is_UniformlyContinuousFunction Y XY (fun y => (x,y)) Qpos2QposInf.
Proof.
 intros x e a b H.
 split; auto.
 apply ball_refl.
 apply QposMinMax.Qpos_nonneg.
Qed.

(** C(X*Y) is isomorphic to (C X)*(C Y) *)
Definition Couple_raw (p: ProductMS (Complete X) (Complete Y)) (e:QposInf): XY :=
(approximate (fst p) e,approximate (snd p) e).

Lemma Couple_prf : forall p, is_RegularFunction (@ball XY) (Couple_raw p).
Proof.
 intros [p1 p2] e1 e2.
 split; simpl; apply regFun_prf.
Qed.

Definition Couple_fun (p: ProductMS (Complete X) (Complete Y)) : Complete XY :=
Build_RegularFunction (Couple_prf p).

Lemma Couple_uc : is_UniformlyContinuousFunction Couple_fun Qpos2QposInf.
Proof.
 intros e a b [Hl Hr] e1 e2.
 split; simpl; auto.
Qed.

Definition Couple : (ProductMS (Complete X) (Complete Y)) --> (Complete (ProductMS X Y)) :=
Build_UniformlyContinuousFunction Couple_uc.

Lemma CoupleCorrect1 : forall p,
msp_eq (Couple ((Cfst p), (Csnd p))) p.
Proof.
 intros p e1 e2.
 rewrite Qplus_0_r.
 destruct (regFun_prf p e1 e2).
 split; simpl; auto.
Qed.

Lemma CoupleCorrect2 : forall p q,
msp_eq (Cfst (Couple (p,q))) p.
Proof.
 intros p q e1 e2.
 rewrite Qplus_0_r.
 apply (regFun_prf p e1 e2).
Qed.

Lemma CoupleCorrect3 : forall p q,
msp_eq (Csnd (Couple (p,q))) q.
Proof.
 intros p q e1 e2.
 rewrite Qplus_0_r.
 apply (regFun_prf q e1 e2).
Qed.

End CompleteProduct.

(* begin hide *)
Arguments Couple {X Y}.
Arguments Cfst {X Y}.
Arguments Csnd {X Y}.
(* end hide *)


Require Export Iron.Language.SystemF.Ty.

(* Type enviroments *)
Definition tyenv := list ty.
Hint Unfold tyenv.

(* Lift type indices in type environments. *)
Definition liftTE d te    := map (liftTT d) te.
Hint Unfold liftTE.

(* Substitution of Types in Type Environments. *)
Definition substTE d t te := map (substTT d t) te.
Hint Unfold substTE.

(********************************************************************)
(* The following lemmas as similar to the ones in Ty.v,
   except that we've applied them to entire type environments.
 *)

Lemma liftTE_liftTE
 :  forall n n' te
 ,  liftTE n              (liftTE (n + n') te)
 =  liftTE (1 + (n + n')) (liftTE n te).
Proof.
 intros. induction te.
  auto.
  unfold liftTE.
   simpl. rewrite liftTT_liftTT.
   unfold liftTE in IHte. rewrite IHte. auto.
Qed.

Lemma substTE_liftTE
 :  forall d te t2
 ,  substTE d t2 (liftTE d te) = te.
Proof.
 intros.
 unfold substTE.
 unfold liftTE.
 rewrite map_map.
 induction te.
  auto.
  simpl.
   unfold compose. rewrite substTT_liftTT.
   unfold compose in IHte. rewrite IHte. auto.
Qed.

Lemma liftTE_substTE
 :  forall n n' t2 te
 ,  liftTE n (substTE (n + n') t2 te)
 =  substTE (1 + n + n') (liftTT n t2) (liftTE n te).
Proof.
 intros. induction te.
  auto.
  unfold substTE. unfold liftTE.
   simpl. rewrite liftTT_substTT.
   unfold liftTE in IHte.
   unfold substTE in IHte. rewrite IHte. auto.
Qed.


(**
----
_This file is part of_

----
*** A Formal Definition of JML in Coq #
# and its Application to Runtime Assertion Checking
Ph.D. Thesis by Hermann Lehner
----
Online available at #jmlcoq.info#

Authors:
  - Hermann Lehner
  - David Pichardie (Bicolano)
  - Andreas Kaegi (Syntax Rewritings, Implementation of ADTs)

Copyright 2011 Hermann Lehner

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

----
*)

From Coq Require Import ZArith.

Definition Peq x y :=
 match Pcompare x y Eq with
 | Eq => true
 | _ => false
 end.

Lemma Peq_spec : forall x y, if Peq x y then x = y else x <> y.
Proof.
 unfold Peq;intros x y.
 generalize (refl_equal (Pcompare x y Eq));pattern (Pcompare x y Eq) at -1;
  case (Pcompare x y Eq);intros.
 apply Pcompare_Eq_eq;trivial.
 intros Heq;rewrite Heq in H;rewrite Pcompare_refl in H;discriminate.
 intros Heq;rewrite Heq in H;rewrite Pcompare_refl in H;discriminate.
Qed.

Definition Neq x y :=
 match x, y with
 | N0, N0 => true
 | Npos x, Npos y => Peq x y
 | _, _ => false
 end.

Lemma Neq_spec : forall x y, if Neq x y then x = y else x <> y.
Proof.
 destruct x;destruct y;simpl;trivial;try (intro; discriminate).
 generalize (Peq_spec p p0);destruct (Peq p p0);unfold not;intros;subst;trivial.
 injection H0;trivial.
Qed.

Lemma Zeq_spec : forall (x y:Z), if Zeq_bool x y then x = y else x<>y.
Proof.
 unfold Zeq_bool; intros.
 case_eq (x ?= y)%Z.
 - apply Z.compare_eq_iff.
 - intro.
   rewrite Z.compare_lt_iff in H.
   auto with zarith.
 - intro.
   rewrite Z.compare_gt_iff in H.
   auto with zarith.
Qed.

Definition nat_of_N (n : N) : nat := match n with
  | N0 => 0
  | (Npos p) => nat_of_P p
end.

Definition N_of_nat n :=
  match n with
  | O => N0
  | S n => Npos (P_of_succ_nat n)
  end.

Lemma nat_of_N_bij1 :
    forall v, nat_of_N (N_of_nat v) = v.
Proof.
 intros [|n];simpl. reflexivity.
 apply nat_of_P_o_P_of_succ_nat_eq_succ.
Qed.

Lemma nat_of_N_bij2 : forall n, N_of_nat (nat_of_N n) = n.
Proof.
 intros [|p];simpl. reflexivity.
 assert (exists m, nat_of_P p = S m).
 induction p.
  rewrite nat_of_P_xI;eauto.
  rewrite nat_of_P_xO.
  destruct IHp as (m, Heq);rewrite Heq.
  simpl;eauto.
  unfold nat_of_P;simpl. eauto.
  destruct H as (m,Heq);rewrite Heq;simpl.
  assert (H:=pred_o_P_of_succ_nat_o_nat_of_P_eq_id p).
  rewrite <- H;rewrite Heq.
  simpl.  rewrite Pos.pred_succ. trivial.
Qed.

Definition Npred x :=
 match x with
 | N0 => N0
 | Npos xH => N0
 | Npos p => Npos (Pos.pred p)
 end.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e192m2e64m1_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e213m3_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e226m5_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e216m2e108m1_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


From Undecidability.L Require Import LTactics.
Require Import Undecidability.Shared.Libs.PSL.Vectors.Vectors.
Require Import Vector List.
Import ListNotations.
Import VectorNotations.
Import L_Notations.

Fixpoint many_lam k s := match k with 0 => s | S k => lam (many_lam k s) end.

Lemma subst_many_lam k n u s :
  subst (many_lam k s) n u = many_lam k (subst s (k + n) u).
Proof.
  induction k in n |- *; cbn.
  - reflexivity.
  - f_equal. rewrite IHk. repeat f_equal. lia.
Qed.

Fixpoint many_app k s (v : Vector.t term k) :=
    match v with
    | Vector.nil => s
    | Vector.cons x _ v => many_app (L.app s x) v
    end.

Lemma subst_many_app k (v : Vector.t term k) n u s :
  subst (many_app s v) n u = many_app (subst s n u) (Vector.map (fun s => subst s n u) v).
Proof.
  induction v in s |- *; cbn.
  - reflexivity.
  - now rewrite IHv.
Qed.

Lemma equiv_many_app_L k (v : Vector.t term k) s t :
  s == t -> many_app s v == many_app t v.
Proof.
  induction v in s, t |- *; intros H; cbn.
  - eassumption.
  - eapply IHv. now rewrite H.
Qed.

Definition many_vars k := (tabulate (n := k) (fun i => k - S (proj1_sig (Fin.to_nat i)))).

Lemma tabulate_ext {X} k f1 f2 :
  (forall i, f1 i = f2 i :> X) -> tabulate (n := k) f1 = tabulate f2.
Proof.
  intros H. induction k in f1, f2, H |- *; cbn.
  - reflexivity.
  - f_equal; eauto.
Qed.

Lemma many_vars_S n :
  many_vars (S n) = n :: many_vars n.
Proof.
  cbn. f_equal. unfold many_vars. lia. eapply tabulate_ext. intros i. destruct Fin.to_nat as [i_ Hi].
  reflexivity.
Qed.

Fixpoint many_subst {k} s n (v : Vector.t term k) :=
  match v with
  | [] => s
  | Vector.cons u k v => many_subst (subst s (n + k) u) n v
  end.

Lemma beta_red s t t' : lambda t -> t' == subst s 0 t -> (lam s) t == t'.
Proof.
  intros [u ->] ->. repeat econstructor.
Qed.

Lemma many_beta k (v : Vector.t term k) s :
  (forall x, Vector.In x v -> proc x) ->
  many_app (many_lam k s) v == many_subst s 0 v.
Proof.
  induction v in s |- *; cbn; intros Hv.
  - reflexivity.
  - rewrite equiv_many_app_L. 2:{ eapply beta_red. eapply Hv. econstructor. reflexivity. }
    rewrite subst_many_lam. replace (n + 0) with n by lia. rewrite IHv. reflexivity.
    intros. eapply Hv. now econstructor.
Qed.

Lemma many_subst_app (s t : term) {k} n (v : Vector.t term k) :
  many_subst (s t) n v = (many_subst s n v) (many_subst t n v).
Proof.
  induction v in n, s, t |- *.
  - reflexivity.
  - cbn. now rewrite IHv.
Qed.

Lemma many_subst_many_app (s : term) {k} n (ts v : Vector.t term k) :
  many_subst (many_app s ts) n v = many_app (many_subst s n v) (Vector.map (fun t => many_subst t n v) ts).
Proof.
  induction v in n, s, ts |- *.
  - cbn. revert ts. apply case0. reflexivity.
  - cbn. apply (caseS' ts). cbn. intros.
    rewrite subst_many_app, IHv. cbn. rewrite many_subst_app.
    now rewrite Vector.map_map.
Qed.

Lemma many_subst_closed (s : term) {k} n (v : Vector.t term k) :
  closed s -> many_subst s n v = s.
Proof.
  induction v in n, s |- *.
  - reflexivity.
  - cbn. intros H. rewrite H. now eapply IHv.
Qed.

Lemma many_var_in a k : Vector.In a (many_vars k) -> a < k.
Proof.
  induction k.
  - inversion 1.
  - intros Ha. rewrite many_vars_S in Ha. inv Ha.
    + lia.
    + transitivity k. 2:lia. eapply IHk. eapply Eqdep_dec.inj_pair2_eq_dec in H2. subst. eauto. eapply nat_eq_dec.
Qed.


Require Import ssreflect ssrbool eqtype ssrnat ssrfun.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* error 2 *)

Goal (exists f: Set -> nat, f nat = 0).
Proof. set (f:= fun  _:Set =>0). by exists f. Qed.

Goal (exists f: Set -> nat, f nat = 0).
Proof. set f := (fun  _:Set =>0). by exists f. Qed.


(* WARNING : Not to be compiled!!!

This defines operations on polynomials defined as Pol1 Coef given

Coef:Set
cdeg : Coef -> N
c0 : coef
c1 : Coef
cadd : Cooef -> Coef -> Coef
cmul : Cooef -> Coef -> Coef
copp : Coef -> Coef
csub : Coef -> Coef -> Coef
czero_test : Cof -> bool
cpow : Coef -> N -> Coef

and an underlying Rat_structure, this means

cof_Rat : Rat -> Coef
cis_Rat : Coef -> bool
cof_pos:positive -> Coef

*)
 Notation  "x # y" := (MkRat x y)(at level 20, no associativity).

 Notation "x // y" := (cdiv x y) (at level 40, left associativity).

 (** Builds a Pol from a Rat *)
 Definition Pol_of_Rat(r:Rat) := Pc (cof_Rat r).

 (** Builds a constant pol from a positive **)
 Definition Pol_of_pos(p:positive):Pol:= Pc (cof_Rat (rof_pos p)).

 (** Cst pol from a rational **)
 Definition  Pol_mkPc(c:Rat):= Pc (cof_Rat c).

(** Truncations of P:truncates if the leading coef is not a base cst **)
 Definition Pol_trunc(P:Pol) :=
   let f:=
     fix Poln_trunc(P:Pol)(tlist:list Pol)(clist:list Coef){struct P}:(list Pol)*(list Coef) :=
       match P with
	 |Pc c =>
	   if (cis_Rat c) then ((P :: tlist), clist) else ((P :: (Pc c0) :: tlist), c::clist)
	 |PX Q i c => let (tres,cres):= Poln_trunc Q tlist clist in
	   (map (fun x => (mkPX  x i c)) tres, cres)
       end in
       f P nil nil.

 (**************************************************************)
 (***********         Division (pseudo)         ****************)
 (**************************************************************)

  (** division:like an euclidian division, but if the division over coef
  fails, returns 0*)
(* patch 12/07*)

 Definition Pol_div_cst :=
   fix Pol1_div_cst(A:Pol)(q:Coef){struct A}: Pol:=
     if (Pol_zero_test A) then P0
     else
     match A with
       |Pc a => Pc (a // q)
       |PX P i p =>
	 let P':= (Pol1_div_cst P q) in
	 if (Pol_zero_test P') then P0 else
	   if czero_test p then PX P' i p else
	     let p':= p // q in
	       if czero_test p' then P0 else
		 PX P' i p'
     end.

   (*auxiliary division of RX^i by D.invariant :
    -- deg R < deg D
    -- R <> 0
    -- D is not constant *)
 Definition Pol_div_aux(D:Pol):=
   let (dd, cd) := Pol_deg_coefdom D in
     fix Pol_div_aux(R:Pol)(i:positive){struct i}:Pol*Pol:=
       let (dr,cr) := (Pol_deg_coefdom R) in
       	 match (Ncompare (dr + (Npos i)) dd) with
	   |Lt => (Pc c0, PX R i c0)
	   | _  =>
	     match i with
	       | xH => (Pc (cr // cd), (mkPX R xH c0) - (Pol_mul_Rat D (cr//cd)))
	       | xO p =>
		 let (Q1, R1) := (Pol_div_aux R p) in
		 let (dR1, cR1):=(Pol_deg_coefdom R1) in
		   if (czero_test cR1) then (mkPX Q1 p c0, Pc c0)
		     else
		       let (Q2, R2):=(Pol_div_aux R1 p) in
			 ((mkPX Q1 p c0) + Q2, R2)
	       | xI p =>
		 let (Q1, R1):=(Pol_div_aux R p) in
		 let (dR1, cR1):=Pol_deg_coefdom R1 in
		   if (czero_test cR1) then
		     ((mkPX Q1 (Psucc p) c0), Pc c0)
		     else
		       let (Q2, R2) := (Pol_div_aux R1 p) in
		       let (dr2, cr2) := (Pol_deg_coefdom R2) in
			 if (czero_test cr2) then
			   ((mkPX Q1 (Psucc p) c0)+(mkPX Q2 xH c0), Pc c0)
			   else
			     match (Ncompare (Nsucc dr2) dd) with
			       | Lt =>
				 ((mkPX Q1 (Psucc p) c0)+(mkPX Q2 xH c0), mkPX R2 xH c0)
			       | _ =>
				 let quo := (mkPX Q1 (Psucc p) c0)+ (mkPX Q2 xH c0)+(Pc (cr2//cd)) in
        		         let rem := (mkPX R2 xH c0) - (Pol_mul_Rat D (cr2//cd)) in
				   (quo,rem)
			     end
	     end
       	 end.

  (** division of polynomials with coef in Coef:
  - as usual arguments are supposed to be normalized
  - div_euclide A B = (Q,R) with  A = BQ ++ R and
	--either deg(R)< deg(B)
	-- or deg(R)=deg(B)=0 and R != P R0
	-- Q and R are normalized
  ## non trivial case :
  if AX^i +a is to be divided by B, with  A = PQ1 + c1 and deg(c1)<deg(B)
  then AX+a=(BQ1)X^i + c1X^i +a and :
    - either deg (c1X^i +a) < deg (B),it ok : Q = X^i*Q1 and R = c1X^i + a
    - or deg (c1X^i +a) >= deg (B) and  Q = (X^i*Q1+Q2) et R = R2 + a
  where (Q2, R2) = div_aux B db cb c1 i i.e. c1X^i = Q2B ++2
  ## poly returned are normalized as soon as args are normalized
  **)

 (** First division by a non constant polynomial **)

 Definition Pol_euclide_div_PX(B:Pol):=
   let (db,cb) := Pol_deg_coefdom B in
     fix Pol_euclide_div_PX (A :Pol):Pol*Pol :=
       match A with
     	 |Pc a => (Pc c0, Pc a)
     	 |PX P i p =>
       	   let (Q1, R1):=Pol_euclide_div_PX P in
	   let (dr, r) := Pol_deg_coefdom R1 in
	     match (Pol_zero_test R1),(Ncompare (Nplus (Npos i) dr) db) with
	       |true, _ => (mkPX Q1 i c0, Pc p)
	       | _ , Lt => (mkPX Q1 i c0, mkPX R1 i p)
	       | _ , _ => let (Q2, R2) := (Pol_div_aux B R1 i) in
		 ((mkPX Q1 i c0)+Q2, R2 + Pc p)
	     end
       end.

 (** General division function **)
 Definition Pol_euclide_div(A B:Pol):Pol*Pol :=
   match B with
     |Pc q => (Pol_div_cst A q, Pc c0)
     |_ => (Pol_euclide_div_PX B A)
   end.

 (** Only the quotient **)
 Definition Pol_div(A B:Pol):Pol:= fst (Pol_euclide_div A B).

  (************************************************************)
  (***          Subresultant polynomials                     **)
  (************************************************************)

  (** Notations are the ones of BPR **)

  (** q to the n*(n+1)/2 **)
 Definition sum_pow(q:Coef)(n:N):Coef :=
   match n with
     |N0 => c1
     |Npos p =>
       match p with
	 |xH => q
	 |xO p' => cpow q (Npos (Pmult p' (Psucc p)))
	 |xI p' => cpow q (Npos (Pmult (Psucc p') p))
       end
   end.

  (** kth subresultant coefficient **)
 Definition Pol_subres_aux (j k:N)(q q':Coef): Coef:=
   let t := (Npred (Nminus j k)) in
     (sum_pow (-- c1) t)**(cpow (q // q') t)** q.

  (*next polynomial in the sequence,after ASRi_1 and SRj_1 and arguments
      for the possible next step of computations. if is nul, then B was
      the last poly of the sequence. SRj_1 is not zero*)

 Definition Pol_next_subres(SRi_1 SRj_1:Pol)(srj:Coef)(i j:N):
   (uple4 Pol Coef N N) :=
   let (k, dom_srj_1) := (Pol_deg_coefdom SRj_1) in
   let (d, dom_sri_1) := (Pol_deg_coefdom SRi_1) in
   let next_SR := fun x:Coef =>
     -(Pol_div_cst
       (snd (Pol_euclide_div (Pol_mul_Rat SRi_1 x) SRj_1))
       (srj **  dom_sri_1)) in
     match (Ncompare k  (Npred j)) with
       |Eq =>
	 let srj_1 := dom_srj_1 in
	   (Four (next_SR (cpow dom_srj_1 2)) dom_srj_1 j k)
       |_ =>
	 let srk := (Pol_subres_aux j k dom_srj_1 srj) in
	   (Four (next_SR (dom_srj_1 **  srk)) srk j k)
     end.

  (** next triple (S, U, V) in the rec relation for subresultants **)
 Definition Pol_next_subres_triple(Ti_1 Tj_1:(triple Pol Pol Pol))(srj:Coef)(i j:N):
   uple6 Pol Pol Pol Coef N N :=
   let (SRi_1,Ui_1,Vi_1) := Ti_1 in
   let (SRj_1,Uj_1, Vj_1) := Tj_1 in
   let (k, dom_srj_1) := (Pol_deg_coefdom SRj_1) in
   let (d, dom_sri_1) := (Pol_deg_coefdom SRi_1) in
   let next :=
     (fun x =>
       let (C,R) := (Pol_euclide_div (Pol_mul_Rat SRi_1 x) SRj_1) in
       (C, Pol_div_cst R ((-- srj)** dom_sri_1)) ) in
   let next_UV :=
     (fun (x:Coef)(Pi_1 Pj_1 C:Pol) =>
       (Pol_div_cst
	 ((C * Pj_1) - (Pol_mul_Rat Pi_1 x)) (srj** dom_sri_1))) in
     match (Ncompare k  (Npred j)) with
       |Eq =>
	 let y:= (cpow dom_srj_1 2) in
	 let (C,SR) := next y in
	   (Six
	     SR (next_UV y Ui_1 Uj_1 C) (next_UV y Vi_1 Vj_1 C) dom_srj_1 j k)
       |_ =>
	 let srk := (Pol_subres_aux j k dom_srj_1 srj) in
	 let y:= (dom_srj_1 **  srk) in
	 let (C,SR) := next y in
	   (Six
	     SR (next_UV y Ui_1 Uj_1 C) (next_UV y Vi_1 Vj_1 C) srk j k)
     end.

   (**Subres pol list, from A B, n ensures termination and will be deg P + 1**)

 Definition Pol_subres_list1:=
   fix Pol1_subres_list1(A B:Pol)(q:Coef)(i j:N)(m:nat){struct m}:list Pol :=
     match m with
       |O => nil
       |S n =>
	 let (SR,sr,k,l) := (Pol_next_subres A B q i j) in
	   if (Pol_zero_test SR) then nil
	     else   SR :: (Pol1_subres_list1 B SR sr k l n)
     end.

 Definition Pol_subres_list(A B:Pol) :=
   let p := Pol_deg A in
   let q := Pol_deg B in
   A :: B :: (Pol_subres_list1 A B c1 (p+1) p  (S (nat_of_N p))).

 Definition Pol_subres_coef_list(A B:Pol):=
   let dom := (fun x => Pol_dom x) in (* for impl args*)
   let res := Pol_subres_list A B in
     map dom res.

  (** Extented subresultants **)
 Definition Pol_ext_signed_subres_list :=
  fix Pol1_ext_signed_subres_list(T T':(triple Pol Pol Pol))(q:Coef)(i j:N)(m:nat)
    {struct m}:list (triple Pol Pol Pol) :=
    let (B,_,_):= T' in
      if (Pol_zero_test B) then nil
	else
	 match m with
	   |O => nil
	   |S n =>
	     let (next_SR,next_U,next_V,sr,k,l) := (Pol_next_subres_triple T T' q i j) in
	     let next_T := Tr next_SR next_U next_V in
     	       next_T :: (Pol1_ext_signed_subres_list T' next_T sr k l n)
	 end.

  (** extended signed subres chain *)
   Definition Pol_ext_signed_subres_chain(P Q:Pol) :=
	let (deg_p, dom_p) := Pol_deg_coefdom P in
   	let (deg_q, dom_q) := Pol_deg_coefdom Q in
	let Tp := Tr P P1 P0 in
	let Tq := Tr Q P0 P1 in
     	  Tp :: (Tq ::
    	    (Pol_ext_signed_subres_list
      	      Tp Tq  c1 deg_p (Npred deg_p) (S (nat_of_N deg_p)))).

   (** Gcd of P and Q : last subresultant dP>dQ **)

   (** For polys with different degrees **)
   Definition Pol_gcd_strict (P Q:Pol) :=
     let l := (Pol_subres_list P Q) in
     let SRj := (last_elem l Q) in
     let srj := Pol_dom SRj in
     let cP := Pol_dom P in
       Pol_div_cst (Pol_mul_Rat SRj cP) srj.

   Definition Pol_gcd(P Q:Pol) :=
     let (dP, cP):= Pol_deg_coefdom P in
     let (dQ,cQ) := Pol_deg_coefdom Q in
       match Ncompare dP dQ with
	 |Lt  => Pol_gcd_strict Q P
	 |Gt  => Pol_gcd_strict P Q
	 |Eq =>
           let next := ((Pol_mul_Rat Q cP) - (Pol_mul_Rat P cQ)) in
             match next with
              |Pc c0 => P
              |_ => Pol_gcd_strict P next
             end
       end.

   (** Triple gcd of P and Q, P/gcd, Q/gcd **)

   (** For polys with different degrees **)
   Definition Pol_gcd_gcd_free_strict (P Q:Pol) :=
     let cP := Pol_dom P in
     let (Tj, Tj_1):= two_last_elems (Pol_ext_signed_subres_chain P Q)
       ((Tr (Pc c0) (Pc c0) (Pc c0)),(Tr (Pc c0) (Pc c0) (Pc c0))) in
     let (SRj,_,_) := Tj in
     let srj := Pol_dom SRj in
     let (_,Uj_1,Vj_1) := Tj_1 in
     let cVj_1 := Pol_dom Vj_1 in
     let cUj_1 := Pol_dom Uj_1 in
       (Pol_div_cst (Pol_mul_Rat SRj cP) srj,
         Pol_div_cst (Pol_mul_Rat Vj_1 cP) cVj_1,
	 Pol_div_cst (Pol_mul_Rat Uj_1 cP) cUj_1).

  (*TODO virer les contenus constants?*)

   Definition Pol_gcd_gcd_free (P Q:Pol) :=
     match P, Q with
       |Pc p, Pc q =>
	 let (a,b) := cgcd_gcd_free p q in (Pc (snd a), Pc (snd a), Pc b)
       |_,_ =>
	 let (dQ,cQ):= Pol_deg_coefdom Q in
	 let (dP,cP):= Pol_deg_coefdom P in
	   match (Ncompare dP dQ) with
	     |Eq =>
	       let Next := (Pol_mul_Rat Q cP) - (Pol_mul_Rat P cQ) in
	       let (GCD_Q',Next'):= Pol_gcd_gcd_free_strict Q Next in
	       let (GCD,Q'):= GCD_Q' in
	       let cGCD := Pol_dom GCD in
	       let cQ' := Pol_dom Q' in
	       let cNext' := Pol_dom Next' in
	       let cNext := Pol_dom Next in
		 (GCD,
		   (Pol_mul_Rat Q' ((cGCD** cNext'** cP)// cNext)) -
		   (Pol_mul_Rat Next' ((cGCD** cQ')// cQ)),
		   Q')
	     |Gt  => Pol_gcd_gcd_free_strict P Q
	     |Lt  => Pol_gcd_gcd_free_strict Q P
	   end
     end.

   (** Square free part of a poly **)
 Definition Pol_square_free(P:Pol) := snd (fst (Pol_gcd_gcd_free P (Pol_deriv P))).

  (** Tests if P is a base cst **)
 Definition  Pol_is_base_cst(P:Pol):=
   match P with
     |Pc c => cis_Rat c
     |PX Q i c => false
   end.

  (** Prod and div by a rational, maps the rat operation over base coefs *)
 Definition Poln_op_base_cst (Op:Coef->Rat->Coef):=
   fix Poln_op_base_cst(P:Pol)(c:Rat){struct P}:Pol:=
     match P with
       |Pc p => Pc (Op p c)
       |PX Q i q => mkPX (Poln_op_base_cst Q c) i (Op q c)
     end.

 Definition Pol_mult_base_cst := Poln_op_base_cst cmult_base_cst.
 Definition Pol_div_base_cst :=Poln_op_base_cst cdiv_base_cst.

  (** Eval of a pol at a rational, returns a coef *)
 Definition Pol_partial_eval :=
   fix partial_eval(P:Pol)(c:Rat){struct P}:Coef:=
     match P with
       |Pc p => p
       |PX Q i q =>
	 (cmult_base_cst (partial_eval Q c) (rpow c (Npos i)))++q
     end.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e369m25_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


(* Banach-Tarski paradox. *)

Require Import Utf8 List Relations.
Import ListNotations.
Require Import Reals Nsatz.

Require Import Misc MiscReals Words Normalize Reverse Matrix Pset.

Definition same_orbit x y := ∃ el, (mat_of_path el * x)%vec = y.

Theorem same_orbit_refl : reflexive _ same_orbit.
Proof. now exists []; rewrite mat_vec_mul_id. Qed.

Theorem same_orbit_sym : symmetric _ same_orbit.
Proof.
intros p₁ p₂ (el, H); simpl in H.
exists (rev_path el).
revert p₁ p₂ H.
induction el as [| e]; intros; [ now rewrite mat_vec_mul_id in H |-* | ].
rewrite rev_path_cons, mat_of_path_app, mat_vec_mul_assoc.
apply IHel; rewrite <- H, <- mat_vec_mul_assoc.
rewrite <- mat_of_path_app, rev_path_single; simpl.
now rewrite mat_of_path_negf.
Qed.

Theorem same_orbit_trans : transitive _ same_orbit.
Proof.
intros p₁ p₂ p₃ (el₁, H₁) (el₂, H₂); simpl in H₁, H₂.
exists (el₂ ++ el₁).
now rewrite mat_of_path_app, mat_vec_mul_assoc, H₁, H₂.
Qed.

Add Parametric Relation : _ same_orbit
 reflexivity proved by same_orbit_refl
 symmetry proved by same_orbit_sym
 transitivity proved by same_orbit_trans
 as same_orbit_rel.

Definition equiv_same_orbit : equiv vector same_orbit :=
  conj same_orbit_refl (conj same_orbit_trans same_orbit_sym).

Definition not_in_fixpoints :=
  mkset (λ p, ∀ el, norm_list el ≠ [] → fold_right rotate p el ≠ p).

Theorem not_in_fixpoints_one_path : ∀ f p e₁ e₂ el el₂ el₁ el₃,
  p ∈ not_in_fixpoints
  → (mat_of_path el * p)%vec = f p
  → (mat_of_path el₁ * (f p))%vec = p
  → norm_list el = el₂ ++ [e₁]
  → norm_list el₁ = e₂ :: el₃
  → e₂ ≠ negf e₁
  → False.
Proof.
intros f p e₁ e₂ el el₂ el₁ el₃ Hnf Hel H₆ H₂ H₄ Hd.
rewrite rotate_rotate_norm in Hel, H₆.
rewrite <- Hel in H₆.
rewrite <- mat_vec_mul_assoc in H₆.
rewrite <- mat_of_path_app in H₆.
revert H₆.
rewrite <- rotate_vec_mul.
apply Hnf.
intros H.
apply norm_list_app_is_nil in H.
 rewrite H₄, H₂ in H.
 apply rev_path_eq_eq in H.
 rewrite rev_path_involutive, rev_path_app in H.
 apply not_eq_sym in Hd.
 now injection H.

 now rewrite norm_list_idemp.

 now rewrite norm_list_idemp.
Qed.

Definition orbit_selector := choice_function same_orbit.

Definition sphere r := mkset (λ '(V x y z), (x² + y² + z² = r²)%R).
Definition ball := mkset (λ '(V x y z), (x² + y² + z² <= 1)%R).

Theorem on_sphere_norm : ∀ p r, (0 ≤ r)%R → p ∈ sphere r ↔ ‖p‖ = r.
Proof.
intros (x, y, z) r Hr; simpl.
split; intros Hp.
 now rewrite Hp; apply sqrt_Rsqr.

 apply (f_equal Rsqr) in Hp.
 rewrite Rsqr_sqrt in Hp; [ easy | ].
 apply nonneg_sqr_vec_norm.
Qed.

Theorem in_its_sphere : ∀ v, v ∈ sphere ‖v‖.
Proof.
intros (x, y, z); simpl.
rewrite Rsqr_sqrt; [ easy | ].
apply nonneg_sqr_vec_norm.
Qed.

Theorem on_sphere_after_rotation : ∀ p m r,
  p ∈ sphere r
  → is_rotation_matrix m
  → (m * p)%vec ∈ sphere r.
Proof.
intros * His Hm.
destruct p as (x, y, z).
unfold sphere in His; simpl in His.
unfold sphere; simpl.
unfold is_rotation_matrix in Hm.
destruct Hm as (Hm, Hd).
unfold mat_det in Hd.
unfold mat_mul, mat_id in Hm; simpl in Hm.
injection Hm; clear Hm; intros H₁ H₂ H₃ H₄ H₅ H₆ H₇ H₈ H₉.
nsatz.
Qed.

Theorem in_ball_after_rotation : ∀ p m,
  p ∈ ball
  → is_rotation_matrix m
  → mat_vec_mul m p ∈ ball.
Proof.
intros * His Hrm.
destruct p as (x, y, z).
remember (V x y z) as p eqn:HP.
remember (x² + y² + z²)%R as r eqn:Hr; symmetry in Hr.
assert (Hos : p ∈ sphere (√ r)).
 subst p; simpl; rewrite Rsqr_sqrt; [ easy | subst r ].
 apply nonneg_sqr_vec_norm.

 pose proof on_sphere_after_rotation _ _ _ Hos Hrm as H.
 unfold ball in His.
 unfold sphere in H.
 unfold ball.
 subst p; simpl in *.
 now rewrite H, <- Hos.
Qed.

Theorem in_ball_after_rotate : ∀ p e,
  p ∈ ball
  → rotate e p ∈ ball.
Proof.
intros * His.
apply in_ball_after_rotation; [ easy | ].
apply rotate_is_rotation_matrix.
Qed.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqExt. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose     : Extension of Logic
  author      : ZhengPu Shi
  date        : 2023.02

*)

(** Good exercises for logic *)
Section exercise_forall_exist_not.

  (** These lemmas needn't axiom *)

  Let all_not_not_ex:
    forall (U : Type) (P : U -> Prop), (forall n : U, ~ P n) -> ~ (exists n : U, P n).
  Proof. intros. intro. destruct H0. specialize (H x). easy. Qed.

  Let ex_not_not_all: forall (U : Type) (P : U -> Prop),
      (exists n : U, ~ P n) -> ~ (forall n : U, P n).
  Proof. intros. intro. destruct H. specialize (H0 x). easy. Qed.

  (** These lemmas need axiom in Classic Logic *)

  Let reverse_proof : forall P Q : Prop, (~Q -> ~P) -> (P -> Q).
  Proof. Abort.

  Let not_ex_not_all:
    forall (U : Type) (P : U -> Prop), ~ (exists n : U, ~ P n) -> forall n : U, P n.
  Proof. Abort.

  Let not_ex_all_not:
    forall (U : Type) (P : U -> Prop), ~ (exists n : U, P n) -> forall n : U, ~ P n.
  Proof. Abort.

  Let not_all_ex_not: forall (U : Type) (P : U -> Prop),
      ~ (forall n : U, P n) -> exists n : U, ~ P n.
  Proof. Abort.

  Let not_all_not_ex: forall (U : Type) (P : U -> Prop),
      ~ (forall n : U, ~ P n) -> exists n : U, P n.
  Proof. Abort.

End exercise_forall_exist_not.


Require Export Category Functor NaturalTransformation.
Require Import Common Notations NatCategory.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Notation InitialCategory := (NatCategory 0) (only parsing).
Notation TerminalCategory := (NatCategory 1) (only parsing).

Class IsTerminalCategory (C : PreCategory)
      `{Contr (Object C)}
      `{forall s d, Contr (Morphism C s d)}.

Class IsInitialCategory (C : PreCategory)
  := initial_category_rect : forall P : Type, C -> P.

Instance trunc_initial_category `{IsInitialCategory C}
: IsHProp C
  := fun x y => initial_category_rect _ x.
Instance trunc_initial_category_mor `{IsInitialCategory C} x y
: Contr (Morphism C x y)
  := initial_category_rect _ x.

Instance is_initial_category_0 : IsInitialCategory 0 := Empty_rect.
Instance: IsTerminalCategory 1 | 0.
Instance: Contr (Object 1) | 0 := _.
Instance: Contr (Morphism 1 x y) | 0 := fun x y => _.
Instance default_terminal C {H H1} : @IsTerminalCategory C H H1 | 10.

Arguments initial_category_rect / .
Arguments is_initial_category_0 / .

Section Functors.
  Variable C : PreCategory.

  Definition FunctorToTerminal `{@IsTerminalCategory one Hone Hone'}
  : Functor C one
    := Build_Functor
         C one
         (fun _ => center _)
         (fun _ _ _ => center _)
         (fun _ _ _ _ _ => contr _)
         (fun _ => contr _).

  Definition FunctorFromTerminal `{@IsTerminalCategory one Hone Hone'} (c : C)
  : Functor one C
    := Build_Functor
         one C
         (fun _ => c)
         (fun _ _ _ => Identity c)
         (fun _ _ _ _ _ => symmetry _ _ (@IdentityIdentity _ _))
         (fun _ => idpath).

  Definition FunctorFromInitial `{@IsInitialCategory zero}
  : Functor zero C
    := Build_Functor
         zero C
         (fun x => initial_category_rect _ x)
         (fun x _ _ => initial_category_rect _ x)
         (fun x _ _ _ _ => initial_category_rect _ x)
         (fun x => initial_category_rect _ x).
End Functors.

Arguments FunctorToTerminal / .
Arguments FunctorFromTerminal / .
Arguments FunctorFromInitial / .

Definition FunctorTo1 C : Functor C 1
  := Eval simpl in FunctorToTerminal C.
Definition FunctorFrom1 C c : Functor 1 C
  := Eval simpl in FunctorFromTerminal C c.
Definition FunctorFrom0 C : Functor 0 C
  := Eval simpl in FunctorFromInitial C.

Notation "! x" := (FunctorFromTerminal _ x) : functor_scope.

Section FunctorsUnique.
  Context `{Funext}.

  Global Instance trunc_InitialCategoryFunction
         `{@IsInitialCategory zero} T
  : Contr (zero -> T) :=
    let x := {| center x := initial_category_rect _ x |} in x.
  Proof.
    intro y.
    apply path_forall; intro x.
    apply (initial_category_rect _ x).
  Defined.

  Variable C : PreCategory.

  Global Instance trunc_InitialCategoryFunctor
         `{@IsInitialCategory zero}
  : Contr (Functor zero C)
    := let x := {| center := FunctorFromInitial C |} in x.
  Proof.
    abstract (
        intros; apply Functor_eq'_sig;
        (exists (center _));
        apply path_forall; intro x;
        apply (initial_category_rect _ x)
      ).
  Defined.

  Global Instance trunc_ToInitialCategoryFunctor
         `{@IsInitialCategory zero}
  : IsHProp (Functor C zero).
  Proof.
    typeclasses eauto.
  Qed.

  Definition ToInitialCategoryFunctor_empty
             `{@IsInitialCategory zero}
             (F : Functor C zero)
  : IsInitialCategory C
    := fun P x => initial_category_rect P (F x).

  Global Instance trunc_TerminalCategoryFunctor
         `{@IsTerminalCategory one H0 H1}
  : Contr (Functor C one)
    := let x := {| center := FunctorToTerminal C |} in x.
  Proof.
    intros.
    exact (center _).
  Defined.
End FunctorsUnique.

Section NaturalTransformations.
  Variable C : PreCategory.

  Definition FromInitialCategoryNaturalTransformation
             `{@IsInitialCategory zero} (F G : Functor zero C)
  : NaturalTransformation F G
    := Build_NaturalTransformation
         F G
         (fun x => initial_category_rect _ x)
         (fun x _ _ => initial_category_rect _ x).

  Global Instance trunc_FromInitialCategoryNaturalTransformation
         `{Funext}
         `{@IsInitialCategory zero} (F G : Functor zero C)
  : Contr (NaturalTransformation F G)
    := let x := {| center := FromInitialCategoryNaturalTransformation F G |}
       in x.
  Proof.
    abstract (
        intros;
        apply NaturalTransformation_eq;
        intro x;
        exact (initial_category_rect _ x)
      ).
  Defined.

  Local Existing Instance ToInitialCategoryFunctor_empty.

  Global Instance trunc_ToInitialCategoryNaturalTransformation
         `{Funext}
         `{@IsInitialCategory zero}
         (F G : Functor zero C)
  : Contr (NaturalTransformation F G)
    := trunc_FromInitialCategoryNaturalTransformation F G.

  Definition TerminalCategoryNaturalTransformation
             `{@IsTerminalCategory one H0 H1} (F G : Functor C one)
  : NaturalTransformation F G
    := Build_NaturalTransformation
         F G
         (fun x => center _)
         (fun _ _ _ => path_contr _ _).

  Global Instance trunc_TerminalCategoryNaturalTransformation
         `{Funext}
         `{@IsTerminalCategory one H0 H1} (F G : Functor C one)
  : Contr (NaturalTransformation F G)
    := let x := {| center := TerminalCategoryNaturalTransformation F G |} in x.
  Proof.
    abstract (nt_eq; exact (contr _)).
  Defined.
End NaturalTransformations.


From cgraphs.lambdabar Require Export langtools.
From cgraphs.lambdabar Require Export langdef.

Module GV.

(* Expressions and values *)
(* ---------------------- *)

Inductive expr :=
  | Val : val -> expr
  | Var : string -> expr
  | Fun : string -> expr -> expr
  | App : expr -> expr -> expr
  | Unit : expr
  | Pair : expr -> expr -> expr
  | LetPair : expr -> expr -> expr
  | Sum : nat -> expr -> expr
  | MatchSum n : expr -> (fin n -> expr) -> expr
  | Fork : expr -> expr
  | Send : expr -> expr -> expr
  | Send' : val -> val -> expr (* We have dummy steps in the operational semantics to get a lockstep correspondence. *)
  | Send'' : val -> val -> expr (* This shows precisely which operations do administrative β reductions after compilation. *)
  | Send''' : val -> val -> expr
  | Send'''' : val -> val -> expr
  | Recv : expr -> expr
  | Close : expr -> expr
with val :=
  | FunV : string -> expr -> val
  | UnitV : val
  | PairV : val -> val -> val
  | SumV : nat -> val -> val
  | ChanV : nat -> val.

(* Operational semantics *)
(* --------------------- *)

Definition subst (x:string) (a:val) := fix rec e :=
  match e with
  | Val _ => e
  | Var x' => if decide (x = x') then Val a else e
  | Fun x' e => Fun x' (if decide (x = x') then e else rec e)
  | App e1 e2 => App (rec e1) (rec e2)
  | Unit => Unit
  | Pair e1 e2 => Pair (rec e1) (rec e2)
  | LetPair e1 e2 => LetPair (rec e1) (rec e2)
  | Sum n e => Sum n (rec e)
  | MatchSum n e1 e2 => MatchSum n (rec e1) (rec ∘ e2)
  | Fork e => Fork (rec e)
  | Send e1 e2 => Send (rec e1) (rec e2)
  | Send' v1 v2 => Send' v1 v2
  | Send'' v1 v2 => Send'' v1 v2
  | Send''' v1 v2 => Send''' v1 v2
  | Send'''' v1 v2 => Send'''' v1 v2
  | Recv e => Recv (rec e)
  | Close e => Close (rec e)
  end.

Inductive pure_step : expr -> expr -> Prop :=
  | Fun_step x e :
    pure_step (Fun x e) (Val $ FunV x e)
  | App_step x e a :
    pure_step (App (Val $ FunV x e) (Val a)) (subst x a e)
  | Unit_step :
    pure_step Unit (Val $ UnitV)
  | Pair_step v1 v2 :
    pure_step (Pair (Val v1) (Val v2)) (Val $ PairV v1 v2)
  | LetPair_step v1 v2 e:
    pure_step (LetPair (Val $ PairV v1 v2) e) (App (App e (Val v1)) (Val v2))
  | Sum_step n v :
    pure_step (Sum n (Val v)) (Val $ SumV n v)
  | MatchSum_step n (i : fin n) v es :
    pure_step (MatchSum n (Val $ SumV i v) es) (App (es i) (Val v))
  | Send'_step v1 v2 :
    pure_step (Send (Val v1) (Val v2)) (Send' v1 v2)
  | Send''_step v1 v2 :
    pure_step (Send' v1 v2) (Send'' v1 v2)
  | Send'''_step v1 v2 :
    pure_step (Send'' v1 v2) (Send''' v1 v2)
  | Send''''_step v1 v2 :
    pure_step (Send''' v1 v2) (Send'''' v1 v2).

Inductive ctx1 : (expr -> expr) -> Prop :=
  | Ctx_App_l e : ctx1 (λ x, App x e)
  | Ctx_App_r v : ctx1 (λ x, App (Val v) x)
  | Ctx_Pair_l e : ctx1 (λ x, Pair x e)
  | Ctx_Pair_r e : ctx1 (λ x, Pair e x)
  | Ctx_LetPair e : ctx1 (λ x, LetPair x e)
  | Ctx_Sum i : ctx1 (λ x, Sum i x)
  | Ctx_MatchSum n es : ctx1 (λ x, MatchSum n x es)
  | Ctx_Fork : ctx1 (λ x, Fork x)
  | Ctx_Send_l e : ctx1 (λ x, Send x e)
  | Ctx_Send_r e : ctx1 (λ x, Send e x)
  | Ctx_Recv : ctx1 (λ x, Recv x)
  | Ctx_Close : ctx1 (λ x, Close x).

Inductive ctx : (expr -> expr) -> Prop :=
  | Ctx_id : ctx id
  | Ctx_comp k1 k2 : ctx1 k1 -> ctx k2 -> ctx (k1 ∘ k2).

(* Buffers are represented as doubly linked lists in the heap. *)
(* When a buffer element has been used, it gets set to `Used`.
   THe `Used` marker is then deleted from the heap in a subsequent step.
   This maintains the lockstep correspondence.
   The Buf' and Buf'' are for the administrative β reductions that messenger threads do. *)
Inductive obj := Thread (e : expr) | Chan | Buf (c1 c2 : nat) (v : val) | Buf' (c1 c2 : nat) (v : val) | Buf'' (c1 c2 : nat) (v : val) | Used.
Definition cfg := gmap nat obj.

Inductive local_step : nat -> cfg -> cfg -> Prop :=
  | Pure_step i k e e' :
    ctx k -> pure_step e e' ->
    local_step i {[ i := Thread (k e) ]} {[ i := Thread (k e') ]}
  | Exit_step i v :
    local_step i {[ i := Thread (Val v) ]} ∅
  | Buf_done_step i :
    local_step i {[ i := Used ]} ∅
  | Fork_step i j n k v :
    i ≠ j -> i ≠ n -> j ≠ n -> ctx k ->
    local_step i {[ i := Thread (k (Fork (Val v))) ]}
                 {[ i := Thread (k (Val $ ChanV n));
                    j := Thread (App (Val v) (Val $ ChanV n));
                    n := Chan ]}
  | Send_step i j n k v c :
    i ≠ j -> i ≠ n -> j ≠ n -> ctx k ->
    local_step i {[ i := Thread (k (Send'''' (ChanV c) v)) ]}
                 {[ i := Thread (k (Val $ ChanV n));
                    j := Buf c n v;
                    n := Chan ]}
  | Buf'_step i n v c :
    local_step i {[ i := Buf c n v ]} {[ i := Buf' c n v ]}
  | Buf''_step i n v c :
    local_step i {[ i := Buf' c n v ]} {[ i := Buf'' c n v ]}
  | Recv_step i j n  k v c :
    i ≠ j -> i ≠ n -> j ≠ n -> ctx k ->
    local_step n {[ i := Thread (k (Recv (Val $ ChanV n)));
                    j := Buf'' n c v;
                    n := Chan ]}
                 {[ i := Thread (k $ Val (PairV (ChanV c) v));
                    j := Used ]}.

Inductive step : nat -> cfg -> cfg -> Prop :=
  | Frame_step ρ ρ' ρf i :
    ρ ##ₘ ρf -> ρ' ##ₘ ρf ->
    local_step i ρ ρ' -> step i (ρ ∪ ρf) (ρ' ∪ ρf).

Definition step' ρ ρ' := ∃ i, step i ρ ρ'.
Definition steps := rtc step'.

End GV.

Notation Let x e1 e2 := (App (Fun x e2) e1).
Notation Let' x e1 e2 := (App (Val $ FunV x e2) e1).
Notation Let2 x y e1 e2 e3 := (App (App (Val $ FunV x (Fun y e3)) e1) e2).

Fixpoint compile (e : GV.expr) : expr :=
  match e with
  | GV.Val v => Val $ compile_val v
  | GV.Var x => Var x
  | GV.Fun x e => Fun x (compile e)
  | GV.App e1 e2 => App (compile e1) (compile e2)
  | GV.Unit => Unit
  | GV.Pair e1 e2 => Pair (compile e1) (compile e2)
  | GV.LetPair e1 e2 => LetPair (compile e1) (compile e2)
  | GV.Sum n e => Sum n (compile e)
  | GV.MatchSum n e f => MatchSum n (compile e) (compile ∘ f)
  | GV.Fork e => Fork (compile e)
  | GV.Send e1 e2 =>
      Let2 "x" "y" (compile e1) (compile e2) (
          Fork (Fun "z" (App (Var "x") (Pair (Var "z") (Var "y"))))
      )
  | GV.Send' v1 v2 =>
      Let "y" (Val $ compile_val v2) (
        Fork (Fun "z" (App (Val $ compile_val v1) (Pair (Var "z") (Var "y"))))
      )
  | GV.Send'' v1 v2 =>
      Let' "y" (Val $ compile_val v2) (
        Fork (Fun "z" (App (Val $ compile_val v1) (Pair (Var "z") (Var "y"))))
      )
  | GV.Send''' v1 v2 =>
        Fork (Fun "z" (App (Val $ compile_val v1) (Pair (Var "z") (Val $ compile_val v2))))
  | GV.Send'''' v1 v2 =>
        Fork (Val $ FunV "z" (App (Val $ compile_val v1) (Pair (Var "z") (Val $ compile_val v2))))
  | GV.Recv e => App (compile e) (Val $ UnitV)
  | GV.Close e => App (compile e) (Val $ UnitV)
  end
with compile_val (v : GV.val) : val :=
  match v with
  | GV.FunV x e => FunV x (compile e)
  | GV.UnitV => UnitV
  | GV.PairV v1 v2 => PairV (compile_val v1) (compile_val v2)
  | GV.SumV n v => SumV n (compile_val v)
  | GV.ChanV n => BarrierV n
  end.

Definition compile_obj (o : GV.obj) : obj :=
  match o with
  | GV.Thread e => Thread (compile e)
  | GV.Chan => Barrier
  | GV.Buf c n v => Thread (App (Val $ FunV "z" (App (Val $ BarrierV c) (Pair (Var "z") (Val $ compile_val v)))) (Val $ BarrierV n))
  | GV.Buf' c n v => Thread (App (Val $ BarrierV c) (Pair (Val $ BarrierV n) (Val $ compile_val v)))
  | GV.Buf'' c n v => Thread (App (Val $ BarrierV c) (Val $ PairV (BarrierV n) (compile_val v)))
  | GV.Used => Thread (Val $ UnitV)
  end.

Definition compile_cfg (ρ : GV.cfg) : cfg := compile_obj <$> ρ.

Lemma compile_ctx k1 :
  GV.ctx k1 -> ∃ k2, ctx k2 ∧ ∀ e, compile (k1 e) = k2 (compile e).
Proof.
  induction 1; eauto using ctx.
  destruct IHctx as [k3 [Hk3 Heq]].
  destruct H; simpl; setoid_rewrite Heq.
  - eexists (λ x, App (k3 x) _). split; eauto.
    eapply (Ctx_comp (λ x, App x _)); eauto using ctx1.
  - eexists (λ x, App _ (k3 x)). split; eauto.
    eapply (Ctx_comp (λ x, App _ x)); eauto using ctx1.
  - eexists (λ x, Pair (k3 x) _). split; eauto.
    eapply (Ctx_comp (λ x, Pair x _)); eauto using ctx1.
  - eexists (λ x, Pair _ (k3 x)). split; eauto.
    eapply (Ctx_comp (λ x, Pair _ x)); eauto using ctx1.
  - eexists (λ x, LetPair (k3 x) _). split; eauto.
    eapply (Ctx_comp (λ x, LetPair x _)); eauto using ctx1.
  - eexists (λ x, Sum _ (k3 x)). split; eauto.
    eapply (Ctx_comp (λ x, Sum _ x)); eauto using ctx1.
  - eexists (λ x, MatchSum _ (k3 x) _). split; eauto.
    eapply (Ctx_comp (λ x, MatchSum _ x _)); eauto using ctx1.
  - eexists (λ x, Fork (k3 x) ). split; eauto.
    eapply (Ctx_comp (λ x, Fork x)); eauto using ctx1.
  - eexists (λ x, App (App _ (k3 x)) _). split; eauto.
    eapply (Ctx_comp (λ x, App x _)); eauto using ctx1.
    eapply (Ctx_comp (λ x, App _ x)); eauto using ctx1.
  - eexists (λ x, App _ (k3 x)). split; eauto.
    eapply (Ctx_comp (λ x, App _ x)); eauto using ctx1.
  - eexists (λ x, App (k3 x) _). split; eauto.
    eapply (Ctx_comp (λ x, App x _)); eauto using ctx1.
  - eexists (λ x, App (k3 x) _). split; eauto.
    eapply (Ctx_comp (λ x, App x _)); eauto using ctx1.
Qed.

Lemma compile_subst x v e :
  compile (GV.subst x v e) = subst x (compile_val v) (compile e).
Proof.
  induction e; simpl; eauto; repeat case_decide; eauto;
  try by f_equal; simplify_eq.
  - f_equal; eauto. apply functional_extensionality. eauto.
  - do 4 (f_equal; eauto).
Qed.

Lemma ctx_append k1 k2 :
  ctx k1 -> ctx k2 -> ctx (k1 ∘ k2).
Proof.
  induction 1; eauto. intros Q.
  eapply (Ctx_comp k1); eauto.
Qed.

Lemma compile_pure_step i e e' k :
  ctx k ->
  GV.pure_step e e' ->
  local_step i {[i := Thread (k (compile e))]} {[i := Thread (k (compile e'))]}.
Proof.
  intros Hk []; simpl; try solve [econstructor; eauto using pure_step].
  - rewrite compile_subst. econstructor; eauto using pure_step.
  - econstructor; eauto using pure_step. econstructor.
  - eapply (Pure_step _ (λ x, k (App x _))); eauto using pure_step.
    { eapply ctx_append; eauto. eapply (Ctx_comp (λ x, App x _)); eauto using ctx, ctx1. }
    eapply App_step.
  - eapply (Pure_step _ (λ x, k (App x _))); eauto using pure_step.
    { eapply ctx_append; eauto. eapply (Ctx_comp (λ x, App x _)); eauto using ctx, ctx1. }
  - eapply Pure_step; eauto.
    eapply App_step.
  - eapply (Pure_step _ (λ x, k (Fork x))); eauto using pure_step.
    { eapply ctx_append; eauto. eapply Ctx_comp; eauto using ctx, ctx1. }
Qed.

Lemma compile_step ρ ρ' i :
  GV.step i ρ ρ' -> step i (compile_cfg ρ) (compile_cfg ρ').
Proof.
  intros Hstep.
  destruct Hstep.
  unfold compile_cfg.
  rewrite !map_fmap_union.
  econstructor; eauto using fmap_map_disjoint.
  clear H H0.
  destruct H1.
  - rewrite !map_fmap_singleton /=.
    destruct (compile_ctx k) as [k2 [Hk2 Hk2c]]; first done.
    rewrite !Hk2c.
    eapply compile_pure_step; done.
  - rewrite fmap_empty map_fmap_singleton /=. econstructor.
  - rewrite fmap_empty map_fmap_singleton /=. econstructor.
  - rewrite !fmap_insert fmap_empty /=.
    destruct (compile_ctx k) as [k2 [Hk2 Hk2c]]; first done.
    rewrite !Hk2c.
    econstructor; eauto.
  - rewrite !fmap_insert fmap_empty /=.
    destruct (compile_ctx k) as [k2 [Hk2 Hk2c]]; first done.
    rewrite !Hk2c /=.
    eapply Fork_step; eauto.
  - rewrite !map_fmap_singleton /=.
    eapply (Pure_step _ id); eauto using ctx.
    econstructor.
  - rewrite !map_fmap_singleton /=.
    eapply Pure_step; eauto using pure_step, ctx, ctx1.
  - rewrite !fmap_insert fmap_empty /=.
    destruct (compile_ctx k) as [k2 [Hk2 Hk2c]]; first done.
    rewrite !Hk2c /=.
    eapply (Sync_step i j n k2 id UnitV); eauto using ctx.
Qed.


Set Implicit Arguments.

Require Import
        List
        Syntax.Experiment
        Syntax.Name
        Tactics.Tactics.

Inductive wf_treatment : experiment -> treatment -> Prop :=
| WF_treatment
  : forall e t ts,
      ts = exp_treatments e ->
      In t ts               ->
      wf_treatment e t.

Hint Constructors wf_treatment.

Inductive wf_experimental_object : experiment -> experimental_object -> Prop :=
| WF_object
  : forall e o os,
    os = exp_objects e ->
    In o os ->
    wf_experimental_object e o.

Hint Constructors wf_experimental_object.

Inductive wf_dependent_variable : experiment -> dependent_variable -> Prop :=
| WF_variable
  : forall e v vs,
    vs = exp_variables e ->
    In v vs              ->
    wf_dependent_variable e v.

Hint Constructors wf_dependent_variable.

Inductive wf_experimental_design : experiment -> experimental_design -> Prop :=
| WF_design
  : forall e d ts os f,
    ts = exp_treatments e ->
    d  = exp_design e     ->
    os = exp_objects e    ->
    f = des_function d    ->
    Forall (fun t => Exists (fun o => In o os /\ In (t,o) f) os) ts ->
    wf_experimental_design e d.

Hint Constructors wf_experimental_design.

Inductive wf_research_hypothesis : experiment -> research_hypothesis -> Prop :=
| WF_hypothesis
  : forall e n rh rhs t1 t2 op dv,
    n = hyp_name rh ->
    rhs = exp_hypothesis e ->
    t1 = hyp_treatment1 rh ->
    t2 = hyp_treatment2 rh ->
    op = hyp_operator rh ->
    dv = hyp_variable rh ->
    In rh rhs ->
    wf_treatment e t1 ->
    wf_treatment e t2 ->
    wf_dependent_variable e dv ->
    t1 <> t2 ->
    wf_research_hypothesis e rh.

Hint Constructors wf_research_hypothesis.

Inductive wf_experiment : experiment -> Prop :=
| WF_experiment
  : forall e rhs d ts os vs,
    rhs = exp_hypothesis e ->
    d = exp_design e ->
    ts = exp_treatments e ->
    os = exp_objects e ->
    vs = exp_variables e ->
    Forall (fun rh => wf_research_hypothesis e rh) rhs ->
    Forall (fun t => wf_treatment e t) ts ->
    Forall (fun o => wf_experimental_object e o) os ->
    Forall (fun v => wf_dependent_variable e v) vs ->
    wf_experimental_design e d ->
    NoDup ts ->
    NoDup vs ->
    NoDup os ->
    NoDup (names rhs) ->
    wf_experiment e.

Hint Constructors wf_experiment.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_nom_equ_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 L2 T2', T2 = (t_equ L2 T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.