Require Import Coq.Lists.List.
Require Import MirrorCore.Reify.Reify.
Require Import MirrorCharge.Imp.Imp.
Require Import MirrorCharge.Imp.Syntax.

Reify Declare Patterns patterns_imp_typ := Syntax.typ.

Reify Declare Patterns patterns_imp := (ExprCore.expr Syntax.typ Syntax.func).

Reify Declare Syntax reify_imp_typ :=
  { (@Patterns.CPatterns Syntax.typ patterns_imp_typ) }.

Reify Declare Typed Table term_table : BinNums.positive => reify_imp_typ.

Let Ext x := @ExprCore.Inj Syntax.typ Syntax.func (inl (inl x)).

Reify Declare Syntax reify_imp :=
  { (@Patterns.CFirst _ ((@Patterns.CVar _ (@ExprCore.Var Syntax.typ Syntax.func)) ::
                         (@Patterns.CPatterns _ patterns_imp) ::
                         (@Patterns.CApp _ (@ExprCore.App Syntax.typ Syntax.func)) ::
                         (@Patterns.CAbs _ reify_imp_typ (@ExprCore.Abs Syntax.typ Syntax.func)) ::
                         (@Patterns.CTypedTable _ _ _ term_table Ext) :: nil))
  }.

Let _Inj := @ExprCore.Inj Syntax.typ Syntax.func.

Local Notation "x @ y" := (@RApp x y) (only parsing, at level 30).
Local Notation "'!!' x" := (@RExact _ x) (only parsing, at level 25).
Local Notation "'?' n" := (@RGet n RIgnore) (only parsing, at level 25).
Local Notation "'?!' n" := (@RGet n RConst) (only parsing, at level 25).
Local Notation "'#'" := RIgnore (only parsing, at level 0).

Reify Pattern patterns_imp_typ += (@RImpl (?0) (?1)) => (fun (a b : function reify_imp_typ) => tyArr a b).
Reify Pattern patterns_imp_typ += (!! locals)  => tyLocals.
Reify Pattern patterns_imp_typ += (!! lprop)  => (tyArr tyLocals tyHProp).
Reify Pattern patterns_imp_typ += (!! icmd) => tyCmd.
Reify Pattern patterns_imp_typ += (!! SProp) => tySProp.
Reify Pattern patterns_imp_typ += (!! HProp) => tyHProp.
Reify Pattern patterns_imp_typ += (!! Prop) => tyProp.
Reify Pattern patterns_imp_typ += (!! var) => tyVariable.
Reify Pattern patterns_imp_typ += (!! function_name) => tyVariable.
Reify Pattern patterns_imp_typ += (!! iexpr) => tyExpr.
Reify Pattern patterns_imp_typ += (!! nat)  => tyNat.
Reify Pattern patterns_imp_typ += (!! value)  => tyNat.
Reify Pattern patterns_imp_typ += (!! Fun @ ?0 @ ?1) => (fun (a b : function reify_imp_typ) => tyArr a b).

Reify Pattern patterns_imp += (RHasType var (?!0)) => (fun (x : id Imp.var) => fVar x).
Reify Pattern patterns_imp += (RHasType String.string (?!0)) => (fun (x : id Imp.var) => fVar x).
Reify Pattern patterns_imp += (RHasType nat (?!0)) => (fun (x : id nat) => fConst x).
Reify Pattern patterns_imp += (!! (@eq) @ ?0) => (fun (x : function reify_imp_typ) => (fEq x)).

(** Commands **)
Reify Pattern patterns_imp += (!! Skip) => fSkip.
Reify Pattern patterns_imp += (!! Seq) => fSeq.
Reify Pattern patterns_imp += (!! Assign) => fAssign.
Reify Pattern patterns_imp += (!! Read) => fRead.
Reify Pattern patterns_imp += (!! Write) => fWrite.
(** TODO: Call **)

(** Expressions **)
Reify Pattern patterns_imp += (!! iConst) => fConst.
Reify Pattern patterns_imp += (!! iVar) => fVar.

(** Intuitionistic Operators **)
Reify Pattern patterns_imp += (!! @ILogic.lentails @ ?0 @ #) => (fun (x : function reify_imp_typ) => (_Inj (inr (ILogicFunc.ilf_entails x)))).
Reify Pattern patterns_imp += (!! @ILogic.ltrue @ ?0 @ #) => (fun (x : function reify_imp_typ) => (_Inj (inr (ILogicFunc.ilf_true x)))).
Reify Pattern patterns_imp += (!! @ILogic.lfalse @ ?0 @ #) => (fun (x : function reify_imp_typ) => (_Inj (inr (ILogicFunc.ilf_false x)))).
Reify Pattern patterns_imp += (!! @ILogic.land @ ?0 @ #) => (fun (x : function reify_imp_typ) => (_Inj (inr (ILogicFunc.ilf_and x)))).
Reify Pattern patterns_imp += (!! @ILogic.lor @ ?0 @ #) => (fun (x : function reify_imp_typ) => (_Inj (inr (ILogicFunc.ilf_or x)))).
Reify Pattern patterns_imp += (!! @ILogic.limpl @ ?0 @ #) => (fun (x : function reify_imp_typ) => (_Inj (inr (ILogicFunc.ilf_impl x)))).
Reify Pattern patterns_imp += (!! @ILogic.lexists @ ?0 @ # @ ?1) => (fun (x y : function reify_imp_typ) => (_Inj (inr (ILogicFunc.ilf_exists y x)))).
Reify Pattern patterns_imp += (!! @ILogic.lforall @ ?0 @ # @ ?1) => (fun (x y : function reify_imp_typ) => (_Inj (inr (ILogicFunc.ilf_forall y x)))).

(** Embedding Operators **)
Reify Pattern patterns_imp += (!! @ILEmbed.embed @ ?0 @ ?1 @ #) => (fun (x y : function reify_imp_typ) => (_Inj (inr (ILogicFunc.ilf_embed x y)))).

(** Special cases for Coq's primitives **)
Reify Pattern patterns_imp += (!! True) => (_Inj (inr (ILogicFunc.ilf_true tyProp))).
Reify Pattern patterns_imp += (!! False) => (_Inj (inr (ILogicFunc.ilf_false tyProp))).
Reify Pattern patterns_imp += (!! and) => (_Inj (inr (ILogicFunc.ilf_and tyProp))).
Reify Pattern patterns_imp += (!! or) => (_Inj (inr (ILogicFunc.ilf_or tyProp))).
Reify Pattern patterns_imp += (RPi (?0) (?1)) => (fun (x : function reify_imp_typ) (y : function reify_imp) =>
                                                   ExprCore.App (_Inj (inr (ILogicFunc.ilf_forall x tyProp )))
                                                                (ExprCore.Abs x y)).
Reify Pattern patterns_imp += (RImpl (?0) (?1)) => (fun (x y : function reify_imp) => ExprCore.App (ExprCore.App (_Inj (inr (ILogicFunc.ilf_impl tyProp))) x) y).

(** Separation Logic Operators **)
Reify Pattern patterns_imp += (!! @BILogic.sepSP @ ?0 @ #) => (fun (x : function reify_imp_typ) => (fStar x)).
Reify Pattern patterns_imp += (!! @BILogic.empSP @ ?0 @ #) => (fun (x : function reify_imp_typ) => (fEmp x)).

(** Program Logic **)
Reify Pattern patterns_imp += (!! triple) => fTriple.
Reify Pattern patterns_imp += (!! eval_iexpr) => feval_iexpr.
Reify Pattern patterns_imp += (!! locals_get) => flocals_get.
Reify Pattern patterns_imp += (!! locals_upd) => flocals_upd.

Reify Pattern patterns_imp += (!! PtsTo) => fPtsTo.

(** Applicative **)
Reify Pattern patterns_imp += (!! @Applicative.ap @ !! (Fun locals) @ # @ ?0 @ ?1) => (fun (x y : function reify_imp_typ) => (fAp x y)).
Reify Pattern patterns_imp += (!! @Applicative.pure @ !! (Fun locals) @ # @ ?0) => (fun (x : function reify_imp_typ) => (fPure x)).

(** Table Entries **)
Local Notation "a >> b" := (tyArr a b) (at level 31,right associativity).

Reify Seed Typed Table term_table += 1 => [ (tyLProp >> tyCmd >> tyLProp >> tySProp) , triple ].
Reify Seed Typed Table term_table += 2 => [ (tyCmd >> tyCmd >> tyCmd) , Seq ].
Reify Seed Typed Table term_table += 3 => [ (tyVariable >> tyExpr >> tyCmd) , Assign ].
Reify Seed Typed Table term_table += 4 => [ (tyVariable >> tyExpr >> tyCmd) , Read ].
Reify Seed Typed Table term_table += 5 => [ (tyExpr >> tyExpr >> tyCmd) , Write ].
Reify Seed Typed Table term_table += 6 => [ tyCmd , Skip ].
Reify Seed Typed Table term_table += 7 => [ (tyNat >> tyNat >> tyHProp) , PtsTo ].
Reify Seed Typed Table term_table += 8 => [ (tyVariable >> (tyNat >> tyLProp) >> (tyNat >> tyLProp) >> tySProp) , function_spec ].

Definition elem_ctor : forall x : Syntax.typ, (typD x) -> @SymEnv.function _ _ :=
  @SymEnv.F _ _.

Ltac reify_imp e :=
  let k fs e :=
      pose e in
  reify_expr reify_imp k
             [ (fun (y : @mk_dvar_map _ _ _ _ term_table elem_ctor) => True) ]
             [ e ].

Goal True.
  reify_imp 1.
  reify_imp Skip.
  reify_imp (ILogic.lentails True True).
  reify_imp ((True -> False) -> True).
  reify_imp (forall G P Q, ILogic.lentails G (triple P Skip Q)).
  generalize (String.EmptyString).
  intro x.
  exact I.
Defined.


(* RootHeadTail.v *)

Require Import Utf8 QArith NPeano Sorting.

Require Import Misc.
Require Import Field2.
Require Import Fpolynomial.
Require Import Fsummation.
Require Import Newton.
Require Import ConvexHull.
Require Import Power_series.
Require Import Puiseux_series.
Require Import Ps_add.
Require Import Ps_mul.
Require Import Ps_div.
Require Import PSpolynomial.
Require Import Puiseux_base.
Require Import AlgCloCharPol.
Require Import CharactPolyn.
Require Import F1Eq.
Require Import F1Prop.
Require Import Q_field.
Require Import PosOrder.
Require Import QbarM.

Set Implicit Arguments.

Definition phony_ns :=
  {| ini_pt := (0, 0); fin_pt := (0, 0); oth_pts := [] |}.

Definition option_get {A} (x : A) v :=
  match v with
  | Some v => v
  | None => x
  end.

Fixpoint nth_pol α {R : ring α} {K : field R} {acf : algeb_closed_field K}
  n f L :=
  match n with
  | 0%nat => f
  | S n₁ =>
      let c₁ := ac_root (Φq f L) in
      let f₁ := next_pol f (β L) (γ L) c₁ in
      let L₁ := option_get phony_ns (newton_segments f₁) in
      nth_pol n₁ f₁ L₁
  end.

Fixpoint nth_ns α {R : ring α} {K : field R} {acf : algeb_closed_field K}
  n f L :=
  match n with
  | 0%nat => L
  | S n₁ =>
      let c₁ := ac_root (Φq f L) in
      let f₁ := next_pol f (β L) (γ L) c₁ in
      let L₁ := option_get phony_ns (newton_segments f₁) in
      nth_ns n₁ f₁ L₁
  end.

Fixpoint nth_c α {R : ring α} {K : field R} {acf : algeb_closed_field K}
  n f L :=
  match n with
  | 0%nat => ac_root (Φq f L)
  | S n₁ =>
      let c₁ := ac_root (Φq f L) in
      let f₁ := next_pol f (β L) (γ L) c₁ in
      let L₁ := option_get phony_ns (newton_segments f₁) in
      nth_c n₁ f₁ L₁
  end.

Fixpoint nth_γ α {R : ring α} {K : field R} {acf : algeb_closed_field K}
  n f L :=
  match n with
  | 0%nat => γ L
  | S n₁ =>
      let c₁ := ac_root (Φq f L) in
      let f₁ := next_pol f (β L) (γ L) c₁ in
      let L₁ := option_get phony_ns (newton_segments f₁) in
      nth_γ n₁ f₁ L₁
  end.

Fixpoint nth_r α {R : ring α} {K : field R} {acf : algeb_closed_field K}
  n f L :=
  match n with
  | 0%nat => root_multiplicity acf (ac_root (Φq f L)) (Φq f L)
  | S n₁ =>
      let c₁ := ac_root (Φq f L) in
      let f₁ := next_pol f (β L) (γ L) c₁ in
      let L₁ := option_get phony_ns (newton_segments f₁) in
      nth_r n₁ f₁ L₁
  end.

Definition next_pow pow L₁ m :=
  let n := (γ L₁ * inject_Z (Zpos m)) in
  (pow + Z.to_nat (Qnum n / Zpos (Qden n)))%nat.

Fixpoint find_coeff α {R : ring α} {K : field R}
  {acf : algeb_closed_field K} max_iter npow m f L i :=
  match max_iter with
  | 0%nat => 0%K
  | S mx =>
      if ps_zerop _ (ps_poly_nth 0 f) then 0%K
      else
        match Nat.compare npow i with
        | Eq => ac_root (Φq f L)
        | Lt =>
            let c₁ := ac_root (Φq f L) in
            let f₁ := next_pol f (β L) (γ L) c₁ in
            let L₁ := option_get phony_ns (newton_segments f₁) in
            let npow₁ := next_pow npow L₁ m in
            find_coeff mx npow₁ m f₁ L₁ i
        | Gt => 0%K
        end
  end.

Definition root_tail_series_from_cγ_list α {R : ring α} {K : field R}
  {acf : algeb_closed_field K} m f L i :=
  find_coeff (S i) 0%nat m f L i.

Definition root_tail_from_cγ_list α {R : ring α} {K : field R}
  {acf : algeb_closed_field K} m f L :=
  {| ps_terms := {| terms := root_tail_series_from_cγ_list m f L |};
     ps_ordnum := Qnum (γ L) * Zpos m / Zpos (Qden (γ L));
     ps_polydo := m |}.

Definition γ_sum α {R : ring α} {K : field R}
  {acf : algeb_closed_field K} b n f L :=
  let qr := Q_ring in
  Σ (i = 0, n), nth_γ (b + i) f L.

Fixpoint root_head_from_cγ_list α {R : ring α} {K : field R}
  {acf : algeb_closed_field K} f L b n i :=
  (ps_monom (nth_c (b + i) f L) (γ_sum b i f L) +
   match n with
   | O => 0%ps
   | S n₁ =>
       if ps_zerop K (ps_poly_nth 0 (nth_pol (b + S i) f L)) then 0%ps
       else root_head_from_cγ_list f L b n₁ (S i)
   end)%ps.

Fixpoint zerop_1st_n_const_coeff α {R : ring α} {K : field R}
  {acf : algeb_closed_field K} n f L :=
  if ps_zerop _ (ps_poly_nth 0 f) then true
  else
    match n with
    | O => false
    | S n₁ =>
        let c₁ := ac_root (Φq f L) in
        let f₁ := next_pol f (β L) (γ L) c₁ in
        let L₁ := option_get phony_ns (newton_segments f₁) in
        zerop_1st_n_const_coeff n₁ f₁ L₁
    end.

(* Σ _(i=0,n).c_{b+i} x^Σ_(j=0,i) γ_{b+j} *)
Definition root_head α {R : ring α} {K : field R} {acf : algeb_closed_field K}
  b n f L :=
  if zerop_1st_n_const_coeff b f L then 0%ps
  else root_head_from_cγ_list f L b n 0.

(* Σ _(i=n,∞).c_i x^Σ_(j=n,i) γ_j *)
Definition root_tail α {R : ring α} {K : field R} {acf : algeb_closed_field K}
  m n f L :=
  if zerop_1st_n_const_coeff n f L then 0%ps
  else root_tail_from_cγ_list m (nth_pol n f L) (nth_ns n f L).

Section theorems.

Variable α : Type.
Variable R : ring α.
Variable K : field R.
Variable acf : algeb_closed_field K.

Theorem fold_γ_sum : ∀ b n f L,
  let qr := Q_ring in
  Σ (i = 0, n), nth_γ (b + i) f L = γ_sum b n f L.
Proof. reflexivity. Qed.

(* *)

(* f₁(x,y₁) = 0 => f(x,c₁.x^γ+x^γ.y₁) = 0 *)
Theorem f₁_root_f_root : ∀ f f₁ β γ c₁ y y₁,
  f₁ = next_pol f β γ c₁
  → (y = ps_monom c₁ γ + ps_monom 1%K γ * y₁)%ps
  → (ps_pol_apply f₁ y₁ = 0)%ps
  → (ps_pol_apply f y = 0)%ps.
Proof.
intros f f₁ β γ c₁ y y₁ Hf₁ Hy Happ.
destruct (ps_zerop K 1%ps) as [Hzo| Hnzo].
 apply eq_1_0_all_0; assumption.

 subst f₁.
 unfold next_pol in Happ.
 unfold ps_pol_apply, apply_poly in Happ; simpl in Happ.
 unfold next_lap in Happ; simpl in Happ.
 unfold ps_pol_apply, apply_poly.
 rewrite apply_lap_mul in Happ.
 rewrite apply_lap_compose in Happ.
 simpl in Happ.
 rewrite ps_mul_0_l in Happ.
 do 2 rewrite ps_add_0_l in Happ.
 rewrite ps_add_comm, <- Hy in Happ.
 apply fld_eq_mul_0_r in Happ; [ assumption | apply ps_field | idtac ].
 simpl; intros H.
 apply ps_monom_0_coeff_0 in H.
 apply Hnzo.
 unfold ps_one; rewrite H.
 apply ps_zero_monom_eq.
Qed.

Theorem exists_ini_pt_nat_fst_seg : ∀ f L,
  L = option_get phony_ns (newton_segments f)
  → ∃ i αi, ini_pt L = (Qnat i, αi).
Proof.
intros f L HL.
remember (newton_segments f) as Ll eqn:HLl .
symmetry in HLl.
destruct Ll as [L₁| ].
 simpl in HL; subst L₁.
 now eapply exists_ini_pt_nat with (f := f).

 subst L; simpl.
 exists 0%nat, 0; reflexivity.
Qed.

Theorem exists_fin_pt_nat_fst_seg : ∀ f L,
  L = option_get phony_ns (newton_segments f)
  → ∃ i αi, fin_pt L = (Qnat i, αi).
Proof.
intros f L HL.
remember (newton_segments f) as Ll eqn:HLl .
symmetry in HLl.
destruct Ll as [L₁| ].
 simpl in HL; subst L₁.
 now eapply exists_fin_pt_nat with (f := f).

 subst L; simpl.
 exists 0%nat, 0; reflexivity.
Qed.

Theorem hd_newton_segments : ∀ f L j k αj αk,
  L = option_get phony_ns (newton_segments f)
 → ini_pt L = (Qnat j, αj)
  → fin_pt L = (Qnat k, αk)
  → (j < k)%nat
  → newton_segments f = Some L.
Proof.
intros f L j k αj αk HL Hini Hfin Hjk.
remember (newton_segments f) as Ll.
symmetry in HeqLl.
destruct Ll as [L₁| ]; simpl in HL.
 subst L; reflexivity.

 subst L; simpl in Hini, Hfin.
 injection Hini; intros; subst.
 injection Hfin; intros; subst.
 rewrite <- Nat2Z.inj_0 in H0.
 rewrite <- Nat2Z.inj_0 in H1.
 apply Nat2Z.inj in H0.
 apply Nat2Z.inj in H1.
 subst j k; exfalso; revert Hjk; apply Nat.lt_irrefl.
Qed.

(* *)

Theorem nth_pol_succ : ∀ n f L f₁ L₁ c₁,
  f₁ = nth_pol n f L
  → L₁ = nth_ns n f L
  → c₁ = nth_c n f L
  → nth_pol (S n) f L = next_pol f₁ (β L₁) (γ L₁) c₁.
Proof.
intros n f L f₁ L₁ c₁ Hf₁ HL₁ Hc₁; subst.
revert f L.
induction n; intros; [ reflexivity | idtac ].
remember (S n) as sn; simpl; subst sn.
apply IHn.
Qed.

Theorem nth_pol_succ2 : ∀ f L c f₁ L₁ n,
  c = ac_root (Φq f L)
  → f₁ = next_pol f (β L) (γ L) c
  → L₁ = option_get phony_ns (newton_segments f₁)
  → nth_pol (S n) f L = nth_pol n f₁ L₁.
Proof. intros; subst; reflexivity. Qed.

Theorem nth_ns_succ : ∀ n f L f₁,
  f₁ = nth_pol (S n) f L
  → nth_ns (S n) f L = option_get phony_ns (newton_segments f₁).
Proof.
intros n f L f₁ Hf₁; subst.
revert f L.
induction n; intros; [ reflexivity | idtac ].
remember (S n) as sn; simpl; subst sn.
apply IHn.
Qed.

Theorem nth_ns_succ2 : ∀ f L c f₁ L₁ n,
  c = ac_root (Φq f L)
  → f₁ = next_pol f (β L) (γ L) c
  → L₁ = option_get phony_ns (newton_segments f₁)
  → nth_ns (S n) f L = nth_ns n f₁ L₁.
Proof. intros; subst; reflexivity. Qed.

Theorem nth_c_succ : ∀ n f L f₁ L₁,
  f₁ = nth_pol (S n) f L
  → L₁ = nth_ns (S n) f L
  → nth_c (S n) f L = ac_root (Φq f₁ L₁).
Proof.
intros n f L f₁ L₁ Hf₁ HL₁; subst.
revert f L.
induction n; intros; [ reflexivity | idtac ].
remember (S n) as sn; simpl; subst sn.
apply IHn.
Qed.

Theorem nth_r_succ2 : ∀ f L c f₁ L₁ n,
  c = ac_root (Φq f L)
  → f₁ = next_pol f (β L) (γ L) c
  → L₁ = option_get phony_ns (newton_segments f₁)
  → nth_r (S n) f L = nth_r n f₁ L₁.
Proof. intros; subst; reflexivity. Qed.

Theorem Qnum_inv_Qnat_sub : ∀ j k,
  (j < k)%nat
  → Qnum (/ (Qnat k - Qnat j)) = 1%Z.
Proof.
intros j k Hjk.
rewrite Qnum_inv; [ reflexivity | simpl ].
do 2 rewrite Z.mul_1_r.
rewrite Z.add_opp_r.
rewrite <- Nat2Z.inj_sub.
 rewrite <- Nat2Z.inj_0.
 apply Nat2Z.inj_lt.
 apply Nat.lt_add_lt_sub_r; assumption.

 apply Nat.lt_le_incl; assumption.
Qed.

Theorem Qden_inv_Qnat_sub : ∀ j k,
  (j < k)%nat
  → Qden (/ (Qnat k - Qnat j)) = Pos.of_nat (k - j).
Proof.
intros j k Hjk.
apply Pos2Z.inj.
rewrite Qden_inv.
 simpl.
 do 2 rewrite Z.mul_1_r.
 symmetry.
 rewrite <- positive_nat_Z; simpl.
 rewrite Nat2Pos.id.
  rewrite Nat2Z.inj_sub; [ | apply Nat.lt_le_incl; assumption ].
  reflexivity.

  intros H.
  apply Nat.sub_0_le in H.
  apply Nat.nlt_ge in H; contradiction.

 simpl.
 do 2 rewrite Z.mul_1_r.
 rewrite Z.add_opp_r.
 rewrite <- Nat2Z.inj_sub.
  rewrite <- Nat2Z.inj_0.
  apply Nat2Z.inj_lt.
  apply Nat.lt_add_lt_sub_r; assumption.

  apply Nat.lt_le_incl; assumption.
Qed.

Theorem num_m_den_is_pos : ∀ f L j αj m,
  newton_segments f = Some L
  → pol_in_K_1_m f m
  → ini_pt L = (Qnat j, αj)
  → (0 < Qnum αj)%Z
  → (0 < Z.to_nat (Qnum αj * Zpos m / Zpos (Qden αj)))%nat.
Proof.
intros f L j αj m HL Hm Hini Hn.
assert (Zpos (Qden αj) | Qnum αj * Zpos m)%Z as H.
 eapply den_αj_divides_num_αj_m; eassumption.

 destruct H as (d, Hd).
 rewrite Hd.
 rewrite Z.div_mul; [ | apply Pos2Z_ne_0 ].
 destruct d as [| d| d].
  simpl in Hd.
  apply Z.eq_mul_0_l in Hd; [ | apply Pos2Z_ne_0 ].
  rewrite Hd in Hn.
  exfalso; revert Hn; apply Z.lt_irrefl.

  apply Pos2Nat.is_pos.

  simpl in Hd.
  pose proof (Pos2Z.neg_is_neg (d * Qden αj)) as I.
  rewrite <- Hd in I.
  apply Z.nle_gt in I.
  exfalso; apply I.
  apply Z.mul_nonneg_nonneg; [ | apply Pos2Z.is_nonneg].
  apply Z.lt_le_incl; assumption.
Qed.

Theorem next_pow_add : ∀ p q L m,
  next_pow (p + q) L m = (next_pow p L m + q)%nat.
Proof.
intros p q L m.
unfold next_pow.
rewrite Nat.add_shuffle0; reflexivity.
Qed.

Theorem find_coeff_add : ∀ f L m mx p dp i,
  (find_coeff mx (p + dp) m f L (i + dp) =
   find_coeff mx p m f L i)%K.
Proof.
intros f L m mx p dp i.
revert f L m p dp i.
induction mx; intros; [ reflexivity | simpl ].
destruct (ps_zerop K (ps_poly_nth 0 f)) as [| H₁]; [ reflexivity | ].
rewrite <- Nat_compare_add.
remember (Nat.compare p i) as cmp eqn:Hcmp .
symmetry in Hcmp.
destruct cmp; [ reflexivity | | reflexivity ].
rewrite next_pow_add.
apply IHmx.
Qed.

Theorem zerop_1st_n_const_coeff_succ : ∀ f L n,
  zerop_1st_n_const_coeff (S n) f L =
  zerop_1st_n_const_coeff 0 f L ||
  zerop_1st_n_const_coeff n (nth_pol 1 f L) (nth_ns 1 f L).
Proof.
intros f L n; simpl.
destruct (ps_zerop K (ps_poly_nth 0 f)); reflexivity.
Qed.

Theorem zerop_1st_n_const_coeff_succ2 : ∀ f L n,
  zerop_1st_n_const_coeff (S n) f L =
  zerop_1st_n_const_coeff n f L ||
  zerop_1st_n_const_coeff 0 (nth_pol (S n) f L) (nth_ns (S n) f L).
Proof.
intros f L n.
revert f L.
induction n; intros.
 simpl.
 destruct (ps_zerop K (ps_poly_nth 0 f)); reflexivity.

 remember (S n) as sn; simpl.
 destruct (ps_zerop K (ps_poly_nth 0 f)) as [H₁| H₁].
  rewrite Heqsn in |- * at 1; simpl.
  destruct (ps_zerop K (ps_poly_nth 0 f)); [ | contradiction ].
  symmetry; apply Bool.orb_true_l.

  remember (ac_root (Φq f L)) as c₁ eqn:Hc₁ .
  remember (next_pol f (β L) (γ L) c₁) as f₁ eqn:Hf₁ .
  remember (option_get phony_ns (newton_segments f₁)) as L₁ eqn:HL₁ .
  rewrite IHn; simpl.
  remember (nth_pol sn f₁ L₁) as fn eqn:Hfn .
  destruct (ps_zerop K (ps_poly_nth 0 fn)) as [H₂| H₂].
   do 2 rewrite Bool.orb_true_r; reflexivity.

   do 2 rewrite Bool.orb_false_r.
   subst sn; simpl.
   destruct (ps_zerop K (ps_poly_nth 0 f)); [ contradiction | ];
   subst; reflexivity.
Qed.

Theorem zerop_1st_n_const_coeff_false_iff : ∀ f L n,
  zerop_1st_n_const_coeff n f L = false
  ↔ ∀ i : nat, i ≤ n → (ps_poly_nth 0 (nth_pol i f L) ≠ 0)%ps.
Proof.
intros f L n.
split; intros H.
 intros i Hin.
 revert f L i H Hin.
 induction n; intros.
  simpl in H.
  apply Nat.le_0_r in Hin; subst i.
  destruct (ps_zerop K (ps_poly_nth 0 f)); auto.
  discriminate H.

  simpl in H.
  destruct (ps_zerop K (ps_poly_nth 0 f)) as [H₁| H₁].
   discriminate H.

   destruct i; auto; simpl.
   apply IHn; auto.
   apply Nat.succ_le_mono; assumption.

 revert f L H.
 induction n; intros; simpl.
  destruct (ps_zerop K (ps_poly_nth 0 f)) as [H₁| H₁]; auto.
  pose proof (H O (Nat.le_refl 0)) as H₂.
  contradiction.

  destruct (ps_zerop K (ps_poly_nth 0 f)) as [H₁| H₁].
   pose proof (H O (Nat.le_0_l (S n))) as H₂.
   contradiction.

   apply IHn; intros i Hin.
   apply Nat.succ_le_mono, H in Hin; assumption.
Qed.

Theorem nth_c_n : ∀ f₁ L₁ fn Ln n,
  fn = nth_pol n f₁ L₁
  → Ln = nth_ns n f₁ L₁
  → nth_c n f₁ L₁ = ac_root (Φq fn Ln).
Proof.
intros f₁ L₁ fn Ln n Hfn HLn.
revert f₁ L₁ fn Ln Hfn HLn.
induction n; intros.
 simpl in Hfn, HLn; simpl.
 subst fn Ln; reflexivity.

 simpl in Hfn, HLn; simpl.
 remember (ac_root (Φq f₁ L₁)) as c₁ eqn:Hc₁ .
 remember (next_pol f₁ (β L₁) (γ L₁) c₁) as f₂ eqn:Hf₂ .
 remember (option_get phony_ns (newton_segments f₂)) as L₂ eqn:HL₂ .
 apply IHn; assumption.
Qed.

Theorem nth_pol_n : ∀ f L c f₁ L₁ fn Ln cn n,
  c = ac_root (Φq f L)
  → f₁ = next_pol f (β L) (γ L) c
  → L₁ = option_get phony_ns (newton_segments f₁)
  → fn = nth_pol n f L
  → Ln = nth_ns n f L
  → cn = ac_root (Φq fn Ln)
  → nth_pol n f₁ L₁ = next_pol fn (β Ln) (γ Ln) cn.
Proof.
intros f₁ L₁ c₁ f₂ L₂ fn Ln cn n.
intros Hc₁ Hf₂ HL₂ Hfn HLn Hcn.
revert f₁ L₁ c₁ f₂ L₂ fn Ln cn Hc₁ Hf₂ HL₂ Hfn HLn Hcn.
induction n; intros.
 simpl in Hfn, HLn; simpl.
 subst fn Ln f₂ c₁ cn; reflexivity.

 simpl in Hfn, HLn; simpl.
 remember (ac_root (Φq f₂ L₂)) as c₂ eqn:Hc₂ .
 remember (next_pol f₂ (β L₂) (γ L₂) c₂) as f₃ eqn:Hf₃ .
 remember (option_get phony_ns (newton_segments f₃)) as L₃ eqn:HL₃ .
 rewrite <- Hc₁, <- Hf₂, <- HL₂ in Hfn, HLn.
 eapply IHn; eauto .
Qed.

Theorem nth_ns_n : ∀ f L c f₁ L₁ fn Ln cn nfn n,
  c = ac_root (Φq f L)
  → f₁ = next_pol f (β L) (γ L) c
  → L₁ = option_get phony_ns (newton_segments f₁)
  → fn = nth_pol n f L
  → Ln = nth_ns n f L
  → cn = ac_root (Φq fn Ln)
  → nfn = next_pol fn (β Ln) (γ Ln) cn
  → nth_ns n f₁ L₁ = option_get phony_ns (newton_segments nfn).
Proof.
intros f L c f₁ L₁ fn Ln cn nfn n.
intros Hc Hf₁ HL₁ Hfn HLn Hcn Hnfn.
revert f L c f₁ L₁ fn Ln cn nfn Hc Hf₁ HL₁ Hfn HLn Hcn
 Hnfn.
induction n; intros.
 simpl in Hfn, HLn; simpl.
 subst fn Ln nfn f₁ L₁ c cn.
 reflexivity.

 simpl in Hfn, HLn; simpl.
 rewrite <- Hc, <- Hf₁, <- HL₁ in Hfn, HLn.
 remember (ac_root (Φq f₁ L₁)) as c₁ eqn:Hc₁ .
 remember (next_pol f₁ (β L₁) (γ L₁) c₁) as f₂ eqn:Hf₂ .
 remember (option_get phony_ns (newton_segments f₂)) as L₂.
 rename HeqL₂ into HL₂.
 eapply IHn with (c := c₁); eauto .
Qed.

Theorem nth_r_n : ∀ f L f₁ L₁ c₁ n,
  f₁ = nth_pol n f L
  → L₁ = nth_ns n f L
  → c₁ = nth_c n f L
  → nth_r n f L = root_multiplicity acf c₁ (Φq f₁ L₁).
Proof.
intros f L f₁ L₁ c₁ n Hf₁ HL₁ Hc₁.
revert f L f₁ L₁ c₁ Hf₁ HL₁ Hc₁.
induction n; intros; [ subst; reflexivity | simpl ].
apply IHn; subst; reflexivity.
Qed.

Theorem nth_γ_n : ∀ f L n Ln jn αjn kn αkn,
  Ln = nth_ns n f L
  → ini_pt Ln = (jn, αjn)
  → fin_pt Ln = (kn, αkn)
  → nth_γ n f L = (αjn - αkn) / (kn - jn).
Proof.
intros f L n Ln jm αjn kn αkn HLn Hini Hfin.
revert f L Ln jm αjn kn αkn HLn Hini Hfin.
induction n; intros.
 simpl in HLn; simpl.
 subst Ln; unfold γ; simpl.
 rewrite Hini, Hfin; simpl.
 reflexivity.

 simpl in HLn; simpl.
 eapply IHn; eauto .
Qed.

Theorem zerop_1st_n_const_coeff_true_if : ∀ f L b,
  zerop_1st_n_const_coeff b f L = true
  → ∀ n, zerop_1st_n_const_coeff (b + n) f L = true.
Proof.
intros f L b Hz n.
revert f L Hz n.
induction b; intros.
 simpl.
 revert f L Hz.
 induction n; intros; auto.
 simpl in Hz; simpl.
 destruct (ps_zerop K (ps_poly_nth 0 f)); auto.
 discriminate Hz.

 simpl in Hz; simpl.
 destruct (ps_zerop K (ps_poly_nth 0 f)); auto.
Qed.

Theorem root_head_from_cγ_list_succ : ∀ f L b n i,
  zerop_1st_n_const_coeff (b + i) f L = false
  → (root_head_from_cγ_list f L b (S n) i =
     root_head_from_cγ_list f L b n i +
      (if zerop_1st_n_const_coeff (b + i + S n) f L then 0
       else
         ps_monom (nth_c (b + i + S n) f L)
           (γ_sum b (i + S n) f L)))%ps.
Proof.
intros f L b n i Hz; simpl.
revert b i Hz.
induction n; intros; simpl.
 symmetry; rewrite rng_add_0_r; symmetry.
 rewrite Nat.add_1_r.
 remember (zerop_1st_n_const_coeff (S (b + i)) f L) as z₁ eqn:Hz₁ .
 symmetry in Hz₁.
 rewrite Nat.add_succ_r.
 destruct z₁.
  rewrite zerop_1st_n_const_coeff_succ2 in Hz₁.
  rewrite Hz, Bool.orb_false_l in Hz₁.
  remember (nth_pol (S (b + i)) f L) as p.
  simpl in Hz₁.
  destruct (ps_zerop K (ps_poly_nth 0 p)) as [H₂| H₂]; subst p.
   reflexivity.

   discriminate Hz₁.

  apply zerop_1st_n_const_coeff_false_iff with (i := S (b + i)) in Hz₁.
   remember (nth_pol (S (b + i)) f L) as p.
   destruct (ps_zerop K (ps_poly_nth 0 p)) as [H₂| H₂]; subst p.
    contradiction.

    rewrite rng_add_0_r, Nat.add_1_r; reflexivity.

   reflexivity.

 rewrite <- rng_add_assoc; simpl.
 apply rng_add_compat_l; simpl.
 remember (nth_pol (b + S i) f L) as p.
 destruct (ps_zerop K (ps_poly_nth 0 p)) as [H₁| H₁]; subst p.
  rewrite rng_add_0_l.
  remember (zerop_1st_n_const_coeff (b + i + S (S n)) f L) as z₁ eqn:Hz₁ .
  symmetry in Hz₁.
  destruct z₁; [ reflexivity | idtac ].
  rewrite zerop_1st_n_const_coeff_false_iff in Hz₁.
  assert (b + S i ≤ b + i + S (S n)) as H by fast_omega .
  apply Hz₁ in H; contradiction.

  rewrite IHn.
   do 7 rewrite Nat.add_succ_r; rewrite Nat.add_succ_l.
   reflexivity.

   rewrite Nat.add_succ_r.
   rewrite zerop_1st_n_const_coeff_succ2.
   rewrite Hz, Bool.orb_false_l.
   rewrite <- Nat.add_succ_r.
   apply zerop_1st_n_const_coeff_false_iff.
   intros j Hj.
   apply Nat.le_0_r in Hj; subst j.
   assumption.
Qed.

Theorem root_head_succ : ∀ f L b n,
  zerop_1st_n_const_coeff b f L = false
  → (root_head b (S n) f L =
     root_head b n f L +
     if zerop_1st_n_const_coeff (b + S n) f L then 0
     else ps_monom (nth_c (b + S n) f L) (γ_sum b (S n) f L))%ps.
Proof.
intros f L b n Hz.
unfold root_head; rewrite Hz.
rewrite root_head_from_cγ_list_succ.
 rewrite Nat.add_0_r, Nat.add_0_l.
 reflexivity.

 rewrite Nat.add_0_r; assumption.
Qed.

Theorem root_head_from_cγ_list_succ_r : ∀ f L f₁ L₁ c n i,
  c = ac_root (Φq f L)
  → f₁ = next_pol f (β L) (γ L) c
  → L₁ = option_get phony_ns (newton_segments f₁)
  → zerop_1st_n_const_coeff n f₁ L₁ = false
  → (ps_poly_nth 0 f₁ ≠ 0)%ps
  → (root_head_from_cγ_list f L 0 n (S i) =
      ps_monom 1%K (γ L) * root_head_from_cγ_list f₁ L₁ 0 n i)%ps.
Proof.
intros f L f₁ L₁ c n i Hc Hf₁ HL₁ Hnz Hnz₁.
revert f L f₁ L₁ c i Hc Hf₁ HL₁ Hnz Hnz₁.
induction n; intros.
 simpl.
 unfold γ_sum; simpl.
 rewrite summation_split_first; [ idtac | apply Nat.le_0_l ].
 rewrite summation_shift; [ idtac | apply le_n_S, Nat.le_0_l ].
 rewrite Nat_sub_succ_1.
 do 2 rewrite rng_add_0_r; simpl.
 rewrite <- Hc, <- Hf₁, <- HL₁.
 rewrite rng_add_comm.
 rewrite ps_monom_add_r.
 apply ps_mul_comm.

 simpl in Hnz.
 destruct (ps_zerop K (ps_poly_nth 0 f₁)) as [H₁| H₁].
  discriminate Hnz.

  remember (S i) as si; simpl.
  rewrite <- Hc, <- Hf₁, <- HL₁.
  subst si; simpl.
  rewrite <- Hc, <- Hf₁, <- HL₁.
  remember (ac_root (Φq f₁ L₁)) as c₁ eqn:Hc₁ .
  remember (next_pol f₁ (β L₁) (γ L₁) c₁) as f₂ eqn:Hf₂ .
  remember (option_get phony_ns (newton_segments f₂)) as L₂.
  unfold γ_sum; simpl.
  rewrite summation_split_first; [ idtac | apply Nat.le_0_l ].
  rewrite summation_shift; [ idtac | apply le_n_S, Nat.le_0_l ].
  rewrite Nat_sub_succ_1.
  destruct (ps_zerop K (ps_poly_nth 0 (nth_pol i f₂ L₂))) as [H₂| H₂].
   do 2 rewrite rng_add_0_r.
   rewrite rng_add_comm.
   rewrite ps_monom_add_r; simpl.
   rewrite <- Hc, <- Hf₁, <- HL₁.
   apply ps_mul_comm.

   simpl.
   rewrite <- Hc, <- Hf₁, <- HL₁.
   rewrite ps_mul_add_distr_l.
   apply rng_add_compat.
    rewrite rng_add_comm; simpl.
    rewrite ps_monom_add_r.
    apply ps_mul_comm.

    apply IHn with (c := c); auto.
    rewrite zerop_1st_n_const_coeff_false_iff in Hnz.
    apply zerop_1st_n_const_coeff_false_iff.
    clear i H₂.
    intros i Hin.
    destruct i; [ assumption | simpl ].
    rewrite <- Hc₁, <- Hf₂, <- HeqL₂.
    apply Hnz, Nat.lt_le_incl; auto.
Qed.

Theorem apply_nth_pol : ∀ f L y n,
  let qr := Q_ring in
  zerop_1st_n_const_coeff n f L = false
  → (ps_pol_apply f
       (root_head 0 n f L + ps_monom 1%K (γ_sum 0 n f L) * y) =
     ps_monom 1%K (Σ (i = 0, n), β (nth_ns i f L)) *
     ps_pol_apply (nth_pol (S n) f L) y)%ps.
Proof.
intros; revert H; intros Hnz.
revert f L y Hnz.
induction n; intros.
 unfold root_head; simpl.
 unfold γ_sum, summation; simpl.
 unfold next_pol; simpl.
 unfold ps_pol_apply; simpl.
 unfold apply_poly; simpl.
 unfold next_lap; simpl.
 remember (ac_root (Φq f L)) as c eqn:Hc .
 rewrite apply_lap_mul; simpl.
 rewrite rng_mul_0_l, rng_add_0_l.
 symmetry; rewrite rng_add_0_r; symmetry.
 rewrite rng_mul_assoc; simpl.
 rewrite <- ps_monom_add_r.
 rewrite rng_add_opp_r; simpl.
 rewrite ps_mul_1_l.
 rewrite apply_lap_compose; simpl.
 rewrite rng_mul_0_l, rng_add_0_l.
 simpl in Hnz.
 destruct (ps_zerop K (ps_poly_nth 0 f)) as [H₁| H₁].
  discriminate Hnz.

  do 2 rewrite rng_add_0_r.
  rewrite rng_add_comm; reflexivity.

 simpl in Hnz.
 destruct (ps_zerop K (ps_poly_nth 0 f)) as [H₁| H₁].
  discriminate Hnz.

  rewrite summation_split_first; [ idtac | apply Nat.le_0_l ].
  rewrite summation_shift; [ idtac | apply le_n_S, Nat.le_0_l ].
  rewrite Nat_sub_succ_1.
  remember (S n) as sn in |- *; simpl.
  remember (ac_root (Φq f L)) as c eqn:Hc .
  remember (next_pol f (β L) (γ L) c) as f₁ eqn:Hf₁ .
  remember (option_get phony_ns (newton_segments f₁)) as L₁ eqn:HL₁ .
  rewrite ps_monom_add_r.
  rewrite <- rng_mul_assoc.
  subst sn; simpl.
  erewrite nth_pol_n with (f := f₁) (L := L₁); eauto .
  erewrite <- nth_pol_succ; eauto ; [ idtac | erewrite nth_c_n; eauto  ].
  remember (S n) as sn in |- *; simpl.
  unfold root_head; simpl.
  destruct (ps_zerop K (ps_poly_nth 0 f)) as [H₂| H₂].
   contradiction.

   clear H₂.
   rewrite Heqsn in |- * at 1; simpl.
   rewrite <- Hc, <- Hf₁.
   destruct (ps_zerop K (ps_poly_nth 0 f₁)) as [H₂| H₂].
    rewrite zerop_1st_n_const_coeff_false_iff in Hnz.
    pose proof (Hnz O (Nat.le_0_l n)) as H; contradiction.

    subst sn.
    rewrite <- IHn; auto.
    unfold root_head; simpl.
    destruct (ps_zerop K (ps_poly_nth 0 f₁)) as [H₃| H₃].
     contradiction.

     clear H₃.
     unfold γ_sum at 1, summation; simpl.
     rewrite rng_add_0_r.
     unfold γ_sum.
     rewrite summation_split_first; [ idtac | apply Nat.le_0_l ].
     rewrite summation_shift; [ idtac | apply le_n_S, Nat.le_0_l ].
     rewrite Nat_sub_succ_1; simpl.
     rewrite <- Hc, <- Hf₁, <- HL₁.
     rewrite ps_monom_add_r.
     remember Σ (i = 0, n), nth_γ i f₁ L₁ as sγ eqn:Hsγ .
     rewrite <- ps_mul_assoc.
     remember (ps_monom 1%K sγ * y)%ps as u eqn:Hu .
     rewrite Hf₁ in |- * at 1; simpl.
     unfold next_pol; simpl.
     unfold ps_pol_apply; simpl.
     unfold apply_poly; simpl.
     unfold next_lap; simpl.
     rewrite apply_lap_mul; simpl.
     rewrite rng_mul_0_l, rng_add_0_l.
     rewrite rng_mul_assoc; simpl.
     rewrite <- ps_monom_add_r.
     rewrite rng_add_opp_r; simpl.
     rewrite ps_mul_1_l.
     rewrite apply_lap_compose; simpl.
     rewrite rng_mul_0_l, rng_add_0_l.
     symmetry; rewrite ps_add_comm; symmetry.
     rewrite ps_mul_add_distr_l.
     rewrite ps_add_assoc.
     rewrite root_head_from_cγ_list_succ_r; eauto .
     reflexivity.
Qed.

Theorem summation_all_lt : ∀ f n x,
  let qr := Q_ring in
  (∀ i : nat, i ≤ n → x < f i)
  → x * Qnat (S n) < Σ (i = 0, n), f i.
Proof.
intros f n x qr Hi.
induction n.
 unfold Qnat, summation; simpl.
 rewrite rng_add_0_r.
 rewrite rng_mul_1_r.
 apply Hi; reflexivity.

 rewrite summation_split_last; [ simpl | apply Nat.le_0_l ].
 rewrite Qnat_succ.
 apply Qplus_lt_le_compat.
  apply IHn.
  intros i Hin; apply Hi.
  apply Nat.le_le_succ_r; auto.

  apply Qlt_le_weak.
  apply Hi; reflexivity.
Qed.

Theorem order_pol_apply_nonneg : ∀ f y,
  (∀ a, a ∈ al f → (0 ≤ order a)%Qbar)
  → (0 ≤ order y)%Qbar
  → (0 ≤ order (ps_pol_apply f y))%Qbar.
Proof.
intros f y Ha Hy.
unfold ps_pol_apply, apply_poly.
remember (al f) as la; clear Heqla.
induction la as [| a]; intros; simpl.
 rewrite order_0; constructor.

 eapply Qbar.le_trans; [ idtac | apply order_add ].
 rewrite order_mul; auto.
 apply Qbar.min_glb.
  eapply Qbar.le_trans; eauto .
  rewrite Qbar.add_comm.
  apply Qbar.le_sub_le_add_l.
  rewrite Qbar.sub_diag.
  apply IHla.
  intros b Hb.
  apply Ha; right; assumption.

  apply Ha; left; reflexivity.
Qed.

Theorem eq_1_0_ps_0 : (1 = 0)%K → ∀ a, (a = 0)%ps.
Proof.
intros H a.
apply order_inf.
unfold order.
remember (series_order (ps_terms a) 0) as v eqn:Hv .
symmetry in Hv.
destruct v as [v| ]; auto.
apply series_order_iff in Hv.
destruct Hv as (_, Hv).
exfalso; apply Hv; simpl.
apply eq_1_0_all_0; assumption.
Qed.

Fixpoint lowest_with_zero_1st_const_coeff n f L :=
  match n with
  | O => O
  | S n' =>
      if ps_zerop _ (ps_poly_nth 0 f) then O
      else
        let f₁ := next_pol f (β L) (γ L) (ac_root (Φq f L)) in
        let L₁ := option_get phony_ns (newton_segments f₁) in
        S (lowest_with_zero_1st_const_coeff n' f₁ L₁)
  end.

Theorem lowest_zerop_1st_n_const_coeff : ∀ f L n,
  zerop_1st_n_const_coeff n f L = true
  → ∃ i, i = lowest_with_zero_1st_const_coeff n f L ∧
    i ≤ n ∧
    (i = O ∨ zerop_1st_n_const_coeff (pred i) f L = false) ∧
    zerop_1st_n_const_coeff i f L = true.
Proof.
intros f L n Hz.
remember (lowest_with_zero_1st_const_coeff n f L) as i eqn:Hi.
exists i; split; [ reflexivity | ].
revert f L i Hz Hi.
induction n; intros.
 simpl in Hi; subst i.
 split; [ reflexivity |  ].
 split; [ left; reflexivity | assumption ].

 simpl in Hi, Hz.
 remember (ps_zerop K (ps_poly_nth 0 f)) as t eqn:Ht .
 destruct t as [t| t].
  subst i.
  split; [ apply Nat.le_0_l |  ].
  split; [ left; reflexivity | simpl; rewrite <- Ht; reflexivity ].

  destruct i; [ discriminate Hi |  ].
  remember (ac_root (Φq f L)) as c eqn:Hc .
  remember (next_pol f (β L) (γ L) c) as f₁ eqn:Hf₁ ; subst c.
  remember (option_get phony_ns (newton_segments f₁)) as L₁ eqn:HL₁ .
  apply Nat.succ_inj in Hi.
  pose proof (IHn f₁ L₁ i Hz Hi) as H.
  destruct H as (Hin, (Hip, Hii)).
  split; [ rewrite <- Nat.succ_le_mono; assumption | simpl ].
  destruct Hip as [Hip| Hip].
   split; [ right; simpl |  ].
    subst i; simpl.
    rewrite Hip; simpl.
    rewrite <- Ht; reflexivity.

    rewrite <- Ht, <- Hf₁, <- HL₁; assumption.

   split; [ right; simpl |  ].
    destruct i; simpl; [ rewrite <- Ht; reflexivity |  ].
    rewrite <- Ht, <- Hf₁, <- HL₁; assumption.

    rewrite <- Ht, <- Hf₁, <- HL₁; assumption.
Qed.

Theorem first_null_coeff : ∀ f₁ L₁ i a₁ la₁,
  zerop_1st_n_const_coeff i f₁ L₁ = false
  → zerop_1st_n_const_coeff (S i) f₁ L₁ = true
  → al (nth_pol (S i) f₁ L₁) = [a₁ … la₁]
  → (a₁ = 0)%ps.
Proof.
intros f₁ L₁ i a₁ la₁ Hnz₁ Hz₁ Hla₁.
revert f₁ L₁ a₁ la₁ Hnz₁ Hz₁ Hla₁.
induction i; intros.
 simpl in Hnz₁, Hz₁, Hla₁.
 destruct (ps_zerop K (ps_poly_nth 0 f₁)) as [H₁| H₁].
  discriminate Hnz₁.

  remember (ac_root (Φq f₁ L₁)) as c₁ eqn:Hc₁ .
  remember (next_pol f₁ (β L₁) (γ L₁) c₁) as f₂ eqn:Hf₂ .
  remember (option_get phony_ns (newton_segments f₂)) as L₂ eqn:HL₂ .
  destruct (ps_zerop K (ps_poly_nth 0 f₂)) as [H₂| H₂].
   unfold ps_poly_nth, ps_lap_nth in H₂; simpl in H₂.
   unfold next_pol in Hf₂.
   rewrite Hla₁ in Hf₂.
   rewrite Hf₂ in H₂; simpl in H₂.
   assumption.

   discriminate Hz₁.

 remember (S i) as si; simpl in Hz₁, Hla₁; subst si.
 simpl in Hnz₁.
 destruct (ps_zerop K (ps_poly_nth 0 f₁)) as [H₁| H₁].
  discriminate Hnz₁.

  remember (ac_root (Φq f₁ L₁)) as c₁ eqn:Hc₁ .
  remember (next_pol f₁ (β L₁) (γ L₁) c₁) as f₂ eqn:Hf₂ .
  remember (option_get phony_ns (newton_segments f₂)) as L₂ eqn:HL₂ .
  eapply IHi; eauto .
Qed.

Theorem a₀_0_root_0 : ∀ f,
  (ps_poly_nth 0 f = 0)%ps
  → (ps_pol_apply f 0 = 0)%ps.
Proof.
intros f H.
unfold ps_pol_apply, apply_poly, apply_lap; simpl.
unfold ps_poly_nth in H.
destruct (al f) as [| a la]; [ reflexivity | simpl ].
unfold ps_lap_nth in H; simpl in H.
rewrite rng_mul_0_r, rng_add_0_l; assumption.
Qed.

Theorem root_when_fin : ∀ f L n,
  zerop_1st_n_const_coeff (pred n) f L = false
  → zerop_1st_n_const_coeff n f L = true
  → (ps_pol_apply f (root_head 0 (pred n) f L) = 0)%ps.
Proof.
intros f L n Hnz Hz.
destruct n.
 rewrite Nat.pred_0 in Hnz.
 rewrite Hnz in Hz; discriminate Hz.

 rewrite Nat.pred_succ in Hnz.
 rewrite Nat.pred_succ.
 remember Hnz as H; clear HeqH.
 eapply apply_nth_pol with (y := 0%ps) in H.
 rewrite rng_mul_0_r, rng_add_0_r in H; rewrite H.
 unfold ps_pol_apply, apply_poly.
 remember (S n) as sn.
 unfold apply_lap; simpl.
 remember (al (nth_pol sn f L)) as la eqn:Hla .
 symmetry in Hla.
 destruct la as [| a]; simpl.
  rewrite rng_mul_0_r; reflexivity.

  rewrite rng_mul_0_r, rng_add_0_l; subst sn.
  rewrite first_null_coeff with (a₁ := a); eauto .
  rewrite rng_mul_0_r; reflexivity.
Qed.

Theorem no_newton_segments : ∀ f,
  (ps_poly_nth 0 f ≠ 0)%ps
  → newton_segments f = None
  → (∀ i, (0 < i)%nat → (ps_poly_nth i f = 0)%ps).
Proof.
(* perhaps simplifiable *)
intros f Hnz HL i Hi.
destruct i; [ exfalso; revert Hi; apply Nat.lt_irrefl | idtac ].
clear Hi.
unfold newton_segments in HL.
unfold lower_convex_hull_points in HL.
unfold points_of_ps_polynom in HL.
unfold points_of_ps_lap in HL.
remember (al f) as la eqn:Hla .
symmetry in Hla.
unfold ps_poly_nth.
unfold ps_poly_nth in Hnz.
rewrite Hla in Hnz; rewrite Hla.
clear f Hla.
unfold points_of_ps_lap_gen in HL.
unfold qpower_list in HL.
remember (pair_rec (λ pow ps, (Qnat pow, ps))) as f.
unfold ps_lap_nth in Hnz.
unfold ps_lap_nth.
revert la Hnz HL.
induction i; intros.
 destruct la as [| a].
  exfalso; apply Hnz; reflexivity.

  simpl in Hnz; simpl.
  simpl in HL.
  remember (f (O, a)) as fa.
  rewrite Heqf in Heqfa.
  simpl in Heqfa.
  unfold pair_rec in Heqfa; simpl in Heqfa.
  subst fa; simpl in HL.
  apply order_fin in Hnz.
  remember (order a) as oa.
  symmetry in Heqoa.
  destruct oa as [oa| ]; [ idtac | exfalso; apply Hnz; reflexivity ].
  simpl in HL.
  remember (filter_finite_ord (List.map f (power_list 1 la))) as pts.
  symmetry in Heqpts.
  destruct pts; [ idtac | discriminate HL ].
  clear HL Hnz.
  destruct la as [| b]; [ reflexivity | simpl ].
  simpl in Heqpts.
  remember (f (1%nat, b)) as fb.
  rewrite Heqf in Heqfb.
  unfold pair_rec in Heqfb.
  simpl in Heqfb.
  subst fb; simpl in Heqpts.
  remember (order b) as ob.
  symmetry in Heqob.
  destruct ob as [ob| ]; auto.
   discriminate Heqpts.

   apply order_inf; assumption.

 destruct la as [| a]; [ reflexivity | simpl ].
 simpl in Hnz.
 simpl in HL.
 remember (f (O, a)) as fa.
 rewrite Heqf in Heqfa.
 simpl in Heqfa.
 unfold pair_rec in Heqfa; simpl in Heqfa.
 subst fa; simpl in HL.
 apply order_fin in Hnz.
 remember (order a) as oa.
 symmetry in Heqoa.
 destruct oa as [oa| ]; [ idtac | exfalso; apply Hnz; reflexivity ].
 simpl in HL.
 remember (filter_finite_ord (List.map f (power_list 1 la))) as pts.
 symmetry in Heqpts.
 destruct pts; [ idtac | discriminate HL ].
 clear HL.
 clear Hnz.
 revert Heqf Heqpts; clear; intros.
 remember 1%nat as pow; clear Heqpow.
 revert i pow Heqpts.
 induction la as [| a]; intros; [ reflexivity | idtac ].
 simpl in Heqpts.
 remember (f (pow, a)) as fa.
 rewrite Heqf in Heqfa.
 unfold pair_rec in Heqfa.
 simpl in Heqfa.
 subst fa; simpl in Heqpts.
 remember (order a) as oa.
 symmetry in Heqoa.
 destruct oa as [oa| ]; [ discriminate Heqpts | simpl ].
 destruct i.
  destruct la as [| b]; [ reflexivity | simpl ].
  simpl in Heqpts.
  remember (f (S pow, b)) as fb.
  rewrite Heqf in Heqfb.
  unfold pair_rec in Heqfb; simpl in Heqfb.
  subst fb.
  apply order_inf.
  remember (order b) as ob.
  symmetry in Heqob.
  destruct ob as [ob| ]; [ discriminate Heqpts | reflexivity ].

  eapply IHla; eauto .
Qed.

Theorem root_multiplicity_0 : ∀ c cf,
  c = ac_root cf
  → root_multiplicity acf c cf = 0%nat
  → (degree fld_zerop cf = 0)%nat.
Proof.
intros c cf Hc Hr.
unfold root_multiplicity in Hr.
unfold degree, apply_poly.
remember (al cf) as la.
symmetry in Heqla.
destruct la as [| a]; [ reflexivity | simpl ].
simpl in Hr.
unfold lap_mod_deg_1 in Hr; simpl in Hr.
destruct (fld_zerop (apply_lap la c * c + a)%K) as [H₁| H₁].
 discriminate Hr.

 remember (degree fld_zerop cf) as deg eqn:Hdeg .
 symmetry in Hdeg.
 destruct deg.
  unfold degree in Hdeg.
  rewrite Heqla in Hdeg.
  simpl in Hdeg.
  assumption.

  assert (degree fld_zerop cf ≥ 1)%nat as H.
   rewrite Hdeg; apply le_n_S, Nat.le_0_l.

   clear Hdeg.
   apply ac_prop_root in H.
   rewrite <- Hc in H.
   unfold apply_poly in H.
   rewrite Heqla in H; simpl in H.
   contradiction.
Qed.

Theorem degree_eq_0_if : ∀ cf,
  degree fld_zerop cf = O
  → (cf = POL [])%pol ∨ (∃ a, (a ≠ 0)%K ∧ (cf = POL [a])%pol).
Proof.
intros cf Hdeg.
unfold degree in Hdeg.
unfold eq_poly; simpl.
remember (al cf) as la; clear Heqla.
induction la as [| a]; [ left; reflexivity | idtac ].
simpl in Hdeg.
remember (degree_plus_1_of_list fld_zerop la) as deg eqn:Hdeg₁ .
symmetry in Hdeg₁.
destruct deg.
 clear Hdeg.
 pose proof (IHla (Nat.eq_refl O)) as H.
 clear IHla.
 destruct H as [Hla| Hla].
  rewrite Hla.
  destruct (fld_zerop a) as [H₁| H₁].
   left; rewrite H₁.
   apply lap_eq_0.

   right.
   exists a.
   split; [ assumption | idtac ].
   rewrite Hla; reflexivity.

  clear cf.
  destruct Hla as (b, (Hb, Hla)).
  rewrite Hla.
  right.
  revert a b Hb Hla.
  induction la as [| c]; intros.
   apply lap_eq_nil_cons_inv in Hla.
   destruct Hla; contradiction.

   simpl in Hdeg₁.
   apply lap_eq_cons_inv in Hla.
   destruct Hla as (Hcb, Hla).
   remember (degree_plus_1_of_list fld_zerop la) as deg eqn:Hdeg .
   symmetry in Hdeg.
   destruct deg.
    destruct (fld_zerop c) as [H₁| H₁]; [ idtac | discriminate Hdeg₁ ].
    rewrite H₁ in Hcb.
    symmetry in Hcb; contradiction.

    discriminate Hdeg₁.

 discriminate Hdeg.
Qed.

Theorem multiplicity_neq_0 : ∀ f L c,
  newton_segments f = Some L
  → c = ac_root (Φq f L)
  → root_multiplicity acf c (Φq f L) ≠ O.
Proof.
intros f L c HL Hc Hr.
apply root_multiplicity_0 in Hr; eauto .
apply degree_eq_0_if in Hr.
destruct Hr as [Hr| Hr].
 unfold Φq in Hr; simpl in Hr.
 rewrite Nat.sub_diag in Hr; simpl in Hr.
 unfold eq_poly in Hr; simpl in Hr.
 remember HL as H; clear HeqH.
 apply exists_ini_pt_nat in H.
 destruct H as (j, (αj, Hini)).
 rewrite Hini in Hr; simpl in Hr.
 rewrite nat_num_Qnat in Hr.
 apply lap_eq_cons_nil_inv in Hr.
 destruct Hr as (Hoj, Hcf).
 exfalso; revert Hoj.
 eapply ord_coeff_non_zero_in_newt_segm; eauto .
 left; eassumption.

 destruct Hr as (a, (Ha, Hcf)).
 unfold Φq in Hcf; simpl in Hcf.
 remember HL as H; clear HeqH.
 apply exists_ini_pt_nat in H.
 destruct H as (j, (αj, Hini)).
 rewrite Hini in Hcf; simpl in Hcf.
 rewrite nat_num_Qnat in Hcf.
 rewrite Nat.sub_diag in Hcf.
 simpl in Hcf.
 unfold eq_poly in Hcf; simpl in Hcf.
 apply lap_eq_cons_inv in Hcf.
 destruct Hcf as (Hoa, Hcf).
 remember (oth_pts L) as opts eqn:Hopts .
 symmetry in Hopts.
 destruct opts as [| pt].
  simpl in Hcf.
  remember HL as H; clear HeqH.
  apply exists_fin_pt_nat in H.
  destruct H as (k, (αk, Hfin)).
  rewrite Hfin in Hcf.
  simpl in Hcf.
  rewrite nat_num_Qnat in Hcf; simpl in Hcf.
  remember (k - S j)%nat as kj.
  clear Heqkj.
  induction kj.
   simpl in Hcf.
   apply lap_eq_cons_nil_inv in Hcf.
   destruct Hcf as (Hoc, _).
   exfalso; revert Hoc.
   eapply ord_coeff_non_zero_in_newt_segm; eauto .
   rewrite Hopts; simpl.
   right; left; eassumption.

   simpl in Hcf.
   apply lap_eq_cons_nil_inv in Hcf.
   destruct Hcf as (_, Hcf).
   apply IHkj in Hcf.
   assumption.

  simpl in Hcf.
  remember HL as H; clear HeqH.
  eapply exists_oth_pt_nat with (pt := pt) in H.
   destruct H as (h, (αh, Hoth)).
   rewrite Hoth in Hcf; simpl in Hcf.
   rewrite nat_num_Qnat in Hcf.
   remember (h - S j)%nat as hj.
   clear Heqhj.
   induction hj.
    simpl in Hcf.
    apply lap_eq_cons_nil_inv in Hcf.
    destruct Hcf as (Hoc, _).
    exfalso; revert Hoc.
    eapply ord_coeff_non_zero_in_newt_segm; eauto .
    right; apply List.in_or_app; left.
    rewrite Hopts; left; eassumption.

    simpl in Hcf.
    apply lap_eq_cons_nil_inv in Hcf.
    destruct Hcf as (_, Hcf).
    apply IHhj in Hcf.
    assumption.

   rewrite Hopts; left; reflexivity.
Qed.

End theorems.


(** **********************************************************

Benedikt Ahrens, Chris Kapulkin, Mike Shulman

january 2013

************************************************************)

(** **********************************************************

Contents : Definition of the Yoneda functor
           [yoneda(C) : [C, [C^op, HSET]]]

           Proof that [yoneda(C)] is fully faithful

TODO: this file needs cleanup

************************************************************)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Export UniMath.CategoryTheory.FunctorCategory.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso.
Require Import UniMath.CategoryTheory.whiskering.

Local Notation "'hom' C" := (precategory_morphisms (C := C)) (at level 2).

Ltac unf := unfold identity,
                   compose,
                   precategory_morphisms;
                   simpl.

(** The following lemma is already in precategories.v . It should be transparent? *)

Lemma iso_comp_left_isweq {C:category} {a b:ob C} (h:iso a b) (c:C) :
  isweq (λ f : hom _ c a, f · h).
Proof. intros. apply (@iso_comp_right_isweq C^op b a (opp_iso h)). Qed.

(** * Yoneda functor *)

(** ** On objects *)

Definition yoneda_objects_ob (C : category) (c : C)
          (d : C) := hom C d c.

Definition yoneda_objects_mor (C : category) (c : C)
    (d d' : C) (f : hom C d  d') :
   yoneda_objects_ob C c d' -> yoneda_objects_ob C c d :=
    λ g, f · g.

Definition yoneda_ob_functor_data (C : category) (c : C) :
    functor_data (C^op) HSET.
Proof.
  exists (λ c', make_hSet (yoneda_objects_ob C c c') (homset_property C _ _ ) ).
  intros a b f g. unfold yoneda_objects_ob in *. simpl in *.
  exact (f · g).
Defined.

Lemma is_functor_yoneda_functor_data (C : category) (c : C) :
  is_functor (yoneda_ob_functor_data C c).
Proof.
  repeat split; unf; simpl.
  unfold functor_idax .
  intros.
  apply funextsec.
  intro f. unf. apply id_left.
  intros a b d f g.
  apply funextsec. intro h.
  apply (! assoc _ _ _ ).
Qed.

Definition yoneda_objects (C : category) (c : C) :
             functor C^op HSET :=
    tpair _ _ (is_functor_yoneda_functor_data C c).

(** ** On morphisms *)

Definition yoneda_morphisms_data (C : category) (c c' : C)
    (f : hom C c c') : ∏ a : ob C^op,
         hom _ (yoneda_objects C c a) ( yoneda_objects C c' a) :=
            λ a g, g · f.

Lemma is_nat_trans_yoneda_morphisms_data (C : category)
     (c c' : ob C) (f : hom C c c') :
  is_nat_trans (yoneda_objects C c) (yoneda_objects C c')
    (yoneda_morphisms_data C c c' f).
Proof.
  unfold is_nat_trans; simpl.
  unfold yoneda_morphisms_data; simpl.
  intros d d' g.
  apply funextsec; simpl in *.
  unfold yoneda_objects_ob; simpl.
  unf; intro;
  apply  ( ! assoc _ _ _ ).
Qed.

Definition yoneda_morphisms (C : category) (c c' : C)
   (f : hom C c c') : nat_trans (yoneda_objects C c) (yoneda_objects C c') :=
   tpair _ _ (is_nat_trans_yoneda_morphisms_data C c c' f).

Definition yoneda_functor_data (C : category) :
   functor_data C [C^op , HSET, (has_homsets_HSET) ] :=
   tpair _ (yoneda_objects C) (yoneda_morphisms C).

(** ** Functorial properties of the yoneda assignments *)

Lemma is_functor_yoneda (C : category) :
  is_functor (yoneda_functor_data C).
Proof.
  unfold is_functor.
  repeat split; simpl.
  intro a.
  set (T:= nat_trans_eq (C:=C^op) (has_homsets_HSET)). simpl.
  apply T.
  intro c; apply funextsec; intro f.
  apply id_right.
  intros a b c f g.
  set (T:=nat_trans_eq (C:=C^op) (has_homsets_HSET)).
  apply T.
  simpl; intro d; apply funextsec; intro h.
  apply assoc.
Qed.

Definition yoneda (C : category) :
  functor C (functor_category C^op hset_category) :=
   tpair _ _ (is_functor_yoneda C).

(* Notation "'ob' F" := (precategory_ob_mor_fun_objects F)(at level 4). *)

(** ** Yoneda lemma: natural transformations from [yoneda C c] to [F]
         are isomorphic to [F c] *)

Definition yoneda_map_1 (C : category) (c : C)
   (F : functor C^op HSET) :
       hom _ (yoneda C c) F -> pr1 (F c) :=
   λ h,  pr1 h c (identity c).

Lemma yoneda_map_2_ax (C : category) (c : C)
       (F : functor C^op HSET) (x : pr1 (F c)) :
  is_nat_trans (pr1 (yoneda C c)) F
         (fun (d : C) (f : hom (C ^op) c d) => #F f x).
Proof.
  intros a b f; simpl in *.
  apply funextsec.
  unfold yoneda_objects_ob; intro g.
  set (H:= @functor_comp _ _ F  _ _  b g).
  unfold functor_comp in H;
  unfold opp_precat_data in H;
  simpl in *.
  apply (toforallpaths _ _ _ (H f) x).
Qed.

Definition yoneda_map_2 (C : category) (c : C)
   (F : functor C^op HSET) :
       pr1 (F c) -> hom _ (yoneda C c) F.
Proof.
  intro x.
  exists (λ d : ob C, λ f, #F f x).
  apply yoneda_map_2_ax.
Defined.

Lemma yoneda_map_1_2 (C : category) (c : C)
  (F : functor C^op HSET)
  (alpha : hom _ (yoneda C c) F) :
      yoneda_map_2 _ _ _ (yoneda_map_1 _ _ _ alpha) = alpha.
Proof.
  simpl in *.
  set (T:=nat_trans_eq (C:=C^op) (has_homsets_HSET)).
  apply T.
  intro a'; simpl.
  apply funextsec; intro f.
  unfold yoneda_map_1.
  intermediate_path ((alpha c · #F f) (identity c)).
    apply idpath.
  rewrite <- nat_trans_ax.
  unf; apply maponpaths.
  apply (id_right f ).
Qed.

Lemma yoneda_map_2_1 (C : category) (c : C)
   (F : functor C^op HSET) (x : pr1 (F c)) :
   yoneda_map_1 _ _ _ (yoneda_map_2 _  _ _ x) = x.
Proof.
  simpl.
  rewrite (functor_id F).
  apply idpath.
Qed.

Lemma isaset_nat_trans_yoneda (C: category) (c : C)
  (F : functor C^op HSET) :
 isaset (nat_trans (yoneda_ob_functor_data C c) F).
Proof.
  apply isaset_nat_trans.
  apply (has_homsets_HSET).
Qed.

Lemma yoneda_iso_sets (C : category) (c : C)
   (F : functor C^op HSET) :
   is_z_isomorphism (C:=HSET)
     (a := make_hSet (hom _ ((yoneda C) c) F) (isaset_nat_trans_yoneda C c F))
     (b := F c)
     (yoneda_map_1 C c F).
Proof.
  set (T:=yoneda_map_2 C c F). simpl in T.
  set (T':= T : hom HSET (F c) (make_hSet (hom _ ((yoneda C) c) F)
                                  (isaset_nat_trans_yoneda C c F))).
  exists T'.
  split; simpl.
  - apply funextsec; intro alpha.
    unf; simpl.
    apply (yoneda_map_1_2 C c F).
  - apply funextsec; intro x.
    unf; rewrite (functor_id F).
    apply idpath.
Defined.

Definition yoneda_iso_target (C : category)
           (F : [C^op, HSET])
  : functor C^op HSET.
Proof.
  use (@functor_composite _ [C^op, HSET]^op).
  - apply functor_opp.
    apply yoneda.
  - apply (yoneda _  F).
Defined.

Lemma is_natural_yoneda_iso (C : category) (F : functor C^op HSET):
  is_nat_trans (yoneda_iso_target C F) F
  (λ c, yoneda_map_1 C c F).
Proof.
  unfold is_nat_trans.
  intros c c' f. cbn in *.
  apply funextsec.
  unfold yoneda_ob_functor_data. cbn.
  unfold yoneda_morphisms_data.
  unfold yoneda_map_1.
  intro X.
  assert (XH := nat_trans_ax X).
  cbn in XH. unfold yoneda_objects_ob in XH.
  assert (XH' := XH c' c' (identity _ )).
  assert (XH2 := toforallpaths _ _ _ XH').
  rewrite XH2.
  rewrite (functor_id F).
  cbn.
  clear XH2 XH'.
  assert (XH' := XH _ _ f).
  assert (XH2 := toforallpaths _ _ _ XH').
  eapply pathscomp0. 2: apply XH2.
  rewrite id_right.
  apply idpath.
Qed.

Definition natural_trans_yoneda_iso (C : category)
  (F : functor C^op HSET)
  : nat_trans (yoneda_iso_target C F) F
  := tpair _ _ (is_natural_yoneda_iso C F).

Lemma is_natural_yoneda_iso_inv (C : category) (F : functor C^op HSET):
  is_nat_trans F (yoneda_iso_target C F)
  (λ c, yoneda_map_2 C c F).
Proof.
  unfold is_nat_trans.
  intros c c' f. cbn in *.
  apply funextsec.
  unfold yoneda_ob_functor_data. cbn.
  unfold yoneda_map_2.
  intro A.
  apply nat_trans_eq. { apply (has_homsets_HSET). }
  cbn. intro d.
  apply funextfun.
  unfold yoneda_objects_ob. intro g.
  unfold yoneda_morphisms_data.
  apply (! toforallpaths _ _ _ (functor_comp F _ _ ) A).
Qed.

Definition natural_trans_yoneda_iso_inv (C : category)
  (F : functor C^op HSET)
  : nat_trans (yoneda_iso_target C F) F
  := tpair _ _ (is_natural_yoneda_iso C F).

Lemma isweq_yoneda_map_1 (C : category) (c : C)
   (F : functor C^op HSET) :
  isweq
     (*a := make_hSet (hom _ ((yoneda C) hs c) F) (isaset_nat_trans_yoneda C hs c F)*)
     (*b := F c*)
     (yoneda_map_1 C c F).
Proof.
  set (T:=yoneda_map_2 C c F). simpl in T.
  use isweq_iso.
  - apply T.
  - apply yoneda_map_1_2.
  - apply yoneda_map_2_1.
Defined.

Definition yoneda_weq (C : category) (c : C)
   (F : functor C^op HSET)
  :  hom [C^op, HSET, has_homsets_HSET] (yoneda C c) F ≃ pr1hSet (F c)
  := make_weq _ (isweq_yoneda_map_1 C c F).

(** ** The Yoneda embedding is fully faithful *)

Lemma yoneda_fully_faithful (C : category) : fully_faithful (yoneda C).
Proof.
  intros a b; simpl.
  apply (isweq_iso _
      (yoneda_map_1 C a (pr1 (yoneda C) b))).
  - intro; simpl in *.
    apply id_left.
  - intro gamma.
    simpl in *.
    apply nat_trans_eq. apply (has_homsets_HSET).
    intro x. simpl in *.
    apply funextsec; intro f.
    unfold yoneda_map_1.
    unfold yoneda_morphisms_data.
    assert (T:= toforallpaths _ _ _ (nat_trans_ax gamma a x f) (identity _ )).
    cbn in T.
    eapply pathscomp0; [apply (!T) |].
    apply maponpaths.
    apply id_right.
Defined.

Section yoneda_functor_precomp.

Variables C D : category.
Variable F : functor C D.

Section fix_object.

Variable c : C.

Definition yoneda_functor_precomp' : nat_trans (yoneda_objects C c)
      (functor_composite (functor_opp F) (yoneda_objects D (F c))).
Proof.
  use tpair.
  - intros d f ; simpl.
    apply (#F f).
  - abstract (intros d d' f ;
              apply funextsec; intro t; simpl;
              apply functor_comp).
Defined.

Definition yoneda_functor_precomp :  _ ⟦ yoneda C c, functor_composite (functor_opp F) (yoneda_objects D (F c))⟧.
Proof.
  exact yoneda_functor_precomp'.
Defined.

Variable Fff : fully_faithful F.

Lemma is_z_iso_yoneda_functor_precomp : is_z_isomorphism yoneda_functor_precomp.
Proof.
  apply nat_trafo_z_iso_if_pointwise_z_iso.
  intro a. simpl.
  set (T:= make_weq _ (Fff a c)).
  set (TA := make_hSet (hom C a c) (homset_property C _ _)).
  set (TB := make_hSet (hom D (F a) (F c)) (homset_property _ _ _ )).
  apply (hset_equiv_is_z_iso TA TB T).
Defined.

End fix_object.

Let A : C ⟶ [D^op, HSET] := functor_composite F (yoneda D).
Let B : [D^op, HSET] ⟶ [C^op, HSET]
    := pre_composition_functor _ _ HSET (functor_opp F : [C^op, D^op]).

Definition yoneda_functor_precomp_nat_trans :
    @nat_trans
      C
      [C^op, HSET, (has_homsets_HSET)]
      (yoneda C)
      (functor_composite A B).
Proof.
  use tpair.
  - intro c; simpl.
    apply yoneda_functor_precomp.
  - abstract (
        intros c c' f;
        apply nat_trans_eq; [apply (has_homsets_HSET) |];
        intro d; apply funextsec; intro t;
        cbn;
        apply functor_comp).
Defined.

End yoneda_functor_precomp.


From iris.program_logic Require Export weakestpre.
From iris.base_logic.lib Require Export invariants.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation.
From iris.algebra Require Import excl.
Set Default Proof Using "Type".

Definition spawn : val :=
  λ: "f",
    let: "c" := ref NONE in
    Fork ("c" <- SOME ("f" #())) ;; "c".
Definition join : val :=
  rec: "join" "c" :=
    match: !"c" with
      SOME "x" => "x"
    | NONE => "join" "c"
    end.

(** The CMRA & functor we need. *)
(* Not bundling heapG, as it may be shared with other users. *)
Class spawnG Σ := SpawnG { spawn_tokG :> inG Σ (exclR unitC) }.
Definition spawnΣ : gFunctors := #[GFunctor (exclR unitC)].

Instance subG_spawnΣ {Σ} : subG spawnΣ Σ → spawnG Σ.
Proof. solve_inG. Qed.

(** Now we come to the Iris part of the proof. *)
Section proof.
Context `{!heapG Σ, !spawnG Σ} (N : namespace).

Definition spawn_inv (γ : gname) (l : loc) (Ψ : val → iProp Σ) : iProp Σ :=
  (∃ lv, l ↦ lv ∗ (⌜lv = NONEV⌝ ∨
                   ∃ w, ⌜lv = SOMEV w⌝ ∗ (Ψ w ∨ own γ (Excl ()))))%I.

Definition join_handle (l : loc) (Ψ : val → iProp Σ) : iProp Σ :=
  (∃ γ, own γ (Excl ()) ∗ inv N (spawn_inv γ l Ψ))%I.

Global Instance spawn_inv_ne n γ l :
  Proper (pointwise_relation val (dist n) ==> dist n) (spawn_inv γ l).
Proof. solve_proper. Qed.
Global Instance join_handle_ne n l :
  Proper (pointwise_relation val (dist n) ==> dist n) (join_handle l).
Proof. solve_proper. Qed.

(** The main proofs. *)
Lemma spawn_spec (Ψ : val → iProp Σ) (f : val) :
  {{{ WP f #() {{ Ψ }} }}} spawn f {{{ l, RET #l; join_handle l Ψ }}}.
Proof.
  iIntros (Φ) "Hf HΦ". rewrite /spawn /=. wp_lam.
  wp_alloc l as "Hl".
  iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
  iMod (inv_alloc N _ (spawn_inv γ l Ψ) with "[Hl]") as "#?".
  { iNext. iExists NONEV. iFrame; eauto. }
  wp_apply (wp_fork with "[Hf]").
  - iNext. wp_bind (f _). iApply (wp_wand with "Hf"); iIntros (v) "Hv".
    wp_inj. iInv N as (v') "[Hl _]".
    wp_store. iSplitL; last done. iIntros "!> !>". iExists (SOMEV v). iFrame. eauto.
  - wp_pures. iApply "HΦ". rewrite /join_handle. eauto.
Qed.

Lemma join_spec (Ψ : val → iProp Σ) l :
  {{{ join_handle l Ψ }}} join #l {{{ v, RET v; Ψ v }}}.
Proof.
  iIntros (Φ) "H HΦ". iDestruct "H" as (γ) "[Hγ #?]".
  iLöb as "IH". wp_rec. wp_bind (! _)%E. iInv N as (v) "[Hl Hinv]".
  wp_load. iDestruct "Hinv" as "[%|Hinv]"; subst.
  - iModIntro. iSplitL "Hl"; [iNext; iExists _; iFrame; eauto|].
    wp_apply ("IH" with "Hγ [HΦ]"). auto.
  - iDestruct "Hinv" as (v' ->) "[HΨ|Hγ']".
    + iModIntro. iSplitL "Hl Hγ"; [iNext; iExists _; iFrame; eauto|].
      wp_pures. by iApply "HΦ".
    + iDestruct (own_valid_2 with "Hγ Hγ'") as %[].
Qed.
End proof.

Typeclasses Opaque join_handle.


Require Import floyd.proofauto.
Require Import floyd.library.
Require Import progs.list_dt.  Import LsegSpecial.
Require Import progs.queue2.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition t_struct_elem := Tstruct _elem noattr.
Definition t_struct_fifo := Tstruct _fifo noattr.

Instance QS: listspec _elem _next (fun sh => malloc_token sh (sizeof t_struct_elem)).
Proof. eapply mk_listspec; reflexivity. Defined.

Lemma isnil: forall {T: Type} (s: list T), {s=nil}+{s<>nil}.
Proof. intros. destruct s; [left|right]; auto. intro Hx; inv Hx. Qed.

Lemma field_at_list_cell:
  forall sh i v p,
  data_at sh t_struct_elem (i,v) p
  = list_cell QS sh i p *
  field_at sh t_struct_elem [StructField _next] v p.
Proof.
intros.
unfold_data_at 1%nat.
f_equal.
unfold field_at, list_cell.
autorewrite with gather_prop.
f_equal.
apply ND_prop_ext.
rewrite field_compatible_cons; simpl.
intuition.
left; auto.
Qed.

Definition surely_malloc_spec :=
  DECLARE _surely_malloc
   WITH n:Z
   PRE [ _n OF tuint ]
       PROP (0 <= n <= Int.max_unsigned)
       LOCAL (temp _n (Vint (Int.repr n)))
       SEP ()
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (malloc_token Tsh n p * memory_block Tsh n p).

Definition fifo (contents: list val) (p: val) : mpred :=
  (EX ht: (val*val), let (hd,tl) := ht in
      !! is_pointer_or_null hd && !! is_pointer_or_null tl &&
      data_at Tsh t_struct_fifo (hd, tl) p * malloc_token Tsh (sizeof t_struct_fifo) p *
      if isnil contents
      then (!!(hd=nullval) && emp)
      else (EX prefix: list val, EX last: val,
              !!(contents = prefix++last::nil)
            &&  (lseg QS Tsh prefix hd tl
                   * malloc_token Tsh (sizeof t_struct_elem) tl
                   * data_at Tsh t_struct_elem (last, nullval) tl)))%logic.

Definition fifo_new_spec :=
 DECLARE _fifo_new
  WITH u : unit
  PRE  [  ]
       PROP() LOCAL() SEP ()
  POST [ (tptr t_struct_fifo) ]
    EX v:val, PROP() LOCAL(temp ret_temp v) SEP (fifo nil v).

Definition fifo_put_spec :=
 DECLARE _fifo_put
  WITH q: val, contents: list val, p: val, last: val
  PRE  [ _Q OF (tptr t_struct_fifo) , _p OF (tptr t_struct_elem) ]
          PROP () LOCAL (temp _Q q; temp _p p)
          SEP (fifo contents q;
                 malloc_token Tsh (sizeof t_struct_elem) p;
                 data_at Tsh t_struct_elem (last,Vundef) p)
  POST [ tvoid ]
          PROP() LOCAL() SEP (fifo (contents++(last :: nil)) q).

Definition fifo_empty_spec :=
 DECLARE _fifo_empty
  WITH q: val, contents: list val
  PRE  [ _Q OF (tptr t_struct_fifo) ]
     PROP() LOCAL (temp _Q q) SEP(fifo contents q)
  POST [ tint ]
      PROP ()
      LOCAL(temp ret_temp (if isnil contents then Vtrue else Vfalse))
      SEP (fifo (contents) q).

Definition fifo_get_spec :=
 DECLARE _fifo_get
  WITH q: val, contents: list val, first: val
  PRE  [ _Q OF (tptr t_struct_fifo) ]
       PROP() LOCAL (temp _Q q) SEP (fifo (first :: contents) q)
  POST [ (tptr t_struct_elem) ]
      EX p:val,
       PROP ()
       LOCAL(temp ret_temp p)
       SEP (fifo contents q;
              malloc_token Tsh (sizeof t_struct_elem) p;
              data_at Tsh t_struct_elem (first,Vundef) p).

Definition make_elem_spec :=
 DECLARE _make_elem
  WITH i: int
  PRE  [ _data OF tint ]
        PROP() LOCAL(temp _data (Vint i)) SEP()
  POST [ (tptr t_struct_elem) ]
    EX p:val,
       PROP()
       LOCAL (temp ret_temp p)
       SEP (malloc_token Tsh (sizeof t_struct_elem) p;
              data_at Tsh t_struct_elem (Vint i, Vundef) p).

Definition main_spec :=
 DECLARE _main
  WITH u : unit
  PRE  [] main_pre prog nil u
  POST [ tint ] main_post prog nil u.

Definition Gprog : funspecs :=
  ltac:(with_library prog
    [surely_malloc_spec; fifo_new_spec; fifo_put_spec;
     fifo_empty_spec; fifo_get_spec; make_elem_spec;
     main_spec]).

Lemma body_surely_malloc: semax_body Vprog Gprog f_surely_malloc surely_malloc_spec.
Proof.
  start_function.
  forward_call (* p = malloc(n); *)
     n.
  Intros p.
  forward_if
  (PROP ( )
   LOCAL (temp _p p)
   SEP (malloc_token Tsh n p * memory_block Tsh n p)).
*
  if_tac.
    subst p. entailer!.
    entailer!.
*
    forward_call tt.
    contradiction.
*
    if_tac.
    + forward. subst p. inv H0.
    + Intros. forward. entailer!.
*
  forward. Exists p; entailer!.
Qed.

Lemma memory_block_fifo:
 forall p,
  field_compatible t_struct_fifo nil p ->
  memory_block Tsh 8 p = field_at_ Tsh t_struct_fifo nil p.
Proof.
 intros.
 change 8 with (sizeof t_struct_fifo).
 rewrite memory_block_data_at_; auto.
Qed.

Lemma fifo_isptr: forall al q, fifo al q |-- !! isptr q.
Proof.
intros.
 unfold fifo.
 if_tac; entailer; destruct ht; entailer!.
Qed.

Hint Resolve fifo_isptr : saturate_local.

Lemma body_fifo_empty: semax_body Vprog Gprog f_fifo_empty fifo_empty_spec.
Proof.
start_function.
unfold fifo.
Intros ht; destruct ht as [hd tl].
Intros.
forward. (* h = Q->head; *)
forward. (* return (h == NULL); *)
unfold fifo.
Exists (hd,tl).
destruct (isnil contents).
* entailer!.
  apply andp_right; auto with valid_pointer.
* Intros prefix last.
  Exists prefix last.
  assert_PROP (isptr hd). {
    destruct prefix; entailer.
    rewrite @lseg_cons_eq by auto. Intros y.
    entailer.
 }
 destruct hd; try contradiction.
 entailer!. simpl sizeof. entailer!.
Qed.

Lemma body_fifo_new: semax_body Vprog Gprog f_fifo_new fifo_new_spec.
Proof.
  start_function.
  forward_call (* Q = surely_malloc(sizeof ( *Q)); *)
     (sizeof t_struct_fifo).
    simpl; computable.
  Intros q.
  assert_PROP (field_compatible t_struct_fifo [] q).
   entailer!.
  rewrite memory_block_fifo by auto.
  forward. (* Q->head = NULL; *)
  forward. (* Q->tail = NULL; *)
  forward. (* return Q; *)
  Exists q. unfold fifo. Exists (nullval,nullval).
  rewrite if_true by auto.
  simpl sizeof.
  entailer!.
Qed.

Lemma body_fifo_put: semax_body Vprog Gprog f_fifo_put fifo_put_spec.
Proof.
start_function.
unfold fifo at 1.
Intros ht; destruct ht as [hd tl].
Intros.
forward. (* p->next = NULL; *)
forward. (*   h = Q->head; *)
forward_if
  (PROP() LOCAL () SEP (fifo (contents ++ last :: nil) q))%assert.
* if_tac; entailer.  (* typechecking clause *)
* (* then clause *)
  subst.
  forward. (* Q->head=p; *)
  forward. (* Q->tail=p; *)
  entailer.
  unfold fifo.
  destruct (isnil contents).
  + subst. Exists (p,p).
     simpl. rewrite if_false by congruence.
     Exists (@nil val) last.
      rewrite @lseg_nil_eq by auto.
      entailer!.
   + Intros prefix last0.
      destruct prefix;
      entailer!.
      rewrite @lseg_cons_eq by auto. simpl.
      Intros y.
      entailer!.
* (* else clause *)
  forward. (*  t = Q->tail; *)
  destruct (isnil contents).
  + Intros. contradiction H; auto.
  + Intros prefix last0.
     forward. (*  t->next=p; *)
     forward. (* Q->tail=p; *)
     entailer!.
     unfold fifo. Exists (hd, p).
     rewrite if_false by (clear; destruct prefix; simpl; congruence).
     Exists  (prefix ++ last0 :: nil) last.
     entailer.
     fold (data_at Tsh t_struct_elem (last0,p) tl).
     rewrite (field_at_list_cell Tsh last0 p).
     unfold_data_at 2%nat.
     unfold_field_at 3%nat.
     simpl sizeof.
     match goal with
     | |- _ |-- _ * _ * (_ * ?AA) => remember AA as A
     end.     (* prevent it from canceling! *)
     cancel. subst A.
     eapply derives_trans;
        [ | apply (lseg_cons_right_neq QS Tsh prefix hd last0 tl nullval p ); auto].
     simpl sizeof.  cancel.
* (* after the if *)
     forward. (* return ; *)
Qed.

Lemma body_fifo_get: semax_body Vprog Gprog f_fifo_get fifo_get_spec.
Proof.
start_function.
unfold fifo at 1.
Intros ht; destruct ht as [hd tl].
rewrite if_false by congruence.
Intros prefix last.
forward.  (*   h = Q->head; *)
destruct prefix; inversion H; clear H.
+
   rewrite @lseg_nil_eq by auto.
   Intros.
   subst_any.
   forward. (*  n=h->next; *)
   forward. (* Q->head=n; *)
   forward. (* return p; *)
   unfold fifo. Exists tl (nullval, tl).
   rewrite if_true by congruence.
   entailer!. simpl sizeof. unfold_data_at 1%nat. unfold_data_at 1%nat. cancel.
+ rewrite @lseg_cons_eq by auto.
    Intros x.
    simpl @valinject. (* can we make this automatic? *)
    subst_any.
    forward. (*  n=h->next; *)
    forward. (* Q->head=n; *)
    forward. (* return p; *)
    Exists hd. unfold fifo. Exists (x, tl).
    rewrite if_false by (destruct prefix; simpl; congruence).
    Exists prefix last.
    entailer!.
    rewrite field_at_list_cell. simpl sizeof. cancel.
Qed.

Lemma body_make_elem: semax_body Vprog Gprog f_make_elem make_elem_spec.
Proof.
start_function.
forward_call (*  p = surely_malloc(sizeof ( *p));  *)
  (sizeof t_struct_elem).
 simpl; computable.
 Intros p.
 assert_PROP (field_compatible t_struct_elem [] p). entailer!.
 rewrite memory_block_data_at_ by auto.
forward.  (*  p->data=i; *)
simpl.
forward. (* return p; *)
Exists p.
entailer!.
Qed.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
forward_call (* Q = fifo_new(); *)  tt.
Intros q.

forward_call  (*  p = make_elem(1); *)
     (Int.repr 1).
Intros p'.
forward_call (* fifo_put(Q,p);*)
    ((q, @nil val),p', Vint (Int.repr 1)).

forward_call  (*  p = make_elem(2); *)
     (Int.repr 2).
Intros p2.
simpl app.
 forward_call  (* fifo_put(Q,p); *)
    (((q,[Vint (Int.repr 1)]),p2), Vint (Int.repr 2)).
simpl app.
forward_call  (*   p' = fifo_get(Q); p = p'; *)
    ((q,[Vint (Int.repr 2)]), Vint (Int.repr 1)).
Intros p3.
forward. (*   i = p->data;  *)
forward_call (*  free(p); *)
   (p3, sizeof t_struct_elem).
 assert_PROP (field_compatible t_struct_elem [] p3) by entailer!.
 rewrite memory_block_data_at_ by auto.
 cancel.
 forward. (* return i; *)
Qed.

Existing Instance NullExtension.Espec.

Lemma ret_temp_make_ext_rval:
  forall gx ret p,
   locald_denote (temp ret_temp p) (make_ext_rval gx ret) ->
    p = force_val ret.
Proof.
  intros.
  hnf in H.
  rewrite retval_ext_rval in H. auto.
Qed.

Lemma all_funcs_correct:
  semax_func Vprog Gprog (prog_funct prog) Gprog.
Proof.
unfold Gprog, prog, prog_funct; simpl.
semax_func_cons body_malloc. apply semax_func_cons_malloc_aux.
semax_func_cons body_free.
semax_func_cons body_exit.
semax_func_cons body_surely_malloc.
semax_func_cons body_fifo_new.
semax_func_cons body_fifo_put.
semax_func_cons body_fifo_empty.
semax_func_cons body_fifo_get.
semax_func_cons body_make_elem.
semax_func_cons body_main.
Qed.


Global
Set Primitive Projections.
Global
Unset Printing Primitive Projection Parameters.

Global
Set Universe Polymorphism.

Global
Set Default Goal Selector "!".

From Ltac2 Require Import Ltac2.

Set Default Proof Mode "Classic".

Require Import Coq.Unicode.Utf8.
Require Import Coq.Lists.List.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Module Import Bundle.
  #[universes(cumulative)]
  Record bundle A := suprema {
    s: Type ;
    π: s → A ;
  }.

  Arguments suprema [A s].
  Arguments s [A].
  Arguments π [A].

  Coercion s: bundle >-> Sortclass.
  Coercion π: bundle >-> Funclass.

  Notation "'sup' x .. y , P" := {| π x := .. {| π y := P |} .. |}
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' '[ ' 'sup'  x .. y ']' , '/' P ']'").
End Bundle.

Module Import Span.

  #[universes(cumulative)]
  Record span A B := {
    s: Type ;
    π1: s → A ;
    π2: s → B ;
  }.

  Arguments s [A B].
  Arguments π1 [A B].
  Arguments π2 [A B].

  Coercion s: span >-> Sortclass.

  Module Export SpanNotations.
    Reserved Notation "'SPAN' x , P ———— Q" (x ident, at level 90, format "'SPAN' x , '//' P '//' ———— '//' Q").
    Reserved Notation "'SPAN' x : A , P ———— Q" (x ident, at level 90, format "'SPAN' x : A , '//' P '//' ———— '//' Q").
    Reserved Notation "'SPAN' ( x : A ) , P ———— Q" (x ident, at level 90, format "'SPAN' ( x : A ) , '//' P '//' ———— '//' Q").

    Notation "'SPAN' x , P ———— Q" := {| π1 x := P ; π2 x := Q |} .
    Notation "'SPAN' x : A , P ———— Q" := {| π1 (x : A) := P ; π2 (x : A) := Q |} .
    Notation "'SPAN' ( x : A ) , P ———— Q" := {| π1 (x : A) := P ; π2 (x : A) := Q |} .
  End SpanNotations.
End Span.

Module Import Logic.
  Import List.ListNotations.

  (* FIXME have an or for results as well ? *)
  Definition axiom C := span C C.

  Definition axiom_scheme C := bundle (axiom C).
  Definition theory C := bundle (axiom_scheme C).

  (* FIXME make category *)
  Inductive syn {K} {th: theory K}: K → K → Type :=
  | syn_id {A}: syn A A
  | syn_compose {A B C}: syn B C → syn A B → syn A C

  | syn_axiom rule args C D:
      (∀ ix, syn C (π1 (th rule args) ix)) →
      (∀ ix, syn (π2 (th rule args) ix) D) →
      syn C D
  .
End Logic.

Module Import Sanity.
  #[universes(cumulative)]
  Class Propositional := {
    P: Type ;

    true: P ;
    and: P → P → P ;

    false: P ;
    or: P → P → P ;
  }.

  Infix "∧" := and.
  Infix "∨" := or.

  Variant idx :=
  | bang
  | absurd
  | inl | inr | fanin
  | fst | snd | fanout.

  Definition propositional `{Propositional}: theory P := sup ix,
    match ix with
    | bang => sup A,
              SPAN (_: True),
               A
               ————
               true

    | absurd => sup A,
                SPAN (_: True),
                  false
                  ————
                  A

    | fanin => sup '(A, B),
                SPAN b:bool,
                      A ∨ B
                      ————
                      if b then A else B

    | inl => sup '(A, B),
             SPAN _:True,
                   A
                   ————
                   A ∨ B
    | inr => sup '(A, B),
             SPAN _:True,
                   B
                   ————
                   A ∨ B

    | fanout => sup '(A, B),
                SPAN b:bool,
                      (if b then A else B)
                      ————
                      A ∧ B

    | fst => sup '(A, B),
             SPAN _:True,
                   A ∧ B
                   ————
                   A

    | snd => sup '(A, B),
             SPAN _:True,
                   A ∧ B
                   ————
                   B
    end
    .

  Section sanity.
    Context `{Propositional}.

    Definition free := @syn _ propositional.

    Definition bang' C: free C true := @syn_axiom _ propositional
                                                  bang C
                                                  C true
                                                  (λ _, syn_id)
                                                  (λ _, syn_id).

    Definition inl' A B: free A (A ∨ B) := @syn_axiom _ propositional
                                                      inl (A, B)
                                                      A (A ∨ B)
                                                      (λ _, syn_id) (λ _, syn_id).
    Definition inr' A B: free B (A ∨ B) := @syn_axiom _ propositional
                                                      inr (A, B)
                                                      B (A ∨ B)
                                                      (λ _, syn_id)
                                                      (λ _, syn_id).

    #[program]
    Definition fanin' C A B (f: free A C) (g: free B C) :=
      @syn_axiom _ propositional
                 fanin (A, B)
                 (A ∨ B) C
                 (λ _, syn_id) _.

    Next Obligation.
      destruct ix.
      - apply f.
      - apply g.
    Defined.

    #[program]
     Definition fanout' C A B (f: free C A) (g: free C B): free C (A ∧ B) :=
      @syn_axiom _ propositional
                 fanout (A, B)
                 C (A ∧ B)
                 _ (λ _, syn_id).
    Next Obligation.
      destruct ix.
      - apply f.
      - apply g.
    Defined.

    Definition fst' A B: free (A ∧ B) A := @syn_axiom _ propositional
                                                      fst (A, B)
                                                      (A ∧ B) A
                                                      (λ _, syn_id) (λ _, syn_id).
    Definition snd' A B: free (A ∧ B) B := @syn_axiom _ propositional
                                                      snd (A, B)
                                                      (A ∧ B) B
                                                      (λ _, syn_id) (λ _, syn_id).
  End sanity.

  Instance as_Prop: Propositional := {
    P := Prop ;

    true := True ;
    and := Logic.and ;

    false := False ;
    or := Logic.or ;
  }.

  Definition eval_Prop [A B: @P as_Prop]: free A B → A → B.
    intros f.
    induction f.
    - intro x.
      apply x.
    - intro x.
      apply (IHf1 (IHf2 x)).
    - destruct rule.
      all: cbn in *.
      + intro x.
        apply H0.
        all: auto.
      + intro x.
        set (H' := H I x).
        contradiction.
      + intro x.
        destruct args as [P Q].
        cbn in *.
        apply (H0 I).
        left.
        apply (H I x).
      + intro x.
        destruct args as [P Q].
        cbn in *.
        apply (H0 I).
        right.
        apply (H I x).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        refine (_ (H Datatypes.false x)).
        * intro x'.
          destruct x'.
          -- apply (H0 Datatypes.true H1).
          -- apply (H0 Datatypes.false H1).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        apply (H0 I).
        apply (H I x).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        apply (H0 I).
        apply (H I x).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        apply (H0 Datatypes.false).
        split.
        * apply (H Datatypes.true x).
        * apply (H Datatypes.false x).
  Defined.

  Instance as_Set: Propositional := {
    P := Set ;

    true := unit ;
    and := prod ;

    false := Empty_set ;
    or := sum ;
  }.

  Definition eval_Set [A B: @P as_Set]: free A B → A → B.
    intros f.
    induction f.
    - intro x.
      apply x.
    - intro x.
      apply (IHf1 (IHf2 x)).
    - destruct rule.
      all: cbn in *.
      + intro x.
        apply (H0 I tt).
      + intro x.
        set (H' := H I x).
        contradiction.
      + intro x.
        destruct args as [P Q].
        cbn in *.
        apply (H0 I).
        left.
        apply (H I x).
      + intro x.
        destruct args as [P Q].
        cbn in *.
        apply (H0 I).
        right.
        apply (H I x).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        refine (_ (H Datatypes.false x)).
        * intro x'.
          destruct x' as [p|q].
          -- apply (H0 Datatypes.true p).
          -- apply (H0 Datatypes.false q).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        apply (H0 I).
        apply (H I x).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        apply (H0 I).
        apply (H I x).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        apply (H0 Datatypes.false).
        split.
        * apply (H Datatypes.true x).
        * apply (H Datatypes.false x).
  Defined.

  Example foo `{Propositional}: free true (true ∧ true) := fanout' _ _ _ (bang' _) (bang' _).

  Definition foo' := eval_Set foo.
End Sanity.

(* FIXME do the same thing but with bundles ? *)
Module Import Hoas.
  #[universes(cumulative)]
  Class Lam := {
    tm: Type ;
    ty: Type ;

    pt: ty ;
    exp: ty → ty → ty ;

    lam: ty → (tm → tm) → tm ;
    app: tm → tm → tm ;
  }.
End Hoas.

Module Import Spec.
  Import List.ListNotations.

  Variant type_query `{Lam} := ofty (_:tm) (_: ty).

  Module Export SpecNotations.
    Infix "∈" := ofty (at level 40).
  End SpecNotations.

  Open Scope logic_scope.

  Variant index := app_rule | lam_rule.
  Definition stlc `{Lam}: theory type_query := {|
    dom := index ;
    proj x :=
      match x with
      | app_rule => FREE (A, B, f, x) ,
                      app f x ∈ B ⊢ [
                           f ∈ exp A B ;
                           x ∈ A ]
        (*
       Not sure how I'm going to handle variables, not correct at all here,
       Also not sure how I'm going to handle evaluating expressions
         *)
      | lam_rule => FREE (A, B, f, x) ,
                      lam A f ∈ exp A B ⊢ [
                           x ∈ A ;
                           f x ∈ B]
      end
   |}.
End Spec.

Module Import Sanity.
  Import List.ListNotations.

  Section sanity.
    Context `{Lam}.

    Definition free := @syn _ stlc.

    Definition foo x A: free [ x ∈ A ; x ∈ A ] [].
      apply (syn_weaken nil).
    Defined.
  End sanity.
End Sanity.

Module Import Lattice.
  #[universes(cumulative)]
  Class Lattice := {
    S: Type ;

    top: S ;
    bot: S ;

    meet: S → S → S ;
    join: S → S → S ;
  }.

  Definition meet_all `{Lattice}: list S → S := List.fold_right meet top.
  Definition join_all `{Lattice}: list S → S := List.fold_right join bot.

  Module Export LatticeNotations.
    Declare Scope lattice_scope.
    Delimit Scope lattice_scope with lattice.
    Bind Scope lattice_scope with S.

    Notation "⊤" := top : lattice_scope.
    Notation "⊥" := bot : lattice_scope.

    Infix "∧" := meet : lattice_scope.

    Notation "⋀" := meet_all : lattice_scope.
    Notation "⋁" := join_all : lattice_scope.

    Coercion S: Lattice >-> Sortclass.
  End LatticeNotations.
End Lattice.

(* FIXME implement a Lattice algebra using bundles and interpret
everything categorically *)
Module Import Pred.
  #[program]
   Definition predicate_logic A: Lattice := {|
    S := A → Prop ;

    top _ := True ;
    bot _ := False ;

    meet P Q x := P x ∧ Q x ;
    join P Q x := P x ∨ Q x ;
  |}.
End Pred.

Module Import Sanity.
  Local Set Implicit Arguments.

  Definition ofty `{Lam} A B f x := check stlc app_rule (A, B, f, x).
  Check ofty.
  Definition ofty `{Lam} i v x A :=
    let (H, T) := chk (predicate_logic _) (simplify pred_stlc) {| ix := i ; val := v |}  in
    H (x ∈ A) → T (x ∈ A).
  Definition foo `{Lam} A: ofty (lam A (λ x, x)) (exp A A).
    exists lam_rule.
    intro.
    cbn in *.
    destruct .

  Definition bar `{Lam} := foo 0 I.
  #[program]
   Definition bar `{Lam} := foo 1 _.
  Next Obligation.
    cbn.
  (* Definition foo `{Lam}: oftype (λ x, x = P ∈ T) (λ x, x = P ∈ T) *)
    cbn.
    eexists.
    Unshelve.
    2: {
      cbn.
      left.
      exists.
    }
    cbn.
    reflexivity.
  Qed.
End Sanity.

Module Import Foo.
  Definition type_Lattice := {|
    S := Set ;

    top := True ;
    bot := False ;

    meet P Q := P * Q ;
    join P Q := P + Q ;
  |}.
  Definition oftype `{Lam} (p: any_head rules) :=
      let (H, T) := chk type_Lattice (λ q, {x: type_query | q = x}) rules p in
      T → H.

  Definition bar `{Lam} : any_head rules.
    cbn.
    left.
    exists.
  Defined.

  Definition foo `{Lam}: oftype bar.
    cbn.
    intros.
    exists (P ∈ T).
    reflexivity.
  Defined.
End Foo.