Require Import HoTT.
Require Import Auxiliary.General.
Require Import Auxiliary.Family.
Require Import Auxiliary.Coproduct.
Require Import Syntax.ScopeSystem.
Require Import Syntax.SyntacticClass.
Require Import Syntax.Arity.
Require Import Syntax.Signature.
Require Import Syntax.Expression.

Section RawSubstitution.

  Context {σ : scope_system} {Σ : signature σ}.

  (* A raw substitution is the input data for a simultaneous substitution:
  for each variable of one scope, a raw term over another scope.

  NOTE: naming-wise, it would be nicer if this was called [Context.map] or
  similar.  However, in terms of depedency requirements, it fits much more
  naturally here: this and its lemmas do not depend on anything about raw
  contexts, whereas most constructions on them depend on this file. *)
  Definition raw_substitution (γ δ : σ)
    := δ -> raw_term Σ γ.

  (* Not required now, but required so that later things that coerce to
     raw substitutions can be used as functions. *)
  Identity Coercion map_of_raw_substitution : raw_substitution >-> Funclass.

  (* A substitution from [γ] to [γ'] may be extended to one from [γ + δ] to
  [γ' + δ], by variable-renaming.

  This is needed for going under binders during substitution. *)
  Local Definition extend (γ γ' δ : σ)
    : raw_substitution γ' γ -> raw_substitution (scope_sum γ' δ) (scope_sum γ δ).
  Proof.
    intros f.
    simple refine (coproduct_rect (scope_is_sum) _ _ _); cbn.
    - intros i.
      refine (rename _ (f i)).
      apply (coproduct_inj1 (scope_is_sum)).
    - intros i.
      apply raw_variable.
      apply (coproduct_inj2 (scope_is_sum)), i.
  Defined.

  (* Apply a raw substitution to a raw expression. *)
  Fixpoint substitute
      {γ δ : σ} (f : raw_substitution δ γ)
      {cl : syntactic_class}
      (e : raw_expression Σ cl γ)
    : raw_expression Σ cl δ.
  Proof.
    destruct e as [ γ i | γ S args ].
    - exact (f i).
    - refine (raw_symbol S _). intros i.
      refine (substitute _ _ _ _ (args i)).
      apply extend. exact f.
  Defined.

  (** Interaction of substitution with transport *)

  (* TODO: consistentise naming of this and the following *)
  Definition transport_substitute {γ γ' : σ} (g : _)
      {cl cl' : syntactic_class} (p : cl = cl') (e : raw_expression Σ cl γ)
    : transport (fun cl => raw_expression Σ cl γ') p (substitute g e)
      = substitute g (transport (fun cl => raw_expression Σ cl γ) p e).
  Proof.
    destruct p. apply idpath.
  Defined.

  Lemma substitute_transport_scope
      {γ γ'} (e_γ : γ = γ') {δ}
      (f : raw_substitution δ γ')
      {cl} (e : raw_expression Σ cl γ)
    : substitute f (transport (raw_expression _ _) e_γ e)
      = substitute (transport (raw_substitution _) e_γ^ f) e.
  Proof.
    destruct e_γ; apply idpath.
  Defined.

End RawSubstitution.

Arguments raw_substitution [_] _ _ _.

(* Here we show that raw substitutions form a category (modulo truncation assumptions).

  Note: we assume functional extensionality throughout.  That shouldn’t be essentially necessary — it should be possible to show that e.g. [Substitution.rename] respects “recursive extensional equality” of terms, and so on, and hence to show that raw substitutions form a category modulo this equality — but using funext makes life a lot simpler. *)

Section Raw_Context_Category_Structure.
(* Identity and composition of raw substitutions. *)

  Context {σ : scope_system}.
  Context {Σ : signature σ}.

  Definition id_raw_context (γ : σ) : raw_substitution Σ γ γ.
  Proof.
    exact (@raw_variable _ _ _).
  Defined.

  Definition comp_raw_context {γ γ' γ'': σ}
      (f : raw_substitution Σ γ' γ)
      (f' : raw_substitution Σ γ'' γ')
    : raw_substitution Σ γ'' γ
  := fun x => substitute f' (f x).

End Raw_Context_Category_Structure.

(* Just as the definition of substitution resembles the “lift” operation of a Kleisli-style monad, similarly, its “functoriality” is naturally proved in a form similar to the laws of a Kleisli-style monad.  That is, in terms of
  [ return := raw_variable : γ -> Raw_Syntax γ ]
  [ lift := substitute : (γ' -> Raw_Syntax γ) -> (Raw_Syntax γ' -> Raw_Syntax γ) ]
  we show roughly:
  [ id_left_substitute : forall (f : γ' -> Raw_Syntax γ) , (fun a => lift f (return a)) = f ]
  [ id_right_substitute : lift return = idfun : Raw_Syntax γ -> Raw_Syntax γ]
  [ associativity : (lift g) o (lift f) = lift ((lift g) o f) ]

  These then suffice to show that raw substitutions (roughly, the Kleisli category of this not-exactly-monad) form a category (modulo h-levels).

  TODO: see if this “looks like a monad” can be made more precise: does our approach fit into e.g. relative or indexed monads?
*)
Section Substitute_Laws.

  Context `{H_Funext : Funext}.
  Context {σ : scope_system}.
  Context {Σ : signature σ}.

  Definition id_left_substitute
      {γ γ' : σ} (f : raw_substitution Σ γ' γ) (x : _)
    : substitute f (raw_variable x) = f x.
  Proof.
    apply idpath.
  Defined.

  Lemma substitute_idmap {γ} {cl} (e : raw_expression Σ cl γ)
    : substitute (id_raw_context γ) e = e.
  Proof.
    induction e as [ γ i | γ s es IH_es ].
    - apply idpath.
    - cbn. apply ap.
      apply path_forall; intros i.
      eapply concat.
      2: { apply IH_es. }
      apply (ap_2back substitute), path_forall.
      refine (coproduct_rect scope_is_sum _ _ _).
      + intros j. refine (coproduct_comp_inj1 _).
      + intros j. refine (coproduct_comp_inj2 _).
  (* Note: original proof literally identical to that of [rename_idmap]! *)
  Defined.

  (* We provide this under two names: [substitute_idmap] follows general
     naming conventions for recognising it when it arises in derivations;
     [id_right_substitute] fits the monad-law structure, for when it’s being
     used in those terms. *)
  Definition id_right_substitute
      {γ : σ} {cl : syntactic_class} (e : raw_expression Σ cl γ)
    : substitute (id_raw_context γ) e = e
  := substitute_idmap e.

  Lemma substitute_raw_variable
    {γ γ' : σ} (r : γ -> γ')
    {cl} (e : raw_expression Σ cl γ)
    : substitute (fun i => raw_variable (r i)) e = rename r e.
  Proof.
    revert γ' r; induction e as [ γ i | γ s es IH_es ]; intros γ' r.
    - apply idpath.
    - cbn. apply ap.
      apply path_forall; intros i.
      eapply concat.
      2: { apply IH_es. }
      apply (ap_2back substitute), path_forall.
      refine (coproduct_rect scope_is_sum _ _ _); intro; unfold extend.
      + repeat rewrite coproduct_comp_inj1; apply idpath.
      + repeat rewrite coproduct_comp_inj2; apply idpath.
  Defined.

  Fixpoint rename_substitute {γ γ' γ'' : σ}
      (f : raw_substitution Σ γ' γ) (g : γ' -> γ'')
      {cl} (e : raw_expression Σ cl γ)
    : rename g (substitute f e)
      = substitute ((rename g) o f) e.
  Proof.
    destruct e as [ γ i | γ S args ].
    { apply idpath. }
    cbn. apply ap. apply path_forall; intros i.
    eapply concat. { apply rename_substitute. }
    apply (ap_2back substitute), path_forall.
    simple refine (coproduct_rect (scope_is_sum) _ _ _); cbn; intros x.
    - eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
      refine (_ @ _^). { apply rename_rename. }
      eapply concat. { refine (coproduct_comp_inj1 _). }
      refine (_ @ _). { apply rename_rename. }
      apply (ap_2back rename), path_forall; intros y.
      refine _^. refine (coproduct_comp_inj1 _).
    - eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
      cbn. refine (_^).
      eapply concat. { refine (coproduct_comp_inj2 _). }
      apply ap. refine _^. refine (coproduct_comp_inj2 _).
  Defined.

  Fixpoint substitute_rename
      {γ γ' γ'' : σ} (f : γ -> γ') (g : raw_substitution Σ γ'' γ')
      {cl} (e : raw_expression Σ cl γ)
    : substitute g (rename f e)
    = substitute (g o f) e.
  Proof.
    destruct e as [ γ i | γ S args ].
    { apply idpath. }
    cbn. apply ap. apply path_forall; intros i.
    eapply concat. { apply substitute_rename. }
    apply (ap_2back substitute), path_arrow.
    simple refine (coproduct_rect (scope_is_sum) _ _ _); cbn; intros x.
    - eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
      eapply concat. { refine (coproduct_comp_inj1 _). }
      refine _^. refine (coproduct_comp_inj1 _).
    - eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
      eapply concat. { refine (coproduct_comp_inj2 _). }
      refine _^. refine (coproduct_comp_inj2 _).
  Defined.

  Fixpoint assoc_substitute {γ γ' γ'': σ}
      (f : raw_substitution Σ γ' γ)
      (f' : raw_substitution Σ γ'' γ')
      {cl : syntactic_class} (e : raw_expression Σ cl γ)
    : substitute f' (substitute f e)
    = substitute (fun i => substitute f' (f i)) e.
  Proof.
    destruct e as [ γ i | γ S args ].
    { apply idpath. }
    cbn. apply ap. apply path_forall; intros i.
    eapply concat. { apply assoc_substitute. }
    apply (ap_2back substitute), path_arrow.
    simple refine (coproduct_rect (scope_is_sum) _ _ _); cbn; intros x.
    - eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
      refine (_ @ _^).
      2 : { refine (coproduct_comp_inj1 _). }
      + eapply concat. { apply substitute_rename. }
        eapply concat.
        2: { eapply inverse, rename_substitute. }
        * apply (ap_2back substitute), path_arrow. intros ?.
          refine (coproduct_comp_inj1 _).
    - eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
      refine (_ @ _^).
      2: { refine (coproduct_comp_inj2 _). }
      + cbn. refine (coproduct_comp_inj2 _).
  Defined.

  (* Alias of [assoc_substitute], to fit general naming conventions for
     equational lemmas *)
  Definition substitute_substitute {γ γ' γ'': σ}
      (f : raw_substitution Σ γ' γ)
      (f' : raw_substitution Σ γ'' γ')
      {cl : syntactic_class} (e : raw_expression Σ cl γ)
    : substitute f' (substitute f e)
    = substitute (fun i => substitute f' (f i)) e
  := assoc_substitute f f' e.

End Substitute_Laws.

(* Finally, the category laws for raw substitutions. *)
Section Raw_Context_Category.

  Context `{H_Funext : Funext}.
  Context {σ : scope_system}.
  Context {Σ : signature σ}.

  Lemma id_left_raw_context {γ} (f : raw_substitution Σ γ γ)
    : comp_raw_context (id_raw_context _) f = f.
  Proof.
    apply idpath.
    (* To understand this, uncomment the following: *)
    (* [unfold comp_raw_context, id_raw_context.] *)
  Defined.

  Lemma id_right_raw_context {γ} (f : raw_substitution Σ γ γ)
    : comp_raw_context f (id_raw_context _) = f.
  Proof.
    apply path_forall; intros x; cbn.
    apply id_right_substitute.
  Defined.

  Lemma assoc_raw_context {γ0 γ1 γ2 γ3: σ}
      (f0 : raw_substitution Σ γ0 γ1)
      (f1 : raw_substitution Σ γ1 γ2)
      (f2 : raw_substitution Σ γ2 γ3)
    : comp_raw_context f2 (comp_raw_context f1 f0)
    = comp_raw_context (comp_raw_context f2 f1) f0.
  Proof.
    apply path_forall; intros x; unfold comp_raw_context; cbn.
    refine _^. apply assoc_substitute.
  Defined.

End Raw_Context_Category.

(* Here we give naturality of substitution with respect to signature maps *)
Section Naturality.

  Context `{H_Funext : Funext}.
  Context {σ : scope_system}.

  Definition raw_substitution_fmap
      {Σ Σ' : signature σ} (f : Signature.map Σ Σ')
      {γ γ'} (g : raw_substitution Σ γ' γ)
    : raw_substitution Σ' γ' γ
  := fun i => (Expression.fmap f (g i)).

  Local Definition fmap_extend
      {Σ Σ' : signature σ} (f : Signature.map Σ Σ')
      {γ γ' δ : σ} (g : raw_substitution Σ γ' γ)
    : raw_substitution_fmap f (extend _ _ δ g)
    = extend _ _ δ (raw_substitution_fmap f g).
  Proof.
    apply path_forall.
    refine (coproduct_rect scope_is_sum _ _ _).
    - intros i. unfold raw_substitution_fmap.
      eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
      eapply concat. { apply Expression.fmap_rename. }
      apply inverse. refine (coproduct_comp_inj1 _).
    - intros i. unfold raw_substitution_fmap.
      eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
      apply inverse. refine (coproduct_comp_inj2 _).
  Defined.

  Fixpoint fmap_substitute
      {Σ Σ' : signature σ} (f : Signature.map Σ Σ')
      {γ γ'} (g : raw_substitution Σ γ' γ)
      {cl} (e : raw_expression Σ cl γ)
    : Expression.fmap f (substitute g e)
    = substitute (raw_substitution_fmap f g) (Expression.fmap f e).
  Proof.
    destruct e as [ γ i | γ S args ].
    - apply idpath.
    - simpl.
      eapply concat.
      { apply ap, ap, ap. apply path_forall; intros i. apply fmap_substitute. }
      eapply concat. 2: { apply transport_substitute. }
      + apply ap. cbn. apply ap.
        set (ΣfS := Σ' (f S)). change (symbol_arity (f S)) with (snd ΣfS).
        set (p := Family.map_commutes f S : ΣfS = _). clearbody p ΣfS.
        revert p; apply inverse_sufficient; intros q.
        destruct q. cbn.
        apply path_forall; intros i.
        apply (ap_2back substitute).
        apply fmap_extend.
  Defined.

End Naturality.


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

(** Extraction of [nat] into Ocaml's [big_int] *)

Require Import Arith Even Div2 EqNat Euclid.
Require Import ExtrOcamlBasic.

(** NB: The extracted code should be linked with [nums.cm(x)a]
    from ocaml's stdlib and with the wrapper [big.ml] that
    simlifies the use of [Big_int] (it could be found in the sources
    of Coq). *)

(** Disclaimer: trying to obtain efficient certified programs
    by extracting [nat] into [big_int] isn't necessarily a good idea.
    See comments in [ExtrOcamlNatInt.v].
*)

(** Mapping of [nat] into [big_int]. The last string corresponds to
    a [nat_case], see documentation of [Extract Inductive]. *)

Extract Inductive nat => "Big.big_int" [ "Big.zero" "Big.succ" ]
 "Big.nat_case".

(** Efficient (but uncertified) versions for usual [nat] functions *)

Extract Constant plus => "Big.add".
Extract Constant mult => "Big.mult".
Extract Constant pred => "fun n -> Big.max Big.zero (Big.pred n)".
Extract Constant minus => "fun n m -> Big.max Big.zero (Big.sub n m)".
Extract Constant max => "Big.max".
Extract Constant min => "Big.min".
Extract Constant nat_beq => "Big.eq".
Extract Constant EqNat.beq_nat => "Big.eq".
Extract Constant EqNat.eq_nat_decide => "Big.eq".

Extract Constant Peano_dec.eq_nat_dec => "Big.eq".

Extract Constant Compare_dec.nat_compare =>
 "Big.compare_case Eq Lt Gt".

Extract Constant Compare_dec.leb => "Big.le".
Extract Constant Compare_dec.le_lt_dec => "Big.le".
Extract Constant Compare_dec.lt_eq_lt_dec =>
 "Big.compare_case (Some false) (Some true) None".

Extract Constant Even.even_odd_dec =>
 "fun n -> Big.sign (Big.mod n Big.two) = 0".
Extract Constant Div2.div2 => "fun n -> Big.div n Big.two".

Extract Inductive Euclid.diveucl => "(Big.big_int * Big.big_int)" [""].
Extract Constant Euclid.eucl_dev => "fun n m -> Big.quomod m n".
Extract Constant Euclid.quotient => "fun n m -> Big.div m n".
Extract Constant Euclid.modulo => "fun n m -> Big.modulo m n".

(*
Require Import Euclid.
Definition test n m (H:m>0) :=
 let (q,r,_,_) := eucl_dev m H n in
 nat_compare n (q*m+r).

Extraction "/tmp/test.ml" test fact pred minus max min Div2.div2.
*)


(** Copyright (c) 2018 by Swirlds, Inc.
   Implemented by Karl Crary.
*)

Require Import Bool.
Require Import Nat.
Require Import Omega.
Require Import List.

Require Import Tact.
Require Import Decide.
Require Import Relation.
Require Import HashgraphFacts.
Require Import Round.
Require Import Progress.
Require Import Decision.
Require Import Consensus.
Require Import Famous.
Require Import Fairness.

Definition ufwitness s W i x :=
  fwitness s W i x
  /\ forall y,
       fwitness s W i y
       -> creator x = creator y
       -> Is_true (textorder x y).

Lemma extends_fwitness :
  forall s W W' i x,
    extends W W'
    -> fwitness s W i x
    -> fwitness s W' i x.
Proof.
intros s W W' i x Hextends Hw.
destruct Hw as (Hwit & Hfamous).
split; auto.
eapply extends_famous; eauto.
Qed.

(** In a few places we need to know that the set of uniue famous witnesses is Kuratowski
   finite (in order to decide received_by).  This holds in all but pathological cases.
   For, example, it holds for any finite world (which includes all the hashgraphs that
   peers actually manipulate), and it holds for the global world.
*)

Lemma fwitness_ufwitness_finite :
  forall s W i,
    finite (fwitness s W i) -> finite (ufwitness s W i).
Proof.
intros s W i Hfin.
apply (finite_subset' _ _ (fwitness s W i)); auto.
  {
  exact eq_event_decide.
  }

  {
  intros x H.
  destruct H; auto.
  }
intros x Hx.
cut (decidable (forall y, fwitness s W i y -> creator x = creator y -> Is_true (textorder x y))).
  {
  intros [Hyes | Hno].
    {
    left.
    split; auto.
    }

    {
    right.
    contradict Hno.
    destruct Hno; auto.
    }
  }
apply dec_forall_imp_finite; auto.
intros y Hy.
apply dec_imp.
  {
  apply eq_peer_decide.
  }

  {
  apply textorder_decide.
  }
Qed.

Lemma fwitness_finite_finite :
  forall s W,
    finite (member W)
    -> forall i, finite (fwitness s W i).
Proof.
intros s W Hfinite i.
apply (finite_subset _ _ (member W)); auto.
  {
  intros x H.
  destruct H.
  eapply famous_member; eauto.
  }

  {
  intro x.
  apply dec_and.
    {
    apply rwitness_decide.
    }

    {
    apply famous_decide_finite; auto.
    }
  }
Qed.

Lemma ufwitness_finite_finite :
  forall s W,
    finite (member W)
    -> forall i, finite (ufwitness s W i).
Proof.
intros s W Hfin i.
apply fwitness_ufwitness_finite.
apply fwitness_finite_finite; auto.
Qed.

Lemma fwitness_finite_global :
  forall s i, finite (fwitness s (global s) i).
Proof.
intros s i.
so (famous_witness_exists s i) as (x & Hx).
eapply fwitness_finite_global_if; eauto.
Qed.

Lemma ufwitness_finite_global :
  forall s i, finite (ufwitness s (global s) i).
Proof.
intros s i.
apply fwitness_ufwitness_finite.
apply fwitness_finite_global; auto.
Qed.

Definition nonempty W := exists x, member W x.

Lemma nonterminating_nonempty :
  forall W, nonterminating W -> nonempty W.
Proof.
intros W Hnt.
so (Hnt 0) as (_ & x & _ & _ & Wx).
exists x; auto.
Qed.

Definition received_by (s : sample) (W : world) (i : nat) (x : event) :=
  (forall j w, j <= i -> member W w -> rwitness j w -> exists y b, member W y /\ decision s w y b)
  /\
  (forall w, ufwitness s W i w -> x @= w).

Definition received (s : sample) (W : world) (i : nat) (x : event) :=
  received_by s W i x
  /\ forall j, j < i -> ~ received_by s W j x.

Lemma received_by_inhabited :
  forall s W i x,
    nonempty W
    -> received_by s W i x
    -> exists y, member W y /\ round i y.
Proof.
intros s W i x (y & Wy) Hrb.
destruct Hrb as (Hsettled & _).
so (round_defined y) as (j & Hroundy).
so (le_dec j i) as [Hle | Hnle].
2:{
  assert (i <= j) as Hij by omega.
  so (ancestor_witness _#3 Hij Hroundy) as (z & Hzy & (Hroundz & _)).
  exists z.
  split; auto.
  eapply world_closed; eauto.
  }
revert Hsettled.
induct Hle.

(** eq *)
{
intros _.
exists y.
auto.
}

(** S *)
{
intros i Hle IH Hsettled.
exploit IH as H.
  {
  intros j' w Hle' Ww Hwitw.
  apply (Hsettled j'); auto.
  }
destruct H as (z & Wz & Hroundz).
so (ancestor_witness _#3 (le_refl _) Hroundz) as (u & Huz & Hwitu).
so (Hsettled i u (Nat.le_succ_diag_r _) (world_closed _#3 Huz Wz) Hwitu) as (v & b & Wv & Hdecision).
destruct Hdecision as (i' & k & _ & _ & Hwitu' & Hwitv & Hlt & _).
so (rwitness_fun _#3 Hwitu Hwitu'); subst i'.
assert (S i <= k) as Hle' by omega.
so (ancestor_witness _#3 Hle' (Hwitv andel)) as (w & Hwv & (Hroundw & _)).
exists w.
split; auto.
eapply world_closed; eauto.
}
Qed.

Lemma received_fun :
  forall s W i i' x,
    received s W i x
    -> received s W i' x
    -> i = i'.
Proof.
intros s W i j x Hrec Hrec'.
destruct Hrec as (Hrb & Hfirst).
destruct Hrec' as (Hrb' & Hfirst').
so (lt_eq_lt_dec i j) as [[Hij | Heq] | Hji]; auto; exfalso.
  {
  eapply Hfirst'; eauto.
  }

  {
  eapply Hfirst; eauto.
  }
Qed.

Lemma received_by_global :
  forall s i x,
    (forall w,
       ufwitness s (global s) i w -> x @= w)
    -> received_by s (global s) i x.
Proof.
intros s i x Hrb.
split; auto.
intros j w Hji Hsw Hwitw.
so (fame_consensus _ _ Hsw (Hwitw ander)) as (y & b & Hsy & Hdecision).
eauto.
Qed.

Lemma received_by_decide :
  forall s i x,
    decidable (received_by s (global s) i x).
Proof.
intros s i x.
apply (dec_equiv
         (forall w, ufwitness s (global s) i w -> x @= w)).
  {
  split.
    {
    intro H.
    apply received_by_global; auto.
    }

    {
    intros H w Hw.
    apply H; auto.
    }
  }
apply dec_forall_imp_finite.
  {
  apply ufwitness_finite_global.
  }
intros w _.
apply ancestor_decide.
Qed.

Lemma received_by_exists :
  forall s x,
    member (global s) x
    -> honest (creator x)
    -> exists i,
         received_by s (global s) i x.
Proof.
intros s x Hsx Hhonest.
so (events_are_received s x Hsx Hhonest) as (i & Hall).
exists i.
apply received_by_global.
intros w Hw.
destruct Hw as (Hw & _).
destruct Hw as (Hwit & Hfamous).
apply Hall; auto.
eapply famous_member; eauto.
Qed.

Lemma received_defined :
  forall s x,
    member (global s) x
    -> honest (creator x)
    -> exists i,
         received s (global s) i x.
Proof.
intros s x Hsx Hhonest.
cut (forall i, (exists j, received s (global s) j x) \/ (forall j, j <= i -> ~ received_by s (global s) j x)).
  {
  intro Hprop.
  so (received_by_exists _ _ Hsx Hhonest) as (i & Hrb).
  so (Hprop i) as [? | Hall]; auto.
  so (Hall i (le_refl i)).
  contradiction.
  }
intro i.
induct i.

(** 0 *)
{
so (received_by_decide s 0 x) as [Hrb | Hnrb].
  {
  left.
  exists 0; split; auto.
  intros j H.
  omega.
  }

  {
  right.
  intros j H.
  assert (j = 0) by omega.
  subst j.
  exact Hnrb.
  }
}

(** S *)
{
intros i IH.
destruct IH as [| Hall]; [left; auto |].
so (received_by_decide s (S i) x) as [Hrb | Hnrb].
  {
  left.
  exists (S i).
  split; auto.
  intros j H.
  apply Hall.
  omega.
  }

  {
  right.
  intros j Hle.
  so (eq_nat_dec j (S i)) as [Heq | Hneq].
    {
    subst j.
    auto.
    }

    {
    apply Hall.
    omega.
    }
  }
}
Qed.

Lemma received_by_consistent :
  forall s W W' i x,
    extends W W'
    -> (forall x, decidable (member W x))
    -> nonempty W
    -> received_by s W i x
    -> received_by s W' i x.
Proof.
intros s W W' i x Hextends Hdec Hne Hrb.
so (received_by_inhabited _#4 Hne Hrb) as Hinh.
so Hrb as (Hsettled & Hall).
split.
  {
  intros j w Hji W'w Hwitw.
  so (Hdec w) as [Ww | Wnw].
    {
    so (Hsettled _ _ Hji Ww Hwitw) as (y & b & Wy & Hdecision).
    exists y, b.
    split; auto.
    }

    {
    destruct Hinh as (v & Wv & Hroundv).
    so (ancestor_witness _#3 Hji Hroundv) as (u & Huv & Hwitu).
    so (world_closed _#3 Huv Wv) as Wu.
    so (Hsettled _ _ Hji Wu Hwitu) as (y & b & Wy & Hdecision).
    exists y, false.
    split; auto.
    apply (no_late_fame s j u w y b); auto.
    contradict Wnw.
    eapply world_closed; eauto.
    }
  }

  {
  intros w Hw.
  destruct Hw as ((Hwitw & Hfamous) & Hmin).
  so (Hdec w) as [Ww | Wnw].
    {
    apply Hall; auto.
    so (Hsettled _ _ (le_refl _) Ww Hwitw) as (y & b & Wy & Hdecision).
    split; [split |]; auto.
      {
      exists y.
      split; auto.
      destruct b; auto.
      exfalso.
      destruct Hfamous as (z & W'z & Hdecision').
      so (decision_consistent _#7 (Hextends _ Wy) W'z Hdecision Hdecision') as H.
      discriminate H.
      }

      {
      intros z Hz Heqcr.
      apply Hmin; auto.
      eapply extends_fwitness; eauto.
      }
    }

    {
    exfalso.
    destruct Hinh as (v & Wv & Hroundv).
    so (ancestor_witness _#3 (le_refl _) Hroundv) as (u & Huv & Hwitu).
    so (world_closed _#3 Huv Wv) as Wu.
    so (Hsettled _ _ (le_refl _) Wu Hwitu) as (y & b & Wy & Hdecisionu).
    eassert _ as Hdecision; [refine (no_late_fame _#6 Hwitu Hwitw Hdecisionu _) |].
      {
      contradict Wnw.
      eapply world_closed; eauto.
      }
    destruct Hfamous as (z & W'z & Hdecision').
    so (decision_consistent _#7 (Hextends _ Wy) W'z Hdecision Hdecision') as H.
    discriminate H.
    }
  }
Qed.

Lemma extends_ufwitness :
    forall s W W' i x,
    extends W W'
    -> (forall y, decidable (member W y))
    -> (forall w, member W w -> rwitness i w -> exists y b, member W y /\ decision s w y b)
    -> ufwitness s W i x
    -> ufwitness s W' i x.
Proof.
intros s W W' i x Hextends HdecW Hsettled Hw.
destruct Hw as (Hw & Hfirst).
split; eauto using extends_fwitness.
intros y Hy Heqcr.
apply Hfirst; auto.
destruct Hy as (Hwity & Hfamous).
split; auto.
assert (forall u, member W u -> decision s y u false -> False) as Hnunfamous.
  {
  intros u Wu Hdecision.
  destruct Hfamous as (v & Wv & Hdecision').
  so (decision_consistent _#7 (Hextends _ Wu) Wv Hdecision Hdecision') as H.
  discriminate H.
  }
so (HdecW y) as [Wy | Wny].
  {
  so (Hsettled _ Wy Hwity) as (u & b & Wu & Hdecision).
  exists u.
  split; auto.
  destruct b; auto.
  exfalso.
  eapply Hnunfamous; eauto.
  }

  {
  exfalso.
  destruct Hw as (Hwitx & (u & Wu & Hdecision)).
  so (no_late_fame_world _#7 Wu Wny Hwitx Hwity Hdecision) as Hdecision'.
  eapply Hnunfamous; eauto.
  }
Qed.

Lemma received_consistent :
  forall s W W' i x,
    extends W W'
    -> (forall x, decidable (member W x))
    -> nonempty W
    -> received s W i x
    -> received s W' i x.
Proof.
intros s W W' i x Hextends Hdec Hne Hrec.
destruct Hrec as (Hrb & Hfirst).
split.
  {
  eapply received_by_consistent; eauto.
  }
intros j Hji Hrbj.
refine (Hfirst _ Hji _).
destruct Hrb as (Hsettled & Hall).
split.
  {
  intros k w Hkj Ww Hwitw.
  eapply (Hsettled k); eauto.
  omega.
  }

  {
  intros w Hw.
  apply (Hrbj ander); auto.
  eapply extends_ufwitness; eauto.
  intros v Wv Hwitv.
  apply (Hsettled j); auto.
  omega.
  }
Qed.

Lemma received_cumulative :
  forall s W W' x y i j,
    extends W W'
    -> (forall x, decidable (member W x))
    -> nonempty W
    -> received s W' i x
    -> received s W j y
    -> i <= j
    -> received s W i x.
Proof.
intros s W W' x y i j Hextends Hdec Hne Hrecx Hrecy Hij.
destruct Hrecx as (Hrbx & Hfirstx).
destruct Hrecy as (Hrby & Hfirsty).
split.
  {
  split.
    {
    intros k w Hki Ww Hwitw.
    apply (Hrby andel k); auto.
    omega.
    }

    {
    intros w Hw.
    apply (Hrbx ander); eauto.
    eapply extends_ufwitness; eauto.
    intros v Wv Hwitv.
    eapply (Hrby andel); eauto.
    }
  }

  {
  intros k Hki Hrb.
  refine (Hfirstx k _ _).
    { omega. }
  eapply received_by_consistent; eauto.
  }
Qed.

Lemma decisions_support :
  forall s i,
    exists j,
      i <= j
      /\ forall x y,
           rwitness i x
           -> rwitness j y
           -> member (global s) y
           -> exists b, decision s x y b.
Proof.
intros s i.
so (famous_witness_exists s i) as (z & Hwitz & Hfamousz).
destruct Hfamousz as (w & Hsw & Hdecisionz).
so Hdecisionz as (_ & n & _ & _ & _ & Hwitw & _).
exploit (finite_subset _ (fun x => x @= w /\ rwitness i x) (fun x => x @= w)) as H.
  {
  intros x (H & _).
  auto.
  }

  {
  intro x.
  apply dec_and.
    { apply ancestor_decide. }

    { apply rwitness_decide. }
  }

  {
  apply ancestor_finite.
  }
destruct H as (l & Hl).
assert (exists j,
          i <= j
          /\ forall k x y,
               j <= k
               -> (k - i) mod coin_freq <> 0
               -> In x l
               -> rwitness k y
               -> member (global s) y
               -> exists b, decision s x y b) as H.
  {
  so (Forall_forall _#3 ander (fun x Hx => Hl x ander Hx)) as H.
  clear Hl.
  induct H.
    (** nil *)
    {
    exists i.
    split; auto.
    intros k x y _ _ Hx _.
    destruct Hx.
    }

    (** cons *)
    {
    intros x l Hx _ IH.
    destruct Hx as (Hxw & Hwitx).
    destruct IH as (j & Hij & Hj).
    so (fame_consensus _ _ (world_closed _#3 Hxw Hsw) (Hwitx ander)) as (y & b & Hsy & Hdecision).
    so Hdecision as (_ & k & _ & _ & _ & Hwity & _).
    so (decisions_propagate _#7 Hsy (Hwitx andel) (Hwity andel) Hdecision) as Hall.
    exists (max j (S k)).
    split.
      {
      so (Nat.le_max_l j (S k)).
      omega.
      }
    intros m u v Hle Hnocoin Hu Hwitv Hsv.
    destruct Hu as [| Hu].
      {
      subst u.
      exists b.
      apply (Hall m); auto.
        {
        so (Nat.le_max_r j (S k)).
        omega.
        }
      }

      {
      apply (Hj m); auto.
      so (Nat.le_max_l j (S k)).
      omega.
      }
    }
  }
destruct H as (j & Hij & Hj).
assert (exists k, n < k /\ j <= k /\ (k - i) mod coin_freq <> 0) as (k & Hik & Hjk & Hnocoin).
  {
  so (Nat.le_max_l (S n) j).
  so (Nat.le_max_r (S n) j).
  so (eq_nat_dec ((max (S n) j - i) mod coin_freq) 0) as [Heq | Hneq].
    {
    exists (S (max (S n) j)).
    do2 2 split; try omega.
    replace (S (max (S n) j) - i) with (S (max (S n) j - i)) by omega.
    apply succ_no_coin; auto.
    }

    {
    exists (max (S n) j).
    do2 2 split; auto.
    }
  }
exists k.
split; [omega |].
intros x y Hwitx Hwity Hsy.
so (ancestor_decide x w) as [Hxw | Hnxw].
  {
  eapply Hj; eauto.
  apply Hl; auto.
  }

  {
  exists false.
  so (no_late_fame _#6 Hwitz Hwitx Hdecisionz Hnxw) as Hdecisionx.
  exact (decisions_propagate _#7 Hsw (Hwitx andel) (Hwitw andel) Hdecisionx k y Hsy Hik Hnocoin Hwity).
  }
Qed.

Lemma cumulative_decisions_support :
  forall s i,
    exists j,
      i <= j
      /\ forall i' x y,
           i' <= i
           -> rwitness i' x
           -> round j y
           -> member (global s) y
           -> exists z b, z @= y /\ decision s x z b.
Proof.
intros s.
cut (forall i,
       exists j,
         i <= S j
         /\ forall i' x y,
              i' < i
              -> rwitness i' x
              -> round j y
              -> member (global s) y
              -> exists z b, z @= y /\ decision s x z b).
  {
  intros Hprop i.
  so (Hprop (S i)) as (j & Hij & Hj).
  exists j.
  split; [omega |].
  intros i' x y Hi Hwix Hroundy Hsy.
  apply (Hj i'); eauto.
  omega.
  }
intro i.
induct i.

(** 0 *)
{
exists 0.
split; auto.
intros i' x y H.
omega.
}

(** S *)
{
intros i IH.
destruct IH as (j & Hij & Hj).
so (decisions_support s i) as (k & Hik & Hk).
exists (max j k).
so (Nat.le_max_r j k).
split; [omega |].
intros i' x y Hlt Hwitx Hroundy Hsy.
so (eq_nat_dec i' i) as [Heq | Hneq].
  {
  subst i'.
  so (ancestor_witness _#3 (Max.le_max_r j k) Hroundy) as (z & Hzy & Hwitz).
  so (Hk _ _ Hwitx Hwitz (world_closed _#3 Hzy Hsy)) as (b & Hdecision).
  exists z, b.
  auto.
  }

  {
  so (ancestor_witness _#3 (Max.le_max_l j k) Hroundy) as (z & Hzy & Hwitz).
  assert (i' < i) as Hlt' by omega.
  so (Hj _ _ _ Hlt' Hwitx (Hwitz andel) (world_closed _#3 Hzy Hsy)) as (w & b & Hwy & Hdecision).
  exists w, b.
  split; auto.
  eapply star_trans; eauto.
  }
}
Qed.

Lemma received_by_support :
  forall s i x W,
    extends W (global s)
    -> (forall x, decidable (member W x))
    -> received_by s (global s) i x
    -> exists j,
         (exists y, member W y /\ round j y)
         -> received_by s W i x.
Proof.
intros s i x W HsW Hdec Hrb.
so (cumulative_decisions_support s i) as (k & Hik & Hk).
exists k.
intros (y & Wy & Hroundy).
destruct Hrb as (Hsettled & Hall).
split.
  {
  intros j w Hji Ww Hwitw.
  so (Hk j w y Hji Hwitw Hroundy (HsW _ Wy)) as (z & b & Hzy & Hdecision).
  exists z, b.
  split; auto.
  eapply world_closed; eauto.
  }

  {
  intros w Hw.
  apply Hall; auto.
  eapply extends_ufwitness; eauto.
  intros u Wu Hwitu.
  exploit (Hk i u y) as H; auto.
  destruct H as (z & b & Hzy & Hdecision).
  exists z, b.
  split; auto.
  eapply world_closed; eauto.
  }
Qed.

Lemma received_support :
  forall s i x W,
    extends W (global s)
    -> (forall x, decidable (member W x))
    -> nonempty W
    -> received s (global s) i x
    -> exists j,
         (exists y, member W y /\ round j y)
         -> received s W i x.
Proof.
intros s i x W HsW Hdec Hne Hrec.
destruct Hrec as (Hrb & Hfirst).
so (received_by_support _#4 HsW Hdec Hrb) as (j & Hrbif).
exists j.
intros Hinh.
split.
  {
  apply Hrbif; auto.
  }
intros k Hki.
intro Hrb'.
apply (Hfirst k); auto.
eapply received_by_consistent; eauto.
Qed.


(** exploring the isomorphism between [A × B --> C] and [[B, [A,C]]] for categories A, B, C

Authors: Ralph Matthes 2021
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.HorizontalComposition.
Require Import UniMath.CategoryTheory.UnitorsAndAssociatorsForEndofunctors.
Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Examples.BicatOfCats.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.Modifications.Modification.

Import Bicat.Notations.

Local Open Scope cat.

Local Definition CAT : bicat := bicat_of_cats.

Section ThePseudoFunctors.

Section ProductWithFixedSecondArgument.

  Context (B0 : ob CAT).

  Local Definition productwithfixedelement (A: ob CAT) : ob CAT := category_binproduct A B0.

Definition binproductleft_map_data: psfunctor_data CAT CAT.
Proof.
  use make_psfunctor_data.
  - exact productwithfixedelement.
  - intros A A' F.
    exact (pair_functor F (functor_identity (pr1 B0))).
  - intros A A' F G α. cbn.
    use make_nat_trans.
    + intro ab. induction ab as [a b].
      cbn.
      exact (pr1 α a ,, identity b).
    + intros ab ab' fg. induction ab as [a b]. induction ab' as [a' b'].
      induction fg as [f g].
      cbn.
      apply pathsdirprod.
      * apply nat_trans_ax.
      * rewrite id_left.
        apply id_right.
  - intro A. cbn.
    use make_nat_trans.
    + intro ab. exact (identity ab).
    + intros ab ab' fg.
      cbn.
      apply pathsdirprod; rewrite id_left; apply id_right.
  - intros A1 A2 A3 F G. cbn.
    use make_nat_trans.
    + intro a1b. apply identity.
    + intros a1b a1b' fg.
      cbn.
      apply pathsdirprod; rewrite id_left; apply id_right.
Defined.

Definition binproductleft_map_laws: psfunctor_laws binproductleft_map_data.
Proof.
  repeat split; red; cbn.
  - intros A A' F.
    apply (nat_trans_eq (homset_property (productwithfixedelement _))).
    intro ab. cbn. apply idpath.
  - intros A A' F1 F2 F3 α β.
    apply (nat_trans_eq (homset_property (productwithfixedelement _))).
    intro ab. cbn.
    apply pathsdirprod.
    * apply idpath.
    * apply pathsinv0, id_left.
  - intros A B F.
    apply (nat_trans_eq (homset_property (productwithfixedelement _))).
    intro ab. cbn.
    apply pathsdirprod.
    * do 2 rewrite id_right. apply pathsinv0, functor_id.
    * do 2 rewrite id_right. apply idpath.
  - intros A B F.
    apply (nat_trans_eq (homset_property (productwithfixedelement _))).
    intro ab. cbn.
    apply pathsdirprod; do 2 rewrite id_right; apply idpath.
  - intros A1 A2 A3 A4 F G H.
    apply (nat_trans_eq (homset_property (productwithfixedelement _))).
    intro a1b. cbn.
    apply pathsdirprod.
    * do 3 rewrite id_left. rewrite id_right.
      apply pathsinv0, functor_id.
    * apply idpath.
  - intros A1 A2 A3 F G1 G2 β.
    apply (nat_trans_eq (homset_property (productwithfixedelement _))).
    intro a1b. cbn.
    apply pathsdirprod.
    * rewrite id_left, id_right.
      apply idpath.
    * apply idpath.
  - intros A1 A2 A3 F1 F2 G α.
    apply (nat_trans_eq (homset_property (productwithfixedelement _))).
    intro a1b. cbn.
    apply pathsdirprod.
    * rewrite id_left, id_right.
      apply idpath.
    * apply idpath.
Defined.

Definition binproductleft_psfunctor: psfunctor CAT CAT.
Proof.
  use make_psfunctor.
  - exact binproductleft_map_data.
  - exact binproductleft_map_laws.
  - split; red; cbn.
    + intro A.
      use tpair.
      * use make_nat_trans.
        -- intro ab. apply identity.
        -- intros ab ab' fg.
           cbn.
           apply pathsdirprod; rewrite id_left; apply id_right.
      * split; apply (nat_trans_eq (homset_property (productwithfixedelement _)));
          intro ab; cbn; apply pathsdirprod; apply id_left.
    + intros A1 A2 A3 F G.
      use tpair.
      * use make_nat_trans.
        -- intro a1b. apply identity.
        -- intros a1b a1b' fg.
           cbn.
           apply pathsdirprod; rewrite id_left; apply id_right.
      * split; apply (nat_trans_eq (homset_property (productwithfixedelement _)));
          intro a1b; cbn; apply pathsdirprod; apply id_left.
Defined.

End ProductWithFixedSecondArgument.

Section FunctorCategoryWithFixedSource.

  Context (A0 : ob CAT).

Definition functorcategoryright_map_data: psfunctor_data CAT CAT.
Proof.
  use make_psfunctor_data.
  - exact (fun B => functor_category (pr1 A0) B).
  - intros B B' F.
    cbn.
    exact (post_composition_functor A0 B B' F).
  - intros B1 B2 F F' β.
    use make_nat_trans.
    + intro G. cbn.
      exact (pre_whisker (pr1 G) β).
    + intros G G' α. cbn.
      etrans.
      2: { apply horcomp_pre_post. }
      apply pathsinv0.
      apply horcomp_post_pre.
  - intro B.
    use make_nat_trans.
    + intro G. cbn. apply ρ_functors_inv.
    + intros G G' α.
      apply (nat_trans_eq (homset_property _)).
      intro a.
      cbn.
      rewrite id_left; apply id_right.
  - intros B1 B2 B3 H F. cbn.
    use make_nat_trans.
    + intro G.
      cbn.
      apply α_functors.
    + intros G G' α. cbn.
      apply (nat_trans_eq (homset_property _)).
      intro a.
      cbn.
      rewrite id_left; apply id_right.
Defined.

Definition functorcategoryright_map_laws: psfunctor_laws functorcategoryright_map_data.
Proof.
  repeat split; red; cbn.
  - intros B B' F.
    apply (nat_trans_eq (homset_property (functor_category _ _))).
    intro G.
    apply (nat_trans_eq (homset_property _)).
    intro a. apply idpath.
  - intros B B' F1 F2 F3 β1 β2.
    apply (nat_trans_eq (homset_property (functor_category _ _))).
    intro G.
    apply (nat_trans_eq (homset_property _)).
    intro a. apply idpath.
  - intros B B' F.
    apply (nat_trans_eq (homset_property (functor_category _ _))).
    intro G.
    apply (nat_trans_eq (homset_property _)).
    intro a.
    cbn.
    do 2 rewrite id_right; apply pathsinv0, functor_id.
  - intros B B' F.
    apply (nat_trans_eq (homset_property (functor_category _ _))).
    intro G.
    apply (nat_trans_eq (homset_property _)).
    intro a.
    cbn.
    do 2 rewrite id_right; apply idpath.
  - intros B1 B2 B3 B4 F1 F2 F3.
    apply (nat_trans_eq (homset_property (functor_category _ _))).
    intro G.
    apply (nat_trans_eq (homset_property _)).
    intro a.
    cbn. do 3 rewrite id_left. rewrite id_right. apply pathsinv0, functor_id.
  - intros B C D F H1 H2 γ.
    apply (nat_trans_eq (homset_property (functor_category _ _))).
    intro G.
    apply (nat_trans_eq (homset_property _)).
    intro a.
    cbn. rewrite id_right; apply id_left.
  - intros B C D F1 F2 H β.
    apply (nat_trans_eq (homset_property (functor_category _ _))).
    intro G.
    apply (nat_trans_eq (homset_property _)).
    intro a.
    cbn. rewrite id_right; apply id_left.
Defined.

Definition functorcategoryright_psfunctor: psfunctor CAT CAT.
Proof.
  use make_psfunctor.
  - exact functorcategoryright_map_data.
  - exact functorcategoryright_map_laws.
  - split; red; cbn.
    + intro B.
      use tpair.
      * use make_nat_trans.
        -- intro G.
           cbn. apply ρ_functors.
        -- intros G G' α.
           apply (nat_trans_eq (homset_property _)).
           intro a.
           cbn. rewrite id_left; apply id_right.
      * split; apply (nat_trans_eq (homset_property (functor_category _ _)));
          intro G; cbn; apply (nat_trans_eq (homset_property _)); intro a; apply id_left.
    + intros B1 B2 B3 F H.
      use tpair.
      * use make_nat_trans.
        -- intro G.
           cbn. apply α_functors_inv.
        -- intros G G' α.
           apply (nat_trans_eq (homset_property _)).
           intro a.
           cbn. rewrite id_left; apply id_right.
      * split; apply (nat_trans_eq (homset_property (functor_category _ _)));
          intro G; cbn; apply (nat_trans_eq (homset_property _)); intro a; apply id_left.
Defined.

End FunctorCategoryWithFixedSource.

End ThePseudoFunctors.

Section Currying.

  Context (B0 : ob CAT).

  Let L := binproductleft_psfunctor B0.
  Let R := functorcategoryright_psfunctor B0.

(* to observe the type of the goal: match goal with | |- ?f => set (goal := f) end. *)

  Definition coevaluation_pstrans_data: pstrans_data (id_psfunctor CAT) (comp_psfunctor R L).
  Proof.
    use make_pstrans_data.
      + intro A. apply coevaluation_functor.
      + intros A A' F.
        apply nat_z_iso_to_invertible_2cell.
        use make_nat_z_iso.
        * use make_nat_trans.
          -- intro a.
             cbn in a. cbn.
             ++ use make_nat_trans.
                ** intro b. apply identity.
                ** intros b b' f. cbn.
                   apply pathsdirprod.
                   --- do 2 rewrite id_right. apply functor_id.
                   --- rewrite id_left. apply id_right.
          --  intros a a' g. cbn.
              apply (nat_trans_eq (homset_property (productwithfixedelement _ _))).
              cbn. intro b.
              apply pathsdirprod.
              ++ rewrite id_left. apply id_right.
              ++ apply idpath.
        * intro a.
          apply nat_trafo_z_iso_if_pointwise_z_iso.
          intro b. cbn.
          cbn in F, a.
          set (aux := identity(C:=pr1(productwithfixedelement _ _)) (make_dirprod (F a) b)).
          change (is_z_isomorphism aux).
          apply identity_is_z_iso.
  Defined.

  Lemma coevaluation_is_pstrans: is_pstrans coevaluation_pstrans_data.
  Proof.
    repeat split.
    - intros A A' F F' α.
      apply (nat_trans_eq (homset_property (functor_category _ _))).
      intro a.
      apply (nat_trans_eq (homset_property (productwithfixedelement _ _))).
      intro b. cbn.
      apply pathsdirprod.
      + rewrite id_left. apply id_right.
      + apply idpath.
    - intro A.
      apply (nat_trans_eq (homset_property (functor_category _ _))).
      intro a.
      apply (nat_trans_eq (homset_property (productwithfixedelement _ _))).
      intro b. cbn. apply idpath.
    - intros A1 A2 A3 F G.
      apply (nat_trans_eq (homset_property (functor_category _ _))).
      intro a.
      apply (nat_trans_eq (homset_property (productwithfixedelement _ _))).
      intro b. cbn.
      apply pathsdirprod.
      + do 6 rewrite id_right. rewrite id_left. apply pathsinv0, functor_id.
      + etrans.
        2: { do 3 rewrite id_right. apply idpath. }
        apply idpath.
  Qed.

  Definition coevaluation_pstrans: pstrans (id_psfunctor CAT) (comp_psfunctor R L).
  Proof.
    use make_pstrans.
    - exact coevaluation_pstrans_data.
    - exact coevaluation_is_pstrans.
  Defined.

  Definition evaluation_pstrans_data: pstrans_data (comp_psfunctor L R) (id_psfunctor CAT).
  Proof.
    use make_pstrans_data.
    - intro A. apply evaluation_functor.
    - intros A A' F.
      apply nat_z_iso_to_invertible_2cell.
      use make_nat_z_iso.
      + use make_nat_trans.
        * intro Gb. apply identity.
        * intros Gb Gb' βg. induction Gb as [G b]. induction Gb' as [G' b']. induction βg as [β g].
          simpl in *.
          rewrite id_left, id_right.
          apply functor_comp.
      + intro a.
        cbn.
        apply identity_is_z_iso.
  Defined.

  Lemma evaluation_is_pstrans: is_pstrans evaluation_pstrans_data.
  Proof.
    repeat split.
    - intros A A' F F' α.
      apply (nat_trans_eq (homset_property _)).
      intro Gb. induction Gb as [G b]. cbn.
      do 2 rewrite functor_id. do 2 rewrite id_left. apply id_right.
    - intro A.
      apply (nat_trans_eq (homset_property _)).
      intro Gb. induction Gb as [G b]. cbn.
      do 5 rewrite id_left. rewrite id_right. apply pathsinv0, functor_id.
    - intros A1 A2 A3 F H.
      apply (nat_trans_eq (homset_property _)).
      intro Gb. induction Gb as [G b]. cbn.
      do 7 rewrite id_right.
      do 3 rewrite functor_id.
      rewrite id_left, id_right. apply pathsinv0, functor_id.
  Qed.

  Definition evaluation_pstrans: pstrans (comp_psfunctor L R) (id_psfunctor CAT).
  Proof.
    use make_pstrans.
    - exact evaluation_pstrans_data.
    - exact evaluation_is_pstrans.
  Defined.

  Definition currying_biajd_unit_counit: left_biadj_unit_counit L.
  Proof.
    use (make_biadj_unit_counit R).
    - exact coevaluation_pstrans.
    - exact evaluation_pstrans.
  Defined.

  Definition currying_biajd_triangle_l_law: biadj_triangle_l_law currying_biajd_unit_counit.
  Proof.
    red.
    use make_invertible_modification.
    - intro A.
      apply nat_z_iso_to_invertible_2cell.
      use make_nat_z_iso.
      + use make_nat_trans.
        * intro ab. apply identity.
        * intros ab ab' fg.
          cbn.
          apply pathsdirprod.
          -- rewrite id_right. apply idpath.
          -- rewrite id_left. rewrite id_right. apply id_right.
      + intro ab.
        cbn.
        set (aux := identity(C:=pr1(productwithfixedelement _ _)) ab).
        change (is_z_isomorphism aux).
        apply identity_is_z_iso.
    - intros A A' F.
      apply (nat_trans_eq (homset_property (productwithfixedelement _ _))).
      intro ab. cbn.
      apply pathsdirprod.
      + rewrite functor_id. repeat rewrite id_left. apply idpath.
      + repeat rewrite id_left. apply idpath.
  Defined.

  Definition currying_biajd_triangle_r_law: biadj_triangle_r_law currying_biajd_unit_counit.
  Proof.
    red.
    use make_invertible_modification.
    - intro A.
      apply nat_z_iso_to_invertible_2cell.
      use make_nat_z_iso.
      + use make_nat_trans.
        * intro G. cbn in G.
          use make_nat_trans.
          -- intro b. apply identity.
          -- intros b b' g.
             cbn. rewrite id_left, id_right. apply id_right.
        * intros G G' β.
          apply (nat_trans_eq (homset_property _)).
          intro b.
          cbn. rewrite id_right. apply cancel_postcomposition. apply functor_id.
      + intro G.
        apply nat_trafo_z_iso_if_pointwise_z_iso.
        intro b. cbn.
        apply identity_is_z_iso.
    - intros A A' F.
      apply (nat_trans_eq (homset_property (functor_category _ _))).
      intro G. cbn.
      apply (nat_trans_eq (homset_property _)).
      intro b.
      cbn.
      repeat rewrite id_left.
      repeat rewrite functor_id.
      repeat rewrite id_left.
      rewrite id_right. apply pathsinv0, functor_id.
  Defined.

  Definition currying_biajd: left_biadj_data L.
  Proof.
    use make_biadj_data.
    - exact currying_biajd_unit_counit.
    - exact currying_biajd_triangle_l_law.
    - exact currying_biajd_triangle_r_law.
  Defined.

  Definition currying_hom_equivalence (C E : category) :
    equivalence_of_cats [C, [B0:category,E]] [category_binproduct C B0, E].
  Proof.
    apply (biadj_hom_equivalence currying_biajd).
  Defined.

End Currying.


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

Section IncRA.
  Inductive incRAT : Type :=
  | S : incRAT
  | F : incRAT
  | Bot : incRAT.

  (* From what I've read, this roughly speaking allows the Coq type
  inference to view incRAT as a particular kind of OFE, which has some
  additional structure. *)
  Canonical Structure incRAC := leibnizC incRAT.

  (* Supply the resource algebra operation by giving an instance of
  the Op type class. *)
  Instance incRAop : Op incRAT :=
    λ p1 p2,
    match (p1, p2) with
    | (F, F) => F
    | _ => Bot
    end.

  Instance incRAvalid : Valid incRAT :=
    λ p,
    match p with
    | Bot => False
    | _ => True
    end.

  Instance incRAcore : PCore incRAT :=
    λ p, None.

  (* Combine all the components of the RA and prove that it is an
  RA *)
  Definition incRA_mixin : RAMixin incRAT.
  Proof.
    split; try apply _; try done.
    - (* associativity, simply show by case analysis *)
      rewrite /op. rewrite /incRAop.
      intros [] [] []; reflexivity.
    - (* commutativity *)
      rewrite /op. rewrite /incRAop.
      intros [] []; reflexivity.
    - (* validity of combination implies validity of parts *)
      intros [] [] HV; try done.
    (* there were a bunch more properties, such as the relation
       between validity and extension order but apparently it could
       automatically proof those. *)
  Qed.

  Canonical Structure incRA := discreteR incRAT incRA_mixin.

  (* Let Coq know that our CMRA is discrete. *)
  Instance incRA_cmra_discrete : CmraDiscrete incRA.
  Proof. apply discrete_cmra_discrete. Qed.

  (* Use an instantiation of Iris that has my new resource algebra. *)
  Class incG Σ := IncG { inc_inG :> inG Σ incRA }.
  Definition incΣ : gFunctors := #[GFunctor incRA].

  Instance subG_incΣ {Σ} : subG incΣ Σ -> incG Σ.
  Proof. solve_inG. Qed.

  Context `{!heapG Σ, !incG Σ}.

  Lemma incRA_F_duplicable γ: own γ F -∗ (own γ F ∗ own γ F).
  Proof.
    iIntros "HF".
    iApply own_op.
    iExact "HF".
  Qed.

  Lemma incRA_S_F_incompatible γ Φ: own γ S ∗ own γ F -∗ Φ.
  Proof.
    iIntros "HR".
    iExFalso.
    rewrite -own_op.
    iDestruct (own_valid with "HR") as "HV".
    iDestruct "HV" as %HV.
    iPureIntro.
    exact HV.
  Qed.

  Lemma incRA_S_F_update: S ~~> F.
  Proof.
    intros n mz H.
    destruct mz.
    - rewrite /opM. simpl.
      rewrite <-cmra_discrete_valid_iff.
      rewrite /opM in H.
      rewrite <-cmra_discrete_valid_iff in H.
      destruct c; naive_solver.
    - simpl. rewrite <-cmra_discrete_valid_iff. done.
  Qed.
End IncRA.


(*
(C) Copyright 2010, COQTAIL team

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

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

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

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

Require Import Rbase.
Require Export Rsequence.
Require Import Ranalysis.
Require Import Rfunctions.
Require Import Rseries_def.
Require Import Lra.
Require Import RiemannInt.
Require Import SeqProp.
Require Import MyRIneq.
Require Import Rinterval Ranalysis_def Ranalysis_def_simpl.
Require Import Ranalysis_continuity.

Local Open Scope R_scope.

(** * Intermediate Value Theorem on an Interval and its corollary *)
(** This proof was mainly taken from Reals.Rsqrt_def *)

Lemma dicho_steps_interval_compat : forall x y P N, x <= y ->
  interval x y (dicho_up x y P N)
  /\ interval x y (dicho_lb x y P N).
Proof.
intros x y P N x_le_y ; induction N.
 simpl ; split ; [apply interval_r | apply interval_l] ; assumption.
 simpl ; split ; fold (middle (Dichotomy_lb x y P N) (Dichotomy_ub x y P N)) ;
 destruct (P (middle (Dichotomy_lb x y P N) (Dichotomy_ub x y P N))) ;
 try apply interval_middle_compat ; apply IHN.
Qed.

Lemma dicho_interval_compat : forall x y l P, x <= y ->
  Rseq_cv (dicho_up x y P) l -> interval x y l.
Proof.
intros x y l P x_le_y Hl ; eapply Rseq_interval_compat ;
 [| eassumption] ; intro ; apply dicho_steps_interval_compat ;
 assumption.
Qed.

Lemma cond_positivity_car: forall x,
  cond_positivity x = true <-> 0 <= x.
Proof.
intro ; unfold cond_positivity ; destruct (Rle_dec 0 x) ;
 intuition ; discriminate.
Qed.

Lemma cond_positivity_car': forall x,
  cond_positivity x = false <-> x < 0.
Proof.
intro ; unfold cond_positivity ; destruct (Rle_dec 0 x) ; intuition.
 discriminate.
 destruct (Rlt_irrefl 0) ; eapply Rle_lt_trans ; eassumption.
Qed.

Lemma Rseq_cv_0_abs_compat : forall Un,
  Rseq_cv (| Un |) 0 -> Rseq_cv Un 0.
Proof.
intros Un HUn eps eps_pos ; destruct (HUn _ eps_pos) as [N HN] ;
 exists N ; intros n n_lb ; apply Rle_lt_trans with (R_dist (|Un| n)%R 0).
  right ; unfold R_dist, Rseq_abs ; do 2 rewrite Rminus_0_r ;
  rewrite Rabs_Rabsolu ; reflexivity.
  apply HN ; assumption.
Qed.

Lemma dicho_diff_cv : forall x y P, x <= y ->
  Rseq_cv (dicho_up x y P - dicho_lb x y P) 0.
Proof.
intros x y P xley ; eapply Rseq_cv_eq_compat.
 intro n ; apply dicho_lb_dicho_up ; assumption.
 eapply Rseq_cv_pos_infty_div_compat, Rseq_constant_cv.
 apply Rseq_pow_gt_1_cv ; lra.
Qed.

Lemma interval_open_interval : forall x y z,
  interval x y z -> x <> z -> y <> z ->
  open_interval x y z.
Proof.
intros x y z [xz zy] x_neq y_neq ; split ;
 apply Rle_neq_lt ; auto.
Qed.

Lemma IVT_open_interval_prelim : forall (f : R -> R) (x y : R),
  continuity_interval x y f -> x < y -> open_interval (f x) (f y) 0 ->
  {z : R | open_interval x y z /\ f z = 0}.
Proof.
intros f x y Hf xlty O_in ; assert (xley := Rlt_le _ _ xlty) ;
 pose (P := fun z => cond_positivity (f z)) ; pose (Zn := dicho_up x y P) ;
 pose (Zn' := dicho_lb x y P) ; assert (Hcv := dicho_diff_cv _ _ P xley) ;
 destruct (dicho_up_cv x y P xley) as [z Hz] ; exists z.
 assert (Hz' : Rseq_cv Zn' z).
  destruct (dicho_lb_cv x y P xley) as [z' Hz'] ;
  rewrite <- (cv_dicho _ _ _ _ _ xley Hz' Hz) ; assumption.
 assert (fz_eq : f z = 0).
  apply Rle_antisym.

  apply Rseq_negative_limit with (fun n => f (Zn' n)).
  intro n ; left ; rewrite <- cond_positivity_car' ; fold (P (Zn' n)) ;
  apply dicho_lb_car ; unfold P ; rewrite cond_positivity_car' ; apply O_in.

  eapply Rseq_cv_continuity_interval_compat ; [eapply dicho_interval_compat |
  intro ; apply dicho_steps_interval_compat | |] ; eassumption.

  apply Rseq_positive_limit with (fun n => f (Zn n)).
  intro n ; rewrite <- cond_positivity_car ; fold (P (Zn n)) ;
  apply dicho_up_car ; unfold P ; rewrite cond_positivity_car ;
  left ;  apply O_in.
  eapply Rseq_cv_continuity_interval_compat ; [eapply dicho_interval_compat |
  intro ; apply dicho_steps_interval_compat | |] ; eassumption.

  split ; [apply interval_open_interval | assumption].
   eapply dicho_interval_compat ; eassumption.
   intro Hfalse ; rewrite Hfalse in O_in ; apply (Rlt_irrefl 0) ;
   apply Rle_lt_trans with (f z) ; [right ; symmetry ; apply fz_eq | apply O_in].
   intro Hfalse ; rewrite Hfalse in O_in ; apply (Rlt_irrefl 0) ;
   apply Rlt_le_trans with (f z) ; [apply O_in | right ; apply fz_eq].
Qed.

Lemma IVT_open_interval : forall (f : R -> R) (x y : R) l,
  continuity_interval x y f -> x < y -> open_interval (f x) (f y) l ->
  { z : R | open_interval x y z /\ f z = l }.
Proof.
intros f x y l Hf Hxy Hl ;
 destruct IVT_open_interval_prelim with (f - (fun _ => l))%F x y as [z [z_in Hz]].
  apply continuity_in_minus, continuity_in_const ; assumption.
  assumption.
  clear - Hl; destruct Hl ; split ; unfold minus_fct ; lra.
 exists z ; split ; [assumption |].
  clear - Hz ; unfold minus_fct in * ; intuition.
Qed.

Lemma IVT_interval : forall (f : R -> R) (x y : R) l,
  continuity_interval x y f -> x <= y -> interval (f x) (f y) l ->
  {z : R | interval x y z /\ f z = l}.
Proof.
intros f x y l Hf xley [fxlel llefy] ;
 destruct (Rle_lt_or_eq_dec _ _ xley) as [xlty | xeqy].
 destruct (Rle_lt_or_eq_dec _ _ fxlel) as [fxltl | fxeql].
 destruct (Rle_lt_or_eq_dec _ _ llefy) as [lltfy | leqfy].
 destruct (IVT_open_interval _ _ _ l Hf xlty) as [z [z_in Hz]].
  split ; assumption.
  exists z ; split ; [apply open_interval_interval |] ; assumption.
  exists y ; split ; [apply interval_r |] ; auto.
  exists x ; split ; [apply interval_l |] ; auto.
  exists y ; subst ; split ; [apply interval_r | apply Rle_antisym] ; auto.
Qed.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 13: Deep and Shallow Embeddings
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

Set Implicit Arguments.
Set Asymmetric Patterns.

(** * Shared notations and definitions; main material starts afterward. *)

Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).
Definition heap := fmap nat nat.
Definition assertion := heap -> Prop.

Hint Extern 1 (_ <= _) => linear_arithmetic.
Hint Extern 1 (@eq nat _ _) => linear_arithmetic.

Example h0 : heap := $0 $+ (0, 2) $+ (1, 1) $+ (2, 8) $+ (3, 6).

Hint Rewrite max_l max_r using linear_arithmetic.

Ltac simp := repeat (simplify; subst; propositional;
                    try match goal with
                        | [ H : ex _ |- _ ] => invert H
                        end); try linear_arithmetic.

(** * Basic concepts of shallow, deep, and mixed embeddings *)

(* We often have many options for how to encode some sort of formal expression.
 * The simplest way is to write it directly as a Gallina functional program,
 * which Coq knows how to evaluate directly.  That style is called
 * *shallow embedding*. *)

Module SimpleShallow.
  Definition foo (x y : nat) : nat :=
    let u := x + y in
    let v := u * y in
    u + v.
End SimpleShallow.

(* Alternatively, we can do as we have been through most of the chapters: define
 * inductive types of program syntax, along with semantics for syntax trees.
 * That style is called *deep embedding*. *)

Module SimpleDeep.
  Inductive exp :=
  | Const (n : nat)
  | Var (x : var)
  | Plus (e1 e2 : exp)
  | Times (e1 e2 : exp)
  | Let (x : var) (e1 e2 : exp).

  Definition foo : exp :=
    Let "u" (Plus (Var "x") (Var "y"))
        (Let "v" (Times (Var "u") (Var "y"))
             (Plus (Var "u") (Var "v"))).

  Fixpoint interp (e : exp) (v : fmap var nat) : nat :=
    match e with
    | Const n => n
    | Var x => v $! x
    | Plus e1 e2 => interp e1 v + interp e2 v
    | Times e1 e2 => interp e1 v * interp e2 v
    | Let x e1 e2 => interp e2 (v $+ (x, interp e1 v))
    end.
End SimpleDeep.

(* We defined function [foo] in shallow and deep styles, and it is easy to prove
 * that the encodings are equivalent. *)
Theorem shallow_to_deep : forall x y,
    SimpleShallow.foo x y = SimpleDeep.interp SimpleDeep.foo ($0 $+ ("x", x) $+ ("y", y)).
Proof.
  unfold SimpleShallow.foo.
  simplify.
  reflexivity.
Qed.

(* More interestingly, we can mix characteristics of the two styles.  To explain
 * exactly how, it's important to introduce the distinction between the
 * *metalanguage*, in which we do our proofs (e.g., Coq for us); and the
 * *object language*, which we formalize explicitly (e.g., lambda calculus,
 * simple imperative programs, ...).  With *higher-order abstract syntax*, we
 * represent binders of the object language using the function types of the
 * metalanguage. *)
Module SimpleMixed.
  Inductive exp :=
  | Const (n : nat)
  | Var (x : string)
  | Plus (e1 e2 : exp)
  | Times (e1 e2 : exp)
  | Let (e1 : exp) (e2 : nat -> exp).
  (* Note a [Let] body is a *function* over the computed value attached to the
   * variable being bound. *)

  Definition foo : exp :=
    Let (Plus (Var "x") (Var "y"))
        (fun u => Let (Times (Const u) (Var "y"))
                      (fun v => Plus (Const u) (Const v))).

  Fixpoint interp (e : exp) (v : fmap var nat) : nat :=
    match e with
    | Var x => v $! x
    | Const n => n
    | Plus e1 e2 => interp e1 v + interp e2 v
    | Times e1 e2 => interp e1 v * interp e2 v
    | Let e1 e2 => interp (e2 (interp e1 v)) v
    end.

  (* We can even do useful transformations on such expressions within Gallina,
   * as in this function to recursively simplify additions of 0 and
   * multiplications by 1. *)
  Fixpoint reduce (e : exp) : exp :=
    match e with
    | Var x => Var x
    | Const n => Const n
    | Plus e1 e2 =>
      let e1' := reduce e1 in
      let e2' := reduce e2 in
      match e1' with
      | Const 0 => e2'
      | _ => match e2' with
             | Const 0 => e1'
             | _ => Plus e1' e2'
             end
      end
    | Times e1 e2 =>
      let e1' := reduce e1 in
      let e2' := reduce e2 in
      match e1' with
      | Const 1 => e2'
      | _ => match e2' with
             | Const 1 => e1'
             | _ => Times e1' e2'
             end
      end
    | Let e1 e2 =>
      let e1' := reduce e1 in
      match e1' with
      | Const n => reduce (e2 n)
      | _ => Let e1' (fun n => reduce (e2 n))
      end
    end.

  (* This example shows simplification, even under binders. *)
  Compute (reduce (Let (Plus (Const 0) (Const 1))
                       (fun n => Let (Times (Var "x") (Const 2))
                                     (fun m => Times (Const n) (Const m))))).

  (* The transformation is provably meaning-preserving. *)
  Theorem reduce_ok : forall v e, interp (reduce e) v = interp e v.
  Proof.
    induct e; simplify;
    repeat match goal with
           | [ H : _ = interp _ _ |- _ ] => rewrite <- H
           | [ |- context[match ?E with _ => _ end] ] => cases E; simplify; subst; try linear_arithmetic
    end; eauto.
  Qed.
End SimpleMixed.

Theorem shallow_to_mixed : forall x y,
    SimpleShallow.foo x y = SimpleMixed.interp SimpleMixed.foo ($0 $+ ("x", x) $+ ("y", y)).
Proof.
  unfold SimpleShallow.foo.
  simplify.
  reflexivity.
Qed.

(** * Shallow embedding of a language very similar to the one we used last chapter *)

(* With the basic terminology out of the way, let's see these ideas in action,
 * to encode the sort of imperative language we studied in the previous
 * chapter. *)

Module Shallow.
  (* As a shallow embedding, we can represent imperative programs as functional
   * programs that manipulate heaps explicitly. *)
  Definition cmd result := heap -> heap * result.
  (* Parameter [result] gives the type of the value being computed by a
   * command.  The command is a function taking the initial heap as input, and
   * it returns a pair of the final heap and the command's result. *)

  (* We can redefine Hoare triples over these functional programs. *)
  Definition hoare_triple (P : assertion) {result} (c : cmd result) (Q : result -> assertion) :=
    forall h, P h
              -> let (h', r) := c h in
                 Q r h'.

  Notation "{{ h ~> P }} c {{ r & h' ~> Q }}" :=
    (hoare_triple (fun h => P) c (fun r h' => Q)) (at level 90, c at next level).

  (* Standard rules of Hoare logic can be proved as lemmas.  For instance,
   * here's the rule of consequence. *)
  Theorem consequence : forall P {result} (c : cmd result) Q
                               (P' : assertion) (Q' : _ -> assertion),
      hoare_triple P c Q
      -> (forall h, P' h -> P h)
      -> (forall r h, Q r h -> Q' r h)
      -> hoare_triple P' c Q'.
  Proof.
    unfold hoare_triple; simplify.
    specialize (H h).
    specialize (H0 h).
    cases (c h).
    auto.
  Qed.

  (* However, the programs themselves look quite different from those we saw in
   * the previous chapter.  This function computes the maximum among the first [i]
   * cells of memory and the accumulator [acc]. *)
  Fixpoint array_max (i acc : nat) : cmd nat :=
    fun h =>
      match i with
      | O => (h, acc)
      | S i' =>
        let h_i' := h $! i' in
        array_max i' (max h_i' acc) h
      end.

  (* We can prove its correctness via preconditions and postconditions. *)

  Lemma array_max_ok' : forall len i acc,
    {{ h ~> forall j, i <= j < len -> h $! j <= acc }}
      array_max i acc
    {{ r&h ~> forall j, j < len -> h $! j <= r }}.
  Proof.
    induct i; unfold hoare_triple in *; simplify; propositional; auto.

    specialize (IHi (max (h $! i) acc) h); propositional.
    cases (array_max i (max (h $! i) acc) h); simplify; propositional; subst.
    apply IHi; auto.
    simplify.
    cases (j0 ==n i); subst; auto.
    assert (h $! j0 <= acc) by auto.
    linear_arithmetic.
  Qed.

  Theorem array_max_ok : forall len,
    {{ _ ~> True }}
      array_max len 0
    {{ r&h ~> forall i, i < len -> h $! i <= r }}.
  Proof.
    simplify.
    eapply consequence.
    apply array_max_ok' with (len := len).

    simplify.
    linear_arithmetic.

    auto.
  Qed.

  (* We can also run the program on concrete inputs. *)
  Example run_array_max0 : array_max 4 0 h0 = (h0, 8).
  Proof.
    unfold h0.
    simplify.
    reflexivity.
  Qed.

  (* One more example in the same style: increment each of the first [i] cells
   * of memory. *)

  Fixpoint increment_all (i : nat) : cmd unit :=
    fun h =>
      match i with
      | O => (h, tt)
      | S i' => increment_all i' (h $+ (i', S (h $! i')))
      end.

  Lemma increment_all_ok' : forall len h0 i,
    {{ h ~> (forall j, j < i -> h $! j = h0 $! j)
       /\ (forall j, i <= j < len -> h $! j = S (h0 $! j)) }}
      increment_all i
    {{ _&h ~> forall j, j < len -> h $! j = S (h0 $! j) }}.
  Proof.
    induct i; unfold hoare_triple in *; simplify; propositional; auto.

    specialize (IHi (h $+ (i, S (h $! i)))); propositional.
    cases (increment_all i (h $+ (i, S (h $! i)))); simplify; propositional; subst.
    apply H; simplify; auto.

    cases (j0 ==n i); subst; auto.
    simplify; auto.
    simplify; auto.
  Qed.

  Theorem increment_all_ok : forall len h0,
    {{ h ~> h = h0 }}
      increment_all len
    {{ _&h ~> forall j, j < len -> h $! j = S (h0 $! j) }}.
  Proof.
    simplify.
    eapply consequence.
    apply increment_all_ok' with (len := len).

    simplify; subst; propositional.
    linear_arithmetic.

    simplify.
    auto.
  Qed.

  Example run_increment_all0 : increment_all 4 h0 = ($0 $+ (0, 3) $+ (1, 2) $+ (2, 9) $+ (3, 7), tt).
  Proof.
    unfold h0.
    simplify.
    f_equal.
    maps_equal.
  Qed.
End Shallow.

(** * A basic deep embedding *)

(* One disadvantage of the last style of programs is computational efficiency:
 * real CPU architectures don't manipulate memory as functional maps that are
 * passed around, and the abstraction gap between our code and CPUs prevents us
 * from taking maximum advantage of the hardware to achieve good performance.
 * To help regain that efficiency, let's do a deep embedding of the language.
 * Actually, it's a mixed embedding, with no explicit concept of variables,
 * using higher-order abstract syntax to represent binders. *)

Module Deep.
  Inductive cmd : Set -> Type :=
  | Return {result : Set} (r : result) : cmd result
  | Bind {result result'} (c1 : cmd result') (c2 : result' -> cmd result) : cmd result
  | Read (a : nat) : cmd nat
  | Write (a v : nat) : cmd unit.

  (* These constructors are most easily explained through examples.  We'll
   * translate both of the programs from the shallowly embedding above. *)

  Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 80).

  Fixpoint array_max (i acc : nat) : cmd nat :=
    match i with
    | O => Return acc
    | S i' =>
      h_i' <- Read i';
      array_max i' (max h_i' acc)
    end.

  Fixpoint increment_all (i : nat) : cmd unit :=
    match i with
    | O => Return tt
    | S i' =>
      v <- Read i';
      _ <- Write i' (S v);
      increment_all i'
    end.

  (* Note how this is truly a mixed encoding: we freely use Gallina constructs
   * like [match], mixed in with instructions specific to the object language,
   * like reading or writing memory.  An interpreter explains what it all means,
   * reducing programs to their original type from the shallow embedding. *)

  Fixpoint interp {result} (c : cmd result) (h : heap) : heap * result :=
    match c with
    | Return _ r => (h, r)
    | Bind _ _ c1 c2 =>
      let (h', r) := interp c1 h in
      interp (c2 r) h'
    | Read a => (h, h $! a)
    | Write a v => (h $+ (a, v), tt)
    end.

  Example run_array_max0 : interp (array_max 4 0) h0 = (h0, 8).
  Proof.
    unfold h0.
    simplify.
    reflexivity.
  Qed.

  Example run_increment_all0 : interp (increment_all 4) h0 = ($0 $+ (0, 3) $+ (1, 2) $+ (2, 9) $+ (3, 7), tt).
  Proof.
    unfold h0.
    simplify.
    f_equal.
    maps_equal.
  Qed.

  (* This time, we define a Hoare-triple relation syntactically. *)
  Inductive hoare_triple : assertion -> forall {result}, cmd result -> (result -> assertion) -> Prop :=
  | HtReturn : forall P {result : Set} (v : result),
      hoare_triple P (Return v) (fun r h => P h /\ r = v)

  | HtBind : forall P {result' result} (c1 : cmd result') (c2 : result' -> cmd result) Q R,
      hoare_triple P c1 Q
      -> (forall r, hoare_triple (Q r) (c2 r) R)
      -> hoare_triple P (Bind c1 c2) R
    (* Interesting thing about this rule: the second premise uses nested
     * universal quantification over all possible results of the first command. *)

  | HtRead : forall P a,
      hoare_triple P (Read a) (fun r h => P h /\ r = h $! a)
  | HtWrite : forall P a v,
      hoare_triple P (Write a v) (fun _ h => exists h', P h' /\ h = h' $+ (a, v))
  | HtConsequence : forall {result} (c : cmd result) P Q (P' : assertion) (Q' : _ -> assertion),
      hoare_triple P c Q
      -> (forall h, P' h -> P h)
      -> (forall r h, Q r h -> Q' r h)
      -> hoare_triple P' c Q'.

  Lemma HtStrengthen : forall {result} (c : cmd result) P Q (Q' : _ -> assertion),
      hoare_triple P c Q
      -> (forall r h, Q r h -> Q' r h)
      -> hoare_triple P c Q'.
  Proof.
    simplify.
    eapply HtConsequence; eauto.
  Qed.

  (* Here are a few tactics, whose details we won't explain, but which
   * streamline the individual program proofs below. *)
  Ltac basic := apply HtReturn || eapply HtRead || eapply HtWrite.
  Ltac step0 := basic || eapply HtBind || (eapply HtStrengthen; [ basic | ]).
  Ltac step := step0; simp.
  Ltac ht := simp; repeat step; eauto.
  Ltac conseq := simplify; eapply HtConsequence.
  Ltac use_IH H := conseq; [ apply H | .. ]; ht.

  Notation "{{ h ~> P }} c {{ r & h' ~> Q }}" :=
    (hoare_triple (fun h => P) c (fun r h' => Q)) (at level 90, c at next level).

  Lemma array_max_ok' : forall len i acc,
    {{ h ~> forall j, i <= j < len -> h $! j <= acc }}
      array_max i acc
    {{ r&h ~> forall j, j < len -> h $! j <= r }}.
  Proof.
    induct i; ht.
    use_IH IHi.
    cases (j ==n i); simp.
    assert (h $! j <= acc) by auto.
    linear_arithmetic.
  Qed.

  Theorem array_max_ok : forall len,
    {{ _ ~> True }}
      array_max len 0
    {{ r&h ~> forall i, i < len -> h $! i <= r }}.
  Proof.
    conseq.
    apply array_max_ok' with (len := len).
    simp.
    simp.
    auto.
  Qed.

  Lemma increment_all_ok' : forall len h0 i,
    {{ h ~> (forall j, j < i -> h $! j = h0 $! j)
       /\ (forall j, i <= j < len -> h $! j = S (h0 $! j)) }}
      increment_all i
    {{ _&h ~> forall j, j < len -> h $! j = S (h0 $! j) }}.
  Proof.
    induct i; ht.
    use_IH IHi.
    cases (j ==n i); simp.
    auto.
    auto.
  Qed.

  Theorem increment_all_ok : forall len h0,
    {{ h ~> h = h0 }}
      increment_all len
    {{ _&h ~> forall j, j < len -> h $! j = S (h0 $! j) }}.
  Proof.
    conseq.
    apply increment_all_ok' with (len := len).
    simp.
    simp.
    auto.
  Qed.

  (* It's easy to prove the syntactic Hoare-triple relation sound with
   * respect to the semantic one from the shallow embedding. *)
  Theorem hoare_triple_sound : forall P {result} (c : cmd result) Q,
      hoare_triple P c Q
      -> forall h, P h
                   -> let (h', r) := interp c h in
                      Q r h'.
  Proof.
    induct 1; simplify; propositional; eauto.

    specialize (IHhoare_triple h).
    cases (interp c1 h).
    apply H1; eauto.

    specialize (IHhoare_triple h).
    cases (interp c h).
    eauto.
  Qed.

  (* We use Coq's *extraction* feature to produce OCaml versions of our deeply
   * embedded programs.  Then we can run them using OCaml intepreters, which are
   * able to take advantage of the side effects built into OCaml, as a
   * performance optimization.  This command generates file "Deep.ml", which can
   * be loaded along with "DeepInterp.ml" to run the generated code.  Note how
   * the latter file uses OCaml's built-in mutable hash-table type for efficient
   * representation of program memories. *)
  Extraction "Deep.ml" array_max increment_all.
End Deep.

(** * A slightly fancier deep embedding, adding unbounded loops *)

Module Deeper.
  (* All programs in the last embedding must terminate, but let's add loops with
   * the potential to run forever, which takes us beyond what is representable
   * in the shallow embedding, since Gallina enforces terminating of all
   * programs. *)

  (* We use this type to represent the outcome of a single loop iteration.
   * These are functional loops, where we successively modify an accumulator
   * value across iterations. *)
  Inductive loop_outcome acc :=
  | Done (a : acc)  (* The loop finished, and here is the final accumulator. *)
  | Again (a : acc) (* Keep looping, with this new accumulator. *).

  Inductive cmd : Set -> Type :=
  | Return {result : Set} (r : result) : cmd result
  | Bind {result result'} (c1 : cmd result') (c2 : result' -> cmd result) : cmd result
  | Read (a : nat) : cmd nat
  | Write (a v : nat) : cmd unit
  | Loop {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) : cmd acc.

  (* Again, it's all easier to explain with an example. *)

  Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 80).
  Notation "'for' x := i 'loop' c1 'done'" := (Loop i (fun x => c1)) (right associativity, at level 80).

  (* This program finds the first occurrence in memory of value [needle]. *)
  Definition index_of (needle : nat) : cmd nat :=
    for i := 0 loop
      h_i <- Read i;
      if h_i ==n needle then
        Return (Done i)
      else
        Return (Again (S i))
    done.

  (* Next, we write a single-stepping interpreter for this language.  We can
   * no longer write a straightforward big-stepping interpeter, as programs of
   * the object language can diverge, while Gallina enforces termination. *)

  Inductive stepResult (result : Set) :=
  | Answer (r : result)
  | Stepped (h : heap) (c : cmd result).

  Fixpoint step {result} (c : cmd result) (h : heap) : stepResult result :=
    match c with
    | Return _ r => Answer r
    | Bind _ _ c1 c2 =>
      match step c1 h with
      | Answer r => Stepped h (c2 r)
      | Stepped h' c1' => Stepped h' (Bind c1' c2)
      end
    | Read a => Answer (h $! a)
    | Write a v => Stepped (h $+ (a, v)) (Return tt)
    | Loop _ init body =>
      Stepped h (r <- body init;
                 match r with
                 | Done r' => Return r'
                 | Again r' => Loop r' body
                 end)
    end.

  Fixpoint multiStep {result} (c : cmd result) (h : heap) (n : nat) : stepResult result :=
    match n with
    | O => Stepped h c
    | S n' => match step c h with
              | Answer r => Answer r
              | Stepped h' c' => multiStep c' h' n'
              end
    end.

  Example run_index_of : multiStep (index_of 6) h0 20 = Answer 3.
  Proof.
    unfold h0.
    simplify.
    reflexivity.
  Qed.

  Inductive hoare_triple : assertion -> forall {result}, cmd result -> (result -> assertion) -> Prop :=
  | HtReturn : forall P {result : Set} (v : result),
      hoare_triple P (Return v) (fun r h => P h /\ r = v)
  | HtBind : forall P {result' result} (c1 : cmd result') (c2 : result' -> cmd result) Q R,
      hoare_triple P c1 Q
      -> (forall r, hoare_triple (Q r) (c2 r) R)
      -> hoare_triple P (Bind c1 c2) R
  | HtRead : forall P a,
      hoare_triple P (Read a) (fun r h => P h /\ r = h $! a)
  | HtWrite : forall P a v,
      hoare_triple P (Write a v) (fun _ h => exists h', P h' /\ h = h' $+ (a, v))
  | HtConsequence : forall {result} (c : cmd result) P Q (P' : assertion) (Q' : _ -> assertion),
      hoare_triple P c Q
      -> (forall h, P' h -> P h)
      -> (forall r h, Q r h -> Q' r h)
      -> hoare_triple P' c Q'

  | HtLoop : forall {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc))
                    (I : loop_outcome acc -> assertion),
      (forall acc, hoare_triple (I (Again acc)) (body acc) I)
      -> hoare_triple (I (Again init)) (Loop init body) (fun r h => I (Done r) h).
  (* The loop rule contains a tricky new kind of invariant, parameterized on the
   * current loop state: either [Done] for a finished loop or [Again] for a loop
   * still in progress. *)

  Notation "{{ h ~> P }} c {{ r & h' ~> Q }}" :=
    (hoare_triple (fun h => P) c (fun r h' => Q)) (at level 90, c at next level).

  Lemma HtStrengthen : forall {result} (c : cmd result) P Q (Q' : _ -> assertion),
      hoare_triple P c Q
      -> (forall r h, Q r h -> Q' r h)
      -> hoare_triple P c Q'.
  Proof.
    simplify.
    eapply HtConsequence; eauto.
  Qed.

  Lemma HtWeaken : forall {result} (c : cmd result) P Q (P' : assertion),
      hoare_triple P c Q
      -> (forall h, P' h -> P h)
      -> hoare_triple P' c Q.
  Proof.
    simplify.
    eapply HtConsequence; eauto.
  Qed.

  Ltac basic := apply HtReturn || eapply HtRead || eapply HtWrite.
  Ltac step0 := basic || eapply HtBind || (eapply HtStrengthen; [ basic | ]).
  Ltac step := step0; simp.
  Ltac ht := simp; repeat step; eauto.
  Ltac conseq := simplify; eapply HtConsequence.
  Ltac use_IH H := conseq; [ apply H | .. ]; ht.
  Ltac loop_inv Inv := eapply HtConsequence; [ apply HtLoop with (I := Inv) | .. ]; ht.

  (* We prove our [index_of] example correct, relying crucially on a tactic
   * [loop_inv] to prove a loop by giving its loop invariant, which, recall, is
   * parameterized on a [loop_outcome]. *)
  Theorem index_of_ok : forall hinit needle,
    {{ h ~> h = hinit }}
      index_of needle
    {{ r&h ~> h = hinit
         /\ hinit $! r = needle
         /\ forall i, i < r -> hinit $! i <> needle }}.
  Proof.
    simplify.
    loop_inv (fun r h => h = hinit
                         /\ match r with
                            | Done r' => hinit $! r' = needle
                                         /\ forall i, i < r' -> hinit $! i <> needle
                            | Again r' => forall i, i < r' -> hinit $! i <> needle
                            end).
    cases (r ==n needle); ht.
    cases (i ==n acc); simp.
    apply H3 with (i0 := i); auto.
  Qed.

  (* The single-stepping interpreter forms the basis for defining transition
   * systems from commands. *)
  Definition trsys_of {result} (c : cmd result) (h : heap) := {|
    Initial := {(c, h)};
    Step := fun p1 p2 => step (fst p1) (snd p1) = Stepped (snd p2) (fst p2)
  |}.

  (* We now prove soundness of [hoare_triple], starting from a number of
   * inversion lemmas for it, collapsing the potential effects of many nested
   * rule-of-consequence applications. *)

  Lemma invert_Return : forall {result : Set} (r : result) P Q,
    hoare_triple P (Return r) Q
    -> forall h, P h -> Q r h.
  Proof.
    induct 1; propositional; eauto.
  Qed.

  Lemma invert_Bind : forall {result' result} (c1 : cmd result') (c2 : result' -> cmd result) P Q,
    hoare_triple P (Bind c1 c2) Q
    -> exists R, hoare_triple P c1 R
                 /\ forall r, hoare_triple (R r) (c2 r) Q.
  Proof.
    induct 1; propositional; eauto.

    invert IHhoare_triple; propositional.
    eexists; propositional.
    eapply HtWeaken.
    eassumption.
    auto.
    eapply HtStrengthen.
    apply H4.
    auto.
  Qed.

  (* Highly technical point: in some of the inductions below, we wind up needing
   * to show that the cases for [Read] and [Write] can never overlap, which
   * would imply that they have the same result types, which would mean that the
   * types [unit] and [nat] are equal. *)
  Lemma unit_not_nat : unit = nat -> False.
  Proof.
    simplify.
    assert (exists x : unit, forall y : unit, x = y).
    exists tt; simplify.
    cases y; reflexivity.
    rewrite H in H0.
    invert H0.
    specialize (H1 (S x)).
    linear_arithmetic.
  Qed.

  Lemma invert_Read : forall a P Q,
    hoare_triple P (Read a) Q
    -> forall h, P h -> Q (h $! a) h.
  Proof.
    induct 1; propositional; eauto.
    apply unit_not_nat in x0.
    propositional.
  Qed.

  Lemma invert_Write : forall a v P Q,
    hoare_triple P (Write a v) Q
    -> forall h, P h -> Q tt (h $+ (a, v)).
  Proof.
    induct 1; propositional; eauto.
    symmetry in x0.
    apply unit_not_nat in x0.
    propositional.
  Qed.

  Lemma invert_Loop : forall {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) P Q,
      hoare_triple P (Loop init body) Q
      -> exists I, (forall acc, hoare_triple (I (Again acc)) (body acc) I)
                   /\ (forall h, P h -> I (Again init) h)
                   /\ (forall r h, I (Done r) h -> Q r h).
  Proof.
    induct 1; propositional; eauto.

    invert IHhoare_triple; propositional.
    exists x; propositional; eauto.
  Qed.

  Lemma step_sound : forall {result} (c : cmd result) h Q,
      hoare_triple (fun h' => h' = h) c Q
      -> match step c h with
         | Answer r => Q r h
         | Stepped h' c' => hoare_triple (fun h'' => h'' = h') c' Q
         end.
  Proof.
    induct c; simplify; propositional.

    eapply invert_Return.
    eauto.
    simplify; auto.

    apply invert_Bind in H0.
    invert H0; propositional.
    apply IHc in H0.
    cases (step c h); auto.
    econstructor.
    apply H2.
    equality.
    auto.
    econstructor; eauto.

    eapply invert_Read; eauto.
    simplify; auto.

    eapply HtStrengthen.
    econstructor.
    simplify; propositional; subst.
    eapply invert_Write; eauto.
    simplify; auto.

    apply invert_Loop in H0.
    invert H0; propositional.
    econstructor.
    eapply HtWeaken.
    apply H0.
    equality.
    simplify.
    cases r.
    eapply HtStrengthen.
    econstructor.
    simplify.
    propositional; subst; eauto.
    eapply HtStrengthen.
    eapply HtLoop.
    auto.
    simplify.
    eauto.
  Qed.

  (* Clever choice of strengthened invariant here: intermediate commands are
   * checked against degenerate preconditions that force equality to the current
   * heap, and the postcondition is preserved across all steps. *)
  Lemma hoare_triple_sound' : forall P {result} (c : cmd result) Q,
      hoare_triple P c Q
      -> forall h, P h
                   -> invariantFor (trsys_of c h)
                                   (fun p => hoare_triple (fun h => h = snd p)
                                                          (fst p)
                                                          Q).
  Proof.
    simplify.

    apply invariant_induction; simplify.

    propositional; subst; simplify.
    eapply HtConsequence.
    eassumption.
    equality.
    auto.

    eapply step_sound in H1.
    rewrite H2 in H1.
    auto.
  Qed.

  (* Proving: if we reach a [Return] state, the postcondition holds. *)
  Theorem hoare_triple_sound : forall P {result} (c : cmd result) Q,
      hoare_triple P c Q
      -> forall h, P h
                   -> invariantFor (trsys_of c h)
                                   (fun p => forall r, fst p = Return r
                                                       -> Q r (snd p)).
  Proof.
    simplify.

    eapply invariant_weaken.
    eapply hoare_triple_sound'; eauto.
    simplify.
    rewrite H2 in H1.
    eapply invert_Return; eauto.
    simplify; auto.
  Qed.

  Extraction "Deeper.ml" index_of.
End Deeper.

(** * Adding the possibility of program failure *)

(* Let's model another effect that can be implemented using native OCaml
 * features.  We'll add a very basic form of exceptions, namely just one
 * (uncatchable) exception, for program failure.  We'll prove, by the end, that
 * verified programs never throw the exception. *)

Module DeeperWithFail.
  Inductive loop_outcome acc :=
  | Done (a : acc)
  | Again (a : acc).

  Inductive cmd : Set -> Type :=
  | Return {result : Set} (r : result) : cmd result
  | Bind {result result'} (c1 : cmd result') (c2 : result' -> cmd result) : cmd result
  | Read (a : nat) : cmd nat
  | Write (a v : nat) : cmd unit
  | Loop {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) : cmd acc
  | Fail {result} : cmd result.

  Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 80).
  Notation "'for' x := i 'loop' c1 'done'" := (Loop i (fun x => c1)) (right associativity, at level 80).

  (* This program loops forever, maintaining a tally in memory address 0.
   * We periodically test that address, failing if it's ever found to be 0. *)
  Definition forever : cmd nat :=
    _ <- Write 0 1;
    for i := 1 loop
      h_i <- Read i;
      acc <- Read 0;
      match acc with
      | 0 => Fail
      | _ =>
        _ <- Write 0 (acc + h_i);
        Return (Again (i + 1))
      end
    done.

  (* We adapt our single-stepper with a new result kind, for failure. *)

  Inductive stepResult (result : Set) :=
  | Answer (r : result)
  | Stepped (h : heap) (c : cmd result)
  | Failed.

  Implicit Arguments Failed [result].

  Fixpoint step {result} (c : cmd result) (h : heap) : stepResult result :=
    match c with
    | Return _ r => Answer r
    | Bind _ _ c1 c2 =>
      match step c1 h with
      | Answer r => Stepped h (c2 r)
      | Stepped h' c1' => Stepped h' (Bind c1' c2)
      | Failed => Failed
      end
    | Read a => Answer (h $! a)
    | Write a v => Stepped (h $+ (a, v)) (Return tt)
    | Loop _ init body =>
      Stepped h (r <- body init;
                 match r with
                 | Done r' => Return r'
                 | Again r' => Loop r' body
                 end)
    | Fail _ => Failed
    end.

  Fixpoint multiStep {result} (c : cmd result) (h : heap) (n : nat) : stepResult result :=
    match n with
    | O => Stepped h c
    | S n' => match step c h with
              | Answer r => Answer r
              | Stepped h' c' => multiStep c' h' n'
              | Failed => Failed
              end
    end.

  Extraction "DeeperWithFail.ml" forever.

  Inductive hoare_triple : assertion -> forall {result}, cmd result -> (result -> assertion) -> Prop :=
  | HtReturn : forall P {result : Set} (v : result),
      hoare_triple P (Return v) (fun r h => P h /\ r = v)
  | HtBind : forall P {result' result} (c1 : cmd result') (c2 : result' -> cmd result) Q R,
      hoare_triple P c1 Q
      -> (forall r, hoare_triple (Q r) (c2 r) R)
      -> hoare_triple P (Bind c1 c2) R
  | HtRead : forall P a,
      hoare_triple P (Read a) (fun r h => P h /\ r = h $! a)
  | HtWrite : forall P a v,
      hoare_triple P (Write a v) (fun _ h => exists h', P h' /\ h = h' $+ (a, v))
  | HtConsequence : forall {result} (c : cmd result) P Q (P' : assertion) (Q' : _ -> assertion),
      hoare_triple P c Q
      -> (forall h, P' h -> P h)
      -> (forall r h, Q r h -> Q' r h)
      -> hoare_triple P' c Q'

  | HtLoop : forall {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) I,
      (forall acc, hoare_triple (I (Again acc)) (body acc) I)
      -> hoare_triple (I (Again init)) (Loop init body) (fun r h => I (Done r) h)

  | HtFail : forall {result},
      hoare_triple (fun _ => False) (Fail (result := result)) (fun _ _ => False).
    (* The rule for [Fail] simply enforces that this command can't be reachable,
     * since it gets an unsatisfiable precondition. *)

  Notation "{{ h ~> P }} c {{ r & h' ~> Q }}" :=
    (hoare_triple (fun h => P) c (fun r h' => Q)) (at level 90, c at next level).

  Lemma HtStrengthen : forall {result} (c : cmd result) P Q (Q' : _ -> assertion),
      hoare_triple P c Q
      -> (forall r h, Q r h -> Q' r h)
      -> hoare_triple P c Q'.
  Proof.
    simplify.
    eapply HtConsequence; eauto.
  Qed.

  Lemma HtWeaken : forall {result} (c : cmd result) P Q (P' : assertion),
      hoare_triple P c Q
      -> (forall h, P' h -> P h)
      -> hoare_triple P' c Q.
  Proof.
    simplify.
    eapply HtConsequence; eauto.
  Qed.

  Ltac basic := apply HtReturn || eapply HtRead || eapply HtWrite.
  Ltac step0 := basic || eapply HtBind || (eapply HtStrengthen; [ basic | ])
                || (eapply HtConsequence; [ apply HtFail | .. ]).
  Ltac step := step0; simp.
  Ltac ht := simp; repeat step.
  Ltac conseq := simplify; eapply HtConsequence.
  Ltac use_IH H := conseq; [ apply H | .. ]; ht.
  Ltac loop_inv0 Inv := (eapply HtWeaken; [ apply HtLoop with (I := Inv) | .. ])
                        || (eapply HtConsequence; [ apply HtLoop with (I := Inv) | .. ]).
  Ltac loop_inv Inv := loop_inv0 Inv; ht.

  Theorem forever_ok :
    {{ _ ~> True }}
      forever
    {{ _&_ ~> False }}.
  Proof.
    ht.
    loop_inv (fun (r : loop_outcome nat) h => h $! 0 > 0 /\ match r with
                                                            | Done _ => False
                                                            | _ => True
                                                            end).
    cases r1; ht.
  Qed.

  Definition trsys_of {result} (c : cmd result) (h : heap) := {|
    Initial := {(c, h)};
    Step := fun p1 p2 => step (fst p1) (snd p1) = Stepped (snd p2) (fst p2)
  |}.

  (* Next, we adapt the proof of soundness from before. *)

  Lemma invert_Return : forall {result : Set} (r : result) P Q,
    hoare_triple P (Return r) Q
    -> forall h, P h -> Q r h.
  Proof.
    induct 1; propositional; eauto.
  Qed.

  Lemma invert_Bind : forall {result' result} (c1 : cmd result') (c2 : result' -> cmd result) P Q,
    hoare_triple P (Bind c1 c2) Q
    -> exists R, hoare_triple P c1 R
                 /\ forall r, hoare_triple (R r) (c2 r) Q.
  Proof.
    induct 1; propositional; eauto.

    invert IHhoare_triple; propositional.
    eexists; propositional.
    eapply HtWeaken.
    eassumption.
    auto.
    eapply HtStrengthen.
    apply H4.
    auto.
  Qed.

  Lemma unit_not_nat : unit = nat -> False.
  Proof.
    simplify.
    assert (exists x : unit, forall y : unit, x = y).
    exists tt; simplify.
    cases y; reflexivity.
    rewrite H in H0.
    invert H0.
    specialize (H1 (S x)).
    linear_arithmetic.
  Qed.

  Lemma invert_Read : forall a P Q,
    hoare_triple P (Read a) Q
    -> forall h, P h -> Q (h $! a) h.
  Proof.
    induct 1; propositional; eauto.
    apply unit_not_nat in x0.
    propositional.
  Qed.

  Lemma invert_Write : forall a v P Q,
    hoare_triple P (Write a v) Q
    -> forall h, P h -> Q tt (h $+ (a, v)).
  Proof.
    induct 1; propositional; eauto.
    symmetry in x0.
    apply unit_not_nat in x0.
    propositional.
  Qed.

  Lemma invert_Loop : forall {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) P Q,
      hoare_triple P (Loop init body) Q
      -> exists I, (forall acc, hoare_triple (I (Again acc)) (body acc) I)
                   /\ (forall h, P h -> I (Again init) h)
                   /\ (forall r h, I (Done r) h -> Q r h).
  Proof.
    induct 1; propositional; eauto.

    invert IHhoare_triple; propositional.
    exists x; propositional; eauto.
  Qed.

  Lemma invert_Fail : forall result P Q,
    hoare_triple P (Fail (result := result)) Q
    -> forall h, P h -> False.
  Proof.
    induct 1; propositional; eauto.
  Qed.

  Lemma step_sound : forall {result} (c : cmd result) h Q,
      hoare_triple (fun h' => h' = h) c Q
      -> match step c h with
         | Answer r => Q r h
         | Stepped h' c' => hoare_triple (fun h'' => h'' = h') c' Q
         | Failed => False
         end.
  Proof.
    induct c; simplify; propositional.

    eapply invert_Return.
    eauto.
    simplify; auto.

    apply invert_Bind in H0.
    invert H0; propositional.
    apply IHc in H0.
    cases (step c h); auto.
    econstructor.
    apply H2.
    equality.
    auto.
    econstructor; eauto.

    eapply invert_Read; eauto.
    simplify; auto.

    eapply HtStrengthen.
    econstructor.
    simplify; propositional; subst.
    eapply invert_Write; eauto.
    simplify; auto.

    apply invert_Loop in H0.
    invert H0; propositional.
    econstructor.
    eapply HtWeaken.
    apply H0.
    equality.
    simplify.
    cases r.
    eapply HtStrengthen.
    econstructor.
    simplify.
    propositional; subst; eauto.
    eapply HtStrengthen.
    eapply HtLoop.
    auto.
    simplify.
    eauto.

    eapply invert_Fail; eauto.
    simplify; eauto.
  Qed.

  Lemma hoare_triple_sound' : forall P {result} (c : cmd result) Q,
      hoare_triple P c Q
      -> forall h, P h
                   -> invariantFor (trsys_of c h)
                                   (fun p => hoare_triple (fun h => h = snd p)
                                                          (fst p)
                                                          Q).
  Proof.
    simplify.

    apply invariant_induction; simplify.

    propositional; subst; simplify.
    eapply HtConsequence.
    eassumption.
    equality.
    auto.

    eapply step_sound in H1.
    rewrite H2 in H1.
    auto.
  Qed.

  Theorem hoare_triple_sound : forall P {result} (c : cmd result) Q,
      hoare_triple P c Q
      -> forall h, P h
                   -> invariantFor (trsys_of c h)
                                   (fun p => step (fst p) (snd p) <> Failed).
  Proof.
    simplify.

    eapply invariant_weaken.
    eapply hoare_triple_sound'; eauto.
    simplify.
    eapply step_sound in H1.
    cases (step (fst s) (snd s)); equality.
  Qed.

  (** ** Showcasing the opportunity to create new programming abstractions,
       * without modifying the language definition *)

  (* Here's an example of a new programming construct defined within Gallina,
   * without extending the definition of object-language syntax.  It's for
   * folding a command over every one of the first [len] cells in memory.  We
   * work with some accumulator type [A], initializing the accumulator to [init]
   * and calling [combine] to update the accumulator for each value we read out
   * of memory. *)
  Definition heapfold {A : Set} (init : A) (combine : A -> nat -> cmd A) (len : nat) : cmd A :=
    p <- for p := (0, init) loop
           if len <=? fst p then
             Return (Done p)
           else
             h_i <- Read (fst p);
             acc <- combine (snd p) h_i;
             Return (Again (S (fst p), acc))
         done;
    Return (snd p).

  (* Next, two pretty mundane facts about list operations. *)

  Lemma firstn_nochange : forall A (ls : list A) n,
      length ls <= n
      -> firstn n ls = ls.
  Proof.
    induct ls; simplify.

    cases n; simplify; auto.

    cases n; simplify.
    linear_arithmetic.
    rewrite IHls; auto.
  Qed.

  Lemma fold_left_firstn : forall A B (f : A -> B -> A) (d : B) (ls : list B) (init : A) n,
      n < length ls
      -> f (fold_left f (firstn n ls) init) (nth_default d ls n)
         = fold_left f (firstn (S n) ls) init.
  Proof.
    induct ls; simplify.
    linear_arithmetic.
    cases n; simplify.
    unfold nth_default; simplify.
    reflexivity.
    rewrite <- IHls by linear_arithmetic.
    unfold nth_default; simplify.
    reflexivity.
  Qed.

  Hint Rewrite firstn_nochange fold_left_firstn using linear_arithmetic.

  (* Here's the soundness theorem for [heapfold], relying on a hypothesis of
   * soundness for [combine]. *)
  Theorem heapfold_ok : forall {A : Set} (init : A) combine
                               (ls : list nat) (f : A -> nat -> A),
    (forall P v acc,
      {{h ~> P h}}
        combine acc v
      {{r&h ~> r = f acc v /\ P h}})
    -> {{h ~> forall i, i < length ls -> h $! i = nth_default 0 ls i}}
         heapfold init combine (length ls)
       {{r&h ~> (forall i, i < length ls -> h $! i = nth_default 0 ls i)
           /\ r = fold_left f ls init}}.
  Proof.
    ht.
    loop_inv (fun r h => (forall i, i < length ls -> h $! i = nth_default 0 ls i)
                         /\ match r with
                            | Done (_, acc) => acc = fold_left f ls init
                            | Again (i, acc) => acc = fold_left f (firstn i ls) init
                            end).
    cases (length ls <=? a); ht; auto; simp; auto.
    rewrite H2 by assumption.
    simplify.
    reflexivity.
    simp; auto.
    simp.
  Qed.

  (* Here's a concrete use of [heapfold], to implement [array_max] more
   * succinctly. *)
  Definition array_max (len : nat) : cmd nat :=
    heapfold 0 (fun n m => Return (max n m)) len.

  (* Next, some more lemmas about lists and arithmetic *)

  Lemma le_max' : forall v ls acc,
      v <= acc
      -> v <= fold_left max ls acc.
  Proof.
    induct ls; simplify; auto.
  Qed.

  Lemma le_max : forall ls i acc,
      i < Datatypes.length ls
      -> nth_default 0 ls i <= fold_left max ls acc.
  Proof.
    induct ls; simplify.

    linear_arithmetic.

    cases i; simplify.
    unfold nth_default; simplify.
    apply le_max'; linear_arithmetic.
    unfold nth_default; simplify.
    apply IHls; linear_arithmetic.
  Qed.

  Hint Resolve le_max.

  (* Finally, a short proof of [array_max], appealing mostly to the generic
   * proof of [heapfold] *)
  Theorem array_max_ok : forall ls : list nat,
    {{ h ~> forall i, i < length ls -> h $! i = nth_default 0 ls i}}
      array_max (length ls)
    {{ r&h ~> forall i, i < length ls -> h $! i <= r }}.
  Proof.
    conseq.
    apply heapfold_ok with (f := max); ht.
    simp; auto.
    simp.
    rewrite H1 by assumption.
    auto.
  Qed.
End DeeperWithFail.