Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Notations.
Require Import Crypto.Util.ZUtil.Pow.
Require Import Crypto.Util.ZUtil.Modulo.
Require Import Crypto.Util.ZUtil.Tactics.SolveTestbit.
Local Open Scope Z_scope.

Module Z.
  Lemma truncating_shiftl_correct bw x y
  : Z.truncating_shiftl bw x y = (x << y) mod 2^bw.
  Proof. reflexivity. Qed.

  Lemma truncating_shiftl_correct_land_ones bw x y
  : Z.truncating_shiftl bw x y = (x << y) &'
      Z.ones ltac:(match eval hnf in (1 mod 0) with | 0 => exact (Z.max 0 bw) | _ => exact bw end).
  Proof.
    rewrite truncating_shiftl_correct.
    destruct (Z_lt_le_dec bw 0).
    - assert (Hbw : Z.max 0 bw = 0) by lia.
      assert (H0 : Z.pred (2 ^ 0) = 0) by reflexivity.
      now rewrite ?Hbw, Z.ones_equiv, ?H0, ?(Z.base_pow_neg 2 bw), ?Z.land_0_r, ?Z.land_m1_r, ?Zmod_0_r.
    - assert (Hbw : Z.max 0 bw = bw) by lia.
      rewrite ?Hbw. now rewrite Z.land_ones.
  Qed.

  Lemma truncating_shiftl_correct_land_pow2 bw x y
  : Z.truncating_shiftl bw x y = (x << y) &' (2^(ltac:(match eval hnf in (1 mod 0) with | 0 => exact (Z.max 0 bw) | _ => exact bw end)) - 1).
  Proof.
    rewrite truncating_shiftl_correct_land_ones, Z.ones_equiv, <- Z.sub_1_r.
    reflexivity.
  Qed.

  Lemma truncating_shiftl_mod a b (Hb : 0 < b):
    Z.truncating_shiftl b a (b - 1) = 2 ^ (b - 1) * (a mod 2).
  Proof.
    unfold Definitions.Z.truncating_shiftl. rewrite Z.shiftl_mul_pow2 by lia.
    replace (2^b) with (2 * 2^(b-1)) by (rewrite Pow.Z.pow_mul_base, Z.sub_simpl_r; lia).
    rewrite Zmult_mod_distr_r; ring. Qed.

  Lemma truncating_shiftl_testbit_spec_full m a k i :
    Z.testbit (Z.truncating_shiftl m a k) i
    = if (i <? 0) then false else if (orb (i <? m) ((1 mod 0 =? 1) && (m <? 0))) then Z.testbit a (i - k) else false.
  Proof. unfold Z.truncating_shiftl. Z.solve_testbit. Qed.

#[global]
  Hint Rewrite truncating_shiftl_testbit_spec_full : testbit_rewrite.

  Lemma truncating_shiftl_truncating_shiftl m a p q
        (Hp : 0 <= p)
        (Hq : 0 <= q) :
    Z.truncating_shiftl m (Z.truncating_shiftl m a p) q
    = Z.truncating_shiftl m a (p + q).
  Proof. Z.solve_using_testbit. Qed.
  Lemma truncating_shiftl0 m k :
    Z.truncating_shiftl m 0 k = 0.
  Proof. Z.solve_using_testbit. Qed.

  Lemma truncating_shiftl_lor m a b k :
    Z.truncating_shiftl m (a |' b) k
    = (Z.truncating_shiftl m a k) |' (Z.truncating_shiftl m b k).
  Proof. Z.solve_using_testbit. Qed.

  (* (* not compatible with x mod 0 = x *)
  Lemma truncating_shiftl_large m a k (Hk : k >= m) :
    Z.truncating_shiftl m a k = 0.
  Proof. Z.solve_using_testbit. Qed. *)

  Lemma truncating_shiftl_range m a k (Hm : 0 <= m) :
    0 <= Z.truncating_shiftl m a k < 2 ^ m.
  Proof. unfold Z.truncating_shiftl; apply Z.mod_pos_bound; apply Z.pow_pos_nonneg; lia. Qed.

#[global]
  Hint Resolve truncating_shiftl_range : zarith.

  Lemma truncating_shiftl_nonneg m a k (Hm : 0 <= m) :
    0 <= Z.truncating_shiftl m a k.
  Proof. unfold Z.truncating_shiftl; apply Z.mod_pos_bound; apply Z.pow_pos_nonneg; lia. Qed.
End Z.


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

Require Import ZAxioms ZProperties BinInt.

Local Open Scope Z_scope.

(** BinInt.Z is already implementing [ZAxiomsMiniSig] *)

Module Z
 <: ZAxiomsSig <: UsualOrderedTypeFull <: TotalOrder
 <: UsualDecidableTypeFull
 := BinInt.Z.

(** * An [order] tactic for integers *)

Ltac z_order := Z.order.

(** Note that [z_order] is domain-agnostic: it will not prove
    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *)

Section TestOrder.
 Let test : forall x y, x<=y -> y<=x -> x=y.
 Proof.
 z_order.
 Qed.
End TestOrder.

(** Z forms a ring *)

(*Lemma Zring : ring_theory 0 1 NZadd NZmul NZsub Z.opp NZeq.
Proof.
constructor.
exact Zadd_0_l.
exact Zadd_comm.
exact Zadd_assoc.
exact Zmul_1_l.
exact Zmul_comm.
exact Zmul_assoc.
exact Zmul_add_distr_r.
intros; now rewrite Zadd_opp_minus.
exact Zadd_opp_r.
Qed.

Add Ring ZR : Zring.*)


(** Some examples of lattices. *)
Require Import HoTT lattice_interface.

(** [Bool] is a lattice. *)
Section BoolLattice.
  Ltac solve_bool :=
    let x := fresh in
    repeat (intro x ; destruct x)
    ; compute
    ; auto
    ; try contradiction.

  Instance maximum_bool : maximum Bool := orb.
  Instance minimum_bool : minimum Bool := andb.
  Instance bottom_bool : bottom Bool := false.

  Global Instance lattice_bool : Lattice Bool.
  Proof.
    split ; solve_bool.
  Defined.

  Definition and_true : forall b, andb b true = b.
  Proof.
    solve_bool.
  Defined.

  Definition and_false : forall b, andb b false = false.
  Proof.
    solve_bool.
  Defined.

  Definition dist₁ : forall b₁ b₂ b₃,
      andb b₁ (orb b₂ b₃) = orb (andb b₁ b₂) (andb b₁ b₃).
  Proof.
    solve_bool.
  Defined.

  Definition dist₂ : forall b₁ b₂ b₃,
      orb b₁ (andb b₂ b₃) = andb (orb b₁ b₂) (orb b₁ b₃).
  Proof.
    solve_bool.
  Defined.

  Definition max_min : forall b₁ b₂,
      orb (andb b₁ b₂) b₁ = b₁.
  Proof.
    solve_bool.
  Defined.
End BoolLattice.

Create HintDb bool_lattice_hints.
Hint Resolve associativity : bool_lattice_hints.
Hint Resolve (associativity _ _ _)^ : bool_lattice_hints.
Hint Resolve commutativity : bool_lattice_hints.
Hint Resolve absorb : bool_lattice_hints.
Hint Resolve idempotency : bool_lattice_hints.
Hint Resolve neutralityL : bool_lattice_hints.
Hint Resolve neutralityR : bool_lattice_hints.

Hint Resolve
     associativity
     and_true and_false
     dist₁ dist₂ max_min
  : bool_lattice_hints.

(** If [B] is a lattice, then [A -> B] is a lattice. *)
Section fun_lattice.
  Context {A B : Type}.
  Context `{Lattice B}.
  Context `{Funext}.

  Global Instance max_fun : maximum (A -> B) :=
    fun (f g : A -> B) (a : A) => max_L0 (f a) (g a).

  Global Instance min_fun : minimum (A -> B) :=
    fun (f g : A -> B) (a : A) => min_L0 (f a) (g a).

  Global Instance bot_fun : bottom (A -> B)
    := fun _ => empty_L.

  Ltac solve_fun :=
    compute ; intros ; apply path_forall ; intro ;
    eauto with lattice_hints typeclass_instances.

  Global Instance lattice_fun : Lattice (A -> B).
  Proof.
    split ; solve_fun.
  Defined.
End fun_lattice.

(** If [A] is a lattice and [P] is closed under the lattice operations, then [Σ(x:A), P x] is a lattice. *)
Section sub_lattice.
  Context {A : Type} {P : A -> hProp}.
  Context `{Lattice A}.
  Context {Hmax : forall x y, P x -> P y -> P (max_L0 x y)}.
  Context {Hmin : forall x y, P x -> P y -> P (min_L0 x y)}.
  Context {Hbot : P empty_L}.

  Definition AP : Type := sig P.

  Instance botAP : bottom AP := (empty_L ; Hbot).

  Instance maxAP : maximum AP :=
    fun x y =>
      match x, y with
      | (a ; pa), (b ; pb) => (max_L0 a b ; Hmax a b pa pb)
      end.

  Instance minAP : minimum AP :=
    fun x y =>
      match x, y with
      | (a ; pa), (b ; pb) => (min_L0 a b ; Hmin a b pa pb)
      end.

  Instance hprop_sub : forall c, IsHProp (P c).
  Proof.
    apply _.
  Defined.

  Ltac solve_sub :=
    let x := fresh in
    repeat (intro x ; destruct x)
    ; simple refine (path_sigma _ _ _ _ _)
    ; simpl
    ; try (apply hprop_sub)
    ; eauto 3 with lattice_hints typeclass_instances.

  Global Instance lattice_sub : Lattice AP.
  Proof.
    split ; solve_sub.
  Defined.
End sub_lattice.

Instance lor : maximum hProp := fun X Y => BuildhProp (Trunc (-1) (sum X Y)).

Delimit Scope logic_scope with L.
Notation "A ∨ B" := (lor A B) (at level 20, right associativity) : logic_scope.
Arguments lor _%L _%L.
Open Scope logic_scope.

Instance land : minimum hProp := fun X Y => BuildhProp (prod X Y).
Instance lfalse : bottom hProp := False_hp.

Notation "A ∧ B" := (land A B) (at level 20, right associativity) : logic_scope.
Arguments land _%L _%L.
Open Scope logic_scope.

(** [hProp] is a lattice. *)
Section hPropLattice.
  Context `{Univalence}.

  Local Ltac lor_intros :=
    let x := fresh in intro x
                      ; repeat (strip_truncations ; destruct x as [x | x]).

  Instance lor_commutative : Commutative lor.
  Proof.
    intros X Y.
    apply path_iff_hprop ; lor_intros
    ; apply tr ; auto.
  Defined.

  Instance land_commutative : Commutative land.
  Proof.
    intros X Y.
    apply path_hprop.
    apply equiv_prod_symm.
  Defined.

  Instance lor_associative : Associative lor.
  Proof.
    intros X Y Z.
    apply path_iff_hprop ; lor_intros
    ; apply tr ; auto
    ; try (left ; apply tr)
    ; try (right ; apply tr) ; auto.
  Defined.

  Instance land_associative : Associative land.
  Proof.
    intros X Y Z.
    symmetry.
    apply path_hprop.
    apply equiv_prod_assoc.
  Defined.

  Instance lor_idempotent : Idempotent lor.
  Proof.
    intros X.
    apply path_iff_hprop ; lor_intros
    ; try(refine (tr(inl _))) ; auto.
  Defined.

  Instance land_idempotent : Idempotent land.
  Proof.
    intros X.
    apply path_iff_hprop ; cbn.
    - intros [a b] ; apply a.
    - intros a ; apply (pair a a).
  Defined.

  Instance lor_neutrall : NeutralL lor lfalse.
  Proof.
    intros X.
    apply path_iff_hprop ; lor_intros ; try contradiction
    ; try (refine (tr(inr _))) ; auto.
  Defined.

  Instance lor_neutralr : NeutralR lor lfalse.
  Proof.
    intros X.
    apply path_iff_hprop ; lor_intros ; try contradiction
    ; try (refine (tr(inl _))) ; auto.
  Defined.

  Instance absorption_orb_andb : Absorption lor land.
  Proof.
    intros Z1 Z2.
    apply path_iff_hprop ; cbn.
    - intros X ; strip_truncations.
      destruct X as [Xx | [Xy1 Xy2]] ; assumption.
    - intros X.
      apply (tr (inl X)).
  Defined.

  Instance absorption_andb_orb : Absorption land lor.
  Proof.
    intros Z1 Z2.
    apply path_iff_hprop ; cbn.
    - intros [X Y] ; strip_truncations.
      assumption.
    - intros X.
      split.
      * assumption.
      * apply (tr (inl X)).
  Defined.

  Global Instance lattice_hprop : Lattice hProp :=
    { commutative_min := _ ;
      commutative_max := _ ;
      associative_min := _ ;
      associative_max := _ ;
      idempotent_min := _ ;
      idempotent_max := _ ;
      neutralL_max := _ ;
      neutralR_max := _ ;
      absorption_min_max := _ ;
      absorption_max_min := _
  }.
End hPropLattice.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.Classes.RelationClasses Coq.Relations.Relation_Definitions Coq.Classes.Morphisms.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.Telescope.Core.
Require Import Fiat.Common.Telescope.Instances.

Module Export Telescope.
  Fixpoint flattenT_apply_unapply {t : Telescope} {X : Type} {struct t}
  : forall (f : flattenT_sig t -> X)
           (x : flattenT_sig t),
      f x = flattenT_apply (flattenT_unapply f) x
    := match t return forall (f : flattenT_sig t -> X)
                             (x : flattenT_sig t),
                        f x = flattenT_apply (flattenT_unapply f) x
       with
         | bottom => fun f x => match x with
                                  | tt => eq_refl
                                end
         | tele A B => fun f x => eq_trans (f_equal f match x return x = existT (fun a => flattenT_sig (B a)) (projT1 x) (projT2 x) with
                                                        | existT _ _ => eq_refl
                                                      end)
                                           (@flattenT_apply_unapply
                                              (B (projT1 x)) X
                                              (fun p => f (existT (fun x' => flattenT_sig (B x')) (projT1 x) p))
                                              (projT2 x))
       end.

  Fixpoint flattenT_unapply_apply {t : Telescope} {X : Type} {struct t}
  : forall (f : flattenT t X),
      flattenT_eq f (flattenT_unapply (flattenT_apply f))
    := match t return forall (f : flattenT t X),
                        flattenT_eq f (flattenT_unapply (flattenT_apply f))
       with
         | bottom => fun f => eq_refl
         | tele A B => fun f x => @flattenT_unapply_apply (B x) X (f x)
       end.

  Fixpoint flatten_forall_apply_unapply {t : Telescope} {struct t}
  : forall {P : flattenT_sig t -> Type}
           (f : forall x, P x)
           (x : flattenT_sig t),
      eq_rect _ (fun Px => Px) (f x) _ (flattenT_apply_unapply P x)
      = flatten_forall_apply (flatten_forall_unapply f) x.
  Proof.
    refine match t return forall {P : flattenT_sig t -> Type}
                                 (f : forall x, P x)
                                 (x : flattenT_sig t),
                            eq_rect _ (fun Px => Px) (f x) _ (flattenT_apply_unapply P x)
                            = flatten_forall_apply (flatten_forall_unapply f) x
           with
             | bottom => fun f x ttt => match ttt with
                                          | tt => eq_refl
                                        end
             | tele A B => fun f x x' => eq_trans
                                           _
                                           (@flatten_forall_apply_unapply (B (projT1 x')) _ _ _)
           end.
    destruct x'; simpl in *.
    refine (f_equal _ (concat_1p _)).
  Defined.

  Fixpoint flatten_forall_unapply_apply {t : Telescope} {struct t}
  : forall {P : flattenT t Type}
           (f : flatten_forall P),
      flatten_forall_eq
        (flatten_forall_eq_rect (flattenT_unapply_apply P) f)
        (flatten_forall_unapply (flatten_forall_apply f))
    := match t return forall {P : flattenT t Type}
                             (f : flatten_forall P),
                        flatten_forall_eq
                          (flatten_forall_eq_rect (flattenT_unapply_apply P) f)
                          (flatten_forall_unapply (flatten_forall_apply f))
       with
         | bottom => fun P f => eq_refl
         | tele A B => fun P f a => @flatten_forall_unapply_apply (B a) (P a) (f a)
       end.

  Fixpoint flatten_forall_eq_rect_trans {t : Telescope}
  : forall {P Q R : flattenT t Type}
           (p : flattenT_eq P Q)
           (q : flattenT_eq Q R)
           (f : flatten_forall P),
      flatten_forall_eq (flatten_forall_eq_rect (transitivity p q) f)
                        (flatten_forall_eq_rect q (flatten_forall_eq_rect p f)).
  Proof.
    refine match t return forall {P Q R : flattenT t Type}
                                 (p : flattenT_eq P Q)
                                 (q : flattenT_eq Q R)
                                 (f : flatten_forall P),
                            flatten_forall_eq (flatten_forall_eq_rect (transitivity p q) f)
                                              (flatten_forall_eq_rect q (flatten_forall_eq_rect p f))
           with
             | bottom => fun P Q H k => _
             | tele A B => fun P Q R p q f a => @flatten_forall_eq_rect_trans (B a) _ _ _ _ _ _
           end;
    simpl in *.
    { intros; subst; simpl; reflexivity. }
  Defined.

  Fixpoint flatten_forall_eq_rect_flattenT_unapply_Proper {t}
  : forall {P Q : flattenT_sig t -> Type}
           (H : forall x, P x = Q x)
           (f : forall x, P x),
      flatten_forall_eq
        (flatten_forall_eq_rect (@flattenT_unapply_Proper t _ P (fun x => Q x) H) (flatten_forall_unapply f))
        (flatten_forall_unapply (fun x => eq_rect _ (fun P => P) (f x) _ (H x)))
    := match t return forall {P Q : flattenT_sig t -> Type}
                             (H : forall x, P x = Q x)
                             (f : forall x, P x),
                        flatten_forall_eq
                          (flatten_forall_eq_rect (@flattenT_unapply_Proper t _ P (fun x => Q x) H) (flatten_forall_unapply f))
                          (flatten_forall_unapply (fun x => eq_rect _ (fun P => P) (f x) _ (H x)))
       with
         | bottom => fun P Q H k => eq_refl
         | tele A B => fun P Q H f a => @flatten_forall_eq_rect_flattenT_unapply_Proper (B a) _ _ _ _
       end.

  Fixpoint eq_rect_symmetry_flattenT_apply_unapply {t}
  : forall {f x k},
      eq_rect _ (fun T => T) (flatten_forall_apply (flatten_forall_unapply k) x) _ (eq_sym (@flattenT_apply_unapply t Type f x))
      = k x
    := match t return forall {f x k},
                        eq_rect _ (fun T => T) (flatten_forall_apply (flatten_forall_unapply k) x) _ (eq_sym (@flattenT_apply_unapply t Type f x))
                        = k x
       with
         | bottom => fun f x k => match x with
                                    | tt => eq_refl
                                  end
         | tele A'' B'' => fun f x k =>
                             match x with
                               | existT x1 x2
                                 => eq_trans
                                      (y := eq_rect
                                              _ (fun T => T)
                                              (flatten_forall_apply
                                                 (flatten_forall_unapply (fun x' => k (existT (fun x'' => flattenT_sig (B'' x'')) x1 x')))
                                                 x2)
                                              _
                                              (eq_sym (flattenT_apply_unapply (fun p => f (existT (fun x' => flattenT_sig (B'' x')) x1 p)) x2)))
                                      (f_equal (fun p' => eq_rect
                                                            _ (fun T => T)
                                                            (flatten_forall_apply
                                                               (flatten_forall_unapply (fun x' => k (existT (fun x'' => flattenT_sig (B'' x'')) x1 x')))
                                                               x2)
                                                            _
                                                            (eq_sym p'))
                                               (concat_1p _))
                                      (@eq_rect_symmetry_flattenT_apply_unapply (B'' x1) (fun x2' => f (existT (fun a => flattenT_sig (B'' a)) x1 x2')) x2 (fun x2' => k (existT (fun a => flattenT_sig (B'' a)) x1 x2')))
                             end
       end.

  Fixpoint flatten_forall_eq_rect_symmetry_flattenT_unapply_apply {t}
  : forall {f k},
      flatten_forall_eq
        (flatten_forall_eq_rect
           (symmetry (@flattenT_unapply_apply t Type f))
           (flatten_forall_unapply (flatten_forall_apply k)))
        k
    := match t return forall {f k},
                        flatten_forall_eq
                          (flatten_forall_eq_rect
                             (symmetry (@flattenT_unapply_apply t Type f))
                             (flatten_forall_unapply (flatten_forall_apply k)))
                          k
       with
         | bottom => fun f k => eq_refl
         | tele A'' B'' => fun f k a => @flatten_forall_eq_rect_symmetry_flattenT_unapply_apply (B'' a) (f a) (k a)
       end.

  Lemma flatten_forall_apply_of_unapply_eq {t X}
        f x
  : eq_rect
      _
      (fun T : Type => T)
      (flatten_forall_apply f x)
      _
      (eq_sym
         (flattenT_apply_unapply (fun _ => X) _))
    = @flatten_forall_apply_of_unapply t X f x.
  Proof.
    induction t as [|A B IHt]; simpl in *.
    { destruct x; simpl; reflexivity. }
    { specialize (IHt (projT1 x) (f (projT1 x)) (projT2 x)).
      etransitivity; [ clear IHt | exact IHt ].
      repeat apply f_equal.
      etransitivity; [ | apply concat_1p ].
      apply f_equal2; [ | reflexivity ].
      apply ap_const. }
  Defined.
End Telescope.


(*
 - Displayed prebicategory that is the product of displayed prebicategories indexed by I
From 'UniMath/Bicategories/DisplayedBicats/Examples/DispDepProd.v' *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.

Require Import Integers.Prebicategories.DispPrebicat.
Import DispPrebicat.Notations.

Local Open Scope cat.
Local Open Scope mor_disp.

Section DispDepProd.
  Context {C : prebicat}
          (I : UU)
          (D : I → disp_prebicat C).

  Definition disp_depprod_cat_ob_mor : disp_cat_ob_mor C.
  Proof.
    use tpair.
    - exact (λ a, ∏ (i : I), D i a).
    - exact (λ a b ha hb f, ∏ i : I, ha i -->[ f ] hb i).
  Defined.

  Definition disp_depprod_cat_id_comp : disp_cat_id_comp C disp_depprod_cat_ob_mor.
  Proof.
    split.
    - exact (λ a ha i, id_disp (ha i)).
    - exact (λ a b c f g ha hb hc ff gg i, ff i ;; gg i).
  Defined.

  Definition disp_depprod_1_id_comp_cells : disp_prebicat_1_id_comp_cells C.
  Proof.
    use tpair.
    - use tpair.
      + exact disp_depprod_cat_ob_mor.
      + exact disp_depprod_cat_id_comp.
    - exact (λ a b f g θ ha hb ff gg, ∏ i : I, ff i ==>[ θ ] gg i).
  Defined.

  Definition disp_depprod_ops : disp_prebicat_ops' disp_depprod_1_id_comp_cells.
  Proof.
    repeat split.
    - exact (λ a b f ha hb ff i, disp_id2 (ff i)).
    - exact (λ a b f ha hb ff i, disp_lunitor (ff i)).
    - exact (λ a b f ha hb ff i, disp_runitor (ff i)).
    - exact (λ a b f ha hb ff i, disp_linvunitor (ff i)).
    - exact (λ a b f ha hb ff i, disp_rinvunitor (ff i)).
    - exact (λ a b c d f g h ha hb hc hd ff gg hh i,
             disp_rassociator (ff i) (gg i) (hh i)).
    - exact (λ a b c d f g h ha hb hc hd ff gg hh i,
             disp_lassociator (ff i) (gg i) (hh i)).
    - exact (λ a b f g h θ γ ha hb ff gg hh θθ γγ i, θθ i •• γγ i).
    - exact (λ a b c f g1 g2 θ ha hb hc ff gg1 gg2 θθ i, ff i ◃◃ θθ i).
    - exact (λ a b c f1 f2 g θ ha hb hc ff1 ff2 gg θθ i, θθ i ▹▹ gg i).
  Defined.

  Definition disp_depprod_prebicat_laws_help
             {a b : C}
             {f g : a --> b}
             {θ γ : f ==> g}
             {ha : ∏ (i : I), D i a}
             {hb : ∏ (i : I), D i b}
             {ff : ∏ (i : I), ha i -->[ f ] hb i}
             {gg : ∏ (i : I), ha i -->[ g ] hb i}
             (θθ : ∏ (i : I), ff i ==>[ γ ] gg i)
             (p : θ = γ)
             (i : I)
    : transportb (λ α : f ==> g, ff i ==>[ α ] gg i) p (θθ i)
      =
      transportb (λ α : f ==> g, ∏ (i : I), ff i ==>[ α ] gg i) p θθ i.
  Proof.
    induction p.
    apply idpath.
  Qed.

  Definition disp_depprod_ops_laws
    : disp_prebicat_laws (disp_depprod_1_id_comp_cells ,, disp_depprod_ops).
  Proof.
    repeat split; intro; intros; use funextsec; intro
    ; refine (_ @ disp_depprod_prebicat_laws_help _ _ _).
    - apply disp_id2_left.
    - apply disp_id2_right.
    - apply disp_vassocr.
    - apply disp_lwhisker_id2.
    - apply disp_id2_rwhisker.
    - apply disp_lwhisker_vcomp.
    - apply disp_rwhisker_vcomp.
    - apply disp_vcomp_lunitor.
    - apply disp_vcomp_runitor.
    - apply disp_lwhisker_lwhisker.
    - apply disp_rwhisker_lwhisker.
    - apply disp_rwhisker_rwhisker.
    - apply disp_vcomp_whisker.
    - apply disp_lunitor_linvunitor.
    - apply disp_linvunitor_lunitor.
    - apply disp_runitor_rinvunitor.
    - apply disp_rinvunitor_runitor.
    - apply disp_lassociator_rassociator.
    - apply disp_rassociator_lassociator.
    - apply disp_runitor_rwhisker.
    - apply disp_lassociator_lassociator.
  Qed.

  Definition disp_depprod_prebicat : disp_prebicat C
    := (_ ,, disp_depprod_ops_laws).

  Definition prebicat_depprod := total_prebicat disp_depprod_prebicat.
End DispDepProd.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.R_sqrt.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require int.ComputerDivision.
Require int.Power.
Require real.Real.
Require real.RealInfix.
Require real.FromInt.
Require real.Square.

(* Why3 assumption *)
Inductive ref (a:Type) :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Arguments mk_ref {a}.

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:ref a) : a :=
  match v with
  | mk_ref x => x
  end.

Parameter truncate: R -> Z.

Axiom Truncate_int : forall (i:Z), ((truncate (BuiltIn.IZR i)) = i).

Axiom Truncate_down_pos :
  forall (x:R), (0%R <= x)%R ->
  ((BuiltIn.IZR (truncate x)) <= x)%R /\
  (x < (BuiltIn.IZR ((truncate x) + 1%Z)%Z))%R.

Axiom Truncate_up_neg :
  forall (x:R), (x <= 0%R)%R ->
  ((BuiltIn.IZR ((truncate x) - 1%Z)%Z) < x)%R /\
  (x <= (BuiltIn.IZR (truncate x)))%R.

Axiom Real_of_truncate :
  forall (x:R),
  ((x - 1%R)%R <= (BuiltIn.IZR (truncate x)))%R /\
  ((BuiltIn.IZR (truncate x)) <= (x + 1%R)%R)%R.

Axiom Truncate_monotonic :
  forall (x:R) (y:R), (x <= y)%R -> ((truncate x) <= (truncate y))%Z.

Axiom Truncate_monotonic_int1 :
  forall (x:R) (i:Z), (x <= (BuiltIn.IZR i))%R -> ((truncate x) <= i)%Z.

Axiom Truncate_monotonic_int2 :
  forall (x:R) (i:Z), ((BuiltIn.IZR i) <= x)%R -> (i <= (truncate x))%Z.

Parameter floor: R -> Z.

Parameter ceil: R -> Z.

Axiom Floor_int : forall (i:Z), ((floor (BuiltIn.IZR i)) = i).

Axiom Ceil_int : forall (i:Z), ((ceil (BuiltIn.IZR i)) = i).

Axiom Floor_down :
  forall (x:R),
  ((BuiltIn.IZR (floor x)) <= x)%R /\
  (x < (BuiltIn.IZR ((floor x) + 1%Z)%Z))%R.

Axiom Ceil_up :
  forall (x:R),
  ((BuiltIn.IZR ((ceil x) - 1%Z)%Z) < x)%R /\ (x <= (BuiltIn.IZR (ceil x)))%R.

Axiom Floor_monotonic :
  forall (x:R) (y:R), (x <= y)%R -> ((floor x) <= (floor y))%Z.

Axiom Ceil_monotonic :
  forall (x:R) (y:R), (x <= y)%R -> ((ceil x) <= (ceil y))%Z.

Parameter n: Z.

Axiom H : (0%Z <= n)%Z.

Parameter sum: Z.

Parameter count: Z.

Axiom H1 : (0%Z <= count)%Z.

Axiom H2 : ((int.Power.power count 2%Z) <= n)%Z.

Axiom H3 : (sum = (int.Power.power (count + 1%Z)%Z 2%Z)).

Axiom H4 : ~ (sum <= n)%Z.

(* Why3 goal *)
Theorem VC_isqrt :
  (((BuiltIn.IZR count) * (BuiltIn.IZR count))%R <= (BuiltIn.IZR n))%R.
Proof.

Qed.


(* -*- coding: utf-8 -*- *)
(*      This file is distributed under the terms of the      *)
(*       GNU Lesser General Public License Version 2.1       *)
(* Author: Sosuke Moriguchi *)
(* Extended implementation from MSetAVL *)

(** * XSetAVL : Implementation of XSetInterface via AVL trees *)

(** This file is extension of [MSetAVL] to implement extensions in XSetInterface. *)

Require Import XSetInterface XSetGenTree ZArith Int.

Set Implicit Arguments.
Unset Strict Implicit.
Local Unset Elimination Schemes.
Local Unset Case Analysis Schemes.

(** * Ops : the pure functions *)

Module Ops (Import I:Int)(X:OrderedType) <: XSetInterface.Ops X.
Local Open Scope Int_scope.
Local Notation int := I.t.

(** ** Generic trees instantiated with integer height *)

Include XSetGenTree.Ops X I.

Definition t := tree.

(** ** Height of trees *)

Definition height (s : t) : int :=
  match s with
  | Leaf => 0
  | Node h _ _ _ => h
  end.

(** ** Singleton set *)

Definition singleton x := Node 1 Leaf x Leaf.

(** ** Helper functions *)

(** [create l x r] creates a node, assuming [l] and [r]
    to be balanced and [|height l - height r| <= 2]. *)

Definition create l x r :=
   Node (max (height l) (height r) + 1) l x r.

(** [bal l x r] acts as [create], but performs one step of
    rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *)

Definition assert_false := create.

Definition bal l x r :=
  let hl := height l in
  let hr := height r in
  if gt_le_dec hl (hr+2) then
    match l with
     | Leaf => assert_false l x r
     | Node _ ll lx lr =>
       if ge_lt_dec (height ll) (height lr) then
         create ll lx (create lr x r)
       else
         match lr with
          | Leaf => assert_false l x r
          | Node _ lrl lrx lrr =>
              create (create ll lx lrl) lrx (create lrr x r)
         end
    end
  else
    if gt_le_dec hr (hl+2) then
      match r with
       | Leaf => assert_false l x r
       | Node _ rl rx rr =>
         if ge_lt_dec (height rr) (height rl) then
            create (create l x rl) rx rr
         else
           match rl with
            | Leaf => assert_false l x r
            | Node _ rll rlx rlr =>
                create (create l x rll) rlx (create rlr rx rr)
           end
      end
    else
      create l x r.

(** ** Insertion *)

Fixpoint add x s := match s with
   | Leaf => Node 1 Leaf x Leaf
   | Node h l y r =>
      match X.compare x y with
         | Lt => bal (add x l) y r
         | Eq => Node h l y r
         | Gt => bal l y (add x r)
      end
  end.

(** ** Join

    Same as [bal] but does not assume anything regarding heights
    of [l] and [r].
*)

Fixpoint join l : elt -> t -> t :=
  match l with
    | Leaf => add
    | Node lh ll lx lr => fun x =>
       fix join_aux (r:t) : t := match r with
          | Leaf => add x l
          | Node rh rl rx rr =>
               if gt_le_dec lh (rh+2) then bal ll lx (join lr x r)
               else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr
               else create l x r
          end
  end.

(** ** Extraction of minimum element

  Morally, [remove_min] is to be applied to a non-empty tree
  [t = Node h l x r]. Since we can't deal here with [assert false]
  for [t=Leaf], we pre-unpack [t] (and forget about [h]).
*)

Fixpoint remove_min l x r : t*elt :=
  match l with
    | Leaf => (r,x)
    | Node lh ll lx lr =>
       let (l',m) := remove_min ll lx lr in (bal l' x r, m)
  end.

(** ** Merging two trees

  [merge t1 t2] builds the union of [t1] and [t2] assuming all elements
  of [t1] to be smaller than all elements of [t2], and
  [|height t1 - height t2| <= 2].
*)

Definition merge s1 s2 :=  match s1,s2 with
  | Leaf, _ => s2
  | _, Leaf => s1
  | _, Node _ l2 x2 r2 =>
        let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2'
end.

(** ** Deletion *)

Fixpoint remove x s := match s with
  | Leaf => Leaf
  | Node _ l y r =>
      match X.compare x y with
         | Lt => bal (remove x l) y r
         | Eq => merge l r
         | Gt => bal l y (remove x r)
      end
   end.

(** ** Concatenation

    Same as [merge] but does not assume anything about heights.
*)

Definition concat s1 s2 :=
   match s1, s2 with
      | Leaf, _ => s2
      | _, Leaf => s1
      | _, Node _ l2 x2 r2 =>
            let (s2',m) := remove_min l2 x2 r2 in
            join s1 m s2'
   end.

(** ** Splitting

    [split x s] returns a triple [(l, present, r)] where
    - [l] is the set of elements of [s] that are [< x]
    - [r] is the set of elements of [s] that are [> x]
    - [present] is [true] if and only if [s] contains  [x].
*)

Record triple := mktriple { t_left:t; t_in:bool; t_right:t }.
Notation "<< l , b , r >>" := (mktriple l b r) (at level 9).

Fixpoint split x s : triple := match s with
  | Leaf => << Leaf, false, Leaf >>
  | Node _ l y r =>
     match X.compare x y with
      | Lt => let (ll,b,rl) := split x l in << ll, b, join rl y r >>
      | Eq => << l, true, r >>
      | Gt => let (rl,b,rr) := split x r in << join l y rl, b, rr >>
     end
 end.

(** ** Intersection *)

Fixpoint inter s1 s2 := match s1, s2 with
    | Leaf, _ => Leaf
    | _, Leaf => Leaf
    | Node _ l1 x1 r1, _ =>
            let (l2',pres,r2') := split x1 s2 in
            if pres then join (inter l1 l2') x1 (inter r1 r2')
            else concat (inter l1 l2') (inter r1 r2')
    end.

(** ** Difference *)

Fixpoint diff s1 s2 := match s1, s2 with
 | Leaf, _ => Leaf
 | _, Leaf => s1
 | Node _ l1 x1 r1, _ =>
    let (l2',pres,r2') := split x1 s2 in
    if pres then concat (diff l1 l2') (diff r1 r2')
    else join (diff l1 l2') x1 (diff r1 r2')
end.

(** ** Union *)

Fixpoint union s1 s2 :=
 match s1, s2 with
  | Leaf, _ => s2
  | _, Leaf => s1
  | Node _ l1 x1 r1, _ =>
     let (l2',_,r2') := split x1 s2 in
     join (union l1 l2') x1 (union r1 r2')
 end.

(** ** Filter *)

Fixpoint filter (f:elt->bool) s := match s with
  | Leaf => Leaf
  | Node _ l x r =>
    let l' := filter f l in
    let r' := filter f r in
    if f x then join l' x r' else concat l' r'
 end.

(** ** Partition *)

Fixpoint partition (f:elt->bool)(s : t) : t*t :=
  match s with
   | Leaf => (Leaf, Leaf)
   | Node _ l x r =>
      let (l1,l2) := partition f l in
      let (r1,r2) := partition f r in
      if f x then (join l1 x r1, concat l2 r2)
      else (concat l1 r1, join l2 x r2)
  end.

End Ops.

(** * MakeRaw

   Functor of pure functions + a posteriori proofs of invariant
   preservation *)

Module MakeRaw (Import I:Int)(X:OrderedType) <: RawSets X.
Include Ops I X.

(** Generic definition of binary-search-trees and proofs of
    specifications for generic functions such as mem or fold. *)

Include XSetGenTree.Props X I.

(** Automation and dedicated tactics *)

Local Hint Immediate MX.eq_sym.
Local Hint Unfold In lt_tree gt_tree Ok.
Local Hint Constructors InT bst.
Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok.
Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
Local Hint Resolve elements_spec2.

(* Sometimes functional induction will expose too much of
   a tree structure. The following tactic allows to factor back
   a Node whose internal parts occurs nowhere else. *)

(* TODO: why Ltac instead of Tactic Notation don't work ? why clear ? *)

Tactic Notation "factornode" ident(s) :=
 try clear s;
 match goal with
   | |- context [Node ?l ?x ?r ?h] =>
       set (s:=Node l x r h) in *; clearbody s; clear l x r h
   | _ : context [Node ?l ?x ?r ?h] |- _ =>
       set (s:=Node l x r h) in *; clearbody s; clear l x r h
 end.

(** Inductions principles for some of the set operators *)

Functional Scheme bal_ind := Induction for bal Sort Prop.
Functional Scheme remove_min_ind := Induction for remove_min Sort Prop.
Functional Scheme merge_ind := Induction for merge Sort Prop.
Functional Scheme concat_ind := Induction for concat Sort Prop.
Functional Scheme inter_ind := Induction for inter Sort Prop.
Functional Scheme diff_ind := Induction for diff Sort Prop.
Functional Scheme union_ind := Induction for union Sort Prop.

(** Notations and helper lemma about pairs and triples *)

Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
Notation "t #l" := (t_left t) (at level 9, format "t '#l'") : pair_scope.
Notation "t #b" := (t_in t) (at level 9, format "t '#b'") : pair_scope.
Notation "t #r" := (t_right t) (at level 9, format "t '#r'") : pair_scope.

Local Open Scope pair_scope.

(** ** Singleton set *)

Lemma singleton_spec : forall x y, InT y (singleton x) <-> X.eq y x.
Proof.
 unfold singleton; intuition_in.
Qed.

Instance singleton_ok x : Ok (singleton x).
Proof.
 unfold singleton; auto.
Qed.

(** ** Helper functions *)

Lemma create_spec :
 forall l x r y,  InT y (create l x r) <-> X.eq y x \/ InT y l \/ InT y r.
Proof.
 unfold create; split; [ inversion_clear 1 | ]; intuition.
Qed.

Instance create_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
 Ok (create l x r).
Proof.
 unfold create; auto.
Qed.

Lemma bal_spec : forall l x r y,
 InT y (bal l x r) <-> X.eq y x \/ InT y l \/ InT y r.
Proof.
 intros l x r; functional induction bal l x r; intros; try clear e0;
 rewrite !create_spec; intuition_in.
Qed.

Instance bal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
 Ok (bal l x r).
Proof.
 functional induction bal l x r; intros;
 inv; repeat apply create_ok; auto; unfold create;
 (apply lt_tree_node || apply gt_tree_node); auto;
 (eapply lt_tree_trans || eapply gt_tree_trans); eauto.
Qed.

(** ** Insertion *)

Lemma add_spec' : forall s x y,
 InT y (add x s) <-> X.eq y x \/ InT y s.
Proof.
 induct s x; try rewrite ?bal_spec, ?IHl, ?IHr; intuition_in.
 setoid_replace y with x'; eauto.
Qed.

Lemma add_spec : forall s x y `{Ok s},
 InT y (add x s) <-> X.eq y x \/ InT y s.
Proof. intros; apply add_spec'. Qed.

Instance add_ok s x `(Ok s) : Ok (add x s).
Proof.
 induct s x; auto; apply bal_ok; auto;
  intros y; rewrite add_spec'; intuition; order.
Qed.

Local Open Scope Int_scope.

(** ** Join *)

(** Function/Functional Scheme can't deal with internal fix.
    Let's do its job by hand: *)

Ltac join_tac :=
 intro l; induction l as [| lh ll _ lx lr Hlr];
   [ | intros x r; induction r as [| rh rl Hrl rx rr _]; unfold join;
     [ | destruct (gt_le_dec lh (rh+2)) as [GT|LE];
       [ match goal with |- context b [ bal ?a ?b ?c] =>
           replace (bal a b c)
           with (bal ll lx (join lr x (Node rh rl rx rr))); [ | auto]
         end
       | destruct (gt_le_dec rh (lh+2)) as [GT'|LE'];
         [ match goal with |- context b [ bal ?a ?b ?c] =>
             replace (bal a b c)
             with (bal (join (Node lh ll lx lr) x rl) rx rr); [ | auto]
           end
         | ] ] ] ]; intros.

Lemma join_spec : forall l x r y,
 InT y (join l x r) <-> X.eq y x \/ InT y l \/ InT y r.
Proof.
 join_tac.
 simpl.
 rewrite add_spec'; intuition_in.
 rewrite add_spec'; intuition_in.
 rewrite bal_spec, Hlr; clear Hlr Hrl; intuition_in.
 rewrite bal_spec, Hrl; clear Hlr Hrl; intuition_in.
 apply create_spec.
Qed.

Instance join_ok : forall l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r),
 Ok (join l x r).
Proof.
 join_tac; auto with *; inv; apply bal_ok; auto;
 clear Hrl Hlr; intro; intros; rewrite join_spec in *.
 intuition; [ setoid_replace y with x | ]; eauto.
 intuition; [ setoid_replace y with x | ]; eauto.
Qed.

(** ** Extraction of minimum element *)

Lemma remove_min_spec : forall l x r y h,
 InT y (Node h l x r) <->
  X.eq y (remove_min l x r)#2 \/ InT y (remove_min l x r)#1.
Proof.
 intros l x r; functional induction (remove_min l x r); simpl in *; intros.
 intuition_in.
 rewrite bal_spec, In_node_iff, IHp, e0; simpl; intuition.
Qed.

Instance remove_min_ok l x r : forall h `(Ok (Node h l x r)),
 Ok (remove_min l x r)#1.
Proof.
 functional induction (remove_min l x r); simpl; intros.
 inv; auto.
 assert (O : Ok (Node _x ll lx lr)) by (inv; auto).
 assert (L : lt_tree x (Node _x ll lx lr)) by (inv; auto).
 specialize IHp with (1:=O); rewrite e0 in IHp; auto; simpl in *.
 apply bal_ok; auto.
 inv; auto.
 intro y; specialize (L y).
 rewrite remove_min_spec, e0 in L; simpl in L; intuition.
 inv; auto.
Qed.

Lemma remove_min_gt_tree : forall l x r h `{Ok (Node h l x r)},
 gt_tree (remove_min l x r)#2 (remove_min l x r)#1.
Proof.
 intros l x r; functional induction (remove_min l x r); simpl; intros.
 inv; auto.
 assert (O : Ok (Node _x ll lx lr)) by (inv; auto).
 assert (L : lt_tree x (Node _x ll lx lr)) by (inv; auto).
 specialize IHp with (1:=O); rewrite e0 in IHp; simpl in IHp.
 intro y; rewrite bal_spec; intuition;
  specialize (L m); rewrite remove_min_spec, e0 in L; simpl in L;
   [setoid_replace y with x|inv]; eauto.
Qed.
Local Hint Resolve remove_min_gt_tree.

(** ** Merging two trees *)

Lemma merge_spec : forall s1 s2 y,
 InT y (merge s1 s2) <-> InT y s1 \/ InT y s2.
Proof.
 intros s1 s2; functional induction (merge s1 s2); intros;
  try factornode s1.
 intuition_in.
 intuition_in.
 rewrite bal_spec, remove_min_spec, e1; simpl; intuition.
Qed.

Instance merge_ok s1 s2 : forall `(Ok s1, Ok s2)
 `(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2),
 Ok (merge s1 s2).
Proof.
 functional induction (merge s1 s2); intros; auto;
  try factornode s1.
 apply bal_ok; auto.
 change s2' with ((s2',m)#1); rewrite <-e1; eauto with *.
 intros y Hy.
 apply H1; auto.
 rewrite remove_min_spec, e1; simpl; auto.
 change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto.
Qed.

(** ** Deletion *)

Lemma remove_spec : forall s x y `{Ok s},
 (InT y (remove x s) <-> InT y s /\ ~ X.eq y x).
Proof.
 induct s x.
 intuition_in.
 rewrite merge_spec; intuition; [order|order|intuition_in].
 elim H2; eauto.
 rewrite bal_spec, IHl; clear IHl IHr; intuition; [order|order|intuition_in].
 rewrite bal_spec, IHr; clear IHl IHr; intuition; [order|order|intuition_in].
Qed.

Instance remove_ok s x `(Ok s) : Ok (remove x s).
Proof.
 induct s x.
 auto.
 (* EQ *)
 apply merge_ok; eauto.
 (* LT *)
 apply bal_ok; auto.
 intro z; rewrite remove_spec; auto; destruct 1; eauto.
 (* GT *)
 apply bal_ok; auto.
 intro z; rewrite remove_spec; auto; destruct 1; eauto.
Qed.

(** ** Concatenation *)

Lemma concat_spec : forall s1 s2 y,
 InT y (concat s1 s2) <-> InT y s1 \/ InT y s2.
Proof.
 intros s1 s2; functional induction (concat s1 s2); intros;
  try factornode s1.
 intuition_in.
 intuition_in.
 rewrite join_spec, remove_min_spec, e1; simpl; intuition.
Qed.

Instance concat_ok s1 s2 : forall `(Ok s1, Ok s2)
 `(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2),
 Ok (concat s1 s2).
Proof.
 functional induction (concat s1 s2); intros; auto;
  try factornode s1.
 apply join_ok; auto.
 change (Ok (s2',m)#1); rewrite <-e1; eauto with *.
 intros y Hy.
 apply H1; auto.
 rewrite remove_min_spec, e1; simpl; auto.
 change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto.
Qed.

(** ** Splitting *)

Lemma split_spec1 : forall s x y `{Ok s},
 (InT y (split x s)#l <-> InT y s /\ X.lt y x).
Proof.
 induct s x.
 intuition_in.
 intuition_in; order.
 specialize (IHl x y).
 destruct (split x l); simpl in *. rewrite IHl; intuition_in; order.
 specialize (IHr x y).
 destruct (split x r); simpl in *. rewrite join_spec, IHr; intuition_in; order.
Qed.

Lemma split_spec2 : forall s x y `{Ok s},
 (InT y (split x s)#r <-> InT y s /\ X.lt x y).
Proof.
 induct s x.
 intuition_in.
 intuition_in; order.
 specialize (IHl x y).
 destruct (split x l); simpl in *. rewrite join_spec, IHl; intuition_in; order.
 specialize (IHr x y).
 destruct (split x r); simpl in *. rewrite IHr; intuition_in; order.
Qed.

Lemma split_spec3 : forall s x `{Ok s},
 ((split x s)#b = true <-> InT x s).
Proof.
 induct s x.
 intuition_in; try discriminate.
 intuition.
 specialize (IHl x).
 destruct (split x l); simpl in *. rewrite IHl; intuition_in; order.
 specialize (IHr x).
 destruct (split x r); simpl in *. rewrite IHr; intuition_in; order.
Qed.

Lemma split_ok : forall s x `{Ok s}, Ok (split x s)#l /\ Ok (split x s)#r.
Proof.
 induct s x; simpl; auto.
 specialize (IHl x).
 generalize (fun y => @split_spec2 l x y _).
 destruct (split x l); simpl in *; intuition. apply join_ok; auto.
 intros y; rewrite H; intuition.
 specialize (IHr x).
 generalize (fun y => @split_spec1 r x y _).
 destruct (split x r); simpl in *; intuition. apply join_ok; auto.
 intros y; rewrite H; intuition.
Qed.

Instance split_ok1 s x `(Ok s) : Ok (split x s)#l.
Proof. intros; destruct (@split_ok s x); auto. Qed.

Instance split_ok2 s x `(Ok s) : Ok (split x s)#r.
Proof. intros; destruct (@split_ok s x); auto. Qed.

(** ** Intersection *)

Ltac destruct_split := match goal with
 | H : split ?x ?s = << ?u, ?v, ?w >> |- _ =>
   assert ((split x s)#l = u) by (rewrite H; auto);
   assert ((split x s)#b = v) by (rewrite H; auto);
   assert ((split x s)#r = w) by (rewrite H; auto);
   clear H; subst u w
 end.

Lemma inter_spec_ok : forall s1 s2 `{Ok s1, Ok s2},
 Ok (inter s1 s2) /\ (forall y, InT y (inter s1 s2) <-> InT y s1 /\ InT y s2).
Proof.
 intros s1 s2; functional induction inter s1 s2; intros B1 B2;
 [intuition_in|intuition_in | | ]; factornode s2;
 destruct_split; inv;
 destruct IHt0 as (IHo1,IHi1), IHt1 as (IHo2,IHi2); auto with *;
 split; intros.
 - (* Ok join *)
   apply join_ok; auto with *; intro y; rewrite ?IHi1, ?IHi2; intuition.
 - (* InT join *)
   rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
   setoid_replace y with x1; auto. rewrite <- split_spec3; auto.
 - (* Ok concat *)
   apply concat_ok; auto with *; intros y1 y2; rewrite IHi1, IHi2;
   intuition; order.
 - (* InT concat *)
   rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; auto.
   intuition_in.
   absurd (InT x1 s2).
   rewrite <- split_spec3; auto; congruence.
   setoid_replace x1 with y; auto.
Qed.

Lemma inter_spec : forall s1 s2 y `{Ok s1, Ok s2},
 (InT y (inter s1 s2) <-> InT y s1 /\ InT y s2).
Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed.

Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2).
Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed.

(** ** Difference *)

Lemma diff_spec_ok : forall s1 s2 `{Ok s1, Ok s2},
 Ok (diff s1 s2) /\ (forall y, InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2).
Proof.
 intros s1 s2; functional induction diff s1 s2; intros B1 B2;
 [intuition_in|intuition_in | | ]; factornode s2;
 destruct_split; inv;
 destruct IHt0 as (IHb1,IHi1), IHt1 as (IHb2,IHi2); auto with *;
 split; intros.
 - (* Ok concat *)
   apply concat_ok; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
 - (* InT concat *)
   rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
   absurd (InT x1 s2).
   + setoid_replace x1 with y; auto.
   + rewrite <- split_spec3; auto; congruence.
 - (* Ok join *)
   apply join_ok; auto; intro y; rewrite ?IHi1, ?IHi2; intuition.
 - (* InT join *)
   rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; auto with *.
   intuition_in.
   absurd (InT x1 s2); auto.
   * rewrite <- split_spec3; auto; congruence.
   * setoid_replace x1 with y; auto.
Qed.

Lemma diff_spec : forall s1 s2 y `{Ok s1, Ok s2},
 (InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2).
Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed.

Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2).
Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed.

(** ** Union *)

Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2},
 (InT y (union s1 s2) <-> InT y s1 \/ InT y s2).
Proof.
 intros s1 s2; functional induction union s1 s2; intros y B1 B2.
 intuition_in.
 intuition_in.
 factornode s2; destruct_split; inv.
 rewrite join_spec, IHt0, IHt1, split_spec1, split_spec2; auto with *.
 destruct (X.compare_spec y x1); intuition_in.
Qed.

Instance union_ok s1 s2 : forall `(Ok s1, Ok s2), Ok (union s1 s2).
Proof.
 functional induction union s1 s2; intros B1 B2; auto.
 factornode s2; destruct_split; inv.
 apply join_ok; auto with *.
 intro y; rewrite union_spec, split_spec1; intuition_in.
 intro y; rewrite union_spec, split_spec2; intuition_in.
Qed.

(** * Filter *)

Lemma filter_spec_w : forall s x f,
 Proper (X.eq==>Logic.eq) f ->
 (InT x (filter f s) <-> InT x s /\ f x = true).
Proof.
 induction s as [ |h l Hl x0 r Hr]; intros x f Hf; simpl.
 - intuition_in.
 - case_eq (f x0); intros Hx0.
   * rewrite join_spec, Hl, Hr; intuition_in.
     now setoid_replace x with x0.
   * rewrite concat_spec, Hl, Hr; intuition_in.
     assert (f x = f x0) by auto. congruence.
Qed.

Lemma filter_spec : forall s x f `{Ok s},
 Proper (X.eq==>Logic.eq) f ->
 (InT x (filter f s) <-> InT x s /\ f x = true).
Proof. intros s x f _. exact (@filter_spec_w _ _ _). Qed.

Lemma filter_spec'_w : forall s x f,
 InT x (filter f s) -> InT x s.
Proof.
 induction s as [ |h l Hl x0 r Hr]; intros x f; simpl.
 - trivial.
 - destruct (f x0).
   * rewrite join_spec; intuition_in; eauto.
   * rewrite concat_spec; intuition_in; eauto.
Qed.

Lemma filter_spec' : forall s x f `{Ok s},
 InT x (filter f s) -> InT x s.
Proof. intros s x f _. exact (@filter_spec'_w _ _ _). Qed.

Instance filter_ok s f `(H : Ok s) : Ok (filter f s).
Proof.
 induction H as [ | h x l r Hl Hfl Hr Hfr Hlt Hgt ].
 - constructor.
 - simpl.
   assert (lt_tree x (filter f l)) by (eauto using filter_spec'_w).
   assert (gt_tree x (filter f r)) by (eauto using filter_spec'_w).
   destruct (f x); eauto using concat_ok, join_ok.
Qed.

(** * Partition *)

Lemma partition_spec1w s f : (partition f s)#1 = filter f s.
Proof.
 induction s as [ | h l Hl x r Hr ]; simpl.
 - trivial.
 - rewrite <- Hl, <- Hr.
   now destruct (partition f l), (partition f r), (f x).
Qed.

Lemma partition_spec2w s f :
 (partition f s)#2 = filter (fun x => negb (f x)) s.
Proof.
 induction s as [ | h l Hl x r Hr ]; simpl.
 - trivial.
 - rewrite <- Hl, <- Hr.
   now destruct (partition f l), (partition f r), (f x).
Qed.

Lemma partition_spec1 s f `{Ok s} :
 Proper (X.eq==>Logic.eq) f ->
 Equal (partition f s)#1 (filter f s).
Proof. now rewrite partition_spec1w. Qed.

Lemma partition_spec2 s f `{Ok s} :
 Proper (X.eq==>Logic.eq) f ->
 Equal (partition f s)#2 (filter (fun x => negb (f x)) s).
Proof. now rewrite partition_spec2w. Qed.

Lemma partition_spec1' s x f `{Ok s} :
 In x (partition f s)#1 -> In x s.
Proof. rewrite partition_spec1w. exact (@filter_spec'_w _ _ _). Qed.

Lemma partition_spec2' s x f `{Ok s} :
 In x (partition f s)#2 -> In x s.
Proof. rewrite partition_spec2w. exact (@filter_spec'_w _ _ _). Qed.

Instance partition_ok1 s f `(Ok s) : Ok (partition f s)#1.
Proof. rewrite partition_spec1w; now apply filter_ok. Qed.

Instance partition_ok2 s f `(Ok s) : Ok (partition f s)#2.
Proof. rewrite partition_spec2w; now apply filter_ok. Qed.

End MakeRaw.

(** * Encapsulation *)

Module IntMake (I:Int)(X: OrderedType) <: Sets with Module E := X.
 Module Raw := MakeRaw I X.
 Include Raw2Sets X Raw.
End IntMake.

(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)

Module Make (X: OrderedType) <: Sets with Module E := X
 :=IntMake(Z_as_Int)(X).


(* Proving equivalence between the Hacspec implementation of the Ed25519 curve operations
   and the fiat crypto specification. Addition is finished, but there is missing parts of
   multiplication. *)

Require Import Hacspec.Util.Lib.
Require Import Hacspec.Util.MachineIntegers.
From Coq Require Import ZArith.
Import List.ListNotations.
Open Scope Z_scope.
Open Scope bool_scope.
Open Scope hacspec_scope.

Require Import Hacspec.Curve.Ed25519.

From Coqprime Require Import GZnZ.
Require Import Field.
Require Import Crypto.Spec.Curve25519.
Require Import Crypto.Curves.Edwards.XYZT.Basic.
Require Import Crypto.Algebra.Hierarchy.

Notation ed_field := (nat_mod 57896044618658097711785492504343953926634992332820282019728792003956564819949).

Lemma ed_field_theory: @field_theory ed25519_field_element_t nat_mod_zero nat_mod_one nat_mod_add nat_mod_mul nat_mod_sub nat_mod_neg nat_mod_div nat_mod_inv Logic.eq.
Proof. apply FZpZ. apply prime_p. Qed.

Lemma ed_field_theory': @field_theory ed_field nat_mod_zero nat_mod_one nat_mod_add nat_mod_mul nat_mod_sub nat_mod_neg nat_mod_div nat_mod_inv Logic.eq.
Proof. apply FZpZ. apply prime_p. Qed.

Add Field ed_field: ed_field_theory.
Add Field ed_field': ed_field_theory'.

Lemma test: forall x: ed25519_field_element_t, x -% x = nat_mod_zero.
Proof. intros. field. Qed.

Global Instance fc_field: @field ed25519_field_element_t (@Logic.eq ed_field) nat_mod_zero nat_mod_one nat_mod_neg nat_mod_add nat_mod_sub nat_mod_mul nat_mod_inv nat_mod_div.
Proof.
    repeat split; try apply (Fdiv_def ed_field_theory); try (intros; field); try apply (_ (ed_field_theory)); auto.
     symmetry; apply (F_1_neq_0 (ed_field_theory)).
Qed.

Lemma pos_le_three: forall pos: positive, (pos < 3)%positive -> pos = 1%positive \/ pos = 2%positive.
Proof. intros [] H; auto; inversion H.
- unfold Pos.compare, Pos.compare_cont in H1. destruct p; inversion H1.
- assert (p = 1%positive). unfold Pos.compare, Pos.compare_cont in H1. destruct p; inversion H1. auto.
  rewrite H0. auto.
Qed.

Lemma ed_char_ge:  @Ring.char_ge ed25519_field_element_t Logic.eq nat_mod_zero nat_mod_one nat_mod_neg nat_mod_add nat_mod_sub nat_mod_mul (BinNat.N.succ_pos BinNat.N.two).
Proof.
  unfold char_ge, Hierarchy.char_ge. intros pos. cbn. intros H. apply pos_le_three in H. destruct H;
  rewrite H; simpl; intro c; discriminate c.
Qed.

Lemma ed_dec: DecidableRel (@Logic.eq ed25519_field_element_t).
Proof. unfold Decidable. intros x y. destruct (x =.? y) eqn:E.
  - left. apply eqb_leibniz. apply E.
  - right. intro. rewrite H in E. unfold "=.?", nat_mod_eqdec in E. rewrite Z.eqb_refl in E. discriminate.
Qed.

Notation a := (nat_mod_neg nat_mod_one : ed25519_field_element_t).
Notation d := (mkznz _ _ (modz _ 37095705934669439343138083508754565189542113879843219016388785533085940283555) : ed25519_field_element_t).

Notation twice_d := (d +% d).

Lemma nonzero_a : a <> nat_mod_zero.
Proof. intro. inversion H.
Qed.

Require Import Lia.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.

Lemma square_a : exists sqrt_a : ed25519_field_element_t, sqrt_a *% sqrt_a = a.
Proof.
  exists (mkznz _ _ (modz _ 19681161376707505956807079304988542015446066515923890162744021073123829784752)).
  unfold "*%", mul, nat_mod_neg, GZnZ.opp, nat_mod_one, one, val. apply zirr.
  pull_Zmod. reflexivity.
Qed.

Lemma nonsquare_d : forall x : ed25519_field_element_t, x *% x <> d.
Proof. intros x H.  Admitted.

Notation fc_point := (@point ed25519_field_element_t Logic.eq nat_mod_zero nat_mod_add nat_mod_mul a d).
Notation fc_add := (@m1add ed25519_field_element_t Logic.eq nat_mod_zero nat_mod_one nat_mod_neg nat_mod_add nat_mod_sub nat_mod_mul nat_mod_inv nat_mod_div fc_field ed_char_ge ed_dec
a d nonzero_a square_a nonsquare_d eq_refl twice_d eq_refl).
Notation fc_id := (@Basic.zero ed25519_field_element_t Logic.eq nat_mod_zero nat_mod_one nat_mod_neg nat_mod_add nat_mod_sub nat_mod_mul nat_mod_inv nat_mod_div fc_field ed_dec
a d nonzero_a).

Notation fc_eq := (@eq ed25519_field_element_t Logic.eq nat_mod_zero nat_mod_add nat_mod_mul a d).

Lemma same_d: nat_mod_from_byte_seq_le (constant_d_v) = d.
Proof.
Admitted.

Lemma two_equiv: (nat_mod_two: ed25519_field_element_t) = nat_mod_one +% nat_mod_one.
Proof. reflexivity. Qed.

Definition ed_eq (p q : ed_point_t): Prop :=
  let '(x1, y1, z1, _) := p in
  let '(x2, y2, z2, _) := q in
  z2 *% x1 = z1 *% x2 /\ z2 *% y1 = z1 *% y2.

Lemma add_equiv: forall p q: fc_point, (point_add (coordinates p) (coordinates q)) = (coordinates (fc_add p q)).
Proof. intros [[[[]]]] [[[[]]]]. unfold m1add, coordinates, proj1_sig, point_add, ed_eq. rewrite same_d, two_equiv.
  repeat (apply pair_equal_spec; split); field_simplify; reflexivity.
Qed.

Notation "x ^%2" := (x *% x) (at level 20).

Definition onCurve (p: ed_point_t) : Prop :=
  let '(x, y, z, t) := p in
  a *% x^%2 *% z^%2 +% y^%2 *% z^%2 = (z^%2)^%2 +% d *% x^%2 *% y^%2
  /\ x *% y = z *% t
  /\ z <> nat_mod_zero.

Program Definition to_fc_point (p: ed_point_t) (onc : onCurve p): fc_point :=
  p.

Lemma to_and_from: forall (p : ed_point_t) (oncp :onCurve p),
  p = coordinates (to_fc_point p oncp).
Proof.
  intros. reflexivity.
Qed.

Lemma on_curve_fc: forall (p : fc_point), onCurve (coordinates p).
Proof.
  intros [[[[]]]]. apply y.
Qed.

Lemma add_preserves_curve: forall p q (oncp: onCurve p) (oncq: onCurve q),
  onCurve (point_add p q).
Proof.
  intros. rewrite (to_and_from p oncp). rewrite (to_and_from q oncq). rewrite add_equiv.
  apply on_curve_fc.
Qed.

Lemma add_equiv': forall (p q : ed_point_t) (oncp : onCurve p) (oncq : onCurve q),
  eq (fc_add (to_fc_point p oncp) (to_fc_point q oncq)) (to_fc_point (point_add p q) (add_preserves_curve _ _ oncp oncq)).
Proof.
  intros [[[]]] [[[]]] oncp oncq. unfold m1add, to_fc_point, point_add, eq, coordinates, proj1_sig. rewrite same_d, two_equiv.
  split; field_simplify; reflexivity.
Qed.

Require Import Crypto.Spec.CompleteEdwardsCurve.

Notation spec_point := (@E.point ed25519_field_element_t Logic.eq nat_mod_one nat_mod_add nat_mod_mul a d).
Notation spec_add := (@E.add ed25519_field_element_t Logic.eq nat_mod_zero nat_mod_one nat_mod_neg nat_mod_add nat_mod_sub nat_mod_mul nat_mod_inv nat_mod_div fc_field ed_char_ge ed_dec
a d nonzero_a square_a nonsquare_d).

Notation fc_from_spec := (@from_twisted ed25519_field_element_t Logic.eq nat_mod_zero nat_mod_one nat_mod_neg nat_mod_add nat_mod_sub nat_mod_mul nat_mod_inv nat_mod_div fc_field ed_dec
  a d nonzero_a).
Notation fc_to_spec := (@to_twisted ed25519_field_element_t Logic.eq nat_mod_zero nat_mod_one nat_mod_neg nat_mod_add nat_mod_sub nat_mod_mul nat_mod_inv nat_mod_div fc_field ed_dec
  a d nonzero_a).

Require Import Crypto.Algebra.Group.
Require Import Crypto.Algebra.Monoid.

Lemma fc_eq_equiv: forall (p q: fc_point), ed_eq (coordinates p) (coordinates q) <-> fc_eq p q.
Proof.
  intros [[[[]]]] [[[[]]]].
  unfold eq, coordinates, proj1_sig, ed_eq. reflexivity.
Qed.

Local Instance iso_group : Group.isomorphic_commutative_groups
:= (@isomorphic_commutative_group_m1 ed25519_field_element_t Logic.eq nat_mod_zero nat_mod_one nat_mod_neg nat_mod_add nat_mod_sub nat_mod_mul nat_mod_inv nat_mod_div fc_field ed_char_ge ed_dec
a d nonzero_a square_a nonsquare_d eq_refl twice_d eq_refl).

Local Instance fc_eq_class : RelationClasses.Equivalence eq := (@Equivalence_eq ed25519_field_element_t Logic.eq nat_mod_zero nat_mod_one nat_mod_neg nat_mod_add nat_mod_sub nat_mod_mul nat_mod_inv nat_mod_div fc_field ed_dec
a d nonzero_a).

Lemma add_spec_equiv: forall (p q : spec_point), ed_eq (point_add (coordinates (fc_from_spec p)) (coordinates (fc_from_spec q))) (coordinates (fc_from_spec (spec_add p q))).
Proof.
   intros. rewrite add_equiv, fc_eq_equiv. symmetry. apply homomorphism.
Qed.

Lemma spec_refl: forall (x: spec_point), E.eq x x.
Proof.
  intros [[]]. split; reflexivity.
Qed.

Lemma spec_symm: forall (x y : spec_point), E.eq x y -> E.eq y x.
Proof.
  intros [[]] [[]]. cbn. intros [-> ->]. auto.
Qed.

Lemma spec_trans: forall (x y z : spec_point), E.eq x y -> E.eq y z -> E.eq x z.
Proof.
  intros [[]] [[]] [[]]. cbn. intros [-> ->] [-> ->]. auto.
Qed.

Add Relation spec_point E.eq
  reflexivity proved by spec_refl
  symmetry proved by spec_symm
  transitivity proved by spec_trans
  as spec_eq_rel.

Lemma add_spec_equiv': forall (p q : ed_point_t) (oncp : onCurve p) (oncq : onCurve q),
  E.eq (spec_add (fc_to_spec (to_fc_point p oncp)) (fc_to_spec (to_fc_point q oncq))) (fc_to_spec (to_fc_point (point_add p q) (add_preserves_curve _ _ oncp oncq))).
Proof.
  intros. rewrite <- add_equiv'. rewrite homomorphism. reflexivity.
Qed.

Notation "x ?=? y" := (ed_eq x y) (at level 90).
Notation "x ?+? y" := (point_add x y) (at level 60).
Notation "x #=# y" := (fc_eq x y) (at level 90).
Notation "x #+# y" := (fc_add x y) (at level 60).

Lemma ed_refl: forall x, x ?=? x.
Proof. intros [[[]]]. split; reflexivity.
Qed.

Lemma ed_symm: forall x y, x ?=? y -> y ?=? x.
Proof.
  intros [[[]]] [[[]]]. cbn. intros [-> ->]. auto.
Qed.

Lemma ed_field_refl: forall x: ed25519_field_element_t, x =.? x = true.
Proof. intros. unfold "=.?", nat_mod_eqdec. apply Z.eqb_refl. Qed.

(* Missing the case for zero, should be possible using fiat-crypto IntegralDomain *)
Lemma ed_trans: forall x y z, x ?=? y -> y ?=? z -> x ?=? z.
Proof.
  intros [[[]]] [[[]]] [[[]]]. cbn. intros [] []. split.
  - destruct (e5 =.? (nat_mod_zero : ed25519_field_element_t)) eqn:E.
    + rewrite eqb_leibniz in E. subst. admit.
    + apply (f_equal (fun x => e9 *% (nat_mod_inv e5) *% x)) in H. field_simplify in H. rewrite H.
   pose proof ed_field_theory as [[]]. rewrite (Rmul_comm e9). rewrite <- Rmul_assoc. rewrite H1. field.
   intro. all: subst; rewrite ed_field_refl in E; discriminate.
  - destruct (e5 =.? (nat_mod_zero : ed25519_field_element_t)) eqn:E.
   + rewrite eqb_leibniz in E. subst. admit.
   + apply (f_equal (fun x => e9 *% (nat_mod_inv e5) *% x)) in H0. field_simplify in H0. rewrite H0.
  pose proof ed_field_theory as [[]]. rewrite (Rmul_comm e9). rewrite <- Rmul_assoc. rewrite H2. field.
  intro. all: subst; rewrite ed_field_refl in E; discriminate.
Admitted.

Add Relation ed_point_t ed_eq
  reflexivity proved by ed_refl
  symmetry proved by ed_symm
  transitivity proved by ed_trans
  as ed_eq_rel.

Lemma ed_add_comm: forall x y, onCurve x -> onCurve y -> x ?+? y ?=? y ?+? x.
  intros. rewrite (to_and_from _ H). rewrite (to_and_from _ H0). do 2 rewrite -> add_equiv.
  rewrite fc_eq_equiv. apply commutative.
Qed.

Lemma ed_add_assoc: forall x y z, onCurve x -> onCurve y -> onCurve z -> x ?+? (y ?+? z) ?=? (x ?+? y) ?+? z.
Proof. intros. rewrite (to_and_from _ H). rewrite (to_and_from _ H0). rewrite (to_and_from _ H1).
repeat rewrite add_equiv. rewrite fc_eq_equiv. apply associative.
Qed.

Require Import Lia.

Require Import MachineIntegers.

Lemma max_unsigned32 : @max_unsigned WORDSIZE32 = 4294967295.
Proof. reflexivity. Qed.

Lemma modulus32 : @modulus WORDSIZE32 = 4294967296.
Proof. reflexivity. Qed.

Lemma foldi_helper: forall A n i f (acc : A), 0 <= i <= 256 -> foldi_ (S n) (repr i) f acc = foldi_ (n) (repr (i +1)) f (f (repr i) acc).
Proof. intros. assert (@add WORDSIZE32 (repr i) one = repr (i + 1)). {
    unfold add. rewrite unsigned_one. rewrite unsigned_repr. reflexivity.
    rewrite max_unsigned32. lia.
  }
  cbn. rewrite H0. reflexivity.
Qed.

Notation scalarmod := (2^252 + 27742317777372353535851937790883648493).

Definition scalar_from_z (z : Z) : scalar_t := (mkznz _ _ (modz _ z)).
Definition scalar_from_pos (p : positive) : scalar_t := scalar_from_z (Zpos p).

Definition helperf (s: scalar_t) := (fun i_69 '(p_67, q_68) =>
let '(q_68) :=
  if nat_mod_bit (s) (i_69):bool then (let q_68 :=
      point_add (q_68) (p_67) in
    (q_68)) else ((q_68)) in
let p_67 :=
  point_add (p_67) (p_67) in
(p_67, q_68)).

Notation point_double p := (point_add p p).

Fixpoint helpermul1 (n: nat) (z: Z) (acc: ed_point_t * ed_point_t) :=
  let (acc1, acc2) := acc in match n with
  | O => acc
  | S n' => match z with
    | 0 => helpermul1 n' 0 (point_double acc1, acc2)
    | Zneg _ => acc
    | Zpos b => match b with
      | xH => helpermul1 n' 0 (point_double acc1, point_add acc2 acc1)
      | xO b => helpermul1 n' (Zpos b) (point_double acc1, acc2)
      | xI b => helpermul1 n' (Zpos b) (point_double acc1, point_add acc2 acc1)
      end
  end
end.

(* Should be in Hacspec.Lib *)
Lemma foldi_one_more: forall (A: Type) (lo hi: Z) f (acc: A), foldi (repr lo) (repr (Z.succ hi)) f acc = f (repr hi) (foldi (repr lo) (repr hi) f acc).
Admitted.

Lemma helpermul1_help: forall n z acc1 acc2, 0 <= z -> helpermul1 (S n) z (acc1, acc2) =
  let (acc1', acc2') := helpermul1 n z (acc1, acc2) in
  (point_double acc1', if Z.testbit z n then point_add acc2' acc1' else acc2').
Proof. induction n.
  - intros. cbn. destruct z; cbn.
    + reflexivity.
    + destruct p; reflexivity.
    + lia.
  - intros. destruct z.
    + rewrite nat_N_Z, Nat2Z.inj_succ. cbn. assert (0 = 2 * 0) as -> by reflexivity. rewrite Z.testbit_even_succ.
    rewrite nat_N_Z in IHn. rewrite <- IHn. reflexivity. lia. lia.
    + destruct p.
      * rewrite nat_N_Z, Nat2Z.inj_succ. cbn. assert (Z.pos p~1 = 2 * (Z.pos p) + 1) as -> by reflexivity. rewrite Z.testbit_odd_succ.
      rewrite nat_N_Z in IHn. rewrite <- IHn. reflexivity. lia. lia.
      * rewrite nat_N_Z, Nat2Z.inj_succ. cbn. assert (Z.pos p~0 = 2 * (Z.pos p)) as -> by reflexivity. rewrite Z.testbit_even_succ.
      rewrite nat_N_Z in IHn. rewrite <- IHn. reflexivity. lia. lia.
      * rewrite nat_N_Z, Nat2Z.inj_succ. cbn. assert (1 = 2 * 0 + 1) as -> by reflexivity. rewrite Z.testbit_odd_succ.
        rewrite nat_N_Z in IHn. rewrite <- IHn. reflexivity. lia. lia.
    + lia.
Qed.

Lemma foldi_is_ok: forall (i: uint_size) (z: Z) acc, 0 <= z < scalarmod ->
  foldi (repr 0) i (helperf (scalar_from_z z)) acc = helpermul1 (Z.to_nat (unsigned i)) z acc.
Proof. intro i. induction_uint_size i.
  - cbn. destruct acc. reflexivity.
  - unfold foldi. repeat rewrite unsigned_repr;try rewrite max_unsigned32; try lia. cbn. assert (Pos.to_nat 1 = 1%nat) as -> by reflexivity. cbn.
  destruct z.
    + unfold helperf. cbn. destruct acc. reflexivity.
    + unfold helperf. cbn. rewrite Zmod_small; try lia. destruct p; cbn; destruct acc; reflexivity.
    + lia.
  - rewrite modulus32 in H. rewrite unsigned_repr in H0; try rewrite max_unsigned32; try lia. cbn in H0.
    rewrite foldi_one_more. rewrite H0; try lia.
    repeat rewrite unsigned_repr;try rewrite max_unsigned32; try lia. rewrite Z2Nat.inj_succ; try lia. destruct acc. rewrite helpermul1_help.
    unfold helperf, nat_mod_bit.
    assert ((from_uint_size (repr (Z.pos b))) = Z.pos b). {
    unfold from_uint_size, Z_uint_sizable. apply unsigned_repr. rewrite max_unsigned32. lia. }
    rewrite H2. rewrite Z_nat_N, Z2N.id.
    cbn. rewrite Zmod_small. reflexivity. lia. lia. lia.
Qed.

Fixpoint helpermul2 (pos: positive) (acc1 acc2 : fc_point) := match pos with
| xH => fc_add acc2 acc1
| xO b => helpermul2 b (fc_add acc1 acc1) acc2
| xI b => helpermul2 b (fc_add acc1 acc1) (fc_add acc2 acc1)
end.

(* Need equivalence between helpermul1 and helpermul2, Something like this *)
Lemma one_two_equiv: forall pos n acc1 acc2, Pos.size_nat pos <= n -> snd (helpermul1 n (Zpos pos) (coordinates acc1, coordinates acc2)) = coordinates (helpermul2 pos acc1 acc2).
Admitted.

Require Export Setoid.

Add Morphism helpermul2 : helpermul2_m.
Proof. induction y; intros.
  - simpl. rewrite IHy. reflexivity. rewrite H. reflexivity. rewrite H, H0. reflexivity.
  - simpl. rewrite IHy. reflexivity. rewrite H. reflexivity. apply H0.
  - simpl.  rewrite H, H0. reflexivity.
Qed.

Lemma helpermul2_helper2: forall pos acc1 acc2 acc3, helpermul2 pos acc1 (acc2 #+# acc3) #=# acc3 #+# (helpermul2 pos acc1 acc2).
Proof. induction pos; intros.
- simpl. rewrite <- associative. rewrite (commutative acc3). rewrite associative. apply IHpos.
- simpl. apply IHpos.
-  simpl. rewrite associative. rewrite (commutative acc2). reflexivity.
Qed.

Notation fc_double x := (fc_add x x).
Lemma double_add: forall x y, fc_double (x #+# y) #=# fc_double x #+# fc_double y.
Proof. intros. rewrite associative. rewrite (commutative _ x). rewrite associative. symmetry. apply associative.
Qed.

Lemma helpermul2_helper: forall pos acc1, helpermul2 pos (fc_double acc1) fc_id #=# fc_double (helpermul2 pos acc1 fc_id).
Proof. induction pos; intros.
  - simpl. rewrite helpermul2_helper2. rewrite IHpos. rewrite helpermul2_helper2. symmetry. apply double_add.
  - simpl. apply IHpos.
  - simpl. do 2 rewrite left_identity. reflexivity.
Qed.

Fixpoint helpermul3 (pos : positive) (p : fc_point) : fc_point := match pos with
| xH => p
| xO pos' => fc_double (helpermul3 pos' p)
| xI pos' => (fc_double (helpermul3 pos' p)) #+# p
end.

Lemma two_three_equiv : forall pos p, helpermul2 pos p fc_id #=# helpermul3 pos p.
Proof. induction pos; intros.
- simpl. rewrite helpermul2_helper2. rewrite helpermul2_helper. rewrite IHpos. apply commutative.
- simpl. rewrite helpermul2_helper. rewrite IHpos. reflexivity.
- simpl. apply left_identity.
Qed.

(* Need equivalence between helpermul3 and fiat crypto mul *)


Require Import ListAux.
Require Import TreeAux.
Lemma batchedq1consistent_ListRev0 (il_0:list nat) (il_1:list nat) (u_0:nat) : (reverse_spec  il_0 il_1) -> (((list_member  il_0 u_0)) -> (list_member  il_1 u_0)).
Proof. solve_reverse. Qed.

Lemma batchedq1consistent_ListRev1 (il_0:list nat) (il_1:list nat) (u_0:nat) : (reverse_spec  il_0 il_1) -> (((not (list_member  il_0 u_0))) -> (not (list_member  il_1 u_0))).
Proof. solve_reverse. Qed.

Lemma batchedq1consistent_ListRev2 (il_0:list nat) (il_1:list nat) (u_0:nat) : (reverse_spec  il_0 il_1) -> (((not (list_member  il_0 u_0))) -> (not (list_head  il_0 u_0))).
Proof. solve_reverse. Qed.


(* -*- mode: coq -*- *)
(* Time-stamp: <2014/8/16 0:27:22> *)
(*
  binheap.v
  - mathink : Author
 *)

(**
 ** Binary Heap Structure
 *)

(* SSReflect libraries *)
Require Import
  Ssreflect.ssreflect
  Ssreflect.ssrbool
  Ssreflect.ssrfun
  Ssreflect.eqtype
  Ssreflect.ssrnat
  Ssreflect.seq.

Require Import
  MathComp.path
  MathComp.div.

Require Import
  Adlibssr.btree
  Adlibssr.order
  Adlibssr.monad.

Require Import Wf_nat Recdef.

(* Implicity *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Generalizable All Variables.

Section Accessor.

  Variables (T: eqType).

  Inductive pos :=
  | pos_on
  | pos_l of pos
  | pos_r of pos.

  Fixpoint pos_cat (p1 p2: pos) :=
    match p1 with
      | pos_on => p2
      | pos_l p => pos_l (pos_cat p p2)
      | pos_r p => pos_r (pos_cat p p2)
    end.

  Fixpoint btget t p: option T :=
    match t, p with
      | _ -< x >- _, pos_on => Some x
      | t' -< _ >- _, pos_l p'
      | _ -< _ >- t', pos_r p' => btget t' p'
      | #, _ => None
    end.

  (* pos の適用順が逆 *)
  Fixpoint pos2n_base (acc: nat)(p: pos) :=
    match p with
      | pos_on => acc
      | pos_l p' => (pos2n_base (acc.*2.+1) p')
      | pos_r p' => (pos2n_base (acc.+1.*2) p')
    end.

  Definition pos2n := pos2n_base 0.

  Eval compute in (pos2n (pos_l (pos_l (pos_l pos_on)))).

  Definition ltn (x y: nat): Prop := x < y.
  Hint Unfold ltn.
  Definition wf_ltn: well_founded ltn.
  Proof.
    apply well_founded_lt_compat with id.
    move=> x y Hlt; apply/ltP=>//.
  Defined.

  Function n2pos_base (n: nat){wf ltn}: pos -> pos :=
    match n with
      | O => id
      | n'.+1 => let (q, r) := edivn n' 2 in
                 if r == 0
                 then n2pos_base q \o pos_l
                 else n2pos_base q \o pos_r
    end.
  Proof.
    - move=> n n' Heqn q r.
      rewrite edivn_def /ltn => Heq; move: Heq => [] <- <- /eqP _.
      apply leq_ltn_trans with n'; last by apply ltnSn.
      by apply leq_div.
    - move=> n n' Heqn q r.
      rewrite /ltn edivn_def => Heq; move: Heq => [] <- <- /eqP _.
      apply leq_ltn_trans with n'; last by apply ltnSn.
      by apply leq_div.
    - by apply wf_ltn.
  Defined.

  Definition n2pos n := n2pos_base n pos_on.

  Lemma n2pos_pos2n_base n p:
   pos2n_base 0 (n2pos_base n p) = pos2n_base n p.
  Proof.
    move: p; pattern n.
    apply well_founded_induction with ltn; first by apply wf_ltn.
    rewrite /ltn => {n} x IH p /=.
    rewrite n2pos_base_equation.
    case: x IH => [| x] IH //=.
    rewrite edivn_def modn2 eqb0 if_arg fun_if /=.
    do 2 (rewrite IH; last by (rewrite ltnS; apply leq_div)).
    case Hodd: (odd x) => /=.
    - have: ((x %/ 2).+1.*2 = x.+1); last by move=>->//.
      rewrite /= -addn1 addnC -muln2 mulnDl muln2 -addnn addnAC addn1 muln2 divn2.
      move: Hodd => /eqP; rewrite eqb_id -[odd x]eqb1 => /eqP {1}<-.
      by rewrite odd_double_half.
    - have: ((x %/ 2).*2.+1 = x.+1); last by move=>->//.
      apply eq_S; apply/eqP.
      by rewrite -muln2 -dvdn_eq dvdn2 Hodd.
  Qed.

  Lemma n2pos_pos2n_cancel: cancel n2pos pos2n.
  Proof.
    move=> n /=.
    by rewrite/n2pos /pos2n n2pos_pos2n_base.
  Qed.

  Lemma pos2n_n2pos_base n p1 p2:
    n2pos_base (pos2n_base n p1) p2 =
    n2pos_base n (pos_cat p1 p2).
  Proof.
    elim: p1 p2 n => [| p1 /= IHp | p1 /= IHp] //= p2 n.
    - by rewrite IHp n2pos_base_equation edivn_def -muln2 modnMl/= mulnK//.
    - by rewrite IHp n2pos_base_equation -addn1 -addnn /= addnAC addnC /= addnA edivn_def addnn -muln2 modnMDl/= divnMDl//= divn_small// addn0.
  Qed.

  Lemma pos_catp0 p: pos_cat p pos_on = p.
  Proof.
    by elim: p => [|p/=->|p/=->].
  Qed.

  Lemma pos2n_n2pos_cancel: cancel pos2n n2pos.
  Proof.
    move=> p /=.
    rewrite/n2pos /pos2n pos2n_n2pos_base pos_catp0 //.
  Qed.

  Lemma bij_n2pos: bijective n2pos.
  Proof.
    apply Bijective with pos2n.
    - apply n2pos_pos2n_cancel.
    - apply pos2n_n2pos_cancel.
  Qed.

  Lemma bij_pos2n: bijective pos2n.
  Proof.
    apply Bijective with n2pos.
    - apply pos2n_n2pos_cancel.
    - apply n2pos_pos2n_cancel.
  Qed.

End Accessor.

Require Import MathComp.prime MathComp.bigop.

(* Eval compute in (avl ((#-< 1 >-#) -< 2 >- (#-< 3 >-#))). *)
(* Eval compute in (avl (((#-< 2 >-#) -< 1 >- (#-< 3 >-#))-< 0 >- (#-< 4 >-#))). *)
(* Eval compute in (map n2pos [:: 0 ; 1 ; 2 ; 3;  4 ]). *)
(* Eval compute in (let t := (((#-< 3 >-#) -< 1 >- (#-< 4 >-#))-< 0 >- (#-< 2 >-#)) in (btget t (pos_l (pos_r pos_on)))). *)
(* Eval compute in (let t := (((#-< 3 >-#) -< 1 >- (#-< 4 >-#))-< 0 >- (#-< 2 >-#)) in (map (btget t \o n2pos) [:: 0 ; 1 ; 2 ; 3;  4 ])). *)
(* Eval compute in (btget ((#-< 1 >-#) -< 2 >- (#-< 3 >-#)) pos_on). *)
(* Eval compute in (btget ((#-< 1 >-#) -< 2 >- (#-< 3 >-#)) (pos_l pos_on)). *)
(* Eval compute in (btget ((#-< 1 >-#) -< 2 >- (#-< 3 >-#)) (n2pos 0)). *)

Section Heap.

  Variables (T: eqType)(ord: totalOrder T).
  Implicit Type (t: btree T).

  Fixpoint bt_ord a t: bool :=
    if t is tl -< x >- tr
    then (ord a x) && (bt_ord x tl) && (bt_ord x tr)
    else true.

  (* heap property *)
  Definition bt_ordered t: bool :=
    if t is tl -< x >- tr
    then (bt_ord x tl) && (bt_ord x tr)
    else true.

  Lemma bt_ord_min a t:
    bt_ord a t -> all (ord a) t.
  Proof.
    elim: t a => [//=|/= x tl IHl tr IHr] a.
    by rewrite -!andbA => /and3P [Hord /IHl Hbl /IHr Hbr]; apply /and3P; split; try done;
      apply/allP=> y Hin; apply ord_transitive with x => //;
       [move: Hbl | move: Hbr]; move=>/allP; apply.
  Qed.

  Definition btgetn t := btget t \o n2pos.
(* shape property *)
  Definition bt_shape t: bool :=
    seq.all (fun n => btgetn t n != None) (iota 0 (size t)).

  Context `(mon: eqMonad m)(monf: eqMonad_F mon).

  Fixpoint put t p a: m (btree_eqType T) :=
    match t, p with
      | #, pos_on => emb (#-< a >-#)
      | tl -< x >- tr, pos_l p' =>
        tl' <- put tl p' a;
          emb (tl' -< x >- tr)
      | tl -< x >- tr, pos_r p' =>
        tr' <- put tr p' a;
          emb (tl -< x >- tr')
      | _, _ => failure
    end.

  (* Section InitBase. *)
  (*   Variable (a: T). *)
  (*   Compute (map (fun x => (x, half x, uphalf x)) (iota 0 15)). *)

  (*   Function init_base (n: nat){wf ltn}: btree T := *)
  (*     match n with *)
  (*       | O => # *)
  (*       | 1 => #-< a >-# *)
  (*       | n'.+1 => *)
  (*         init_base (uphalf n') -< a >- init_base (half n') *)
  (*     end. *)
  (*   Proof. *)
  (*     - move=> n ? n' ? Heqn; rewrite/ltn -divn2. *)
  (*       remember (n'.+1) as n1. *)
  (*       rewrite -addn1 -[n1.+1]addn1 leq_add2r. *)
  (*       by apply leq_div. *)
  (*     - move=> n ? n' ? Heqn; rewrite/ltn. *)
  (*       rewrite uphalf_half -modn2 -divn2 addnC. *)
  (*       remember (n'.+1) as n1. *)
  (*       rewrite -addn1 -[n1.+1]addn1 leq_add2r. *)
  (*       rewrite {3}[n1](divn_eq n1 2) leq_add2r. *)
  (*       by apply leq_pmulr => //. *)
  (*     - by apply wf_ltn. *)
  (*   Defined. *)

  (* End InitBase. *)

  (* Lemma bt_shape_put t a: *)
  (*   bt_shape t -> *)
  (*   exists t', put t (n2pos (size t)) a = emb t'. *)
  (* Proof. *)
  (*   elim: t => [| x tl IHl tr IHr] //=. *)
  (*   - by move=> _; exists (#-< a >-#). *)
  (*   -  *)

(* W.I.P. *)

End Heap.

(* Compute (let ft := init_base 0 in *)
(*          (map (bt_shape (T:=nat_eqType) \o ft) (iota 0 15))). *)

Fixpoint bits2pos (bits: list bool): pos :=
  match bits with
    | [::] => pos_on
    | true :: bits' => pos_l (bits2pos bits')
    | false :: bits' => pos_r (bits2pos bits')
  end.

Compute ((pos2n \o bits2pos) [::false]).
Compute (pos2n (pos_l (pos_r (pos_l pos_on)))).
Compute (pos2n (pos_r (pos_r (pos_l pos_on)))).
Compute (pos2n (pos_l (pos_l (pos_r (pos_l pos_on))))).
Compute (pos2n (pos_r (pos_l (pos_r (pos_l pos_on))))).
Compute (height (#-< 1 >-#: btree nat)).

Definition ttree :=
  bnode
    50
    (bnode
       17
       (bnode
          12
          (bnode 9 # #)
          (bnode 14 # #))
       (bnode
          23
          (bnode 19 # #)
          #))
    (bnode
       72
       (bnode 54 # #)
       (bnode 76 # #)).

Eval compute in (x <- (put eqMaybe_F ttree (n2pos (size ttree)) 0); emb (bt_shape x)).

Eval compute in
    (let t :=
         bnode
           50
           (bnode
              17
              (bnode
                 12
                 (bnode 9 # #)
                 (bnode 14 # #))
              (bnode
                 23
                 (bnode 19 # #)
                 #))
           (bnode
              72
              (bnode 54 # #)
              (bnode 76 # #))
     in bt_shape t).


(* BEGIN FIX *)
From Coq Require Import Strings.String.

Inductive exp : Type :=
| lit (n : nat)
| var (x : string)
| plus (e1 e2 : exp).

Definition state : Type := string -> nat.

Definition empty : state := fun x => 0.

Definition update (x:string)(n:nat)(s:state) : state :=
  fun x' => match string_dec x x' with
  | left  e => n
  | right e => s x'
  end.

Definition W : string := "W".
Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".

Reserved Notation "e , s => e'" (at level 50).

Inductive evalo : exp -> state -> exp -> Prop :=
  | eval_var (x : string)(s : state) :

    (*------------------*)
    var x , s => lit (s x)

  | eval_plus_lhs (e1 e2 e1' : exp)(s : state) :

          e1 , s => e1'           ->
    (*-------------------------*)
    plus e1 e2 , s => plus e1' e2

  | eval_plus_rhs (e2 e2' : exp)(s : state)(n : nat) :

             e2 , s => e2'                  ->
    (*-----------------------------------*)
    plus (lit n) e2 , s => plus (lit n) e2'

  | eval_plus_fin (n m : nat)(s : state) :

    (*-----------------------------------*)
    plus (lit m) (lit n) , s => lit (m + n)

  where "e , s => e'" := (evalo e s e').

Example ex1 : exists (e : exp)(m n : nat), e , empty => plus (lit m) (lit n).
(* END FIX *)
Proof.
  exists ((plus (lit 1) (var X))).
  exists 1.
  exists 0.
  apply eval_plus_rhs.
  apply eval_var.
Qed.
(* BEGIN FIX *)
Example ex2 : exists (e : exp), plus (lit 1) (plus (lit 2) (lit 3)) , empty => e.
(* END FIX *)
Proof.
  exists (plus (lit 1) (lit 5)).
  apply eval_plus_rhs.
  apply eval_plus_fin.
Qed.
(* BEGIN FIX *)
Example ex3 : ~ (exists (s : state), var X , s => var Y).
(* END FIX *)
Proof.
  unfold not.
  intro.
  inversion H.
  inversion H0.
Qed.
(* BEGIN FIX *)
Example ex4 : forall (s : state)(e : exp), var X , s => e -> exists (n : nat), e = lit n.
(* END FIX *)
Proof.
  intros.
  induction e.
  - exists n. reflexivity.
  - inversion H.
  - inversion H.
Qed.
(* BEGIN FIX *)
Example ex5 : ~ (plus (lit 3) (plus (lit 4) (plus (lit 5) (lit 6))) , empty =>
                 plus (lit 3) (plus (lit 4) (lit 12))).
(* END FIX *)
Proof.
  unfold not.
  intros.
  inversion H.
  inversion H3.
  inversion H8.
Qed.
(* BEGIN FIX *)
Example ex6 : exists (e1 e2 : exp), e1 <> e2 /\ e1 , empty => lit 0 /\ e2 , empty => lit 0.
(* END FIX *)
Proof.
  exists (var X).
  exists (var Y).
  split.
  { unfold not. intros. inversion H. }
  { split. all: apply eval_var. }
Qed.
(* BEGIN FIX *)
Reserved Notation "e , s =>* e'" (at level 50).

Inductive evalo_rtc : exp -> state -> exp -> Prop :=
  | eval_refl (e : exp)(s : state) :

    e , s =>* e

  | eval_trans (e e' e'' : exp)(s : state) :

    e , s => e'    ->    e' , s =>* e'' ->
    (*-------------------------------*)
    e , s =>* e''

  where "e , s =>* e'" := (evalo_rtc e s e').

Example ex7 : exists (n : nat),
  plus (plus (var X) (var Y)) (plus (lit 3) (var Z)) , update X 3 (update Y 2 empty) =>* lit n.
(* END FIX *)
Proof.
  exists 8.
  apply (eval_trans _ (plus (plus (lit 3) (var Y)) (plus (lit 3) (var Z)))).
  { apply eval_plus_lhs. apply eval_plus_lhs. apply eval_var. }
  apply (eval_trans _ (plus (plus (lit 3) (lit 2)) (plus (lit 3) (var Z)))).
  { apply eval_plus_lhs. apply eval_plus_rhs. apply eval_var. }
  apply (eval_trans _ (plus (lit 5) (plus (lit 3) (var Z)))).
  { apply eval_plus_lhs. apply eval_plus_fin. }
  apply (eval_trans _ (plus (lit 5) (plus (lit 3) (lit 0)))).
  { apply eval_plus_rhs. apply eval_plus_rhs. apply eval_var. }
  apply (eval_trans _ (plus (lit 5) (lit 3))).
  { apply eval_plus_rhs. apply eval_plus_fin. }
  apply (eval_trans _ (lit 8)).
  { apply eval_plus_fin. }
  apply eval_refl.
Qed.
(* BEGIN FIX *)
Lemma notrefl (e : exp)(s : state) : ~ (e , s => e).
intro.
induction e.
 * inversion H.
 * inversion H.
 * inversion H.
   - (* eval_plus_lhs *) apply IHe1. exact H3.
   - (* eval_plus_rhs *) apply IHe2. exact H3.
Qed.

(* tanacs: szukseg lesz a notrefl-re *)
Lemma notsym (e e' : exp)(s : state) : e , s => e' -> ~ e' , s => e.
(* END FIX *)
(* BEGIN FIX *)
Lemma trans (e e' e'' : exp)(s : state) : e , s =>* e' -> e' , s =>* e'' -> e , s =>* e''.
(* END FIX *)


Require Import Arith Lia.
Require Import List.
Require Import Recdef.
Import ListNotations.

Require Import TPPMark2019.Value.
Require Import TPPMark2019.Tape.
Require Import TPPMark2019.CTM.
Require Import TPPMark2019.Clearer.
Require Import TPPMark2019.Util.

Set Implicit Arguments.

Instance BoolFinite : Finite.class bool :=
  {|
    Finite.card := 2;
    Finite.surj n := n =? 1;
  |}.
Proof.
  destruct x; eauto.
Defined.

Instance BoolValue : @Value.class bool BoolFinite :=
  {|
    Value.zero := false;
    Value.one := true;
  |}.
Proof.
  - decide equality.
  - auto.
Defined.

Module ListTape.
  Record t (V : Type) : Type :=
    {
      left_part: list V;
      top : V;
      right_part :list V;
    }.
  Arguments Build_t {V}.
  Arguments left_part {V} t.
  Arguments top {V} t.
  Arguments right_part {V} t.

  Definition size {V} '(Build_t l v r : t V) : nat := S (length l + length r).

  Definition head {V} '(Build_t l _ _ : t V) : nat := length l.

  Definition read {V} '(Build_t _ v _ : t V) : V := v.

  Definition write {V} (v : V) '(Build_t l _ r : t V)  : t V :=
    Build_t l v r.

  Function move_right {V} (tape : t V) :=
    let '(Build_t l v r) := tape in
    match r with
    | [] =>
      match rev l with
      | nil => Build_t [] v []
      | v' :: r' => Build_t [] v' (r' ++ [v])
      end
    | v' :: r' => Build_t (v :: l) v' r'
    end.

  Function move_left {V} (tape : t V) : t V :=
    let '(Build_t l v r) := tape in
    match l with
    | [] =>
      match rev r with
      | nil => Build_t [] v []
      | v' :: l' => Build_t (l' ++ [v]) v' []
      end
    | v' :: l' => Build_t  l' v' (v :: r)
    end.

  Definition to_list {V} '(Build_t l v r : t V)  : list V :=
    rev l ++ v :: r.

  Definition from_list {V} `{Value.class V} (vs : list V) : t V :=
    match vs with
    | [] => Build_t [] Value.zero []
    | v :: vs'  => Build_t [] v vs'
    end.

End ListTape.

Instance ListTape_Tape V `{Value.class V} : Tape.ops (ListTape.t V) V :=
  {|
    Tape.read := ListTape.read;
    Tape.write := ListTape.write;
    Tape.move_right := ListTape.move_right;
    Tape.move_left := ListTape.move_left;

  |}.

Instance ListTape_TapeSpec V `{Value.class V} : Tape.spec :=
  {|
    Tape.to_list := ListTape.to_list;
    Tape.size := ListTape.size;
    Tape.head := ListTape.head;
  |}.
Proof.
  - destruct t. simpl. ssimpl_list. auto.
  - destruct t. simpl. auto with arith.
  - destruct t. simpl. rewrite nth_error_app2; ssimpl_list; auto.
    rewrite Nat.sub_diag. reflexivity.
  - destruct t. simpl. rewrite nth_error_app2; ssimpl_list; auto.
    rewrite Nat.sub_diag. reflexivity.
  - intros i v t. destruct t. simpl.
    destruct (Nat.lt_ge_cases i (length (rev left_part))).
    + rewrite !nth_error_app1; auto.
    + rewrite !nth_error_app2; auto.
      case_eq (i - length (rev left_part)); simpl; auto.
      rewrite rev_length in *. lia.
  - intros v t. destruct t. reflexivity.
  - destruct t as [l v r]. destruct r; simpl; [destruct l using rev_ind|]; ssimpl_list; auto.
    rewrite <- List.app_assoc. auto.
  - destruct t as [l v r]. simpl.
    destruct r; [destruct l using rev_ind|]; rewrite ?rev_unit; simpl; auto; destruct_cmpbs.
  - destruct t as [l v r]; simpl; destruct l; simpl; [destruct r using rev_ind|]; ssimpl_list; auto.
    rewrite <- List.app_assoc. auto.
  - destruct t as [l v r]. simpl.
    destruct l; [destruct r using rev_ind|]; rewrite ?rev_unit; simpl; auto; destruct_cmpbs.
    ssimpl_list. auto with arith.
Defined.


Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.

Fixpoint eqn (m n : natural) : bool :=
  match m , n with
  | Zero , Zero => true
  | Succ m' , Succ n' => eqn m' n'
  | _, _ => false
  end.

Definition leq (m n : natural) : bool :=
  orb (eqn m n) (less m n).

Fixpoint insort (insort_arg0 : natural) (insort_arg1 : lst) : lst
           := match insort_arg0, insort_arg1 with
              | i, Nil => Cons i Nil
              | i, Cons x y => if less i x then Cons i (Cons x y) else Cons x (insort i y)
              end.

Fixpoint sorted (sorted_arg0 : lst) : bool
           := match sorted_arg0 with
              | Nil => true
              | Cons x l =>
                let s := sorted l in
                match l with
                | Nil => true
                | Cons y _ => andb s (leq x y)
                end
              end.

Fixpoint sort (sort_arg0 : lst) : lst
           := match sort_arg0 with
              | Nil => Nil
              | Cons x y => insort x (sort y)
              end.

(*
Lemma lem2: forall m n, less m n = false -> leq n m = true.
(* Proof.
  induction m.
  - intros. unfold leq. unfold orb. remember (eqn n (Succ m)).
    destruct b.
    * reflexivity.
    * destruct n.
      + simpl. simpl in H.  *)
Admitted.

Lemma lem3: forall n0 n l, sorted (Cons n l) = true -> leq n0 n = true ->
    sorted (Cons n0 (Cons n l)) = true.
Admitted.
*)

Lemma lem: forall n l, sorted l = true -> sorted (insort n l) = true.
(* Proof.
 intros. induction l.
  - simpl. remember (less n n0) as lt. destruct lt.
    * remember (Cons n0 l) as l0. simpl. rewrite Heql0 in H. rewrite Heql0.
      rewrite H. simpl. unfold leq. rewrite <- Heqlt. destruct (eqn n n0).
      + auto.
      + auto.
    * assert (sorted l = true).
      + destruct l.
        ** simpl in H. unfold andb in H. remember (match l with | Cons y _ => if sorted l then leq n1 y else false
      | Nil => true end). destruct b.
          *** simpl. unfold andb. rewrite <- Heqb. reflexivity.
          *** inversion H.
        ** reflexivity.
      + remember (insort n l) as li. destruct li.
        ** apply lem3. apply IHl. assumption.
        assert ((sorted (Cons n1 li)) = true).
        ** apply IHl. apply H0.
        ** assert (leq n0 n1 = true).
           *** inversion H1. remember (leq n0 n1). destruct b.
              ++ rewrite H3. reflexivity.
              ++ destruct li.
                +++ rewrite H3.
        remember (sorted (Cons n1 li)) as r1.
        remember (leq n0 n1) as r2.
        destruct andb.
        ** reflexivity.
        **
        ** simpl. simpl in IHl. unfold andb.
           remember (match li with
  | Cons y _ => if sorted li then leq n1 y else false
  | Nil => true
  end). destruct b.
          *** *)
Admitted.

Theorem theorem0 : forall (x : lst), eq (sorted (sort x)) true.
Proof.
induction x.
  - simpl. apply lem. apply IHx.
  - reflexivity.
Qed.


From ExtensibleCompiler.Theory Require Import
     IndexedFunctor
.

Declare Scope IndexedSum1.
Delimit Scope IndexedSum1 with IndexedSum1.
Open Scope IndexedSum1.

Variant IndexedSum1 I (F G : I-indexedPropFunctor) (A : I-indexedProp) (i : I) : Prop :=
| iinl1 : F A i -> (F + G)%IndexedSum1 A i
| iinr1 : G A i -> (F + G)%IndexedSum1 A i
where "F + G" := (IndexedSum1 _ F G) : IndexedSum1.
Arguments iinl1 {I F G A i}.
Arguments iinr1 {I F G A i}.

Global Instance IndexedFunctorSum1
       {I} {F G : I-indexedPropFunctor} `{IndexedFunctor I F} `{IndexedFunctor I G}
  : IndexedFunctor I (F + G)
  | 0 :=
  {|
    indexedFmap
    := fun A B i f fg =>
         match fg with
         | iinl1 fa => iinl1 (indexedFmap i f fa)
         | iinr1 ga => iinr1 (indexedFmap i f ga)
         end;
  |}.

Definition indexedSum1Dispatch
           {I} {A : I -> Prop} {L R : I-indexedPropFunctor} {O : I -> Prop} {i}
           (fl : L A i -> O i) (fr : R A i -> O i) v :=
  match v with
  | iinl1 l => fl l
  | iinr1 r => fr r
  end.

Notation "f || g" := (indexedSum1Dispatch f g) : IndexedSum1.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable lt_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable proposition_06a_1 : (forall A B C : Universe, ((triangle_ A B C /\ congA_ A B C A C B) -> ~(lt_ A C A B))).
Variable deftriangle_2 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_3 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable lemma_collinearorder_4 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_equalanglessymmetric_5 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_angledistinct_6 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> (A <> B /\ (B <> C /\ (A <> C /\ (Xa <> Xb /\ (Xb <> Xc /\ Xa <> Xc))))))).
Variable lemma_trichotomy1_7 : (forall A B C D : Universe, ((~(lt_ A B C D) /\ (~(lt_ C D A B) /\ (A <> B /\ C <> D))) -> cong_ A B C D)).

Theorem proposition_06_8 : (forall A B C : Universe, ((triangle_ A B C /\ congA_ A B C A C B) -> cong_ A B A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Lists.List.
Require Import Coq.Strings.String.

Require Export SystemFR.Trees.
Require Export SystemFR.Syntax.
Require Export SystemFR.Tactics.

Inductive base_type: nat -> tree -> tree -> Prop :=
| BTNat: forall X, base_type X T_nat T_nat
| BTUnit: forall X, base_type X T_unit T_unit
| BTBool: forall X, base_type X T_bool T_bool
| BTSum:
    forall X A B A0 B0,
      base_type X A A0 ->
      base_type X B B0 ->
      base_type X (T_sum A B) (T_sum A0 B0)
| BTProd:
    forall X A B A0 B0,
      base_type X A A0 ->
      base_type X B B0 ->
      base_type X (T_prod A B) (T_prod A0 B0)
| BTId:
    forall X A,
      ~(X ∈ pfv A type_var) ->
      is_erased_type A ->
      base_type X A A
| BTApprox:
    forall X A,
      (* X ∈ pfv A type_var -> *)
      (* We use this rule only when X belongs to pfv A type_var, but this extra assumption is
         not needed for the BaseTypeLemmas proofs *)
      base_type X A T_top.

#[export]
Hint Constructors base_type: c_base_type.