Require Import
  Coq.MSets.MSetInterface Coq.MSets.MSetFacts Coq.MSets.MSetProperties
  MathClasses.implementations.list MathClasses.implementations.list_finite_set MathClasses.theory.finite_sets
  MathClasses.interfaces.finite_sets MathClasses.interfaces.orders MathClasses.interfaces.abstract_algebra.

Module MSet_FSet (E : DecidableType) (Import set : WSetsOn E).

Module facts := WFactsOn E set.
Module props := WPropertiesOn E set.

Instance mset: SetType elt := t.

Instance mset_in: SetContains elt := In.
Instance mset_car_eq: Equiv elt := E.eq.
Instance mset_eq: SetEquiv elt := Equal.
Instance mset_le: SetLe elt := Subset.

Instance mset_singleton: SetSingleton elt := singleton.
Instance mset_empty: EmptySet elt := empty.
Instance mset_join: SetJoin elt := union.
Instance mset_meet: SetMeet elt := inter.
Instance mset_difference: SetDifference elt := diff.

Instance mset_car_dec: ∀ x y : elt, Decision (x = y) := E.eq_dec.
Instance mset_dec: ∀ x y : t, Decision (x = y) := eq_dec.

Local Instance: Setoid elt.
Proof. split; try apply _. Qed.

Local Instance: BoundedJoinSemiLattice mset.
Proof.
  Local Opaque Equal.
  repeat (split; try apply _); repeat intro.
      symmetry. now apply props.union_assoc.
     now apply props.empty_union_1, empty_spec.
    now apply props.empty_union_2, empty_spec.
   now apply props.union_sym.
  apply props.union_subset_equal, props.subset_refl.
  Local Transparent Equal.
Qed.

Local Instance: Setoid_Morphism singleton.
Proof. split; try apply _. Qed.

Definition to_listset (X : @set_type _ mset) : @set_type _ (listset elt)
  := props.to_list X↾elements_spec2w X.
Instance from_listset: Inverse to_listset := λ l, props.of_list (`l).

Local Instance: Setoid_Morphism to_listset.
Proof.
  split; try apply _. intros X Y E x.
  change (InA E.eq x (props.to_list X) ↔ InA E.eq x (props.to_list Y)).
  now rewrite <-!props.of_list_1, 2!props.of_list_3, E.
Qed.

Instance: Bijective to_listset.
Proof.
  split; split; try apply _.
   intros X Y E x. rewrite <-!elements_spec1. now apply E.
  intros ?? E. rewrite <-E. now rapply props.of_list_2.
Qed.

Instance: BoundedJoinSemiLattice_Morphism to_listset.
Proof.
  split; try apply _; split; try apply _.
   split; try apply _. intros X Y z.
   setoid_rewrite listset_in_join.
   repeat setoid_rewrite elements_spec1.
   apply union_spec.
  intros z. compute. rewrite props.elements_empty. tauto.
Qed.

Instance mset_extend: FSetExtend elt := iso_is_fset_extend id to_listset.

Local Instance: FSet elt.
Proof.
  apply (iso_is_fset id to_listset).
  intros x y E z.
  change (InA E.eq z (elements (singleton x)) ↔ InA E.eq z [y]).
  now rewrite elements_spec1, singleton_spec, E, InA_singleton.
Qed.

Instance: FullFSet elt.
Proof.
  split; try apply _. split.
     apply lattices.alt_Build_JoinSemiLatticeOrder.
     intros X Y. split; intros E.
      now apply props.union_subset_equal.
     rewrite <-E. now apply props.union_subset_1.
    intros x X. split; intros E.
     transitivity (add x empty).
      now apply props.subset_equal, props.singleton_equal_add.
     apply props.subset_add_3. auto. now apply props.subset_empty.
    apply props.union_subset_equal in E. rewrite <-E.
    now apply facts.union_2, singleton_spec.
   now apply inter_spec.
  now apply diff_spec.
Qed.
End MSet_FSet.


Require Import ZArith.
Require Import QArith.
Require Import Toy.CC.usl.implementation.
Require Import Toy.CC.lib.
Require Import Toy.CC.type.
Require Import Toy.CC.Language.
Import T.
Import Denote_Aexp Denote_Bexp Denote_Term Denote_Assertion_D Denote_Com.

Module Assertion_Shallow.
Import Denote_Aexp.
Import Denote_Bexp.
Import Denote_Com.

Definition exp {A : Type} (P : A -> Assertion) : Assertion := fun st => exists a, P a st.

Definition inj (b : bexp) : Assertion := fun st => true_set (beval b) st.

Definition eqp (a : aexp) (v : Z) : Assertion := fun st => (aeval a) st = Some v.

Definition safea (a : aexp) : Assertion := fun st => ~ (aeval a) st = None.

Definition safeb (b : bexp) : Assertion := fun st => ~ error_set (beval b) st.

Definition mapsto_ (p : addr) (pi : Q) : Assertion := fun st => (exists v, snd st p = Some (inl (pi, v))) /\ (forall p', p' <> p -> snd st p' = None).

Definition mapsto (p : addr) (pi : Q) (v : Z) : Assertion := fun st => snd st p = Some (inl (pi, v)) /\ (forall p', p' <> p -> snd st p' = None).

Definition derives : Assertion -> Assertion -> Prop := fun P Q => forall st, P st -> Q st.

Definition store_update (s : store) (X : var) (v : option Z) : store :=
  match v with
  | Some n => fun Y => if (Nat.eq_dec Y X) then n else s Y
  | None => fun Y => 0
  end.

Definition subst (P : Assertion) (X : var) (v : Z) : Assertion :=
  fun st => P (store_update (fst st) X (Some v), snd st).

Definition heap_update (h : heap) (p : addr) (v : option Z) : heap :=
  match v with
  | Some n => fun p' => if (Z.eq_dec p' p) then match h p' with
    | Some (inl (q, z)) => Some (inl (q, n))
    | _ => None
  end else h p'
  | _ => fun p' => None
  end.

Definition hasLock (L : addr) (pi : Q) (R : Assertion_D) : Assertion :=
  fun st => snd st L = Some (inr (pi, None, R)) /\ (forall p, p <> L -> snd st p = None).

Definition readytoRelease (L : addr) (pi : Q) (R : Assertion_D) : Assertion :=
  fun st => snd st L = Some (inr (pi, Some tt, R)) /\ (forall p, p <> L -> snd st p = None).

End Assertion_Shallow.

Module Validity.
Import Assertion_Shallow.
Import Denote_Com.

Definition valid (P : Assertion) (c : com) (Q Rb Rc : Assertion) : Prop :=
  forall st1 st2, P st1 ->
    (~ com_error (ceval c) st1) /\
    (com_normal (ceval c) st1 st2 -> Q st2) /\
    (com_break (ceval c) st1 st2 -> Rb st2) /\
    (com_cont (ceval c) st1 st2 -> Rc st2).

End Validity.

Module Deep_Shallow.

Definition DeepintoShallow (P : Assertion_D) : Assertion :=
  fun st => Assertion_Denote P st.

End Deep_Shallow.

Module tactics.
Import Assertion_Shallow.

Ltac ufsepcon := unfold sepcon; unfold SepCon.
Ltac ufSepcon H := unfold sepcon in H; unfold SepCon in H.
Ltac ufstatej := unfold stateJ; unfold OSAGenerators.prod_Join; unfold SeparationAlgebra.join.
Ltac ufStatej H := unfold stateJ in H; unfold OSAGenerators.prod_Join in H; unfold SeparationAlgebra.join in H.
Ltac ufstorej := unfold storeJ; unfold OSAGenerators.equiv_Join.
Ltac ufStorej H := unfold storeJ in H; unfold OSAGenerators.equiv_Join in H.
Ltac ufheapj := unfold heapJ; unfold OSAGenerators.fun_Join; unfold SeparationAlgebra.join; unfold OSAGenerators.option_Join.
Ltac ufHeapj H := unfold heapJ in H; unfold OSAGenerators.fun_Join in H; unfold SeparationAlgebra.join in H; unfold OSAGenerators.option_Join in H.

(* Lemma heapoptionj : forall (st st1 st2 : state) (x : addr),
@OSAGenerators.option_join (Q * Z + Q * option unit * Assertion_D) QZandLock_Join
(snd st1 x) (snd st2 x) (snd st x) <->
  (snd st1 x = None /\ snd st2 x = None /\ snd st x = None) \/
  (exists v, snd st1 x = Some v /\ snd st2 x = None /\ snd st x = Some v) \/
  (exists v, snd st1 x = None /\ snd st2 x = Some v /\ snd st x = Some v) \/
  (exists v1 v2 v, snd st1 x = Some v1 /\ snd st2 x = Some v2 /\ snd st x = Some v /\ QZandLock_Join v1 v2 v).
Proof.
  unfold iff. split.
  + intros.
    destruct H.
    - tauto.
    - right. right. left. exists a. tauto.
    - right. left. exists a. tauto.
    - right. right. right. exists a, b, c. tauto.
  + intros.
    destruct H as [? | [? | [? | ?]]].
    - destruct H as [? [? ?]]. rewrite H, H0, H1. constructor.
    - destruct H as [v [? [? ?]]]. rewrite H, H0, H1. constructor.
    - destruct H as [v [? [? ?]]]. rewrite H, H0, H1. constructor.
    - destruct H as [v1 [v2 [v [? [? [? ?]]]]]].
      rewrite H, H0, H1. constructor. tauto.
Qed. *)

Lemma ufoptionj : forall {A : Type} (J : SeparationAlgebra.Join A) (a1 a2 a : option A) ,
  @OSAGenerators.option_join A J a1 a2 a <->
  (a1 = None /\ a2 = None /\ a = None) \/
  (exists v, a1 = None /\ a2 = Some v /\ a = Some v) \/
  (exists v, a1 = Some v /\ a2 = None /\ a = Some v) \/
  (exists v1 v2 v, a1 = Some v1 /\ a2 = Some v2 /\ a = Some v /\ J v1 v2 v).
Proof.
  unfold iff; split; intros.
  + destruct H.
    - left; tauto.
    - right; left; exists a; tauto.
    - right; right; left; exists a; tauto.
    - right; right; right. exists a,b,c; tauto.
  + destruct H as [? | [? | [? | ?]]].
    - destruct H as [? [? ?]]. rewrite H, H0, H1; constructor.
    - destruct H as [v [? [? ?]]]. rewrite H, H0, H1; constructor.
    - destruct H as [v [? [? ?]]]. rewrite H, H0, H1; constructor.
    - destruct H as [v1 [v2 [v [? [? [? ?]]]]]].
      rewrite H, H0, H1; constructor; tauto.
Qed.

Lemma ufsumj : forall {A B : Type} (J1 : SeparationAlgebra.Join A) (J2 : SeparationAlgebra.Join B) (a1 a2 a : A + B),
  @OSAGenerators.sum_join A B J1 J2 a1 a2 a <->
  (exists al1 al2 al, a1 = inl al1 /\ a2 = inl al2 /\ a = inl al /\ J1 al1 al2 al) \/
  (exists ar1 ar2 ar, a1 = inr ar1 /\ a2 = inr ar2 /\ a = inr ar /\ J2 ar1 ar2 ar).
Proof.
  unfold iff; split; intros.
  + destruct H.
    - left; exists a, b, c; tauto.
    - right; exists a, b, c; tauto.
  + destruct H.
    - destruct H as [al1 [al2 [al [? [? [? ?]]]]]].
      rewrite H, H0, H1. constructor; tauto.
    - destruct H as [ar1 [ar2 [ar [? [? [? ?]]]]]].
      rewrite H, H0, H1. constructor; tauto.
Qed.

Goal forall x1 x2 x, QZandLock_Join x1 x2 x.
Proof.
  unfold QZandLock_Join.
  intros.
  rewrite ufsumj.
  left. exists (0.5%Q, 1), (0.5%Q, 1), (1%Q, 1).
  split; try split; try split. admit. admit. admit.
  unfold QZ_Join.
  unfold OSAGenerators.prod_Join.
  unfold SeparationAlgebra.join.
  unfold Q_Join, Z_Join.

Admitted.

End tactics.


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

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

Import WfExtensionality.

Lemma subtype_sel_equ_all_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_equ x1 L1 T1') ->
                  forall T2 T T', T2 = (t_all T T') ->
                             subtype T1 T2 = subtype T1' T2.
Proof.
  intros.

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

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


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

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

Print Assumptions carry.


(* The Operational Semantics *)

Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Program.

Require Import EqNat.

Require Import LiftedTypes.
Require Import MyReals.
Require Import Weights.
Require Import Measures.
Require Import Types.
Require Import Syntax.
Require Import Substitutions.

Inductive ev : forall {o: Otype}, Exp nil o -> Val nil o -> Prop :=
| ev_val : forall o (val: Val nil o), ev (valexp val) val
| ev_prod : forall {m m'} (e1 : Exp nil (Stype m)) (e2 : Exp nil (Stype m'))
                   v1 v2,
    ev e1 v1
    -> ev e2 v2
    -> ev (prodexp e1 e2) (prodval v1 v2)
| ev_proj1 : forall {m m'}
                    (e : Exp nil (Stype (Prod_type m m')))
                    v w,
    ev e (prodval v w) -> ev (proj1exp e) v

| ev_proj2 : forall {m m'}
                    (e : Exp nil (Stype (Prod_type m m')))
                    v w,
    ev e (prodval v w) -> ev (proj2exp e) w

| ev_app : forall o o' (e1 : Exp nil (Funtype o o'))
                  (e2 : Exp nil o)
                  e' v w,
    ev e1 (absexp e')
    -> ev e2 v
    -> ev (ap_Se (subst1 v) e') w
    -> ev (appexp e1 e2) w
| ev_bind : forall (o o': Mtype)
                   (e1 : Exp nil (Meastype o))
                   (c1 : Val nil (Meastype o))

                   (e2 : Exp nil (Funtype (Stype o)
                                          (Meastype o')))

                   (c2 : Val nil (Funtype (Stype o)
                                          (Meastype o'))),

    ev e1 c1 ->
    ev e2 c2 ->
    ev (bindexp e1 e2) (bindval c1 c2)
| ev_return : forall o
                     (e : Exp nil (Stype o))
                     (c : Val nil (Stype o)),
    ev e c ->
    ev (returnexp e) (returnval c).

(* these could be replaced by saying
   ev_val : forall {o} (e : /etc/) ...
 *)

Arguments ev_val {_} _.
Arguments ev_app {_ _ _ _ _ _ _} _ _ _.
Arguments ev_bind {_ _ _ _ _} _ _ _.
Arguments ev_return {_ _ _} _.

Inductive evs : forall {o: Mtype},
    Unit
    -> Val nil (Meastype o)
    -> Val nil (Stype o)
    -> Weight
    -> Prop :=
| evs_unif : forall {u},
               evs u (uniformval) (constexp (unit_real u)) one_weight
| evs_return : forall {o u} {c: Val nil (Stype o)},
                 evs u (returnval c) c one_weight
| evs_bind : forall {u a b}
                    {c1 : Val nil (Meastype a)}
                    {c2 : Val nil (Funtype (Stype a)(Meastype b))}
                    {c3 c4 c5 w1 w2},
               evs (left_half u) c1 c3 w1 ->
               ev (appexp (valexp c2) (valexp c3)) c4 ->
               evs (right_half u) c4 c5 w2 ->
               evs u (bindval c1 c2) c5 (prod_weights w1 w2)
| evs_dist : forall {p u},
    evs u
        (distval (constexp p))
        (constexp (unit_real u))
        (density_1 p (unit_real u)).

Hint Constructors ev.
Hint Constructors evs.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e521m1_17limbs.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.


(* -*- mode: coq; mode: visual-line -*-  *)
(** * Defining the natural numbers from univalence and propresizing. *)
Require Import Basics.
Require Import Types.
Require Import UnivalenceImpliesFunext.
Require Import HProp.
Require Import PropResizing.PropResizing.
Require Import PropResizing.ImpredicativeTruncation.
Local Open Scope path_scope.

(* Be careful about [Import]ing this file!  Usually you want to use the standard [Nat] instead. *)

(** Using propositional resizing and univalence, we can construct the natural numbers rather than defining them as an inductive type.  In concrete practice there is no reason we would want to do this, but semantically it means that an elementary (oo,1)-topos (unlike an elementary 1-topos) automatically has a natural numbers object. *)

Section AssumeStuff.
  Context {UA:Univalence} {PR:PropResizing}.

  (** The basic idea is that since the universe is closed under coproducts, it is already "infinite", so we can find the "smallest infininte set" N inside it.  To get rid of the automorphisms in the universe coming from univalence and make N a set, instead of the universe of types we consider graphs (we could use posets or many other things too; in fact the graphs we are interested in will be posets). *)

  (** Here is the readable definition of [Graph]:

  > Definition Graph := { V : Type & { E : V -> V -> Type & forall x y, IsHProp@{hp} (E x y) }}.

  However, to enable performance speedups by controlling universes, we write out its universe parameters explicitly, making it less readable.  Moreover, since here we will eventually only be interested in those graphs that represent natural numbers, it does no harm to fix these universes at the outset throughout the entire development. *)

  (** [s] : universe of the vertex and edge types
      [u] : universe of the graph type, morally [s+1] *)
  Universes s u.

  Definition Graph@{} := @sig@{u u} Type@{s} (fun V => @sig@{u u} (V -> V -> Type@{s}) (fun E => forall x y, IsHProp (E x y))).

  (** We also write out its constructors and fields explicitly to control their universes. *)
  Definition Build_Graph@{} (vert : Type@{s}) (edge : vert -> vert -> Type@{s})
             (ishprop_edge : forall x y, IsHProp (edge x y))
    : Graph
    := @exist@{u u} Type@{s} (fun V => @sig@{u u} (V -> V -> Type@{s}) (fun E => forall x y, IsHProp (E x y)))
             vert
             (@exist@{u u} (vert -> vert -> Type@{s}) (fun E => forall x y, IsHProp (E x y))
                    edge ishprop_edge).
  Definition vert@{} : Graph -> Type@{s} := pr1.
  Definition edge@{} (A : Graph) : vert A -> vert A -> Type@{s} := pr1 (pr2 A).
  Instance ishprop_edge@{} (A : Graph) (x y : vert A) : IsHProp (edge A x y)
    := pr2 (pr2 A) x y.
  (** We will need universe annotations in a few more places, but not many. *)

  Definition equiv_path_graph0 (A B : Graph)
    : { f : vert A <~> vert B &
            forall x y, edge A x y <-> edge B (f x) (f y) }
        <~> (A = B).
  Proof.
    srefine (equiv_path_sigma _ A B oE _).
    srefine (equiv_functor_sigma' (equiv_path_universe (vert A) (vert B)) _).
    intros f; cbn.
    rewrite transport_sigma.
    srefine (equiv_path_sigma_hprop _ _ oE _). cbn.
    srefine (equiv_path_forall _ _ oE _).
    srefine (equiv_functor_forall' (f^-1) _).
    intros x.
    srefine (equiv_path_forall _ _ oE _).
    srefine (equiv_functor_forall' (f^-1) _).
    intros y. cbn.
    rewrite transport_arrow.
    rewrite transport_arrow_toconst.
    rewrite !transport_path_universe_V.
    rewrite !eisretr.
    srefine (equiv_path_universe _ _ oE _).
    srefine (equiv_equiv_iff_hprop _ _).
  Qed.

  Definition equiv_path_graph@{} := ltac:(first[exact equiv_path_graph0@{u}|exact equiv_path_graph0]).

  (** N will be the set of graphs generated by the empty graph as
  "zero", and "adding a new top element" as "successor". *)
  Definition graph_zero@{} : Graph
    := Build_Graph Empty
                   (fun x y => @Empty_rec@{u} Type@{s} x)
                   (fun x y => Empty_rec x).

  Definition graph_succ@{} (A : Graph) : Graph.
  Proof.
    srefine (Build_Graph (sum@{s s} (vert A) Unit) _ _).
    - intros [x|x] [y|y].
      + exact (edge A x y).
      + exact Unit.
      + exact Empty.
      + exact Unit.
    - cbn; intros [x|x] [y|y]; exact _.
  Defined.

  (** The following lemmas about graphs will be used later on to prove
  the Peano axioms about N. *)

  Definition graph_succ_top@{} {A : Graph} (x : vert (graph_succ A))
    : edge (graph_succ A) x (inr tt).
  Proof.
    destruct x as [x|x]; exact tt.
  Qed.

  Definition graph_succ_top_unique@{}
             {A : Graph} (y : vert (graph_succ A))
             (yt : forall x, edge (graph_succ A) x y)
    : y = inr tt.
  Proof.
    destruct y as [y|[]].
    - destruct (yt (inr tt)).
    - reflexivity.
  Qed.

  Definition graph_succ_not_top@{} {A : Graph} (x : vert A)
    : ~(edge (graph_succ A) (inr tt) (inl x))
    := idmap.

  Definition graph_succ_not_top_unique@{} {A : Graph} (x : vert (graph_succ A))
             (xt : ~(edge (graph_succ A) (inr tt) x))
    : is_inl x.
  Proof.
    destruct x as [x|x].
    - exact tt.
    - destruct (xt tt).
  Qed.

  Section Graph_Succ_Equiv.
    Context {A B : Graph} (f : vert (graph_succ A) <~> vert (graph_succ B))
            (e : forall x y, edge (graph_succ A) x y <-> edge (graph_succ B) (f x) (f y)).

    Definition graph_succ_equiv_inr@{} : f (inr tt) = inr tt.
    Proof.
      apply (graph_succ_top_unique (f (inr tt))).
      intros x.
      rewrite <- (eisretr f x).
      apply (fst (e (f^-1 x) (inr tt))).
      apply graph_succ_top.
    Qed.

    Local Definition Ha@{} : forall x, is_inl (f (inl x)).
    Proof.
      intros x.
      apply graph_succ_not_top_unique.
      rewrite <- (eisretr f (inr tt)).
      intros ed.
      apply (snd (e (f^-1 (inr tt)) (inl x))) in ed.
      pose (finr := graph_succ_equiv_inr).
      apply moveL_equiv_V in finr.
      rewrite <- finr in ed.
      exact (graph_succ_not_top x ed).
    Qed.

    (* Coq bug: without the [:Unit] annotation some floating universe appears. *)
    Local Definition Hb@{} : forall x:Unit, is_inr (f (inr x)).
    Proof.
      destruct x.
      srefine (transport@{s Set} is_inr graph_succ_equiv_inr^ tt).
    Qed.

    Definition graph_unsucc_equiv_vert@{} : vert A <~> vert B
      := equiv_unfunctor_sum_l@{s s s s s  s Set Set Set Set}
                              f Ha Hb.

    Definition graph_unsucc_equiv_edge@{} (x y : vert A)
      : iff@{s s s} (edge A x y) (edge B (graph_unsucc_equiv_vert x) (graph_unsucc_equiv_vert y)).
    Proof.
      pose (h := e (inl x) (inl y)).
      rewrite <- (unfunctor_sum_l_beta f Ha x) in h.
      rewrite <- (unfunctor_sum_l_beta f Ha y) in h.
      exact h.
    Qed.

  End Graph_Succ_Equiv.

  Definition graph_succ_path_equiv0 (A B : Graph)
    : (A = B) <~> (graph_succ A = graph_succ B).
  Proof.
    refine ((equiv_path_graph _ _) oE _).
    refine (_ oE (equiv_path_graph _ _)^-1).
    srefine (equiv_adjointify _ _ _ _).
    - intros [f e].
      exists (f +E 1).
      intros x y.
      destruct x as [x|x]; destruct y as [y|y]; cbn.
      + apply e.
      + split; apply idmap.
      + split; apply idmap.
      + split; apply idmap.
    - intros [f e].
      exists (graph_unsucc_equiv_vert f e).
      exact (graph_unsucc_equiv_edge f e).
    - intros [f e].
      apply path_sigma_hprop; cbn.
      apply path_equiv, path_arrow; intros [x|[]]; cbn.
      + apply unfunctor_sum_l_beta.
      + symmetry; apply graph_succ_equiv_inr, e.
    - intros [f e].
      apply path_sigma_hprop; cbn.
      apply path_equiv, path_arrow; intros x; reflexivity.
  Defined.

  Definition graph_succ_path_equiv@{}
    := Eval unfold graph_succ_path_equiv0 in graph_succ_path_equiv0@{u}.

  Definition graph_unsucc_path@{} (A B : Graph)
    : (graph_succ A = graph_succ B) -> A = B
    := (graph_succ_path_equiv A B)^-1.

  (** Here is the impredicative definition of N, as the smallest
  subtype of [Graph] containing [graph_zero] and closed under
  [graph_succ]. *)
  Definition in_N@{p} (n : Graph)
    := forall (P : Graph -> Type@{p}),
           (forall A, IsHProp (P A))
           -> P graph_zero
           -> (forall A, P A -> P (graph_succ A))
           -> P n.

  Lemma ishprop_in_N0 (n : Graph) : IsHProp (in_N@{p} n).
  Proof.
    apply trunc_forall.
  Qed.

  Instance ishprop_in_N@{p sp} : forall n, IsHProp (in_N n)
    := ltac:(first [exact ishprop_in_N0@{sp p sp sp}|exact ishprop_in_N0@{sp p}]).

  (** [p] : universe of [N], morally [u+1] i.e. [s+2]. *)
  Universe p.
  Definition N@{} : Type@{p}
    := @sig@{u p} Graph in_N@{u}.

  Definition path_N@{} (n m : N) : n.1 = m.1 -> n = m
    := path_sigma_hprop@{u p p} n m.

  Definition zero@{} : N.
  Proof.
    exists graph_zero.
    intros P PH P0 Ps; exact P0.
  Defined.

  Definition succ@{} : N -> N.
  Proof.
    intros [n nrec].
    exists (graph_succ n).
    intros P PH P0 Ps. apply Ps.
    exact (nrec P PH P0 Ps).
  Defined.

  (** First Peano axiom: successor is injective *)
  Definition succ_inj@{} (n m : N) (p : succ n = succ m) : n = m.
  Proof.
    apply path_N.
    apply ((graph_succ_path_equiv n.1 m.1)^-1).
    exact (p..1).
  Qed.

  (** A slightly more general version of the theorem that N is a set,
  which will be useful later. *)
  Lemma ishprop_path_graph_in_N@{} (A B : Graph) (Arec : in_N@{u} A) : IsHProp (A = B).
  Proof.
    apply hprop_inhabited_contr; intros [].
    apply Arec; try exact _.
    - apply contr_inhabited_hprop; try exact 1.
      apply hprop_allpath.
      equiv_intro (equiv_path_graph graph_zero graph_zero) fe.
      destruct fe as [f e].
      equiv_intro (equiv_path_graph graph_zero graph_zero) fe'.
      destruct fe' as [f' e'].
      apply equiv_ap; try exact _.
      apply path_sigma_hprop, path_equiv@{s s s u}, path_arrow.
      intros [].
    - clear B;intros B BC.
      refine (contr_equiv (B = B) (graph_succ_path_equiv B B)).
  Qed.

  Instance ishprop_path_N@{} (n : N) (A : Graph) : IsHProp (n.1 = A).
  Proof.
    apply ishprop_path_graph_in_N, pr2.
  Qed.

  Instance ishset_N@{} : IsHSet N.
  Proof.
    intros n m.
    change (IsHProp (n = m)).
    refine (trunc_equiv (n.1 = m.1) (equiv_path_sigma_hprop n m)).
  Qed.

  Definition graph_zero_neq_succ@{} {A : Graph}
    : graph_zero <> graph_succ A.
  Proof.
    intros p.
    destruct ((equiv_path_graph graph_zero (graph_succ A))^-1 p) as [f e].
    exact (f^-1 (inr tt)).
  Qed.

  (** Second Peano axiom: zero is not a successor *)
  Definition zero_neq_succ@{} (n : N) : zero <> succ n.
  Proof.
    intros p; apply pr1_path in p; refine (graph_zero_neq_succ p).
  Qed.

  (** This tweak is sometimes necessary to avoid universe inconsistency.
  It's how the impredicativity of propositional resizing enters. *)
  Definition resize_nrec@{p0 p1} (n : Graph) (nrec : in_N@{p0} n)
    : in_N@{p1} n.
  Proof.
    intros P' PH' P0' Ps'.
    srefine ((equiv_resize_hprop (P' n))^-1
             (nrec (fun A => resize_hprop (P' A)) _ _ _));
      try exact _; cbn.
    - exact (equiv_resize_hprop (P' graph_zero) P0').
    - intros A P'A.
      exact (equiv_resize_hprop (P' (graph_succ A))
                                (Ps' A ((equiv_resize_hprop (P' A))^-1 P'A))).
  Qed.

  Local Instance ishprop_graph_zero_or_succ@{} : forall n : Graph,
      IsHProp ((n = graph_zero) + { m : N & n = graph_succ m.1 }).
  Proof.
    intros n. apply ishprop_sum@{p u p}.
    - apply (@trunc_equiv' _ _ (equiv_path_inverse _ _)),ishprop_path_graph_in_N.
      exact zero.2.
    - apply @ishprop_sigma_disjoint.
      + intros m;apply (@trunc_equiv' _ _ (equiv_path_inverse _ _)).
        apply ishprop_path_graph_in_N. exact ((succ m).2).
      + intros x y ex ey.
        apply succ_inj, path_N. path_via n.
    - intros e0 [m es].
      apply zero_neq_succ with m, path_N. path_via n.
  Qed.

  Local Instance ishprop_N_zero_or_succ@{} : forall n : N,
      IsHProp ((n = zero) + { m : N & n = succ m }).
  Proof.
    intros n. apply ishprop_sum.
    - exact _.
    - apply ishprop_sigma_disjoint. intros x y ex ey.
      apply succ_inj;path_via n.
    - intros e0 [m es].
      apply zero_neq_succ with m. path_via n.
  Qed.

  Definition N_zero_or_succ@{} (n : N)
    : (n = zero) + { m : N & n = succ m }.
  Proof.
    apply (functor_sum (path_N _ _)
                       (functor_sigma (Q := fun m:N => n = succ m) idmap (fun m => path_N _ (succ m)))).
    destruct n as [n nrec]; cbn.
    srefine (resize_nrec n nrec
             (fun n => (n = graph_zero) +
                    {m : N & n = graph_succ m.1}) _ _ _); cbn.
    - apply inl; reflexivity.
    - intros A [A0|[m As]]; apply inr.
      + exists zero.
        rewrite A0.
        reflexivity.
      + exists (succ m).
        rewrite As.
        reflexivity.
  Qed.

  Definition pred_in_N@{} (n : Graph) (snrec : in_N@{u} (graph_succ n))
    : in_N@{u} n.
  Proof.
    destruct (N_zero_or_succ (graph_succ n ; snrec)) as [H0|[m Hs]].
    - apply pr1_path in H0; cbn in H0.
      destruct (graph_zero_neq_succ H0^).
    - apply pr1_path in Hs.
      apply graph_unsucc_path in Hs.
      apply (transport@{u p} in_N Hs^).
      exact m.2.
  Qed.

  (** Final Peano axiom: induction *)
  Definition N_propind0 (P : N -> Type) `{forall n, IsHProp (P n)}
             (P0 : P zero) (Ps : forall n, P n -> P (succ n))
    : forall n, P n.
  Proof.
    intros [n nrec].
    pose (Q := fun m:Graph => forall (mrec : in_N m), P (m;mrec)).
    refine (resize_nrec n nrec Q _ _ _ nrec);clear n nrec.
    - intros A; apply trunc_forall.
    - intros zrec.
      refine (transport P _ P0).
      apply ap.
      apply path_ishprop.
    - intros A QA Asrec.
      pose (m := (A ; pred_in_N A Asrec) : N).
      refine (transport P _ (Ps m (QA (pred_in_N A Asrec)))).
      apply path_N; reflexivity.
  Qed.

  (** Sometimes we just need a bigger fish. *)
  Universe large.

  (** Importantly, however, the universe of the motive [P] is not
      constrained but can be arbitrary. *)
  Definition N_propind@{P}  (P : N -> Type@{P}) `{forall n, IsHProp (P n)}
             (P0 : P zero) (Ps : forall n, P n -> P (succ n))
    : forall n, P n
    := ltac:(first [exact (N_propind0@{P large large large} P P0 Ps)|
                    exact (N_propind0@{P} P P0 Ps)]).

  (** A first application *)
  Definition N_neq_succ@{} (n : N) : n <> succ n.
  Proof.
    revert n; apply N_propind@{p}.
    - intros n;exact trunc_arrow@{p p p}.
    - apply zero_neq_succ.
    - intros n H e.
      apply H.
      exact (succ_inj n (succ n) e).
  Qed.

  (** Now we want to use induction to define recursion.  The basic
  idea is the same as always: define partial attempts and show by
  induction that they are uniquely defined.  But we have to be careful
  to phrase it in a way that works without assuming any truncation
  restritions on the codomain.

  First we need inequality on N, which we define in terms of addition.
  Normally addition is defined *using* recursion, but here we can
  "cheat" because we know how to add graphs, and then prove that it
  satisfies the recursive equations for addition. *)
  Definition graph_add0 (A B : Graph) : Graph.
  Proof.
    exists (vert A + vert B).
    exists (fun ab ab' =>
              match ab, ab' return Type@{s} with
              | inl a, inl a' => edge A a a'
              | inl a, inr b => Unit
              | inr b, inl a => Empty
              | inr b, inr b' => edge B b b'
              end).
    intros [a|b] [a'|b']; exact _.
  Defined.

  (* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *)
  Definition graph_add@{} : Graph -> Graph -> Graph
    := Eval unfold graph_add0 in ltac:(first [exact graph_add0|exact graph_add0@{s s}]).

  Definition graph_add_zero_r@{} (A : Graph) : graph_add A graph_zero = A.
  Proof.
    apply equiv_path_graph.
    exists (sum_empty_r (vert A)).
    intros [x|[]] [y|[]].
    apply iff_reflexive@{u s}.
  Qed.

  Definition graph_add_zero_l@{} (A : Graph) : graph_add graph_zero A = A.
  Proof.
    apply equiv_path_graph.
    exists (sum_empty_l (vert A)).
    intros [[]|x] [[]|y].
    apply iff_reflexive@{u s}.
  Qed.

  Definition graph_add_succ@{} (A B : Graph)
    : graph_add A (graph_succ B) = graph_succ (graph_add A B).
  Proof.
    apply equiv_path_graph.
    exists (equiv_inverse (equiv_sum_assoc (vert A) (vert B) Unit)).
    intros [x|[x|[]]] [y|[y|[]]];apply iff_reflexive@{u s}.
  Qed.

  Definition graph_add_assoc@{} (A B C : Graph)
    : graph_add (graph_add A B) C = graph_add A (graph_add B C).
  Proof.
    apply equiv_path_graph.
    exists (equiv_sum_assoc _ _ _).
    intros [[x|x]|x] [[y|y]|y]; apply iff_reflexive@{u s}.
  Qed.

  Definition graph_one@{} : Graph
    := Build_Graph Unit (fun _ _ : Unit => Unit) _.

  Definition graph_add_one_succ@{} (A : Graph)
    : graph_add A graph_one = graph_succ A.
  Proof.
    apply equiv_path_graph.
    exists equiv_idmap.
    intros [x|[]] [y|[]]; apply iff_reflexive@{u s}.
  Qed.

  Definition graph_succ_zero@{} : graph_succ graph_zero = graph_one.
  Proof.
    rewrite <- graph_add_one_succ.
    apply graph_add_zero_l.
  Qed.

  Definition one@{} : N.
  Proof.
    exists graph_one.
    intros P PH P0 Ps.
    rewrite <- graph_succ_zero.
    apply Ps, P0.
  Defined.

  Definition N_add@{} (n m : N) : N.
  Proof.
    exists (graph_add n.1 m.1).
    intros P PH P0 Ps.
    apply m.2.
    - intros; apply PH.
    - apply (transport P (graph_add_zero_r n.1)^).
      exact (n.2 P PH P0 Ps).
    - intros A PA.
      apply (transport P (graph_add_succ n.1 A)^).
      apply Ps, PA.
  Defined.

  Notation "n + m" := (N_add n m).

  Definition N_add_zero_l@{} (n : N) : zero + n = n.
  Proof.
    apply path_N, graph_add_zero_l.
  Qed.

  Definition N_add_zero_r@{} (n : N) : n + zero = n.
  Proof.
    apply path_N, graph_add_zero_r.
  Qed.

  Definition N_add_succ@{} (n m : N) : n + succ m = succ (n + m).
  Proof.
    apply path_N, graph_add_succ.
  Qed.

  Definition N_add_assoc@{} (n m k : N) : (n + m) + k = n + (m + k).
  Proof.
    apply path_N, graph_add_assoc.
  Qed.

  Definition N_add_cancel_r@{} (n m k : N) (H : n + k = m + k)
    : n = m.
  Proof.
    revert k H.
    refine (N_propind _ _ _).
    - intros H; rewrite !N_add_zero_r in H; exact H.
    - intros k H1 H2.
      rewrite !N_add_succ in H2.
      apply H1.
      exact (succ_inj _ _ H2).
  Qed.

  Definition N_add_cancel_zero_r@{} (n k : N) (H : k + n = n)
    : k = zero.
  Proof.
    refine (N_add_cancel_r k zero n _).
    rewrite H; symmetry.
    apply path_N, graph_add_zero_l.
  Qed.

  Definition N_add_one_r@{} (n : N) : n + one = succ n.
  Proof.
    apply path_N; cbn.
    apply graph_add_one_succ.
  Qed.

  Definition N_add_one_l@{} (n : N) : one + n = succ n.
  Proof.
    revert n; refine (N_propind (fun m => one + m = succ m) _ _).
    - rewrite N_add_zero_r.
      apply path_N.
      symmetry; apply graph_succ_zero.
    - intros n H.
      rewrite N_add_succ.
      apply ap, H.
  Qed.

  Definition N_add_succ_l@{} (n m : N) : succ n + m = succ (n + m).
  Proof.
    rewrite <- (N_add_one_r n).
    rewrite N_add_assoc.
    rewrite N_add_one_l.
    apply N_add_succ.
  Qed.

  (** Now we define inequality in terms of addition. *)
  Definition N_le@{} (n m : N) : Type@{p}
    := { k : N & k + n = m }.

  Notation "n <= m" := (N_le n m).

  Local Instance ishprop_N_le@{} n m : IsHProp (n <= m).
  Proof.
    apply ishprop_sigma_disjoint.
    intros x y e1 e2.
    apply N_add_cancel_r with n. path_via m.
  Qed.

  Definition N_zero_le@{} (n : N) : zero <= n.
  Proof.
    exists n.
    apply N_add_zero_r.
  Qed.

  Definition N_le_zero@{} (n : N) (H : n <= zero) : n = zero.
  Proof.
    destruct H as [k H].
    apply pr1_path in H.
    apply ((equiv_path_graph _ _)^-1), pr1 in H.
    pose proof ((fun x => H (inr x)) : (vert n.1) -> Empty) as f.
    apply path_N, equiv_path_graph.
    srefine ((Build_Equiv _ _ f _);_); cbn.
    intros x y; destruct (f x).
  Qed.

  Instance contr_le_zero@{} : Contr {n:N & n <= zero}.
  Proof.
    exists (existT (fun n => n <= zero) zero (N_zero_le zero)).
    intros [n H].
    apply path_sigma_hprop.
    exact (N_le_zero n H)^.
  Qed.

  Instance reflexive_N_le@{} : Reflexive N_le.
  Proof.
    intros n.
    exists zero.
    apply N_add_zero_l.
  Qed.

  Definition N_lt@{} (n m : N) : Type@{p}
    := { k : N & (succ k) + n = m }.

  Notation "n < m" := (N_lt n m).

  Lemma ishprop_N_lt@{} n m : IsHProp (n < m).
  Proof.
    apply ishprop_sigma_disjoint.
    intros x y e1 e2.
    apply N_add_cancel_r with (succ n).
    rewrite !N_add_succ, <-!N_add_succ_l.
    path_via m.
  Qed.
  Local Existing Instance ishprop_N_lt.

  Definition N_lt_zero@{} (n : N) : ~(n < zero).
  Proof.
    unfold N_lt; intros [k H].
    apply pr1_path, (equiv_path_graph _ _)^-1, pr1 in H.
    exact (H (inl (inr tt))).
  Qed.

  Definition N_lt_irref@{} (n : N) : ~(n < n).
  Proof.
    revert n; apply N_propind@{p}.
    - intros n;exact trunc_arrow@{p p p}.
    - apply N_lt_zero.
    - intros n H [k K].
      apply H; exists k.
      rewrite N_add_succ in K.
      apply succ_inj; assumption.
  Qed.

  Definition N_le_eq_or_lt@{} (n m : N) (H : n <= m)
    : (n = m) + (n < m).
  Proof.
    assert (HP : IsHProp ((n = m) + (n < m))).
    { apply ishprop_sum; try exact _.
      intros [] [l K].
      apply N_add_cancel_zero_r in K.
      symmetry in K; apply zero_neq_succ in K; assumption. }
    destruct H as [k K].
    destruct (N_zero_or_succ k) as [k0|[l L]].
    - rewrite k0 in K.
      rewrite (N_add_zero_l n) in K.
      exact (inl K).
    - rewrite L in K.
      exact (inr (l;K)).
  Qed.

  Definition N_succ_nlt@{} (n : N) : ~(succ n < n).
  Proof.
    revert n; apply N_propind@{p}.
    - intros n;exact trunc_arrow@{p p p}.
    - apply N_lt_zero.
    - intros n H L.
      apply H; clear H.
      destruct L as [k H].
      exists k.
      rewrite N_add_succ in H.
      exact (succ_inj _ _ H).
  Qed.

  Definition N_lt_succ@{} (n : N) : n < succ n.
  Proof.
    exists zero.
    rewrite N_add_succ_l.
    apply ap, N_add_zero_l.
  Qed.

  Definition N_succ_lt@{} (n m : N) (H : n < m) : succ n < succ m.
  Proof.
    destruct H as [k H].
    exists k.
    rewrite N_add_succ.
    apply ap; assumption.
  Qed.

  Definition N_lt_le@{} (n m : N) (H : n < m) : n <= m.
  Proof.
    destruct H as [k K].
    exact (succ k; K).
  Qed.

  Definition N_lt_iff_succ_le@{} (n m : N) :
    (n < m) <-> (succ n <= m).
  Proof.
    split; intros [k H]; exists k.
    - rewrite N_add_succ, <- N_add_succ_l.
      assumption.
    - rewrite N_add_succ_l, <- N_add_succ.
      assumption.
  Qed.

  Definition N_lt_succ_iff_le@{} (n m : N) : (n < succ m) <-> (n <= m).
  Proof.
    split; intros [k H]; exists k.
    - rewrite N_add_succ_l in H.
      exact (succ_inj _ _ H).
    - rewrite N_add_succ_l; apply ap, H.
  Qed.

  Definition equiv_N_segment@{} (n : N)
    : { m : N & m <= n } <~> (sum@{p p} {m : N & m < n} Unit).
  Proof.
    srefine (equiv_adjointify _ _ _ _).
    - intros mH.
      destruct (N_le_eq_or_lt mH.1 n mH.2) as [H0|Hs].
      + exact (inr tt).
      + exact (inl (mH.1;Hs)).
    - intros [mH|?].
      + exact (mH.1; N_lt_le mH.1 n mH.2).
      + exists n; reflexivity.
    - abstract (intros [[m H]|[]]; cbn;
      [ generalize (N_le_eq_or_lt m n (N_lt_le m n H));
        intros [H0|Hs]; cbn;
        [ apply Empty_rec;
          rewrite H0 in H; exact (N_lt_irref n H)
        | apply ap, ap, path_ishprop ]
      | generalize (N_le_eq_or_lt n n (reflexive_N_le n));
        intros [H0|Hs];
        [ reflexivity
        | apply Empty_rec;
          exact (N_lt_irref n Hs) ]]).
    - abstract (intros [m H]; cbn;
      generalize (N_le_eq_or_lt m n H);
      intros [H0|Hs]; cbn;
      [ apply path_sigma_hprop;
        symmetry; assumption
      | apply ap, path_ishprop ]).
  Defined.

  Definition equiv_N_segment_succ@{} (n : N)
    : { m : N & m <= succ n } <~> @sum@{p p} {m : N & m <= n} Unit.
  Proof.
    refine (_ oE equiv_N_segment (succ n)).
    apply equiv_functor_sum_r.
    apply equiv_functor_sigma_id.
    intros m; apply equiv_iff_hprop_uncurried, N_lt_succ_iff_le.
  Defined.

  (** A fancy name for [1] so that we can [rewrite] with it later. *)
  Definition equiv_N_segment_succ_inv_inl@{} (n : N) (mh : {m:N & m <= n})
    : ((equiv_N_segment_succ n)^-1 (inl mh)).1 = mh.1.
  Proof.
    reflexivity.
  Qed.

  Definition equiv_N_segment_lt_succ@{} (n : N)
    : { m : N & m < succ n } <~> {m : N & m <= n}.
  Proof.
    apply equiv_functor_sigma_id.
    intros; apply equiv_iff_hprop; apply N_lt_succ_iff_le.
  Defined.

  Definition zero_seg@{} (n : N) : { m : N & m <= n }
    := (zero ; N_zero_le n).

  Definition succ_seg@{} (n : N)
    : { m : N & m < n } -> { m : N & m <= n }
    := fun mh =>
         let (m,H) := mh in
         (succ m; fst (N_lt_iff_succ_le m n) H).

  Definition refl_seg@{} (n : N) : {m : N & m <= n}.
  Proof.
    exists n.
    reflexivity.
  Defined.

  (** Now we're finally ready to prove recursion. *)
  Section NRec.
    (** Here is the type we will recurse into.  Importantly, it
    doesn't have to be a set! *)
    (** [nr] is the universe of [partial_Nrec], morally [max(p,x)].
        Note that it shouldn't be [large], see constraints on [contr_partial_Nrec_zero]. *)
    Universe x nr.
    Context (X : Type@{x}) (x0 : X) (xs : X -> X).

    (** The type of partially defined recursive functions "up to [n]". *)
    Local Definition partial_Nrec@{} (n : N) : Type@{nr}
      := sig@{nr nr}
            (fun f : ({ m : N & m <= n} -> X) =>
               prod@{x nr} (f (zero_seg n) = x0)
                   (forall (mh : {m:N & m < n}),
                       f (succ_seg n mh) = xs (f ((equiv_N_segment n)^-1 (inl mh))))).

    (** The crucial point that makes it work for arbitrary [X] is to
    prove in one big induction that these types are always
    contractible.  Here is the base case. *)
    Lemma contr_partial_Nrec_zero0 : Contr (partial_Nrec zero).
    Proof.
      unfold partial_Nrec.
      srefine (trunc_equiv' {f0 : {f : {m : N & m <= zero} -> X &
    (f (zero_seg zero) = x0)} &
    (forall mh : {m : N & m < zero},
     f0.1 (succ_seg zero mh) =
     xs (f0.1 ((equiv_N_segment zero)^-1 (inl mh))))} _).
      - exact _.
      - refine (_ oE equiv_inverse (equiv_sigma_assoc _ _)).
        apply equiv_functor_sigma_id; intros f.
        cbn; apply equiv_sigma_prod0.
      - refine (@trunc_sigma@{nr nr large nr} _ _ _ _ _).
        + srefine (Build_Contr _ _ _).
          * exists (fun _ => x0); reflexivity.
          * intros [g H].
            srefine (path_sigma _ _ _ _ _); cbn.
            { apply path_forall; intros m.
              exact (H^ @ ap g (path_ishprop _ _)). }
            { rewrite transport_paths_Fl.
              rewrite ap_apply_l.
              rewrite ap10_path_forall.
              rewrite inv_pp, inv_V, concat_p1.
              transitivity ((ap g 1)^ @ H).
              - apply whiskerR, ap, ap.
                apply path_ishprop.
              - apply concat_1p. }
        + intros [f H].
          exists (fun mh => Empty_rec (N_lt_zero mh.1 mh.2)).
          intros g.
          apply path_forall; intros m.
          destruct (N_lt_zero m.1 m.2).
    Qed.
    Definition contr_partial_Nrec_zero@{} : Contr (partial_Nrec zero)
      := ltac:(first [exact contr_partial_Nrec_zero0@{nr}|exact contr_partial_Nrec_zero0]).
    Local Existing Instance contr_partial_Nrec_zero.

    Local Definition equiv_N_segment_succ_maps@{} (n : N)
      : Equiv@{nr nr} (prod@{nr x} ({ m : N & m <= n} -> X) X) ({ m : N & m <= succ n} -> X).
    Proof.
      refine (_ oE @equiv_sum_ind@{x nr nr nr nr p p p}
                _ {m:N&m<=n} Unit (fun _ => X) oE _).
      - apply equiv_precompose'.
        apply equiv_N_segment_succ.
      - apply equiv_functor_prod_l.
        apply equiv_unit_rec@{x nr Set}.
    Defined.

    Local Definition equiv_seg_succ@{} (n m : N) (H : m < succ n)
               (f : { m : N & m <= n} -> X) (xsn : X)
      : equiv_N_segment_succ_maps n (f,xsn) (m ; N_lt_le m _ H) = f (existT (fun m=>m<=n) m (fst (N_lt_succ_iff_le m _) H)).
    Proof.
      cbn.
      generalize (N_le_eq_or_lt m (succ n) (N_lt_le m (succ n) H)).
      intros [E|L].
      - apply Empty_rec.
        rewrite E in H.
        exact (N_lt_irref _ H).
      - cbn.
        apply ap, path_sigma_hprop; reflexivity.
    Qed.

    (** And here, essentially, is the inductive step. *)
    Local Definition partial_Nrec_succ0 (n : N)
      : partial_Nrec n <~> partial_Nrec (succ n).
    Proof.
      unfold partial_Nrec.
      srefine (equiv_functor_sigma' (equiv_N_segment_succ_maps n) _ oE _).
      { intros [f xsn].
        srefine ((f (zero_seg n) = x0) *
           ((forall (mh : {m:N & m < n}),
             f (succ_seg n mh) = xs (f ((equiv_N_segment n)^-1 (inl mh)))) *
           (xsn = xs (f (refl_seg n))))). }
      { intros [f xsn].
        apply equiv_functor_prod'.
        { apply equiv_concat_l.
          cbn.
          generalize (N_le_eq_or_lt zero (succ n) (N_zero_le (succ n))).
          intros [H0|Hs].
          + destruct (zero_neq_succ n (H0)).
          + cbn. apply ap.
            apply path_sigma_hprop; reflexivity. }
        { srefine ((equiv_functor_forall_pf
                      (Q := fun mh =>
                              (equiv_N_segment_succ_maps n)
                                (f, xsn) (succ_seg (succ n) mh)
                              = xs ((equiv_N_segment_succ_maps n)
                                      (f, xsn)
                                      ((equiv_N_segment (succ n))^-1
                                         (inl mh))))
                   (equiv_N_segment_lt_succ n)) oE _).
          srefine ((equiv_functor_forall_pf (equiv_N_segment n)) oE _).
          srefine (equiv_sum_ind _ oE _).
          apply equiv_functor_prod'.
          - apply equiv_functor_forall_id; intros [m H].
            apply equiv_concat_lr.
            + transitivity ((equiv_N_segment_succ_maps n)
                              (f,xsn)
                              (succ m; N_lt_le _ _ (N_succ_lt m n H))).
              * apply ap. apply path_sigma_hprop. reflexivity.
              * rewrite equiv_seg_succ.
                apply ap, path_sigma_hprop; reflexivity.
            + apply ap.
              cbv [equiv_fun equiv_inv equiv_isequiv equiv_inverse equiv_adjointify isequiv_adjointify equiv_compose' equiv_compose equiv_precompose' equiv_functor_sigma_id equiv_N_segment_succ equiv_sum_ind equiv_functor_prod_l equiv_functor_sum_r equiv_functor_sigma' equiv_functor_sum equiv_functor_sum' equiv_functor_sigma equiv_functor_prod equiv_functor_prod' equiv_idmap isequiv_idmap equiv_unit_rec isequiv_functor_sigma equiv_iff_hprop equiv_iff_hprop_uncurried eisretr inverse transport succ_seg equiv_N_segment_succ_maps equiv_N_segment_lt_succ equiv_N_segment];
                cbn.
              match goal with
              | [ |- context[match ?L with | inl _ => inr tt | inr Hs => inl (?k; Hs) end] ] => generalize L
              end.
              intros [L|L].
              * apply Empty_rec; rewrite L in H.
                exact (N_succ_nlt n H).
              * cbn. apply ap, path_sigma_hprop; reflexivity.
          - refine ((equiv_contr_forall _)^-1 oE _).
            apply equiv_concat_lr.
            + cbv [equiv_fun equiv_inv equiv_isequiv equiv_N_segment_succ_maps equiv_N_segment_lt_succ equiv_N_segment equiv_adjointify isequiv_adjointify equiv_compose' equiv_compose equiv_precompose' equiv_functor_sigma_id equiv_N_segment_succ equiv_sum_ind equiv_functor_prod_l equiv_functor_sum_r equiv_functor_sigma' equiv_functor_sum equiv_functor_sum' equiv_functor_sigma equiv_functor_prod equiv_functor_prod' equiv_idmap isequiv_idmap equiv_unit_rec isequiv_functor_sigma equiv_iff_hprop equiv_iff_hprop_uncurried eisretr inverse transport succ_seg];
                cbn.
              match goal with
              | [ |- context[match ?L with | inl _ => inr tt | inr Hs => inl (?k; Hs) end] ] => generalize L
              end.
              intros [L|L].
              * reflexivity.
              * case (N_lt_irref _ L).
            + apply ap.
              cbv [eisretr equiv_adjointify equiv_compose equiv_compose' equiv_fun equiv_functor_prod equiv_functor_prod' equiv_functor_prod_l equiv_functor_sigma equiv_functor_sigma' equiv_functor_sigma_id equiv_functor_sum equiv_functor_sum' equiv_functor_sum_r equiv_idmap equiv_iff_hprop equiv_iff_hprop_uncurried equiv_inv equiv_inverse equiv_isequiv equiv_N_segment equiv_N_segment_lt_succ equiv_N_segment_succ equiv_N_segment_succ_maps equiv_precompose' equiv_sum_ind equiv_unit_rec inverse isequiv_adjointify isequiv_functor_sigma isequiv_idmap transport];
                cbn [fst snd pr1 pr2 functor_sigma].
              match goal with
              | [ |- context[match ?L with | inl _ => inr tt | inr Hs => inl (?k; Hs) end] ] => generalize L
              end.
              intros [L|L].
              * case (N_neq_succ n L).
              * cbn.
                apply ap, path_sigma_hprop. reflexivity. } }
      { refine (equiv_sigma_prod _ oE _).
        apply equiv_functor_sigma_id. intros f.
        refine (equiv_functor_sigma_id (fun b:X => equiv_sigma_prod0 _ _) oE _).
        refine (equiv_sigma_symm _ oE _).
        refine (_ oE (equiv_sigma_prod0 _ _)^-1).
        apply equiv_functor_sigma_id; intros f0.
        refine (equiv_functor_sigma_id (fun b:X => equiv_sigma_prod0 _ _) oE _).
        refine (equiv_sigma_symm _ oE _).
        exact ((equiv_sigma_contr _)^-1%equiv). }
    Defined.
    Local Definition partial_Nrec_succ@{}
      := Eval unfold partial_Nrec_succ0 in partial_Nrec_succ0@{nr nr nr nr}.

    Local Instance contr_partial_Nrec@{} (n : N) : Contr (partial_Nrec n).
    Proof.
      revert n; apply N_propind; try exact _.
      intros n H.
      refine (trunc_equiv' _ (partial_Nrec_succ n)).
    Qed.

    (** This will be useful later. *)
    Local Definition partial_Nrec_restr@{} (n : N)
      : partial_Nrec (succ n) -> partial_Nrec n.
    Proof.
      intros f.
      destruct f as [f [f0 fs]].
      exists (fun mh => f ((equiv_N_segment_succ n)^-1 (inl mh))).
      split.
      - refine (_ @ f0).
        apply ap, path_sigma_hprop. reflexivity.
      - intros mh.
        refine (_ @ fs (((equiv_N_segment_lt_succ n)^-1)
                          ((equiv_N_segment n)^-1 (inl mh))) @ _).
        + apply ap.
          apply path_sigma_hprop; reflexivity.
        + apply ap, ap.
          apply path_sigma_hprop; reflexivity.
    Defined.

    (** Finally, we want to put all this together to show that the
    type of fully defined recursive functions is contractible, so that
    N has the universal property of a natural numbers object.  If we
    attack it directly, this can lead to quite annoying path algebra.
    Instead, we will show that it is a retract of the product of all
    the types of partial attempts, which is contractible since each of
    them is.  *)
    Local Definition partials@{} := forall n, partial_Nrec n.
    Local Instance contr_partials@{} : Contr partials := trunc_forall@{p nr nr}.

    (** From a family of partial attempts, we get a totally defined
    recursive function. *)
    Section Partials.
      Context (pf : partials).

      Local Definition N_rec'@{} : N -> X
        := fun n => (pf n).1 (refl_seg n).

      Definition N_rec_beta_zero'@{} : N_rec' zero = x0.
      Proof.
        refine (_ @ fst (pf zero).2).
        unfold N_rec'.
        apply ap, path_sigma_hprop; reflexivity.
      Defined.

      Definition N_rec_beta_succ'@{} (n : N)
        : N_rec' (succ n) = xs (N_rec' n).
      Proof.
        unfold N_rec'.
        refine (_ @ snd (pf (succ n)).2
                  (n ; N_lt_succ n) @ _).
        - apply ap, path_sigma_hprop; reflexivity.
        - apply ap.
          transitivity ((partial_Nrec_restr n (pf (succ n))).1 (refl_seg n)).
          + refine (ap (pf (succ n)).1 _).
            apply path_sigma_hprop; reflexivity.
          + apply ap10@{p x nr}.
            apply ap, path_contr.
      Defined.

    End Partials.

    (** Applying this to the "canonical" partial attempts, we get "the recursor". *)
    Definition N_rec@{} : N -> X := N_rec' (center partials).
    Definition N_rec_beta_zero@{} : N_rec zero = x0
      := N_rec_beta_zero' (center partials).
    Definition N_rec_beta_succ@{} (n : N)
      : N_rec (succ n) = xs (N_rec n)
      := N_rec_beta_succ' (center partials) n.

    (** Here is the type of totally defined recursive functions that
    we want to prove to be contractible. *)
    Definition NRec : Type@{nr}
      := sig@{nr nr} (fun f : N -> X =>
                        prod@{x nr} (f zero = x0)
                            (forall m:N, f (succ m) = xs (f m))).

    Local Definition nrec_partials@{} : NRec -> partials.
    Proof.
      intros f n.
      exists (fun mh => f.1 mh.1).
      split.
      - exact (fst f.2).
      - intros mh.
        exact (snd f.2 mh.1).
    Defined.

    (** This is a weird lemma.  We could prove it by [path_contr], but
    we give an explicit proof instead using [path_sigma], so that
    later on we know what happens when [pr1_path] is applied to it. *)
    Local Definition nrec_partials_succ@{} (n : N) (f : NRec)
      : partial_Nrec_restr n (nrec_partials f (succ n)) = nrec_partials f n.
    Proof.
      change (?x = ?y) with ((x.1; x.2) = (y.1; y.2)).
      srefine (path_sigma' _ 1 _).
      abstract (rewrite transport_1;
      apply path_prod;
      [ cbn [partial_Nrec_restr nrec_partials fst pr2 pr1];
        rewrite ap_compose;
        rewrite ap_pr1_path_sigma_hprop;
        apply concat_1p
      | cbn [partial_Nrec_restr nrec_partials pr1 pr2 snd];
        apply path_forall; intros mh;
        rewrite ap_compose;
        rewrite ap_pr1_path_sigma_hprop;
        rewrite ap_1, concat_1p;
        refine (_ @ concat_p1 _); apply whiskerL;
        refine (_ @ ap_1 _ xs); apply ap;
        rewrite ap_compose;
        rewrite ap_pr1_path_sigma_hprop;
        reflexivity ]).
    Defined.

    Local Definition partials_nrec@{} : partials -> NRec.
    Proof.
      intros pf.
      exists (N_rec' pf).
      exact (N_rec_beta_zero' pf, N_rec_beta_succ' pf).
    Defined.

    Local Definition nrec_partials_sect@{} (f : NRec)
      : partials_nrec (nrec_partials f) = f.
    Proof.
      destruct f as [f [f0 fs]].
      unfold partials_nrec, nrec_partials. cbn.
      unfold N_rec', N_rec_beta_zero'; cbn.
      apply ap@{nr nr}, path_prod.
      - cbn.
        rewrite ap_compose.
        rewrite ap_pr1_path_sigma_hprop.
        apply concat_1p.
      - apply path_forall; intros n.
        unfold N_rec_beta_succ'.
        cbn [fst snd pr1 pr2];
          cbv [equiv_fun equiv_inverse equiv_inv equiv_isequiv equiv_compose' equiv_compose isequiv_compose equiv_functor_sum_r equiv_functor_sigma_id equiv_functor_sigma' equiv_functor_sigma equiv_functor_sum' equiv_functor_sum equiv_adjointify isequiv_adjointify isequiv_functor_sum isequiv_idmap equiv_idmap isequiv_functor_sigma equiv_iff_hprop_uncurried functor_sum functor_sigma equiv_N_segment equiv_N_segment_succ inverse transport eisretr];
          cbn [fst snd pr1 pr2 refl_seg].
        rewrite ap_compose.
        rewrite ap_pr1_path_sigma_hprop.
        rewrite ap_1, concat_1p.
        rewrite (ap_compose pr1 f).
        rewrite ap_pr1_path_sigma_hprop.
        rewrite ap_1, concat_1p.
        refine (_ @ (concat_p1 _)); apply whiskerL.
        set (refl_seg_n := refl_seg n).
        (** Here is where we use [nrec_partials_succ]: the [path_contr] equal to it, which allows us to identify [ap pr1] of the latter.  (Note that [ap pr1] of a [path_contr] can be nontrivial even when the endpoints happen to coincide judgmentally, for instance (x;p) and (x;1) in {y:X & y = x}, so there really is something to prove here.) *)
        transitivity (ap xs (ap10 (ap pr1 (nrec_partials_succ n (f;(f0,fs)))) refl_seg_n)).
        + apply ap.
          assert (p : path_contr _ _ =  nrec_partials_succ n (f; (f0, fs))).
          { apply path_contr. }
          exact (ap (fun h => ap10 (ap pr1 h) refl_seg_n) p).
        + unfold nrec_partials_succ.
          unfold path_sigma'.
          rewrite ap_pr1_path_sigma.
          reflexivity.
    Qed.

    (** And we're done! *)
    Global Instance contr_NRec@{} : Contr NRec.
    Proof.
      refine (trunc_equiv partials partials_nrec).
      refine (isequiv_adjointify _ nrec_partials nrec_partials_sect _).
      intros x; apply path_contr.
    Defined.

  End NRec.

End AssumeStuff.


Require Export Coq.Lists.List.
Require Import Fiat.BinEncoders.NoEnv.Specs
               Fiat.BinEncoders.NoEnv.Libraries.Sig
               Coq.omega.Omega.

Set Implicit Arguments.

Section FixList2Encoder.
  Variable (A : Type)
           (B : Type)
           (size : nat)
           (encode_A : A * B -> B)
           (predicate_A : A -> Prop)
           (decoder_A : decoder (fun bundle => predicate_A (fst bundle)) encode_A).

  Definition data_t := { xs : list A | length xs = size }.

  Definition FixList2_predicate (bundle : data_t * B) :=
    forall x, In x (proj1_sig (fst bundle)) -> predicate_A x.

  Fixpoint encode' (xs : list A) (ext : B) :=
    match xs with
      | nil => ext
      | x :: xs => encode_A (x, encode' xs ext)
    end.

  Definition FixList2_encode (bundle : data_t * B) := encode' (proj1_sig (fst bundle)) (snd bundle).

  Fixpoint decode' (len : nat) (b : B) : list A * B :=
    match len with
    | O => (nil, b)
    | S size' => let (_data, _bin) := @decode _ _ _ _ decoder_A b in
                 let (_rest, _bin') := decode' size' _bin in
                     (_data :: _rest, _bin')
    end.

  Definition FixList2_decode (b : B) : data_t * B.
    refine (exist _ (fst (decode' size b)) _, snd (decode' size b)).
    generalize dependent b; induction size; intuition eauto.
    simpl. destruct (decode b). specialize (IHn b0). destruct (decode' n b0). simpl. f_equal. eauto.
  Defined.

  Theorem FixList2_encode_decode_correct :
    encode_decode_correct FixList2_predicate FixList2_encode FixList2_decode.
  Proof.
    unfold encode_decode_correct, FixList2_predicate, FixList2_encode, FixList2_decode.
    intros [[data data_pf] ext] pred_pf.
    f_equal; try eapply sig_equivalence; simpl in *;
    generalize dependent data; induction size; intuition eauto; simpl in *;
    destruct data; inversion data_pf; eauto; simpl in *.
    - assert (forall x : A, In x data -> predicate_A x) by intuition.
      specialize (IHn data H0 H). rewrite (@decode_correct _ _ _ _ decoder_A); eauto.
      rewrite H0. destruct (decode' n (encode' data ext)). subst. eauto.
    - assert (forall x : A, In x data -> predicate_A x) by intuition.
      specialize (IHn data H0 H). rewrite (@decode_correct _ _ _ _ decoder_A); eauto.
      rewrite H0. destruct (decode' n (encode' data ext)). subst. eauto.
  Qed.
End FixList2Encoder.

Global Instance FixList2_decoder
       (A : Type)
       (B : Type)
       (size : nat)
       (predicate_A : A -> Prop)
       (encode_A : A * B -> B)
       (decoder_A : decoder (fun bundle => predicate_A (fst bundle)) encode_A)
  : decoder (FixList2_predicate predicate_A) (FixList2_encode (size:=size) encode_A) :=
  { decode := FixList2_decode size predicate_A decoder_A;
    decode_correct := @FixList2_encode_decode_correct _ _ _ _ _ _ }.

Arguments FixList2_predicate / _ _ _ _ _.


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

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

Print Assumptions carry.


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

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

Print Assumptions sub.


Require Import Psatz.
Require Import String.
Require Import Program.
Require Export Complex.
Require Export Matrix.
Require Import List.

(*
Require Export CoRN.fta.FTA.
Require Export CoRN.coq_reals.Rreals_iso.
*)

(* polynomial represented by a list of coeficients and a degree*)
Definition Polynomial (n : nat) := list (Complex.C).

Definition WF_Poly {n : nat} (p : Polynomial n) :=
  length p = (S n).

Definition eval_P (n : nat) (p : Polynomial n) (x : Complex.C):=
  Csum (fun i => (nth i p C0)* x^i) (S n).

(*****************************************************)
(* First, we show that our C is the same as ccorns C *)
(*****************************************************)

(*

Definition CtoCC (c : Complex.C) : CC_set := Build_CC_set (RasIR (fst c)) (RasIR (snd c)).
Definition CCtoC (c : CC_set) : Complex.C := (IRasR (Re c), IRasR (Im c)).

Lemma CasCCasC_id : forall (x : Complex.C), (CCtoC (CtoCC x) = x).
Proof. intros.
       unfold CtoCC, CCtoC.
       simpl.
       do 2 rewrite RasIRasR_id.
       rewrite surjective_pairing.
       easy.
Qed.

(*
Lemma CCasCasCC_id : forall (x : CC_set), (CtoCC (CCtoC x) = x).
Proof. intros.
       unfold CtoCC, CCtoC.
       simpl.
       do 2 rewrite RasIRasR_id.
       rewrite surjective_pairing.
       easy.
Qed. *)

*)

Theorem Fundamental_Theorem_Algebra : forall {n : nat} (p : Polynomial n),
  (n > 0)%nat -> (exists c : (R * R), eval_P n p c = C0).
Proof. Admitted.


Require Import VST.msl.sepalg.

Class Ghost := { G : Type; valid : G -> Prop;
  Join_G :> Join G; Sep_G :> Sep_alg G; Perm_G :> Perm_alg G;
  join_valid : forall a b c, join a b c -> valid c -> valid a }.

Section Update.

Context {RA: Ghost}.

Lemma core_valid: forall a, valid a -> valid (core a).
Proof.
  intros; eapply join_valid; eauto.
  apply core_unit.
Qed.

Definition valid_2 a b := exists c, join a b c /\ valid c.

Definition fp_update_ND a B := forall c, valid_2 a c -> exists b, B b /\ valid_2 b c.

Definition fp_update a b := forall c, valid_2 a c -> valid_2 b c.

Lemma fp_update_equiv: forall a b, fp_update a b <-> fp_update_ND a (eq b).
Proof.
  split; repeat intro.
  - exists b; split; eauto; constructor.
  - destruct (H _ H0) as (? & Hx & ?); inversion Hx; auto.
Qed.

End Update.


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

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

Print Assumptions opp.


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

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

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e512m569_10limbs.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.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Arith.
Require Export Nnewton.
Require Export Ndiv.
Open Scope nat_scope.

(** * Fermat's little theorem over [nat] *)
Theorem Nlittle_fermat :
  forall a p, Nprime p -> (p | a ^ p - a).
(* begin hide *)
  Lemma pow : forall (a p:nat),
    Nprime p -> (p | (a+1)^p - a^p -1).
  Proof.
  intros.
  rewrite Nnewton.
  assert (exists p', p=S(S p')).
  destruct p.
  apply Nnot_prime_0 in H. contradiction.
  destruct p.
  apply Nnot_prime_1 in H. contradiction.
  exists p.
  reflexivity.
  destruct H0.
  rewrite H0.
  unfold Nnewton_sum.
  rewrite Nfinite_sum_split_lower.
  rewrite Nfinite_sum_split_upper.
  rewrite Nbinomial_0.
  rewrite Nbinomial_diag.
  rewrite mult_1_l.
  rewrite mult_1_l.
  rewrite Npower_1_n.
  rewrite Npower_1_n.
  rewrite mult_1_r.
  assert (1 +
  (Nfinite_sum_0_n x
     (fun k : nat =>
      Nbinomial (S (S x)) (S k) * a ^ S k * 1 ^ (S (S x) - S k)) +
   a ^ S (S x)) - a ^ S (S x) - 1 =
  (Nfinite_sum_0_n x
     (fun k : nat =>
      Nbinomial (S (S x)) (S k) * a ^ S k * 1 ^ (S (S x) - S k)) + 1 +
   a ^ S (S x)) - a ^ S (S x) - 1).
  rewrite plus_assoc.
  auto with arith.
  rewrite H1. clear H1.

  Lemma plus_minus : forall n m r, r<=m -> (n+m)-r=n+(m-r).
  Proof.
  induction n.
  intros.
  simpl.
  reflexivity.
  intros.
  assert (S n+m=S(n+m)).
  auto with arith.
  rewrite H0.
  rewrite <- minus_Sn_m.
  rewrite IHn.
  auto with arith.
  exact H.
  assert (m<=n+m).
  auto with arith.
  apply le_trans with m.
  exact H. exact H1.
  Qed.

  rewrite plus_minus.
  rewrite minus_diag.
  rewrite plus_0_r.
  rewrite plus_minus.
  rewrite minus_diag.
  rewrite plus_0_r.

  rewrite <- H0.
  apply Nfinite_sum_div_compat.
  intros.
  apply Ndiv_mult_compat.
  apply Ndiv_mult_compat.
  apply Nbinomial_div.
  split.
  auto with arith.
  rewrite H0.
  auto with arith.
  auto.
  auto.
  auto.
  Qed.

induction a.
intros.
rewrite Npower_0_n.
simpl.
apply Ndiv_0.
destruct p.
apply Nnot_prime_0 in H. contradiction.
destruct p.
apply Nnot_prime_1 in H. contradiction.
auto with arith.

intros.
destruct p.
apply Nnot_prime_0 in H. contradiction.
destruct p.
apply Nnot_prime_1 in H. contradiction.
simpl.
replace (S a) with (a+1).
replace ((a+1)^(S(S p))-(a+1)) with ((a+1)^(S(S p))-a-1).
assert((S(S p))|(a+1)^(S(S p)) - a^(S (S p))-1).
apply pow. auto.
assert((S(S p))|((a+1)^(S(S p))-a^(S(S p))-1)+(a^(S(S p))-a)).
apply Ndiv_plus_compat.
auto.
apply IHa. auto.
clear H0.
assert((a + 1) ^ S (S p) - a ^ S (S p) - 1 + (a ^ S (S p) - a)
          =(a + 1) ^ S (S p) - a - 1).
assert((a+1)^(S(S p))>=a^(S(S p))+1).
assert((a+1)^(S(S p))>=a^(S(S p))+1^(S (S p))).
apply Npower_plus_le_compat. auto with arith.
rewrite Npower_1_n in H0. auto.
apply Nle_plus in H0.
destruct H0.
rewrite H0.
clear H0.
  Lemma minus_L0: forall p q x, p>=q -> p+x-q=p-q+x.
  Proof.
  intros.
  apply Nle_plus in H.
  destruct H.
  rewrite H.
  rewrite minus_plus.
  rewrite <- plus_assoc.
  rewrite minus_plus.
  auto.
  Qed.

  Lemma minus_L1 : forall p q x, p>=q -> x+(p-q)=x+p-q.
  Proof.
  intros.
  apply Nle_plus in H.
  destruct H.
  rewrite H.
  rewrite minus_plus.
  rewrite plus_assoc.
  replace (x+q+x0) with (q+(x+x0)).
  rewrite minus_plus.
  auto.
  ring.
  Qed.

rewrite minus_L0.
rewrite minus_plus.
rewrite minus_plus.
replace (a ^ S (S p) + 1 + x - a - 1) with (1+(a ^ S (S p) + x - a) - 1).
rewrite minus_plus.
rewrite minus_L1.
auto with arith.
destruct a.
rewrite Npower_0_n. auto. auto with arith.
apply le_trans with ((S a)^1).
rewrite Npower_n_1.
auto.
apply Npower_le_compat_r.
auto with arith.
auto with arith.
rewrite minus_L1.
rewrite plus_assoc.
auto with arith.
destruct a.
rewrite Npower_0_n.
simpl. auto with arith.
auto with arith.
apply le_trans with ((S a)^(S(S p))).
apply le_trans with ((S a)^1).
rewrite Npower_n_1. auto.
apply Npower_le_compat_r.
auto with arith.
auto with arith.
auto with arith.
auto with arith.
rewrite H0 in H1.
auto.
  Lemma minus_L2 : forall n p q, n>=p+q -> n-p-q=n-(p+q).
  Proof.
  intros.
  apply Nle_plus in H.
  destruct H.
  rewrite H.
  rewrite minus_plus.
  replace (p+q+x-p) with (q+x).
  rewrite minus_plus.
  auto.
  rewrite <- plus_assoc.
  rewrite minus_plus.
  auto.
  Qed.
rewrite minus_L2.
auto.
apply le_trans with (a^(S(S p))+1^(S(S p))).
apply plus_le_compat.
destruct a.
rewrite Npower_0_n.
auto.
auto with arith.
apply le_trans with ((S a)^1).
rewrite Npower_n_1.
auto.
apply Npower_le_compat_r.
auto with arith.
auto with arith.
rewrite Npower_1_n.
auto.
apply Npower_plus_le_compat.
auto with arith.
ring.
Qed.

(* end hide *)
(** * Alternative formulation of Fermat's little theorem *)
Theorem Nlittle_fermat_alt :
  forall a p, Nprime p -> Nrel_prime a p ->
  (p | a ^ (pred p) - 1).
Proof.
intros.
destruct p.
apply Nnot_prime_0 in H. contradiction.
destruct p.
apply Nnot_prime_1 in H. contradiction.
assert(S(S p)|a^(S(S p))-a).
apply Nlittle_fermat.
auto.
simpl.
rewrite Npower_succ in H1.
replace (a * a ^ S p - a) with (a * a ^ S p - a*1) in H1.
rewrite <- mult_minus_distr_l in H1.
apply Ngauss in H1.
auto.
apply Nrel_prime_comm. auto.
rewrite mult_1_r.
auto.
Qed.


(* -*- mode: coq -*- *)
(* Time-stamp: <2014/8/23 13:4:32> *)
(*
  binsearch.v
  - mathink : Author
 *)

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

Require Import
  MathComp.path.

Require Import
  Adlibssr.btree
  Adlibssr.sorted
  Adlibssr.order.

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

(**
 ** Binary Search Tree
 *)

(* Aux *)
Definition flip {X Y Z: Type}(f: X -> Y -> Z): Y -> X -> Z :=
  fun y x => f x y.
Arguments flip X Y Z f / y x.

Inductive btR {T}(R: T -> T -> Prop)(a: T): btree T -> Prop :=
| btR_bleaf: btR R a #
| btR_bnode: forall x tl tr,
                R a x -> btR R a tl -> btR R a tr ->
                btR R a (tl -< x >- tr).
Hint Constructors btR.

Lemma btRP {T}(R: T -> T -> Prop) ord a t:
  (forall x y, reflect (R x y) (ord x y)) ->
  reflect (btR R a t) (all (ord a) t).
Proof.
  move=> ordP.
  elim: t => [//=|/= x tl IHl tr IHr]; first by left.
  move: IHl IHr => [Hl | Hnl] /= [Hr | Hnr] /=;
    rewrite ?andbT ?andbF; try (right; move=> Hb).
  - case: (ordP a x) => [HR | HnR]; [left; apply btR_bnode=> //| right].
    move=> Hb; apply HnR; inversion Hb => //.
  - apply Hnr; inversion Hb => //.
  - apply Hnl; inversion Hb => //.
  - apply Hnr; inversion Hb => //.
Qed.

Section BinarySearchTree.

  Variables (T: eqType)
            (le: T -> T -> Prop)
            (ord: totalOrder T).
  Notation "x <= y" := (le x y).
  Hypothesis (ordP: forall x y, reflect (x <= y) (ord x y)).

  Lemma ordP' x y: reflect (flip le x y) (ord^~ x y).
  Proof.
    simpl; apply ordP.
  Qed.

  Implicit Types (t: btree T)(s: seq T).

  Inductive isBst: btree T -> Prop :=
  | isBst_bleaf: isBst #
  | isBst_bnode: forall x tl tr,
                   isBst tl -> btR (flip le) x tl ->
                   isBst tr -> btR le x tr ->
                   isBst (tl -< x >- tr).
  Hint Constructors isBst.

  Fixpoint bst t: bool :=
    if t is tl -< x >- tr
    then (bst tl) && (all (flip ord x) tl) && (bst tr) && (all (ord x) tr)
    else true.
  Functional Scheme bst_ind := Induction for bst Sort Prop.

  Lemma bstP t: reflect (isBst t) (bst t).
  Proof.
    elim: t => [//=|/= x tl IHl tr IHr]; first by left.
    move: IHl IHr => [Hbl | Hnbl] [Hbr | Hnbr] /=.
    - rewrite andbT.
      case: (btRP x tl ordP') => Hal /=;
        last by right; move=> Hb; apply Hal; inversion Hb.
      case: (btRP x tr ordP) => Har /=;
        last by right; move=> Hb; apply Har; inversion Hb.
        by left; apply isBst_bnode => //.
    - by rewrite andbF /=; right; move=> Hb; apply Hnbr; inversion Hb.
    - by right; move=> Hb; apply Hnbl; inversion Hb.
    - by right; move=> Hb; apply Hnbl; inversion Hb.
  Qed.

  Lemma bst_bnode x tl tr:
    bst (tl -< x >- tr) = (bst tl) && (all (flip ord x) tl) && (bst tr) && (all (ord x) tr).
  Proof.
    by [].
  Qed.

  Lemma all_revtree p t:
    all p (revtree t) = all p t.
  Proof.
    elim: t => [//=|/= x tl -> tr ->].
    by rewrite andbAC.
  Qed.

  Lemma sorted_walk_bst t s:
    sorted ord (walk t s) = (bst t) && (sorted ord s)
                                    && (all (fun x => seq.all (ord x) s) t).
  Proof.
    elim/walk_ind: t s /(walk t s)=> t s; first by rewrite andbT.
    move=> x tl tr _ Heqr ->.
    rewrite sorted_cons1 // Heqr /= ?andbA /=.
    case (bst tl) => //=.
    case (bst tr) => //=;
    rewrite /= ?andbT ?andbF //.
    case (all (fun x0 : T => seq.all (ord x0) s) tr);
    rewrite /= ?andbT ?andbF //.
    case (sorted ord s) => //=;
    rewrite /= ?andbT ?andbF //.
    case Hta: (all (fun x0 : T => ord x0 x && seq.all (ord x0) (walk tr s)) tl).
    - move: Hta => /eqP; rewrite eqb_id andbT /= => /allP Hta.
      case Hsa: (seq.all (ord x) (walk tr s)).
      move: Hsa => /eqP; rewrite eqb_id => /seq.allP Hsa.
      + apply esym; apply/eqP; rewrite eqb_id -!andbA; apply/and4P; split.
        * by apply/allP=> y Hin; move: (Hta _ Hin) => /andP [] //.
        * by apply/allP=> y Hin; apply Hsa; rewrite mem_walk; apply/orP; left.
        * by apply/seq.allP=> y Hin; apply Hsa; rewrite mem_walk; apply/orP; right.
        * apply/allP=> y Hiny; apply/seq.allP=> z Hinz.
          move: (Hta _ Hiny) => /andP [] _ /seq.allP; apply.
          by rewrite mem_walk; apply/orP; right.
      + apply esym; apply/eqP; rewrite eqbF_neg; apply/negP => H.
        move: Hsa => /eqP; rewrite eqbF_neg => /negP; apply.
        move: H; rewrite -!andbA => /and4P [/allP Hal /allP Har /seq.allP Has /allP Hsal].
        apply/seq.allP=> y; rewrite mem_walk => /orP [Hin | Hin].
        * by apply Har.
        * by apply Has.
    - rewrite andbF /=; apply esym; apply/eqP; rewrite eqbF_neg -!andbA;
      apply/negP => /and4P [/allP Hal /allP Har /seq.allP Has /allP Hsal].
      move: Hta => /eqP; rewrite eqbF_neg => /negP; apply.
      apply/allP=> y Hin; apply/andP; split; first by apply Hal.
      apply/seq.allP => z; rewrite mem_walk => /orP [Hinr | Hins].
      + apply ord_transitive with x.
        * by apply Hal.
        * by apply Har.
      + by move: (Hsal _ Hin) => /seq.allP; apply.
  Qed.

  Lemma all_predT t:
    all predT t.
  Proof.
    by elim: t => [//=|/= x tl -> tr ->].
  Qed.

  Lemma sorted_bst t:
    sorted ord (flatten t) = bst t.
  Proof.
    by rewrite sorted_walk_bst /= andbT all_predT andbT.
  Qed.

  Section Operations.

    Fixpoint search a t: bool :=
      if t is tl -< x >- tr
      then if a == x then true
           else if ord! a x then search a tl else search a tr
      else false.
    Functional Scheme search_ind := Induction for search Sort Prop.
    Lemma bst_search_aux a t:
      (a \in t) && (bst t) -> search a t.
    Proof.
      elim: t => [//= |/= x tl IHl tr IHr].
      rewrite in_bnode.
      case: (a =P x) => [<- | /eqP /negbTE Hneq] //=.
      rewrite -!andbA.
      move=> /andP
              [/orP [Hinl | Hinr]
                /and4P [Hbstl /allP Halll Hbstr /allP Hallr]].
      - move: (Halll _ Hinl) => /=; rewrite /strict_ord Hneq andbT => ->.
        by apply IHl; apply/andP.
      - move: (Hallr _ Hinr) => /=; rewrite -ord_neg_sord => -> /=.
        by apply IHr; apply/andP.
      (* functional induction (search a t) => //=; *)
      (*   rewrite in_bnode -!orbA -!andbA e0 /=; *)
      (*     move=>/and4P [/orP [Hin | Hin] Hbl Hal /andP [Hbr Har]]; *)
      (*       apply IHb; apply/andP; split=> //. *)
      (* - by move: Har => /allP Har; move: (Har a Hin); *)
      (*       rewrite -sord_neg_ord e1 //. *)
      (* - by move: Hal => /allP Hal; move: e1 (Hal a Hin) =>/eqP; rewrite eqbF_neg /strict_ord negb_and e0 orbF/= -eqbF_neg => /eqP->//. *)
    Qed.

    Lemma bst_search a t:
      bst t -> (a \in t) = (search a t).
    Proof.
      move=> Hbst.
      case Hin: (a \in t).
      - by apply esym; apply bst_search_aux; apply/andP.
      - move: {Hbst} Hin; elim: t => [//=|/= x tl IHl tr IHr].
        rewrite in_bnode.
        case: (a =P x) => [Heq | Hneq] //=.
        move/negbT; rewrite negb_or =>/andP [/negbTE/IHl<- /negbTE/IHr<-].
        by rewrite if_same.
    Qed.

    Fixpoint insert a t: btree T :=
      if t is tl -< x >- tr
      then if ord! a x
           then (insert a tl) -< x >- tr
           else tl -< x >- (insert a tr)
      else #-< a >-#.
    Functional Scheme insert_ind := Induction for insert Sort Prop.

    Lemma mem_insert a b t:
      b \in (insert a t) = (b == a) || (b \in t).
    Proof.
      by functional induction (insert a t)
        as [| _ x tl tr _ _ IH
            | _ x tl tr _ _ IH] => //;
        rewrite !in_bnode /= IH orbCA -!orbA.
    Qed.

    Lemma all_insert p a t:
      all p (insert a t) = p a && all p t.
    Proof.
      by functional induction (insert a t)
        as [| _ x tl tr _ Hord IH
            | _ x tl tr _ Hord IH] => //=;
        rewrite ?andbT // IH andbCA -!andbA.
    Qed.

    Lemma bst_bst_insert a t:
      bst t -> bst (insert a t).
    Proof.
      functional induction (insert a t)
        as [| _ x tl tr _ Hord IH
            | _ x tl tr _ Hord IH] => //=; rewrite -!andbA all_insert;
      [ move=> /and4P [/IH-> -> -> ->]
      | move=> /and4P [-> -> /IH-> ->]];
      rewrite /= !andbT //.
      - by move: Hord=>/eqP; rewrite eqb_id=>/andP []//.
      - by rewrite -sord_neg_ord Hord.
    Qed.

    Lemma bst_insert_bst a t:
      bst (insert a t) -> bst t.
    Proof.
      by functional induction (insert a t)
        as [| _ x tl tr _ Hord IH
            | _ x tl tr _ Hord IH] => //=; rewrite -!andbA all_insert;
      [ move=> /and4P [/IH-> /andP [Ho ->] -> ->]
      | move=> /and4P [-> -> /IH-> /andP [Ho ->]]].
    Qed.

    Lemma bst_insert a t:
      bst t = bst (insert a t).
    Proof.
      case H: (bst t).
      - by apply esym; apply bst_bst_insert.
      - apply esym; apply/negbTE; move: H => /negbT; apply contraL.
        by move=> Hbst; apply/negPn; apply bst_insert_bst with a.
    Qed.

    Lemma in_insert a t:
      a \in insert a t.
    Proof.
      by functional induction (insert a t)
        as [| _ x tl tr _ Hord IH
            | _ x tl tr _ Hord IH] => //=;
        rewrite ?mem_bnode1 ?in_bnode //= IH orbT //.
    Qed.

    Lemma search_insert a t:
      bst t -> search a (insert a t).
    Proof.
        by move=> Hbst; rewrite -bst_search; [apply: in_insert | apply: bst_bst_insert].
    Qed.

  (* Sorting by using binary-search tree *)
    Fixpoint btsort_insert s t: btree T :=
      if s is h :: s' then btsort_insert s' (insert h t) else t.
    Functional Scheme btsort_insert_ind := Induction for btsort_insert Sort Prop.

    Definition btsort s := flatten (btsort_insert s #).

    Lemma btsort_insert_bst s t:
      bst t -> bst (btsort_insert s t).
    Proof.
      by functional induction (btsort_insert s t) => //=;
       move=> Hbst; apply IHb; move: Hbst; apply bst_bst_insert.
    Qed.

    Lemma btsort_sorted s:
      sorted ord (btsort s).
    Proof.
      by rewrite /btsort sorted_bst; apply btsort_insert_bst.
    Qed.

    Lemma insert_count a t p:
      count p (insert a t) = (p a + count p t)%nat.
    Proof.
      by functional induction (insert a t)
        as [| _ x tl tr _ Hord IH
            | _ x tl tr _ Hord IH] => //=; rewrite IH addnCA -!addnA.
    Qed.

    Lemma btsort_insert_count s t p:
        (seq.count p s + count p t)%nat = count p (btsort_insert s t).
    Proof.
        by functional induction (btsort_insert s t) => //=;
        rewrite -IHb insert_count addnCA addnA.
    Qed.

    Lemma btsort_insert_perm s t:
      perm_eq (s ++ flatten t) (flatten (btsort_insert s t)).
    Proof.
      apply/perm_eqP=> p /=.
      by functional induction (btsort_insert s t) => //=;
        rewrite -IHb ?count_cat ?flatten_count insert_count addnCA.
    Qed.

    Lemma btsort_perm_eq s:
      perm_eq s (btsort s).
    Proof.
      by eapply perm_eq_trans; [| apply btsort_insert_perm]; rewrite cats0.
    Qed.

    Definition sorting f := forall s, perm_eq s (f s) /\ sorted ord (f s).

    Theorem btsort_sorting: sorting btsort.
    Proof. by split; [apply btsort_perm_eq | apply btsort_sorted]. Qed.

    (* lend & rend with bst *)
    Lemma bst_lend a t:
      bst t ->
      all (ord a) t ->
      all (ord (lend a t)) t.
    Proof.
      rewrite -!flatten_all -sorted_bst -head_flatten_lend.
      remember (flatten t) as l.
      clear Heql t.
      case: l a => [//=| h l] a.
      rewrite sorted_cons1 // => /=.
      move=> /andP [Hordah Hallal] /andP [Hallhl Hsorted].
      by apply/andP; split; first apply ord_reflexive.
    Qed.

    Lemma bst_rend a t:
      all (flip ord a) t -> bst t ->
      all (flip ord (rend t a)) t.
    Proof.
      rewrite -!flatten_all -sorted_bst -rend_flatten_rhead.
      remember (flatten t) as l.
      clear Heql t.
      case: l a => [//=| h l] a.
      rewrite sorted_cons1 // => /=.
      move=> /andP [Hordah Hallal] /andP [Hallhl Hsorted].
      apply/andP; split.
      - move: (mem_last h l); rewrite in_cons => /orP [/eqP->|Hin];
          first by apply ord_reflexive.
        by move: Hallhl => /seq.allP Hallhl; apply Hallhl.
      - move: Hallhl Hsorted => {a} {Hordah} {Hallal}.
        elim: l h => [//=| h' l IHl] h.
        rewrite sorted_cons1 // => /=.
        move=> /andP [Hordhh' Hallhl] /andP [Hallh'l Hsorted].
        apply/andP; split.
        + move: (mem_last h' l); rewrite in_cons => /orP [/eqP->|Hin];
            first by apply ord_reflexive.
          by move: Hallh'l => /seq.allP Hallh'l; apply Hallh'l.
        + by apply IHl.
    Qed.

    Fixpoint delete_l a t: btree T :=
      if t is tl -< x >- tr
      then if a == x
           then rem_root_r t
           else if ord! a x
                then (delete_l a tl) -< x >- tr
                else tl -< x >- (delete_l a tr)
      else #.
    Functional Scheme delete_l_ind := Induction for delete_l Sort Prop.

    Lemma bst_lend_remove a t:
      bst t -> bst (lend_remove a t).2.
    Proof.
      rewrite -!sorted_bst flatten_lend_remove_behead.
      remember (flatten t) as l.
      clear Heql t.
      case: l => [//=| h l] .
      by rewrite sorted_cons1 // /= => /andP [Hord Hsorted].
    Qed.

    Lemma bst_rend_remove t a:
      bst t -> bst (rend_remove t a).1.
    Proof.
      rewrite -!sorted_bst flatten_rend_remove_rbehead.
      remember (flatten t) as l.
      clear Heql t.
      elim: l => [//=| h l] .
      rewrite sorted_cons1 //.
      elim: l => [//=| h' l IHl].
      move=> IH /andP [Hall Hsorted].
      rewrite rbehead_cons sorted_cons1 //.
      apply /andP; split.
      - move: Hall => {IHl Hsorted} /seq.allP H.
        apply /seq.allP => x Hin; apply H.
        by apply mem_rbehead.
      - by apply IH.
    Qed.

    Lemma bst_rem_root_r t:
      bst t -> bst (rem_root_r t).
    Proof.
      elim: t => [//=|/= x tl IHl tr IHr].
      remember (rend_remove tl x).
      case: p Heqp => t node Heq /=.
      rewrite -!andbA => /and4P [Hbl Hal -> Har] /=.
      move: (bst_rend_remove x Hbl); rewrite -Heq/= => -> /=.
      apply/andP; split.
      - apply/allP => y Hin.
        move: (rend_remove_rend tl x); rewrite -Heq => /= ->.
        move: (bst_rend Hal Hbl) => /allP; apply.
        by move: (@mem_rend_remove _ y tl x); rewrite -Heq; apply.
      - apply/allP => y Hin.
        move: (rend_remove_rend tl x) (mem_rend tl x);
          rewrite -Heq => /= <- /orP [/eqP->|Hin'].
        + by move: Har => /allP; apply.
        + apply ord_transitive with x.
          * by move: Hal => /allP; apply.
          * by move: Har => /allP; apply.
    Qed.

    Lemma all_delete_l p a t:
       all p t -> all p (delete_l a t).
    Proof.
      functional induction (delete_l a t) => //=; rewrite -!andbA.
      - remember (rend_remove tl x) as tn.
        case: tn Heqtn => t node Heq /= /and3P [Hp /allP Hal ->]; rewrite andbT.
        + apply/andP; split.
          * by move: (rend_remove_rend tl x) (mem_rend tl x);
            rewrite -Heq/= => <- /orP [/eqP->//|Hin]; apply Hal.
          * by apply/allP=> y Hin; apply Hal; apply mem_rend_remove with x; rewrite -Heq.
      - by move=> /and3P [-> /IHb-> ->].
      - by move=> /and3P [-> -> /IHb->].
    Qed.

    Lemma bst_delete_l a t:
      bst t -> bst (delete_l a t).
    Proof.
      elim: t => [//=| x tl IHl tr IHr].
      move=> Hbst; move: (Hbst) => /bst_rem_root_r H /=.
      case: (a =P x) => [Heq | Hneq]; first done.
      move: Hbst => /=; rewrite -!andbA => /and4P [Hbl Hal Hbr Har].
      case Hord: (ord! a x) => /=.
      - rewrite -!andbA; apply/and4P; split; try done.
        + by apply: IHl.
        + by apply: all_delete_l.
      - rewrite -!andbA; apply/and4P; split; try done.
        + by apply: IHr.
        + by apply: all_delete_l.
    Qed.

    (* I want to prove them *)
    Lemma mem_delete_l x a t:
      x \in (delete_l a t) -> x \in t.
    Proof.
      elim: t x => [//=| y tl IHl tr IHr /=] x.
      case: (a =P y) => [<-{y} | /eqP Hneq].
      - remember (rend_remove tl a).
        move: p Heqp => [tl' node] Heq.
        rewrite in_bnode -orbA => /or3P [/eqP-> | Hin | Hin].
        + move: (mem_rend tl a); rewrite -rend_remove_rend -Heq /=.
          by move=> H; rewrite in_bnode; apply/orP; left.
        + rewrite in_bnode -orbA; apply/or3P; apply Or32.
          by move: (@mem_rend_remove _ x tl a); rewrite -Heq /=; apply.
        + by rewrite in_bnode -orbA; apply/or3P; apply Or33.
      - rewrite /strict_ord Hneq andbT.
        case Hord: (ord a y);
          rewrite !in_bnode -!orbA => /or3P [Heq | Hin | Hin]; apply/or3P;
            try (by apply Or33); try (by apply Or32); try (by apply Or31).
        + by apply Or32; apply: IHl.
        + by apply Or33; apply: IHr.
    Qed.

    Lemma delete_l_eq a t:
      (a \notin t) -> (delete_l a t == t).
    Proof.
      elim: t a => [//=|/= x tl IHl tr IHr] a.
      - rewrite in_bnode // !negb_or -!andbA
        => /and3P [/negbTE-> /IHl/eqP-> /IHr/eqP->].
        by rewrite if_same.
    Qed.

    Lemma size_delete_l a t:
      (size (delete_l a t) < size t)%nat -> a \in t.
    Proof.
      apply contraTT => Hnin.
      move: (delete_l_eq Hnin) => /eqP->.
      by rewrite ltnn.
    Qed.

    Fixpoint delete_r t a: btree T :=
      if t is tl -< x >- tr
      then if a == x
           then rem_root_l t
           else if ord! a x
                then (delete_r tl a) -< x >- tr
                else tl -< x >- (delete_r tr a)
      else #.

    Lemma mem_lend_remove x a t:
      x \in (lend_remove a t).2 -> x \in t.
    Proof.
      rewrite
      -{1}[t]revtree_involutive
          lend_remove_revtree swap_app_fst /= mem_revtree.
      by move=> /mem_rend_remove Hin; rewrite -mem_revtree.
    Qed.

    Lemma all_delete_r p t a:
       all p t -> all p (delete_r t a).
    Proof.
      elim: t => [//=|/= x tl IHl tr IHr].
      case: (a =P x) => [<-{x}|Hneq];
        rewrite -!andbA => /and3P [Hp Hal Har].
      - remember (lend_remove a tr).
        case: p0 Heqp0 => t x Heq /=.
        rewrite -!andbA; apply/and3P; split; try done.
        + move: (lend_remove_lend a tr) (mem_lend a tr);
          rewrite -Heq /= => <- /orP [/eqP->//|Hin].
          by move: Har => /allP; apply.
        + apply/allP => y Hin.
          move: Har => /allP; apply.
          by move: (@mem_lend_remove y a tr); rewrite -Heq; apply.
      - case: (ord! a x) => /=; rewrite -!andbA;
          apply/and3P; split; try done.
        + by apply IHl.
        + by apply IHr.
    Qed.

    Lemma bst_rem_root_l t:
      bst t -> bst (rem_root_l t).
    Proof.
      elim: t => [//=|/= x tl IHl tr IHr].
      rewrite -!andbA => /and4P [Hbl Hal Hbr Har].
      remember (lend_remove x tr).
      case: p Heqp => node t Heq /=.
      rewrite -!andbA; apply/and4P; split; try done.
      - apply/allP => y Hin.
        move: (lend_remove_lend x tr) (mem_lend x tr);
          rewrite -Heq => /= <- /orP [/eqP->|Hin'].
        + by move: Hal => /allP; apply.
        + apply ord_transitive with x.
          * by move: Hal => /allP; apply.
          * by move: Har => /allP; apply.
      - by move: (bst_lend_remove x Hbr); rewrite -Heq.
      - apply/allP => y Hin.
        move: (lend_remove_lend x tr); rewrite -Heq => /= ->.
        move: (bst_lend Hbr Har) => /allP; apply.
        by move: (@mem_lend_remove y x tr); rewrite -Heq; apply.
    Qed.

    Lemma bst_delete_r t a:
      bst t -> bst (delete_r t a).
    Proof.
      elim: t => [//=| x tl IHl tr IHr].
      move=> Hbst; move: (Hbst) => /bst_rem_root_l H /=.
      case: (a =P x) => [Heq | Hneq]; first done.
      move: Hbst => /=; rewrite -!andbA => /and4P [Hbl Hal Hbr Har].
      case Hord: (ord! a x) => /=.
      - rewrite -!andbA; apply/and4P; split; try done.
        + by apply: IHl.
        + by apply: all_delete_r.
      - rewrite -!andbA; apply/and4P; split; try done.
        + by apply: IHr.
        + by apply: all_delete_r.
    Qed.

    Lemma mem_delete_r x t a:
      x \in (delete_r t a) -> x \in t.
    Proof.
      elim: t x => [//=| y tl IHl tr IHr /=] x.
      case: (a =P y) => [<-{y} | /eqP Hneq].
      - remember (lend_remove a tr).
        move: p Heqp => [node tr'] Heq.
        rewrite in_bnode -orbA => /or3P [/eqP-> | Hin | Hin].
        + move: (mem_lend a tr); rewrite -lend_remove_lend -Heq /=.
          by move=> H; rewrite in_bnode -orbAC; apply/orP; left.
        + by rewrite in_bnode -orbA; apply/or3P; apply Or32.
        + rewrite in_bnode -orbA; apply/or3P; apply Or33.
          by move: (@mem_lend_remove x a tr); rewrite -Heq /=; apply.
      - rewrite /strict_ord Hneq andbT.
        case Hord: (ord a y);
          rewrite !in_bnode -!orbA => /or3P [Heq | Hin | Hin]; apply/or3P;
            try (by apply Or33); try (by apply Or32); try (by apply Or31).
        + by apply Or32; apply: IHl.
        + by apply Or33; apply: IHr.
    Qed.

    Lemma delete_r_eq t a:
      (a \notin t) -> (delete_r t a == t).
    Proof.
      elim: t a => [//=|/= x tl IHl tr IHr] a.
      - rewrite in_bnode // !negb_or -!andbA
        => /and3P [/negbTE-> /IHl/eqP-> /IHr/eqP->].
        by rewrite if_same.
    Qed.

    Lemma size_delete_r t a:
      (size (delete_r t a) < size t)%nat -> a \in t.
    Proof.
      apply contraTT => Hnin.
      move: (delete_r_eq Hnin) => /eqP->.
      by rewrite ltnn.
    Qed.

  End Operations.

End BinarySearchTree.

(* Eval compute in (btsort (fun x y => x < y) [::3;1;4;1;5;9;2;6]). *)
(* = [:: 1; 1; 2; 3; 4; 5; 6; 9] *)
(* : seq nat_eqType *)

(* Definition tb := ((# -< 1 >- # -< 2 >- (# -< 3 >- #)) -< 4 >- (# -< 5 >- #)). *)
(* Eval compute in (delete (fun x y => x < y) 4 tb). *)
(* Eval compute in (rend_remove 6 tb). *)
(* Eval compute in (lend_remove 0 (lend_remove 0 tb).2). *)


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2011 Sylvie Boldo
#<br />#
Copyright (C) 2010-2011 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Functions for computing the number of digits of integers and related theorems. *)

Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_float_prop.
Require Import Fcore_digits.

Section Fcalc_digits.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Theorem Zdigits_ln_beta :
  forall n,
  n <> Z0 ->
  Zdigits beta n = ln_beta beta (Z2R n).
Proof.
intros n Hn.
destruct (ln_beta beta (Z2R n)) as (e, He) ; simpl.
specialize (He (Z2R_neq _ _ Hn)).
rewrite <- Z2R_abs in He.
assert (Hd := Zdigits_correct beta n).
assert (Hd' := Zdigits_gt_0 beta n).
apply Zle_antisym ; apply (bpow_lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
rewrite <- Z2R_Zpower by omega.
now apply Z2R_le.
apply Rle_lt_trans with (1 := proj1 He).
rewrite <- Z2R_Zpower by omega.
now apply Z2R_lt.
Qed.

Theorem ln_beta_F2R_Zdigits :
  forall m e, m <> Z0 ->
  (ln_beta beta (F2R (Float beta m e)) = Zdigits beta m + e :> Z)%Z.
Proof.
intros m e Hm.
rewrite ln_beta_F2R with (1 := Hm).
apply (f_equal (fun v => Zplus v e)).
apply sym_eq.
now apply Zdigits_ln_beta.
Qed.

Theorem Zdigits_mult_Zpower :
  forall m e,
  m <> Z0 -> (0 <= e)%Z ->
  Zdigits beta (m * Zpower beta e) = (Zdigits beta m + e)%Z.
Proof.
intros m e Hm He.
rewrite <- ln_beta_F2R_Zdigits with (1 := Hm).
rewrite Zdigits_ln_beta.
rewrite Z2R_mult.
now rewrite Z2R_Zpower with (1 := He).
contradict Hm.
apply Zmult_integral_l with (2 := Hm).
apply neq_Z2R.
rewrite Z2R_Zpower with (1 := He).
apply Rgt_not_eq.
apply bpow_gt_0.
Qed.

Theorem Zdigits_Zpower :
  forall e,
  (0 <= e)%Z ->
  Zdigits beta (Zpower beta e) = (e + 1)%Z.
Proof.
intros e He.
rewrite <- (Zmult_1_l (Zpower beta e)).
rewrite Zdigits_mult_Zpower ; try easy.
apply Zplus_comm.
Qed.

Theorem Zdigits_le :
  forall x y,
  (0 <= x)%Z -> (x <= y)%Z ->
  (Zdigits beta x <= Zdigits beta y)%Z.
Proof.
intros x y Hx Hxy.
case (Z_lt_le_dec 0 x).
clear Hx. intros Hx.
rewrite 2!Zdigits_ln_beta.
apply ln_beta_le.
now apply (Z2R_lt 0).
now apply Z2R_le.
apply Zgt_not_eq.
now apply Zlt_le_trans with x.
now apply Zgt_not_eq.
intros Hx'.
rewrite (Zle_antisym _ _ Hx' Hx).
apply Zdigits_ge_0.
Qed.

Theorem lt_Zdigits :
  forall x y,
  (0 <= y)%Z ->
  (Zdigits beta x < Zdigits beta y)%Z ->
  (x < y)%Z.
Proof.
intros x y Hy.
cut (y <= x -> Zdigits beta y <= Zdigits beta x)%Z. omega.
now apply Zdigits_le.
Qed.

Theorem Zpower_le_Zdigits :
  forall e x,
  (e < Zdigits beta x)%Z ->
  (Zpower beta e <= Zabs x)%Z.
Proof.
intros e x Hex.
destruct (Zdigits_correct beta x) as (H1,H2).
apply Zle_trans with (2 := H1).
apply Zpower_le.
clear -Hex ; omega.
Qed.

Theorem Zdigits_le_Zpower :
  forall e x,
  (Zabs x < Zpower beta e)%Z ->
  (Zdigits beta x <= e)%Z.
Proof.
intros e x.
generalize (Zpower_le_Zdigits e x).
omega.
Qed.

Theorem Zpower_gt_Zdigits :
  forall e x,
  (Zdigits beta x <= e)%Z ->
  (Zabs x < Zpower beta e)%Z.
Proof.
intros e x Hex.
destruct (Zdigits_correct beta x) as (H1,H2).
apply Zlt_le_trans with (1 := H2).
now apply Zpower_le.
Qed.

Theorem Zdigits_gt_Zpower :
  forall e x,
  (Zpower beta e <= Zabs x)%Z ->
  (e < Zdigits beta x)%Z.
Proof.
intros e x Hex.
generalize (Zpower_gt_Zdigits e x).
omega.
Qed.

(** Characterizes the number digits of a product.

This strong version is needed for proofs of division and square root
algorithms, since they involve operation remainders.
*)

Theorem Zdigits_mult_strong :
  forall x y,
  (0 <= x)%Z -> (0 <= y)%Z ->
  (Zdigits beta (x + y + x * y) <= Zdigits beta x + Zdigits beta y)%Z.
Proof.
intros x y Hx Hy.
case (Z_lt_le_dec 0 x).
clear Hx. intros Hx.
case (Z_lt_le_dec 0 y).
clear Hy. intros Hy.
(* . *)
assert (Hxy: (0 < Z2R (x + y + x * y))%R).
apply (Z2R_lt 0).
change Z0 with (0 + 0 + 0)%Z.
apply Zplus_lt_compat.
now apply Zplus_lt_compat.
now apply Zmult_lt_0_compat.
rewrite 3!Zdigits_ln_beta ; try now (apply sym_not_eq ; apply Zlt_not_eq).
apply ln_beta_le_bpow with (1 := Rgt_not_eq _ _ Hxy).
rewrite Rabs_pos_eq with (1 := Rlt_le _ _ Hxy).
destruct (ln_beta beta (Z2R x)) as (ex, Hex). simpl.
specialize (Hex (Rgt_not_eq _ _ (Z2R_lt _ _ Hx))).
destruct (ln_beta beta (Z2R y)) as (ey, Hey). simpl.
specialize (Hey (Rgt_not_eq _ _ (Z2R_lt _ _ Hy))).
apply Rlt_le_trans with (Z2R (x + 1) * Z2R (y + 1))%R.
rewrite <- Z2R_mult.
apply Z2R_lt.
apply Zplus_lt_reg_r with (- (x + y + x * y + 1))%Z.
now ring_simplify.
rewrite bpow_plus.
apply Rmult_le_compat ; try (apply (Z2R_le 0) ; omega).
rewrite <- (Rmult_1_r (Z2R (x + 1))).
change (F2R (Float beta (x + 1) 0) <= bpow ex)%R.
apply F2R_p1_le_bpow.
exact Hx.
unfold F2R. rewrite Rmult_1_r.
apply Rle_lt_trans with (Rabs (Z2R x)).
apply RRle_abs.
apply Hex.
rewrite <- (Rmult_1_r (Z2R (y + 1))).
change (F2R (Float beta (y + 1) 0) <= bpow ey)%R.
apply F2R_p1_le_bpow.
exact Hy.
unfold F2R. rewrite Rmult_1_r.
apply Rle_lt_trans with (Rabs (Z2R y)).
apply RRle_abs.
apply Hey.
apply neq_Z2R.
now apply Rgt_not_eq.
(* . *)
intros Hy'.
rewrite (Zle_antisym _ _ Hy' Hy).
rewrite Zmult_0_r, 3!Zplus_0_r.
apply Zle_refl.
intros Hx'.
rewrite (Zle_antisym _ _ Hx' Hx).
rewrite Zmult_0_l, Zplus_0_r, 2!Zplus_0_l.
apply Zle_refl.
Qed.

Theorem Zdigits_mult :
  forall x y,
  (Zdigits beta (x * y) <= Zdigits beta x + Zdigits beta y)%Z.
Proof.
intros x y.
rewrite <- Zdigits_abs.
rewrite <- (Zdigits_abs _ x).
rewrite <- (Zdigits_abs _ y).
apply Zle_trans with (Zdigits beta (Zabs x + Zabs y + Zabs x * Zabs y)).
apply Zdigits_le.
apply Zabs_pos.
rewrite Zabs_Zmult.
generalize (Zabs_pos x) (Zabs_pos y).
omega.
apply Zdigits_mult_strong ; apply Zabs_pos.
Qed.

Theorem Zdigits_mult_ge :
  forall x y,
  (x <> 0)%Z -> (y <> 0)%Z ->
  (Zdigits beta x + Zdigits beta y - 1 <= Zdigits beta (x * y))%Z.
Proof.
intros x y Zx Zy.
cut ((Zdigits beta x - 1) + (Zdigits beta y - 1) < Zdigits beta (x * y))%Z. omega.
apply Zdigits_gt_Zpower.
rewrite Zabs_Zmult.
rewrite Zpower_exp.
apply Zmult_le_compat.
apply Zpower_le_Zdigits.
apply Zlt_pred.
apply Zpower_le_Zdigits.
apply Zlt_pred.
apply Zpower_ge_0.
apply Zpower_ge_0.
generalize (Zdigits_gt_0 beta x). omega.
generalize (Zdigits_gt_0 beta y). omega.
Qed.

Theorem Zdigits_div_Zpower :
  forall m e,
  (0 <= m)%Z ->
  (0 <= e <= Zdigits beta m)%Z ->
  Zdigits beta (m / Zpower beta e) = (Zdigits beta m - e)%Z.
Proof.
intros m e Hm He.
destruct (Zle_lt_or_eq 0 m Hm) as [Hm'|Hm'].
(* *)
destruct (Zle_lt_or_eq _ _ (proj2 He)) as [He'|He'].
(* . *)
unfold Zminus.
rewrite <- ln_beta_F2R_Zdigits.
2: now apply Zgt_not_eq.
assert (Hp: (0 < Zpower beta e)%Z).
apply lt_Z2R.
rewrite Z2R_Zpower with (1 := proj1 He).
apply bpow_gt_0.
rewrite Zdigits_ln_beta.
rewrite <- Zfloor_div with (1 := Zgt_not_eq _ _ Hp).
rewrite Z2R_Zpower with (1 := proj1 He).
unfold Rdiv.
rewrite <- bpow_opp.
change (Z2R m * bpow (-e))%R with (F2R (Float beta m (-e))).
destruct (ln_beta beta (F2R (Float beta m (-e)))) as (e', E').
simpl.
specialize (E' (Rgt_not_eq _ _ (F2R_gt_0_compat beta (Float beta m (-e)) Hm'))).
apply ln_beta_unique.
rewrite Rabs_pos_eq in E'.
2: now apply F2R_ge_0_compat.
rewrite Rabs_pos_eq.
split.
assert (H': (0 <= e' - 1)%Z).
(* .. *)
cut (1 <= e')%Z. omega.
apply bpow_lt_bpow with beta.
apply Rle_lt_trans with (2 := proj2 E').
simpl.
rewrite <- (Rinv_r (bpow e)).
rewrite <- bpow_opp.
unfold F2R. simpl.
apply Rmult_le_compat_r.
apply bpow_ge_0.
rewrite <- Z2R_Zpower with (1 := proj1 He).
apply Z2R_le.
rewrite <- Zabs_eq with (1 := Hm).
now apply Zpower_le_Zdigits.
apply Rgt_not_eq.
apply bpow_gt_0.
(* .. *)
rewrite <- Z2R_Zpower with (1 := H').
apply Z2R_le.
apply Zfloor_lub.
rewrite Z2R_Zpower with (1 := H').
apply E'.
apply Rle_lt_trans with (2 := proj2 E').
apply Zfloor_lb.
apply (Z2R_le 0).
apply Zfloor_lub.
now apply F2R_ge_0_compat.
apply Zgt_not_eq.
apply Zlt_le_trans with (beta^e / beta^e)%Z.
rewrite Z_div_same_full.
apply refl_equal.
now apply Zgt_not_eq.
apply Z_div_le.
now apply Zlt_gt.
rewrite <- Zabs_eq with (1 := Hm).
now apply Zpower_le_Zdigits.
(* . *)
unfold Zminus.
rewrite He', Zplus_opp_r.
rewrite Zdiv_small.
apply refl_equal.
apply conj with (1 := Hm).
pattern m at 1 ; rewrite <- Zabs_eq with (1 := Hm).
apply Zpower_gt_Zdigits.
apply Zle_refl.
(* *)
revert He.
rewrite <- Hm'.
intros (H1, H2).
simpl.
now rewrite (Zle_antisym _ _ H2 H1).
Qed.

End Fcalc_digits.

Definition radix2 := Build_radix 2 (refl_equal _).

Theorem Z_of_nat_S_digits2_Pnat :
  forall m : positive,
  Z_of_nat (S (digits2_Pnat m)) = Zdigits radix2 (Zpos m).
Proof.
intros m.
rewrite Zdigits_ln_beta. 2: easy.
apply sym_eq.
apply ln_beta_unique.
generalize (digits2_Pnat m) (digits2_Pnat_correct m).
intros d H.
simpl in H.
replace (Z_of_nat (S d) - 1)%Z with (Z_of_nat d).
rewrite <- Z2R_abs.
rewrite <- 2!Z2R_Zpower_nat.
split.
now apply Z2R_le.
now apply Z2R_lt.
rewrite inj_S.
apply Zpred_succ.
Qed.