Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Structure.Monoidal.

Generalizable All Variables.

Section SemicartesianMonoidal.

Context {C : Category}.

(* A semi-cartesian monoidal category is basically an assertion that the unit
   is terminal. *)

Class SemicartesianMonoidal `{@Monoidal C} := {
  eliminate {x} : x ~> I;

  unit_terminal {x} (f g : x ~> I) : f ≈ g;

  proj_left  {x y} : x ⨂ y ~> x := unit_right ∘ id ⨂ eliminate;
  proj_right {x y} : x ⨂ y ~> y := unit_left  ∘ eliminate ⨂ id
}.

Corollary eliminate_comp `{@Monoidal C} `{@SemicartesianMonoidal _} `{f : A ~> B} :
  eliminate ∘ f ≈ eliminate.
Proof. intros; apply unit_terminal. Qed.

End SemicartesianMonoidal.

Require Import Category.Structure.Terminal.

(* Wikipedia: "In any cartesian monoidal category, the terminal object is the
   tensor unit." *)

Program Definition SemicartesianMonoidal_Terminal `{@Monoidal C}
        `{@SemicartesianMonoidal C _} : @Terminal C := {|
  terminal_obj := I;
  one := @eliminate _ _ _;
  one_unique := @unit_terminal _ _ _
|}.

Import EqNotations.

(* Likewise, any monoidal category whose terminal object is the unit object,
   is semicartesian monoidal. *)

Program Definition Terminal_SemicartesianMonoidal `{M : @Monoidal C}
        `{T : @Terminal C} (Heq : 1 = @I C M) :
  @SemicartesianMonoidal C _ := {|
  eliminate := fun x => rew Heq in one;
  unit_terminal := fun x f g =>
    _ (one_unique (rew <- Heq in f) (rew <- Heq in g))
|}.
Next Obligation.
  unfold eq_rect_r, eq_rect, eq_sym in x.
  destruct Heq.
  assumption.
Defined.


Require Import HoTT.Basics HoTT.Types HoTT.Tactics.

Set Universe Polymorphism.
Set Primitive Projections.

Context {ua : Univalence} {fe : Funext}.

Record Pack (A₀ A₁ : Type) (Aᴿ : A₀ -> A₁ -> Type) := mkPack {
  el₀ : A₀;
  el₁ : A₁;
  prp : Aᴿ el₀ el₁;
}.

Arguments el₀ {_ _ _} _.
Arguments el₁ {_ _ _} _.
Arguments prp {_ _ _} _.

Definition Rel A B := A -> B -> Type.

Definition HEqRefl {A B} (R : Rel A B) (e : A <~> B)
  := forall x, R x (e x).

Definition HEqIsEq {A B} (R : Rel A B) (e : A <~> B) (r : HEqRefl R e)
  := forall x x', @IsEquiv (x = x') (R x (e x'))
                      (fun p => transport (fun y => R x (e y)) p (r x)).

(* Definition of univalent relation for the universe *)
(* Note that this definiiton slighty differs from the papier *)
(* As we ask for a functior from forall x, R x (e x) that leads to an *)
(* equivalence x = y <~> R x (e y), instead of asking directly *)
(* for the equivalence *)

Definition univalent {A B} (R : Rel A B)
  := exists (e : A <~> B) (r : HEqRefl R e), HEqIsEq R e r.

Definition univalentRel A B := {R : Rel A B & univalent R}.

Definition TYPE :=
  Pack Type Type (fun A₀ A₁ => {R : A₀ -> A₁ -> Type & univalent R}).

Definition El (A : TYPE) : Type := Pack A.(el₀) A.(el₁) (A.(prp).1).

(* Auxiliary lemma *)
Definition transportD3 {A : Type} (B : A -> Type) (B' : A -> Type) B''
           (C : forall (a:A) (x: B a) (y: B' a), B'' a x y -> Type)
  {x1 x2 : A} (p : x1 = x2) y y' y'' (z : C x1 y y' y'')
  : C x2 (p # y) (p # y') (transportD2 _ _ _ p _ _ y'')
  :=
  match p with idpath => z end.

Definition transport_univalentRel {A B B'} (e: B = B') R e' r H
  : transport (univalentRel A) e (R; (e'; (r; H)))
    = (e # R ; (e # e' ; (transportD2 _ _ (fun B e' (R : Rel A B) => HEqRefl R e') e _ _ r ; transportD3 _ _ _ (fun B e' (R : Rel A B) (r : HEqRefl R e') => HEqIsEq R e' r) e _ _ _ H))).
  destruct e; reflexivity.
Defined.

Definition path_univalentRel {A B} (X Y : univalentRel A B)
           (eR : X.1 = Y.1) (ee : X.2.1 = Y.2.1)
           (eH : transport (fun Z => HEqRefl Y.1 Z) ee (transport (fun Z => HEqRefl Z X.2.1) eR X.2.2.1) = Y.2.2.1)
  : X = Y.
  destruct X as [R [e [r H]]].
  destruct Y as [R' [e' [r' H']]].
  cbn in *. destruct ee, eR. cbn in *. destruct eH.
  assert (H  = H').
  apply path_forall; intro. apply path_forall; intro. apply hprop_isequiv.
  destruct X. reflexivity.
Defined.

Definition HEqGen A : univalentRel A A.
  exists paths. exists equiv_idmap.
  unshelve econstructor.
  - intro; reflexivity.
  - intros x y; cbn.
    eapply isequiv_homotopic.
    eapply isequiv_idmap. intros []; reflexivity.
Defined.

(** Type *)

Notation "A ⋈ B" := {R : A -> B -> Type & univalent R} (at level 50).

Definition UR_Equiv (A B C:Type) {e : B <~> C} {R : A -> B -> Type} : A -> C -> Type :=
  fun a b => R a (e^-1 b).

Definition UR_Type_Struct_Equiv {A B C} (e' : B <~> C) (H: A ⋈ B) : A ⋈ C.
Proof.
  destruct H as [R e r H].
  unshelve econstructor.
  - eapply UR_Equiv; eassumption.
  - unshelve econstructor.
    + eapply equiv_compose'. eassumption. destruct e as [e _]. auto.
    +  unshelve eexists.
       intro x. cbn. unfold UR_Equiv. cbn. destruct e as [e [ur_refl _]]. cbn.
       refine ((eissect e' (e x))^ # _). eapply ur_refl.
       intros a b. serapply isequiv_adjointify; cbn.
       *  intro p. destruct e as [e [ur_refl ur_is_eq]].
          cbn in *. apply ur_is_eq. refine (eissect e' (e b) # p).
       * intro p; cbn. destruct e as [e [ur_refl ur_is_eq]].
         match goal with
         | |- transport _ (@equiv_inv _ _ ?gg ?ff ?pp) ?qq = _ =>
           set pp; set ff; set gg in *
         end.
         match goal with
         | |- transport _ ?ff _ = _ => set ff
         end.
         transitivity (transport (R a) (eissect e' (e b))^
                    (transport (fun x => R a (e x)) p0 (ur_refl a))).
         destruct p0. reflexivity.
         cbn. eapply (moveR_transport_V (R a)).
         exact (eisretr r0 r).
       * intros []; cbn. rewrite <- transport_pp.
         rewrite concat_Vp. cbn.
         apply equiv_moveR_equiv_V. reflexivity.
Defined.

Definition transport_equiv `{Fs: Funext} {A B} P {e e' : A <~> B} (H : e = e' :> (A -> B))
  : transport (fun e : A <~> B => P (equiv_fun e)) (path_equiv H)
    = transport (fun f => P f) H.
  eapply path_forall; intro a.
  (* Set Printing Coercions. *)
  rewrite (transport_compose P).
  eapply ap10, ap. destruct e as [f Hf], e' as [f' Hf']; cbn in *.
  rewrite concat_1p, concat_p1. cbn.
  destruct H. assert (Hf = Hf'). apply path_ishprop.
  destruct X.
  assert (path_sigma_hprop (f; Hf) (f; Hf) 1 = 1)%path. {
    unfold path_sigma_hprop.
    unshelve eapply path_path_sigma.
    rewrite pr1_path_sigma_uncurried.
    reflexivity. eapply path_ishprop. }
  rewrite X. reflexivity.
Defined.

Definition path_UR_Type_Struct {A B} {e e' : A <~> B} {R R' : A -> B -> Type}
           {r : forall a, R a (e a)}
           {r' : forall a, R' a (e' a)} {H H'}
           (e1: e == e')
           (e2: forall x y, R x y = R' x y)
           (e3 : (forall a, (transport (fun b => R' a b) (e1 a)
                                  (transport idmap (e2 _ _) (r a))) = r' a))
  : (R ; (e; (r ; H))) = (R' ; (e'; (r' ; H'))) :> A ⋈ B.
Proof.
  transparent assert (e1' : (e = e')). {
    eapply path_equiv, path_forall, e1. }
  transparent assert (e2' : (R = R')). {
    eapply path_forall; intro; eapply path_forall; intro.
    apply e2. }
  assert (e3' : transport (fun e : A <~> B => forall a, R' a (e a)) e1'
                          (transport (fun R => forall a, R a (e a)) e2' r) = r'). {
    etransitivity. eapply path_forall.
    simple refine (transport_forall_constant _ _).
    eapply path_forall; intro a.
    subst e1'. rewrite (transport_equiv (fun f => R' a (f a))).
    rewrite transport_compose. rewrite ap_apply_l.
    rewrite ap10_path_forall. rewrite transport_forall_constant.
    refine (_ @ e3 a). apply ap.
    subst e2'. by transport_path_forall_hammer. }
  destruct e1', e2', e3'. cbn.
  assert (H = H'). apply path_ishprop.
    by destruct X.
Defined.

Definition UR_Type_Struct_transport_equiv {A B C} {e' : B <~> C} {H: A ⋈ B}
  : transport (fun X => A ⋈ X) (path_universe_uncurried e') H
    = UR_Type_Struct_Equiv e' H.
  rewrite <- (equiv_path_path_universe_uncurried e').
  set (path_universe_uncurried e').
  destruct p. clear e'.
  rewrite eta_path_universe_uncurried; cbn.
  destruct H as [R [e [u u']]].
  unshelve eapply path_UR_Type_Struct.
  intro; reflexivity.
  intros; cbn. reflexivity.
  intro; reflexivity.
Defined.

Definition UR_is_eq_equiv {A B} (e : A ⋈ B) (a : A) (b : B)
  : (a = (e.2.1)^-1 b) <~> (e.1 a b).
Proof.
  etransitivity. econstructor.
  exact (e.2.2.2 a _).
  refine (transport (fun X =>  (e.1 a X) <~> _) (eisretr _ b)^ (equiv_idmap _)).
Defined.

Definition UR_is_eq_equiv' {A B} (e : A ⋈ B) (a : A) (b : B)
  : (a = (e.2.1)^-1 b) <~> (e.1 a b).
Proof.
  refine (transport (fun X =>  a = (e.2.1)^-1 b <~> (e.1 a  X))
                    (eisretr (e.2.1) b) _).
  econstructor.
  exact (e.2.2.2 a ((e.2.1)^-1 b)).
Defined.

Definition Typeᶠ : TYPE.
  refine (mkPack Type Type (fun A₀ A₁ => {R : A₀ -> A₁ -> Type & univalent R})
                 Type Type (fun A₀ A₁ => {R : A₀ -> A₁ -> Type & univalent R} ; _)).
  exists equiv_idmap. cbn.
  unshelve econstructor.
  - exact HEqGen.
  - intros A B; cbn. unshelve eapply isequiv_adjointify.
    + intro e. apply path_universe_uncurried. destruct e as [_ [e _]]. exact e.
    + intros [R [e [r H]]].
      rewrite UR_Type_Struct_transport_equiv.
      serapply path_UR_Type_Struct; cbn.
      intro; reflexivity.
      intros. apply path_universe_uncurried.
      apply (UR_is_eq_equiv (R;(e;(r;H)))).
      intro; cbn.
      rewrite transport_idmap_path_universe_uncurried. cbn.
      rewrite transport_paths_r.
      rewrite concat_1p.
      match goal with
      | |- ?f ?g = _ => set f; set g
      end.
      transitivity (transport (fun x => R a (e x)) (eissect e a) r1).
      apply ap10. subst r1 r0. clear.
      rewrite <- (equiv_path_path_universe_uncurried e).
      destruct (path_universe_uncurried e). reflexivity.
      subst r0.
      refine (transport_pV (fun x : A => R a (e x)) (eissect e a) (r a)).
    + intro e; cbn. destruct e. cbn.
      exact (eta_path_universe_uncurried idpath).
Defined.

Check Typeᶠ : El Typeᶠ.

Definition mkTYPE (A₀ A₁ : Type) (Aᴿ : A₀ -> A₁ -> Type) (Aᴿs : univalent Aᴿ)
  : El Typeᶠ :=
  mkPack Type Type (fun A₀ A₁ => univalentRel A₀ A₁) A₀ A₁ (Aᴿ ; Aᴿs).

(** Dependent products *)

Definition Prodᶠ (A : TYPE) (B : El A -> TYPE) : El Typeᶠ.
  refine (mkTYPE
            (forall x : El A, (B x).(el₀))
            (forall x : El A, (B x).(el₁))
            (fun f₀ f₁ => forall x : El A, (B x).(prp).1 (f₀ x) (f₁ x))
            _).
  simple refine (_; (_; _)).
  - eapply equiv_functor_forall_id.
    intro ; exact ((B a).(prp).2.1).
  - intros f a. cbn; unfold functor_forall.
    exact ((B a).(prp).2.2.1 (f a)).
  - intros f g; cbn; unfold functor_forall.
    unshelve eapply isequiv_adjointify.
    + intro H. eapply path_forall; intro a.
      refine (@equiv_inv _ _ _ ((B a).(prp).2.2.2 (f a) (g a)) _).
      exact (H a).
    + intro H. eapply path_forall; intro a.
      rewrite transport_forall_constant.
      rewrite (transport_compose
                 (fun y => (prp (B a)).1 (f a) (((prp (B a)).2).1 y))).
      match goal with
      | |- transport ?PP (ap _ ?ee) ?uu = ?vv
        => change (transport PP (apD10 ee a) uu = vv)
      end.
      rewrite apD10_path_forall.
      exact (@eisretr _ _ _ ((B a).(prp).2.2.2 (f a) (g a)) (H a)).
    + intro e.
      pose proof (fun a => @eissect _ _ _ ((B a).(prp).2.2.2 (f a) (g a))
                                 (apD10 e a)).
      cbn in *.
      match goal with
      | |- path_forall f g ?ee = e
        => assert (XX: ee = apD10 e); [|rewrite XX; apply eta_path_forall]
      end.
      eapply path_forall; intro a; cbn.
      etransitivity. 2: exact (X a).
      eapply ap. rewrite transport_forall_constant.
      rewrite (transport_compose
                 (fun y => (prp (B a)).1 (f a) (((prp (B a)).2).1 y))).
      reflexivity.
Defined.

Notation "A →ᶠ B" := (Prodᶠ A (fun _ => B)) (at level 99, right associativity, B at level 200).
Notation "'Πᶠ'  x .. y , P" := (Prodᶠ _ (fun x => .. (Prodᶠ _ (fun y => P)) ..))
  (at level 200, x binder, y binder, right associativity).

Definition Lamᶠ {A B} (f : forall x : El A, El (B x)) : El (Prodᶠ A B).
Proof.
  unshelve econstructor.
  + refine (fun x => (f x).(el₀)).
  + refine (fun x => (f x).(el₁)).
  + refine (fun x => (f x).(prp)).
Defined.

Notation "'λᶠ'  x .. y , t" := (Lamᶠ (fun x => .. (Lamᶠ (fun y => t)) ..))
  (at level 200, x binder, y binder, right associativity).

Definition Appᶠ {A B} (f : El (Prodᶠ A B)) (x : El A) : El (B x).
Proof.
  unshelve econstructor.
  + refine (f.(el₀) x).
  + refine (f.(el₁) x).
  + refine (f.(prp) x).
Defined.

Notation "t · u" := (Appᶠ t u) (at level 64, left associativity).

Eval compute in idpath : (fun A B f x => Appᶠ (@Lamᶠ A B f) x) = (fun A B f x => f x).
Eval compute in idpath : (fun A B f => @Lamᶠ A B (fun x => Appᶠ f x)) = (fun A B f => f).

(** Prop *)
Axiom Prop_irrelevance :
  forall (P Q : Prop), IsEquiv (fun p : P = Q
                        => transport (fun Q : Prop => P <-> Q) p (iff_reflexive P)).

Definition Propᶠ : El Typeᶠ.
  refine (mkTYPE Prop Prop (fun P Q => P <-> Q) _).
  exists equiv_idmap.
  unshelve econstructor.
  - intro P; cbn. reflexivity.
  - intros P Q; cbn. exact (Prop_irrelevance P Q).
Defined.

Definition ElProp : El Propᶠ -> Type.
  intro P. refine (Pack P.(el₀) P.(el₁) (fun _ _ => True)).
Defined.

Definition ProdPropᶠ (A : TYPE) (B : El A -> El Propᶠ) : El Propᶠ.
  unshelve eapply mkPack.
  - cbn. exact (forall x : El A, (B x).(el₀)).
  - cbn. exact (forall x : El A, (B x).(el₁)).
  - cbn. split; intros f x.
    + apply (B x).(prp). exact (f x).
    + apply (B x).(prp). exact (f x).
Defined.

Definition LamPropᶠ {A : TYPE} {B : El A -> El Propᶠ}
           (f : forall x : El A, ElProp (B x))
  : ElProp (ProdPropᶠ A B).
Proof.
  unshelve econstructor.
  + refine (fun x => (f x).(el₀)).
  + refine (fun x => (f x).(el₁)).
  + refine I.
Defined.

(** Bool *)

Definition Boolᶠ : El Typeᶠ.
  refine (mkTYPE Bool Bool (fun b₀ b₁ => b₀ = b₁) _).
  exists equiv_idmap. unshelve econstructor.
  - intros []; reflexivity.
  - intros b b'; cbn.
    unshelve eapply isequiv_adjointify.
    + exact (fun p => p).
    + intros []; cbn. destruct b; reflexivity.
    + intro p. destruct b, b', p; reflexivity.
Defined.

Definition trueᶠ : El Boolᶠ := {| prp := idpath true |}.
Definition falseᶠ : El Boolᶠ := {| prp := idpath false |}.

Definition Bool_rectᶠ : El
  (Πᶠ (P : El (Boolᶠ →ᶠ Typeᶠ)), P · trueᶠ →ᶠ P · falseᶠ →ᶠ
  Πᶠ (b : El Boolᶠ), P · b).
Proof.
  refine (λᶠ P Pt Pf b, _).
  destruct P as [P0 P1 PP]. destruct b as [b b' e], e, b.
  cbn in *. exact Pt. exact Pf.
Defined.

Eval compute in idpath :
  (fun P Pt Pf => Bool_rectᶠ · P · Pt · Pf · trueᶠ) = (fun P Pt Pf => Pt).

Eval compute in idpath :
  (fun P Pt Pf => Bool_rectᶠ · P · Pt · Pf · falseᶠ) = (fun P Pt Pf => Pf).


Require Import Coq.Relations.Relation_Definitions Coq.Classes.Morphisms.
Require Export Crypto.Util.FixCoqMistakes.

Module Export Telescope.
  Inductive Telescope := bottom | tele (A : Type) (B : A -> Telescope).

  Fixpoint flattenT (t : Telescope) (X : Type)
    := match t with
         | bottom => X
         | tele A B => forall a : A, flattenT (B a) X
       end.

  Global Arguments tele : clear implicits.

  Fixpoint flattenT_sig (t : Telescope)
    := match t return Type with
         | bottom => unit
         | tele A B => { a : A & flattenT_sig (B a) }
       end.

  Section R.
    Context {X : Type} (R : relation X).

    Fixpoint flattenT_R_relation {t : Telescope} : relation (flattenT t X)
      := match t return relation (flattenT t X) with
           | bottom => R
           | tele A B => forall_relation (fun a => flattenT_R_relation)
         end.
  End R.

  Definition flattenT_eq {X : Type} : forall {t : Telescope}, relation (flattenT t X)
    := Eval unfold flattenT_R_relation, forall_relation in @flattenT_R_relation X eq.

  Fixpoint flattenT_apply {t : Telescope} {X : Type}
  : flattenT t X -> flattenT_sig t -> X
    := match t return flattenT t X -> flattenT_sig t -> X with
         | bottom => fun x _ => x
         | tele A B => fun f p => flattenT_apply (f (projT1 p)) (projT2 p)
       end.

  Fixpoint flattenT_unapply {t : Telescope} {X : Type}
  : (flattenT_sig t -> X) -> flattenT t X
    := match t return (flattenT_sig t -> X) -> flattenT t X with
         | bottom => fun f => f tt
         | tele A B => fun f x => flattenT_unapply (fun p => f (existT (fun x' => flattenT_sig (B x')) x p))
       end.

  Fixpoint Telescope_append_nondep (t t' : Telescope)
  : Telescope
    := match t with
         | bottom => t'
         | tele A B => @tele A (fun a => Telescope_append_nondep (B a) t')
       end.

  Global Arguments Telescope_append_nondep : clear implicits.

  Fixpoint Telescope_append (t : Telescope)
  : flattenT t Type -> Telescope
    := match t return flattenT t _ -> _ with
         | bottom => fun X => @tele X (fun _ => bottom)
         | tele A B => fun X => @tele A (fun a => Telescope_append (B a) (X a))
       end.

  Global Arguments Telescope_append : clear implicits.

  Fixpoint flatten_forall {t : Telescope} : flattenT t Type -> Type
    := match t return flattenT t Type -> Type with
         | bottom => fun P => P
         | tele A B => fun P => forall a : A, flatten_forall (P a)
       end.

  Fixpoint flatten_forall_eq_rect {t : Telescope}
  : forall {P Q : flattenT t Type},
      flattenT_eq P Q
      -> flatten_forall P
      -> flatten_forall Q
    := match t return forall {P Q : flattenT t Type},
                        flattenT_eq P Q
                        -> flatten_forall P
                        -> flatten_forall Q
       with
         | bottom => fun P Q H k => eq_rect _ (fun x => x) k _ H
         | tele A B => fun P Q H k a => @flatten_forall_eq_rect (B a) (P a) (Q a) (H a) (k a)
       end.

  Fixpoint flatten_forall_eq_relation {t : Telescope}
  : forall {P : flattenT t Type},
      relation (flatten_forall P)
    := match t
             return forall {P : flattenT t _},
                      relation (flatten_forall P)
       with
         | bottom => fun P => eq
         | tele A B => fun P => forall_relation (fun a : A => @flatten_forall_eq_relation (B a) (P a))
       end.

  Definition flatten_forall_eq {t : Telescope}
  : forall {P : flattenT t Type}
           (f g : flatten_forall P),
      Prop
    := Eval unfold flatten_forall_eq_relation, forall_relation in @flatten_forall_eq_relation t.

  Fixpoint flatten_forall_eq_relation_with_assumption {t : Telescope}
  : forall {P : flattenT t Type}
           (Q : flattenT t Type),
      relation (flatten_forall P)
    := match t
             return forall {P : flattenT t _}
                           (Q : flattenT t Type),
                      relation (flatten_forall P)
       with
         | bottom => fun P Q => fun x y => Q -> x = y
         | tele A B => fun P Q => forall_relation (fun a : A => @flatten_forall_eq_relation_with_assumption (B a) (P a) (Q a))
       end.

  Definition flatten_forall_eq_with_assumption {t : Telescope}
  : forall {P : flattenT t Type}
           (Q : flattenT t Type)
           (f g : flatten_forall P),
      Prop
    := Eval unfold flatten_forall_eq_relation, forall_relation in @flatten_forall_eq_relation_with_assumption t.

  Fixpoint flatten_forall_apply {t : Telescope}
  : forall {P : flattenT t Type},
      flatten_forall P
      -> forall x : flattenT_sig t,
           flattenT_apply P x
    := match t
             return forall {P : flattenT t Type},
                      flatten_forall P
                      -> forall x : flattenT_sig t,
                           flattenT_apply P x
       with
         | bottom => fun X x _ => x
         | tele A B => fun P f x => @flatten_forall_apply (B (projT1 x)) _ (f (projT1 x)) (projT2 x)
       end.

  Fixpoint flatten_forall_unapply {t : Telescope}
  : forall {P : flattenT_sig t -> Type},
      (forall x : flattenT_sig t, P x)
      -> flatten_forall (flattenT_unapply P)
    := match t
             return forall {P : flattenT_sig t -> Type},
                      (forall x : flattenT_sig t, P x)
                      -> flatten_forall (flattenT_unapply P)
       with
         | bottom => fun X x => x tt
         | tele A B => fun P f x => @flatten_forall_unapply (B x) _ (fun x' => f _)
       end.

  Fixpoint flatten_forall_apply_of_unapply {t X} {struct t}
  : forall (f : flatten_forall
                  (flattenT_unapply
                     (fun _ : flattenT_sig t => X)))
           (x : flattenT_sig t),
      X
    := match t return forall (f : flatten_forall
                                    (flattenT_unapply
                                       (fun _ : flattenT_sig t => X)))
                             (x : flattenT_sig t),
                        X
       with
         | bottom => fun x _ => x
         | tele A B => fun f x => @flatten_forall_apply_of_unapply (B (projT1 x)) X (f (projT1 x)) (projT2 x)
       end.

  Fixpoint flatten_append_forall {t : Telescope}
  : forall {t' : flattenT t Type},
      flattenT (Telescope_append t t') Type -> flatten_forall t' -> Type
    := match t return forall {t' : flattenT t _},
                        flattenT (Telescope_append t t') Type
                        -> flatten_forall t'
                        -> Type
       with
         | bottom => fun t' P v => P v
         | tele A B => fun t' P v => forall a, @flatten_append_forall (B a) (t' a) (P a) (v a)
       end.
End Telescope.


From iris.algebra Require Import auth numbers.
From iris.base_logic Require Import lib.own.
From iris.proofmode Require Export tactics.

(** * Ghost theory for the [unsafe_symbol_adt] exercise *)
(** This file defines the ghost resources [counter] and [symbol] using Iris's
generic mechanism for ghost state. These resources satisfy the following laws:

<<
  counter_alloc:      |==> ∃ γ, counter γ n
  counter_exclusive:  counter γ n1 -∗ counter γ n2 -∗ False
  counter_inc:        counter γ n ==∗ counter γ (S n) ∗ symbol γ n
  symbol_obs:         counter γ n -∗ symbol γ s -∗ ⌜(s < n)%nat⌝
>>
*)

Class symbolG Σ := { symbol_inG :> inG Σ (authR max_natUR) }.
Definition symbolΣ : gFunctors := #[GFunctor (authR max_natUR)].

Instance subG_symbolΣ {Σ} : subG symbolΣ Σ → symbolG Σ.
Proof. solve_inG. Qed.

Section symbol_ghost.
  Context `{!symbolG Σ}.

  Definition counter (γ : gname) (n : nat) : iProp Σ := own γ (● (MaxNat n)).
  Definition symbol (γ : gname) (n : nat) : iProp Σ := own γ (◯ (MaxNat (S n))).

  Global Instance counter_timeless γ n : Timeless (counter γ n).
  Proof. apply _. Qed.
  Global Instance symbol_timeless γ n : Timeless (symbol γ n).
  Proof. apply _. Qed.

  Global Instance symbol_persistent γ n : Persistent (symbol γ n).
  Proof. apply _. Qed.

  Lemma counter_alloc n : ⊢ |==> ∃ γ, counter γ n.
  Proof.
    iMod (own_alloc (● (MaxNat n) ⋅ ◯ (MaxNat n))) as (γ) "[Hγ Hγf]";
      first by apply auth_both_valid.
    iExists γ. by iFrame.
  Qed.

  Lemma counter_exclusive γ n1 n2 : counter γ n1 -∗ counter γ n2 -∗ False.
  Proof.
    apply bi.wand_intro_r. rewrite -own_op own_valid /=. by iDestruct 1 as %[].
  Qed.

  Lemma counter_inc γ n : counter γ n ==∗ counter γ (S n) ∗ symbol γ n.
  Proof.
    rewrite -own_op.
    apply own_update, auth_update_alloc, max_nat_local_update.
    simpl. lia.
  Qed.

  Lemma symbol_obs γ s n : counter γ n -∗ symbol γ s -∗ ⌜(s < n)%nat⌝.
  Proof.
    iIntros "Hc Hs".
    iDestruct (own_valid_2 with "Hc Hs") as %[?%max_nat_included _]%auth_both_valid_discrete.
    iPureIntro. simpl in *. lia.
  Qed.
End symbol_ghost.

Typeclasses Opaque counter symbol.


Fixpoint fueled_lub {A}
         (Aeq : A -> A -> bool)
         (join : A -> A -> A)
         (fuel : nat)
         (f : A -> A) (x : A)
: bool (* fixpoint reached *) * A
:= match fuel with
   | 0 => (false, x)
   | S n
     => let fx := join x (f x) in
        if Aeq x fx
        then (true, fx)
        else @fueled_lub A Aeq join n f fx
   end.


(** This file is a proof of an equivalence relation on [com] that is not
    congruent.

    In this file, [cequiv] represents an equivalence relation on [com].
    At the end of the file, [no_CSeq_congruence] shows that [cequiv]
    is not congruent.

    See the [README.md] file for an overview of this approach. *)

From Coq Require Import Lists.List.
From Coq Require Import Lists.ListSet.
From Coq Require Import Strings.String.
From EquivalenceNotCongruence Require Export Imp.

Import Coq.Lists.List.ListNotations.

Section set_helpers.

  Variable A : Type.
  Hypothesis Aeq_dec : forall x y:A, {x = y} + {x <> y}.

  Definition set_eq (x y : set A) := set_diff Aeq_dec x y = empty_set A /\ set_diff Aeq_dec y x = empty_set A.

End set_helpers.

Fixpoint uniq_var_asgn (c : com): set string :=
  match c with
  | <{ skip }> => empty_set string
  | <{ x := _ }> => [ x ]
  | <{ c1 ; c2 }> => set_union string_dec (uniq_var_asgn c1) (uniq_var_asgn c2)
  | <{ if _ then c1 else c2 end }> => set_union string_dec (uniq_var_asgn c1) (uniq_var_asgn c2)
  end.

Example uniq_vars_asgn_example1 : set_eq _ string_dec (uniq_var_asgn <{ X := 3 }>) [X].
Proof. simpl. unfold set_eq. auto. Qed.

Example uniq_vars_asgn_example2 : set_eq _ string_dec (uniq_var_asgn <{ X := 3; X := 4 }>) [X].
Proof. simpl. unfold set_eq. auto. Qed.

Example uniq_vars_asgn_example3 : set_eq _ string_dec (uniq_var_asgn <{ Y := 3; X := 4 }>) [X; Y].
Proof. simpl. unfold set_eq. auto. Qed.

Example uniq_vars_asgn_example4 : set_eq _ string_dec (uniq_var_asgn <{ Y := 3; X := 4; Y := 100 }>) [X; Y].
Proof. simpl. unfold set_eq. auto. Qed.

Definition count_uniq_var_asgn (c : com): nat := List.length (uniq_var_asgn c).

Example count_uniq_var_asgn_example1 : count_uniq_var_asgn <{ X := 100 }> = 1.
Proof. reflexivity. Qed.

Example count_uniq_var_asgn_example2 : count_uniq_var_asgn <{ skip }> = 0.
Proof. reflexivity. Qed.

Example count_uniq_var_asgn_example3 : count_uniq_var_asgn <{ X := 100 ; Y := 200 }> = 2.
Proof. reflexivity. Qed.

Example count_uniq_var_asgn_example4 : count_uniq_var_asgn <{ X := 100 ; X := 200 }> = 1.
Proof. reflexivity. Qed.

Definition cequiv (c1 c2 : com) : Prop := count_uniq_var_asgn c1 = count_uniq_var_asgn c2.

Example cequiv_example1 : cequiv <{ X := 100 }> <{ X := 200 }>.
Proof. reflexivity. Qed.

Example cequiv_example2 : cequiv <{ X := 100 }> <{ X := 200; skip }>.
Proof. reflexivity. Qed.

Example cequiv_example3 : cequiv <{ X := 0; X := 100; Y := 3 }> <{ X := 200; skip; Y := X }>.
Proof. reflexivity. Qed.

Lemma refl_cequiv : forall (c : com), cequiv c c.
Proof. unfold cequiv. try reflexivity. Qed.

Lemma sym_cequiv : forall (c1 c2 : com), cequiv c1 c2 -> cequiv c2 c1.
Proof. unfold cequiv. intros. now symmetry. Qed.

Lemma trans_cequiv : forall (c1 c2 c3 : com), cequiv c1 c2 -> cequiv c2 c3 -> cequiv c1 c3.
Proof. unfold cequiv. intros. now rewrite H. Qed.

Theorem no_CSeq_congruence :
  ~ (forall c1 c1' c2 c2',
      cequiv c1 c1' -> cequiv c2 c2' -> cequiv <{ c1;c2 }> <{ c1';c2' }>).
Proof.
  unfold not. unfold cequiv. intros H.
  assert (cequiv <{ X := 100 }> <{ X := 100 }>) by reflexivity.
  assert (cequiv <{ X := 200 }> <{ Y := 200 }>) by reflexivity.
  specialize (H _ _ _ _ H0 H1).
  unfold count_uniq_var_asgn in H. simpl in H. discriminate.
  Qed.


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

Require Import XRbase.
Require Import XRfunctions.
Require Import XSeqSeries.
Require Import XRtrigo1.
Require Import XR_sqrt.
Local Open Scope XR_scope.

Lemma tan_PI : tan PI = R0.
Proof.
  unfold tan; rewrite sin_PI; rewrite cos_PI; unfold Rdiv;
    apply Rmult_0_l.
Qed.

Lemma sin_3PI2 : sin (R3 * (PI / R2)) = -R1.
Proof.
  replace (R3 * (PI / R2)) with (PI + PI / R2).
  rewrite sin_plus; rewrite sin_PI; rewrite cos_PI; rewrite sin_PI2.
rewrite Rmult_0_l.
rewrite Rplus_0_l.
rewrite Rmult_1_r.
reflexivity.
  pattern PI at 1; rewrite (double_var PI).
change (IZR 2) with R2.
unfold R3. unfold R2 at 4.
repeat rewrite Rmult_plus_distr_r.
repeat rewrite Rmult_1_l.
reflexivity.
Qed.

Lemma tan_2PI : tan (R2 * PI) = R0.
Proof.
  unfold tan; rewrite sin_2PI; unfold Rdiv; apply Rmult_0_l.
Qed.

Lemma sin_cos_PI4 : sin (PI / R4) = cos (PI / R4).
Proof.
  rewrite cos_sin.
  replace (PI / R2 + PI / R4) with (- (PI / R4) + PI).
  rewrite neg_sin, sin_neg.
rewrite Ropp_involutive. reflexivity.
apply Rmult_eq_reg_r with (R2*R4).
unfold Rdiv.
repeat rewrite Rmult_plus_distr_r.
rewrite Ropp_mult_distr_r.
repeat rewrite Rmult_assoc.
repeat rewrite <- Rmult_plus_distr_l.
apply Rmult_eq_compat_l.
rewrite <- Ropp_mult_distr_l.
rewrite (Rmult_comm R2).
repeat rewrite <- Rmult_assoc.
rewrite Rinv_l, Rmult_1_l.
symmetry.
rewrite Rmult_comm.
repeat rewrite <- Rmult_assoc.
rewrite Rinv_r, Rmult_1_l.
symmetry.
rewrite Rplus_comm.
rewrite Rmult_comm.
rewrite double.
unfold R4 at 2.
repeat rewrite Rplus_assoc.
rewrite Rplus_opp_r, Rplus_0_r.
reflexivity.
exact Neq_2_0.
apply Rlt_not_eq'. exact Rlt_0_4.
apply Rmult_integral_contrapositive_currified.
exact Neq_2_0.
apply Rlt_not_eq'. exact Rlt_0_4.
Qed.

Remark P623 : PI / R2 - PI / R3 = PI / R6.
Proof.
  unfold Rdiv, Rminus.
  rewrite Ropp_mult_distr_r.
  rewrite <- Rmult_plus_distr_l.
  apply Rmult_eq_compat_l.
  apply Rmult_eq_reg_r with (R2*R3).
  repeat rewrite Rmult_plus_distr_r.
  repeat rewrite <- Rmult_assoc.
  rewrite Rinv_l, Rmult_1_l.
  rewrite Rplus_comm.
  rewrite Rmult_comm.
  repeat rewrite <- Ropp_mult_distr_l.
  repeat rewrite <- Ropp_mult_distr_r.
  repeat rewrite <- Rmult_assoc.
  rewrite Rinv_r, Rmult_1_l.
  repeat rewrite Rmult_assoc.
  replace (R2*R3) with R6.
  rewrite Rinv_l.
  unfold R3.
  repeat rewrite <- Rplus_assoc.
  rewrite Rplus_opp_l, Rplus_0_l.
  reflexivity.
  apply Rlt_not_eq'. exact Rlt_0_6.
  rewrite double. unfold R6. reflexivity.
  apply Rlt_not_eq'. exact Rlt_0_3.
  exact Neq_2_0.
  apply Rmult_integral_contrapositive_currified.
  exact Neq_2_0.
  apply Rlt_not_eq'. exact Rlt_0_3.
Qed.

Lemma sin_PI3_cos_PI6 : sin (PI / R3) = cos (PI / R6).
Proof.
  replace (PI / R6) with (PI / R2 - PI / R3).
  now rewrite cos_shift.
  exact P623.
Qed.

Lemma sin_PI6_cos_PI3 : cos (PI / R3) = sin (PI / R6).
Proof.
  replace (PI / R6) with (PI / R2 - PI / R3).
  now rewrite sin_shift.
  exact P623.
Qed.

Lemma PI6_RGT_0 : R0 < PI / R6.
Proof.
  unfold Rdiv; apply Rmult_lt_0_compat;
    [ apply PI_RGT_0 | apply Rinv_0_lt_compat ].
  exact Rlt_0_6.
Qed.

Lemma PI6_RLT_PI2 : PI / R6 < PI / R2.
Proof.
  unfold Rdiv; apply Rmult_lt_compat_l.
  apply PI_RGT_0.
  apply Rinv_lt_contravar.
  apply Rmult_lt_0_compat.
  exact Rlt_0_2.
  exact Rlt_0_6.
  unfold R6. unfold R3. unfold R2.
  repeat rewrite <- Rplus_assoc.
  repeat apply Rplus_lt_compat_r.
  pattern R1 at 1;rewrite <- Rplus_0_l.
  repeat apply Rplus_lt_compat_r.
  repeat apply Rplus_lt_0_compat;exact Rlt_0_1.
Qed.

Lemma sin_PI6 : sin (PI / R6) = R1 / R2.
Proof.
  apply Rmult_eq_reg_l with (R2 * cos (PI / R6)).
  replace (R2 * cos (PI / R6) * sin (PI / R6)) with
  (R2 * sin (PI / R6) * cos (PI / R6)).
  rewrite <- sin_2a; replace (R2 * (PI / R6)) with (PI / R3).
  rewrite sin_PI3_cos_PI6.
{
  unfold Rdiv.
  rewrite Rmult_1_l.
  symmetry.
  rewrite Rmult_comm.
  rewrite <- Rmult_assoc, Rinv_l, Rmult_1_l.
  reflexivity.
  exact Neq_2_0.
}
{
  symmetry.
  unfold R6.
  rewrite <- double.
  change (IZR 2) with R2.
  rewrite Rmult_comm.
  unfold Rdiv.
  rewrite Rinv_mult_distr.
  rewrite (Rmult_comm (/R2)).
  repeat rewrite Rmult_assoc.
  rewrite Rinv_l, Rmult_1_r.
  reflexivity.
  exact Neq_2_0.
  exact Neq_2_0.
  exact Neq_3_0.
}
{
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  reflexivity.
}
  apply prod_neq_R0.
exact Neq_2_0.
  cut (R0 < cos (PI / R6));
    [ intro H1; auto with real
      | apply cos_gt_0;
        [ apply (Rlt_trans (- (PI / R2)) R0 (PI / R6) _PI2_RLT_0 PI6_RGT_0)
          | apply PI6_RLT_PI2 ] ].
Qed.

Lemma sqrt2_neq_0 : sqrt R2 <> R0.
Proof.
  assert (Hyp : R0 < R2);
    [ exact Rlt_0_2
      | generalize (Rlt_le R0 R2 Hyp); intro H1; red; intro H2;
        generalize (sqrt_eq_0 R2 H1 H2); intro H; absurd (R2 = R0);
          [ idtac | assumption ] ].
exact Neq_2_0.
Qed.

Lemma R1_sqrt2_neq_0 : R1 / sqrt R2 <> R0.
Proof.
  generalize (Rinv_neq_0_compat (sqrt R2) sqrt2_neq_0); intro H;
    generalize (prod_neq_R0 R1 (/ sqrt R2) R1_neq_R0 H);
      intro H0; assumption.
Qed.

Lemma sqrt3_2_neq_0 : R2 * sqrt R3 <> R0.
Proof.
  apply prod_neq_R0;
    [ idtac
      | assert (Hyp : R0 < R3);
        [ idtac
          | generalize (Rlt_le R0 R3 Hyp); intro H1; red; intro H2;
            generalize (sqrt_eq_0 R3 H1 H2); intro H; absurd (R3 = R0);
              [ idtac | assumption ] ] ].
exact Neq_2_0.
exact Rlt_0_3.
exact Neq_3_0.
Qed.

Lemma Rlt_sqrt2_0 : R0 < sqrt R2.
Proof.
  assert (Hyp : R0 < R2);
    [ exact Rlt_0_2
      | generalize (sqrt_positivity R2 (Rlt_le R0 R2 Hyp)); intro H1; elim H1;
        intro H2;
          [ assumption
            | absurd (R0 = sqrt R2);
              [ apply (not_eq_sym (A:=R)); apply sqrt2_neq_0 | assumption ] ] ].
Qed.

Lemma Rlt_sqrt3_0 : R0 < sqrt R3.
Proof.
  cut (0%nat <> 1%nat);
    [ intro H0; assert (Hyp : R0 < R2);
      [ exact Rlt_0_2
        | generalize (Rlt_le R0 R2 Hyp); intro H1; assert (Hyp2 : R0 < R3);
          [ exact Rlt_0_3
            | generalize (Rlt_le R0 R3 Hyp2); intro H2;
              generalize (lt_INR_0 1 (neq_O_lt 1 H0));
                unfold INR; intro H3;
                  generalize (Rplus_lt_compat_l R2 R0 R1 H3);
                    rewrite Rplus_comm; rewrite Rplus_0_l; replace (R2 + R1) with R3;
                      [ intro H4; generalize (sqrt_lt_1 R2 R3 H1 H2 H4); clear H3; intro H3;
                        apply (Rlt_trans R0 (sqrt R2) (sqrt R3) Rlt_sqrt2_0 H3)
                        | idtac ] ] ]
      | discriminate ].
unfold R3.
reflexivity.
Qed.

Lemma PI4_RGT_0 : R0 < PI / R4.
Proof.
  unfold Rdiv; apply Rmult_lt_0_compat;
    [ apply PI_RGT_0 | apply Rinv_0_lt_compat; idtac ].
exact Rlt_0_4.
Qed.

Lemma cos_PI4 : cos (PI / R4) = R1 / sqrt R2.
Proof with trivial.
  apply Rsqr_inj...
  apply cos_ge_0...
  left; apply (Rlt_trans (- (PI / R2)) R0 (PI / R4) _PI2_RLT_0 PI4_RGT_0)...
  left; apply PI4_RLT_PI2...
  left; apply (Rmult_lt_0_compat R1 (/ sqrt R2))...
  exact Rlt_0_1...
  apply Rinv_0_lt_compat; apply Rlt_sqrt2_0...
  rewrite Rsqr_div...
  rewrite Rsqr_1; rewrite Rsqr_sqrt...
  unfold Rsqr; pattern (cos (PI / R4)) at 1;
    rewrite <- sin_cos_PI4;
      replace (sin (PI / R4) * cos (PI / R4)) with
      (R1 / R2 * (R2 * sin (PI / R4) * cos (PI / R4))).
  rewrite <- sin_2a; replace (R2 * (PI / R4)) with (PI / R2).
  rewrite sin_PI2...
{
rewrite Rmult_1_r. reflexivity.
}
{
  unfold R4. rewrite <- double.
  symmetry.
  unfold Rdiv.
  rewrite Rmult_comm.
  rewrite Rinv_mult_distr.
  repeat rewrite Rmult_assoc.
  rewrite Rinv_l, Rmult_1_r.
  reflexivity.
  exact Neq_2_0.
  exact Neq_2_0.
  exact Neq_2_0.
}
{
  unfold Rdiv.
  rewrite Rmult_1_l.
  repeat rewrite <- Rmult_assoc.
  rewrite Rinv_l, Rmult_1_l.
  reflexivity.
  exact Neq_2_0.
}
left. exact Rlt_0_2.
  apply sqrt2_neq_0...
Qed.

Lemma sin_PI4 : sin (PI / R4) = R1 / sqrt R2.
Proof.
  rewrite sin_cos_PI4; apply cos_PI4.
Qed.

Lemma tan_PI4 : tan (PI / R4) = R1.
Proof.
  unfold tan; rewrite sin_cos_PI4.
  unfold Rdiv; apply Rinv_r.
  change (cos (PI / R4) <> R0); rewrite cos_PI4; apply R1_sqrt2_neq_0.
Qed.

Lemma cos3PI4 : cos (R3 * (PI / R4)) = -R1 / sqrt R2.
Proof.
  replace (R3 * (PI / R4)) with (PI / R2 - - (PI / R4)).
  rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4.
  unfold Rdiv.

  rewrite <- Ropp_mult_distr_l.
  reflexivity.

  unfold Rminus.
  rewrite Ropp_involutive.
  unfold R3.
  rewrite Rmult_plus_distr_r.
  rewrite Rmult_1_l.
  apply Rplus_eq_compat_r.
  symmetry.
  unfold R4.
  rewrite <- double.
  unfold Rdiv.
  rewrite Rinv_mult_distr.
  repeat rewrite Rmult_assoc.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  rewrite Rinv_l, Rmult_1_r.
  reflexivity.
  exact Neq_2_0.
  exact Neq_2_0.
  exact Neq_2_0.
Qed.

Lemma sin3PI4 : sin (R3 * (PI / R4)) = R1 / sqrt R2.
Proof.
  replace (R3 * (PI / R4)) with (PI / R2 - - (PI / R4)).
  now rewrite sin_shift, cos_neg, cos_PI4.
  unfold Rminus.
  rewrite Ropp_involutive.
  unfold R3.
  rewrite Rmult_plus_distr_r.
  rewrite Rmult_1_l.
  apply Rplus_eq_compat_r.
  symmetry.
  unfold R4.
  rewrite <- double.
  unfold Rdiv.
  rewrite Rinv_mult_distr.
  repeat rewrite Rmult_assoc.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  rewrite Rinv_l, Rmult_1_r.
  reflexivity.
  exact Neq_2_0.
  exact Neq_2_0.
  exact Neq_2_0.
Qed.

Lemma cos_PI6 : cos (PI / R6) = sqrt R3 / R2.
Proof with trivial.
  apply Rsqr_inj...
  apply cos_ge_0...
  left; apply (Rlt_trans (- (PI / R2)) R0 (PI / R6) _PI2_RLT_0 PI6_RGT_0)...
  left; apply PI6_RLT_PI2...
  left; apply (Rmult_lt_0_compat (sqrt R3) (/ R2))...
  apply Rlt_sqrt3_0...
  apply Rinv_0_lt_compat; exact Rlt_0_2...
  rewrite Rsqr_div...
  rewrite cos2; unfold Rsqr; rewrite sin_PI6; rewrite sqrt_def...
unfold Rdiv, Rminus.
repeat rewrite Rmult_1_l.
unfold R3.
rewrite Rmult_plus_distr_r.
rewrite Rmult_1_l.
pattern R1;rewrite double_var.
unfold Rdiv.
rewrite Ropp_mult_distr_l.
rewrite <- Rmult_plus_distr_r.
rewrite <- Rmult_plus_distr_r.
rewrite Rinv_mult_distr.
repeat rewrite <- Rmult_assoc.
rewrite <- Rmult_plus_distr_r.
apply Rmult_eq_compat_r.
rewrite Rinv_r.
repeat rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
pattern R1;rewrite double_var.
unfold Rdiv.
rewrite Rmult_1_l.
repeat rewrite Rplus_assoc.
rewrite Rplus_opp_r, Rplus_0_r.
reflexivity.
  exact Neq_2_0.
  exact Neq_2_0.
  exact Neq_2_0.
left. exact Rlt_0_3.
  exact Neq_2_0.
Qed.

Lemma tan_PI6 : tan (PI / R6) = R1 / sqrt R3.
Proof.
  unfold tan; rewrite sin_PI6; rewrite cos_PI6; unfold Rdiv;
    repeat rewrite Rmult_1_l; rewrite Rinv_mult_distr.
  rewrite Rinv_involutive.
  rewrite (Rmult_comm (/ R2)); rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
  apply Rmult_1_r.
  exact Neq_2_0.
  exact Neq_2_0.
  red; intro; assert (H1 := Rlt_sqrt3_0); rewrite H in H1;
    elim (Rlt_irrefl R0 H1).
  apply Rinv_neq_0_compat; discrR.
  exact Neq_2_0.
Qed.

Lemma sin_PI3 : sin (PI / R3) = sqrt R3 / R2.
Proof.
  rewrite sin_PI3_cos_PI6; apply cos_PI6.
Qed.

Lemma cos_PI3 : cos (PI / R3) = R1 / R2.
Proof.
  rewrite sin_PI6_cos_PI3; apply sin_PI6.
Qed.

Lemma tan_PI3 : tan (PI / R3) = sqrt R3.
Proof.
  unfold tan; rewrite sin_PI3; rewrite cos_PI3; unfold Rdiv;
    rewrite Rmult_1_l; rewrite Rinv_involutive.
  rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  apply Rmult_1_r.
  exact Neq_2_0.
  exact Neq_2_0.
Qed.

Lemma sin_2PI3 : sin (R2 * (PI / R3)) = sqrt R3 / R2.
Proof.
  rewrite double; rewrite sin_plus; rewrite sin_PI3; rewrite cos_PI3;
    unfold Rdiv; repeat rewrite Rmult_1_l; rewrite (Rmult_comm (/ R2));
      repeat rewrite <- Rmult_assoc; rewrite double_var;
        reflexivity.
Qed.

Lemma cos_2PI3 : cos (R2 * (PI / R3)) = -R1 / R2.
Proof.
  rewrite cos_2a, sin_PI3, cos_PI3.
  replace (sqrt R3 / R2 * (sqrt R3 / R2)) with ((sqrt R3 * sqrt R3) / R4).
  rewrite sqrt_sqrt.
unfold Rdiv, Rminus.
repeat rewrite Rmult_1_l.
unfold R4.
rewrite <- double.
rewrite Rinv_mult_distr.
repeat rewrite Ropp_mult_distr_l.
repeat rewrite <- Rmult_assoc.
rewrite <- Rmult_plus_distr_r.
apply Rmult_eq_compat_r.
pattern (/R2) at 1;rewrite <- Rmult_1_l.
rewrite <- Rmult_plus_distr_r.
unfold R3.
rewrite Ropp_plus_distr.
rewrite Rplus_comm.
rewrite Rplus_assoc, Rplus_opp_l, Rplus_0_r.
rewrite <- Ropp_mult_distr_l.
rewrite Rinv_r.
reflexivity.
  exact Neq_2_0.
  exact Neq_2_0.
  exact Neq_2_0.
left. exact Rlt_0_3.
unfold Rdiv.
repeat rewrite Rmult_assoc.
apply Rmult_eq_compat_l.
symmetry.
rewrite Rmult_comm.
repeat rewrite Rmult_assoc.
apply Rmult_eq_compat_l.
rewrite <- Rinv_mult_distr.
unfold R4.
rewrite <- double.
reflexivity.
  exact Neq_2_0.
  exact Neq_2_0.
Qed.

Lemma tan_2PI3 : tan (R2 * (PI / R3)) = - sqrt R3.
Proof.
  unfold tan; rewrite sin_2PI3, cos_2PI3.
unfold Rdiv.
rewrite <- Ropp_mult_distr_l.
rewrite Rmult_1_l.
rewrite <- Ropp_inv_permute.
rewrite <- Ropp_mult_distr_r.
rewrite Rinv_involutive.
rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
reflexivity.
  exact Neq_2_0.
  exact Neq_2_0.
exact half_nz.
Qed.

Remark P45 : PI / R4 + PI = R5 * (PI / R4).
Proof.
unfold R5.
unfold R3.
symmetry.
repeat rewrite Rplus_assoc.
rewrite Rplus_comm.
repeat rewrite Rplus_assoc.
fold R4.
rewrite Rmult_plus_distr_r.
rewrite Rmult_1_l.
rewrite (Rmult_comm R4).
unfold Rdiv.
repeat rewrite Rmult_assoc.
rewrite Rinv_l, Rmult_1_r.
reflexivity.
apply Rlt_not_eq'. exact Rlt_0_4.
Qed.

Lemma cos_5PI4 : cos (R5 * (PI / R4)) = -R1 / sqrt R2.
Proof.
  replace (R5 * (PI / R4)) with (PI / R4 + PI).
  rewrite neg_cos; rewrite cos_PI4; unfold Rdiv.
rewrite <- Ropp_mult_distr_l. reflexivity.
exact P45.
Qed.

Lemma sin_5PI4 : sin (R5 * (PI / R4)) = -R1 / sqrt R2.
Proof.
  replace (R5 * (PI / R4)) with (PI / R4 + PI).
  rewrite neg_sin; rewrite sin_PI4; unfold Rdiv.
rewrite <- Ropp_mult_distr_l. reflexivity.
exact P45.
Qed.

Lemma sin_cos5PI4 : cos (R5 * (PI / R4)) = sin (R5 * (PI / R4)).
Proof.
  rewrite cos_5PI4; rewrite sin_5PI4; reflexivity.
Qed.

Lemma Rgt_3PI2_0 : R0 < R3 * (PI / R2).
Proof.
  apply Rmult_lt_0_compat;
    [ idtac
      | unfold Rdiv; apply Rmult_lt_0_compat;
        [ apply PI_RGT_0 | apply Rinv_0_lt_compat; idtac ] ].
exact Rlt_0_3.
exact Rlt_0_2.
Qed.

Lemma Rgt_2PI_0 : R0 < R2 * PI.
Proof.
  apply Rmult_lt_0_compat; [ idtac | apply PI_RGT_0 ].
exact Rlt_0_2.
Qed.

Lemma Rlt_PI_3PI2 : PI < R3 * (PI / R2).
Proof.
  generalize PI2_RGT_0; intro H1;
    generalize (Rplus_lt_compat_l PI R0 (PI / R2) H1);
      replace (PI + PI / R2) with (R3 * (PI / R2)).
  rewrite Rplus_0_r; intro H2; assumption.
  pattern PI at 2; rewrite double_var.
unfold R3.
unfold R2 at 1.
repeat rewrite Rmult_plus_distr_r.
repeat rewrite Rmult_1_l.
reflexivity.
Qed.

Lemma Rlt_3PI2_2PI : R3 * (PI / R2) < R2 * PI.
Proof.
  generalize PI2_RGT_0; intro H1;
    generalize (Rplus_lt_compat_l (R3 * (PI / R2)) R0 (PI / R2) H1);
      replace (R3 * (PI / R2) + PI / R2) with (R2 * PI).
  rewrite Rplus_0_r; intro H2; assumption.
  rewrite double; pattern PI at 1 2; rewrite double_var.
  repeat rewrite <- Rplus_assoc.
  apply Rplus_eq_compat_r.
  symmetry.
unfold R3.
unfold R2 at 1.
repeat rewrite Rmult_plus_distr_r.
repeat rewrite Rmult_1_l.
reflexivity.
Qed.

(***************************************************************)
(** Radian -> Degree | Degree -> Radian                        *)
(***************************************************************)

Definition R180 := R18 * R10.

Definition plat : R := R180.
Definition toRad (x:R) : R := x * PI * / plat.
Definition toDeg (x:R) : R := x * plat * / PI.

Remark Neq_180_0 : R180 <> R0.
Proof.
unfold R180.
apply Rmult_integral_contrapositive_currified.
apply Rlt_not_eq'.
unfold R18. apply Rplus_lt_0_compat.
unfold R9. apply Rplus_lt_0_compat.
apply Rplus_lt_0_compat.
exact Rlt_0_3.
exact Rlt_0_3.
exact Rlt_0_3.
unfold R9. apply Rplus_lt_0_compat.
apply Rplus_lt_0_compat.
exact Rlt_0_3.
exact Rlt_0_3.
exact Rlt_0_3.
apply Rlt_not_eq'.
unfold R10.
 apply Rplus_lt_0_compat.
exact Rlt_0_5.
exact Rlt_0_5.
Qed.

Lemma rad_deg : forall x:R, toRad (toDeg x) = x.
Proof.
  intro; unfold toRad, toDeg;
    replace (x * plat * / PI * PI * / plat) with
    (x * (plat * / plat) * (PI * / PI)).
  repeat rewrite <- Rinv_r_sym.
repeat rewrite Rmult_1_r. reflexivity.
  apply PI_neq0.

unfold plat.
exact Neq_180_0.

repeat rewrite Rmult_assoc.
repeat apply Rmult_eq_compat_l.
rewrite Rmult_comm.
repeat rewrite Rmult_assoc.
rewrite Rmult_comm.
repeat rewrite Rmult_assoc.
repeat apply Rmult_eq_compat_l.
rewrite Rmult_comm.
reflexivity.
Qed.

Lemma toRad_inj : forall x y:R, toRad x = toRad y -> x = y.
Proof.
  intros; unfold toRad in H; apply Rmult_eq_reg_l with PI.
  rewrite <- (Rmult_comm x); rewrite <- (Rmult_comm y).
  apply Rmult_eq_reg_l with (/ plat).
  rewrite <- (Rmult_comm (x * PI)); rewrite <- (Rmult_comm (y * PI));
    assumption.
  apply Rinv_neq_0_compat; unfold plat; discrR.
exact Neq_180_0.
  apply PI_neq0.

Qed.

Lemma deg_rad : forall x:R, toDeg (toRad x) = x.
Proof.
  intro x; apply toRad_inj; rewrite (rad_deg (toRad x)); reflexivity.
Qed.

Definition sind (x:R) : R := sin (toRad x).
Definition cosd (x:R) : R := cos (toRad x).
Definition tand (x:R) : R := tan (toRad x).

Lemma Rsqr_sin_cos_d_one : forall x:R, Rsqr (sind x) + Rsqr (cosd x) = R1.
Proof.
  intro x; unfold sind; unfold cosd; apply sin2_cos2.
Qed.

(***************************************************)
(**               Other properties                 *)
(***************************************************)

Lemma sin_lb_ge_0 : forall a:R, R0 <= a -> a <= PI / R2 -> R0 <= sin_lb a.
Proof.
  intros; case (Rtotal_order R0 a); intro.
  left; apply sin_lb_gt_0; assumption.
  elim H1; intro.
  rewrite <- H2; unfold sin_lb; unfold sin_approx;
    unfold sum_f_R0; unfold sin_term;
      repeat rewrite pow_ne_zero.
  unfold Rdiv; repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r;
    repeat rewrite Rplus_0_r; right; reflexivity.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  elim (Rlt_irrefl R0 (Rle_lt_trans R0 a R0 H H2)).
Qed.


Require Import Coq.omega.Omega.
Require Import Bedrock.Reflection.
Require Import Coq.Bool.Bool.

Ltac think' ext solver :=
  repeat (match goal with
            | [ H : Some _ = Some _ |- _ ] => inversion H ; clear H ; subst
            | [ H : inl _ = inr _ |- _ ] => inversion H ; clear H ; subst
            | [ H : inr _ = inr _ |- _ ] => inversion H ; clear H ; subst
            | [ H : _ |- _ ] => erewrite H in * |- by solver
            | [ H : _ |- _ ] => erewrite H by solver
            | [ H : andb _ _ = true |- _ ] =>
              apply andb_true_iff in H ; destruct H
            | [ H : orb _ _ = false |- _ ] =>
              apply orb_false_iff in H ; destruct H
            | [ H : Equivalence.equiv _ _ |- _ ] =>
              unfold Equivalence.equiv in H ; subst
            | [ H : _ /\ _ |- _ ] => destruct H
            | [ H : exists x, _ |- _ ] => destruct H
            | [ H : context [ match ?X with _ => _ end ] |- _ ] =>
              ((consider X ; try congruence); [ intros ]) ||
                (consider X ; solve [ congruence | solver ])
          end || (progress ext)).

Ltac think := think' idtac ltac:(eauto).

(** Lemmas About Lists **)
Require Import Coq.Lists.List.
Lemma nth_error_None_length : forall (T : Type) (ls : list T) (n : nat),
  nth_error ls n = None -> length ls <= n.
Proof.
  induction ls; destruct n; simpl; intros; think; try omega. inversion H.
  eapply IHls in H. omega.
Qed.

Lemma map_nth_error_full : forall T U (F : T -> U) ls n,
  nth_error (map F ls) n = match nth_error ls n with
                             | None => None
                             | Some v => Some (F v)
                           end.
Proof.
  induction ls; destruct n; simpl; intros; think; auto.
Qed.


Require Import Gensym.

Import adequacy_gensym.

(* =tree= *)
Inductive Tree (X : Type) :=
| Leaf : X -> Tree X
| Node : Tree X -> Tree X -> Tree X.
(* =end= *)

Arguments Leaf {_}.
Arguments Node {X}.

(* =label= *)
Fixpoint label {X} (t : Tree X) : mon Fresh (Tree ident) :=
  match t with
  | Leaf _ =>
    let! v := gensym in
    ret! (Leaf v)
  | Node l r =>
    let! l' := label l in
    let! r' := label r in
    ret! (Node l' r')
  end.
(* =end= *)

Definition relabel {X} (t : Tree X): Tree ident := snd (run (label t) initial_state).

Fixpoint flatten {X} (t: Tree X) : list X :=
  match t with
  | Leaf v => cons v nil
  | Node l r => flatten l ++ flatten r
  end.

Fixpoint sameShape {X Y} (t1 : Tree X) (t2 : Tree Y) : Prop :=
  match t1,t2 with
  | Leaf _, Leaf _ => True
  | Node l r, Node l_res r_res  => sameShape l l_res /\ sameShape r r_res
  | _, _ => False
  end.

Definition labelPost {X} (t: Tree X) (t_res : Tree ident) : iProp :=
  ([∗ list] x ∈ (flatten t_res), IsFresh x) ∗ ⌜sameShape t t_res⌝.

Lemma label_spec : forall X (t : Tree X),
    ⊢ {{ emp }} label t {{ t'; labelPost t t' }}.
Proof.
  induction t.
  - iBind. eapply gensym_spec. iRet. rewrite /labelPost. simpl; auto.
  - simpl label. iBind. eapply IHt1. iBind. Frame. eapply IHt2. iRet.
    rewrite /labelPost. iIntros "[[HA %] [HB %]]". iSplitL; auto.
    simpl. iApply big_sepL_app. iFrame.
Qed.

Lemma sep_list_fold : forall a l, ⊢ (IsFresh a -∗ ([∗ list] x ∈ l, IsFresh x) -∗ ⌜a ∉ l⌝ : iProp).
Proof.
  induction l; iIntros "* HA HB".
  - iPureIntro. intro. inversion H.
  - iDestruct "HB" as "[HA' HB]".
    iDestruct (singleton_neq with "HA HA'") as "%".
    iDestruct (IHl with "HA HB") as "%". iPureIntro.
    intro. inversion H1; subst; auto.
Qed.

Lemma fold_nodup : forall l,
    ⊢ (([∗ list] x ∈ l, IsFresh x) : iProp) -∗ ⌜NoDup l⌝.
Proof.
  induction l; simpl; iIntros; norm_all; auto.
  - iPureIntro. apply NoDup_nil_2.
  - iDestruct (IHl with "HC") as "%". iDestruct (sep_list_fold with "HB HC") as "%".
    iPureIntro. constructor; auto.
Qed.

Lemma finish_him : forall X (t : Tree X) t' h,
    labelPost t t' () h -> NoDup (flatten t') /\ sameShape t t'.
Proof.
  intros. apply soundness3 in H. apply (soundness1 h).
  iIntros "HA". iDestruct (H with "HA") as "[HA HB]".
  iDestruct (fold_nodup with "HA") as "HA". iSplit; auto.
Qed.

Lemma relabel_spec : forall X (t : Tree X) t',
    relabel t = t' -> NoDup (flatten t') /\ sameShape t t'.
Proof.
  intros. unfold relabel in H. destruct (run (label t) initial_state) eqn:?.
  destruct H. simpl.
  destruct (use_adequacy _ _ _ _ _ emp_trivial (label_spec _ _) Heqp).
  eapply finish_him. eapply H.
Qed.


(** DepMap: Maps with explicit domain contained in their type *)
Require Import Utf8.
Require Import MSets.
Require Import FMaps.
Require Import Orders.
Require Import Coqlib.
Require Import DepMapInterface.

Set Implicit Arguments.

(******************************************************************************)
(** **  Implementation of maps with explicit domain contained in their type  **)
(******************************************************************************)

Module DepMapImpl (X : OrderedType) : (DepMap X) with Definition key := X.t.

(** The type of domains **)
Module Dom := MSetAVL.Make(X).
Module Ddec := Decide(Dom).
Module DProp := EqProperties(Dom).
Ltac fsetdec := Ddec.fsetdec.

(** The type of maps over this domain **)
Module XOT := OTconvert X.
Module S := FMapList.Make(XOT).

(** The type of dependent maps **)
Definition key := X.t.
Definition OK {A} dom (map : S.t A) := ∀ x, S.In x map <-> Dom.In x dom.
Definition t := fun A dom => { map : S.t A | OK dom map}.

Instance OK_compat A : Proper (Dom.eq ==> @S.Equal A ==> iff) OK.
Proof.
intros dom₁ dom₂ Hdom m₁ m₂ Heq. split; intros Hok x.
+ rewrite <- Hdom, <- (Hok x). split; intros [v Hin]; exists v; apply S.find_2.
  - rewrite Heq. apply S.find_1. assumption.
  - rewrite <- Heq. apply S.find_1. assumption.
+ rewrite Hdom, <- (Hok x). split; intros [v Hin]; exists v; apply S.find_2.
  - rewrite <- Heq. apply S.find_1. assumption.
  - rewrite Heq. apply S.find_1. assumption.
Qed.

(** ***  Operations on maps **)

(** The empty map. **)
Lemma empty_OK : forall A, OK Dom.empty (S.empty A).
Proof.
intro x. split; intro Hin.
+ destruct Hin as [v Hin]. elim (S.empty_1 Hin).
+ fsetdec.
Qed.

Definition empty : forall A, t A Dom.empty := fun A => exist (OK Dom.empty) (@S.empty A) (empty_OK A).

Definition is_empty (A : Type) dom (m : t A dom) := Dom.equal dom Dom.empty.

Definition mem (A : Type) dom (x : key) (m : t A dom) := Dom.mem x dom.

Definition find (A : Type) dom (x : key) (m : t A dom) := S.find x (proj1_sig m).

Definition domain (A : Type) dom (m : t A dom) := dom.

(** [add] **)
Lemma add_OK : forall A dom x v (m : t A dom), OK (Dom.add x dom) (S.add x v (proj1_sig m)).
Proof.
destruct m as [m Hok]. simpl. intro y. split; intro Hin.
+ destruct Hin as [u Hy]. destruct (X.eq_dec x y) as [Hxy | Hxy].
  - fsetdec.
  - rewrite Dom.add_spec. right. rewrite <- (Hok y). apply S.add_3 in Hy; trivial. exists u. assumption.
+ rewrite Dom.add_spec in Hin. destruct (X.eq_dec x y) as [Hxy | Hxy].
  - exists v. apply S.add_1. assumption.
  - destruct Hin as [Hin | Hin]; try now symmetry in Hin; contradiction. rewrite <- (Hok y) in Hin.
    destruct Hin as [u Hy]. exists u. apply S.add_2; assumption.
Qed.

Definition add {A : Type} {dom : Dom.t} (x : key) (v : A) (m : @t A dom) : @t A (Dom.add x dom) :=
  exist (OK (Dom.add x dom)) (S.add x v (proj1_sig m)) (add_OK x v m).

(** [set] **)
Lemma set_OK : forall A dom x v (m : t A dom), Dom.In x dom -> OK dom (S.add x v (proj1_sig m)).
Proof.
destruct m as [m Hok]. intros Hx y. simpl. destruct (X.eq_dec y x) as [Hxy | Hxy].
+ split; intro Hin.
  - rewrite Hxy. assumption.
  - exists v. apply S.add_1. symmetry. assumption.
+ split; intro Hin.
  - destruct Hin as [v' Hin]. rewrite <- (Hok y). exists v'. eapply S.add_3. symmetry. eassumption. eassumption.
  - rewrite <- (Hok y) in Hin. destruct Hin as [v' Hin]. exists v'. eapply S.add_2. symmetry. assumption. trivial.
Qed.

Definition set {A : Type} {dom : Dom.t} (x : key) (v : A) (m : @t A dom) (Hin : Dom.In x dom) :=
  exist (OK dom) (S.add x v (proj1_sig m)) (@set_OK _ _ x v m Hin).
Arguments set {A} {dom} x v m _.

(** [singleton] **)
Lemma singleton_OK : forall A x v, OK (Dom.singleton x) (S.add x v (S.empty A)).
Proof.
intros A x v y. split; intro Hin.
+ destruct (X.eq_dec y x) as [Hxy | Hxy].
  - fsetdec.
  - destruct Hin as [u Hin]. apply S.add_3 in Hin. elim (S.empty_1 Hin). symmetry. assumption.
+ rewrite Dom.singleton_spec in Hin. exists v. apply S.add_1. symmetry; assumption.
Qed.

Definition singleton {A : Type} (x : key) (v : A) : t A (Dom.singleton x) :=
  exist (OK (Dom.singleton x)) (S.add x v (@S.empty A)) (singleton_OK x v).

(** [remove] **)
Lemma remove_OK : forall A dom x (m : t A dom), OK (Dom.remove x dom) (S.remove (elt:=A) x (proj1_sig m)).
Proof.
destruct m as [m Hok]. simpl. intro y. split; intro Hin.
+ destruct (X.eq_dec x y) as [Hxy | Hxy].
  - elim (S.remove_1 Hxy Hin).
  - rewrite Dom.remove_spec. destruct Hin as [u Hy]. apply S.remove_3 in Hy. rewrite <- (Hok y).
    split. now exists u. now symmetry.
+ rewrite Dom.remove_spec in Hin. destruct Hin as [Hin Hxy].
  rewrite <- (Hok y) in Hin. destruct Hin as [u Hin]. exists u. apply S.remove_2; trivial. now symmetry.
Qed.

Definition remove {A : Type} {dom : Dom.t} (x : key) (m : @t A dom) : @t A (Dom.remove x dom) :=
  exist (OK (Dom.remove x dom)) (S.remove x (proj1_sig m)) (remove_OK x m).

(** [constant] **)
Lemma constant_OK_aux : forall A v (m : S.t A) l x,
  S.In x (fold_left (λ (a : S.t A) (e : Dom.elt), S.add e v a) l m) <-> S.In x m ∨ InA X.eq x l.
Proof.
intros A v m l x. revert m. induction l as [| y l]; intro m; simpl.
* rewrite InA_nil. intuition.
* split; intro Hin.
  + destruct (X.eq_dec x y) as [Hxy | Hxy].
    - right; left. assumption.
    - rewrite IHl in Hin. destruct Hin as [[v' Hin] | Hin].
        left. exists v'. apply S.add_3 in Hin; auto. now symmetry.
        now do 2 right.
  + rewrite IHl. destruct Hin as [Hin | Hin].
    - left. destruct (X.eq_dec x y) as [Hxy | Hxy].
        exists v. apply S.add_1. now auto.
        destruct Hin as [v' Hin]. exists v'. apply S.add_2; auto. now symmetry.
    - inversion_clear Hin.
        left. exists v. apply S.add_1. now auto.
        now right.
Qed.

Corollary constant_OK : forall A dom v, OK dom (Dom.fold (fun x m => S.add x v m) dom (S.empty A)).
Proof.
intros * ?. rewrite Dom.fold_spec, <- Dom.elements_spec1, constant_OK_aux.
intuition. destruct H0 as [? Hin]. elim (S.empty_1 Hin).
Qed.

Definition constant (A : Type) dom (v : A) : t A dom :=
  exist (OK dom) (Dom.fold (fun x m => S.add x v m) dom (@S.empty A)) (constant_OK dom v).

(** [fold] **)
Definition fold {A B : Type} (f : key -> A -> B -> B) dom (m : t A dom) (i : B) : B := S.fold f (proj1_sig m) i.

(** [map] **)
Lemma map_OK : forall A B (f : A -> B) dom (m : t A dom), OK dom (S.map f (proj1_sig m)).
Proof.
intros A B f dom m. intro x. rewrite <- (proj2_sig m x). split; intro Hin.
+ apply S.map_2 in Hin. assumption.
+ destruct Hin as [v Hv]. exists (f v). apply S.map_1. assumption.
Qed.

Definition map {A B : Type} (f : A -> B) dom (m : t A dom) : t B dom :=
  exist (OK dom) (S.map f (proj1_sig m)) (map_OK f m).

(** [combine] **)
Definition Scombine {A B C : Type} (f : A -> B -> C) (g : A -> C) (h : B -> C) (m₁ : S.t A) (m₂ : S.t B) : S.t C :=
  Dom.fold (fun x acc => match S.find x m₁, S.find x m₂ with
                           | Some v₁, Some v₂ => S.add x (f v₁ v₂) acc
                           | Some v, None => S.add x (g v) acc
                           | None, Some v => S.add x (h v) acc
                           | None, None => acc
                         end)
           (Dom.union (S.fold (fun x _ acc => Dom.add x acc) m₁ Dom.empty)
                      (S.fold (fun x _ acc => Dom.add x acc) m₂ Dom.empty)) (S.empty C).

Lemma Sdom_aux : forall A x (m : S.t A) s,
  Dom.In x (S.fold (fun x _ acc => Dom.add x acc) m s) <-> S.In x m ∨ Dom.In x s.
Proof.
intros A x m. setoid_rewrite S.fold_1.
assert (Hequiv : S.In x m ↔ (∃ v : A, InA (X.eq * eq)%signature (x, v) (S.elements m))).
{ split; intros [v Hin]; exists v; apply S.elements_1 + apply S.elements_2; assumption. }
setoid_rewrite Hequiv. generalize (S.elements m). intro l. induction l as [| [x' v'] l]; simpl.
* setoid_rewrite InA_nil. firstorder.
* intro s. rewrite IHl. clear IHl. rewrite Dom.add_spec. split; intros [[v Hin] | Hin].
  + left. exists v. right. assumption.
  + destruct Hin as [Heq |Hin].
    - left. exists v'. left. split; trivial. reflexivity.
    - tauto.
  + inversion_clear Hin.
    - destruct H. tauto.
    - left. exists v. assumption.
  + tauto.
Qed.

Corollary Sdom : forall A x (m : S.t A), Dom.In x (S.fold (fun x _ acc => Dom.add x acc) m Dom.empty) <-> S.In x m.
Proof. intros. rewrite Sdom_aux. fsetdec. Qed.

Lemma Sfind_compat : forall {A x y} {m : S.t A}, X.eq x y -> S.find x m = S.find y m.
Proof.
intros A x y m Hxy. destruct (S.find y m) eqn:Hin.
+ symmetry in Hxy. eapply S.find_1, S.MapsTo_1, S.find_2; eassumption.
+ destruct (S.find x m) eqn:Habs; trivial. rewrite <- Hin. symmetry.
  eapply S.find_1, S.MapsTo_1, S.find_2; eassumption.
Qed.

Lemma Scombine_spec_aux : forall A B C (f : A -> B -> C) g h x v m₁ m₂ l m, NoDupA X.eq l ->
S.find (elt:=C) x
  (fold_left
     (fun (acc : S.t C) (x : Dom.elt) => match S.find x m₁, S.find x m₂ with
                                           | Some v₁, Some v₂ => S.add x (f v₁ v₂) acc
                                           | Some v, None => S.add x (g v) acc
                                           | None, Some v => S.add x (h v) acc
                                           | None, None => acc
                                         end) l m) = Some v
  <-> InA X.eq x l ∧ ((exists v₁ v₂, S.find x m₁ = Some v₁ ∧ S.find x m₂ = Some v₂ ∧ v = f v₁ v₂)
                      ∨ (exists v₁, S.find x m₁ = Some v₁ ∧ S.find x m₂ = None ∧ v = g v₁)
                      ∨ (exists v₂, S.find x m₁ = None ∧ S.find x m₂ = Some v₂ ∧ v = h v₂))
   ∨ ((InA X.eq x l ∧ S.find x m₁ = None ∧ S.find x m₂ = None ∨ ¬InA X.eq x l) ∧ S.find x m = Some v).
Proof.
intros A B C f g h x v m₁ m₂ l. induction l as [| x' l]; intros m Hnodup; simpl.
* rewrite InA_nil. tauto.
* inversion_clear Hnodup. rewrite IHl; trivial. clear IHl. split; intros [Hin | Hin].
  + left. destruct Hin as [Hl Hin]. split.
    - now right.
    - destruct Hin as [Hin | [Hin| Hin]]; tauto.
  + destruct Hin as [[[Hl [Hin₁ Hin₂]] | Hl] Hm].
    - { right. split.
        + left. repeat split; trivial. now right.
        + destruct (X.eq_dec x x') as [Heq | Heq].
          - rewrite (Sfind_compat Heq) in Hin₁; rewrite (Sfind_compat Heq) in Hin₂.
            rewrite Hin₁, Hin₂ in Hm. assumption.
          - destruct (S.find x' m₁), (S.find x' m₂); trivial;
            apply S.find_2, S.add_3, S.find_1 in Hm; trivial; symmetry; assumption. }
    - { destruct (X.eq_dec x x') as [Heq | Heq].
        + destruct (S.find x' m₁) as [v₁ |] eqn:Hv₁, (S.find x' m₂) as [v₂ |] eqn:Hv₂.
          - left. split; try (left; assumption). left. exists v₁, v₂. repeat rewrite (Sfind_compat Heq).
            repeat split; trivial. cut (Some v = Some (f v₁ v₂)). intro Hfv; inversion Hfv; reflexivity.
            rewrite <- Hm. apply S.find_1, S.add_1. symmetry. assumption.
          - left. split; try (left; assumption). right; left. exists v₁. repeat rewrite (Sfind_compat Heq).
            repeat split; trivial. cut (Some v = Some (g v₁)). intro Hfv; inversion Hfv; reflexivity.
            rewrite <- Hm. apply S.find_1, S.add_1. symmetry. assumption.
          - left. split; try (left; assumption). do 2 right. exists v₂. repeat rewrite (Sfind_compat Heq).
            repeat split; trivial. cut (Some v = Some (h v₂)). intro Hfv; inversion Hfv; reflexivity.
            rewrite <- Hm. apply S.find_1, S.add_1. symmetry. assumption.
          - right. split; trivial. left. repeat rewrite (Sfind_compat Heq). repeat split; trivial. now left.
        + right. split.
          - right. intro Habs. inversion_clear Habs; contradiction.
          - destruct (S.find x' m₁), (S.find x' m₂); trivial;
            apply S.find_2, S.add_3, S.find_1 in Hm; trivial;  symmetry; assumption. }
  + destruct Hin as [Hl Hin]. inversion_clear Hl.
    - right. rewrite H1 at 4. split; try now right.
      destruct Hin as [[v₁ [v₂ [Hin₁ [Hin₂ Hv]]]] | [[v₁ [Hin₁ [Hin₂ Hv]]] | [v₂ [Hin₁ [Hin₂ Hv]]]]];
      rewrite (Sfind_compat H1) in Hin₁; rewrite (Sfind_compat H1) in Hin₂; rewrite Hin₁, Hin₂;
      subst v; apply S.find_1, S.add_1; symmetry; assumption.
    - left. split; assumption.
  + destruct Hin as [[[Hin [Hin₁ Hin₂]] | Hin] Hm].
    - { right. inversion_clear Hin.
        + rewrite (Sfind_compat H1) in Hin₁; rewrite (Sfind_compat H1) in Hin₂; rewrite Hin₁, Hin₂.
          split; trivial. right. rewrite H1. assumption.
        + assert (¬X.eq x x'). { intro Habs. apply H. rewrite <- Habs. assumption. }
          split; try tauto. destruct (S.find x' m₁), (S.find x' m₂); trivial;
          apply S.find_1, S.add_2, S.find_2; trivial; symmetry; assumption. }
    - { right. split.
        + right. intro Habs. apply Hin. now right.
        + assert (¬X.eq x x'). { intro Habs. apply Hin. now left. }
          destruct (S.find x' m₁), (S.find x' m₂); trivial;
          apply S.find_1, S.add_2, S.find_2; trivial; symmetry; assumption. }
Qed.

Theorem Scombine_spec : forall A B C (f : A -> B -> C) g h x v m₁ m₂,
  S.find x (Scombine f g h m₁ m₂) = Some v <->
  (exists v₁ v₂, S.find x m₁ = Some v₁ ∧ S.find x m₂ = Some v₂ ∧ v = f v₁ v₂)
  ∨ (exists v₁, S.find x m₁ = Some v₁ ∧ S.find x m₂ = None ∧ v = g v₁)
  ∨ (exists v₂, S.find x m₁ = None ∧ S.find x m₂ = Some v₂ ∧ v = h v₂).
Proof.
intros A B C f g h x v m₁ m₂. unfold Scombine. rewrite Dom.fold_spec.
rewrite Scombine_spec_aux.
* rewrite Dom.elements_spec1, Dom.union_spec, Sdom, Sdom. split; intro Hin.
  + destruct Hin as [[_ ?] | [_ Habs]].
    - assumption.
    - apply S.find_2, S.empty_1 in Habs. elim Habs.
  + left. split; trivial. destruct Hin as [[v' [? [Hin _]]] | [[v' [? _]] | [v' [_ [? _]]]]];
    left + right; exists v'; apply S.find_2; assumption.
* eapply SortA_NoDupA; refine _. apply Dom.elements_spec2.
Qed.

Lemma combine_OK : forall A B C (f : A -> B -> C) g₁ g₂ dom₁ dom₂ (m₁ : t A dom₁) (m₂ : t B dom₂),
  OK (Dom.union dom₁ dom₂) (Scombine f g₁ g₂ (proj1_sig m₁) (proj1_sig m₂)).
Proof.
destruct m₁ as [m₁ Hok₁], m₂ as [m₂ Hok₂]. simpl. intro x. rewrite Dom.union_spec. split; intro Hin.
+ destruct Hin as [v Hin]. apply S.find_1 in Hin. rewrite (Scombine_spec f) in Hin.
  destruct Hin as [Hin | [Hin | Hin]].
  - destruct Hin as [v₁ [v₂ [Hv₁ _]]]. left. rewrite <- (Hok₁ x). exists v₁. apply S.find_2. assumption.
  - destruct Hin as [v₁ [Hv₁ _]]. left. rewrite <- (Hok₁ x). exists v₁. apply S.find_2. assumption.
  - destruct Hin as [v₂ [_ [Hv₂ _]]]. right. rewrite <- (Hok₂ x). exists v₂. apply S.find_2. assumption.
+ destruct (Dom.mem x dom₁) eqn:Hin₁, (Dom.mem x dom₂) eqn:Hin₂; try rewrite Dom.mem_spec in *.
  - rewrite <- (Hok₁ x) in Hin₁. destruct Hin₁ as [v₁ Hin₁].
    rewrite <- (Hok₂ x) in Hin₂. destruct Hin₂ as [v₂ Hin₂].
    exists (f v₁ v₂). apply S.find_2. rewrite Scombine_spec. left. exists v₁, v₂. now repeat split; apply S.find_1.
  - rewrite <- (Hok₁ x) in Hin₁. destruct Hin₁ as [v₁ Hin₁]. exists (g₁ v₁). apply S.find_2.
    rewrite Scombine_spec. right; left. exists v₁. repeat split; try now apply S.find_1.
    destruct (S.find x m₂) as [v |] eqn:Hfind; trivial. assert (Habs : S.In x m₂) by now exists v; apply S.find_2.
    rewrite (Hok₂ x), <- Dom.mem_spec, Hin₂ in Habs. discriminate Habs.
  - rewrite <- (Hok₂ x) in Hin₂. destruct Hin₂ as [v₂ Hin₂]. exists (g₂ v₂). apply S.find_2.
    rewrite Scombine_spec. do 2 right. exists v₂. repeat split; try now apply S.find_1.
    destruct (S.find x m₁) as [v |] eqn:Hfind; trivial. assert (Habs : S.In x m₁) by now exists v; apply S.find_2.
    rewrite (Hok₁ x), <- Dom.mem_spec, Hin₁ in Habs. discriminate Habs.
  - destruct Hin as [Habs | Habs]; rewrite <- Dom.mem_spec in Habs; rewrite Habs in *; discriminate.
Qed.

Definition combine A B C f g₁ g₂ dom₁ dom₂ (m₁ : t A dom₁) (m₂ : t B dom₂) : t C (Dom.union dom₁ dom₂) :=
  exist (OK (Dom.union dom₁ dom₂)) (Scombine f g₁ g₂ (proj1_sig m₁) (proj1_sig m₂)) (combine_OK f g₁ g₂ m₁ m₂).

(** [cast] **)
Lemma cast_OK : forall A dom₁ dom₂ (Heq : Dom.eq dom₁ dom₂) (m : S.t A), OK dom₁ m -> OK dom₂ m.
Proof. intros. apply (@OK_compat A _ _ Heq m m); trivial. intro. reflexivity. Qed.

Definition cast {A : Type} dom₁ dom₂ (Heq : Dom.eq dom₁ dom₂) (m : t A dom₁) : t A dom₂ :=
  exist (OK dom₂) (proj1_sig m) (cast_OK Heq (proj2_sig m)).

(** [elements] **)
Definition elements A dom (m : t A dom) := S.elements (proj1_sig m).

(** [from_elements] **)
Lemma pre_from_elements_OK : forall A l dom (m : t A dom),
  OK (fold_left (fun acc xv => Dom.add (fst xv) acc) l (domain m))
     (fold_left (fun acc xv => S.add (fst xv) (snd xv) acc) l (proj1_sig m)).
Proof.
intros A l. induction l as [| [x v] l]; intros dom m; simpl; unfold domain.
+ apply (proj2_sig m).
+ change (Dom.add x dom) with (domain (add x v m)).
  change (S.add x v (proj1_sig m)) with (proj1_sig (add x v m)).
  apply IHl.
Qed.

Corollary from_elements_OK : forall A l,
  OK (fold_left (fun acc xv => Dom.add (fst xv) acc) l Dom.empty)
     (fold_left (fun acc xv => S.add (fst xv) (snd xv) acc) l (S.empty A)).
Proof.
intros. change Dom.empty with (domain (@empty A)).
change (S.empty A) with (proj1_sig (@empty A)). apply pre_from_elements_OK.
Qed.

Definition from_elements A (l : list (key * A))
  : t A (List.fold_left (fun acc xv => Dom.add (fst xv) acc) l Dom.empty) :=
  exist (OK (List.fold_left (fun acc xv => Dom.add (fst xv) acc) l Dom.empty))
        (List.fold_left (fun acc xv => S.add (fst xv) (snd xv) acc) l (@S.empty A))
        (from_elements_OK l).

(** ***  Specifications  **)

Lemma empty_spec : forall A x, find x (@empty A) = None.
Proof. intros. reflexivity. Qed.

Lemma is_empty_spec : forall A dom (m : t A dom), is_empty m = true <-> forall x, find x m = None.
Proof.
unfold find, is_empty. intros A dom [m Hok]. simpl. split; intro Hempty.
+ intro x. destruct (S.find x m) as [v |] eqn:?; trivial. assert (Habs : S.In x m) by now exists v; apply S.find_2.
  rewrite (Hok x) in Habs. rewrite Dom.equal_spec in Hempty. fsetdec.
+ apply Dom.equal_spec, DProp.MP.empty_is_empty_1. intros x Habs. rewrite <- (Hok x) in Habs.
  destruct Habs as [v Habs]. apply S.find_1 in Habs. rewrite Hempty in Habs. discriminate Habs.
Qed.

Lemma mem_spec : forall A x dom (m : t A dom), mem x m = true <-> exists v, find x m = Some v.
Proof.
intros A x dom [m Hok]. unfold mem, find. simpl. rewrite Dom.mem_spec. rewrite <- (Hok x).
split; intros [v Hin]; apply S.find_1 in Hin || apply S.find_2 in Hin; exists v; assumption.
Qed.

Instance find_elt_compat A dom (m : t A dom) : Proper (X.eq ==> Logic.eq) (fun x => find x m).
Proof.
intros x y Hxy. unfold find. destruct (S.find y (proj1_sig m)) as [v |] eqn:Hin.
+ eapply S.find_1, S.MapsTo_1, S.find_2; try eassumption. now symmetry.
+ destruct (S.find x (proj1_sig m)) as [v |] eqn:Hin'; trivial.
  eapply S.find_2, S.MapsTo_1, S.find_1 in Hin'; try eassumption; auto. rewrite Hin in Hin'. discriminate Hin'.
Qed.

Lemma find_spec : forall A x dom (m : t A dom), (exists v, find x m = Some v) <-> Dom.In x dom.
Proof.
intros A x dom [m Hok]. unfold find. simpl. rewrite <- (Hok x).
split; intros [v Hin]; exists v; apply S.find_1 || apply S.find_2; assumption.
Qed.

Lemma domain_spec : forall A dom (m : t A dom), domain m = dom.
Proof. intros. reflexivity. Qed.

Lemma set_same : forall A x v dom (m : t A dom) Hin, find x (@set A dom x v m Hin) = Some v.
Proof. intros. unfold set, find. simpl. apply S.find_1, S.add_1. reflexivity. Qed.

Lemma set_other : forall A x y v dom (m : t A dom) Hin, ¬X.eq y x -> find y (@set A dom x v m Hin) = find y m.
Proof.
intros. unfold set, find. simpl. destruct (S.find y (proj1_sig m)) eqn:Hin1.
+ apply S.find_1, S.add_2, S.find_2; trivial. now symmetry.
+ destruct (S.find y (S.add x v (proj1_sig m))) eqn:Hin2; trivial. apply S.find_2, S.add_3, S.find_1 in Hin2.
  - rewrite Hin1 in Hin2. discriminate Hin2.
  - now symmetry.
Qed.

Lemma add_same : forall A x v dom (m : t A dom), find x (add x v m) = Some v.
Proof. intros ? ? ? ? [? ?]. unfold add, find. simpl. apply S.find_1, S.add_1. reflexivity. Qed.

Lemma add_other : forall A x y v dom (m : t A dom), ¬X.eq y x -> find y (add x v m) = find y m.
Proof.
intros A x y v dom [m Hok] Heq. unfold add, find. simpl. destruct (S.find y m) as [u |] eqn:Hin.
+ apply S.find_1, S.add_2, S.find_2; trivial; now symmetry.
+ destruct (S.find y (S.add x v m)) as [u |] eqn:Hin'; trivial.
  apply S.find_2, S.add_3, S.find_1 in Hin'. rewrite Hin in Hin'. discriminate Hin'. now symmetry.
Qed.

Lemma singleton_same : forall A x (v : A), find x (singleton x v) = Some v.
Proof. intros. unfold singleton, find. simpl. apply S.find_1, S.add_1. reflexivity. Qed.

Lemma singleton_other : forall A x y (v : A), ¬X.eq y x -> find y (singleton x v) = None.
Proof.
intros A x y v Heq. unfold singleton, find. simpl.
destruct (S.find y (S.add x v (S.empty A))) as [u |] eqn:Hin; trivial.
apply S.find_2, S.add_3 in Hin. elim (S.empty_1 Hin). now symmetry.
Qed.

Lemma remove_same : forall A x dom (m : t A dom), find x (remove x m) = None.
Proof.
intros A x dom [m Hok]. unfold remove, find. simpl. destruct (S.find x (S.remove x m)) as [v |] eqn:Hin; trivial.
apply S.find_2 in Hin. eelim S.remove_1. reflexivity. exists v. eassumption.
Qed.

Lemma remove_other : forall A x y dom (m : t A dom), ¬X.eq y x -> find y (remove x m) = find y m.
Proof.
intros A x y dom [m Hok] Heq. unfold find, remove. simpl. destruct (S.find y m) as [v |] eqn:Hin.
+ apply S.find_1, S.remove_2, S.find_2; trivial; now symmetry.
+ destruct (S.find y (S.remove x m)) as [v |] eqn:Hin'; trivial.
  apply S.find_2, S.remove_3, S.find_1 in Hin'; auto. rewrite Hin in Hin'. discriminate Hin'.
Qed.

Lemma constant_aux : forall A v x u l (m : S.t A), NoDupA X.eq l ->
  S.find x (fold_left (fun a e => S.add e v a) l m) = Some u <->
  InA X.eq x l ∧ u = v ∨ ¬InA X.eq x l ∧ S.find x m = Some u.
Proof.
intros A v x u l. induction l as [| x' l]; intros m Hl; simpl.
* rewrite InA_nil. tauto.
* rewrite IHl. clear IHl. split; intro Hin.
  + destruct Hin as [[Hin ?] | [? Hin]].
    - left. split; trivial. now right.
    - { destruct (X.eq_dec x' x) as [Heq | Heq].
        + left. rewrite Heq. split; try now left. cut (Some u = Some v). intro Heq'; inversion Heq'; reflexivity.
          rewrite <- Hin. apply S.find_1. eapply S.MapsTo_1, S.add_1; try eassumption || reflexivity.
        + right. split.
          - intro Habs. inversion_clear Habs; solve [contradiction | apply Heq; symmetry; assumption].
          - eapply S.find_1, S.add_3, S.find_2; eassumption. }
  + destruct Hin as [[Hin ?] | [? Hin]].
    - subst. inversion_clear Hin; try tauto. right. split.
        inversion_clear Hl. rewrite H. assumption.
        apply S.find_1, S.add_1. symmetry; assumption.
    - right. split.
        intro Habs. apply H. now right.
        apply S.find_1, S.add_2, S.find_2; trivial. intro Habs. apply H. now left.
  + inversion_clear Hl. assumption.
Qed.

Lemma constant_Some : forall A dom (v : A) x u, find x (constant dom v) = Some u <-> Dom.In x dom ∧ u = v.
Proof.
intros A dom v x u. unfold constant, find. simpl. rewrite Dom.fold_spec, <- Dom.elements_spec1, constant_aux.
split; intro Hin.
+ destruct Hin; trivial. exfalso. destruct H as [_ Habs]. apply S.find_2 in Habs. revert Habs. apply S.empty_1.
+ left. assumption.
+ eapply SortA_NoDupA; refine _. apply Dom.elements_spec2.
Qed.

Lemma constant_None : forall A dom (v : A) x, find x (constant dom v) = None <-> ¬Dom.In x dom.
Proof.
intros A dom v x. unfold constant, find. simpl. rewrite Dom.fold_spec, <- Dom.elements_spec1.
split; intro Hin.
+ intro Habs. assert (Hconj := conj Habs (eq_refl v)). (*BUG: eapply or_introl makes Hconj disappear *)
  apply (@or_introl _ (¬ InA X.eq (x : Dom.elt) (Dom.elements dom) ∧ S.find x (S.empty A) = Some v)) in Hconj.
  rewrite <- constant_aux in Hconj. (* BUG: rewrite Hin in Hconf impossible *)
  - cut (None = Some v). discriminate. rewrite <- Hin. assumption.
  - eapply SortA_NoDupA; refine _. apply Dom.elements_spec2.
+ destruct (S.find x (fold_left (fun a (e : Dom.elt) => S.add e v a) (Dom.elements dom) (S.empty A))) eqn:H; trivial.
  rewrite constant_aux in H. destruct H as [[H _] | [_ H]].
  - contradiction.
  - exfalso. apply S.find_2 in H. revert H. apply S.empty_1.
  - eapply SortA_NoDupA; refine _. apply Dom.elements_spec2.
Qed.

Lemma map_spec : forall A B (f : A -> B) dom (m : t A dom) x v,
  find x (map f m) = Some v <-> exists u, find x m = Some u ∧ f u = v.
Proof.
intros A B f dom m x v. unfold find, map. simpl. split; intro Hin.
+ assert (Hf : S.In x (S.map f (proj1_sig m))). { exists v. apply S.find_2. assumption. }
  apply S.map_2 in Hf. destruct Hf as [u Hu]. exists u. split.
  - apply S.find_1. assumption.
  - eapply S.map_1, S.find_1 in Hu. erewrite Hu in Hin. inversion Hin. reflexivity.
+ destruct Hin as [u [Hu Heq]]. subst. apply S.find_1, S.map_1, S.find_2. assumption.
Qed.

Lemma combine_spec : forall A B C (f : A -> B -> C) g₁ g₂ dom₁ dom₂ (m₁ : t A dom₁) (m₂ : t B dom₂) x v,
  find x (combine f g₁ g₂ m₁ m₂) = Some v <->
  (exists v₁ v₂, find x m₁ = Some v₁ ∧ find x m₂ = Some v₂ ∧ v = f v₁ v₂)
  ∨ (exists v₁, find x m₁ = Some v₁ ∧ find x m₂ = None ∧ v = g₁ v₁)
  ∨ (exists v₂, find x m₁ = None ∧ find x m₂ = Some v₂ ∧ v = g₂ v₂).
Proof.
intros A B C f g₁ g₂ dom₁ dom₂ [m₁ Hok₁] [m₂ Hok₂] x v. unfold combine, find. simpl. rewrite Scombine_spec.
split; intros [Hin | [Hin | Hin]].
+ destruct Hin as [v₁ [v₂ [Hin₁ [Hin₂ Heq]]]]. left. exists v₁, v₂. auto.
+ destruct Hin as [v₁ [Hin₁ [Hin₂ Heq]]]. right; left. exists v₁. auto.
+ destruct Hin as [v₂ [Hin₁ [Hin₂ Heq]]]. do 2 right. exists v₂. auto.
+ destruct Hin as [v₁ [v₂ [Hin₁ [Hin₂ Heq]]]]. left. exists v₁, v₂. auto.
+ destruct Hin as [v₁ [Hin₁ [Hin₂ Heq]]]. right; left. exists v₁. auto.
+ destruct Hin as [v₂ [Hin₁ [Hin₂ Heq]]]. do 2 right. exists v₂. auto.
Qed.

Lemma cast_spec_find : forall A dom₁ dom₂ (Heq : Dom.eq dom₁ dom₂) (m : t A dom₁) x, find x (cast Heq m) = find x m.
Proof. intros. unfold cast, find. simpl. reflexivity. Qed.

Lemma elements_spec : forall A dom (m : t A dom) xv,
  InA (X.eq * eq)%signature xv (elements m) <-> find (fst xv) m = Some (snd xv).
Proof.
intros A dom m [x v]. unfold elements. simpl. split; intro Hin.
+ apply S.find_1, S.elements_2. assumption.
+ apply S.find_2. assumption.
Qed.

Lemma elements_Sorted : forall A dom (m : t A dom), Sorted (X.lt@@1)%signature (elements m).
Proof. intros A dom [m Hok]. unfold elements. simpl. apply S.elements_3. Qed.

Lemma pre_from_elements_spec : forall A l (m : S.t A), NoDupA (X.eq@@1)%signature l ->
  (forall xv, InA (X.eq@@1)%signature xv l -> S.In (fst xv) m -> False) ->
  forall x v, S.find x (fold_left (fun acc xv => S.add (fst xv) (snd xv) acc) l m) = Some v
              <-> InA (X.eq * eq)%signature (x, v) l ∨ ¬InA (X.eq@@1)%signature (x, v) l ∧ S.find x m = Some v.
Proof.
intros A l. induction l as [| [y v'] l]; intros m Hl Hdiff x v; simpl.
* do 2 rewrite InA_nil. tauto.
* inversion_clear Hl. rewrite IHl; trivial; clear IHl.
  + split; intros [Hin | Hin].
    - left. right. assumption.
    - { destruct (X.eq_dec x y) as [Heq | Heq].
        * do 2 left. split; trivial. hnf; simpl. symmetry in Heq. eapply S.add_1, S.find_1 in Heq.
          destruct Hin as [_ Hin]. rewrite Heq in Hin. inversion Hin. reflexivity.
        * destruct Hin as [Hin Hm]. right. split.
          + intro Habs. inversion_clear Habs.
            - apply Heq. assumption.
            - contradiction.
          + apply S.find_2, S.add_3, S.find_1 in Hm; trivial. symmetry. assumption. }
    - { inversion_clear Hin.
        + destruct H1 as [H1 H2]; hnf in H1, H2; simpl in H1, H2. subst v'. right. split.
          - intro Habs. apply H. rewrite <- H1. revert Habs. apply InA_compat; trivial; refine _.
          - apply S.find_1, S.add_1. symmetry. assumption.
        + left. assumption. }
    - { destruct Hin as [Hin Hm]. right. split.
        + intro Habs. apply Hin. right. assumption.
        + apply S.find_1, S.add_2, S.find_2; trivial. intro Habs. apply Hin. left. symmetry. assumption. }
  + intros [z w] Hin [v'' Hadd]. simpl in *. destruct (X.eq_dec y z) as [Heq | Heq].
    - assert (Hz : (X.eq @@1)%signature (y, v') (z, w)). { hnf. simpl. assumption. }
      rewrite Hz in H. contradiction.
    - apply S.add_3 in Hadd; trivial. apply (Hdiff (z, w)).
        right. assumption.
        exists v''. assumption.
Qed.

Lemma from_elements_spec : forall A (l : list (key * A)), NoDupA (X.eq@@1)%signature l ->
  forall x v, find x (from_elements l) = Some v <-> InA (X.eq * eq)%signature (x, v) l.
Proof.
intros A l Hnodup x v. unfold elements, from_elements, find. simpl.
rewrite pre_from_elements_spec; trivial.
+ intuition. eelim S.empty_1. apply S.find_2; eassumption.
+ intros [?] _ [? Hin]; simpl in *. apply (S.empty_1 Hin).
Qed.

Lemma fold_spec : forall A B (f : key -> A -> B -> B) dom (m : t A dom) (i : B),
  fold f m i = List.fold_left (fun acc xv => f (fst xv) (snd xv) acc) (elements m) i.
Proof. intros. unfold fold, elements. rewrite S.fold_1. reflexivity. Qed.

End DepMapImpl.