(** * Partial: Triples for Partial Correctness *)

Set Implicit Arguments.
From SLF Require Export Nondet.

Implicit Types f : var.
Implicit Types b : bool.
Implicit Types s : state.
Implicit Types t : trm.
Implicit Types v : val.
Implicit Types n : int.
Implicit Types p : loc.
Implicit Types h : heap.
Implicit Types P : Prop.
Implicit Types H : hprop.
Implicit Types Q : val->hprop.

(* ################################################################# *)
(** * First Pass *)

(** In this chapter, we investigate definitions of Hoare triples and Separation
    Logic triples with respect to partial correctness, that is, without imposing
    termination.

    Partial correctness is a weaker property than total correctness. However,
    it may be suited for reasoning about programs that are not meant to
    terminate, and may be interesting to consider as an intermediate target
    when reasoning about programs for which termination is much harder to
    establish than correctness.

    This chapter is organized as follows:

    - Partial correctness with respect to big-step semantics.
    - Bonus contents: partial correctness with respect to small-step semantics.

    This chapter, like the previous chapter [Nondet], omits sequences and
    non-recursive functions, as these features can be encoded. *)

(* ================================================================= *)
(** ** Big-Step Characterization of Partial Correctness *)

(** For total correctness, the judgment [evals s t Q] asserts that any
    execution of the program [(s,t)] terminates on an output satisfying [Q].
    In contrast, the partial correctness judgment [evalnp s t Q] asserts that
    any execution of the program [(s,t)] either terminates on an output
    satisfying [Q], or diverges (that is, executes for ever).

    The definition of the predicate [evalnp] is obtained by taking the
    constructors from the inductive definition of [evals], and considering
    the coinductive interpretation of these constructors. The coinductive
    interpretation allows for infinite derivation. It thereby introduces the
    possibility of diverging executions. Importantly, the predicate [evalnp]
    still disallows executions that get stuck. *)

CoInductive evalnp : state -> trm -> (val->state->Prop) -> Prop :=
  | evalnp_val : forall s v Q,
      Q v s ->
      evalnp s (trm_val v) Q
  | evalnp_fix : forall s f x t1 Q,
      Q (val_fix f x t1) s ->
      evalnp s (trm_fix f x t1) Q
  | evalnp_app_fix : forall s1 v1 v2 f x t1 Q,
      v1 = val_fix f x t1 ->
      evalnp s1 (subst x v2 (subst f v1 t1)) Q ->
      evalnp s1 (trm_app v1 v2) Q
  | evalnp_let : forall Q1 s1 x t1 t2 Q,
      evalnp s1 t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalnp s2 (subst x v1 t2) Q) ->
      evalnp s1 (trm_let x t1 t2) Q
  | evalnp_if : forall s1 b t1 t2 Q,
      evalnp s1 (if b then t1 else t2) Q ->
      evalnp s1 (trm_if (val_bool b) t1 t2) Q
  | evalnp_add : forall s n1 n2 Q,
      Q (val_int (n1 + n2)) s ->
      evalnp s (val_add (val_int n1) (val_int n2)) Q
  | evalnp_rand : forall s n Q,
      n > 0 ->
      (forall n1, 0 <= n1 < n -> Q n1 s) ->
      evalnp s (val_rand (val_int n)) Q
  | evalnp_ref : forall s v Q,
      (forall p, ~ Fmap.indom s p ->
         Q (val_loc p) (Fmap.update s p v)) ->
      evalnp s (val_ref v) Q
  | evalnp_get : forall s p Q,
      Fmap.indom s p ->
      Q (Fmap.read s p) s ->
      evalnp s (val_get (val_loc p)) Q
  | evalnp_set : forall s p v Q,
      Fmap.indom s p ->
      Q val_unit (Fmap.update s p v) ->
      evalnp s (val_set (val_loc p) v) Q
  | evalnp_free : forall s p Q,
      Fmap.indom s p ->
      Q val_unit (Fmap.remove s p) ->
      evalnp s (val_free (val_loc p)) Q.

(** The judgment [hoarenp t H Q] captures partial correctness, in terms of
    [evalnp]. It is defined through the usual pattern for Hoare triples. *)

Definition hoarenp (t:trm) (H:hprop) (Q:val->hprop) : Prop :=
  forall s, H s -> evalnp s t Q.

(** One key property is the covariance of [evalnp], which induces the rule
    of consequence for [hoarenp]. An interesting about the proof of covariance
    is that it is not carried out by induction, like [evaln_conseq], but by
    coinduction. Observe carefully the details of that proof. *)

Lemma evalnp_conseq : forall s t Q1 Q2,
  evalnp s t Q1 ->
  Q1 ===> Q2 ->
  evalnp s t Q2.
Proof using.
  introv M W. unfolds qimpl, himpl.
  gen s t Q1 Q2. cofix IH. intros. inverts M; try solve [ constructors* ].
Qed.

(* ================================================================= *)
(** ** From Total to Partial Correctness *)

(** Total correctness is a stronger property than partial correctness:
    [hoaren t H Q] entails [hoarenp t H Q]. To formalize this result, we first
    establish that [evaln s t Q], which is defined inductively, entails
    [evalnp s t Q], which is defined coinductively.

    The proof is a straightforward induction, reflecting on the fact that a
    coinductive interpretation of a set of rules is always derivable from an
    inductive interpretation of a same set of derivation rules. *)

Lemma evalnp_of_evaln : forall s t Q,
  evaln s t Q ->
  evalnp s t Q.
Proof using. introv M. induction M; try solve [ constructors* ]. Qed.

Lemma hoaren_of_cohoare : forall t H Q,
  hoaren t H Q ->
  hoarenp t H Q.
Proof using.
  introv M. intros s K. specializes M K. applys evalnp_of_evaln M.
Qed.

(* ================================================================= *)
(** ** Characterization of Divergence *)

(** The judgment partial correctness judgment [evalnp s t Q] asserts that
    any execution of the program [(s,t)] either terminates on an output
    satisfying [Q], or diverge. By instantiating [Q] as the predicate that is
    always false, we are thus able to assert that "every possible execution of
    the program [(s,t)] diverges".

    Let us name [Empty] this "empty" postcondition, which characterizes an
    empty set of output configurations. *)

Definition Empty : val->state->Prop :=
  fun v s => False.

(** The judgment [divn s t], defined as [evalnp s t Empty], asserts that every
    possible execution of the program [(s,t)] diverges. *)

Definition divn (s:state) (t:trm) : Prop :=
  evalnp s t Empty.

(* ================================================================= *)
(** ** Big-Step-Based Reasoning Rules *)

(** For the partial correctness triple ([hoarenp]), we can derive all the usual
    reasoning rules. The proofs are the same as for the reasoning rules for
    deriving total correctness triples ([hoaren]). *)

(** Structural rules *)

Lemma hoarenp_conseq : forall t H' Q' H Q,
  hoarenp t H' Q' ->
  H ==> H' ->
  Q' ===> Q ->
  hoarenp t H Q.
Proof using.
  unfolds hoarenp. introv M MH MQ HF. applys* evalnp_conseq.
Qed.

Lemma hoarenp_hexists : forall t (A:Type) (J:A->hprop) Q,
  (forall x, hoarenp t (J x) Q) ->
  hoarenp t (hexists J) Q.
Proof using. introv M. intros h (x&Hh). applys M Hh. Qed.

Lemma hoarenp_hpure : forall t (P:Prop) H Q,
  (P -> hoarenp t H Q) ->
  hoarenp t (\[P] \* H) Q.
Proof using.
  introv M. intros h (h1&h2&M1&M2&D&U). destruct M1 as (M1&HP).
  lets E: hempty_inv HP. subst. rewrite Fmap.union_empty_l. applys~ M.
Qed.

(** Rules for term constructs *)

Lemma hoarenp_val : forall v H Q,
  H ==> Q v ->
  hoarenp (trm_val v) H Q.
Proof using. introv M. intros h K. applys* evalnp_val. Qed.

Lemma hoarenp_fix : forall f x t1 H Q,
  H ==> Q (val_fix f x t1) ->
  hoarenp (trm_fix f x t1) H Q.
Proof using. introv M. intros h K. applys* evalnp_fix. Qed.

Lemma hoarenp_app_fix : forall v1 v2 f x t1 H Q,
  v1 = val_fix f x t1 ->
  hoarenp (subst x v2 (subst f v1 t1)) H Q ->
  hoarenp (trm_app v1 v2) H Q.
Proof using. introv E M. intros h K. applys* evalnp_app_fix. Qed.

Lemma hoarenp_let : forall x t1 t2 H Q Q1,
  hoarenp t1 H Q1 ->
  (forall v1, hoarenp (subst x v1 t2) (Q1 v1) Q) ->
  hoarenp (trm_let x t1 t2) H Q.
Proof using. introv M1 M2. intros h K. applys* evalnp_let. Qed.

Lemma hoarenp_if : forall (b:bool) t1 t2 H Q,
  hoarenp (if b then t1 else t2) H Q ->
  hoarenp (trm_if b t1 t2) H Q.
Proof using. introv M. intros h K. applys* evalnp_if. Qed.

(** Rules for primitive operations *)

Lemma hoarenp_add : forall H n1 n2,
  hoarenp (val_add n1 n2)
    H
    (fun r => \[r = val_int (n1 + n2)] \* H).
Proof using.
  intros. intros h K. applys* evalnp_add. rewrite* hstar_hpure_l.
Qed.

Lemma hoarenp_rand : forall n,
  n > 0 ->
  hoarenp (val_rand n)
    \[]
    (fun r => \exists n1, \[0 <= n1 < n] \* \[r = val_int n1]).
Proof using.
  introv N. intros h K. applys* evalnp_rand.
  lets ->: hempty_inv K.
  intros n1 H1. applys* hexists_intro n1. rewrite* hstar_hpure_l.
  split*. applys* hpure_intro.
Qed.

Lemma hoarenp_ref : forall H v,
  hoarenp (val_ref v)
    H
    (fun r => (\exists p, \[r = val_loc p] \* p ~~> v) \* H).
Proof using.
  intros. intros s1 K. applys evalnp_ref. intros p D.
  unfolds update. applys hstar_intro K.
  { applys hexists_intro p. rewrite hstar_hpure_l.
    split*. applys hsingle_intro. }
  { applys* disjoint_single_of_not_indom. }
Qed.

Lemma hoarenp_get : forall H v p,
  hoarenp (val_get p)
    ((p ~~> v) \* H)
    (fun r => \[r = v] \* (p ~~> v) \* H).
Proof using.
  intros. intros s K.
  lets (h1&h2&P1&P2&D&->): hstar_inv (rm K).
  lets E1: hsingle_inv P1. lets I1: indom_single p v.
  applys evalnp_get.
  { applys* Fmap.indom_union_l. subst. applys indom_single. }
  { rewrite hstar_hpure_l. split.
    { subst h1. rewrite* Fmap.read_union_l. rewrite* Fmap.read_single. }
    { applys* hstar_intro. } }
Qed.

Lemma hoarenp_set : forall H w p v,
  hoarenp (val_set (val_loc p) v)
    ((p ~~> w) \* H)
    (fun r => \[r = val_unit] \* (p ~~> v) \* H).
Proof using.
  intros. intros s1 K.
  lets (h1&h2&P1&P2&D&->): hstar_inv (rm K).
  lets E1: hsingle_inv P1. lets I1: indom_single p v.
  applys evalnp_set.
  { applys* Fmap.indom_union_l. subst. applys indom_single. }
  { rewrite hstar_hpure_l. split*.
    { subst h1. rewrite Fmap.update_union_l.
      2:{ applys indom_single. }
      rewrite update_single. applys hstar_intro.
      { applys hsingle_intro. }
      { applys P2. }
      { applys Fmap.disjoint_single_set D. } } }
Qed.

Lemma hoarenp_free : forall H p v,
  hoarenp (val_free (val_loc p))
    ((p ~~> v) \* H)
    (fun r => \[r = val_unit] \* H).
Proof using.
  intros. intros s1 K.
  lets (h1&h2&P1&P2&D&->): hstar_inv (rm K).
  lets E1: hsingle_inv P1. lets I1: indom_single p v.
  applys evalnp_free.
  { applys* Fmap.indom_union_l. subst. applys indom_single. }
  { rewrite hstar_hpure_l. split*.
    { subst h1. rewrite* Fmap.remove_union_single_l.
      { intros Dl. applys* Fmap.disjoint_inv_not_indom_both D Dl. } } }
Qed.

(* ================================================================= *)
(** ** Big-Step-Based Reasoning Rules for Divergence *)

(** In a partial correctness setting, it is also interesting to derive
    reasoning rules for establishing that a program diverges. These rules
    are stated and proved next. *)

Lemma divn_app_fix : forall s1 v1 v2 f x t1,
  v1 = val_fix f x t1 ->
  divn s1 (subst x v2 (subst f v1 t1)) ->
  divn s1 (trm_app v1 v2).
Proof using. introv E M. unfolds divn. applys* evalnp_app_fix. Qed.

(** **** Exercise: 2 stars, standard, especially useful (divn_let_ctx)

    Prove the divergence rule for a let-binding covering the case where the
    first subterm diverges. *)

Lemma divn_let_ctx : forall s1 x t1 t2,
  divn s1 t1 ->
  divn s1 (trm_let x t1 t2).
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

Lemma divn_let : forall s1 x t1 t2 Q1,
  evalnp s1 t1 Q1 ->
  (forall s2 v1, divn s2 (subst x v1 t2)) ->
  divn s1 (trm_let x t1 t2).
Proof using. introv M1 M2. unfolds divn. applys* evalnp_let M1. Qed.

Lemma divn_if : forall s1 b t1 t2,
  divn s1 (if b then t1 else t2) ->
  divn s1 (trm_if (val_bool b) t1 t2).
Proof using. introv M. unfolds divn. applys* evalnp_if. Qed.

(* ################################################################# *)
(** * Optional Material *)

(** So far, this chapter has focused on handling partial correctness using
    a big-step semantics. In this bonus section, we investigate the treatment
    of partial correctness using a small-step semantics. *)

(** Before we get started, let us state and prove a basic lemma asserting
    that values cannot take a step. It will useful throughout the section. *)

Lemma exists_step_val_inv : forall s v,
  (exists s' t', step s v s' t') ->
  False.
Proof using. introv (s'&t'&S). inverts S. Qed.

(* ================================================================= *)
(** ** Small-Step Characterization of Partial Correctness *)

(** In the chapter [Nondet], we presented a definition named
    [evals_attempt_3] that defined a small-step characterization of partial
    correctness. Let us rename this definition to [evalnps].

    The judgment [evalnps s t Q] asserts that, for any configuration
    [(s',t')] that can be reached from [(s',t')], either [t'] is a value that,
    together with [s'], satisfy the postcondition [Q]; or the configuration
    [(s',t')] can take a step, that is, it is not a stuck configuration. *)

Definition evalnps (s:state) (t:trm) (Q:val->state->Prop) : Prop :=
  forall s' t', evals s t s' t' ->
       (exists v, t' = trm_val v /\ Q v s')
    \/ (exists s'' t'', step s' t' s'' t'').

(** On top of [evalnps], we define a partial correctness Hoare triple
    judgment [hoarenps] in the usual way. *)

Definition hoarenps (t:trm) (H:hprop) (Q:val->hprop) : Prop :=
  forall s, H s -> evalnps s t Q.

(** The property [evalnps s t Q] may be viewed as a form of typing:
    the configuration [(s,t)] admits the "type" [Q].

    - Base case: if [t] is a value, we assert that a configuration [(s,v)] has
      type [Q] iff [Q v s] holds.

    - Preservation property: if the configuration [(s,t)] has type [Q] and
      reduces to [(s',t')], then the configuration [(s',t')] also admits the
      same type [Q].

    - Progress property: if the configuration [(s,t)] has type [Q], then
      either [t] is of the form [trm_val v] and [(s,v)] admits type [Q],
      or the configuration [(s,t)] can take a reduction step to some
      configuration [(s',t')].

    The progress property is, in essence, a partial correctness
    property. Indeed, it ensures that programs never get stuck, yet without
    imposing termination.

    In what follows, we formally state and prove the three properties
    associated with the judgment [evalnps s t Q]: the characterization of the
    base case, the preservation property, and the progress property. *)

(** First, let's prove an introduction lemma and an inversion lemma for the
    base case, that is, the characteriation of values. *)

Lemma evalnps_val : forall s v Q,
  Q v s ->
  evalnps s v Q.
Proof using.
  introv M R. inverts R as.
  { left*. }
  { intros s1 t1 R1 R2. false. inverts R1. }
Qed.

Lemma evalnps_val_inv : forall s v Q,
  evalnps s v Q ->
  Q v s.
Proof using.
  introv M. forwards N: M s v. { applys evals_refl. }
  destruct N as [(v1&E1&P1)|(s2&t2&R)].
  { inverts* E1. }
  { inverts R. }
Qed.

(** Second, let's prove the preservation property. *)

(** **** Exercise: 3 stars, standard, especially useful (evalnps_inv_step)

    Prove that the property [evalnps] for a given postcondition [Q] is
    preserved when a program takes a reduction step. *)

Lemma evalnps_inv_step : forall s1 t1 s2 t2 Q,
  evalnps s1 t1 Q ->
  step s1 t1 s2 t2 ->
  evalnps s2 t2 Q.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** Third, let's prove the progress property. *)

(** **** Exercise: 4 stars, standard, especially useful (evalnps_not_val_inv)

    Prove that if the property [evalnps] holds for a given postcondition [Q],
    and for a configuration that has not already reached a value, and this
    configuration can take a step. Moreover, the configuration reached also
    satisfies the property [evalnps] for that same [Q]. *)

Lemma evalnps_not_val_inv : forall s1 t1 Q,
  evalnps s1 t1 Q ->
  (forall v, t1 <> trm_val v) ->
  exists s2 t2, step s1 t1 s2 t2 /\ evalnps s2 t2 Q.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Reasoning Rules w.r.t. Small-Step Characterization *)

(** We present two proofs of reasoning rules established with respect to the
    judgment [hoarenps]. The first proof targets the rule of consequence. This
    result leverages the covariance property for [evalnps]. *)

Lemma evalnps_conseq : forall s t Q Q',
  evalnps s t Q' ->
  Q' ===> Q ->
  evalnps s t Q.
Proof using.
  introv M WQ. introv R. lets [(v&E&P)|N]: M R.
  { left. exists v. split~. applys* WQ. }
  { right*. }
Qed.

Lemma hoarenps_conseq : forall t H' Q' H Q,
  hoarenps t H' Q' ->
  H ==> H' ->
  Q' ===> Q ->
  hoarenps t H Q.
Proof using.
  introv M WH WQ. intros h K. applys evalnps_conseq WQ.
  applys M. applys WH K.
Qed.

(** The second proof targets the reasoning rule for let-bindings, stated
    for the judgment [hoarenps]. This result leverages as key intermediate
    lemma an introduction rule for let-bindings with respect to [evalnps]. *)

(** **** Exercise: 5 stars, standard, especially useful (evalnps_let)

    Prove the reasoning rule for let-bindings for [evalnps]. *)

Lemma evalnps_let : forall s x t1 t2 Q1 Q,
  evalnps s t1 Q1 ->
  (forall s1 v1, Q1 v1 s1 -> evalnps s1 (subst x v1 t2) Q) ->
  evalnps s (trm_let x t1 t2) Q.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

Lemma hoarenps_let : forall x t1 t2 H Q Q1,
  hoarenps t1 H Q1 ->
  (forall v1, hoarenps (subst x v1 t2) (Q1 v1) Q) ->
  hoarenps (trm_let x t1 t2) H Q.
Proof using.
  introv M1 M2. intros h K. applys* evalnps_let.
  { introv K'. applys* M2. }
Qed.

(* ================================================================= *)
(** ** Small-Step Characterization of Divergence *)

(** Recall the definition of [evalnps].

    Definition evalnps (s:state) (t:trm) (Q:val->state->Prop) : Prop :=
      forall s' t', evals s t s' t' ->
           (exists v, t' = trm_val v /\ Q v s')
        \/ (exists s'' t'', step s' t' s'' t'').

    The judgment [evalnps s t Q] can be specialized with the empty post-
    condition [Q := Empty] to express divergence, just like we did earlier on
    for setting up the definition of [divn].

    Recall that [Empty v s] is equivalent to [False]. Thus, let's take the
    definition of [evalnps s t Q] and replace [Q v s'] with [False]. The
    first clause of the disjunction, [exists v, t' = trm_val v /\ Q v s']
    is never satisfiable and thus may be removed. What remains is a simpler,
    direct characterization of the property that "all executions diverge".

    The corresponding predicate, named [divns s t] below, asserts that any
    execution prefix can be extended by at least one step. *)

Definition divns (s:state) (t:trm) : Prop :=
  forall s' t', evals s t s' t' ->
  exists s'' t'', step s' t' s'' t''.

(** **** Exercise: 3 stars, standard, optional (divns_iff_evalnps_Empty)

    Prove the equivalence between [divns] and the specialization
    of [evalnps] to [Empty]. *)

Lemma divns_iff_evalnps_Empty : forall s t,
  divns s t <-> evalnps s t Empty.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 2 stars, standard, optional (divns_inv_step)

    Prove that if a diverging configuration takes a step, then it reaches a
    configuration that also diverges. *)

Lemma divns_inv_step : forall s1 t1 s2 t2,
  divns s1 t1 ->
  step s1 t1 s2 t2 ->
  divns s2 t2.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 2 stars, standard, optional (divns_val_inv)

    Prove that the execution of a value does not diverge. *)

Lemma divns_val_inv : forall s v,
  ~ divns s v.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 5 stars, standard, optional (divns_let_ctx)

    Prove the divergence rule for a let-binding covering the case where the
    first subterm diverges, with respect to the definition [divns]. *)

Lemma divns_let_ctx : forall s1 x t1 t2,
  divns s1 t1 ->
  divns s1 (trm_let x t1 t2).
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Coinductive, Small-Step Characterization of Partial Correctness *)

(** In the previous section, we characterized partial correctness using the
    judgment [evalnps], which is defined in terms of the transitive closure
    of the small-step relation [evals]. In this section, we present an
    alternative definition, based on a coinductive definition.

    Concretely, we start from the inductively defined judgment [evalns],
    which characterizes total correctness, and we consider the coinductive
    intrepretation of the same rules. The resulting judgment is written
    [evalnpz s t Q]. This coinductive definition, because it allows for
    infinite derivations, covers the case of diverging computations that
    take involve infinitely many reduction steps. *)

CoInductive evalnpz : state->trm->(val->hprop)->Prop :=
  | evalnpz_val : forall s v Q,
      Q v s ->
      evalnpz s v Q
  | evalnpz_step : forall s t Q,
      (exists s' t', step s t s' t') ->
      (forall s' t', step s t s' t' -> evalnpz s' t' Q) ->
      evalnpz s t Q.

(** We name [hoarenpz] the associated Hoare triple definition. *)

Definition hoarenpz (t:trm) (H:hprop) (Q:val->hprop) : Prop :=
  forall s, H s -> evalnpz s t Q.

(** Here again, we focus on the proofs of two particular reasoning rules,
    established with respect to [evalnpz]. *)

(** Firstly, let's prove the rule of consequence. The key intermediate result is
    to establish the covariance of [evalnpz]. Observe that this proof is to
    be conducted by coinduction. *)

Lemma evalnpz_conseq : forall s t Q Q',
  evalnpz s t Q' ->
  Q' ===> Q ->
  evalnpz s t Q.
Proof using.
  introv M WQ. gen s t Q'. cofix IH; intros. destruct M.
  { applys evalnpz_val. applys* WQ. }
  { applys evalnpz_step.
    { eauto. }
    { introv R'. lets M': H0 R'. applys IH M' WQ. } }
Qed.

Lemma hoarenpz_conseq : forall t H' Q' H Q,
  hoarenpz t H' Q' ->
  H ==> H' ->
  Q' ===> Q ->
  hoarenpz t H Q.
Proof using.
  introv M WH WQ. intros h K. applys evalnpz_conseq WQ.
  applys M. applys WH K.
Qed.

(** Secondly, we let's prove the reasoning rule for let-bindings. Here again,
    the key intermediate result is to establish a rule for [evalnpz]. *)

(** **** Exercise: 5 stars, standard, especially useful (hoarenpz_let)

    Prove the reasoning rule for let-bindings stated for [evalnpz].
    Hint: to set up the coinductive proof, follow the template that appears
    at the beginning of the proof of [evalnpz_conseq]. *)

Lemma evalnpz_let : forall s x t1 t2 Q1 Q,
  evalnpz s t1 Q1 ->
  (forall s1 v1, Q1 v1 s1 -> evalnpz s1 (subst x v1 t2) Q) ->
  evalnpz s (trm_let x t1 t2) Q.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

Lemma hoarenpz_let : forall x t1 t2 H Q Q1,
  hoarenpz t1 H Q1 ->
  (forall v1, hoarenpz (subst x v1 t2) (Q1 v1) Q) ->
  hoarenpz (trm_let x t1 t2) H Q.
Proof using.
  introv M1 M2. intros h K. applys* evalnpz_let.
  { introv K'. applys* M2. }
Qed.

(** To express diverge, the judgment [evalnp s t Q] may be specialized with
    the postcondition [Q := Empty]. Starting from the definition of
    [evalnpz], replacing [Q v s] with [False] is equivalent to removing
    the constructor [evalnpz_val] altogether. Thus, divergence of a
    configuration [(s,t)] may be characterized directly by the coinductive
    judgment [divnz s t] defined below, featuring a single constructor. *)

CoInductive divnz : state -> trm -> Prop :=
  | divnz_step : forall s1 t1,
      (exists s2 t2, step s1 t1 s2 t2) ->
      (forall s2 t2, step s1 t1 s2 t2 -> divnz s2 t2) ->
      divnz s1 t1.

(** **** Exercise: 4 stars, standard, optional (divnz_iff_evalnpz_Empty)

    Prove the equivalence between [divnz] and the specialization of the
    judgment [evalnp] to [Empty]. *)

Lemma divnz_iff_evalnpz_Empty : forall s t,
  divnz s t <-> evalnpz s t Empty.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Equivalence Between the Two Small-Step Characterizations of Partial Correctness *)

(** This section establishes that [hoarenpz] is equivalent to [hoarenps].
    The key result is to prove [evalnpz] equivalent to [evalnps]. *)

Lemma evalnpz_eq_evalnps :
  evalnpz = evalnps.
Proof using.
  extens. intros s t Q. iff M.
  { introv R. gen M. induction R; intros.
    { inverts M as M1 M2.
      { left*. }
      { right. applys M1. } }
    { rename H into R1, R into R2. inverts M as M1 M2.
      { false. inverts R1. }
      { applys IHR. applys M2 R1. } } }
  { gen s t Q. cofix IH. intros.
    tests C: (exists v, t = trm_val v).
    { destruct C as (v&->). applys evalnpz_val. applys evalnps_val_inv M. }
    { lets (s2&t2&R2&RS): evalnps_not_val_inv M C. applys evalnpz_step.
      { exists* s2 t2. }
      { intros s' t' R'. applys IH. applys evalnps_inv_step M R'. } } }
Qed.

Lemma hoarenpz_eq_hoarenps :
  hoarenpz = hoarenps.
Proof using. unfold hoarenps, hoarenpz. rewrite* evalnpz_eq_evalnps. Qed.

(** As a corollary, we can establish the equivalence between the two small-step
    characterization of divergence. Indeed, both characterizations are obtained
    by specializing the postcondition of their underlying evaluation jugment to
    the empty postcondition, namely [Empty]. *)

Lemma divnz_eq_divns :
  divnz = divns.
Proof using.
  extens. intros s t.
  rewrite divns_iff_evalnps_Empty.
  rewrite divnz_iff_evalnpz_Empty.
  rewrite* evalnpz_eq_evalnps.
Qed.

(** ** Equivalence Between Small-Step and Big-Step Partial Correctness
       Semantics *)

(** We end this chapter with the proof of equivalence between [hoarenps] and
    [hoarenp], establishing a formal relationship between partial correctness
    triples defined with respect to a small-step semantics and those defined
    with respect to a big-step semantics.

    The first step of the proof is to formally relate [evalnpz] and [evalnp],
    which are both defined coinductively. Then, we can derive the equality
    between [hoarenpz] and [hoarenp], and conclude using the equality
    [hoarenpz_eq_hoarenps], which was established earlier on. *)

(** The first direction is from [evalnpz] to [evalnp]. To establish it, we
    need 3 inversion lemmas for let-bindings. *)

Lemma evalnpz_let_inv_ctx : forall x s1 t1 t2 Q Q1,
  evalnpz s1 (trm_let x t1 t2) Q ->
  (fun v s => evals s1 t1 s v) ===> Q1 ->
  evalnpz s1 t1 Q1.
Proof using.
  cofix IH. introv M WQ. inverts M as M0 M'.
  tests C: (exists v1, t1 = trm_val v1).
  { destruct C as (v1&->). applys evalnpz_val.
    applys WQ. applys evals_refl. }
  { applys evalnpz_step.
    { destruct M0 as (s'&t'&S). inverts S as. 2:{ false* C. }
      intros S. exists. applys S. }
    { intros s2 t1' S. applys IH.
      { applys M'. applys step_let_ctx S. }
      { intros v s R. applys WQ. applys evals_step S R. } } }
Qed.

Lemma evalnpz_let_inv_cont : forall s1 s2 v1 x t1 t2 Q,
  evalnpz s1 (trm_let x t1 t2) Q ->
  evals s1 t1 s2 v1 ->
  evalnpz s2 (subst x v1 t2) Q.
Proof using.
  introv M R. gen_eq t1': (trm_val v1). induction R; intros; subst.
  { inverts M as _ M'. applys M'. applys step_let. }
  { rename H into S, R into R', t0 into t1'.
    inverts M as _ M'. applys* IHR. applys M'.
    applys step_let_ctx S. }
Qed.

Lemma evalnpz_let_inv : forall s1 x t1 t2 Q,
  evalnpz s1 (trm_let x t1 t2) Q ->
  exists Q1, evalnpz s1 t1 Q1
          /\ (forall v1 s2, Q1 v1 s2 -> evalnpz s2 (subst x v1 t2) Q).
Proof using.
  introv M. exists (fun v s => evals s1 t1 s (trm_val v)). split.
  { applys* evalnpz_let_inv_ctx M. }
  { introv K. applys* evalnpz_let_inv_cont M K. }
Qed.

(** Using these inversion lemmas, we can prove by induction the first
    direction, from [evalnpz] to [evalnp]. *)

Lemma evalnp_of_evalnpz : forall s t Q,
  evalnpz s t Q ->
  evalnp s t Q.
Proof using.
  cofix IH. introv M. destruct t; try solve [ inverts M; false_invert ].
  { inverts M as.
    { intros R. applys evalnp_val R. }
    { intros (s'&t'&S) _. inverts S. } }
  { inverts M as.
    { intros (s'&t'&S) _. inverts S. } }
  { inverts M as (s'&t'&S) M'. inverts S. } (* not included in semantics *)
  { rename v into f, v0 into x, t into t1.
    inverts M as (s'&t'&S) M1. inverts S.
    applys evalnp_fix.
    forwards M1': M1. { applys step_fix. }
    inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
  { inverts M as (s'&t'&S) M1. inverts S as.
    { applys evalnp_app_fix. { reflexivity. } applys IH.
      applys M1. applys* step_app_fix. }
    { applys evalnp_add.
      forwards M1': M1. { applys step_add. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv N. applys* evalnp_rand. { math. }
      intros n1' N1.
      forwards M1': M1. { applys* step_rand n1'. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv D. applys* evalnp_ref. intros p' D'.
      forwards M1': M1. { applys* step_ref p'. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv D. applys* evalnp_get.
      forwards M1': M1. { applys* step_get. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv D. applys* evalnp_set.
      forwards M1': M1. { applys* step_set. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv D. applys* evalnp_free.
      forwards M1': M1. { applys* step_free. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } } }
  { inverts M as (s'&t'&S) M'. inverts S. } (* not included in semantics *)
  { lets (Q1&M1&M2): evalnpz_let_inv M. applys evalnp_let.
    { applys IH. applys M1. }
    { introv R. applys IH. applys M2 R. } }
  { inverts M as (s'&t'&S) M1. inverts S. applys evalnp_if.
    applys IH. applys M1. applys step_if. }
Qed.

(** For the reciprocal direction, we also need one key inversion lemma. It
    is stated below. Its hypothesis is [evalnp s t Q], and its conclusion
    corresponds to the disjunction of the constructors of the inductive
    definition of [evalnpz s t Q]. *)

Lemma evalnp_inv_step : forall s t Q,
  evalnp s t Q ->
     (exists v, t = trm_val v /\ Q v s)
  \/ ((exists s' t', step s t s' t' /\ evalnp s' t' Q)
      /\ (forall s' t', step s t s' t' -> evalnp s' t' Q)).
Proof using.
  introv M. gen s Q. induction t; intros; inverts M as.
  { introv R. left. eauto. }
  { introv R. right. split.
    { exists. split. { applys step_fix. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S. applys* evalnp_val. } }
  { introv M1. right. split.
    { exists. split. { applys* step_app_fix. } { auto. } }
    { intros s' t' S. inverts S as E. inverts E. auto. } }
  { introv R. right. split.
    { exists. split. { applys step_add. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S. applys* evalnp_val. } }
  { introv N R. right. split.
    { exists. split. { applys* step_rand 0. math. }
       { applys* evalnp_val. applys R. math. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv R. right. split.
    { forwards~ (p&D&N): (exists_fresh null s).
      exists. split. { applys* step_ref. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv D R. right. split.
    { exists. split. { applys* step_get. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv D R. right. split.
    { exists. split. { applys* step_set. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv D R. right. split.
    { exists. split. { applys* step_free. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv M1 M2. rename v into x. right. split.
    { forwards [(v1&->&HQ1)|((s'&t'&S'&M')&_)]: IHt1 M1.
      { exists. split. { applys step_let. } { applys* M2. } }
      { exists. split.
        { applys step_let_ctx S'. }
        { applys evalnp_let M'. applys M2. } } }
    { intros s' t' S. inverts S as S.
      { forwards [(v1&->&HQ1)|(_&M3)]: IHt1 M1.
        { inverts S. }
        { specializes M3 S. applys evalnp_let M3 M2. } }
      { inverts M1 as R. applys* M2. } } }
  { introv M1. right. split.
    { exists. split. { applys step_if. } { auto. } }
    { intros s' t' S. inverts S. auto. } }
Qed.

(** Using this inversion lemma, it is straightforward to derive the
    implication from [evalnp] to [evalnpz]. *)

Lemma evalnpz_of_coeval : forall s t Q,
  evalnp s t Q ->
  evalnpz s t Q.
Proof.
  cofix IH. introv M. lets C: evalnp_inv_step M.
  destruct C as [(v&->&HQ)|((s'&t'&S&M1)&M2)].
  { applys evalnpz_val HQ. }
  { applys evalnpz_step.
    { exists. applys S. }
    { intros s1 t1 S'. applys IH. applys M2 S'. } }
Qed.

(** Combining the two directions yields the equality between [evalnpz] and
    [evalnp], and that between [evalnps] and [evalnp]. *)

Lemma evalnpz_eq_evalnp :
   evalnpz = evalnp.
Proof using.
  extens. intros s t Q. iff M.
  { applys* evalnp_of_evalnpz. }
  { applys* evalnpz_of_coeval. }
Qed.

Lemma hoarenpcso_eq_hoarenp :
  hoarenpz = hoarenp.
Proof using. unfold hoarenp, hoarenpz. rewrite* evalnpz_eq_evalnp. Qed.

Lemma hoarenps_eq_hoarenp :
   hoarenps = hoarenp.
Proof using.
  rewrite <- hoarenpz_eq_hoarenps. rewrite* hoarenpcso_eq_hoarenp.
Qed.

(** As another corollary, we can establish the equivalence between the big-step
    and the small-step characterization of divergence. Indeed, both are
    obtained by specializing the postcondition to [Empty]. *)

Lemma divns_eq_divn :
  divns = divn.
Proof using.
  extens. intros s t. unfold divn.
  rewrite divns_iff_evalnps_Empty.
  rewrite <- evalnpz_eq_evalnp.
  rewrite* evalnpz_eq_evalnps.
Qed.

(* ================================================================= *)
(** ** Historical Notes *)

(** Many program verification tools target partial correctness only, or provide
    separate tooling for justifying termination.

    The soundness of program logics delivering partial correctness is nearly
    always justified with respect to a small-step semantics of the programming
    language. Partial correctness is generally chosen because it appears better
    suited for reasoning about programs that involve some amount of
    concurrency, and for programs that are not meant to terminate (e.g., system
    kernels).

    Capturing partial correctness using a coinductive big-step judgment, as done
    in this chapter with the predicate [evalnp], appears to be novel as of Jan.
    2021. *)

(* 2021-01-25 13:22 *)


Require Import List. Import ListNotations.
Require Import Rules.
Require Import Instructions.
Require Import Machine.

Set Implicit Arguments.

Fixpoint break_expr n (e : rule_expr n) : list (rule_expr n) :=
  match e with
  | L_Bot => []
  | L_Var m => [L_Var m]
  | L_Join e1 e2 => break_expr e1 ++ break_expr e2
  end.

Fixpoint join_exprs n (es : list (rule_expr n)) : rule_expr n :=
  match es with
  | nil => L_Bot
  | e :: nil => e
  | e :: es' => L_Join e (join_exprs es')
  end.

Fixpoint break_scond n (c : rule_scond n) : list (rule_scond n) :=
  match c with
  | A_True => []
  | A_LE e1 e2 => List.map (fun e1' => A_LE e1' e2) (break_expr e1)
  | A_And c1 c2 => break_scond c1 ++ break_scond c2
  | A_Or c1 c2 => [c]
  end.

Fixpoint and_sconds n (cs : list (rule_scond n)) : rule_scond n :=
  match cs with
  | nil => A_True
  | c :: nil => c
  | c :: cs' => A_And c (and_sconds cs')
  end.

Fixpoint drop_each X (xs : list X) : list (list X) :=
  match xs with
  | nil => []
  | x :: xs' => xs' :: (map (fun xs'' => x :: xs'') (drop_each xs'))
  end.

Example ex_drop_each :
  drop_each [1;2;3;4] = [[2;3;4];[1;3;4];[1;2;4];[1;2;3]].
Proof. reflexivity. Qed.

Definition mutate_expr n (e : rule_expr n) : list (rule_expr n) :=
  let es := (break_expr e) in
  match es with
  | nil => []
  | _ => List.map (@join_exprs n) (drop_each es)
  end.

Definition eL1 : rule_expr 3 := Lab1.
Definition eL2 : rule_expr 3 := Lab2.
Definition eL3 : rule_expr 3 := Lab3.
Definition ePC : rule_expr 3 := LabPC.

Example ex_break_expr :
  break_expr (L_Join (L_Join eL1 eL2) eL3) = [eL1; eL2; eL3].
Proof. reflexivity. Qed.

Example ex_drop_each' :
  drop_each [eL1; eL2; eL3] = [[eL2;eL3]; [eL1;eL3]; [eL1;eL2]].
Proof. reflexivity. Qed.

Example ex_join_exprs :
  join_exprs [eL1; eL2; eL3] = L_Join eL1 (L_Join eL2 eL3).
Proof. reflexivity. Qed.

Example ex_mutate_expr :
  mutate_expr (L_Join (L_Join eL1 eL2) eL3) =
    [L_Join eL2 eL3; L_Join eL1 eL3; L_Join eL1 eL2].
Proof. reflexivity. Qed.

Example ex_mutate_expr_var : mutate_expr eL1 = [@L_Bot 3].
Proof. reflexivity. Qed.

Example ex_mutate_expr_bot : mutate_expr (@L_Bot 3) = [].
Proof. compute. reflexivity. Qed.

(* For the pc we move disjuncts to the result label;
   to prevent useless mutants we never move the pc label,
   but we do try to remove it if there is no result label *)
Fixpoint drop_each_but_not_lpc n (es : list (rule_expr n)) :
    list (rule_expr n * list (rule_expr n)) :=
  let f x xs'' := (fst xs'', x :: snd xs'') in
  match es with
  | nil => []
  | (L_Var labpc) :: xs' =>
      map (f (L_Var (@labpc n))) (drop_each_but_not_lpc xs')
  | x :: xs' =>
      (x, xs') :: (map (f x) (drop_each_but_not_lpc xs'))
  end.

Example ex_drop_each_but_not_lpc_1 :
  drop_each_but_not_lpc [eL1; ePC] = [(Lab1, [LabPC])].
Proof. reflexivity. Qed.

Example ex_drop_each_but_not_lpc_1' :
  drop_each_but_not_lpc [ePC; eL1] = [(Lab1, [LabPC])].
Proof. reflexivity. Qed.

Example ex_drop_each_but_not_lpc_2 :
  drop_each_but_not_lpc [eL1; eL2; ePC] =
    [(Lab1, [Lab2; LabPC]); (Lab2, [Lab1; LabPC])].
Proof. reflexivity. Qed.

Example ex_drop_each_but_not_lpc_2' :
  drop_each_but_not_lpc [eL1; ePC; eL2] =
    [(Lab1, [LabPC; Lab2]); (Lab2, [Lab1; LabPC])].
Proof. reflexivity. Qed.

Example ex_drop_each_but_not_lpc_2'' :
  drop_each_but_not_lpc [ePC; eL1; eL2] =
    [(Lab1, [LabPC; Lab2]); (Lab2, [LabPC; Lab1])].
Proof. reflexivity. Qed.

Definition mutate_pc n (ores : option (rule_expr n)) (epc : rule_expr n)
    : list (option (rule_expr n) * (rule_expr n)) :=
  let es := (break_expr epc) in
  match es with
  | nil => []
  | _ =>
      match ores with
      | Some eres =>
          let f xxs := (Some (L_Join eres (fst xxs)), join_exprs (snd xxs)) in
          List.map f (drop_each_but_not_lpc es)
      | None =>
          (* we just drop each pc disjunct as before *)
          let f xs := (None, join_exprs xs) in
          List.map f (drop_each es)
      end
  end.

Example ex_mutate_pc_1 :
  mutate_pc (Some eL2) (L_Join eL1 ePC) = [(Some (JOIN Lab2 Lab1), LabPC)].
Proof. reflexivity. Qed.

Example ex_mutate_pc_1' :
  mutate_pc (Some eL2) (L_Join ePC eL1) = [(Some (JOIN Lab2 Lab1), LabPC)].
Proof. reflexivity. Qed.

Example ex_mutate_pc_2 :
  mutate_pc (Some eL3) (L_Join (L_Join ePC eL1) eL2) =
    [(Some (JOIN Lab3 Lab1), JOIN LabPC Lab2);
     (Some (JOIN Lab3 Lab2), JOIN LabPC Lab1)].
Proof. reflexivity. Qed.

Definition mutate_scond n (c : rule_scond n) : list (rule_scond n) :=
  let cs := (break_scond c) in
  match cs with
  | nil => []
  | _ => List.map (@and_sconds n) (drop_each cs)
  end.

Definition c123 := A_LE (L_Join eL1 eL2) eL3.
Definition c321 := A_LE eL3 (L_Join eL1 eL2).
Definition c13 := A_LE eL1 eL3.
Definition c23 := A_LE eL2 eL3.

Example ex_break_scond :
  break_scond (A_And c123 c321) = [c13; c23; c321].
Proof. reflexivity. Qed.

Example ex_and_sconds :
  and_sconds [c13; c23; c321] = A_And c13 (A_And c23 c321).
Proof. reflexivity. Qed.

Example ex_mutate_scond :
  mutate_scond (A_And c123 c321) = [A_And c23 c321;
                                    A_And c13 c321;
                                    A_And c13 c23].
Proof. reflexivity. Qed.

Example ex_mutate_scond_true : mutate_scond (@A_True 3) = [].
Proof. reflexivity. Qed.

Definition mutate_rule n (r : AllowModify n) : list (AllowModify n) :=
  let a := allow r in
  let res := labRes r in
  let pc := labResPC r in
  (List.map (fun a' => almod a' res pc) (mutate_scond a)) ++
  (match res with
   | Some lres =>
      List.map (fun lres' => almod a (Some lres') pc) (mutate_expr lres)
   | None => []
   end) ++
  (List.map (fun respc => almod a (fst respc) (snd respc)) (mutate_pc res pc)).

(* Printing
Eval cbv in (mutate_rule
  (≪ AND (LE Lab2 LabPC) (LE (JOIN LabPC (JOIN Lab1 Lab2)) Lab3),
     JOIN Lab1 Lab2, LabPC ≫)).
*)

(* This displays bad
Definition mutate_table (t : table) : list table :=
  fold_left (@List.app table)
    (List.map (fun (o : OpCode) =>
      (List.map (fun (mr : AllowModify (labelCount o)) (o' : OpCode) =>
        match opCode_eq_dec o o' with
        | left H => eq_rec_r _ (fun x => x) H mr
        | right _ => t o'
        end
      ) (mutate_rule (t o)))
    ) opCodes) [].
*)

(* Breaking this out gives more control on the evaluation *)
Definition helper o (mr : AllowModify (labelCount o)) o'
  (orig : AllowModify (labelCount o')) : AllowModify (labelCount o') :=
  match opCode_eq_dec o o' with
  | left H => eq_rec_r _ (fun x => x) H mr
  | right _ => orig
  end.

(* The dummy argument t' will be the same as t,
    just that I wanted more control on evaluation *)
Definition mutate_table' (t t' : table) : list table :=
  fold_left (@List.app table)
    (List.map (fun (o : OpCode) =>
      (List.map (fun (mr : AllowModify (labelCount o)) (o' : OpCode)
        => helper o mr o' (t' o')
      ) (mutate_rule (t o)))
    ) opCodes) [].
Definition mutate_table t := mutate_table' t t.

(* Printing
Definition copy_table := default_table.
Eval lazy -[labelCount helper copy_table] in
  (mutate_table' default_table copy_table).

Eval simpl in nth 21 (mutate_table default_table).
(* can achieve the same with partial application *)
Eval lazy -[labelCount helper] in
  (mutate_table' default_table).

Eval lazy in (List.length (mutate_table default_table)).
*)


From stdpp Require Import tactics.
From stdpp Require Import options.
Local Set Universe Polymorphism.

(* Not using [list Type] in order to avoid universe inconsistencies *)
Inductive tlist := tnil : tlist | tcons : Type → tlist → tlist.

Inductive hlist : tlist → Type :=
  | hnil : hlist tnil
  | hcons {A As} : A → hlist As → hlist (tcons A As).

Fixpoint tapp (As Bs : tlist) : tlist :=
  match As with tnil => Bs | tcons A As => tcons A (tapp As Bs) end.
Fixpoint happ {As Bs} (xs : hlist As) (ys : hlist Bs) : hlist (tapp As Bs) :=
  match xs with hnil => ys | hcons x xs => hcons x (happ xs ys) end.

Definition hhead {A As} (xs : hlist (tcons A As)) : A :=
  match xs with hnil => () | hcons x _ => x end.
Definition htail {A As} (xs : hlist (tcons A As)) : hlist As :=
  match xs with hnil => () | hcons _ xs => xs end.

Fixpoint hheads {As Bs} : hlist (tapp As Bs) → hlist As :=
  match As with
  | tnil => λ _, hnil
  | tcons _ _ => λ xs, hcons (hhead xs) (hheads (htail xs))
  end.
Fixpoint htails {As Bs} : hlist (tapp As Bs) → hlist Bs :=
  match As with
  | tnil => id
  | tcons _ _ => λ xs, htails (htail xs)
  end.

Fixpoint himpl (As : tlist) (B : Type) : Type :=
  match As with tnil => B | tcons A As => A → himpl As B end.

Definition hinit {B} (y : B) : himpl tnil B := y.
Definition hlam {A As B} (f : A → himpl As B) : himpl (tcons A As) B := f.
Arguments hlam _ _ _ _ _ / : assert.

Definition hcurry {As B} (f : himpl As B) (xs : hlist As) : B :=
  (fix go {As} xs :=
    match xs in hlist As return himpl As B → B with
    | hnil => λ f, f
    | hcons x xs => λ f, go xs (f x)
    end) _ xs f.
Coercion hcurry : himpl >-> Funclass.

Fixpoint huncurry {As B} : (hlist As → B) → himpl As B :=
  match As with
  | tnil => λ f, f hnil
  | tcons x xs => λ f, hlam (λ x, huncurry (f ∘ hcons x))
  end.

Lemma hcurry_uncurry {As B} (f : hlist As → B) xs : huncurry f xs = f xs.
Proof. by induction xs as [|A As x xs IH]; simpl; rewrite ?IH. Qed.

Fixpoint hcompose {As B C} (f : B → C) {struct As} : himpl As B → himpl As C :=
  match As with
  | tnil => f
  | tcons A As => λ g, hlam (λ x, hcompose f (g x))
  end.


From Coq Require Import Program Program.Tactics Arith List.
From mathcomp Require Import ssreflect ssrnat.
From ssrlib Require Import Lists.

(** * Formalization of heterogeneous lists.

  This formalization is based on the following paper.
  - Paolo Herms, Claude Marché, Benjamin Monate:
    A Certified Multi-prover Verification Condition Generator.
    VSTTE 2012: 2-17
 *)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Declare Scope hlist_scope.
Delimit Scope hlist_scope with hlist.

Reserved Notation "x '=i' y" (at level 70, no associativity).
Reserved Notation "x '<>i' y" (at level 70, no associativity).
Reserved Notation "x '=v' y" (at level 70, no associativity).
Reserved Notation "x '<>v' y" (at level 70, no associativity).

Section HList.

  Variable S : Type.

  Variable T : S -> Type.

  (* A lidx is an index of a hlist. *)
  Inductive lidx A : list S -> Type :=
  | HI0 E : lidx A (A :: E)
  | HIS B E : lidx A E -> lidx A (B :: E).

  (* Heterogeneous lists. *)
  Inductive hlist : list S -> Type :=
  | Hnil : hlist nil
  | Hcons A E : T A -> hlist E -> hlist (A :: E).

  Definition hnil : hlist nil := Hnil.

  (* Equalities *)

  Local Open Scope hlist_scope.

  Definition xdil E A := lidx A E.

  (** Equality of lidx. *)

  Definition lidx_eq A B E (i : lidx A E) (j : lidx B E) :=
    EqdepFacts.eq_dep S (xdil E) A i B j.

  Notation "x '=i' y" := (lidx_eq x y) (at level 70, no associativity) : hlist_scope.
  Notation "x '<>i' y" := (~ (lidx_eq x y)) (at level 70, no associativity) : hlist_scope.

  (* Given that i : lidx A E, j : lidx B E, and H : lidx_eq i j, produce
   i = j and change B to A. *)
  Ltac lidx_eq_eq H :=
    match goal with
    | i : lidx ?A ?E, j : lidx ?B ?E, H : lidx_eq ?i ?j |- _ =>
      let Hab := fresh in
      let Hab' := fresh in
      let Heq := fresh in
      inversion H as [Hab [Hab' Heq]];
        clear Hab';
        move: i j Heq H;
        rewrite -Hab => {Hab};
        move=> i j Heq H;
        move: (EqdepFacts.eq_sigT_snd Heq);
        rewrite -{1}eq_rect_eq => {Heq}
    | H : lidx_eq ?i ?j |- _ =>
      let Hab := fresh in
      let Heq := fresh in
      inversion H as [Hab Heq];
        clear Hab;
        move: (EqdepFacts.eq_sigT_snd Heq);
        rewrite -{1}eq_rect_eq => {Heq}
    end.

  Lemma lidx_eq_ty_eq A B E (i : lidx A E) (j : lidx B E) :
    i =i j -> A = B.
  Proof.
    move=> H.
    inversion H as [H1 [H2 H3]].
    reflexivity.
  Qed.

  Lemma lidx_eq_eq A E (i j : lidx A E) :
    i =i j -> i = j.
  Proof.
    move=> H.
    lidx_eq_eq H => Heq.
    exact: Heq.
  Qed.

  Lemma eq_lidx_eq A E (i j : lidx A E) :
    i = j -> i =i j.
  Proof.
    move=> Heq; rewrite Heq.
    exact: EqdepFacts.eq_dep_intro.
  Qed.

  Lemma lidx_neq_neq A E (x y : lidx A E) :
    x <>i y -> x <> y.
  Proof.
    move=> Hne Hxy; apply: Hne.
    apply: eq_lidx_eq.
    exact: Hxy.
  Qed.

  Lemma neq_lidx_neq A E (x y : lidx A E) :
    x <> y -> x <>i y.
  Proof.
    move=> Hne Hxy; apply: Hne.
    apply: lidx_eq_eq.
    exact: Hxy.
  Qed.

  Lemma ty_neq_lidx_neq A B E (x : lidx A E) (y : lidx B E) :
    A <> B -> x <>i y.
  Proof.
    move=> Hne Hxy; apply: Hne.
    inversion Hxy.
    reflexivity.
  Qed.

  Lemma lidx_eq_his_eq A B E (x : lidx A E) (y : lidx B E) ty :
    x =i y -> HIS ty x =i HIS ty y.
  Proof.
    move=> Hxy; rewrite Hxy.
    reflexivity.
  Qed.

  Lemma his_eq_lidx_eq A B E (x : lidx A E) (y : lidx B E) ty :
    HIS ty x =i HIS ty y -> x =i y.
  Proof.
    move=> Hxy.
    dependent destruction Hxy.
    reflexivity.
  Qed.

  (** Equality of values. *)

  Definition value_eq A B (x : T A) (y : T B) :=
    EqdepFacts.eq_dep S T A x B y.

  Notation "x '=v' y" := (value_eq x y) (at level 70, no associativity) : hlist_scope.
  Notation "x '<>v' y" := (~ (value_eq x y)) (at level 70, no associativity) : hlist_scope.

  Ltac value_eq_eq H :=
    match goal with
    | i : T ?A, j : T ?B, H : value_eq ?i ?j |- _ =>
      let Hab := fresh in
      let Hab' := fresh in
      let Heq := fresh in
      inversion H as [Hab [Hab' Heq]];
        clear Hab';
        move: i j Heq H;
        rewrite -Hab => {Hab};
        move=> i j Heq H;
        move: (EqdepFacts.eq_sigT_snd Heq);
        rewrite -{1}eq_rect_eq => {Heq}
    | H : value_eq ?i ?j |- _ =>
      let Hab := fresh in
      let Heq := fresh in
      inversion H as [Hab Heq];
        clear Hab;
        move: (EqdepFacts.eq_sigT_snd Heq);
        rewrite -{1}eq_rect_eq => {Heq}
    end.

  Lemma value_eq_ty_eq A B (x : T A) (y : T B) :
    x =v y -> A = B.
  Proof.
    move=> H.
    inversion H as [H1 [H2 H3]].
    reflexivity.
  Qed.

  Lemma value_eq_eq A (x : T A) (y : T A) :
    x =v y -> x = y.
  Proof.
    move=> H.
    value_eq_eq H => Heq.
    exact: Heq.
  Qed.

  Lemma eq_value_eq A (x y : T A) :
    x = y -> x =v y.
  Proof.
    move=> Heq; rewrite Heq.
    exact: EqdepFacts.eq_dep_intro.
  Qed.

  Lemma value_neq_neq A (x y : T A) :
    x <>v y -> x <> y.
  Proof.
    move=> Hne Hxy; apply: Hne.
    apply: eq_value_eq.
    exact: Hxy.
  Qed.

  Lemma neq_value_neq A (x y : T A) :
    x <> y -> x <>v y.
  Proof.
    move=> Hne Hxy; apply: Hne.
    apply: value_eq_eq.
    exact: Hxy.
  Qed.

  Lemma ty_neq_value_neq A B (x : T A) (y : T B) :
    A <> B -> x <>v y.
  Proof.
    move=> Hne Hxy; apply: Hne.
    inversion Hxy.
    reflexivity.
  Qed.

  (** Access and update a heterogeneous list. *)

  (* Access an index of a heterogeneous list. *)
  Program Fixpoint acclidx A E (i : lidx A E) (l : hlist E) : T A :=
    match l with
    | Hnil => !
    | Hcons _ _ h q =>
      match i with
      | HI0 _ => h
      | HIS _ _ i1 => acclidx i1 q
      end
    end.
  Next Obligation.
      by inversion i.
  Qed.

  (* Update an index of a heterogeneous list. *)
  Program Fixpoint updlidx A E (i : lidx A E) (v : T A) (l : hlist E) : hlist E :=
    match l with
    | Hnil => !
    | Hcons _ _ h q =>
      match i with
      | HI0 _ => Hcons v q
      | HIS _ _ i1 => Hcons h (updlidx i1 v q)
      end
    end.
  Next Obligation.
      by inversion i.
  Qed.

  Lemma acclidx_updlidx_heq A B E :
    forall (i : lidx A E) (j : lidx B E) (v : T B) (l : hlist E),
      i =i j ->
      acclidx i (updlidx j v l) =v v.
  Proof.
    move=> i j v l Heq.
    rewrite Heq => {A i Heq}.
    elim: l B j v => {E}.
    - move=> A i v.
      by inversion i.
    - move=> A E va l Hind B i vb.
      move: va vb.
      dependent destruction i => /=.
      + move=> _ vb.
        exact: EqdepFacts.eq_dep_intro.
      + move=> _ vb.
        exact: (Hind B i vb).
  Qed.

  Lemma acclidx_updlidx_eq A E :
    forall (i : lidx A E) (j : lidx A E) (v : T A) (l : hlist E),
      i = j ->
      acclidx i (updlidx j v l) = v.
  Proof.
    move=> i j v l Heq.
    move: (eq_lidx_eq Heq) => {Heq} Heq.
    move: (acclidx_updlidx_heq v l Heq) => Hveq.
    value_eq_eq Hveq => {Hveq} Hveq.
    exact: Hveq.
  Qed.

  Lemma acclidx_updlidx_hneq A B E :
    forall (i : lidx A E) (j : lidx B E) (v : T B) (l : hlist E),
      i <>i j ->
      acclidx i (updlidx j v l) = acclidx i l.
  Proof.
    move=> i j v l Hne.
    elim: l A B i j Hne v => {E}.
    - move=> A B i j Hne v.
      by inversion i.
    - move=> A E va l Hind A' B i j Hne vb.
      dependent destruction j => /=.
      + dependent destruction i => /=.
        * apply: False_ind.
          apply: Hne.
          reflexivity.
        * reflexivity.
      + dependent destruction i => /=.
        * reflexivity.
        * apply: Hind => Heq.
          apply: Hne.
          rewrite Heq.
          reflexivity.
  Qed.

  Lemma acclidx_updlidx_neq A E :
    forall (i : lidx A E) (j : lidx A E) (v : T A) (l : hlist E),
      i <> j ->
      acclidx i (updlidx j v l) = acclidx i l.
  Proof.
    move=> i j v l Hne.
    move: (neq_lidx_neq Hne) => {Hne} Hne.
    apply: acclidx_updlidx_hneq.
    exact: Hne.
  Qed.

  Lemma acclidx_updlidx_ty_neq A B E :
    forall (i : lidx A E) (j : lidx B E) (v : T B) (l : hlist E),
      A <> B ->
      acclidx i (updlidx j v l) = acclidx i l.
  Proof.
    move=> i j v l Hne.
    apply: acclidx_updlidx_hneq.
    apply: ty_neq_lidx_neq.
    exact: Hne.
  Qed.

  (** Other operations *)

  Fixpoint length E (l : hlist E) : nat :=
    match l with
    | Hnil => 0
    | Hcons _ _ hd tl => (length tl).+1
    end.

  Program Definition hd (E : nonempty_list S) (l : hlist E) : T (nonempty_hd E) :=
    match l with
    | Hnil => !
    | Hcons _ _ hd _ => hd
    end.
  Next Obligation.
    move: Heq_anonymous => {l Heq_l}.
    elim: E.
    discriminate.
  Qed.
  Next Obligation.
    move=> {l wildcard'1 Heq_l hd}.
    move: wildcard' wildcard'0 Heq_anonymous.
    elim: E => /=.
    move=> hd tl hd' tl' [] Hhd _.
    assumption.
  Qed.

  Definition tl E (l : hlist E) : hlist (List.tl E) :=
    match l with
    | Hnil => Hnil
    | Hcons _ _ _ tl => tl
    end.

End HList.

Notation "x '=i' y" := (lidx_eq x y) (at level 70, no associativity) : hlist_scope.
Notation "x '<>i' y" := (~ (lidx_eq x y)) (at level 70, no associativity) : hlist_scope.
Notation "x '=v' y" := (value_eq x y) (at level 70, no associativity) : hlist_scope.
Notation "x '<>v' y" := (~ (value_eq x y)) (at level 70, no associativity) : hlist_scope.


(* --------------------------------------------------------------------
 * (c) Copyright 2011--2012 Microsoft Corporation and Inria.
 * (c) Copyright 2012--2014 Inria.
 * (c) Copyright 2012--2014 IMDEA Software Institute.
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import ssreflect eqtype ssrbool ssrnat ssrfun seq.
From mathcomp Require Import choice ssralg bigop.
From CoqWord Require Export ssrZ.

Import GRing.Theory.

Local Open Scope ring_scope.

Set Implicit Arguments.
Unset Strict Implicit.

Local Notation simpm := Monoid.simpm.

Require Import NArith ZArith BinPos Ring_polynom Field_theory.

(* -------------------------------------------------------------------- *)
Reserved Notation "x %:S" (at level 2, left associativity, format "x %:S").

Notation "c %:S"   := (PEc c)     : ssring.
Notation "''X_' i" := (PEX _ i)   : ssring.
Notation "x + y"   := (PEadd x y) : ssring.
Notation "x - y"   := (PEsub x y) : ssring.
Notation "- x"     := (PEopp x  ) : ssring.
Notation "x * y"   := (PEmul x y) : ssring.
Notation "x ^+ n"  := (PEpow x n) : ssring.

Notation "0" := PEO : ssring.
Notation "1" := PEI : ssring.

Delimit Scope ssring with S.

(* -------------------------------------------------------------------- *)
Notation "c %:S"   := (FEc c)     : ssfield.
Notation "''X_' i" := (FEX _ i)   : ssfield.
Notation "x + y"   := (FEadd x y) : ssfield.
Notation "x - y"   := (FEsub x y) : ssfield.
Notation "- x"     := (FEopp x  ) : ssfield.
Notation "x * y"   := (FEmul x y) : ssfield.
Notation "x ^-1"   := (FEinv x)   : ssfield.
Notation "x / y"   := (FEdiv x y) : ssfield.
Notation "x ^+ n"  := (FEpow x n) : ssfield.

Notation "0" := FEO : ssfield.
Notation "1" := FEI : ssfield.

Delimit Scope ssfield with F.

(* -------------------------------------------------------------------- *)
Local Coercion Z_of_nat      : nat >-> Z.
Local Coercion N_of_nat      : nat >-> N.
Local Coercion P_of_succ_nat : nat >-> positive.
Local Coercion Z.pos         : positive >-> Z.

(* -------------------------------------------------------------------- *)
Class find (T : Type) (x : T) (xs : seq T) (i:nat).

Instance find0 (T : Type) (x : T) (xs : seq T)
 : find x (x :: xs) 0
 := { }.

Instance findS (T : Type) (x : T) (y : T) (ys :  seq T) i
 {_: find x ys i}
 : find x (y :: ys) i.+1 | 1
 := { }.

(* -------------------------------------------------------------------- *)
Class closed (T : Type) (xs : seq T).

Instance closed_nil T
 : closed (T:=T) nil
 := { }.

Instance closed_cons T (x : T) (xs : seq T)
 {_: closed xs}
 : closed (x :: xs)
 := { }.

(* -------------------------------------------------------------------- *)
Class reify (R : ringType) (a : R) (t : PExpr Z) (e : seq R).

Instance reify_zero (R : ringType) e : @reify R 0 0%S e := { }.
Instance reify_one  (R : ringType) e : @reify R 1 1%S e := { }.

Instance reify_natconst (R : ringType) n e
  : @reify R n%:R ((n : Z)%:S)%S e
  := { }.

Instance reify_add (R : ringType) a1 a2 t1 t2 e
  {_: @reify R a1 t1 e}
  {_: @reify R a2 t2 e}
  : reify (a1 + a2) (t1 + t2)%S e
  := { }.

Instance reify_opp (R : ringType) a t e
  {_: @reify R a t e}
  : reify (-a) (-t)%S e
  := { }.

Instance reify_natmul (R : ringType) a n t e
  {_: @reify R a t e}
  : reify (a *+ n) (t * (n : Z)%:S)%S e
  := { }.

Instance reify_mul (R : ringType) a1 a2 t1 t2 e
  {_: @reify R a1 t1 e}
  {_: @reify R a2 t2 e}
  : reify (a1 * a2) (t1 * t2)%S e
  := { }.

Instance reify_exp (R : ringType) a n t e
  {_: @reify R a t e}
  : reify (a ^+ n) (t ^+ n)%S e | 1
  := { }.

Instance reify_var (R : ringType) a i e
  `{find R a e i}
  : reify a ('X_i)%S e
  | 100
  := { }.

Definition reifyl (R : ringType) a t e
  {_: @reify R a t e}
  `{closed (T := R) e}
  := (t, e).

(* -------------------------------------------------------------------- *)
Ltac reify xt xe :=
  match goal with
  |- ?a = 0 =>
     match eval red in (reifyl (a := a)) with
     | (?t, ?e) => pose xt := t; pose xe := e
     end
  end.

(* -------------------------------------------------------------------- *)
Class freify (F : fieldType) (a : F) (t : FExpr Z) (e : seq F).

Instance freify_zero (F : fieldType) e : @freify F 0 0%F e := { }.
Instance freify_one  (F : fieldType) e : @freify F 1 1%F e := { }.

Instance freify_natconst (F : fieldType) n e
  : @freify F n%:R ((n : Z)%:S)%F e
  := { }.

Instance freify_add (F : fieldType) a1 a2 t1 t2 e
  {_: @freify F a1 t1 e}
  {_: @freify F a2 t2 e}
  : freify (a1 + a2) (t1 + t2)%F e
  := { }.

Instance freify_opp (F : fieldType) a t e
  {_: @freify F a t e}
  : freify (-a) (-t)%F e
  := { }.

Instance freify_natmul (F : fieldType) a n t e
  {_: @freify F a t e}
  : freify (a *+ n) (t * (n : Z)%:S)%F e
  := { }.

Instance freify_mul (F : fieldType) a1 a2 t1 t2 e
  {_: @freify F a1 t1 e}
  {_: @freify F a2 t2 e}
  : freify (a1 * a2) (t1 * t2)%F e
  := { }.

Instance freify_inv (F : fieldType) a t e
  {_: @freify F a t e}
  : freify (a^-1) (t^-1)%F e
  := { }.

Instance freify_exp (F : fieldType) a n t e
  {_: @freify F a t e}
  : freify (a ^+ n) (t ^+ n)%F e | 1
  := { }.

Instance freify_var (F : fieldType) a i e
  `{find F a e i}
  : freify a ('X_i)%F e
  | 100
  := { }.

Definition freifyl (F : fieldType) a t e
  {_: @freify F a t e}
  `{closed (T := F) e}
  := (t, e).

(* -------------------------------------------------------------------- *)
Ltac freify xt xe :=
  match goal with
  |- ?a = 0 =>
     match eval red in (freifyl (a := a)) with
     | (?t, ?e) => pose xt := t; pose xe := e
     end
  end.

(* -------------------------------------------------------------------- *)
Definition R_of_Z (R : ringType) (z : Z) : R :=
  match z with
  | Z0     => 0
  | Zpos n =>   (nat_of_P n)%:R
  | Zneg n => - (nat_of_P n)%:R
  end.

Arguments R_of_Z [R].

Lemma z0E: 0%Z = 0.
Proof. by []. Qed.

Lemma zaddE (z1 z2 : Z): (z1 + z2)%Z = z1 + z2.
Proof. by []. Qed.

Lemma zoppE (z : Z): (-z)%Z = -z.
Proof. by []. Qed.

Lemma zmulE (z1 z2 : Z): (z1 * z2)%Z = z1 * z2.
Proof. by []. Qed.

Definition zE := (z0E, zaddE, zoppE).

Lemma R_of_Z_is_additive (R : ringType): additive (R_of_Z (R := R)).
Proof.
  have oppm: {morph (R_of_Z (R := R)) : x / -x >-> -x}.
    by case=> [|n|n] //=; rewrite ?(oppr0, opprK).
  have addm z1 z2: R_of_Z (z1 + z2) = R_of_Z z1 + R_of_Z z2 :> R.
    wlog: z1 z2 / (z1 <=? z2)%Z; first move=> wlog.
    + case: (boolP (z1 <=? z2))%Z; first by move/wlog.
    + move/negbTE/Z.leb_gt/Z.lt_le_incl/Z.leb_le.
      by move/wlog; rewrite Z.add_comm addrC.
    case: z1 z2=> [|n1|n1] [|n2|n2] //= _; rewrite ?(addr0, add0r) //.
    + by rewrite Pos2Nat.inj_add natrD.
    + case: (Z.compare_spec n1 n2) => [[->]||].
      * by rewrite Z.pos_sub_diag addrC subrr.
      * move=> lt; rewrite (Z.pos_sub_gt _ _ lt) /=.
        rewrite (Pos2Nat.inj_sub _ _ lt) natrB 1?addrC //.
        apply/leP/Pos2Nat.inj_le/Pos.lt_le_incl/Pos.ltb_lt.
        by rewrite Pos2Z.inj_ltb; apply/Pos.ltb_lt.
      * move=> lt; rewrite (Z.pos_sub_lt _ _ lt) /=.
        rewrite (Pos2Nat.inj_sub _ _ lt) natrB ?opprB 1?addrC //.
        apply/leP/Pos2Nat.inj_le/Pos.lt_le_incl/Pos.ltb_lt.
        by rewrite Pos2Z.inj_ltb; apply/Pos.ltb_lt.
    + by rewrite Pos2Nat.inj_add natrD opprD.
  by move=> z1 z2 /=; rewrite addm oppm.
Qed.

Canonical R_of_Z_additive (R : ringType) := Additive (R_of_Z_is_additive R).

Lemma R_of_Z_is_multiplicative (R : ringType): multiplicative (R_of_Z (R := R)).
Proof.
  split=> //=; case=> [|z1|z1] [|z2|z2] //=;
    rewrite ?simpm // ?(mulNr, mulrN, opprK);
    by rewrite nat_of_P_mult_morphism natrM.
Qed.

Canonical R_of_Z_rmorphism (R : ringType) := AddRMorphism (R_of_Z_is_multiplicative R).

Local Notation REeval :=
  (@PEeval _ 0 +%R *%R (fun x y => x - y) -%R Z R_of_Z nat nat_of_N (@GRing.exp _)).

Lemma RE (R : ringType): @ring_eq_ext R +%R *%R -%R (@eq R).
Proof. by split; do! move=> ? _ <-. Qed.

Local Notation "~%R"   := (fun x y => x - y).
Local Notation "/%R"   := (fun x y => x / y).
Local Notation "^-1%R" := (@GRing.inv _) (only parsing).

Lemma RR (R : comRingType): @ring_theory R 0 1 +%R *%R ~%R -%R (@eq R).
Proof.
  split=> //=;
    [ exact: add0r | exact: addrC | exact: addrA  | exact: mul1r
    | exact: mulrC | exact: mulrA | exact: mulrDl | exact: subrr ].
Qed.

Lemma RZ (R : ringType):
  ring_morph (R := R) 0 1 +%R *%R ~%R -%R eq
    0%Z 1%Z Zplus Zmult Zminus Z.opp Zeq_bool (@R_of_Z _).
Proof.
  split=> //=.
  + by move=> x y; rewrite rmorphD.
  + by move=> x y; rewrite rmorphB.
  + by move=> x y; rewrite rmorphM.
  + by move=> x; rewrite raddfN.
  + by move=> x y /Zeq_bool_eq ->.
Qed.

Lemma PN (R : ringType):
  @power_theory R 1 *%R eq nat nat_of_N (@GRing.exp R).
Proof.
  split=> r [|n] //=; elim: n => //= p ih.
  + by rewrite Pos2Nat.inj_xI exprS -!ih -exprD addnn -mul2n.
  + by rewrite Pos2Nat.inj_xO -!ih -exprD addnn -mul2n.
Qed.

Lemma RF (F : fieldType): @field_theory F 0 1 +%R *%R ~%R -%R /%R ^-1%R (@eq F).
Proof.
  split=> //=; first by apply RR.
  + by apply/eqP; rewrite oner_eq0.
  + by move=> x /eqP nz_z; rewrite mulVf.
Qed.

Definition Rcorrect (R : comRingType) :=
  ring_correct (Eqsth R) (RE R)
    (Rth_ARth (Eqsth R) (RE R) (RR R))
    (RZ R) (PN R)
    (triv_div_th
       (Eqsth R) (RE R)
       (Rth_ARth (Eqsth R) (RE R) (RR R)) (RZ R)).

Definition Fcorrect (F : fieldType) :=
  Field_correct
    (Eqsth F) (RE F) (congr1 GRing.inv)
    (F2AF (Eqsth F) (RE F) (RF F)) (RZ F) (PN F)
    (triv_div_th
       (Eqsth F) (RE F)
       (Rth_ARth (Eqsth F) (RE F) (RR F)) (RZ F)).

(* -------------------------------------------------------------------- *)
Fixpoint Reval (R : ringType) (l : seq R) (pe : PExpr Z) :=
  match pe with
  | 0%S           => 0
  | 1%S           => 1
  | (c%:S)%S      => R_of_Z c
  | ('X_j)%S      => BinList.nth 0 j l
  | (pe1 + pe2)%S => (Reval l pe1) + (Reval l pe2)
  | (pe1 - pe2)%S => (Reval l pe1) - (Reval l pe2)
  | (- pe1)%S     => - (Reval l pe1)
  | (pe1 ^+ n)%S  => (Reval l pe1) ^+ (nat_of_N n)
  | (pe1 * pe2)%S =>
      match pe2 with
      | ((Zpos n)%:S)%S => (Reval l pe1) *+ (nat_of_P n)
      | _               => (Reval l pe1) * (Reval l pe2)
      end
  end.

Local Notation RevalC R :=
  (PEeval 0 1 +%R *%R ~%R -%R (R_of_Z (R := R)) nat_of_N (@GRing.exp R)).

Lemma PEReval (R : ringType): RevalC _ =2 @Reval R.
Proof.
  move=> l; elim => //=; try by do? move=> ?->.
  + move=> pe1 -> pe2 ->; case: pe2 => //=.
    by case=> [|c|c] //=; rewrite mulr_natr.
Qed.

(* -------------------------------------------------------------------- *)
Fixpoint Feval (F : fieldType) (l : seq F) (pe : FExpr Z) :=
  match pe with
  | 0%F           => 0
  | 1%F           => 1
  | (c%:S)%F      => R_of_Z c
  | ('X_j)%F      => BinList.nth 0 j l
  | (pe1 + pe2)%F => (Feval l pe1) + (Feval l pe2)
  | (pe1 - pe2)%F => (Feval l pe1) - (Feval l pe2)
  | (- pe1)%F     => - (Feval l pe1)
  | (pe1 ^+ n)%F  => (Feval l pe1) ^+ (nat_of_N n)
  | (pe^-1)%F     => (Feval l pe)^-1
  | (pe1 / pe2)%F => (Feval l pe1) / (Feval l pe2)
  | (pe1 * pe2)%F =>
      match pe2 with
      | ((Zpos n)%:S)%F => (Feval l pe1) *+ (nat_of_P n)
      | _               => (Feval l pe1) * (Feval l pe2)
      end
  end.

Local Notation FevalC R :=
  (FEeval 0 1 +%R *%R ~%R -%R /%R ^-1%R
          (R_of_Z (R := R)) nat_of_N (@GRing.exp R)).

Lemma PEFeval (F : fieldType): FevalC _ =2 @Feval F.
Proof.
  move=> l; elim => //=; try by do? move=> ?->.
  + move=> pe1 -> pe2 ->; case: pe2 => //=.
    by case=> [|c|c] //=; rewrite mulr_natr.
Qed.

(* -------------------------------------------------------------------- *)
Ltac ssring :=
  let xt := fresh "xt" in
  let xe := fresh "xe" in
    apply/eqP; rewrite -subr_eq0; apply/eqP;
    reify xt xe;
    apply (@Rcorrect _ 100 xe [::] xt (Coq.setoid_ring.Ring_polynom.PEc 0%Z) I);
    vm_compute;exact (erefl true).

(* -------------------------------------------------------------------- *)
Ltac ssfield :=
  let xt := fresh "xt" in
  let xe := fresh "xe" in
    apply/eqP; rewrite -subr_eq0; apply/eqP;
      (* rewrite ?(mulr0, mul0r, mulr1, mul1r); *) freify xt xe;
      move: (@Fcorrect _ 100 xe [::] xt (Field_theory.FEc 0) I [::] (erefl [::]));
      move/(_ _ (erefl _) _ (erefl _) (erefl true)); rewrite !PEFeval;
      apply=> /=; do? split; cbv delta[BinPos.Pos.to_nat] => /= {xt xe};
      try (exact I || apply/eqP).


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

(* File Eqdep.v created by Christine Paulin-Mohring in Coq V5.6, May 1992 *)
(* Further documentation and variants of eq_rect_eq by Hugo Herbelin,
   Apr 2003 *)
(* Abstraction with respect to the eq_rect_eq axiom and renaming to
   EqdepFacts.v by Hugo Herbelin, Mar 2006 *)

(** This file defines dependent equality and shows its equivalence with
    equality on dependent pairs (inhabiting sigma-types). It derives
    the consequence of axiomatizing the invariance by substitution of
    reflexive equality proofs and shows the equivalence between the 4
    following statements

    - Invariance by Substitution of Reflexive Equality Proofs.
    - Injectivity of Dependent Equality
    - Uniqueness of Identity Proofs
    - Uniqueness of Reflexive Identity Proofs
    - Streicher's Axiom K

  These statements are independent of the calculus of constructions [2].

  References:

  [1] T. Streicher, Semantical Investigations into Intensional Type Theory,
      Habilitationsschrift, LMU München, 1993.
  [2] M. Hofmann, T. Streicher, The groupoid interpretation of type theory,
      Proceedings of the meeting Twenty-five years of constructive
      type theory, Venice, Oxford University Press, 1998

Table of contents:

1. Definition of dependent equality and equivalence with equality of
   dependent pairs and with dependent pair of equalities

2. Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K

3. Definition of the functor that builds properties of dependent
   equalities assuming axiom eq_rect_eq

*)

(************************************************************************)
(** * Definition of dependent equality and equivalence with equality of dependent pairs *)

Import EqNotations.

(* Set Universe Polymorphism. *)

Section Dependent_Equality.

  Variable U : Type.
  Variable P : U -> Type.

  (** Dependent equality *)

  Inductive eq_dep (p:U) (x:P p) : forall q:U, P q -> Prop :=
    eq_dep_intro : eq_dep p x p x.
  Hint Constructors eq_dep: core.

  Lemma eq_dep_refl : forall (p:U) (x:P p), eq_dep p x p x.
  Proof eq_dep_intro.

  Lemma eq_dep_sym :
    forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep q y p x.
  Proof.
    destruct 1; auto.
  Qed.
  Hint Immediate eq_dep_sym: core.

  Lemma eq_dep_trans :
    forall (p q r:U) (x:P p) (y:P q) (z:P r),
      eq_dep p x q y -> eq_dep q y r z -> eq_dep p x r z.
  Proof.
    destruct 1; auto.
  Qed.

  Scheme eq_indd := Induction for eq Sort Prop.

  (** Equivalent definition of dependent equality as a dependent pair of
      equalities *)

  Inductive eq_dep1 (p:U) (x:P p) (q:U) (y:P q) : Prop :=
    eq_dep1_intro : forall h:q = p, x = rew h in y -> eq_dep1 p x q y.

  Lemma eq_dep1_dep :
    forall (p:U) (x:P p) (q:U) (y:P q), eq_dep1 p x q y -> eq_dep p x q y.
  Proof.
    destruct 1 as (eq_qp, H).
    destruct eq_qp using eq_indd.
    rewrite H.
    apply eq_dep_intro.
  Qed.

  Lemma eq_dep_dep1 :
    forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep1 p x q y.
  Proof.
    destruct 1.
    apply eq_dep1_intro with (eq_refl p).
    simpl; trivial.
  Qed.

End Dependent_Equality.

Arguments eq_dep  [U P] p x q _.
Arguments eq_dep1 [U P] p x q y.

(** Dependent equality is equivalent to equality on dependent pairs *)

Lemma eq_sigT_eq_dep :
  forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
    existT P p x = existT P q y -> eq_dep p x q y.
Proof.
  intros.
  dependent rewrite H.
  apply eq_dep_intro.
Qed.

Notation eq_sigS_eq_dep := eq_sigT_eq_dep (compat "8.6"). (* Compatibility *)

Lemma eq_dep_eq_sigT :
  forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
    eq_dep p x q y -> existT P p x = existT P q y.
Proof.
  destruct 1; reflexivity.
Qed.

Lemma eq_sigT_iff_eq_dep :
  forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
    existT P p x = existT P q y <-> eq_dep p x q y.
Proof.
  split; auto using eq_sigT_eq_dep, eq_dep_eq_sigT.
Qed.

Notation equiv_eqex_eqdep := eq_sigT_iff_eq_dep (only parsing). (* Compat *)

Lemma eq_sig_eq_dep :
  forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
    exist P p x = exist P q y -> eq_dep p x q y.
Proof.
  intros.
  dependent rewrite H.
  apply eq_dep_intro.
Qed.

Lemma eq_dep_eq_sig :
  forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
    eq_dep p x q y -> exist P p x = exist P q y.
Proof.
  destruct 1; reflexivity.
Qed.

Lemma eq_sig_iff_eq_dep :
  forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
    exist P p x = exist P q y <-> eq_dep p x q y.
Proof.
  split; auto using eq_sig_eq_dep, eq_dep_eq_sig.
Qed.

(** Dependent equality is equivalent to a dependent pair of equalities *)

Set Implicit Arguments.

Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <->
                                                   {H:x1=x2 | rew H in H1 = H2}.
Proof.
  intros; split; intro H.
  - change x2 with (projT1 (existT P x2 H2)).
    change H2 with (projT2 (existT P x2 H2)) at 5.
    destruct H. simpl.
    exists eq_refl.
    reflexivity.
  - destruct H as (->,<-).
    reflexivity.
Defined.

Lemma eq_sigT_fst :
  forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), x1 = x2.
Proof.
  intros.
  change x2 with (projT1 (existT P x2 H2)).
  destruct H.
  reflexivity.
Defined.

Lemma eq_sigT_snd :
  forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), rew (eq_sigT_fst H) in H1 = H2.
Proof.
  intros.
  unfold eq_sigT_fst.
  change x2 with (projT1 (existT P x2 H2)).
  change H2 with (projT2 (existT P x2 H2)) at 3.
  destruct H.
  reflexivity.
Defined.

Lemma eq_sig_fst :
  forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), x1 = x2.
Proof.
  intros.
  change x2 with (proj1_sig (exist P x2 H2)).
  destruct H.
  reflexivity.
Defined.

Lemma eq_sig_snd :
  forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), rew (eq_sig_fst H) in H1 = H2.
Proof.
  intros.
  unfold eq_sig_fst, eq_ind.
  change x2 with (proj1_sig (exist P x2 H2)).
  change H2 with (proj2_sig (exist P x2 H2)) at 3.
  destruct H.
  reflexivity.
Defined.

Unset Implicit Arguments.

(** Exported hints *)

Hint Resolve eq_dep_intro: core.
Hint Immediate eq_dep_sym: core.

(************************************************************************)
(** * Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K          *)

Section Equivalences.

  Variable U:Type.

  (** Invariance by Substitution of Reflexive Equality Proofs *)

  Definition Eq_rect_eq_on (p : U) (Q : U -> Type) (x : Q p) :=
    forall (h : p = p), x = eq_rect p Q x p h.
  Definition Eq_rect_eq := forall p Q x, Eq_rect_eq_on p Q x.

  (** Injectivity of Dependent Equality *)

  Definition Eq_dep_eq_on (P : U -> Type) (p : U) (x : P p) :=
    forall (y : P p), eq_dep p x p y -> x = y.
  Definition Eq_dep_eq := forall P p x, Eq_dep_eq_on P p x.

  (** Uniqueness of Identity Proofs (UIP) *)

  Definition UIP_on_ (x y : U) (p1 : x = y) :=
    forall (p2 : x = y), p1 = p2.
  Definition UIP_ := forall x y p1, UIP_on_ x y p1.

  (** Uniqueness of Reflexive Identity Proofs *)

  Definition UIP_refl_on_ (x : U) :=
    forall (p : x = x), p = eq_refl x.
  Definition UIP_refl_ := forall x, UIP_refl_on_ x.

  (** Streicher's axiom K *)

  Definition Streicher_K_on_ (x : U) (P : x = x -> Prop) :=
    P (eq_refl x) -> forall p : x = x, P p.
  Definition Streicher_K_ := forall x P, Streicher_K_on_ x P.

  (** Injectivity of Dependent Equality is a consequence of *)
  (** Invariance by Substitution of Reflexive Equality Proof *)

  Lemma eq_rect_eq_on__eq_dep1_eq_on (p : U) (P : U -> Type) (y : P p) :
    Eq_rect_eq_on p P y -> forall (x : P p), eq_dep1 p x p y -> x = y.
  Proof.
    intro eq_rect_eq.
    simple destruct 1; intro.
    rewrite <- eq_rect_eq; auto.
  Qed.
  Lemma eq_rect_eq__eq_dep1_eq :
    Eq_rect_eq -> forall (P:U->Type) (p:U) (x y:P p), eq_dep1 p x p y -> x = y.
  Proof (fun eq_rect_eq P p y x =>
           @eq_rect_eq_on__eq_dep1_eq_on p P x (eq_rect_eq p P x) y).

  Lemma eq_rect_eq_on__eq_dep_eq_on (p : U) (P : U -> Type) (x : P p) :
    Eq_rect_eq_on p P x -> Eq_dep_eq_on P p x.
  Proof.
    intros eq_rect_eq; red; intros.
    symmetry; apply (eq_rect_eq_on__eq_dep1_eq_on _ _ _ eq_rect_eq).
    apply eq_dep_sym in H; apply eq_dep_dep1; trivial.
  Qed.
  Lemma eq_rect_eq__eq_dep_eq : Eq_rect_eq -> Eq_dep_eq.
  Proof (fun eq_rect_eq P p x y =>
           @eq_rect_eq_on__eq_dep_eq_on p P x (eq_rect_eq p P x) y).

  (** Uniqueness of Identity Proofs (UIP) is a consequence of *)
  (** Injectivity of Dependent Equality *)

  Lemma eq_dep_eq_on__UIP_on (x y : U) (p1 : x = y) :
    Eq_dep_eq_on (fun y => x = y) x eq_refl -> UIP_on_ x y p1.
  Proof.
    intro eq_dep_eq; red.
    elim p1 using eq_indd.
    intros; apply eq_dep_eq.
    elim p2 using eq_indd.
    apply eq_dep_intro.
  Qed.
  Lemma eq_dep_eq__UIP : Eq_dep_eq -> UIP_.
  Proof (fun eq_dep_eq x y p1 =>
           @eq_dep_eq_on__UIP_on x y p1 (eq_dep_eq _ _ _)).

  (** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *)

  Lemma UIP_on__UIP_refl_on (x : U) :
    UIP_on_ x x eq_refl -> UIP_refl_on_ x.
  Proof.
    intro UIP; red; intros; symmetry; apply UIP.
  Qed.
  Lemma UIP__UIP_refl : UIP_ -> UIP_refl_.
  Proof (fun UIP x p =>
           @UIP_on__UIP_refl_on x (UIP x x eq_refl) p).

  (** Streicher's axiom K is a direct consequence of Uniqueness of
      Reflexive Identity Proofs *)

  Lemma UIP_refl_on__Streicher_K_on (x : U) (P : x = x -> Prop) :
    UIP_refl_on_ x -> Streicher_K_on_ x P.
  Proof.
    intro UIP_refl; red; intros; rewrite UIP_refl; assumption.
  Qed.
  Lemma UIP_refl__Streicher_K : UIP_refl_ -> Streicher_K_.
  Proof (fun UIP_refl x P =>
           @UIP_refl_on__Streicher_K_on x P (UIP_refl x)).

  (** We finally recover from K the Invariance by Substitution of
      Reflexive Equality Proofs *)

  Lemma Streicher_K_on__eq_rect_eq_on (p : U) (P : U -> Type) (x : P p) :
    Streicher_K_on_ p (fun h => x = rew -> [P] h in x)
    -> Eq_rect_eq_on p P x.
  Proof.
    intro Streicher_K; red; intros.
    apply Streicher_K.
    reflexivity.
  Qed.
  Lemma Streicher_K__eq_rect_eq : Streicher_K_ -> Eq_rect_eq.
  Proof (fun Streicher_K p P x =>
           @Streicher_K_on__eq_rect_eq_on p P x (Streicher_K p _)).

(** Remark: It is reasonable to think that [eq_rect_eq] is strictly
    stronger than [eq_rec_eq] (which is [eq_rect_eq] restricted on [Set]):

   [Definition Eq_rec_eq :=
      forall (P:U -> Set) (p:U) (x:P p) (h:p = p), x = eq_rec p P x p h.]

    Typically, [eq_rect_eq] allows proving UIP and Streicher's K what
    does not seem possible with [eq_rec_eq]. In particular, the proof of [UIP]
    requires to use [eq_rect_eq] on [fun y -> x=y] which is in [Type] but not
    in [Set].
*)

End Equivalences.

(** UIP_refl is downward closed (a short proof of the key lemma of Voevodsky's
    proof of inclusion of h-level n into h-level n+1; see hlevelntosn
    in https://github.com/vladimirias/Foundations.git). *)

Theorem UIP_shift_on (X : Type) (x : X) :
  UIP_refl_on_ X x -> forall y : x = x, UIP_refl_on_ (x = x) y.
Proof.
  intros UIP_refl y.
  rewrite (UIP_refl y).
  intros z.
  assert (UIP:forall y' y'' : x = x, y' = y'').
  { intros. apply eq_trans with (eq_refl x). apply UIP_refl.
    symmetry. apply UIP_refl. }
  transitivity (eq_trans (eq_trans (UIP (eq_refl x) (eq_refl x)) z)
                         (eq_sym (UIP (eq_refl x) (eq_refl x)))).
  - destruct z. destruct (UIP _ _). reflexivity.
  - change
      (match eq_refl x as y' in _ = x' return y' = y' -> Prop with
       | eq_refl => fun z => z = (eq_refl (eq_refl x))
       end (eq_trans (eq_trans (UIP (eq_refl x) (eq_refl x)) z)
                     (eq_sym (UIP (eq_refl x) (eq_refl x))))).
    destruct z. destruct (UIP _ _). reflexivity.
Qed.
Theorem UIP_shift : forall U, UIP_refl_ U -> forall x:U, UIP_refl_ (x = x).
Proof (fun U UIP_refl x =>
         @UIP_shift_on U x (UIP_refl x)).

Section Corollaries.

  Variable U:Type.

  (** UIP implies the injectivity of equality on dependent pairs in Type *)

 Definition Inj_dep_pair_on (P : U -> Type) (p : U) (x : P p) :=
   forall (y : P p), existT P p x = existT P p y -> x = y.
 Definition Inj_dep_pair := forall P p x, Inj_dep_pair_on P p x.

 Lemma eq_dep_eq_on__inj_pair2_on (P : U -> Type) (p : U) (x : P p) :
   Eq_dep_eq_on U P p x -> Inj_dep_pair_on P p x.
 Proof.
   intro eq_dep_eq; red; intros.
   apply eq_dep_eq.
   apply eq_sigT_eq_dep.
   assumption.
 Qed.
 Lemma eq_dep_eq__inj_pair2 : Eq_dep_eq U -> Inj_dep_pair.
 Proof (fun eq_dep_eq P p x =>
          @eq_dep_eq_on__inj_pair2_on P p x (eq_dep_eq P p x)).

End Corollaries.

Notation Inj_dep_pairS := Inj_dep_pair.
Notation Inj_dep_pairT := Inj_dep_pair.
Notation eq_dep_eq__inj_pairT2 := eq_dep_eq__inj_pair2.

(************************************************************************)
(** * Definition of the functor that builds properties of dependent equalities assuming axiom eq_rect_eq *)

Module Type EqdepElimination.

  Axiom eq_rect_eq :
    forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p),
      x = eq_rect p Q x p h.

End EqdepElimination.

Module EqdepTheory (M:EqdepElimination).

  Section Axioms.

    Variable U:Type.

(** Invariance by Substitution of Reflexive Equality Proofs *)

Lemma eq_rect_eq :
  forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
Proof M.eq_rect_eq U.

Lemma eq_rec_eq :
  forall (p:U) (Q:U -> Set) (x:Q p) (h:p = p), x = eq_rec p Q x p h.
Proof (fun p Q => M.eq_rect_eq U p Q).

(** Injectivity of Dependent Equality *)

Lemma eq_dep_eq : forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y.
Proof (eq_rect_eq__eq_dep_eq U eq_rect_eq).

(** Uniqueness of Identity Proofs (UIP) is a consequence of *)
(** Injectivity of Dependent Equality *)

Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2.
Proof (eq_dep_eq__UIP U eq_dep_eq).

(** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *)

Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x.
Proof (UIP__UIP_refl U UIP).

(** Streicher's axiom K is a direct consequence of Uniqueness of
    Reflexive Identity Proofs *)

Lemma Streicher_K :
  forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
Proof (UIP_refl__Streicher_K U UIP_refl).

End Axioms.

(** UIP implies the injectivity of equality on dependent pairs in Type *)

Lemma inj_pair2 :
 forall (U:Type) (P:U -> Type) (p:U) (x y:P p),
   existT P p x = existT P p y -> x = y.
Proof (fun U => eq_dep_eq__inj_pair2 U (eq_dep_eq U)).

Notation inj_pairT2 := inj_pair2.

End EqdepTheory.

(** Basic facts about eq_dep *)

Lemma f_eq_dep :
  forall U (P:U->Type) R p q x y (f:forall p, P p -> R p),
    eq_dep p x q y -> eq_dep p (f p x) q (f q y).
Proof.
intros * []. reflexivity.
Qed.

Lemma eq_dep_non_dep :
  forall U P p q x y, @eq_dep U (fun _ => P) p x q y -> x = y.
Proof.
intros * []. reflexivity.
Qed.

Lemma f_eq_dep_non_dep :
  forall U (P:U->Type) R p q x y (f:forall p, P p -> R),
    eq_dep p x q y -> f p x = f q y.
Proof.
intros * []. reflexivity.
Qed.

Arguments eq_dep  U P p x q _ : clear implicits.
Arguments eq_dep1 U P p x q y : clear implicits.


Require Export parser.

Definition P1: IA := parse
"IA [IDLE_SS, WAIT_SS, DATA_SS] (IDLE_SS)
[Sa_CONN_conf_S, Sa_DISC_ind_S, Sa_HPDATA_ind_S, Sa_DATA_ind_S]
[Sa_CONN_req_S, Sa_DISC_req_S, Sa_HPDATA_req_S, Sa_DATA_req_S] []
[IDLE_SS->(Sa_CONN_req_S)WAIT_SS,
 WAIT_SS->(Sa_DISC_ind_S)IDLE_SS,
 WAIT_SS->(Sa_CONN_conf_S)DATA_SS,
 DATA_SS->(Sa_DATA_ind_S)DATA_SS, DATA_SS->(Sa_HPDATA_ind_S)DATA_SS,
 DATA_SS->(Sa_DATA_req_S)DATA_SS, DATA_SS->(Sa_HPDATA_req_S)DATA_SS,
 DATA_SS->(Sa_DISC_ind_S)IDLE_SS, DATA_SS->(Sa_DISC_req_S)IDLE_SS]".

Definition P2: IA := parse
"IA
 [DISC_1_S, IDLE_S, DISC_2_S, CONN_S, WFDIS_S, DISC_3_S, SA_HP_S, DISC_4_S,
  WFTC_S, T_DA_S, DATA_S, SA_DA_S, T_HP_S, CONF_S, WFAR_S, AR_S]
 (IDLE_S)
 [Sa_CONN_req_S, Sa_DISC_req_S, T_DISC_ind_S, Sa_HPDATA_req_S, T_DATA_ind_S, T_CONN_conf_S, Sa_DATA_req_S, T_HPDATA_ind_S]
 [T_CONN_req_S, T_DISC_req_S, Sa_DISC_ind_S, T_HPDATA_req_S, Sa_DATA_ind_S, Sa_CONN_conf_S, T_DATA_req_S, Sa_HPDATA_ind_S]
 [e]
 [IDLE_S->(Sa_CONN_req_S)CONN_S,
  CONN_S->(T_CONN_req_S)WFTC_S, CONN_S->(e)DISC_1_S,
  DISC_1_S->(Sa_DISC_ind_S)IDLE_S,
  WFTC_S->(Sa_DISC_ind_S)WFDIS_S, WFTC_S->(T_DISC_ind_S)DISC_1_S,
  WFDIS_S->(T_DISC_req_S)IDLE_S,
  WFTC_S->(T_CONN_conf_S)CONF_S,
  CONF_S->(T_DISC_req_S)DISC_1_S, CONF_S->(T_DATA_req_S)WFAR_S,
  WFAR_S->(T_DISC_ind_S)DISC_1_S, WFAR_S->(Sa_DISC_req_S)DISC_2_S,
  WFAR_S->(T_DATA_ind_S)AR_S,
  AR_S->(Sa_DISC_ind_S)DISC_2_S, AR_S->(Sa_CONN_conf_S)DATA_S,
  DATA_S->(Sa_DISC_req_S)DISC_2_S, DISC_2_S->(T_DISC_req_S)IDLE_S,
  DATA_S->(T_DISC_ind_S)DISC_4_S, DISC_4_S->(Sa_DISC_ind_S)IDLE_S,
  DATA_S->(Sa_HPDATA_req_S)SA_HP_S, SA_HP_S->(T_HPDATA_req_S)DATA_S,
  DATA_S->(T_DATA_ind_S)T_DA_S, T_DA_S->(Sa_DATA_ind_S)DATA_S,
  DATA_S->(Sa_DATA_req_S)SA_DA_S, SA_DA_S->(T_DATA_req_S)DATA_S,
  DATA_S->(T_HPDATA_ind_S)T_HP_S, T_HP_S->(Sa_HPDATA_ind_S)DATA_S,
  T_DA_S->(Sa_DISC_ind_S)DISC_3_S, DISC_3_S->(T_DISC_req_S)IDLE_S]".

(*this is an alternative P2 that considers
  the maximum connection establishment delay timer T_{estab} thus
  the dash arcs in Fig5.(a) of Zhang Yan's SciChinaE *)
Definition P2': IA := parse
"IA [DISC_1_S, IDLE_S, DISC_2_S, CONN_S, WFDIS_S, DISC_3_S, SA_HP_S, DISC_4_S,
    WFTC_S, T_DA_S, DATA_S, SA_DA_S, T_HP_S, CONF_S, WFAR_S, AR_S] (IDLE_S)
 [Sa_CONN_req_S, Sa_DISC_req_S, T_DISC_ind_S, Sa_HPDATA_req_S, T_DATA_ind_S,
  T_CONN_conf_S, Sa_DATA_req_S, T_HPDATA_ind_S]
 [T_CONN_req_S, T_DISC_req_S, Sa_DISC_ind_S, T_HPDATA_req_S, Sa_DATA_ind_S,
  Sa_CONN_conf_S, T_DATA_req_S, Sa_HPDATA_ind_S] [e]
 [DISC_1_S->(Sa_DISC_ind_S)IDLE_S, DISC_2_S->(T_DISC_req_S)IDLE_S,
 IDLE_S->(Sa_CONN_req_S)CONN_S, CONN_S->(e)DISC_1_S,
 WFDIS_S->(T_DISC_req_S)IDLE_S,
 DISC_3_S->(T_DISC_req_S)IDLE_S, DISC_4_S->(Sa_DISC_ind_S)IDLE_S,
 CONN_S->(T_CONN_req_S)WFTC_S, WFTC_S->(Sa_DISC_ind_S)WFDIS_S,
 WFTC_S->(T_DISC_ind_S)DISC_1_S,
 WFTC_S->(T_CONN_conf_S)CONF_S, CONF_S->(T_DISC_req_S)DISC_1_S,
 CONF_S->(T_DATA_req_S)WFAR_S, WFAR_S->(T_DISC_ind_S)DISC_1_S,
 WFAR_S->(Sa_DISC_req_S)DISC_2_S,
 WFAR_S->(T_DATA_ind_S)AR_S, AR_S->(Sa_DISC_ind_S)DISC_2_S,
 AR_S->(Sa_CONN_conf_S)DATA_S,
 DATA_S->(T_DISC_ind_S)DISC_4_S, DATA_S->(Sa_DISC_req_S)DISC_2_S,
 DATA_S->(Sa_HPDATA_req_S)SA_HP_S, SA_HP_S->(T_HPDATA_req_S)DATA_S,
 DATA_S->(T_DATA_ind_S)T_DA_S, T_DA_S->(Sa_DATA_ind_S)DATA_S,
 DATA_S->(Sa_DATA_req_S)SA_DA_S, SA_DA_S->(T_DATA_req_S)DATA_S,
 DATA_S->(T_HPDATA_ind_S)T_HP_S, T_HP_S->(Sa_HPDATA_ind_S)DATA_S,
 T_DA_S->(Sa_DISC_ind_S)DISC_3_S,
 WFAR_S->(Sa_DISC_ind_S)DISC_2_S, WFTC_S->(T_DISC_req_S)DISC_1_S]".

Definition P3: IA := parse
"IA [IDLE_T, HP_F_T, CONR_S_T, DA_S_T, DISC_S_T, HP_S_T, DISC_F_T, DA_F_T, CONRS_F_T]
 (IDLE_T)
 [T_HPDATA_req_F, T_CONN_resp_F, T_DATA_req_F, T_DISC_req_F, T_HPDATA_req_S, T_DISC_req_S, T_DATA_req_S, T_CONN_req_S]
 [T_HPDATA_ind_S, T_CONN_conf_S, T_DATA_ind_S, T_DISC_ind_S, T_HPDATA_ind_F, T_DISC_ind_F, T_DATA_ind_F, T_CONN_ind_F]
 [e]
 [ IDLE_T->(T_HPDATA_req_F)HP_F_T, HP_F_T->(T_HPDATA_ind_S)IDLE_T,
   IDLE_T->(T_CONN_resp_F)CONRS_F_T, CONRS_F_T->(T_CONN_conf_S)IDLE_T,
   IDLE_T->(T_DATA_req_F)DA_F_T, DA_F_T->(T_DATA_ind_S)IDLE_T,
   IDLE_T->(T_DISC_req_F)DISC_F_T, DISC_F_T->(T_DISC_ind_S)IDLE_T,
   IDLE_T->(T_HPDATA_req_S)HP_S_T, HP_S_T->(T_HPDATA_ind_F)IDLE_T,
   IDLE_T->(T_DISC_req_S)DISC_S_T, DISC_S_T->(T_DISC_ind_F)IDLE_T, DISC_S_T->(e)IDLE_T,
   IDLE_T->(T_DATA_req_S)DA_S_T, DA_S_T->(T_DATA_ind_F)IDLE_T,
   IDLE_T->(T_CONN_req_S)CONR_S_T, CONR_S_T->(T_CONN_ind_F)IDLE_T
 ]".

Definition P4: IA := parse
"IA [IDLE_F, DISC_1_F, DISC_2_F, CONIND_F, WFAU3_F, DISC_3_F, SA_HP_F,
 DATA_F, T_HP_F, SA_DA_F, T_DA_F, RAU3_F, WFRESP_F, SNDAR_F]
 (IDLE_F)
 [T_CONN_ind_F, Sa_DISC_req_F, T_DISC_ind_F, Sa_DATA_req_F, T_DATA_ind_F, Sa_CONN_resp_F, Sa_HPDATA_req_F, T_HPDATA_ind_F]
 [Sa_CONN_ind_F, T_DISC_req_F, Sa_DISC_ind_F, T_DATA_req_F, Sa_DATA_ind_F, T_CONN_resp_F, T_HPDATA_req_F, Sa_HPDATA_ind_F] [e]
 [DISC_1_F->(T_DISC_req_F)IDLE_F, DISC_2_F->(Sa_DISC_ind_F)IDLE_F,
 IDLE_F->(T_CONN_ind_F)CONIND_F, CONIND_F->(e)DISC_1_F,
 CONIND_F->(T_CONN_resp_F)WFAU3_F, WFAU3_F->(T_DATA_ind_F)RAU3_F,
 RAU3_F->(e)DISC_1_F, RAU3_F->(Sa_CONN_ind_F)WFRESP_F,
 WFRESP_F->(Sa_DISC_req_F)DISC_1_F, WFRESP_F->(T_DISC_ind_F)DISC_2_F,
 WFRESP_F->(Sa_CONN_resp_F)SNDAR_F, SNDAR_F->(T_DATA_req_F)DATA_F,
 DATA_F->(Sa_HPDATA_req_F)SA_HP_F, SA_HP_F->(T_HPDATA_req_F)DATA_F,
 DATA_F->(T_HPDATA_ind_F)T_HP_F, T_HP_F->(Sa_HPDATA_ind_F)DATA_F,
 DATA_F->(Sa_DATA_req_F)SA_DA_F, SA_DA_F->(T_DATA_req_F)DATA_F,
 DATA_F->(T_DATA_ind_F)T_DA_F, T_DA_F->(Sa_DATA_ind_F)DATA_F,
 WFAU3_F->(T_DISC_ind_F)IDLE_F, DATA_F->(T_DISC_ind_F)DISC_2_F,
 T_DA_F->(Sa_DISC_ind_F)DISC_3_F, DISC_3_F->(T_DISC_req_F)IDLE_F,
 DATA_F->(Sa_DISC_req_F)DISC_3_F]".

Definition P5: IA := parse
"IA [IDLE_SF, WAIT_SF, DATA_SF] (IDLE_SF)
 [Sa_CONN_ind_F, Sa_DISC_ind_F, Sa_HPDATA_ind_F, Sa_DATA_ind_F]
 [Sa_CONN_resp_F, Sa_DISC_req_F, Sa_HPDATA_req_F, Sa_DATA_req_F] []
 [IDLE_SF->(Sa_CONN_ind_F)WAIT_SF, WAIT_SF->(Sa_CONN_resp_F)DATA_SF,
  WAIT_SF->(Sa_DISC_ind_F)IDLE_SF, WAIT_SF->(Sa_DISC_req_F)IDLE_SF,
  DATA_SF->(Sa_DISC_ind_F)IDLE_SF, DATA_SF->(Sa_DISC_req_F)IDLE_SF,
  DATA_SF->(Sa_DATA_ind_F)DATA_SF, DATA_SF->(Sa_HPDATA_ind_F)DATA_SF,
  DATA_SF->(Sa_DATA_req_F)DATA_SF, DATA_SF->(Sa_HPDATA_req_F)DATA_SF]".

(* the S-side synthesis on P2 and P2' *)
Eval compute in IAutomaton.b_compatible P1 P2. (*false*)
Eval compute in IAutomaton.b_compatible P2 P3. (*true*)

Definition P23: IA := IAutomaton.composition P2 P3.

Eval compute in IAutomaton.b_compatible P1 P23. (*true*)

Eval compute in IAutomaton.b_compatible P1 P2'. (*false*)
Eval compute in IAutomaton.b_compatible P2' P3. (*true*)

Definition P23': IA := IAutomaton.composition P2' P3.

Eval compute in IAutomaton.b_compatible P1 P23'. (*true*)

(* according to the synthesis, we get the correct P2 as P2_synthesis *)
Definition P2_synthesis: IA := parse
"IA
 [DISC_1_S, IDLE_S, DISC_2_S, CONN_S, WFDIS_S, DISC_3_S, SA_HP_S, DISC_4_S,
  WFTC_S, T_DA_S, DATA_S, SA_DA_S, T_HP_S, CONF_S, WFAR_S, AR_S]
 (IDLE_S)
 [Sa_CONN_req_S, Sa_DISC_req_S, T_DISC_ind_S, Sa_HPDATA_req_S, T_DATA_ind_S, T_CONN_conf_S, Sa_DATA_req_S, T_HPDATA_ind_S]
 [T_CONN_req_S, T_DISC_req_S, Sa_DISC_ind_S, T_HPDATA_req_S, Sa_DATA_ind_S, Sa_CONN_conf_S, T_DATA_req_S, Sa_HPDATA_ind_S]
 [e]
 [IDLE_S->(Sa_CONN_req_S)CONN_S,
  CONN_S->(T_CONN_req_S)WFTC_S, CONN_S->(e)DISC_1_S,
  DISC_1_S->(Sa_DISC_ind_S)IDLE_S,
  WFTC_S->(Sa_DISC_req_S)WFDIS_S, WFTC_S->(T_DISC_ind_S)DISC_1_S,
  WFDIS_S->(T_DISC_req_S)IDLE_S,
  WFTC_S->(T_CONN_conf_S)CONF_S,
  CONF_S->(T_DISC_req_S)DISC_1_S, CONF_S->(T_DATA_req_S)WFAR_S,
  WFAR_S->(T_DISC_ind_S)DISC_1_S, WFAR_S->(Sa_DISC_req_S)DISC_2_S,
  WFAR_S->(T_DATA_ind_S)AR_S,
  AR_S->(Sa_DISC_ind_S)DISC_2_S, AR_S->(Sa_CONN_conf_S)DATA_S,
  DATA_S->(Sa_DISC_req_S)DISC_2_S, DISC_2_S->(T_DISC_req_S)IDLE_S,
  DATA_S->(T_DISC_ind_S)DISC_4_S, DISC_4_S->(Sa_DISC_ind_S)IDLE_S,
  DATA_S->(Sa_HPDATA_req_S)SA_HP_S, SA_HP_S->(T_HPDATA_req_S)DATA_S,
  DATA_S->(T_DATA_ind_S)T_DA_S, T_DA_S->(Sa_DATA_ind_S)DATA_S,
  DATA_S->(Sa_DATA_req_S)SA_DA_S, SA_DA_S->(T_DATA_req_S)DATA_S,
  DATA_S->(T_HPDATA_ind_S)T_HP_S, T_HP_S->(Sa_HPDATA_ind_S)DATA_S,
  T_DA_S->(Sa_DISC_ind_S)DISC_3_S, DISC_3_S->(T_DISC_req_S)IDLE_S]".

Eval compute in IAutomaton.b_compatible P1 P2_synthesis. (* true *)
Eval compute in IAutomaton.b_compatible P2_synthesis P3. (* true *)

(* the S-side composition *)
Definition P23'': IA := IAutomaton.composition P2_synthesis P3.

Eval compute in IAutomaton.b_compatible P1 P23''. (* true *)

Definition P123: IA := IAutomaton.composition P1 P23''.
Eval compute in :> P123.

(* the F-side composition *)
Eval compute in IAutomaton.b_compatible P3 P4. (*true*)
Eval compute in IAutomaton.b_compatible P4 P5. (*true*)

Definition P45: IA := IAutomaton.composition P4 P5.

Eval compute in IAutomaton.b_compatible P3 P45. (*true*)

Definition P345: IA := IAutomaton.composition P3 P45.

Eval compute in :> P345.


Definition even (n : nat) : Prop :=
  exists p, n = 2 * p.

Definition prime (n : nat) : Prop :=
  n >= 2 /\
  forall p q, n = p * q -> p = n \/ p = 1.

(* Lemma bogus : (2 : {x : nat & prime x}). *)

Lemma fixed : exists y : {x : nat & prime x}, 2 = projT1 y.
Proof. Admitted.

Lemma prime_two : prime 2.
Proof. unfold prime. split.
  {  }

Check even 1.


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

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

Print Assumptions add.


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 Bprime Cprime : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ A Bprime /\ (wd_ A Cprime /\ (wd_ Cprime C /\ (wd_ Bprime B /\ (col_ A B C /\ (col_ A Bprime B /\ col_ A Cprime C)))))))) -> col_ A Bprime Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 Bprime Cprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Cprime A /\ (wd_ Bprime A /\ (col_ A Bprime Cprime /\ (col_ A C Cprime /\ col_ A B Bprime))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

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

Print Assumptions mul.