From Coq Require Import List.
Import List.ListNotations.
Open Scope list_scope.
From Coq Require Import Sorting.Permutation.
From Coq Require Import Setoid.
From Coq Require Import Morphisms.
From Coq Require Import Program.Tactics.
From Coq Require Import NPeano.
From Coq Require Import Omega.

From Coq Require Import FSets.FMapPositive.
From Velus Require Import Common.
From Velus Require Import Environment.
From Velus Require Import Operators.
From Velus Require Import Clocks.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import NLustre.NLSyntax.
From Velus Require Import NLustre.NLOrdered.
From Velus Require Import IndexedStreams.
From Velus Require Import CoindStreams.
From Velus Require Import IndexedToCoind.

From Velus Require Import CoreExpr.CESemantics.
From Velus Require Import CoreExpr.CEInterpreter.
From Velus Require Import NLustre.NLIndexedSemantics.
From Velus Require Import NLustre.NLCoindSemantics.

From Coq Require Import Setoid.

Module Type NLINDEXEDTOCOIND
       (Import Ids    : IDS)
       (Import Op     : OPERATORS)
       (Import OpAux  : OPERATORS_AUX          Op)
       (Import CESyn  : CESYNTAX               Op)
       (Import Syn    : NLSYNTAX           Ids Op       CESyn)
       (Import IStr   : INDEXEDSTREAMS         Op OpAux)
       (Import CStr   : COINDSTREAMS           Op OpAux)
       (Import ICStr  : INDEXEDTOCOIND         Op OpAux IStr CStr)
       (Import Ord    : NLORDERED          Ids Op       CESyn Syn)
       (CESem         : CESEMANTICS        Ids Op OpAux CESyn     IStr)
       (Indexed       : NLINDEXEDSEMANTICS Ids Op OpAux CESyn Syn IStr Ord CESem)
       (Import Interp : CEINTERPRETER      Ids Op OpAux CESyn     IStr     CESem)
       (CoInd         : NLCOINDSEMANTICS   Ids Op OpAux CESyn Syn CStr Ord).

  Section Global.

    Variable G : global.

    (** * SEMANTICS CORRESPONDENCE *)

    (** ** Variables *)

    (* (** An inversion principle for [sem_var]. *) *)
    (* Lemma sem_var_inv: *)
    (*   forall H x xs, *)
    (*     CESem.sem_var H x xs -> *)
    (*     exists xs', *)
    (*       Env.find x H = Some xs' *)
    (*       /\ xs ≈ xs'. *)
    (* Proof. *)
    (*   unfold CESem.sem_var, CESem.lift'. *)
    (*   intros * Sem. *)
    (*   destruct (Env.find x H) as [xs'|] eqn: E; simpl in *. *)
    (*   - exists xs'; intuition. *)
    (*     intro n; specialize (Sem n). *)
    (*     unfold CESem.sem_var_instant, CESem.restr_hist in Sem. *)
    (*     rewrite Env.Props.P.F.map_o in Sem. *)
    (*     setoid_rewrite E in Sem. *)
    (*     now inv Sem. *)
    (*   - specialize (Sem 0). *)
    (*     unfold CESem.sem_var_instant, CESem.restr_hist in Sem. *)
    (*     rewrite Env.Props.P.F.map_o in Sem. *)
    (*     now setoid_rewrite E in Sem. *)
    (* Qed. *)

    (** An inversion principle for [sem_vars]. *)
    Lemma sem_vars_inv_from:
      forall H xs xss,
        CESem.sem_vars H xs xss ->
        forall n,
          Forall2 (fun x k => IStr.sem_var H x (streams_nth k xss))
                  (skipn n xs) (seq n (length xs - n)).
    Proof.
      unfold CESem.sem_vars, IStr.lift.
      intros * Sem n.
      apply Forall2_forall2; split.
      - now rewrite skipn_length, seq_length.
      - intros x_d k_d n' x k Length Hskipn Hseq.
        rewrite skipn_length in Length.
        rewrite nth_skipn in Hskipn.
        rewrite nth_seq in Hseq; auto; subst.
        intro m; specialize (Sem m).
        apply Forall2_forall2 in Sem.
        eapply Sem; eauto.
        + now apply Nat.lt_add_lt_sub_r.
        + unfold streams_nth; eauto.
    Qed.

    Corollary sem_vars_inv:
      forall H xs xss,
        CESem.sem_vars H xs xss ->
        Forall2 (fun x k => IStr.sem_var H x (streams_nth k xss))
                xs (seq 0 (length xs)).
    Proof.
      intros * Sem; apply sem_vars_inv_from with (n:=0) in Sem.
      now rewrite Nat.sub_0_r in Sem.
    Qed.

    Corollary sem_vars_impl_from:
      forall n H xs xss,
      CESem.sem_vars H xs xss ->
      Forall2 (sem_var (tr_history_from n H)) xs (tr_streams_from n xss).
    Proof.
      intros * Sem.
      assert (length xs = length (xss n)) as Length by
            (unfold CESem.sem_vars, IStr.lift in Sem; specialize (Sem n);
             now apply Forall2_length in Sem).
      apply Forall2_forall2; split.
      - now rewrite tr_streams_from_length.
      - apply sem_vars_inv in Sem.
        intros x_d xs_d n' x xs' En' Ex Exs'.
        apply Forall2_forall2 in Sem as (? & Sem).
        assert (nth n' (seq 0 (length xs)) 0 = n') as Nth by
              (rewrite <-(Nat.sub_0_r (length xs)), plus_n_O;
               apply nth_seq; rewrite Nat.sub_0_r; auto).
        eapply Sem in Nth; eauto.
        apply (sem_var_impl_from n) in Nth.
        subst.
        rewrite nth_tr_streams_from_nth; auto.
        now rewrite <-Length.
    Qed.

    Corollary sem_vars_impl:
      forall H xs xss,
      CESem.sem_vars H xs xss ->
      Forall2 (sem_var (tr_history H)) xs (tr_streams xss).
    Proof. apply sem_vars_impl_from. Qed.
    Hint Resolve sem_vars_impl_from sem_vars_impl.

    (** ** exp level synchronous operators inversion principles

        The indexed semantics is inductive only instant-speaking, therefore we
        can't use usual tactics like inversion nor induction.
        We prove some lemmas to provide inversion-like tactics on the semantics
        of exps.
        These lemmas could be proven using the classical axiom of choice which
        gives, from an instant semantics entailment true at every instant,
        the existence of a stream verifying the general entailment.
        But we rather use the interpretor to seq_streams these witnesses, with 2
        benefits :
        1) this is a constructive way of obtaining a witness
        2) we don't rely on an axiom whose use would have to be be deeply
           justified since it would raise some logical contradictions in Coq
     *)

    (** This tactic automatically uses the interpretor to give a witness stream. *)
    Ltac interp_str b H x Sem :=
      let Sem_x := fresh "Sem_" x in
      let sol sem interp sound :=
          assert (sem b H x (interp b H x)) as Sem_x
              by (intro; match goal with n:nat |- _ => specialize (Sem n) end;
                  unfold interp, lift_interp; inv Sem; erewrite <-sound; eauto)
      in
      let sol' sem interp sound :=
          assert (sem H x (interp H x)) as Sem_x
              by (intro; match goal with n:nat |- _ => specialize (Sem n) end;
                  unfold interp, lift_interp'; inv Sem; erewrite <-sound; eauto)
      in
      match type of x with
      | exp => sol CESem.sem_exp interp_exp interp_exp_instant_sound
      | cexp => sol CESem.sem_cexp interp_cexp interp_cexp_instant_sound
      | ident => sol' IStr.sem_var interp_var interp_var_instant_sound
      | clock => sol IStr.sem_clock interp_clock interp_clock_instant_sound
      end.

    Lemma when_inv:
      forall H b e x k es,
        CESem.sem_exp b H (Ewhen e x k) es ->
        exists ys xs,
          CESem.sem_exp b H e ys
          /\ IStr.sem_var H x xs
          /\
          (forall n,
              (exists sc xc,
                  val_to_bool xc = Some k
                  /\ ys n = present sc
                  /\ xs n = present xc
                  /\ es n = present sc)
              \/
              (exists sc xc,
                  val_to_bool xc = Some (negb k)
                  /\ ys n = present sc
                  /\ xs n = present xc
                  /\ es n = absent)
              \/
              (ys n = absent
               /\ xs n = absent
               /\ es n = absent)).
    Proof.
      intros * Sem.
      interp_str b H e Sem.
      interp_str b H x Sem.
      do 2 eexists; intuition; eauto.
      specialize (Sem_e n); specialize (Sem_x n); specialize (Sem n); inv Sem.
      - left. exists sc, xc. repeat split; auto;
                               intuition CESem.sem_det.
      - right; left; exists sc, xc; intuition; try CESem.sem_det.
        now rewrite Bool.negb_involutive.
      - right; right; repeat split; auto; intuition CESem.sem_det.
    Qed.

    Lemma unop_inv:
      forall H b op e ty es,
        CESem.sem_exp b H (Eunop op e ty) es ->
        exists ys,
          CESem.sem_exp b H e ys
          /\
          (forall n,
              (exists c c',
                  ys n = present c
                  /\ sem_unop op c (typeof e) = Some c'
                  /\ es n = present c')
              \/
              (ys n = absent
               /\ es n = absent)).
    Proof.
      intros * Sem.
      interp_str b H e Sem.
      eexists; intuition; eauto.
      specialize (Sem_e n); specialize (Sem n); inv Sem.
      - left; exists c, c'; repeat split; auto; intuition CESem.sem_det.
      - right; repeat split; intuition CESem.sem_det.
    Qed.

    Lemma binop_inv:
      forall H b op e1 e2 ty es,
        CESem.sem_exp b H (Ebinop op e1 e2 ty) es ->
        exists ys zs,
          CESem.sem_exp b H e1 ys
          /\ CESem.sem_exp b H e2 zs
          /\
          (forall n,
              (exists c1 c2 c',
                  ys n = present c1
                  /\ zs n = present c2
                  /\ sem_binop op c1 (typeof e1) c2 (typeof e2) = Some c'
                  /\ es n = present c')
              \/
              (ys n = absent
               /\ zs n = absent
               /\ es n = absent)).
    Proof.
      intros * Sem.
      interp_str b H e1 Sem.
      interp_str b H e2 Sem.
      do 2 eexists; intuition; eauto.
      specialize (Sem_e1 n); specialize (Sem_e2 n); specialize (Sem n); inv Sem.
      - left; exists c1, c2, c'; repeat split; auto; intuition CESem.sem_det.
      - right; repeat split; auto; intuition CESem.sem_det.
    Qed.

    (** ** Semantics of exps *)

    Ltac use_spec Spec :=
      match goal with
        n: nat |- _ =>
        let m := fresh "m" in
        intro m; repeat rewrite init_from_nth;
        specialize (Spec (m + n));
        repeat match goal with
                 H: _ \/ _ |- _ => destruct H
               end;
        destruct_conjs; firstorder
      end.

    (** State the correspondence for [exp].
        Goes by induction on [exp] and uses the previous inversion lemmas. *)
    Hint Constructors when lift1 lift2.
    Lemma sem_exp_impl_from:
      forall n H b e es,
        CESem.sem_exp b H e es ->
        CoInd.sem_exp (tr_history_from n H) (tr_stream_from n b) e
                       (tr_stream_from n es).
    Proof.
      intros * Sem.
      revert dependent H; revert b es n.
      induction e; intros * Sem; unfold CESem.sem_exp, lift in Sem.

      - constructor.
        apply const_spec; use_spec Sem; inv Sem; auto.

      - constructor.
        apply sem_var_impl_from.
        intros n'; specialize (Sem n').
        now inv Sem.

      - apply when_inv in Sem as (ys & xs & ? & ? & Spec).
        econstructor; eauto using sem_var_impl_from.
        apply when_spec; use_spec Spec.

      - apply unop_inv in Sem as (ys & ? & Spec).
        econstructor; eauto.
        apply lift1_spec; use_spec Spec.

      - apply binop_inv in Sem as (ys & zs & ? & ? & Spec).
        econstructor; eauto.
        apply lift2_spec; use_spec Spec.
    Qed.

    Corollary sem_exp_impl:
      forall H b e es,
        CESem.sem_exp b H e es ->
        CoInd.sem_exp (tr_history H) (tr_stream b) e (tr_stream es).
    Proof. apply sem_exp_impl_from. Qed.
    Hint Resolve sem_exp_impl_from sem_exp_impl.

    (** An inversion principle for lists of [exp]. *)
    Lemma sem_exps_inv:
      forall H b es ess,
        CESem.sem_exps b H es ess ->
        exists ess',
          Forall2 (CESem.sem_exp b H) es ess'
          /\ forall n, ess n = List.map (fun es => es n) ess'.
    Proof.
      intros * Sem.
      exists (interp_exps' b H es); split.
      - eapply interp_exps'_sound; eauto.
      - intro n; specialize (Sem n); induction Sem; simpl; auto.
        f_equal; auto.
        unfold interp_exp; now apply interp_exp_instant_sound.
    Qed.

    (** Generalization for lists of [exp]. *)
    Corollary sem_exps_impl_from:
      forall n H b es ess,
        CESem.sem_exps b H es ess ->
        Forall2 (CoInd.sem_exp (tr_history_from n H) (tr_stream_from n b)) es
                (tr_streams_from n ess).
    Proof.
      intros * Sem.
      apply sem_exps_inv in Sem as (ess' & Sem & Eess').
      assert (length es = length (ess n)) as Length by
          (rewrite Eess', map_length; simpl; eapply Forall2_length; eauto).
      apply Forall2_forall2; split.
      - unfold_tr_streams; rewrite seq_streams_length; simpl; omega.
      - intros; subst.
        rewrite nth_tr_streams_from_nth; try omega.
        apply sem_exp_impl_from.
        eapply (Forall2_forall2_eq _ _ (@eq_refl exp) (eq_str_refl))
          in Sem as (? & Sem).
        + eapply Sem; eauto.
          unfold streams_nth.
          intros k; rewrite Eess'.
          change absent with ((fun es => es k) (fun _ => absent)).
          rewrite map_nth; eauto.
        + unfold CESem.sem_exp; clear.
          intros ?? E ?? E' Sem; subst.
          eapply CESem.lift_eq_str; eauto; reflexivity.
    Qed.

    Corollary sem_exps_impl:
      forall H b es ess,
        CESem.sem_exps b H es ess ->
        Forall2 (CoInd.sem_exp (tr_history H) (tr_stream b)) es (tr_streams ess).
    Proof. apply sem_exps_impl_from. Qed.
    Hint Resolve sem_exps_impl_from sem_exps_impl.

    (** An inversion principle for annotated [exp]. *)
    Lemma sem_aexp_inv:
      forall H b e es ck,
        CESem.sem_aexp b H ck e es ->
        CESem.sem_exp b H e es
        /\ exists bs,
            IStr.sem_clock b H ck bs
            /\ forall n,
              bs n = match es n with
                     | present _ => true
                     | absent => false
                     end.
    Proof.
      intros * Sem; split.
      - intro n; specialize (Sem n); inv Sem; auto.
      - exists (fun n => match es n with
                 | present _ => true
                 | absent => false
                 end); split; intro n; specialize (Sem n); inv Sem; auto.
    Qed.

    (** We deduce from the previous lemmas the correspondence for annotated
        [exp]. *)
    Corollary sem_aexp_impl_from:
      forall n H b e es ck,
        CESem.sem_aexp b H ck e es ->
        CoInd.sem_aexp (tr_history_from n H) (tr_stream_from n b) ck e
                        (tr_stream_from n es).
    Proof.
      cofix Cofix; intros * Sem.
      pose proof Sem as Sem';
        apply sem_aexp_inv in Sem' as (Sem' & bs & Sem_ck & Ebs);
        apply (sem_exp_impl_from n) in Sem';
        apply sem_clock_impl_from with (n:=n) in Sem_ck.
      rewrite (init_from_n es) in *.
      rewrite (init_from_n bs), Ebs in Sem_ck.
      destruct (es n); econstructor; eauto;
        rewrite init_from_tl, tr_history_from_tl;
        apply Cofix; auto.
    Qed.

    Corollary sem_aexp_impl:
      forall H b e es ck,
        CESem.sem_aexp b H ck e es ->
        CoInd.sem_aexp (tr_history H) (tr_stream b) ck e (tr_stream es).
    Proof. apply sem_aexp_impl_from. Qed.
    Hint Resolve sem_aexp_impl_from sem_aexp_impl.

    (** ** cexp level synchronous operators inversion principles *)

    Lemma merge_inv:
      forall H b x t f es,
        CESem.sem_cexp b H (Emerge x t f) es ->
        exists xs ts fs,
          IStr.sem_var H x xs
          /\ CESem.sem_cexp b H t ts
          /\ CESem.sem_cexp b H f fs
          /\
          (forall n,
              (exists c,
                  xs n = present true_val
                  /\ ts n = present c
                  /\ fs n = absent
                  /\ es n = present c)
              \/
              (exists c,
                  xs n = present false_val
                  /\ ts n = absent
                  /\ fs n = present c
                  /\ es n = present c)
              \/
              (xs n = absent
               /\ ts n = absent
               /\ fs n = absent
               /\ es n = absent)).
    Proof.
      intros * Sem.
      interp_str b H x Sem.
      interp_str b H t Sem.
      interp_str b H f Sem.
      do 3 eexists; intuition; eauto.
      specialize (Sem_x n); specialize (Sem_t n); specialize (Sem_f n);
        specialize (Sem n); inv Sem.
      - left; exists c; repeat split; auto; intuition CESem.sem_det.
      - right; left; exists c; repeat split; auto; intuition CESem.sem_det.
      - right; right; repeat split; auto; intuition CESem.sem_det.
    Qed.

    Lemma ite_inv:
      forall H b le t f es,
        CESem.sem_cexp b H (Eite le t f) es ->
        exists les ts fs,
          CESem.sem_exp b H le les
          /\ CESem.sem_cexp b H t ts
          /\ CESem.sem_cexp b H f fs
          /\
          (forall n,
              (exists c b ct cf,
                  les n = present c
                  /\ val_to_bool c = Some b
                  /\ ts n = present ct
                  /\ fs n = present cf
                  /\ es n = if b then present ct else present cf)
              \/
              (les n = absent
               /\ ts n = absent
               /\ fs n = absent
               /\ es n = absent)).
    Proof.
      intros * Sem.
      interp_str b H le Sem.
      interp_str b H t Sem.
      interp_str b H f Sem.
      do 3 eexists; intuition; eauto.
      specialize (Sem_le n); specialize (Sem_t n); specialize (Sem_f n);
        specialize (Sem n); inv Sem.
      - left; exists c, b0, ct, cf; repeat split; auto; intuition CESem.sem_det.
      - right; repeat split; auto; intuition CESem.sem_det.
    Qed.

    Lemma exp_inv:
      forall H b le es,
        CESem.sem_cexp b H (Eexp le) es ->
        CESem.sem_exp b H le es.
    Proof.
      intros * Sem n.
      now specialize (Sem n); inv Sem.
    Qed.

    (** [fby] is not a predicate but a function, so we directly state the
        correspondence.  *)
    Lemma fby_impl_from:
      forall n c xs,
        tr_stream_from n (Indexed.fby c xs) ≡
        sfby (Indexed.hold c xs n) (tr_stream_from n xs).
    Proof.
      cofix Cofix; intros.
      rewrite init_from_n; rewrite (init_from_n xs).
      unfold Indexed.fby at 1.
      destruct (xs n) eqn: E.
      - constructor; simpl; auto.
        rewrite Indexed.hold_abs; auto.
      - constructor; simpl; auto.
        erewrite (Indexed.hold_pres v); eauto.
    Qed.

    Corollary fby_impl:
      forall c xs,
      tr_stream (Indexed.fby c xs) ≡ sfby c (tr_stream xs).
    Proof.
      now setoid_rewrite fby_impl_from.
    Qed.

    (** ** Semantics of cexps *)

    (** State the correspondence for [cexp].
        Goes by induction on [cexp] and uses the previous inversion lemmas. *)
    Hint Constructors merge ite.
    Lemma sem_cexp_impl_from:
      forall n H b e es,
        CESem.sem_cexp b H e es ->
        CoInd.sem_cexp (tr_history_from n H) (tr_stream_from n b) e
                       (tr_stream_from n es).
    Proof.
      intros * Sem.
      revert dependent H; revert b es n.
      induction e; intros * Sem; unfold CESem.sem_cexp, IStr.lift in Sem.

      - apply merge_inv in Sem as (xs & ts & fs & ? & ? & ? & Spec).
        econstructor; eauto.
        apply merge_spec; use_spec Spec.

      - apply ite_inv in Sem as (bs & ts & fs & ? & ? & ? & Spec).
        econstructor; eauto.
        apply ite_spec; use_spec Spec.
        destruct H4.
        + apply val_to_bool_true' in H8; subst; firstorder.
        + apply val_to_bool_false' in H8; subst; firstorder.

      - apply exp_inv in Sem; constructor; auto.
    Qed.

    Corollary sem_cexp_impl:
      forall H b e es,
        CESem.sem_cexp b H e es ->
        CoInd.sem_cexp (tr_history H) (tr_stream b) e (tr_stream es).
    Proof. apply sem_cexp_impl_from. Qed.
    Hint Resolve sem_cexp_impl_from sem_cexp_impl.

    (** An inversion principle for annotated [cexp]. *)
    Lemma sem_caexp_inv:
      forall H b e es ck,
        CESem.sem_caexp b H ck e es ->
        CESem.sem_cexp b H e es
        /\ exists bs,
            IStr.sem_clock b H ck bs
            /\ (forall n, bs n = match es n with
                           | present _ => true
                           | absent => false
                           end).
    Proof.
      intros * Sem; split.
      - intro n; specialize (Sem n); inv Sem; auto.
      - exists (fun n => match es n with
                 | present _ => true
                 | absent => false
                 end); split; intro n; specialize (Sem n); inv Sem; auto.
    Qed.

    (** We deduce from the previous lemmas the correspondence for annotated
        [cexp]. *)
    Corollary sem_caexp_impl_from:
      forall n H b e es ck,
        CESem.sem_caexp b H ck e es ->
        CoInd.sem_caexp (tr_history_from n H) (tr_stream_from n b) ck e
                        (tr_stream_from n es).
    Proof.
      cofix Cofix; intros * Sem.
      pose proof Sem as Sem';
        apply sem_caexp_inv in Sem' as (Sem' & bs & Sem_ck & Ebs);
        apply (sem_cexp_impl_from n) in Sem';
        apply sem_clock_impl_from with (n:=n) in Sem_ck.
      rewrite (init_from_n es) in *.
      rewrite (init_from_n bs), Ebs in Sem_ck.
      destruct (es n); econstructor; eauto;
        rewrite init_from_tl, tr_history_from_tl;
        apply Cofix; auto.
    Qed.

    Corollary sem_caexp_impl:
      forall H b e es ck,
        CESem.sem_caexp b H ck e es ->
        CoInd.sem_caexp (tr_history H) (tr_stream b) ck e (tr_stream es).
    Proof. apply sem_caexp_impl_from. Qed.
    Hint Resolve sem_caexp_impl_from sem_caexp_impl.

    (** * RESET CORRESPONDENCE  *)

    (** We state the correspondence for [bools_of]. *)
    Lemma bools_of_impl_from:
      forall n xs rs,
        CESem.bools_of xs rs ->
        CStr.bools_of (tr_stream_from n xs) (tr_stream_from n rs).
    Proof.
      cofix Cofix; intros * Rst.
      pose proof Rst.
      specialize (Rst n).
      rewrite (init_from_n xs), (init_from_n rs).
      destruct (xs n); constructor; auto.
    Qed.

    Corollary bools_of_impl:
      forall xs rs,
        CESem.bools_of xs rs ->
        CStr.bools_of (tr_stream xs) (tr_stream rs).
    Proof. apply bools_of_impl_from. Qed.

    (** ** Properties about [count] and [mask] *)

    (** State the correspondance for [count].  *)
    Lemma count_impl_from:
      forall n (r: stream bool),
        count_acc (if r n then IStr.count r n - 1 else IStr.count r n)
                  (tr_stream_from n r)
        ≡ tr_stream_from n (IStr.count r).
    Proof.
      (* cofix-based proof encounter the guardness criterion (Why ??)  *)
      intros; apply ntheq_eqst; intro m.
      unfold Str_nth; revert n; induction m; intro; simpl.
      - destruct (r n) eqn: R; auto.
        apply count_true_ge_1 in R; rewrite Minus.minus_Sn_m; omega.
      - rewrite <-IHm; simpl; destruct (r n) eqn: R; destruct (r (S n));
          try (apply count_true_ge_1 in R; rewrite Minus.minus_Sn_m; auto);
          try (rewrite Nat.sub_succ, Nat.sub_0_r); auto.
    Qed.

    (** Generalizing is too intricate: we can use the generalized lemma above to
        deduce this one which states the correspondence for [mask]. *)
    Corollary mask_impl:
      forall k (r: stream bool) xss,
        wf_streams xss ->
        EqSts (tr_streams (IStr.mask k r xss))
              (List.map (CStr.mask k (tr_stream r)) (tr_streams xss)).
    Proof.
      intros * Const; unfold tr_streams, tr_stream.
      apply Forall2_forall2; split.
      - rewrite map_length, 2 tr_streams_from_length, mask_length; auto.
      - intros d1 d2 n' xs1 xs2 Len Nth1 Nth2.
        rewrite tr_streams_from_length in Len.
        rewrite <-Nth1, <-Nth2.
        assert (n' < length (tr_streams_from 0 xss)) by
            (rewrite mask_length in Len; auto;
             rewrite tr_streams_from_length; auto).
        rewrite map_nth' with (d':=d2), nth_tr_streams_from_nth; auto.
        rewrite mask_length in Len; auto.
        rewrite nth_tr_streams_from_nth; auto.
        unfold CStr.mask, IStr.mask.
        apply ntheq_eqst; intro m.
        unfold nth_tr_streams_from.
        rewrite init_from_nth, mask_nth, init_from_nth.
        unfold CStr.count, streams_nth.
        pose proof (count_impl_from 0 r) as Count.
        assert ((if r 0 then IStr.count r 0 - 1 else IStr.count r 0) = 0) as E
            by (simpl; destruct (r 0); auto).
        rewrite E in Count; rewrite Count, init_from_nth, Nat.eqb_sym.
        destruct (IStr.count r (m + 0) =? k); auto.
        apply nth_all_absent.
    Qed.

    (** * FINAL LEMMAS *)

    (** Correspondence for [clocks_of], used to give a base clock for node
        applications. *)
    Lemma tr_clocks_of_from:
      forall n xss,
        wf_streams xss ->
        CStr.clocks_of (tr_streams_from n xss) ≡ tr_stream_from n (CESem.clock_of xss).
    Proof.
      cofix Cofix; intros.
      constructor; simpl.
      - unfold CESem.clock_of, CESem.clock_of_instant.
        destruct (existsb (fun v : value => v <>b absent) (xss n)) eqn: E.
        + assert (forall v, v <> absent <-> (v <>b absent) = true)
            by (unfold nequiv_decb; setoid_rewrite Bool.negb_true_iff;
                setoid_rewrite not_equiv_decb_equiv; reflexivity).
          rewrite <-Exists_existsb with (P := fun v => hd v <> absent); auto.
          rewrite <-Exists_existsb with (P := fun v => v <> absent) in E; auto.
          apply Exists_In_tr_streams_from_hd in E; auto.
        + unfold nequiv_decb in *.
          apply existsb_Forall_neg, forallb_Forall in E.
          apply existsb_Forall_neg, forallb_Forall, Forall_forall.
          intros * Hin.
          eapply Forall_In_tr_streams_from_hd in E; eauto.
      - rewrite tr_streams_from_tl; auto.
    Qed.

    Corollary tr_clocks_of:
      forall xss,
        wf_streams xss ->
        CStr.clocks_of (tr_streams xss) ≡ tr_stream (CESem.clock_of xss).
    Proof. apply tr_clocks_of_from. Qed.

    Lemma sem_clocked_var_inv:
      forall b H x xs ck,
        IStr.sem_var H x xs ->
        CESem.sem_clocked_var b H x ck ->
        exists bs,
          IStr.sem_clock b H ck bs
          /\ (forall n, bs n = true <-> xs n <> absent).
    Proof.
      intros * Var Sem.
      assert (IStr.sem_clock b H ck (interp_clock b H ck)) as SemCk.
      { intro n; specialize (Sem n); specialize (Var n); destruct Sem as (Sem & Sem').
        unfold interp_clock, lift_interp.
        destruct (xs n).
        - erewrite <-interp_clock_instant_sound; eauto; apply Sem'; auto.
        - erewrite <-interp_clock_instant_sound; eauto; apply Sem; eauto.
      }
      exists (interp_clock b H ck); split; auto.
      intro n; specialize (Var n); specialize (SemCk n); specialize (Sem n);
        destruct Sem as (Sem & Sem').
      split.
      - intros E E'.
        rewrite E in SemCk; apply Sem in SemCk as (?&?).
        rewrite E' in Var.
        eapply sem_var_instant_det in Var; eauto; discriminate.
      - intro E; apply not_absent_present in E as (?& E).
        rewrite E in Var.
        assert (sem_clock_instant (b n) (H n) ck true)
          by (apply Sem; eauto).
        eapply sem_clock_instant_det; eauto.
    Qed.

    Lemma sem_clocked_var_impl_from:
      forall n H b x xs ck,
        IStr.sem_var H x xs ->
        CESem.sem_clocked_var b H x ck ->
        CoInd.sem_clocked_var (tr_history_from n H) (tr_stream_from n b) x ck.
    Proof.
      intros * Var Sem; eapply sem_clocked_var_inv in Sem as (bs & Clock & Spec); eauto.
      apply sem_var_impl_from with (n := n) in Var;
        apply sem_clock_impl_from with (n := n) in Clock.
      split; eauto.
      intros * Var'.
      eapply sem_var_det in Var; eauto.
      eexists; split; eauto.
      rewrite Var.
      clear - Spec.
      generalize n; clear n.
      cofix COFIX; intros.
      rewrite init_from_n, (init_from_n bs).
      destruct (xs n) eqn: E.
      - assert (bs n = false) as ->
            by (rewrite <-Bool.not_true_iff_false, Spec; auto).
        constructor; auto.
      - assert (bs n = true) as ->
            by (apply Spec; intro; congruence).
        constructor; auto.
    Qed.

    Corollary sem_clocked_var_impl:
      forall H b x xs ck,
        IStr.sem_var H x xs ->
        CESem.sem_clocked_var b H x ck ->
        CoInd.sem_clocked_var (tr_history H) (tr_stream b) x ck.
    Proof. apply sem_clocked_var_impl_from. Qed.

    Lemma sem_clocked_vars_impl:
      forall H b xs xss,
        CESem.sem_vars H (List.map fst xs) xss ->
        CESem.sem_clocked_vars b H xs ->
        CoInd.sem_clocked_vars (tr_history H) (tr_stream b) xs.
    Proof.
      unfold CESem.sem_clocked_vars; intros * Vars Sem.
      apply Forall_forall; intros (x, ck) Hin.
      apply sem_vars_inv in Vars.
      pose proof Hin as Hin'.
      apply in_map with (f := fst) in Hin.
      eapply Forall2_in_left in Vars as (?&?&?); eauto.
      eapply sem_clocked_var_impl; eauto.
      intro n; specialize (Sem n).
      eapply Forall_forall in Sem; eauto.
    Qed.
    Hint Resolve sem_clocked_vars_impl.

    (** The final theorem stating the correspondence for nodes applications.
        We have to use a custom mutually recursive induction scheme [sem_node_mult]. *)
    Hint Constructors CoInd.sem_equation.
    Theorem implies:
      forall f xss oss,
        Indexed.sem_node G f xss oss ->
        CoInd.sem_node G f (tr_streams xss) (tr_streams oss).
    Proof.
      induction 1 as [| |????????????????? IH| |??????????? Heqs IH]
                       using Indexed.sem_node_mult with
          (P_equation := fun b H e =>
                           Indexed.sem_equation G b H e ->
                           CoInd.sem_equation G (tr_history H) (tr_stream b) e);
        eauto.

      - econstructor; eauto.
        rewrite tr_clocks_of; eauto.
        edestruct Indexed.sem_node_wf; eauto.

      - econstructor; eauto.
        + rewrite tr_clocks_of; eauto.
          eapply wf_streams_mask.
          intro k; destruct (IH k) as (Sem &?).
          apply Indexed.sem_node_wf in Sem as (?&?); eauto.
        + apply bools_of_impl; eauto.
        + intro k; destruct (IH k) as (?&?).
          rewrite <- 2 mask_impl; eauto;
            eapply wf_streams_mask; intro n'; destruct (IH n') as (Sem &?);
              apply Indexed.sem_node_wf in Sem as (?&?); eauto.

      - econstructor; eauto; subst.
        rewrite <-fby_impl; eauto.

      - subst.
        CESem.assert_const_length xss.
        econstructor; eauto.
        + rewrite tr_clocks_of; eauto.
          eapply sem_clocked_vars_impl; eauto.
          rewrite map_fst_idck; eauto.
        + apply Forall_forall; intros * Hin.
          rewrite tr_clocks_of; auto.
          eapply Forall_forall in Heqs; eapply Forall_forall in IH; eauto.
    Qed.

  End Global.

End NLINDEXEDTOCOIND.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj16synthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (lv3)).
Admitted.
QuickChick conj16synthconj6.


Require Import CertiGraph.graph.SpaceAdjMatGraph3.

Require Import CertiGraph.dijkstra.dijkstra_env.

(* A separate file with the underlying PQ spec-ed out *)
Require Export CertiGraph.binheap.binary_heap_malloc_spec.
Require Export CertiGraph.binheap.spec_binary_heap_pro.

(* Dijkstra-specific imports *)
Require Import CertiGraph.dijkstra.MathDijkGraph.
Require Export CertiGraph.dijkstra.dijkstra_spec_pure.

(* The first moment we become implementation-specific *)
Require Export CertiGraph.dijkstra.dijkstra3.
Require Import CertiGraph.dijkstra.dijkstra_constants.

Local Open Scope Z_scope.

Section DijkstraSpec.

  Context {Z_EqDec : EquivDec.EqDec Z eq}.

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

  Definition getCell_spec :=
    DECLARE _getCell
    WITH sh: rshare,
         g: @DijkGG size inf,
         graph_ptr: pointer_val,
         addresses: list val,
         u: V,
         i : V
    PRE [tptr (tarray tint size), tint, tint]
      PROP (0 <= i < size;
          0 <= u < size)
      PARAMS (pointer_val_val graph_ptr;
           Vint (Int.repr u);
           Vint (Int.repr i))
      GLOBALS ()
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val graph_ptr))
    POST [tint]
      PROP ()
      RETURN (Vint (Int.repr (Znth i (Znth u (@graph_to_mat size g id)))))
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val graph_ptr)).

  Definition dijkstra_spec :=
    DECLARE _dijkstra
    WITH sh: rshare,
         g: DijkGG,
         graph_ptr : pointer_val,
         addresses : list val,
         dist_ptr : pointer_val,
         prev_ptr : pointer_val,
         src : V
    PRE [tptr (tarray tint size), tint, tptr tint, tptr tint]
      PROP (vvalid g src;
           12 * size <= Int.max_unsigned;
           connected_dir g src)
      PARAMS (pointer_val_val graph_ptr;
             Vint (Int.repr src);
             pointer_val_val dist_ptr;
             pointer_val_val prev_ptr)
      GLOBALS ()
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val graph_ptr);
          data_at_ Tsh (tarray tint size) (pointer_val_val dist_ptr);
          data_at_ Tsh (tarray tint size) (pointer_val_val prev_ptr))
    POST [tvoid]
      EX prev: list V,
      EX dist: list V,
      PROP (forall dst,
               vvalid g dst ->
               @inv_popped size inf g src (VList g) prev dist dst)
      LOCAL ()
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val graph_ptr);
          data_at Tsh (tarray tint size) (map Vint (map Int.repr prev)) (pointer_val_val prev_ptr);
          data_at Tsh (tarray tint size) (map Vint (map Int.repr dist)) (pointer_val_val dist_ptr)).

  Definition Gprog : funspecs :=
    ltac:(with_library prog [
                       getCell_spec;
                       dijkstra_spec;
                       mallocN_spec;
                       freeN_spec;
                       pq_remove_min_nc_spec;
                       pq_insert_nc_spec;
                       pq_size_spec;
                       pq_make_spec;
                       pq_edit_priority_spec;
                       pq_free_spec]).

End DijkstraSpec.


Require Import Coq.omega.Omega.
Require Import Bedrock.Platform.AutoSep.

Lemma allocate_array' : forall p n offset,
  allocated p offset n ===> Ex ls, [| length ls = n |] * array ls (p ^+ $ (offset)).
  induction n; simpl.

  sepLemma.
  instantiate (1 := nil); auto.
  sepLemma.

  intros; sepLemmaLhsOnly.
  etransitivity; [ eapply himp_star_frame; [ apply IHn | reflexivity ] | ]; clear IHn.
  sepLemmaLhsOnly.
  apply himp_ex_c; exists (x :: x0).
  sepLemma.
  etransitivity; [ eapply himp_star_frame; [ apply Arrays.ptsto32m'_in | reflexivity ] | ].
  etransitivity; [ | apply ptsto32m'_out ].
  simpl.
  destruct offset; simpl.
  replace (p ^+ natToW 0) with p by words; sepLemma.
  etransitivity; [ | apply ptsto32m'_shift_base ].
  instantiate (1 := 4); reflexivity.
  auto.
  replace (p ^+ natToW (S offset) ^+ $0) with (p ^+ natToW (S offset)) by words.
  sepLemma.
  etransitivity; [ | apply ptsto32m'_shift_base ].
  instantiate (1 := 4).
  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  replace (S offset + 4) with (S (S (S (S (S offset))))) by omega.
  reflexivity.
  auto.
Qed.

Inductive make_array : Prop := MakeArray.

Hint Constructors make_array.

Lemma allocate_array : forall p n,
  p = p
  -> make_array
  -> p =?> n ===> Ex ls, [| length ls = n |] * array ls p.
  intros; eapply Himp_trans; [ apply allocate_array' | ].
  replace (p ^+ $0) with p by words; apply Himp_refl.
Qed.

Lemma free_array' : forall p n offset,
  Ex ls, [| length ls = n |] * array ls (p ^+ $ (offset)) ===> allocated p offset n.
  sepLemma.
  etransitivity; [ apply ptsto32m_allocated | ].
  etransitivity; [ apply allocated_shift_base | ].
  3: sepLemma.
  unfold natToW; W_eq.
  auto.
Qed.

Inductive dissolve_array : Prop := DissolveArray.

Hint Constructors dissolve_array.

Lemma free_array : forall p n,
  p = p
  -> dissolve_array
  -> Ex ls, [| length ls = n |] * array ls p ===> p =?> n.
  intros; eapply Himp_trans; [ | apply free_array' ].
  replace (p ^+ $0) with p by words; apply Himp_refl.
Qed.

Lemma selN_updN_eq : forall v a n,
  (n < length a)%nat
  -> Array.selN (Array.updN a n v) n = v.
  induction a; destruct n; simpl; intuition.
Qed.

Lemma selN_upd_eq : forall v a n,
  (n < length a)%nat
  -> goodSize (length a)
  -> Array.selN (Array.upd a (natToW n) v) n = v.
  intros; rewrite upd_updN.
  apply selN_updN_eq; auto.
  eauto using goodSize_weaken.
Qed.

Lemma inc : forall n (w : W) l,
  n = wordToNat l
  -> w < natToW n
  -> w ^+ natToW 1 <= l.
  intros; subst.
  assert (exists b, w < b) by eauto.
  pre_nomega.
  destruct H.
  erewrite <- next; eauto.
  unfold natToW in *; rewrite natToWord_wordToNat in *.
  auto.
Qed.

Theorem natToW_wordToNat : forall w : W,
  natToW (wordToNat w) = w.
  intros; apply natToWord_wordToNat.
Qed.

Theorem wordToNat_inj : forall sz (u v : word sz),
  wordToNat u = wordToNat v
  -> u = v.
  intros; rewrite <- (natToWord_wordToNat u); rewrite <- (natToWord_wordToNat v); congruence.
Qed.

Ltac match_locals :=
  match goal with
    | [ _ : context[locals ?NS ?X _ _] |- context[locals ?NS ?Y _ _] ] => equate X Y
  end; descend.

Local Hint Extern 1 (@eq W _ _) => words.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D Aprime Bprime Cprime Dprime X Y E Z Eprime : Universe, ((wd_ X A /\ (wd_ X Aprime /\ (wd_ X C /\ (wd_ X Cprime /\ (wd_ Y B /\ (wd_ Y Bprime /\ (wd_ Y D /\ (wd_ Y Dprime /\ (wd_ A C /\ (wd_ B D /\ (wd_ A Aprime /\ (wd_ B Bprime /\ (wd_ C Cprime /\ (wd_ D Dprime /\ (wd_ Aprime Cprime /\ (wd_ Bprime Dprime /\ (wd_ A E /\ (wd_ Aprime Eprime /\ (wd_ B E /\ (wd_ Bprime Eprime /\ (wd_ Y A /\ (wd_ A B /\ (wd_ X B /\ (wd_ Aprime Dprime /\ (wd_ Dprime Eprime /\ (wd_ A D /\ (wd_ D E /\ (wd_ A Eprime /\ (wd_ E Aprime /\ (wd_ E Eprime /\ (wd_ Y E /\ (wd_ Y Z /\ (wd_ B Z /\ (wd_ E Z /\ (wd_ X E /\ (wd_ X Z /\ (wd_ A Z /\ (wd_ X Y /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ Aprime Bprime /\ (col_ X A C /\ (col_ X A Aprime /\ (col_ X A Cprime /\ (col_ Y B D /\ (col_ Y B Bprime /\ (col_ Y B Dprime /\ (col_ E A B /\ (col_ E C D /\ (col_ Eprime Aprime Bprime /\ (col_ Eprime E Z /\ (col_ B Bprime Eprime /\ (col_ E Bprime Eprime /\ col_ Bprime Aprime B))))))))))))))))))))))))))))))))))))))))))))))))))))) -> col_ Aprime Y B)).
Proof.
  time tac.
Qed.

End FOFProblem.


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.