From mathcomp Require Import all_ssreflect ssralg.
From mathcomp Require Import ring.

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

Import GRing.Theory.

Local Open Scope ring_scope.

(* A failure to test the error message *)

Goal forall (R : comRingType) (a : R), a + a = a.
Proof.
move=> R a.
Fail ring. (* prints Not a valid ring equation. *)
ring || idtac. (* elpi-tactic failure can be caught by Ltac. *)
Abort.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e174m3_3limbs.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 Export Dirac.
Require Export Equival.

(* s = 10*)

(*Step-by-step*)

(*Vector*)
Definition φ20 := ∣0,0,0,0⟩.
Definition φ21 := (H ⊗ H ⊗ I_2 ⊗ σX) × φ20.
Definition φ22 := (I_2 ⊗ CX ⊗ I_2) × φ21.
Definition φ23 := (H ⊗ H ⊗ I_2 ⊗ I_2) × φ22.

Lemma step21 : φ21 ≡ ∣+⟩ ⊗ ∣+⟩ ⊗ ∣0⟩ ⊗ ∣1⟩.
Proof.
unfold φ21,φ20.
operate_reduce.
Qed.

Lemma step22 : φ22 ≡ /√2 .* (∣+⟩ ⊗ ∣0⟩ ⊗ ∣0⟩ ⊗ ∣1⟩) .+ /√2 .* (∣+⟩ ⊗ ∣1⟩ ⊗ ∣1⟩ ⊗ ∣1⟩).
Proof.
unfold φ22.
rewrite step21.
operate_reduce.
Qed.

Lemma step23 : φ23 ≡ /2 .* ∣0,0,0,1⟩ .+ /2 .* ∣0,1,0,1⟩ .+ /2 .* ∣0,0,1,1⟩ .+ - /2 .* ∣0,1,1,1⟩.
Proof.
unfold φ23.
rewrite step22.
operate_reduce.
Qed.

(*Density*)
Definition ρ20 := φ20 × φ20†.
Definition ρ21 := super (H ⊗ H ⊗ I_2 ⊗ σX) ρ20.
Definition ρ22 := super (I_2 ⊗ CX ⊗ I_2) ρ21.
Definition ρ23 := super (H ⊗ H ⊗ I_2 ⊗ I_2) ρ22.

Lemma Dstep21 : ρ21 ≡ φ21 × φ21†.
Proof.
unfold ρ21,ρ20,super.
super_reduce.
Qed.

Lemma Dstep22 : ρ22 ≡ φ22 × φ22†.
Proof.
unfold ρ22,super.
rewrite Dstep21.
super_reduce.
Qed.

Lemma Dstep23 : ρ23 ≡ φ23 × φ23†.
Proof.
unfold ρ23,super.
rewrite Dstep22.
super_reduce.
Qed.

(*
(*One-time*)
Lemma simon2 : (H ⊗ H ⊗ I_2 ⊗ I_2) × (I_2 ⊗ CX ⊗ I_2) × (H ⊗ H ⊗ I_2 ⊗ σX) × ∣0,0,0,0⟩ ≡ /2 .* ∣0,0,0,1⟩ .+ /2 .* ∣0,1,0,1⟩ .+ /2 .* ∣0,0,1,1⟩ .+ - /2 .* ∣0,1,1,1⟩.
Proof. operate_reduce. Qed.

Lemma Dsimon2 : super ((H ⊗ H ⊗ I_2 ⊗ I_2) × (I_2 ⊗ CX ⊗ I_2) × (H ⊗ H ⊗ I_2 ⊗ σX)) (density ∣0,0,0,0⟩) ≡ density (/2 .* ∣0,0,0,1⟩ .+ /2 .* ∣0,1,0,1⟩ .+ /2 .* ∣0,0,1,1⟩ .+ - /2 .* ∣0,1,1,1⟩).
Proof. super_reduce. Qed.

Lemma simon2' : (H ⊗ H ⊗ I_2 ⊗ I_2) × (I_2 ⊗ CX ⊗ I_2) × (H ⊗ H ⊗ I_2 ⊗ σX) × ∣0,0,0,0⟩ ≈ /2 .* ∣0,0,0,1⟩ .+ /2 .* ∣0,1,0,1⟩ .+ /2 .* ∣0,0,1,1⟩ .+ - /2 .* ∣0,1,1,1⟩.
Proof.
by_den.
rewrite simon2.
reflexivity.
Qed. *)

(* s = 11*)

(*Step-by-step*)

(*Vector*)
Definition CIX := B0 ⊗ I_2 ⊗ I_2 .+ B3 ⊗ I_2 ⊗ σX.
Global Hint Unfold  CIX : Gn_db.

Definition φ30 := ∣0,0,0,0⟩.
Definition φ31 := (H ⊗ H ⊗ I_2 ⊗ I_2) × φ30.
Definition φ32 := (CIX ⊗ σX) × φ31.
Definition φ33 := (I_2 ⊗ CX ⊗ I_2) × φ32.
Definition φ34 := (H ⊗ H ⊗ I_2 ⊗ I_2) × φ33.

Lemma step31 : φ31 ≡ ∣+⟩ ⊗ ∣+⟩ ⊗ ∣0⟩ ⊗ ∣0⟩.
Proof.
unfold φ31,φ30.
operate_reduce.
Qed.

Lemma step32 : φ32 ≡ /√2 .* (∣0⟩ ⊗ ∣+⟩ ⊗ ∣0⟩ ⊗ ∣1⟩) .+ /√2 .* (∣1⟩ ⊗ ∣+⟩ ⊗ ∣1⟩ ⊗ ∣1⟩).
Proof.
unfold φ32.
rewrite step31.
operate_reduce.
Qed.

Lemma step33 : φ33 ≡ /2 .* ∣0,0,0,1⟩ .+ /2 .* ∣0,1,1,1⟩ .+ /2 .* ∣1,0,1,1⟩ .+ /2 .* ∣1,1,0,1⟩.
Proof.
unfold φ33.
rewrite step32.
operate_reduce.
Qed.

Lemma step34 : φ34 ≡ /2 .* ∣0,0,0,1⟩ .+ /2 .* ∣1,1,0,1⟩ .+ /2 .* ∣0,0,1,1⟩ .+ - /2 .* ∣1,1,1,1⟩.
Proof.
unfold φ34.
rewrite step33.
operate_reduce.
Qed.

(*Density*)
Definition ρ30 := φ30 × φ30†.
Definition ρ31 := super (H ⊗ H ⊗ I_2 ⊗ I_2) ρ30.
Definition ρ32 := super (CIX ⊗ σX) ρ31.
Definition ρ33 := super (I_2 ⊗ CX ⊗ I_2) ρ32.
Definition ρ34 := super (H ⊗ H ⊗ I_2 ⊗ I_2) ρ33.

Lemma Dstep31 : ρ31 ≡ φ31 × φ31†.
Proof.
unfold ρ31,ρ30,super.
super_reduce.
Qed.

Lemma Dstep32 : ρ32 ≡ φ32 × φ32†.
Proof.
unfold ρ32,super,CIX.
rewrite Dstep31.
super_reduce.
Qed.

Lemma Dstep33 : ρ33 ≡ φ33 × φ33†.
Proof.
unfold ρ33,super.
rewrite Dstep32.
super_reduce.
Qed.

Lemma Dstep34 : ρ34 ≡ φ34 × φ34†.
Proof.
unfold ρ34,super.
rewrite Dstep33.
super_reduce.
Qed.

(*One-time*)
Lemma simon3 : (H ⊗ H ⊗ I_2 ⊗ I_2) × (I_2 ⊗ CX ⊗ I_2) × (CIX ⊗ σX) × (H ⊗ H ⊗ I_2 ⊗ I_2) × ∣0,0,0,0⟩ ≡ /2 .* ∣0,0,0,1⟩ .+ /2 .* ∣1,1,0,1⟩ .+ /2 .* ∣0,0,1,1⟩ .+ - /2 .* ∣1,1,1,1⟩.
Proof. operate_reduce. Qed.
Lemma Dsimon3 : super ((H ⊗ H ⊗ I_2 ⊗ I_2) × (I_2 ⊗ CX ⊗ I_2) × (CIX ⊗ σX) × (H ⊗ H ⊗ I_2 ⊗ I_2)) (density ∣0,0,0,0⟩) ≡ density (/2 .* ∣0,0,0,1⟩ .+ /2 .* ∣1,1,0,1⟩ .+ /2 .* ∣0,0,1,1⟩ .+ - /2 .* ∣1,1,1,1⟩).
Proof.
Time super_reduce.
Qed.

Lemma simon3' : (H ⊗ H ⊗ I_2 ⊗ I_2) × (I_2 ⊗ CX ⊗ I_2) × (CIX ⊗ σX) × (H ⊗ H ⊗ I_2 ⊗ I_2) × ∣0,0,0,0⟩ ≈ /2 .* ∣0,0,0,1⟩ .+ /2 .* ∣1,1,0,1⟩ .+ /2 .* ∣0,0,1,1⟩ .+ - /2 .* ∣1,1,1,1⟩.
Proof.
by_den.
rewrite simon3.
reflexivity.
Qed.

(* Finished transaction in 48.84 secs (48.578u,0.062s) (successful)*)


From mathcomp Require Import all_ssreflect all_algebra.
From categories Require Import classical category functor natural.
From mathcomp.analysis Require Import topology.

Open Scope category_scope.
Open Scope classical_set_scope.

Declare Scope sheaf_scope.
Delimit Scope sheaf_scope with sheaf.

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

Set Universe Polymorphism.

Module OpenSet.
  Definition mixin_of (T : topologicalType) (U : set T) := open U.
  Notation class_of := mixin_of.

  Section ClassDef.
    Structure type (T : topologicalType) := Pack { U : set T ; _ : class_of U }.
    Local Coercion U : type >-> set.

    Variables (T : topologicalType) (U : set T) (cU : type T).
    Definition class := let: Pack _ c as cU' := cU return class_of cU' in c.
  End ClassDef.
  Arguments Pack {T} {U} _.

  Module Exports.
    Notation openType := type.
    Coercion U : type >-> set.
    Notation IsOpen := mixin_of.
    Notation Open fU := (Pack fU).
  End Exports.
End OpenSet.
Import OpenSet.Exports.

Section opens.
  Variable (T : topologicalType).
  Variable (U V : openType T).

  Definition openT0 : openType T := Open open0.
  Definition openTT : openType T := Open openT.
End opens.

Section opens_category.
  Variable T : topologicalType.

  Definition opens_mixin := @CatMixin
                              (@openType T) subset
                              (fun U V W subUV subVW => subset_trans subUV subVW)
                              (fun U V W Y subUV subVW subWY => @Prop_irrelevance _ _ _)
                              (fun X _ => ssrfun.id)
                              (fun _ _ _ => @Prop_irrelevance _ _ _)
                              (fun _ _ _ => @Prop_irrelevance _ _ _).

  Definition opens_Category := Eval hnf in Category (@openType T) opens_mixin.
  Canonical opens_Category.
End opens_category.
Notation opens T := (opens_Category T).

(* A presheaf is just a covariant functor from opens(X) to a category C *)
Notation presheaf X C := (functor ((opens X)^op) C).

(* The category of presheaves, so that we get morphisms of functors for free *)
Notation PSh X C := ([((opens X)^op) ; C]).

Section presheaf.
  Variables (X : topologicalType) (V U: opens X) (C : category).
  Variable (F : PSh X C).
  Hypothesis UV_incl : U `<=` V.

  Definition res := F @@ UV_incl.
End presheaf.
Arguments res {X} V U {C} {F}.

Section sheaf_axiom.
  Variables (X : topologicalType) (U : openType X) (C : category).
  Variables (I : choiceType) (D : set I) (b : I -> set X).
  Hypothesis b_cover : \bigcup_(i in D) b i = U.

  Variable F : presheaf X C.
End sheaf_axiom.


(* Type is Object. *)
Variable Obj: Type.
(* Lambda calculus are arrows from object to object. *)
Definition Obj_id : Obj -> Obj := fun (obj: Obj) => obj.
(* Homset: a set of lambda calculus, still represented as type (all inhabitants of the type) *)
Definition Hom_Obj_Obj := Obj -> Obj.

(* Functor maps Type to Type (and exists a map p maps coresponding arrows to arrows), I skill the commute definition *)
Definition commute := True.
Definition Func (F: Type -> Type) := {p: forall C C', (C -> C') -> F C -> F C'| commute}.
Definition ContraFunc (F: Type -> Type) := { p: forall C C', (C -> C') -> F C' -> F C | commute }.

(* Set valued functor, is still a kind of functor... I kind of hacked here *)
(* Arbitrary set valued functor, make it contravaraint. *)
Inductive set_C_op: (Type -> Type) -> Type :=
| SetCOP: forall (F: Type -> Type), ContraFunc (fun (T: Type) => T -> F T) -> set_C_op (fun (T: Type) => T -> F T).
(* Arbitrary set valued functor, covaraint. *)
Inductive set_C: (Type -> Type) -> Type :=
| SetC: forall (F: Type -> Type), Func (fun (T: Type) => F T -> T) -> set_C (fun (T: Type) => F T -> T).
(* E.g. Yoneda embedding, maps a type to a functor, maps arrows to arrows! *)
Definition y (C: Type) := fun T: Type => T -> C.
Definition y_p (C: Type) : forall A B, (A -> B) -> y C B -> y C A.
Proof. unfold y. auto. Qed.
Definition co_y (C: Type) := fun T: Type => C -> T.
Definition co_y_p (C: Type) : forall A B, (A -> B) -> co_y C A -> co_y C B.
Proof. unfold co_y. auto. Qed.

Theorem YonedaEmbMapsToSetCOP (C: Type): set_C_op (y C).
Proof.
  unfold y.
  apply SetCOP.
  intros. unfold ContraFunc.
  exists (y_p C). unfold commute. auto.
Qed.

(* Natrual Transformation, maps between two functors (Type -> Type), is a family of arrows, still a type. *)
Definition Natrual (F: Type -> Type) (G: Type -> Type) := forall T, F T -> G T.

(* Yoneda lemma: we have two maps, yl_left and yl_right *)
Definition yl_left (C: Type) (F: Type -> Type): set_C_op F -> (Natrual (y C) F) -> F C.
Proof.
  unfold Natrual.
  intros.
  destruct X.
  remember (X0 C (fun c:C => c)).
  apply f.
Defined.

Definition yl_right (C: Type) (F: Type -> Type): set_C_op F -> F C -> (Natrual (y C) F).
Proof.
  unfold y.
  unfold Natrual.
  intro.
  destruct X.
  intros fa C'.
  intro h.
  destruct c.
  remember (x C' C h fa).
  apply f.
Defined.

(* co-Yoneda lemma: we have two maps, yl_left and yl_right *)
Definition co_yl_left (C: Type) (F: Type -> Type): set_C F -> (Natrual (co_y C) F) -> F C.
Proof.
  unfold Natrual.
  intros.
  destruct X.
  remember (X0 C (fun c:C => c)).
  apply c.
Defined.

Definition co_yl_right (C: Type) (F: Type -> Type): set_C F -> F C -> (Natrual (co_y C) F).
Proof.
  unfold co_y.
  unfold Natrual.
  intro.
  destruct X.
  intros fa C'.
  intro h.
  destruct f.
  remember (x C C' h fa).
  apply c0.
Defined.

(* CPS *)

Definition ClosureConvert (A B: Type) (f: A -> B): forall T, (B -> T) -> (A -> T).
Proof.
  remember (co_yl_right B (co_y A)) as H.
  unfold co_y in H.
  unfold Natrual in H.
  auto.
Qed.


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

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

Print Assumptions square.


Require Import Hahn.

Set Implicit Arguments.

Lemma eqv_empty_is_empty (A: Type) : ⦗@set_empty A⦘ ≡ ∅₂.
Proof. basic_solver. Qed.

Lemma ct_begin_absorb A (r r' : relation A) :
  r ⨾ r' ⊆ r'⁺ -> r ⨾ r'⁺ ⊆ r'⁺.
Proof.
  ins; rewrite ct_begin at 1; sin_rewrite H; apply ct_rt.
Qed.

Lemma ct_end_absorb A (r r' : relation A) :
  r ⨾ r' ⊆ r⁺ -> r⁺ ⨾ r' ⊆ r⁺.
Proof.
  by ins; rewrite ct_end at 1; rewrite seqA, H, rt_ct.
Qed.

Lemma inclusion_seq_ct1 A (r1 r2 r: relation A) :
  r1 ⊆ r⁺ -> r2 ⊆ r＊ -> r1 ⨾ r2 ⊆ r⁺.
Proof.
  intros -> ->; apply ct_rt.
Qed.

Lemma inclusion_seq_ct2 A (r1 r2 r: relation A) :
  r1 ⊆ r＊ -> r2 ⊆ r⁺ -> r1 ⨾ r2 ⊆ r⁺.
Proof.
  intros -> ->; apply rt_ct.
Qed.

Hint Resolve inclusion_seq_ct1 inclusion_seq_ct2 : rel_full.
Hint Resolve inclusion_t_r_t inclusion_r_t_t inclusion_seq_l inclusion_seq_r inclusion_t_t2 : rel_full.
Hint Resolve inclusion_rt_rt2 inclusion_seq_rt : rel_full.

Lemma path_union A (r1 r2: relation A) :
  (r1 ∪ r2)^+ ≡ r1^+ ∪ (r1^* ;; r2 ;; r1^*)^+.
Proof.
  split; cycle 1.
    by auto 10 with rel rel_full.
  apply inclusion_t_ind_right; auto 8 with rel_full rel.
  relsf; unionL; auto 6 with rel rel_full.
  rewrite ct_end_absorb; auto with rel.
  rewrite !seqA; rels; auto with rel.
Qed.

(******************************************************************************)
(** ** Notation *)
(******************************************************************************)
Notation "a ✕ b" := (fun x y => a x /\ b y) (at level 1, format "a ✕ b").
Notation "rel |imm" := (immediate rel) (at level 1).

(******************************************************************************)
(** ** Adjacency (new file in hahn?)  *)
(******************************************************************************)

Definition adjacent A (rel: relation A) a b :=
  << LA_ac : forall c, rel b c -> rel a c >> /\
  << LA_ca : forall c, rel c b -> rel^? c a >> /\
  << LA_cb : forall c, rel c a -> rel c b >> /\
  << LA_bc : forall c, rel a c -> rel^? b c >>.

Definition adjacentW A (rel: relation A) a b :=
  << LA_ac : forall c, rel b c -> rel a c >> /\
  << LA_cb : forall c, rel c a -> rel c b >>.

Lemma adjacent_weaken A (rel: relation A) a b :
  adjacent rel a b -> adjacentW rel a b.
Proof. unfold adjacent, adjacentW; intuition. Qed.

Lemma immediate_adjacent A (r: relation A) (dom: A -> Prop)
  (STOT1: ⦗dom⦘ ;; r ;; r^{-1} ⊆ r^? ∪ r^{-1})
  (STOT2: r^{-1} ;; ⦗dom⦘ ;; r ⊆ r^? ∪ r^{-1})
  (T: transitive r) (IRR: irreflexive r):
  forall a b, dom a -> immediate r a b <-> adjacent r a b /\ r a b.
Proof.
unfold adjacent; unfolder in *; ins.
split; splits; desf; ins.
1, 3: by eauto with rel.
assert (AA: dom a /\ (exists z : A, r a z /\ r c z) ) by eauto.
by specialize (STOT1 a c AA) ; desf; [auto|exfalso; eauto |econs].
assert (AA: (exists z : A, r z b /\ dom z /\ r z c) ) by eauto.
by specialize (STOT2 b c AA) ; desf; [auto|econs | exfalso; eauto].
 apply LA_bc in R1; apply LA_ca in R2; desf; eapply IRR, T; eauto.
Qed.

Lemma adjacent_uniqe1 A (r: relation A) (ACYC: acyclic r):
  forall a b c : A,  r a b ->  r a c -> adjacent r a b -> adjacent r a c -> b = c.
Proof.
ins; unfold adjacent in *; desc.
assert (r^? b c) by eauto.
assert (r^? c b) by eauto.
unfolder in *; desf.
by exfalso; eapply ACYC; eapply t_trans; econs; eauto.
Qed.

Lemma adjacent_uniqe2 A (r: relation A) (ACYC: acyclic r):
  forall a b c : A,  r b a ->  r c a -> adjacent r b a -> adjacent r c a -> b = c.
Proof.
ins; unfold adjacent in *; desc.
assert (r^? b c) by eauto.
assert (r^? c b) by eauto.
unfolder in *; desf.
by exfalso; eapply ACYC; eapply t_trans; econs; eauto.
Qed.

(******************************************************************************)
(** ** Tactics *)
(******************************************************************************)
Tactic Notation "arewrite" uconstr(EQ) "at" integer_list(indices) :=
  let H := fresh in
  assert (H : EQ); [eauto 4 with rel rel_full; try done|
                    rewrite H at indices; clear H; rewrite ?seqA].

Tactic Notation "arewrite" uconstr(EQ) "by" tactic(t) :=
  let H := fresh in
    assert (H: EQ) by (by t; eauto with rel rel_full);
    first [seq_rewrite H|sin_rewrite H]; clear H; rewrite ?seqA; try done.

Tactic Notation "arewrite" uconstr(EQ) "at" integer_list(indices) "by" tactic(t) :=
  let H := fresh in
    assert (H : EQ) by (by t; eauto with rel rel_full);
    rewrite H at indices; clear H; rewrite ?seqA; try done.

Tactic Notation "arewrite_false" constr(exp) "at" integer_list(indices) :=
  arewrite (exp ≡ fun _ _ => False) at indices; [split;[|vauto]|].

Tactic Notation "arewrite_id" constr(exp) "at" integer_list(indices) :=
  arewrite (exp ⊆ ⦗fun _ => True⦘) at indices.

Tactic Notation "clear_equivs" uconstr(EQ) "at" integer_list(indices) :=
  arewrite_id EQ at indices; simpl_rels.

Tactic Notation "clear_equivs" uconstr(EQ):=
  arewrite_id !EQ; simpl_rels.

Ltac not_proven H :=
  match goal with
  | [ _ : H |- _ ] => fail 1
  | _ => idtac
  end.

Tactic Notation "case_rt"  uconstr(x) "at" int(index) :=
  simpl_rels; rewrite rtE with (r := x) at index;
  (case_union_2 _ (x⁺) || case_union_2 ⦗fun _ => True⦘ _).
Tactic Notation "case_rt"  uconstr(x) := case_rt x at 1.

Tactic Notation "crewrite" hyp(H) :=
  try (rewrite !H || rewrite <- !H || setoid_rewrite H || setoid_rewrite <- H).

Tactic Notation "rotate" int_or_var(i) := do i (
 rewrite <- ?seqA; (apply irreflexive_seqC || apply acyclic_seqC); rewrite ?seqA
).
Tactic Notation "rotate" := rotate 1.

(******************************************************************************)
(** ** Hahn *)
(******************************************************************************)

Lemma leading_refl A (r r' e : relation A) : r ⊆ r' -> r ⊆ e^? ⨾ r'.
Proof.
  firstorder.
Qed.

(******************************************************************************)
(** ** Domains *)
(******************************************************************************)
Lemma dom_inter A (r r': relation A) (S: A -> Prop) :
  (⦗S⦘ ⨾ r ⨾ ⦗S⦘) ∩ r' ≡ ⦗S⦘ ⨾ (r ∩ r') ⨾ ⦗S⦘.
Proof.
  basic_solver.
Qed.

Lemma dom_inter2 A (r r': relation A) (S S' : A -> Prop) :
  ⦗S⦘ ⨾ ((⦗S'⦘ ⨾ r ⨾ ⦗S'⦘) ∩ r') ⨾ ⦗S⦘ ≡ ⦗S⦘ ⨾ ⦗S'⦘ ⨾ (r ∩ r') ⨾ ⦗S'⦘ ⨾ ⦗S⦘.
Proof.
  basic_solver 42.
Qed.

Lemma dom_imm X (r: relation X) (A : X -> Prop) :
    ⦗A⦘ ⨾ r|imm ⨾ ⦗A⦘  ⊆ (⦗A⦘⨾ r ⨾ ⦗A⦘)|imm.
Proof.
  basic_solver.
Qed.

(******************************************************************************)
(** ** Totality *)
(******************************************************************************)
Lemma total_enclose A (r: relation A) (S: A -> Prop):
  is_total S r -> is_total S (⦗S⦘ ⨾ r ⨾ ⦗S⦘).
Proof.
  unfold is_total; ins; specialize (H a IWa b IWb NEQ); desf;
  (left + right); basic_solver 42.
Qed.

(******************************************************************************)
(** ** Extras *)
(******************************************************************************)
Lemma not_none_implies_some A (o : option A) (N_NONE: o <> None) :
  exists x, o = Some x.
Proof. destruct o; eauto; contradiction. Qed.

Lemma doma_helper2 A (r : relation A) d : doma (⦗d⦘ ⨾ r) d.
Proof. rels. Qed.


Require Import Arith Cpdt.CpdtTactics List Omega.
Require Import VerifiedNatIntf CanonicalArrImpl CommutingArrayIntf Trees.

Set Implicit Arguments.
Import ListNotations.

(* An implementation of CommutingArrayInterface using binary trees. *)
Module TreeArrayImpl (Natl : VerifiedNatInterface)
    : CommutingArrayInterface Natl.

  Module T := TreeDefns Natl.
  Module Canon := CanonicalArrayImpl Natl.

  Inductive tree (A : Type) : Type :=
    | Verified : forall (t:T.tree A), T.well_formed t -> tree A.

  Definition M := tree.

  Definition make A (n:nat) (x:A) : tree A :=
    Verified (T.make n x) (T.make_wf n x).

  Definition len A (t:tree A) : Natl.N :=
    match t with
    | Verified t' _ => T.len t'
    end.

  Definition get A (t:tree A) (n:Natl.N) : option A :=
    match t with
    | Verified t' _ => T.get t' n
    end.

  Definition set A (t:tree A) (n:Natl.N) (x:A) : tree A :=
    match t with
    | Verified t' Hwf => Verified (T.set t' n x) (T.set_wf _ _ _ Hwf)
    end.

  Definition concat A (t1 t2:tree A) : tree A :=
    match t1, t2 with
    | Verified t1' H1, Verified t2' H2 =>
        Verified (T.concat t1' t2') (T.concat_wf _ _ H1 H2)
    end.

  Fixpoint convert' A (t:T.tree A ) : list A :=
    match t with
    | T.Empty => []
    | T.Leaf x => [x]
    | T.Node _ _ l r => Canon.concat (convert' l) (convert' r)
    end.

  Definition convert A (t:tree A) : list A :=
    match t with
    | Verified t' _ => convert' t'
    end.

  (** Commutativity lemmas **)

  Lemma Tmake_add : forall A (t:T.tree A) (n:nat) (x:A),
      convert' t = Canon.make n x ->
        convert' (T.add x t) = Canon.make (S n) x.
    intros A t.
    induction t as [| | nl nr l IHl r IHr];
        intros n x; simpl; intros Heq.
      (* Empty *)
      rewrite Canon.make_def; rewrite <- Heq; auto.
      (* Leaf a *)
      rewrite Canon.make_def.
      rewrite Canon.concat_def.
      rewrite Heq; auto.
      (* Node nl nr l IHl r IHr *)
      destruct (Canon.make_concat Heq) as (m & m' & Hl & Hr & Hsum).
      destruct (Natl.comp nl nr); simpl;
          [ (* Eq *) rewrite Hl; rewrite (IHr _ _ Hr) |
            (* Lt *) rewrite (IHl _ _ Hl); rewrite Hr |
            (* Gt *) rewrite Hl; rewrite (IHr _ _ Hr)];
          rewrite Canon.concat_make;
          [ (* Eq *) rewrite <- plus_n_Sm |
            (* Lt *) simpl |
            (* Gt *) rewrite <- plus_n_Sm];
          rewrite Hsum; auto.
  Defined.

  Lemma Tmake_commutes : forall A (n:nat) (x:A),
      convert' (T.make n x) = Canon.make n x.
    intros A n x.
    induction n;
        rewrite Canon.make_def; auto.
      (* S n *)
      pose (Tmake_add (T.make n x) IHn) as IHn'.
      rewrite Canon.make_def in IHn'.
      exact IHn'.
  Defined.

  Lemma make_commutes : forall A (n:nat) (x:A),
      convert (make n x) = Canon.make n x.
    intros; simpl; apply Tmake_commutes.
  Defined.

  Lemma Tlen_commutes : forall A (t:T.tree A),
      T.well_formed t -> T.len t = Canon.len (convert' t).
    intros A t.
    induction t as [|a| nl nr l IHl r IHr];
        simpl; intros Hwf.
      (* Empty *)
      symmetry; apply Canon.len_def.
      (* Leaf *)
      rewrite (Canon.len_def [a]); rewrite (Canon.len_def []); auto.
      (* Node *)
      destruct Hwf as (Hl & Hr & Hwfl & Hwfr).
      rewrite (Canon.len_concat _ _).
      simpl in IHl; rewrite <- (IHl Hwfl).
      simpl in IHr; rewrite <- (IHr Hwfr).
      rewrite <- Hl; rewrite <- Hr.
      rewrite (T.len_wf _ Hwfl); rewrite (T.len_wf _ Hwfr).
      reflexivity.
  Defined.

  Lemma len_commutes : forall A (t:tree A), len t = Canon.len (convert t).
    intros.
    destruct t as [t' Hwf].
    simpl; apply (Tlen_commutes _ Hwf).
  Defined.

  Lemma Tget_commutes : forall A (t:T.tree A) n,
      T.well_formed t -> T.get t n = Canon.get (convert' t) n.
    intros A t.
    induction t as [| | nl nr l IHl r IHr];
        intros n; simpl; intros Hwf.
      (* Empty *)
      rewrite (Canon.get_def _); reflexivity.
      (* Leaf a *)
      rewrite (Canon.get_def _).
      rewrite (Canon.get_def _); reflexivity.
      (* Node nl nr l r *)
      simpl in IHl; simpl in IHr.
      destruct Hwf as (Hnl & Hnr & Hl & Hr).
      rewrite (Canon.get_concat _ _).
      rewrite <- Hnl.
      rewrite <- (T.len_wf _ Hl).
      rewrite <- (Tlen_commutes _ Hl).
      rewrite (IHl n Hl).
      rewrite (IHr (Natl.sub n (T.len l)) Hr); auto.
  Defined.

  Lemma get_commutes : forall A (t:tree A) n,
      get t n = Canon.get (convert t) n.
    intros A t n.
    destruct t as [t' Hwf]; simpl.
    apply (Tget_commutes _ n Hwf).
  Defined.

  Lemma Tset_commutes : forall A (t:T.tree A) n x,
      T.well_formed t -> convert' (T.set t n x) = Canon.set (convert' t) n x.
    intros A t.
    induction t as [| | nl nr l IHl r IHr];
        intros n x Hwf; simpl.
      (* Empty *)
      rewrite Canon.set_def; reflexivity.
      (* Leaf a *)
      rewrite Canon.set_def.
      destruct (Natl.comp n Natl.zero); auto.
        (* Gt *)
        rewrite Canon.set_def; auto.
      (* Node nl nr l r *)
      destruct Hwf as (Hnl & Hnr & Hwfl & Hwfr).
      rewrite Canon.set_concat.
      rewrite <- Hnl.
      rewrite <- (T.len_wf _ Hwfl).
      rewrite <- (Tlen_commutes _ Hwfl).
      rewrite <- (IHl n x Hwfl).
      rewrite <- (IHr (Natl.sub n (T.len l)) x Hwfr).
      destruct (Natl.comp n (T.len l)); auto.
  Defined.

  Lemma set_commutes : forall A (t:tree A) n x,
      convert (set t n x) = Canon.set (convert t) n x.
    intros.
    destruct t as [t' Hwf]; simpl.
    apply (Tset_commutes _ n x Hwf).
  Defined.

  Lemma Tconcat_commutes : forall A (t t':T.tree A),
      convert' (T.concat t t') = Canon.concat (convert' t) (convert' t').
    intros A t t'.
    destruct t as [|a|nl nr l r];
        rewrite Canon.concat_def; auto; simpl.
      (* Leaf a *)
      destruct t' as [|a'| nl' nr' l' r'];
          auto; simpl.
        (* Leaf a' *)
        rewrite Canon.concat_def; auto.
        (* Node nl' nr' l' r' *)
        rewrite Canon.concat_def; rewrite Canon.concat_def; auto.
      (* Node nl nr l r *)
      destruct t' as [|a'| nl' nr' l' r'];
          simpl;
          [ rewrite app_nil_r (* Empty *)
          | rewrite Canon.concat_def (* Leaf *)
          | rewrite Canon.concat_def ]; (* Node *)
          auto.
  Defined.

  Lemma concat_commutes : forall A (t t':tree A),
      convert (concat t t') = Canon.concat (convert t) (convert t').
    intros A t1 t2.
    destruct t1 as [t1 H1]; destruct t2 as [t2 H2].
    simpl.
    apply Tconcat_commutes.
  Defined.
End TreeArrayImpl.