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

Set Implicit Arguments.
From SLF Require Export Nondet.
Close Scope val_scope.
Close Scope trm_scope.

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.

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

    Assume [evalnp s t Q] to hold. Prove that the postcondition [Q] holds of
    any output that [(s,t)] may evaluate to according to the judgment [eval]. *)

Lemma evalnp_inv_eval : forall s t v s' Q,
  evalnp s t Q ->
  eval s t s' v ->
  Q v s'.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** 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 *)

(* ================================================================= *)
(** ** Interpretation of [evalnp] w.r.t. [eval] and [safe] *)

(** The predicate [safe s t] asserts that an execution of the configuration
    [t/s] can never get stuck. Its definition is a simplified version of
    [evalnp] where all occurences of [Q] are removed. In the rule for let-
    bindings, namely [safe_let], the quantification over the configuration
    [v1/s2] is done by refering to the big-step judgment [eval]. *)

CoInductive safe : state -> trm -> Prop :=
  | safe_val : forall s v,
      safe s (trm_val v)
  | safe_fix : forall s f x t1,
      safe s (trm_fix f x t1)
  | safe_app_fix : forall s v1 v2 f x t1,
      v1 = val_fix f x t1 ->
      safe s (subst x v2 (subst f v1 t1)) ->
      safe s (trm_app v1 v2)
  | safe_let : forall s x t1 t2,
      safe s t1 ->
      (forall v1 s2, eval s t1 s2 v1 -> safe s2 (subst x v1 t2)) ->
      safe s (trm_let x t1 t2)
  | safe_if : forall s b t1 t2,
      safe s (if b then t1 else t2) ->
      safe s (trm_if (val_bool b) t1 t2)
  | safes_add : forall s n1 n2,
      safe s (val_add (val_int n1) (val_int n2))
  | safe_rand : forall s n,
      n > 0 ->
      safe s (val_rand (val_int n))
  | safe_ref : forall s v,
      safe s (val_ref v)
  | safe_get : forall s p,
      Fmap.indom s p ->
      safe s (val_get (val_loc p))
  | safe_set : forall s p v,
      Fmap.indom s p ->
      safe s (val_set (val_loc p) v)
  | safe_free : forall s p,
      Fmap.indom s p ->
      safe s (val_free (val_loc p)).

Section EvalnpSafe.
Hint Constructors eval evalnp.

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

    Prove that [evalnp s t Q] is equivalent to the conjunction of [safe s t]
    and to a partial correctness result asserting that if an evaluation of
    [t/s] terminates on a particular result, then this result satisfies [Q]. *)

Lemma evalnp_iff_safe_and_post : forall s t Q,
  evalnp s t Q <-> (safe s t /\ (forall v s', eval s t s' v -> Q v s')).
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** Let [Any] denotes the postcondition that accepts any result. *)

Definition Any : val->state->Prop :=
  fun v s => True.

Hint Unfold Any.

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

    Prove that [safe s t] is equivalent to [evalnp s t Any].
    Hint: a direct proof fails---why?
    The solution is to exploit [evalnp_iff_safe_and_post]. *)

Lemma safe_iff_evalnp_any : forall s t,
  safe s t <-> evalnp s t Any.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

End EvalnpSafe.

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

(** 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.

(** 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 Charact. 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-08-11 15:25 *)


From UnivalentParametricity Require Import HoTT UR URTactics FP Record MoreInductive.
Require Import PeanoNat list perm lemmas.

Set Universe Polymorphism.

Open Scope bool_scope.
Infix "==>" := implb (at level 40, left associativity) : bool_scope.
Definition is_true (b : bool) := (b = true).
Hint Unfold is_true.
Coercion is_true : bool >-> Sortclass.

Notation "x <= y" := (Nat.leb x y) (at level 70, y at next level, no associativity) : nat_scope.

Notation "x <> y" := (x = y -> False) : type_scope.
Coercion logic_eq_is_eq : Logic.eq >-> eq.
Hint Extern 4 => repeat (match goal with H : Logic.eq _ _ |- _ => apply logic_eq_is_eq in H end).

Notation "'typeof' x" := (let A := _ in let _ : A := x in A) (at level 100).

Definition eq_ind {A : Type} (x : A) (P : A -> Type) (H : P x) (y : A) (Heq : x = y) :=
  eq_rect A x (fun (a : A) (H0 : x = a) => P a) H y Heq. (* for compatibility *)

Definition sigT_rect {A : Type} {P : A -> Type} (P0 : {x : A & P x} -> Set) (H : forall (x : A) (p : P x), P0 (x; p)) :=
  sigT_rect A P P0 H. (* for compatibility *)

Add Printing Let sigT. (* for consistency *)

(*
 * We do not want our timing results to include printing, so we
 * define a function that hides the results while still forcing
 * computation (unit does not work for this).
 *)
Definition hide {T : Type} (t : T) :=
  tl [t].

Module Type Comparable.

  Parameter t : Set.
  Parameter leb : t -> t -> bool.
  Parameter refl : forall x, leb x x.
  Parameter antisym : forall x y, leb x y -> leb y x -> x = y.

  Definition eqb x y := leb x y && leb y x.
  Definition ltb x y := leb x y && negb (leb y x).
  Definition eqb_dec x y : if eqb x y then (x = y) else (x <> y).
  Proof.
    destruct (eqb x y) eqn:E; unfold eqb in E.
    - apply Bool.andb_true_iff in E as [E_l E_r]. apply antisym; [exact E_l|exact E_r].
    - apply Bool.andb_false_iff in E as [E|E]; intro H; rewrite H, refl in E; discriminate.
  Defined.

  Definition min x y := if leb x y then x else y.
  Definition max x y := if leb x y then y else x.

  Parameters x y z : t.

End Comparable.

Module CaseStudy (Elem : Comparable).

  Lemma list_rect_eta {A} (xs : list A) :
    list_rect A (fun _ => list A) nil (fun x _ xs => x :: xs) xs = xs.
  Proof. induction xs; cbn; try rewrite IHxs; reflexivity. Defined.

  Hint Extern 0 (?t ≈ ?t) => reflexivity : typeclass_instances.

  Definition Decidable_eq_elem : DecidableEq Elem.t.
  Proof.
    constructor. intros x y. pose proof (Elem.eqb_dec x y) as H. destruct (Elem.eqb x y); auto.
  Defined.

  Instance elem_Hset : HSet Elem.t := @Hedberg Elem.t Decidable_eq_elem.
  Instance UR_elem : UR Elem.t Elem.t := UR_gen Elem.t.
  Instance FP_elem : Elem.t ⋈ Elem.t := URType_Refl_decidable Elem.t Decidable_eq_elem.
  Instance Transportable_elem (P : Elem.t -> Type) : Transportable P :=
    @Transportable_decidable _ P Decidable_eq_elem.

  Definition Decidable_eq_list_elem : DecidableEq (list Elem.t).
  Proof.
    constructor. induction a as [|x xs IH]; cbn; intros [|y ys].
    - left. reflexivity.
    - right. inversion 1.
    - right. inversion 1.
    - specialize (IH ys). destruct IH as [E|E].
      + rewrite <- E. clear E. pose proof Decidable_eq_elem. destruct H.
        destruct (dec_paths x y) as [E|E].
        * rewrite <- E. clear E. left. reflexivity.
        * right. inversion 1. destruct (E H1).
      + right. inversion 1. destruct (E H2).
  Defined.

  Instance list_elem_Hset : HSet (list Elem.t) := @Hedberg (list Elem.t) Decidable_eq_list_elem.

  Lemma UR_list_refl {A} (xs : list A) : UR_list (eq A) xs xs.
  Proof. induction xs; econstructor; [reflexivity|assumption]. Defined.

  Lemma UR_list_elem_eq {xs xs' : list Elem.t} (U : xs ≈ xs') : xs = xs'.
  Proof.
    apply (@univalent_transport _ _ (alt_ur_coh _ _ _ xs xs')) in U. revert xs U. cbn.
    rewrite list_rect_eta. auto.
  Defined.

  Instance UR_permutes_elem
           (xs xs' : list Elem.t) (U_xs : xs ≈ xs')
           (ys ys' : list Elem.t) (U_ys : ys ≈ ys') :
    UR (permutes xs ys) (permutes xs' ys').
  Proof. rewrite <- (UR_list_elem_eq U_xs), <- (UR_list_elem_eq U_ys). apply UR_gen. Defined.

  Instance UR_permutes_elem_id
           (xs : list Elem.t) (U_xs : xs ≈ xs)
           (ys : list Elem.t) (U_ys : ys ≈ ys) :
    UR_permutes_elem xs xs U_xs ys ys U_ys = UR_gen (permutes xs ys).
  Proof.
    unfold UR_permutes_elem.
    repeat rewrite (is_hset _ _ (UR_list_elem_eq _) eq_refl). reflexivity.
  Defined.

  Instance Equiv_permutes_elem
           (xs xs' : list Elem.t) (U_xs : xs ≈ xs')
           (ys ys' : list Elem.t) (U_ys : ys ≈ ys') :
    permutes xs ys ≃ permutes xs' ys'.
  Proof.
    rewrite <- (UR_list_elem_eq U_xs), <- (UR_list_elem_eq U_ys).
    eapply Equiv_id.
  Defined.

  Instance Equiv_permutes_elem_id
           (xs : list Elem.t) (U_xs : xs ≈ xs)
           (ys : list Elem.t) (U_ys : ys ≈ ys) :
    Equiv_permutes_elem xs xs U_xs ys ys U_ys = Equiv_id (permutes xs ys).
  Proof.
    unfold Equiv_permutes_elem.
    repeat rewrite (is_hset _ _ (UR_list_elem_eq _) eq_refl). reflexivity.
  Defined.

  Instance FP_permutes_elem
           (xs xs' : list Elem.t) (U_xs : xs ≈ xs')
           (ys ys' : list Elem.t) (U_ys : ys ≈ ys') :
    permutes xs ys ⋈ permutes xs' ys'.
  Proof.
    unshelve esplit; try apply Canonical_eq_gen.
    esplit. intros perm perm'. unfold univalent_transport.
    pose proof (UR_list_elem_eq U_xs) as E_xs.
    pose proof (UR_list_elem_eq U_ys) as E_ys.
    revert U_xs U_ys. rewrite <- E_xs, <- E_ys. intros U_xs U_ys.
    rewrite Equiv_permutes_elem_id, UR_permutes_elem_id. cbn.
    eapply Equiv_id.
  Defined.

  Hint Extern 0 ((fun _ => permutes _ _) ≈ (fun _ => permutes _ _)) => unshelve esplit; intros : typeclass_instances.

  Module Base.

    Inductive tree : Type :=
    | Branch (val : Elem.t) (left right : tree)
    | Leaf (val : Elem.t).

    Definition Decidable_eq_tree :  DecidableEq tree.
    Proof.
      constructor. Local Ltac discr := let E := fresh in right; intro E; inversion E; auto; discriminate E.
      Local Ltac recur H x := specialize (H x); destruct H as [H|H]; [rewrite <- H|]; try discr.
      intro x. induction x as [x_v x_l IH_l x_r IH_r|x_v]; intros [y_v y_l y_r|y_v];
      try discr; pose Decidable_eq_elem as H_v; destruct H_v; pose (dec_paths x_v) as H_v'; recur H_v' y_v;
      try recur IH_l y_l; try recur IH_r y_r; left; reflexivity.
    Defined.

    Instance tree_Hset : HSet tree := @Hedberg tree Decidable_eq_tree.
    Instance UR_tree : UR tree tree := UR_gen tree.
    Instance FP_tree : tree ⋈ tree := URType_Refl_decidable tree Decidable_eq_tree.
    Instance Transportable_tree (P: tree -> Type) : Transportable P :=
      @Transportable_decidable _ P Decidable_eq_tree.

    (* --- Test trees --- *)
    Local Coercion Leaf : Elem.t >-> tree.

    (* --- Begin inputs --- *)

    (*
     * We import these from DEVOID, that way we can measure the performance difference of
     * only the lifted functions, controlling for the performance of lifted inputs (which is
     * slower in EFF) without clouding the results.
     *)
    (* INPUT tree1-base *)
    (* INPUT tree10-base *)
    (* INPUT tree20-base *)
    (* INPUT tree40-base *)
    (* INPUT tree60-base *)
    (* INPUT tree80-base *)
    (* INPUT tree100-base *)
    (* INPUT tree200-base *)
    (* INPUT tree400-base *)
    (* INPUT tree600-base *)
    (* INPUT tree800-base *)
    (* INPUT tree1000-base *)
    (* INPUT tree2000-base *)
    (* INPUT tree4000-base *)
    (* INPUT tree6000-base *)
    (* INPUT tree8000-base *)
    (* INPUT tree10000-base *)
    (* INPUT tree20000-base *)
    (* INPUT tree40000-base *)
    (* INPUT tree60000-base *)
    (* INPUT tree80000-base *)
    (* INPUT tree100000-base *)

    (* --- End inputs --- *)

    (* 13 LoC in normal form *)
    Definition preorder (t : tree) : list Elem.t :=
      tree_rect
        (fun _ => list Elem.t)
        (fun x _ ys _ zs => [x] ++ ys ++ zs)
        (fun x => [x])
        t.
    Redirect "../out/preorder/baseEFF1equiv" Time Eval vm_compute in (let foo := preorder tree1 in (hide foo)).
    Redirect "../out/preorder/baseEFF10equiv" Time Eval vm_compute in (let foo := preorder tree10 in (hide foo)).
    Redirect "../out/preorder/baseEFF100equiv" Time Eval vm_compute in (let foo := preorder tree100 in (hide foo)).
    Redirect "../out/preorder/baseEFF1000equiv" Time Eval vm_compute in (let foo := preorder tree1000 in (hide foo)).
    Redirect "../out/preorder/baseEFF10000equiv" Time Eval vm_compute in (let foo := preorder tree10000 in (hide foo)).
    Redirect "../out/preorder/baseEFF100000equiv" Time Eval vm_compute in (let foo := preorder tree100000 in (hide foo)).

    (* 12 LoC in normal form *)
    Definition inorder (t : tree) : list Elem.t :=
      tree_rect
        (fun _ => list Elem.t)
        (fun x _ ys _ zs => ys ++ [x] ++ zs)
        (fun x => [x])
        t.
    Redirect "../out/inorder/baseEFF1equiv" Time Eval vm_compute in (let foo := inorder tree1 in (hide foo)).
    Redirect "../out/inorder/baseEFF10equiv" Time Eval vm_compute in (let foo := inorder tree10 in (hide foo)).
    Redirect "../out/inorder/baseEFF100equiv" Time Eval vm_compute in (let foo := inorder tree100 in (hide foo)).
    Redirect "../out/inorder/baseEFF1000equiv" Time Eval vm_compute in (let foo := inorder tree1000 in (hide foo)).
    Redirect "../out/inorder/baseEFF10000equiv" Time Eval vm_compute in (let foo := inorder tree10000 in (hide foo)).
    Redirect "../out/inorder/baseEFF100000equiv" Time Eval vm_compute in (let foo := inorder tree100000 in (hide foo)).

    (* 12 LoC in normal form *)
    Definition postorder (t : tree) : list Elem.t :=
      tree_rect
        (fun _ => list Elem.t)
        (fun x _ ys _ zs => ys ++ zs ++ [x])
        (fun x => [x])
        t.
    Redirect "../out/postorder/baseEFF1equiv" Time Eval vm_compute in (let foo := postorder tree1 in (hide foo)).
    Redirect "../out/postorder/baseEFF10equiv" Time Eval vm_compute in (let foo := postorder tree10 in (hide foo)).
    Redirect "../out/postorder/baseEFF100equiv" Time Eval vm_compute in (let foo := postorder tree100 in (hide foo)).
    Redirect "../out/postorder/baseEFF1000equiv" Time Eval vm_compute in (let foo := postorder tree1000 in (hide foo)).
    Redirect "../out/postorder/baseEFF10000equiv" Time Eval vm_compute in (let foo := postorder tree10000 in (hide foo)).
    Redirect "../out/postorder/baseEFF100000equiv" Time Eval vm_compute in (let foo := postorder tree100000 in (hide foo)).

    Lemma pre_permutes : forall t : tree,
        permutes (preorder t) (inorder t).
    Proof.
      induction t; simpl.
      - apply perm_cons_app. apply perm_app; assumption.
      - apply perm_skip. apply perm_nil.
    Defined.

    Lemma post_permutes : forall t : tree,
        permutes (postorder t) (inorder t).
    Proof.
      induction t; simpl.
      - apply perm_app. assumption. apply perm_sym. apply perm_cons_app.
        rewrite app_nil_r. apply perm_sym. assumption.
      - apply perm_skip. apply perm_nil.
    Defined.

    Lemma pre_post_permutes : forall t : tree,
        permutes (preorder t) (postorder t).
    Proof.
      intro t. eapply perm_trans. apply pre_permutes.
      apply perm_sym, post_permutes.
    Defined.

  End Base.

  (* --- Single iteration: from binary trees to sized binary trees --- *)

  Module Sized.

    Inductive tree : nat -> Type :=
    | Branch (n_l n_r : nat)
             (val : Elem.t)
             (left : tree n_l) (right : tree n_r)
      : tree (S (n_l + n_r))
    | Leaf (val : Elem.t) : tree (S O).

    Instance Equiv_tree (n n' : nat) (E : n = n') : tree n ≃ tree n'.
    Proof. apply can_eq in E; try tc. rewrite <- E. apply Equiv_id. Defined.

    Lemma Equiv_tree_id n : Equiv_tree n n eq_refl = Equiv_id (tree n).
    Proof. unfold Equiv_tree. rewrite can_eq_refl. reflexivity. Defined.

    Instance UR_tree (n n' : nat) (E : n = n') : UR (tree n) (tree n').
    Proof. rewrite <- E. apply UR_gen. Defined.

    Instance Transportable_tree : Transportable tree.
    Proof. esplit. intros h. rewrite Equiv_tree_id. reflexivity. Defined.

    Definition FP_tree : tree ≈ tree.
    Proof.
      cbn. split; try tc. cbn. intros n n' E. apply can_eq in E; try tc.
      rewrite <- E. esplit; try apply Canonical_eq_gen.
      esplit. cbn. intros t t'. unfold univalent_transport.
      rewrite Equiv_tree_id. cbn. eapply Equiv_id.
    Defined.

    (* --- Begin auto-generated equivalences from DEVOID --- *)

    (* EQUIV orn_size_index *)
    (* EQUIV orn_size *)
    (* EQUIV orn_size_inv *)
    (* EQUIV orn_size_section *)
    (* EQUIV orn_size_retraction *)

    (* --- End auto-generated equivalences from DEVOID --- *)

    Instance IsEquiv_orn_size : IsEquiv orn_size.
    Proof.
      eapply isequiv_adjointify with (g := orn_size_inv).
      - apply orn_size_section.
      - apply orn_size_retraction.
    Defined.

    Instance Equiv_orn_size : Base.tree ≃ {n:nat & tree n} :=
      BuildEquiv _ _ _ IsEquiv_orn_size.

    Instance UR_orn_size : Base.tree ⋈ {n:nat & tree n}.
    Proof.
      cbn. unshelve esplit.
      - esplit. intros t t'. exact (orn_size t = t').
      - esplit. intros t t'. cbn.
        apply (@isequiv_ap _ _ Equiv_orn_size).
      - apply Canonical_eq_gen.
      - apply Canonical_eq_gen.
    Defined.

    Definition orn_size_coh t : orn_size_inv (orn_size t) = t := e_sect orn_size t.

    (* --- Begin automatically generated lifted inputs from DEVOID --- *)

    (*
     * We import these from DEVOID, that way we can measure the performance difference of
     * only the lifted functions, controlling for the performance of lifted inputs (which is
     * slower in EFF) without clouding the results.
     *)
    (* INPUT tree1-sized *)
    (* INPUT tree10-sized *)
    (* INPUT tree20-sized *)
    (* INPUT tree40-sized *)
    (* INPUT tree60-sized *)
    (* INPUT tree80-sized *)
    (* INPUT tree100-sized *)
    (* INPUT tree200-sized *)
    (* INPUT tree400-sized *)
    (* INPUT tree600-sized *)
    (* INPUT tree800-sized *)
    (* INPUT tree1000-sized *)
    (* INPUT tree2000-sized *)
    (* INPUT tree4000-sized *)
    (* INPUT tree6000-sized *)
    (* INPUT tree8000-sized *)
    (* INPUT tree10000-sized *)
    (* INPUT tree20000-sized *)
    (* INPUT tree40000-sized *)
    (* INPUT tree60000-sized *)
    (* INPUT tree80000-sized *)
    (* INPUT tree100000-sized *)

    (* --- End automatically generated lifted inputs from DEVOID --- *)

    (* 38 LoC in normal form *)
    Definition preorder' : {n:nat & tree n} -> list Elem.t := ↑ Base.preorder.
    Definition preorder n t := preorder' (existT _ n t).
    Redirect "../out/preorder/sizedEFF1equiv" Time Eval vm_compute in (let foo := preorder' tree1 in (hide foo)).
    Redirect "../out/preorder/sizedEFF10equiv" Time Eval vm_compute in (let foo := preorder' tree10 in (hide foo)).
    Redirect "../out/preorder/sizedEFF100equiv" Time Eval vm_compute in (let foo := preorder' tree100 in (hide foo)).
    Redirect "../out/preorder/sizedEFF1000equiv" Time Eval vm_compute in (let foo := preorder' tree1000 in (hide foo)).
    Redirect "../out/preorder/sizedEFF10000equiv" Time Eval vm_compute in (let foo := preorder' tree10000 in (hide foo)).
    Redirect "../out/preorder/sizedEFF100000equiv" Time Eval vm_compute in (let foo := preorder' tree100000 in (hide foo)).

    (* 37 LoC in normal form *)
    Definition inorder' : {n:nat & tree n} -> list Elem.t := ↑ Base.inorder.
    Definition inorder n t := inorder' (existT _ n t).
    Redirect "../out/inorder/sizedEFF1equiv" Time Eval vm_compute in (let foo := inorder' tree1 in (hide foo)).
    Redirect "../out/inorder/sizedEFF10equiv" Time Eval vm_compute in (let foo := inorder' tree10 in (hide foo)).
    Redirect "../out/inorder/sizedEFF100equiv" Time Eval vm_compute in (let foo := inorder' tree100 in (hide foo)).
    Redirect "../out/inorder/sizedEFF1000equiv" Time Eval vm_compute in (let foo := inorder' tree1000 in (hide foo)).
    Redirect "../out/inorder/sizedEFF10000equiv" Time Eval vm_compute in (let foo := inorder' tree10000 in (hide foo)).
    Redirect "../out/inorder/sizedEFF100000equiv" Time Eval vm_compute in (let foo := inorder' tree100000 in (hide foo)).

    (* 43 LoC in normal form *)
    Definition postorder' : {n:nat & tree n} -> list Elem.t := ↑ Base.postorder.
    Definition postorder n t := postorder' (existT _ n t).
    Redirect "../out/postorder/sizedEFF1equiv" Time Eval vm_compute in (let foo := postorder' tree1 in (hide foo)).
    Redirect "../out/postorder/sizedEFF10equiv" Time Eval vm_compute in (let foo := postorder' tree10 in (hide foo)).
    Redirect "../out/postorder/sizedEFF100equiv" Time Eval vm_compute in (let foo := postorder' tree100 in (hide foo)).
    Redirect "../out/postorder/sizedEFF1000equiv" Time Eval vm_compute in (let foo := postorder' tree1000 in (hide foo)).
    Redirect "../out/postorder/sizedEFF10000equiv" Time Eval vm_compute in (let foo := postorder' tree10000 in (hide foo)).
    Redirect "../out/postorder/sizedEFF100000equiv" Time Eval vm_compute in (let foo := postorder' tree100000 in (hide foo)).

    Lemma FP_preorder : Base.preorder ≈ preorder'.
    Proof.
      intros t t' U. cbn in U. rewrite <- U. unfold preorder'. generalize Base.preorder.
      intros f. cbn. rewrite list_rect_eta. pose proof orn_size_coh. compute in H. compute. rewrite H.
      eapply UR_list_refl.
    Defined.

    Hint Extern 0 (Base.preorder ?t ≈ preorder' ?t') => unshelve refine (FP_preorder t t' _); intros :  typeclass_instances.

    Lemma FP_inorder : Base.inorder ≈ inorder'.
    Proof.
      intros t t' U. cbn in U. rewrite <- U. unfold inorder'. generalize Base.inorder.
      intros f. cbn. rewrite list_rect_eta. pose proof orn_size_coh. compute in H. compute. rewrite H.
      eapply UR_list_refl.
    Defined.

    Hint Extern 0 (Base.inorder ?t ≈ inorder' ?t') => unshelve refine (FP_inorder t t' _); intros :  typeclass_instances.

    Lemma FP_postorder : Base.postorder ≈ postorder'.
    Proof.
      intros t t' U. cbn in U. rewrite <- U. unfold postorder'. generalize Base.postorder.
      intros f. cbn. rewrite list_rect_eta. pose proof orn_size_coh. compute in H. compute. rewrite H.
      eapply UR_list_refl.
    Defined.

    Hint Extern 0 (Base.postorder ?t ≈ postorder' ?t') => unshelve refine (FP_postorder t t' _); intros :  typeclass_instances.

    Definition pre_permutes' : forall (t : {n:nat & tree n}), permutes (preorder' t) (inorder' t) :=
      ↑ Base.pre_permutes.

    (* --- Normalized term sizes --- *)
    Redirect "../out/normalized/preorder-sizedEFFequiv" Eval compute in preorder'.
    Redirect "../out/normalized/postorder-sizedEFFequiv" Eval compute in postorder'.
    Redirect "../out/normalized/inorder-sizedEFFequiv" Eval compute in inorder'.
    (* Redirect "../out/normalized/pre_permutes-sizedEFFequiv" Eval compute in pre_permutes'. *)

    (* Auto-generated definitions go here in together case study *)
    Module Comparison.
      (* DEF inorder-sized *)
      (* DEF postorder-sized *)
      (* DEF preorder-sized *)
      (* DEF pre_permutes-sized *)

      (* TIME-SIZED inorder-sized *)
      (* TIME-SIZED postorder-sized *)
      (* TIME-SIZED preorder-sized *)

      (* NORMALIZE inorder-sized *)
      (* NORMALIZE postorder-sized *)
      (* NORMALIZE preorder-sized *)
      (* NORMALIZE pre_permutes-sized *)
    End Comparison.

    (* --- Sanity tests --- *)
    Lemma test_inorder_sized : inorder' tree1000 = Comparison.inorder' tree1000. Proof. reflexivity. Qed.
    Lemma test_postorder_sized : postorder' tree1000 = Comparison.postorder' tree1000. Proof. reflexivity. Qed.
    Lemma test_preorder_sized : preorder' tree1000 = Comparison.preorder' tree1000. Proof. reflexivity. Qed.

  End Sized.

  (* --- Multiple iterations: from binary trees to binary search trees to AVL trees --- *)

  Module Ordered.

    Inductive __bst : Elem.t -> Type :=
    | __Branch (min_l min_r : Elem.t)
               (val : Elem.t)
               (left : __bst min_l) (right : __bst min_r)
      : __bst min_l
    | __Leaf (val : Elem.t) : __bst val.

    Inductive _bst : Elem.t -> Elem.t -> Type :=
    | _Branch (min_l min_r : Elem.t) (max_l max_r : Elem.t)
              (val : Elem.t)
              (left : _bst min_l max_l) (right : _bst min_r max_r)
      : _bst min_l max_r
    | _Leaf (val : Elem.t) : _bst val val.

    Definition inv (ord_l ord_r : bool) (max_l val min_r : Elem.t) : bool :=
      ord_l && ord_r && Elem.ltb max_l val && Elem.ltb val min_r.

    Inductive bst : Elem.t -> Elem.t -> bool -> Type :=
    | Branch (ord_l ord_r : bool) (min_l min_r : Elem.t) (max_l max_r : Elem.t)
             (val : Elem.t)
             (left : bst min_l max_l ord_l) (right : bst min_r max_r ord_r)
      : bst min_l max_r (inv ord_l ord_r max_l val min_r)
    | Leaf (val : Elem.t) : bst val val true.

    Instance Equiv_bst
             (lo lo' : Elem.t) (E_lo : lo = lo') (hi hi' : Elem.t) (E_hi : hi = hi')
             (ord ord' : bool) (E_ord : ord = ord') :
      bst lo hi ord ≃ bst lo' hi' ord'.
    Proof.
      apply can_eq in E_lo; try tc. apply can_eq in E_hi; try tc. apply can_eq in E_ord; try tc.
      rewrite <- E_lo, <- E_hi, <- E_ord. apply Equiv_id.
    Defined.

    Lemma Equiv_bst_id lo hi ord :
      Equiv_bst lo lo eq_refl hi hi eq_refl ord ord eq_refl = Equiv_id (bst lo hi ord).
    Proof. unfold Equiv_bst. repeat rewrite can_eq_refl. reflexivity. Defined.

    Instance UR_bst
             (lo lo' : Elem.t) (E_lo : lo = lo') (hi hi' : Elem.t) (E_hi : hi = hi')
             (ord ord' : bool) (E_ord : ord = ord') :
      UR (bst lo hi ord) (bst lo' hi' ord').
    Proof. rewrite <- E_lo, <- E_hi, <- E_ord. apply UR_gen. Defined.

    Instance Transportable_bst lo hi : Transportable (bst lo hi).
    Proof. econstructor. intros ord. rewrite Equiv_bst_id. reflexivity. Defined.

    Definition FP_bst : bst ≈ bst.
    Proof.
      cbn. intros lo lo' E_lo hi hi' E_hi. split; try tc. cbn. intros ord ord' E_ord.
      apply can_eq in E_lo; try tc. apply can_eq in E_hi; try tc. apply can_eq in E_ord; try tc.
      rewrite <- E_lo, <- E_hi, <- E_ord. esplit; try apply Canonical_eq_gen.
      econstructor. cbn. intros t t'. unfold univalent_transport. rewrite Equiv_bst_id. cbn. eapply Equiv_id.
    Defined.

    (* --- Begin auto-generated equivalences from DEVOID --- *)

    (* EQUIV __orn_order_index *)
    (* EQUIV __orn_order *)
    (* EQUIV __orn_order_inv *)
    (* EQUIV __orn_order_section *)
    (* EQUIV __orn_order_retraction *)
    (* EQUIV _orn_order_index *)
    (* EQUIV _orn_order *)
    (* EQUIV _orn_order_inv *)
    (* EQUIV _orn_order_section *)
    (* EQUIV _orn_order_retraction *)
    (* EQUIV orn_order_index *)
    (* EQUIV orn_order *)
    (* EQUIV orn_order_inv *)
    (* EQUIV orn_order_section *)
    (* EQUIV orn_order_retraction *)

    (* --- End auto-generated equivalences from DEVOID --- *)

   Instance IsEquiv___orn_order : IsEquiv __orn_order.
    Proof.
      intros. eapply isequiv_adjointify with (g := __orn_order_inv).
      - apply __orn_order_section.
      - apply __orn_order_retraction.
    Defined.

    Instance IsEquiv__orn_order : forall t, IsEquiv (_orn_order t).
    Proof.
      intros. eapply isequiv_adjointify with (g := _orn_order_inv t).
      - apply _orn_order_section.
      - apply _orn_order_retraction.
    Defined.

    Instance IsEquiv_orn_order : forall t t0, IsEquiv (orn_order t t0).
    Proof.
      intros. eapply isequiv_adjointify with (g := orn_order_inv t t0).
      - apply orn_order_section.
      - apply orn_order_retraction.
    Defined.

    Instance Equiv___orn_order : Base.tree ≃ {lo:Elem.t & __bst lo} :=
      BuildEquiv _ _ _ IsEquiv___orn_order.

    Instance Equiv__orn_order : forall (lo : Elem.t), __bst lo ≃ {hi:Elem.t & _bst lo hi} :=
      fun lo => BuildEquiv _ _ _ (IsEquiv__orn_order lo).

    Instance Equiv_orn_order : forall (lo hi : Elem.t), _bst lo hi ≃ {ord : bool & bst lo hi ord} :=
      fun lo hi => BuildEquiv _ _ _ (IsEquiv_orn_order lo hi).

    Instance UR___orn_order : Base.tree ⋈ {lo:Elem.t & __bst lo}.
    Proof.
      cbn. unshelve esplit.
      - econstructor. intros t t'. exact (__orn_order t = t').
      - econstructor. intros t t'. cbn.
        apply (@isequiv_ap _ _ Equiv___orn_order).
      - apply Canonical_eq_gen.
      - apply Canonical_eq_gen.
    Defined.

    Instance UR__orn_order : forall (lo : Elem.t), __bst lo ⋈ {hi:Elem.t & _bst lo hi}.
    Proof.
      cbn. unshelve esplit.
      - econstructor. intros t t'. exact (_orn_order lo t = t').
      - econstructor. intros t t'. cbn.
        apply (@isequiv_ap _ _ (Equiv__orn_order lo)).
      - apply Canonical_eq_gen.
      - apply Canonical_eq_gen.
    Defined.

    Instance UR_orn_order : forall (lo hi : Elem.t), _bst lo hi ⋈ {ord:bool & bst lo hi ord}.
    Proof.
      cbn. unshelve esplit.
      - econstructor. intros t t'. exact (orn_order lo hi t = t').
      - econstructor. intros t t'. cbn.
        apply (@isequiv_ap _ _ (Equiv_orn_order lo hi)).
      - apply Canonical_eq_gen.
      - apply Canonical_eq_gen.
    Defined.

    (* --- Begin automatically generated lifted inputs from DEVOID --- *)

    (*
     * We import these from DEVOID, that way we can measure the performance difference of
     * only the lifted functions, controlling for the performance of lifted inputs (which is
     * slower in EFF) without clouding the results.
     *)
    (* INPUT tree1'''-bst *)
    (* INPUT tree10'''-bst *)
    (* INPUT tree20'''-bst *)
    (* INPUT tree40'''-bst *)
    (* INPUT tree60'''-bst *)
    (* INPUT tree80'''-bst *)
    (* INPUT tree100'''-bst *)
    (* INPUT tree200'''-bst *)
    (* INPUT tree400'''-bst *)
    (* INPUT tree600'''-bst *)
    (* INPUT tree800'''-bst *)
    (* INPUT tree1000'''-bst *)
    (* INPUT tree2000'''-bst *)
    (* INPUT tree4000'''-bst *)
    (* INPUT tree6000'''-bst *)
    (* INPUT tree8000'''-bst *)
    (* INPUT tree10000'''-bst *)
    (* INPUT tree20000'''-bst *)
    (* INPUT tree40000'''-bst *)
    (* INPUT tree60000'''-bst *)
    (* INPUT tree80000'''-bst *)
    (* INPUT tree100000'''-bst *)

    (* INPUT tree1''-bst *)
    (* INPUT tree10''-bst *)
    (* INPUT tree100''-bst *)
    (* INPUT tree1000''-bst *)
    (* INPUT tree10000''-bst *)
    (* INPUT tree100000''-bst *)

    (* INPUT tree1'-bst *)
    (* INPUT tree10'-bst *)
    (* INPUT tree100'-bst *)
    (* INPUT tree1000'-bst *)
    (* INPUT tree10000'-bst *)
    (* INPUT tree100000'-bst *)

    (* INPUT tree1-bst *)
    (* INPUT tree10-bst *)
    (* INPUT tree100-bst *)
    (* INPUT tree1000-bst *)
    (* INPUT tree10000-bst *)
    (* INPUT tree100000-bst *)

    (* --- End automatically generated lifted inputs from DEVOID --- *)

    (* For consistency, follow the same process *)
    Definition __preorder'  : {lo:Elem.t & __bst lo} -> list Elem.t := ↑ Base.preorder.
    Definition __preorder lo t := __preorder' (lo; t).
    Definition _preorder' lo : {hi:Elem.t & _bst lo hi} -> list Elem.t := ↑ (__preorder lo).
    Definition _preorder lo hi t := _preorder' lo (hi; t).
    Definition preorder' lo hi : {ord : bool & bst lo hi ord} -> list Elem.t := ↑ (_preorder lo hi).
    Definition preorder {lo hi ord} t := preorder' lo hi (ord; t).

    Definition __inorder'  : {lo:Elem.t & __bst lo} -> list Elem.t := ↑ Base.inorder.
    Definition __inorder lo t := __inorder' (lo; t).
    Definition _inorder' lo : {hi:Elem.t & _bst lo hi} -> list Elem.t := ↑ (__inorder lo).
    Definition _inorder lo hi t := _inorder' lo (hi; t).
    Definition inorder' lo hi : {ord : bool & bst lo hi ord} -> list Elem.t := ↑ (_inorder lo hi).
    Definition inorder {lo hi ord} t := inorder' lo hi (ord; t).

    Definition __postorder'  : {lo:Elem.t & __bst lo} -> list Elem.t := ↑ Base.postorder.
    Definition __postorder lo t := __postorder' (lo; t).
    Definition _postorder' lo : {hi:Elem.t & _bst lo hi} -> list Elem.t := ↑ (__postorder lo).
    Definition _postorder lo hi t := _postorder' lo (hi; t).
    Definition postorder' lo hi : {ord : bool & bst lo hi ord} -> list Elem.t := ↑ (_postorder lo hi).
    Definition postorder {lo hi ord} t := postorder' lo hi (ord; t).

    Definition search {min max ord} (tree : bst min max ord) (val' : Elem.t) : bool :=
      bst_rect
        (fun min max ord tree => bool)
        (fun ord_l ord_r min_l min_r max_l max_r val left IH_left right IH_right =>
           Elem.leb min_l val' &&
                    Elem.leb val' max_r &&
                    Elem.eqb val' val ||
           (Elem.leb val' max_l ==> IH_left) ||
           (Elem.leb min_r val' ==> IH_right))
        (fun val => Elem.eqb val' val)
        min max ord tree.

    (* --- Base search data --- *)
    Redirect "../out/search/baseEFF1equiv" Time Eval vm_compute in (let foo := search tree1 Elem.x in (hide foo) ).
    Redirect "../out/search/baseEFF10equiv" Time Eval vm_compute in (let foo := search tree10 Elem.x in (hide foo) ).
    Redirect "../out/search/baseEFF100equiv" Time Eval vm_compute in (let foo := search tree100 Elem.x in (hide foo) ).
    Redirect "../out/search/baseEFF1000equiv" Time Eval vm_compute in (let foo := search tree1000 Elem.x in (hide foo) ).
    Redirect "../out/search/baseEFF10000equiv" Time Eval vm_compute in (let foo := search tree10000 Elem.x in (hide foo) ).
    Redirect "../out/search/baseEFF100000equiv" Time Eval vm_compute in (let foo := search tree100000 Elem.x in (hide foo) ).

  End Ordered.

  Module Balanced.

    Inductive _avl : Elem.t -> Elem.t -> bool -> nat -> Type :=
    | _Branch (h_l h_r : nat) (ord_l ord_r : bool) (min_l min_r : Elem.t) (max_l max_r : Elem.t)
              (val : Elem.t)
              (left : _avl min_l max_l ord_l h_l) (right : _avl min_r max_r ord_r h_r)
      : _avl min_l max_r (Ordered.inv ord_l ord_r max_l val min_r) (S (Nat.max h_l h_r))
    | _Leaf (val : Elem.t) : _avl val val true O.

    Definition inv (bal_l bal_r : bool) (h_l h_r : nat) : bool :=
      bal_l && bal_r && (h_l - h_r <= 1) && (h_r - h_l <= 1).

    Inductive avl : Elem.t -> Elem.t -> bool -> nat -> bool -> Type :=
    | Branch (bal_l bal_r : bool) (h_l h_r : nat) (ord_l ord_r : bool) (min_l min_r : Elem.t) (max_l max_r : Elem.t)
             (val : Elem.t)
             (left : avl min_l max_l ord_l h_l bal_l) (right : avl min_r max_r ord_r h_r bal_r)
      : avl min_l max_r (Ordered.inv ord_l ord_r max_l val min_r) (S (Nat.max h_l h_r)) (inv bal_l bal_r h_l h_r)
    | Leaf (val : Elem.t) : avl val val true O true.

    Instance Equiv_avl
             (lo lo' : Elem.t) (E_lo : lo = lo') (hi hi' : Elem.t) (E_hi : hi = hi')
             (ord ord' : bool) (E_ord : ord = ord') (h h' : nat) (E_h : h = h')
             (bal bal' : bool) (E_bal : bal = bal') :
      avl lo hi ord h bal ≃ avl lo' hi' ord' h' bal'.
    Proof.
      apply can_eq in E_lo; try tc. apply can_eq in E_hi; try tc. apply can_eq in E_ord; try tc.
      apply can_eq in E_h; try tc. apply can_eq in E_bal; try tc.
      rewrite <- E_lo, <- E_hi, <- E_ord, <- E_h, <- E_bal. apply Equiv_id.
    Defined.

    Lemma Equiv_avl_id lo hi ord h bal :
      Equiv_avl lo lo eq_refl hi hi eq_refl ord ord eq_refl h h eq_refl bal bal eq_refl =
      Equiv_id (avl lo hi ord h bal).
    Proof. unfold Equiv_avl. repeat rewrite can_eq_refl. reflexivity. Defined.

    Instance UR_avl
             (lo lo' : Elem.t) (E_lo : lo = lo') (hi hi' : Elem.t) (E_hi : hi = hi')
             (ord ord' : bool) (E_ord : ord = ord') (h h' : nat) (E_h : h = h')
             (bal bal' : bool) (E_bal : bal = bal') :
      UR (avl lo hi ord h bal) (avl lo' hi' ord' h' bal').
    Proof. rewrite <- E_lo, <- E_hi, <- E_ord, <- E_h, <- E_bal. apply UR_gen. Defined.

    Instance Transportable_avl lo hi ord h : Transportable (avl lo hi ord h).
    Proof. econstructor. intros bal. rewrite Equiv_avl_id. reflexivity. Defined.

    Definition FP_avl : avl ≈ avl.
    Proof.
      cbn. intros lo lo' E_lo hi hi' E_hi ord ord' E_ord h h' E_h. split; try tc. cbn.
      intros bal bal' E_bal. apply can_eq in E_lo; try tc. apply can_eq in E_hi; try tc.
      apply can_eq in E_ord; try tc. apply can_eq in E_h; try tc. apply can_eq in E_bal; try tc.
      rewrite <- E_lo, <- E_hi, <- E_ord, <- E_h, <- E_bal. esplit; try apply Canonical_eq_gen.
      econstructor. cbn. intros t t'. unfold univalent_transport.
      rewrite Equiv_avl_id. cbn. eapply Equiv_id.
    Defined.

    (* --- Begin auto-generated equivalences from DEVOID --- *)

    (* EQUIV _orn_balance_index *)
    (* EQUIV _orn_balance *)
    (* EQUIV _orn_balance_inv *)
    (* EQUIV _orn_balance_section *)
    (* EQUIV _orn_balance_retraction *)
    (* EQUIV orn_balance_index *)
    (* EQUIV orn_balance *)
    (* EQUIV orn_balance_inv *)
    (* EQUIV orn_balance_section *)
    (* EQUIV orn_balance_retraction *)

    (* --- End auto-generated equivalences from DEVOID --- *)

    Instance IsEquiv__orn_balance (lo hi : Elem.t) (ord : bool) : IsEquiv (_orn_balance lo hi ord).
    Proof.
      eapply isequiv_adjointify with (g := _orn_balance_inv lo hi ord).
      - apply _orn_balance_section.
      - apply _orn_balance_retraction.
    Defined.

   Instance IsEquiv_orn_balance (lo hi : Elem.t) (ord : bool) (n : nat) : IsEquiv (orn_balance lo hi ord n).
    Proof.
      eapply isequiv_adjointify with (g := orn_balance_inv lo hi ord n).
      - apply orn_balance_section.
      - apply orn_balance_retraction.
    Defined.

    Instance Equiv__orn_balance (lo hi : Elem.t) (ord : bool) :
      Ordered.bst lo hi ord ≃ {n : nat & _avl lo hi ord n} :=
      BuildEquiv _ _ _ (IsEquiv__orn_balance lo hi ord).

    Instance Equiv_orn_balance (lo hi : Elem.t) (ord : bool) (n : nat) :
      _avl lo hi ord n ≃ {bal : bool & avl lo hi ord n bal} :=
      BuildEquiv _ _ _ (IsEquiv_orn_balance lo hi ord n).

    Instance UR__orn_balance (lo hi : Elem.t) (ord : bool) :
      Ordered.bst lo hi ord ⋈ {n : nat & _avl lo hi ord n}.
    Proof.
      cbn. unshelve esplit.
      - econstructor. intros t t'. exact (_orn_balance lo hi ord t = t').
      - econstructor. intros t t'. cbn.
        apply (@isequiv_ap _ _ (Equiv__orn_balance lo hi ord)).
      - apply Canonical_eq_gen.
      - apply Canonical_eq_gen.
    Defined.

    Instance UR_orn_balance (lo hi : Elem.t) (ord : bool) (n : nat) :
      _avl lo hi ord n ⋈ {bal : bool & avl lo hi ord n bal}.
    Proof.
      cbn. unshelve esplit.
      - econstructor. intros t t'. exact (orn_balance lo hi ord n t = t').
      - econstructor. intros t t'. cbn.
        apply (@isequiv_ap _ _ (Equiv_orn_balance lo hi ord n)).
      - apply Canonical_eq_gen.
      - apply Canonical_eq_gen.
    Defined.

    (* --- Begin automatically generated lifted inputs from DEVOID --- *)

    (*
     * We import these from DEVOID, that way we can measure the performance difference of
     * only the lifted functions, controlling for the performance of lifted inputs (which is
     * slower in EFF) without clouding the results.
     *)
    (* INPUT tree1''''-avl *)
    (* INPUT tree10''''-avl *)
    (* INPUT tree20''''-avl *)
    (* INPUT tree40''''-avl *)
    (* INPUT tree60''''-avl *)
    (* INPUT tree80''''-avl *)
    (* INPUT tree100''''-avl *)
    (* INPUT tree200''''-avl *)
    (* INPUT tree400''''-avl *)
    (* INPUT tree600''''-avl *)
    (* INPUT tree800''''-avl *)
    (* INPUT tree1000''''-avl *)
    (* INPUT tree2000''''-avl *)
    (* INPUT tree4000''''-avl *)
    (* INPUT tree6000''''-avl *)
    (* INPUT tree8000''''-avl *)
    (* INPUT tree10000''''-avl *)
    (* INPUT tree20000''''-avl *)
    (* INPUT tree40000''''-avl *)
    (* INPUT tree60000''''-avl *)
    (* INPUT tree80000''''-avl *)
    (* INPUT tree100000''''-avl *)

    (* INPUT tree1'''-avl *)
    (* INPUT tree10'''-avl *)
    (* INPUT tree100'''-avl *)
    (* INPUT tree1000'''-avl *)
    (* INPUT tree10000'''-avl *)
    (* INPUT tree100000'''-avl *)

    (* INPUT tree1''-avl *)
    (* INPUT tree10''-avl *)
    (* INPUT tree100''-avl *)
    (* INPUT tree1000''-avl *)
    (* INPUT tree10000''-avl *)
    (* INPUT tree100000''-avl *)

    (* INPUT tree1'-avl *)
    (* INPUT tree10'-avl *)
    (* INPUT tree100'-avl *)
    (* INPUT tree1000'-avl *)
    (* INPUT tree10000'-avl *)
    (* INPUT tree100000'-avl *)

    (* INPUT tree1-avl *)
    (* INPUT tree10-avl *)
    (* INPUT tree100-avl *)
    (* INPUT tree1000-avl *)
    (* INPUT tree10000-avl *)
    (* INPUT tree100000-avl *)

    (* --- End automatically generated lifted inputs from DEVOID --- *)

    Definition _preorder' lo hi ord : {n : nat & _avl lo hi ord n} -> list Elem.t :=
      ↑ (@Ordered.preorder lo hi ord).
    Definition _preorder lo hi ord n t := _preorder' lo hi ord (n; t).
    Definition preorder' {lo hi ord n} : {bal : bool & avl lo hi ord n bal} -> list Elem.t :=
      ↑ (_preorder lo hi ord n).
    Definition preorder {lo hi ord n bal} t := @preorder' lo hi ord n (bal; t).
    Redirect "../out/preorder/avlEFF1equiv" Time Eval vm_compute in (let foo := preorder' tree1 in (hide foo)).
    Redirect "../out/preorder/avlEFF10equiv" Time Eval vm_compute in (let foo := preorder' tree10 in (hide foo)).
    Redirect "../out/preorder/avlEFF100equiv" Time Eval vm_compute in (let foo := preorder' tree100 in (hide foo)).
    Redirect "../out/preorder/avlEFF1000equiv" Time Eval vm_compute in (let foo := preorder' tree1000 in (hide foo)).
    Redirect "../out/preorder/avlEFF10000equiv" Time Eval vm_compute in (let foo := preorder' tree10000 in (hide foo)).
    Redirect "../out/preorder/avlEFF100000equiv" Time Eval vm_compute in (let foo := preorder' tree100000 in (hide foo)).

   (* 105 LoC in normal form *)
    Definition _inorder' lo hi ord : {n : nat & _avl lo hi ord n} -> list Elem.t :=
      ↑ (@Ordered.inorder lo hi ord).
    Definition _inorder lo hi ord n t := _inorder' lo hi ord (n; t).
    Definition inorder' {lo hi ord n} : {bal : bool & avl lo hi ord n bal} -> list Elem.t :=
      ↑ (_inorder lo hi ord n).
    Definition inorder {lo hi ord n bal} t := @inorder' lo hi ord n (bal; t).
    Redirect "../out/inorder/avlEFF1equiv" Time Eval vm_compute in (let foo := inorder' tree1 in (hide foo)).
    Redirect "../out/inorder/avlEFF10equiv" Time Eval vm_compute in (let foo := inorder' tree10 in (hide foo)).
    Redirect "../out/inorder/avlEFF100equiv" Time Eval vm_compute in (let foo := inorder' tree100 in (hide foo)).
    Redirect "../out/inorder/avlEFF1000equiv" Time Eval vm_compute in (let foo := inorder' tree1000 in (hide foo)).
    Redirect "../out/inorder/avlEFF10000equiv" Time Eval vm_compute in (let foo := inorder' tree10000 in (hide foo)).
    Redirect "../out/inorder/avlEFF100000equiv" Time Eval vm_compute in (let foo := inorder' tree100000 in (hide foo)).

    (* 112 LoC in normal form *)
    Definition _postorder' lo hi ord : {n : nat & _avl lo hi ord n} -> list Elem.t :=
      ↑ (@Ordered.postorder lo hi ord).
    Definition _postorder lo hi ord n t := _postorder' lo hi ord (n; t).
    Definition postorder' {lo hi ord n} : {bal : bool & avl lo hi ord n bal} -> list Elem.t :=
      ↑ (_postorder lo hi ord n).
    Definition postorder {lo hi ord n bal} t := @postorder' lo hi ord n (bal; t).
    Redirect "../out/postorder/avlEFF1equiv" Time Eval vm_compute in (let foo := postorder' tree1 in (hide foo)).
    Redirect "../out/postorder/avlEFF10equiv" Time Eval vm_compute in (let foo := postorder' tree10 in (hide foo)).
    Redirect "../out/postorder/avlEFF100equiv" Time Eval vm_compute in (let foo := postorder' tree100 in (hide foo)).
    Redirect "../out/postorder/avlEFF1000equiv" Time Eval vm_compute in (let foo := postorder' tree1000 in (hide foo)).
    Redirect "../out/postorder/avlEFF10000equiv" Time Eval vm_compute in (let foo := postorder' tree10000 in (hide foo)).
    Redirect "../out/postorder/avlEFF100000equiv" Time Eval vm_compute in (let foo := postorder' tree100000 in (hide foo)).

    (* 105 LoC in normal form *)
    Definition _search' lo hi ord : {n : nat & _avl lo hi ord n} -> Elem.t -> bool :=
      ↑ (@Ordered.search lo hi ord).
    Definition _search lo hi ord n t x := _search' lo hi ord (n; t) x.
    Definition search' {lo hi ord n} : {bal : bool & avl lo hi ord n bal} -> Elem.t -> bool :=
      ↑ (_search lo hi ord n).
    Definition search {lo hi ord n bal} t x := @search' lo hi ord n (bal; t) x.
    Redirect "../out/search/avlEFF1equiv" Time Eval vm_compute in (let foo := search' tree1 Elem.x in (hide foo) ).
    Redirect "../out/search/avlEFF10equiv" Time Eval vm_compute in (let foo := search' tree10 Elem.x in (hide foo) ).
    Redirect "../out/search/avlEFF100equiv" Time Eval vm_compute in (let foo := search' tree100 Elem.x in (hide foo) ).
    Redirect "../out/search/avlEFF1000equiv" Time Eval vm_compute in (let foo := search' tree1000 Elem.x in (hide foo) ).
    Redirect "../out/search/avlEFF10000equiv" Time Eval vm_compute in (let foo := search' tree10000 Elem.x in (hide foo) ).
    Redirect "../out/search/avlEFF100000equiv" Time Eval vm_compute in (let foo := search' tree100000 Elem.x in (hide foo) ).

    (* --- Normalized term sizes --- *)
    Redirect "../out/normalized/preorder-avlEFFequiv" Eval compute in preorder'.
    Redirect "../out/normalized/postorder-avlEFFequiv" Eval compute in postorder'.
    Redirect "../out/normalized/inorder-avlEFFequiv" Eval compute in inorder'.
    Redirect "../out/normalized/search-avlEFFequiv" Eval compute in search'.

    (* Auto-generated definitions go here in together case study *)
    Module Comparison.
      (* DEF inorder-avl *)
      (* DEF postorder-avl *)
      (* DEF preorder-avl *)
      (* DEF search-avl *)

      (* TIME-AVL inorder-avl *)
      (* TIME-AVL postorder-avl *)
      (* TIME-AVL preorder-avl *)
      (* TIME-SEARCH search-avl *)

      (* NORMALIZE inorder-avl *)
      (* NORMALIZE postorder-avl *)
      (* NORMALIZE preorder-avl *)
      (* NORMALIZE search-avl *)
    End Comparison.

    (* --- Sanity tests --- *)
    Lemma test_inorder_avl : inorder' tree1000 = Comparison.inorder' _ _ _ _ tree1000. Proof. reflexivity. Qed.
    Lemma test_postorder_avl : postorder' tree1000 = Comparison.postorder' _ _ _ _ tree1000. Proof. reflexivity. Qed.
    Lemma test_preorder_avl : preorder' tree1000 = Comparison.preorder' _ _ _ _ tree1000. Proof. reflexivity. Qed.
    Lemma test_search_avl : search' tree1000 Elem.x = Comparison.search'  _ _ _ _ tree1000 Elem.x. Proof. reflexivity. Qed.

  End Balanced.

End CaseStudy.

Module NatComparable <: Comparable.
  Definition t := nat.
  Definition leb := Nat.leb.
  Definition refl (x : nat) : leb x x := Nat.leb_refl x.
  Lemma antisym (x y : nat) : leb x y -> leb y x -> x = y.
  Proof.
    revert y. induction x; destruct y; cbn; try reflexivity.
    - intros _ H. inversion H.
    - intros H. inversion H.
    - intros H_l H_r. specialize (IHx y H_l H_r). rewrite IHx. reflexivity.
  Defined.

  Definition eqb x y := leb x y && leb y x.
  Definition ltb x y := leb x y && negb (leb y x).
  Definition eqb_dec x y : if eqb x y then (x = y) else (x <> y).
  Proof.
    destruct (eqb x y) eqn:E; unfold eqb in E.
    - apply Bool.andb_true_iff in E as [E_l E_r]. apply antisym; [exact E_l|exact E_r].
    - apply Bool.andb_false_iff in E as [E|E]; intro H; rewrite H, refl in E; discriminate.
  Defined.

  Definition min x y := if leb x y then x else y.
  Definition max x y := if leb x y then y else x.

  Definition x := 0.
  Definition y := 3.
  Definition z := 7.
End NatComparable.

Module NatCaseStudy := CaseStudy NatComparable.
Import NatCaseStudy.

Fixpoint list_eqb {A} (eqb : A -> A -> bool) (xs ys : list A) : bool :=
  match xs, ys with
  | (x :: xs), (y :: ys) => eqb x y && list_eqb eqb xs ys
  | nil, nil => true
  | _, _ => false
  end.

(** You can use commands like the following to validate the equivalent behavior of liftings and transports: **)
(* Eval vm_compute in (Bool.eqb (Balanced.search' Balanced.tree100 7) (Balanced.search'' Balanced.tree100.2 3)). *)


(** * The precategory of types

This file defines the precategory of types in a fixed universe ([type_precat])
and shows that it has some limits and exponentials.

Author: Langston Barrett (@siddharthist), Feb 2018
*)

(** ** Contents:

- The precategory of types (of a fixed universe) ([type_precat])
- Hom functors
  - As a bifunctor ([hom_functor])
  - Covariant ([cov_hom_functor])
  - Contravariant ([contra_hom_functor])
*)

Require Import UniMath.Foundations.PartA.
Require Import UniMath.Foundations.UnivalenceAxiom.
Require Import UniMath.MoreFoundations.PartA.

(* Basic category theory *)
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.

(* Hom functors *)
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.

Local Open Scope cat.
Local Open Scope functions.

(** ** The precategory of types of a fixed universe *)

Definition type_precat : precategory.
Proof.
  use make_precategory.
  - use tpair; use tpair.
    + exact UU.
    + exact (λ X Y, X -> Y).
    + exact (λ X, idfun X).
    + exact (λ X Y Z f g, funcomp f g).
  - repeat split; intros; apply idpath.
Defined.

(** ** Hom functors *)

Section HomFunctors.

  Context {C : precategory}.

  (** ** As a bifunctor [hom_functor] *)

  Definition hom_functor_data :
    functor_data (precategory_binproduct (opp_precat C) C) type_precat.
  Proof.
    use make_functor_data.
    - intros pair; exact (C ⟦ pr1 pair, pr2 pair ⟧).
    - intros x y fg h.
      refine (_ · h · _).
      + exact (pr1 fg).
      + exact (pr2 fg).
  Defined.

  Lemma is_functor_hom_functor_type : is_functor hom_functor_data.
  Proof.
    use make_dirprod.
    - intro; cbn.
      apply funextsec; intro.
      refine (id_right _ @ _).
      apply id_left.
    - intros ? ? ? ? ?.
      apply funextsec; intro; cbn.
      abstract (do 3 rewrite assoc; reflexivity).
  Defined.

  Definition hom_functor : functor (precategory_binproduct (opp_precat C) C) type_precat :=
    make_functor _ is_functor_hom_functor_type.

  Context (c : C).

  (** ** Covariant [cov_hom_functor] *)

  Definition cov_hom_functor : functor C type_precat :=
    functor_fix_fst_arg (opp_precat C) _ _ hom_functor c.

  (** ** Contravariant [contra_hom_functor] *)

  Definition contra_hom_functor : functor (opp_precat C) type_precat :=
    functor_fix_snd_arg (opp_precat C) _ _ hom_functor c.

End HomFunctors.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

Require Import Ensembles.

Section Ensembles_finis.
  Variable U : Type.

  Inductive Finite : Ensemble U -> Prop :=
    | Empty_is_finite : Finite (Empty_set U)
    | Union_is_finite :
      forall A:Ensemble U,
        Finite A -> forall x:U, ~ In U A x -> Finite (Add U A x).

  Inductive cardinal : Ensemble U -> nat -> Prop :=
    | card_empty : cardinal (Empty_set U) 0
    | card_add :
      forall (A:Ensemble U) (n:nat),
        cardinal A n -> forall x:U, ~ In U A x -> cardinal (Add U A x) (S n).

End Ensembles_finis.

Hint Resolve Empty_is_finite Union_is_finite: sets v62.
Hint Resolve card_empty card_add: sets v62.

Require Import Constructive_sets.

Section Ensembles_finis_facts.
  Variable U : Type.

  Lemma cardinal_invert :
    forall (X:Ensemble U) (p:nat),
      cardinal U X p ->
      match p with
	| O => X = Empty_set U
	| S n =>
          exists A : _,
            (exists x : _, X = Add U A x /\ ~ In U A x /\ cardinal U A n)
      end.
  Proof.
    induction 1; simpl in |- *; auto.
    exists A; exists x; auto.
  Qed.

  Lemma cardinal_elim :
    forall (X:Ensemble U) (p:nat),
      cardinal U X p ->
      match p with
	| O => X = Empty_set U
	| S n => Inhabited U X
      end.
  Proof.
    intros X p C; elim C; simpl in |- *; trivial with sets.
  Qed.

End Ensembles_finis_facts.


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