(* * Natural Deduction *)

From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability.FOL Require Import Syntax.Facts Syntax.Theories.
From Undecidability.FOL Require Export Deduction.FragmentNDFacts.
From Undecidability.FOL.Semantics.Tarski Require Export FragmentFacts FragmentSoundness.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.
Require Import Lia.
Import FragmentSyntax.

Set Default Proof Using "Type".

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Section Consistency.
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Context {p : peirce}.

  #[local] Existing Instance TM.

  Lemma consistent_ND : ~ ([] ⊢ ⊥).
  Proof.
    intros H. unshelve eapply (sound_for_classical_model _ H).
    - exact (fun _ => tt).
    - intros rho phi psi. cbn.
      destruct (TM_sat_decidable rho phi) as [Hl1|Hr1],
               (TM_sat_decidable rho psi) as [Hl2|Hr2]; tauto.
    - easy.
  Qed.

End Consistency.


From iris_time Require Import Base.
From iris.base_logic Require Import invariants.
From iris.algebra Require Import lib.gmap_view.
From iris.proofmode Require Import coq_tactics.
From iris_time.heap_lang Require Import proofmode notation adequacy lang.
From iris_time Require Import Auth_nat Auth_max_nat Reduction Tactics.
From iris_time Require Export Simulation.

Implicit Type e : expr.
Implicit Type v : val.
Implicit Type σ : state.
Implicit Type t : list expr.
Implicit Type K : ectx heap_ectx_lang.
Implicit Type m n max_tc max_tr : nat.
Implicit Type φ ψ : val → Prop.
Implicit Type Σ : gFunctors.

(*
 * Combined abstract interface for time credits and receipts
 *)

(* Ideally, this would be represented as a record (or a typeclass), but it has
 * to be an Iris proposition (iProp Σ) and not a Coq proposition (Prop). *)
Definition TCTR_interface `{irisGS heap_lang Σ, Tick}
  (TC : nat → iProp Σ)
  (max_tr : nat)
  (TR : nat → iProp Σ)
  (TRdup : nat → iProp Σ)
: iProp Σ := (
    ⌜∀ n, Timeless (TC n)⌝
  ∗ (|==> TC 0%nat)
  ∗ ⌜∀ m n, TC (m + n)%nat ≡ (TC m ∗ TC n)⌝
  ∗ ⌜∀ n, Timeless (TR n)⌝
  ∗ ⌜∀ n, Timeless (TRdup n)⌝
  ∗ ⌜∀ n, Persistent (TRdup n)⌝
  ∗ (∀ n, TR n ={⊤}=∗ TR n ∗ TRdup n)
  ∗ (|==> TR 0%nat)
(*   ∗ (|==> TRdup 0%nat) *)
  ∗ ⌜∀ m n, TR (m + n)%nat ≡ (TR m ∗ TR n)⌝
  ∗ ⌜∀ m n, TRdup (m `max` n)%nat ≡ (TRdup m ∗ TRdup n)⌝
(*   ∗ (TR max_tr ={⊤}=∗ False) *)
  ∗ (TRdup max_tr ={⊤}=∗ False)
  ∗ (∀ v n, {{{ TC 1%nat ∗ TRdup n }}} tick v {{{ RET v ; TR 1%nat ∗ TRdup (n+1)%nat }}})
)%I.

(*
 * Prerequisites on the global monoid Σ
 *)

Class tctrHeapPreG Σ := {
  tctrHeapPreG_heapPreG :> heapGpreS Σ ;
  tctrHeapPreG_inG_TC    :> inG Σ (authR natUR) ;
  tctrHeapPreG_inG_TR    :> inG Σ (authR natUR) ;
  tctrHeapPreG_inG_TRdup :> inG Σ (authR max_natUR) ;
}.

Class UseTC := useTC : bool.

Class tctrHeapG Σ := {
  tctrHeapG_heapG :> heapGS Σ ;
  tctrHeapG_inG_TC    :> inG Σ (authR natUR) ;
  tctrHeapG_inG_TR    :> inG Σ (authR natUR) ;
  tctrHeapG_inG_TRdup :> inG Σ (authR max_natUR) ;
  tctrHeapG_loc :> TickCounter ;
  tctrHeapG_name_TC    : gname ;
  tctrHeapG_name_TR    : gname ;
  tctrHeapG_name_TRdup : gname ;
  tctrHeapG_useTC      :> UseTC ;
}.

Local Notation γ := tctrHeapG_name_TC.
Local Notation γ1 := tctrHeapG_name_TR.
Local Notation γ2 := tctrHeapG_name_TRdup.
Local Notation ℓ := tick_counter.

(*
 * Implementation and specification of `tick`, `TC`, `TR` and `TRdup`
 *)

Definition fail : val :=
  λ: <>, #() #().

Definition loop : val :=
  rec: "f" <> := "f" #().

Global Instance tctr_tick {_:TickCounter} {_:UseTC} : Tick :=
  generic_tick (if useTC then fail else loop).

Section Definitions.

  Context `{tctrHeapG Σ}.

  Definition TC (n : nat) : iProp Σ :=
    if useTC then own γ (◯nat n) else True%I.

  (* Note: we can avoid the update modality by redefining TC like so:
         Definition TC' n : iProp Σ := ⌜n = 0%nat⌝ ∨ TC n. *)
  Lemma zero_TC :
    ⊢ |==> TC 0.
  Proof using.
    rewrite /TC ; destruct useTC.
    - by apply own_unit.
    - by iStartProof.
  Qed.
  Lemma TC_plus m n :
    TC (m + n) ≡ (TC m ∗ TC n)%I.
  Proof using.
    rewrite /TC ; destruct useTC.
    - by rewrite auth_frag_op own_op.
    - by iStartProof.
  Qed.
  Lemma TC_succ n :
    TC (S n) ≡ (TC 1%nat ∗ TC n)%I.
  Proof using. by rewrite (eq_refl : S n = 1 + n)%nat TC_plus. Qed.
  Lemma TC_weaken (n₁ n₂ : nat) :
    (n₂ ≤ n₁)%nat →
    TC n₁ -∗ TC n₂.
  Proof using.
    rewrite /TC ; destruct useTC.
    - by apply own_auth_nat_weaken.
    - done.
  Qed.

  Lemma TC_timeless n :
    Timeless (TC n).
  Proof using. rewrite /TC ; destruct useTC ; exact _. Qed.

  (* We give higher priorities to the (+) instances so that the (S n)
     instances are not chosen when m is a constant. *)
  Global Instance into_sep_TC_plus m n : IntoSep (TC (m + n)) (TC m) (TC n) | 0.
  Proof using. by rewrite /IntoSep TC_plus. Qed.
  Global Instance from_sep_TC_plus m n : FromSep (TC (m + n)) (TC m) (TC n) | 0.
  Proof using. by rewrite /FromSep TC_plus. Qed.
  Global Instance into_sep_TC_succ n : IntoSep (TC (S n)) (TC 1) (TC n) | 100.
  Proof using. by rewrite /IntoSep TC_succ. Qed.
  Global Instance from_sep_TC_succ n : FromSep (TC (S n)) (TC 1) (TC n) | 100.
  Proof using. by rewrite /FromSep [TC (S n)] TC_succ. Qed.

  Definition TR (n : nat) : iProp Σ :=
    own γ1 (◯nat n).

  Definition TRdup (n : nat) : iProp Σ :=
    own γ2 (◯ MaxNat n).

  (* Note: we can avoid the update modality by redefining TR like so:
         Definition TR' n : iProp Σ := ⌜n = 0%nat⌝ ∨ TR n. *)
  Lemma zero_TR :
    ⊢ |==> TR 0.
  Proof using. apply own_unit. Qed.
  Lemma TR_plus m n :
    TR (m + n) ≡ (TR m ∗ TR n)%I.
  Proof using. by rewrite /TR auth_frag_op own_op. Qed.
  Lemma TR_succ n :
    TR (S n) ≡ (TR 1 ∗ TR n)%I.
  Proof using. by rewrite (eq_refl : S n = 1 + n)%nat TR_plus. Qed.
  Lemma TR_weaken (n₁ n₂ : nat) :
    (n₂ ≤ n₁)%nat →
    TR n₁ -∗ TR n₂.
  Proof using. apply own_auth_nat_weaken. Qed.

  Lemma TR_timeless n :
    Timeless (TR n).
  Proof using. exact _. Qed.

  (* We give higher priorities to the (+) instances so that the (S n)
     instances are not chosen when m is a constant. *)
  Global Instance into_sep_TR_plus m n : IntoSep (TR (m + n)) (TR m) (TR n) | 0.
  Proof using. by rewrite /IntoSep TR_plus. Qed.
  Global Instance from_sep_TR_plus m n : FromSep (TR (m + n)) (TR m) (TR n) | 0.
  Proof using. by rewrite /FromSep TR_plus. Qed.
  Global Instance into_sep_TR_succ n : IntoSep (TR (S n)) (TR 1) (TR n) | 100.
  Proof using. by rewrite /IntoSep TR_succ. Qed.
  Global Instance from_sep_TR_succ n : FromSep (TR (S n)) (TR 1) (TR n) | 100.
  Proof using. by rewrite /FromSep [TR (S n)] TR_succ. Qed.

  (* Note: we can avoid the update modality by redefining TRdup like so:
         Definition TRdup' n : iProp Σ := ⌜n = 0%nat⌝ ∨ TRdup n. *)
  Lemma zero_TRdup :
    ⊢ |==> TRdup 0.
  Proof using. apply own_unit. Qed.
  Lemma TRdup_max m n :
    TRdup (m `max` n) ≡ (TRdup m ∗ TRdup n)%I.
  Proof using. by rewrite /TRdup -own_op -auth_frag_op. Qed.
  Lemma TRdup_weaken (n₁ n₂ : nat) :
    (n₂ ≤ n₁)%nat →
    TRdup n₁ -∗ TRdup n₂.
  Proof using. apply own_auth_max_nat_weaken. Qed.

  Lemma TRdup_timeless n :
    Timeless (TRdup n).
  Proof using. exact _. Qed.
  Lemma TRdup_persistent n :
    Persistent (TRdup n).
  Proof using. exact _. Qed.

  Global Instance into_sep_TRdup_max m n : IntoSep (TRdup (m `max` n)) (TRdup m) (TRdup n).
  Proof using. by rewrite /IntoSep TRdup_max. Qed.
  Global Instance from_sep_TRdup_max m n : FromSep (TRdup (m `max` n)) (TRdup m) (TRdup n).
  Proof using. by rewrite /FromSep TRdup_max. Qed.

  Definition tctrN := nroot .@ "combinedTimeCreditTimeReceipt".

  Context (max_tr : nat).

  Definition TCTR_invariant : iProp Σ :=
    inv tctrN (
      ∃ (m:nat),
        ⌜(m < max_tr)%nat⌝
      ∗ ℓ ↦ #m
      ∗ (if useTC then own γ (●nat m) else True)
      ∗ own γ1 (●nat (max_tr - 1 - m))
      ∗ own γ2 (● MaxNat (max_tr - 1 - m))
    )%I.

  Lemma TR_nmax_absurd (E : coPset) :
    ↑tctrN ⊆ E →
    TCTR_invariant -∗ TR max_tr ={E}=∗ False.
  Proof using.
    iIntros (?) "#Inv Hγ1◯".
    iInv tctrN as (m) "(>I & _ & _ & >Hγ1● & _)" "InvClose" ; iDestruct "I" as %I.
    iDestruct (own_auth_nat_le with "Hγ1● Hγ1◯") as %I'.
    exfalso ; lia.
  Qed.
  Lemma TR_lt_nmax n (E : coPset) :
    ↑tctrN ⊆ E →
    TCTR_invariant -∗ TR n ={E}=∗ TR n ∗ ⌜n < max_tr⌝%nat.
  Proof using.
    iIntros (?) "#Inv Hγ1◯".
    destruct (le_lt_dec max_tr n) as [ I | I ] ; last by iFrame.
    iDestruct (TR_weaken n max_tr with "Hγ1◯") as "Hγ1◯" ; first done.
    iDestruct (TR_nmax_absurd with "Inv Hγ1◯") as ">?" ; first done.
    done.
  Qed.

  Lemma TRdup_nmax_absurd (E : coPset) :
    ↑tctrN ⊆ E →
    TCTR_invariant -∗ TRdup max_tr ={E}=∗ False.
  Proof using.
    iIntros (?) "#Inv Hγ2◯".
    iInv tctrN as (m) "(>I & _ & _ & _ & >Hγ2●)" "InvClose" ; iDestruct "I" as %I.
    iDestruct (own_auth_max_nat_le with "Hγ2● Hγ2◯") as %I'. exfalso ; lia.
  Qed.
  Lemma TRdup_lt_nmax n (E : coPset) :
    ↑tctrN ⊆ E →
    TCTR_invariant -∗ TRdup n ={E}=∗ TRdup n ∗ ⌜n < max_tr⌝%nat.
  Proof using.
    iIntros (?) "#Inv Hγ1◯".
    destruct (le_lt_dec max_tr n) as [ I | I ] ; last by iFrame.
    iDestruct (TRdup_weaken n max_tr with "Hγ1◯") as "Hγ1◯" ; first done.
    iDestruct (TRdup_nmax_absurd with "Inv Hγ1◯") as ">?" ; first done.
    done.
  Qed.

  Lemma TR_TRdup (E : coPset) n :
    ↑tctrN ⊆ E →
    TCTR_invariant -∗ TR n ={E}=∗ TR n ∗ TRdup n.
  Proof using.
    iIntros (?) "#Inv Hγ1◯".
    iInv tctrN as (m) "(>I & >Hℓ & Hγ● & >Hγ1● & >Hγ2●)" "InvClose".
    iDestruct (own_auth_nat_le with "Hγ1● Hγ1◯") as %I'.
    iDestruct (auth_max_nat_update_read_auth with "Hγ2●") as ">[Hγ2● Hγ2◯]".
    iAssert (TR n ∗ TRdup n)%I with "[$Hγ1◯ Hγ2◯]" as "$". {
      rewrite (_ : (max_tr-1-m) = (max_tr-1-m) `max` n)%nat ; last lia.
      iDestruct "Hγ2◯" as "[_ $]".
    }
    iApply "InvClose". auto with iFrame.
  Qed.

  Theorem loop_spec s E (Φ : val → iProp Σ) :
    ⊢ WP loop #() @ s ; E {{ Φ }}.
  Proof.
    iLöb as "IH". wp_rec. iExact "IH".
  Qed.

  Theorem tick_spec s E (v : val) n :
    ↑tctrN ⊆ E →
    TCTR_invariant -∗
    {{{ ▷ TC 1 ∗ ▷ TRdup n }}} tick v @ s ; E {{{ RET v ; TR 1 ∗ TRdup (n+1) }}}.
  Proof using.
    intros ?. iIntros "#Inv" (Ψ) "!# [Hγ◯ Hγ2◯] HΨ".
    iLöb as "IH".
    wp_lam.
    (* open the invariant, in order to read the value m of location ℓ: *)
    wp_bind (! _)%E ;
    iInv tctrN as (m) "(>I & >Hℓ & Hγ● & >Hγ1● & >Hγ2●)" "InvClose".
    wp_load.
    (* in the case where we are using time credits, deduce that m ≥ 1,
       because we hold a time credit: *)
    iAssert (⌜useTC = true⌝ -∗ ⌜1 ≤ m⌝)%I%nat with "[Hγ● Hγ◯]" as "#J".
    {
      rewrite /TC ; iIntros "->".
      by iApply (own_auth_nat_le with "Hγ● Hγ◯").
    }
    (* close the invariant: *)
    iMod ("InvClose" with "[ I Hℓ Hγ● Hγ1● Hγ2● ]") as "_" ; [ by auto with iFrame | iModIntro ].
    wp_let.
    (* test whether m ≤ 0: *)
    wp_op. case_bool_decide as J' ; wp_if.
    (* — if m ≤ 0: *)
    - destruct useTC.
      (* if we use TC, then m ≤ 0 is absurd, because we hold a time credit: *)
      + iDestruct ("J" with "[//]") as %J.
        exfalso ; lia.
      (* if we don’t, then we loop indefinitely, which gives us any spec we want
         (because we are reasoning in partial correctness): *)
      + iApply loop_spec.
    (* — otherwise: *)
    - wp_op.
      (* open the invariant again, in order to perform CAS on location ℓ: *)
      wp_bind (CAS _ _ _)%E ;
      iInv tctrN as (m') "(>I & >Hℓ & Hγ● & >Hγ1● & >Hγ2●)" "InvClose".
      (* test whether the value ℓ is still m, by comparing m with m': *)
      destruct (nat_eq_dec m m') as [ <- | Hneq ].
      (* — if it holds, then CAS succeeds and ℓ is decremented: *)
      + wp_cas_suc.
        (* reform the invariant with m−1 instead of m: *)
        replace (Z.of_nat m - 1) with (Z.of_nat (m - 1)%nat) by lia.
        iAssert (|==> if useTC then own γ (●nat (m-1)) else True)%I with "[Hγ● Hγ◯]" as ">Hγ●".
        {
          rewrite /TC ; destruct useTC ; last done.
          by iMod (auth_nat_update_decr _ _ _ 1 with "Hγ● Hγ◯") as "[$ _]".
        }
        iMod (auth_nat_update_incr _ _ 1 with "Hγ1●") as "[Hγ1● Hγ1◯]".
        iMod (auth_max_nat_update_incr' _ _ _ 1 with "Hγ2● Hγ2◯") as "[Hγ2● Hγ2◯]".
        iDestruct "I" as %I.
        replace (max_tr - 1 - m + 1)%nat with (max_tr - 1 - (m - 1))%nat by lia.
        assert ((m-1) < max_tr)%nat by lia.
        (* close the invariant: *)
        iMod ("InvClose" with "[ Hℓ Hγ● Hγ1● Hγ2● ]") as "_" ; [ by auto with iFrame | iModIntro ].
        (* finish: *)
        wp_if. iApply "HΨ" ; by iFrame.
      (* — otherwise, CAS fails and ℓ is unchanged: *)
      + wp_cas_fail ; first (injection ; lia).
        (* close the invariant as is: *)
        iMod ("InvClose" with "[ I Hℓ Hγ● Hγ1● Hγ2● ]") as "_" ; [ by auto with iFrame | iModIntro ].
        wp_if.
        (* conclude using the induction hypothesis: *)
        iApply ("IH" with "Hγ◯ Hγ2◯ HΨ").
  Qed.

  Theorem tick_spec_simple v n :
    TCTR_invariant -∗
    {{{ TC 1 ∗ TRdup n }}} tick v {{{ RET v ; TR 1 ∗ TRdup (n+1) }}}.
  Proof using.
    iIntros "#Hinv" (Ψ) "!# [ HTC HTR ] HΨ".
    by iApply (tick_spec with "Hinv [$HTC $HTR] HΨ").
  Qed.

  Lemma TC_implementation : TCTR_invariant -∗ TCTR_interface TC max_tr TR TRdup.
  Proof using.
    iIntros "#Hinv". repeat iSplitR.
    - iPureIntro. by apply TC_timeless.
    - by iApply zero_TC.
    - iPureIntro. by apply TC_plus.
    - iPureIntro. by apply TR_timeless.
    - iPureIntro. by apply TRdup_timeless.
    - iPureIntro. by apply TRdup_persistent.
    - iIntros (n). by iApply (TR_TRdup with "Hinv").
    - by iApply zero_TR.
    - iPureIntro. by apply TR_plus.
    - iPureIntro. by apply TRdup_max.
    - by iApply (TRdup_nmax_absurd with "Hinv").
    - iIntros (v n). by iApply (tick_spec_simple with "Hinv").
  Qed.

End Definitions.

(*
 * Proof-mode tactics for proving WP of translated expressions
 *)

Lemma tac_wp_tick `{tctrHeapG Σ} Δ pe Δ1 Δ2 Δ3 Δ' i i' n max_tc s E K (v : val) Φ :
  ↑tctrN ⊆ E →
  MaybeIntoLaterNEnvs 1 Δ Δ1 →

  envs_lookup i Δ = Some (pe, TCTR_invariant max_tc) →

  envs_lookup i' Δ1 = Some (false, TC (S n)) →
  envs_simple_replace i' false (Esnoc Enil i' (TC n)) Δ1 = Some Δ2 →

  (∃ j pe' p, envs_lookup j Δ2 = Some (pe', TRdup p) ∧
              envs_simple_replace j pe' (Esnoc Enil j (TRdup (S p))) Δ2 = Some Δ3) ∨
  Δ2 = Δ3 →

  (∃ j n, envs_lookup j Δ3 = Some (false, TR n) ∧
          envs_simple_replace j false (Esnoc Enil j (TR (S n))) Δ3 = Some Δ') ∨
  Δ3 = Δ' →

  envs_entails Δ' (WP fill K v @ s; E {{ Φ }}) →
  envs_entails Δ (WP fill K (App tick v) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=>??? HTC1 HTC2 HTRdup HTR HWP.
  iIntros "HΔ".
  iAssert (TCTR_invariant max_tc) as "#Hinv".
  { destruct pe.
    iDestruct (envs_lookup_sound _ i true with "HΔ") as "[? _]"=>//.
    iDestruct (envs_lookup_sound _ i false with "HΔ") as "[? _]"=>//. }
  iDestruct (into_laterN_env_sound with "HΔ") as "HΔ1"=>//.
  iDestruct (envs_simple_replace_singleton_sound with "HΔ1") as "[HTC HΔ2]"=>//=.
  iDestruct "HTC" as "[HTC HTC']". iDestruct ("HΔ2" with "HTC'") as "HΔ2".
  iApply wp_bind.
  destruct HTR as [(j & n' & HTR1 & HTR2)| ->],
           HTRdup as [(j' & pe'' & p & HTRDup1 & HTRDup2)| ->].
  - iDestruct (envs_simple_replace_singleton_sound with "HΔ2") as "[HTRdup HΔ3]"=>//.
    rewrite bi.intuitionistically_if_elim -bi.intuitionistically_intuitionistically_if.
    iDestruct "HTRdup" as "#>HTRdup".
    iApply (tick_spec with "[//] [$HTC $HTRdup]")=>//.
    iIntros "!> [HTR #HTRdup']". iApply HWP.
    rewrite Nat.add_comm. iSpecialize ("HΔ3" with "[//]").
    iDestruct (envs_simple_replace_singleton_sound with "HΔ3") as "[HTR' HΔ']"=>//=.
    iCombine "HTR HTR'" as "HTR". iDestruct ("HΔ'" with "HTR") as "$".
  - iMod zero_TRdup as "HTRdup".
    iApply (tick_spec with "[//] [$HTC $HTRdup]")=>//. iIntros "!> [HTR _]". iApply HWP.
    iDestruct (envs_simple_replace_singleton_sound with "HΔ2") as "[HTR' HΔ']"=>//=.
    iCombine "HTR HTR'" as "HTR". iDestruct ("HΔ'" with "HTR") as "$".
  - iDestruct (envs_simple_replace_singleton_sound with "HΔ2") as "[HTRdup HΔ']"=>//.
    rewrite bi.intuitionistically_if_elim -bi.intuitionistically_intuitionistically_if.
    iDestruct "HTRdup" as "#>HTRdup".
    iApply (tick_spec with "[//] [$HTC $HTRdup]")=>//. iIntros "!> [_ #HTRdup']".
    iApply HWP. rewrite Nat.add_comm. iDestruct ("HΔ'" with "[//]") as "$".
  - iMod zero_TRdup as "HTRdup".
    iApply (tick_spec with "[//] [$HTC $HTRdup]")=>//.
    iIntros "!> [_ #HTRdup']". by iApply HWP.
Qed.

Ltac wp_tick ::=
  iStartProof ;
  simpl_trans ;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
      first
        [ reshape_expr false e ltac:(fun K e' =>
            eapply (tac_wp_tick _ _ _ _ _ _ _ _ _ _ _ _ K)
          )
        | fail 1 "wp_tick: cannot find 'tick ?v' in" e ] ;
      [ try solve_ndisj
      | exact _
      | (* lookup invariant: *) (iAssumptionCore || fail "wp_tick: cannot find TR_invariant")
      | (* lookup TC *) (iAssumptionCore || fail "wp_tick: cannot find (TC (S _))")
      | (* replace TC *) proofmode.reduction.pm_reflexivity
      | (* lookup TRdup: *) (
        left; eexists _, _, _; split;
        [iAssumptionCore | proofmode.reduction.pm_reflexivity]
        || right; reflexivity)
      | (* lookup TR:    *) (
        left; eexists _, _; split;
        [iAssumptionCore | proofmode.reduction.pm_reflexivity]
        || right; reflexivity)
      | wp_expr_simpl ]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
      fail "wp_tick is not implemented for twp"
  | _ => fail "wp_tick: not a 'wp'"
  end.

(*
 * Simulation
 *)

Section Simulation.

  (* Simulation in the “successful” case. *)

  Context {Hloc : TickCounter}.
  Context {useTC : UseTC}.

  Lemma exec_tick_success n v σ :
    prim_exec  (tick v) (<[ℓ := #(S n)]> σ)  v (<[ℓ := #n]> σ)  [].
  Proof. by apply exec_tick_success. Qed.

  Definition simulation_exec_success := simulation_exec_success (if useTC then fail else loop).
  Definition simulation_exec_success' := simulation_exec_success' (if useTC then fail else loop).

  (* Simulation in the “failing” case. *)

  Context (HuseTC : useTC = true).

  Lemma not_safe_tick v σ :
    ¬ safe (tick v) (<[ℓ := #0]> σ).
  Proof.
    assert (prim_exec  (tick v) (<[ℓ := #0]> σ)  (#() #()) (<[ℓ := #0]> σ)  []) as Hexec.
    {
      unlock tick tctr_tick generic_tick fail ; rewrite HuseTC.
      eapply prim_exec_cons_nofork.
      { by prim_step. }
      simpl. eapply prim_exec_cons_nofork.
      { prim_step. apply lookup_insert. }
      simpl. eapply prim_exec_cons_nofork.
      { prim_step. }
      simpl. eapply prim_exec_cons_nofork.
      { by prim_step. }
      simpl. eapply prim_exec_cons_nofork.
      { by prim_step. }
      simpl. eapply prim_exec_cons_nofork.
      { by prim_step. }
      simpl. eapply prim_exec_cons_nofork.
      { by prim_step. }
      simpl. apply prim_exec_nil.
    }
    assert (¬ safe (#() #()) (<[ℓ := #0]> σ)) as Hnotsafe.
    {
      apply stuck_not_safe, head_stuck_stuck, ectxi_language_sub_redexes_are_values.
      - split ; first done. inversion 1.
      - intros [] ; try discriminate 1 ; inversion 1 ; by eauto.
    }
    intros Hsafe. eapply Hnotsafe, safe_exec_nofork, prim_exec_exec ; eassumption.
  Qed.

  Local Ltac not_safe_tick :=
    lazymatch goal with
    | |- ¬ safe ?e _ =>
        reshape_expr false e ltac:(fun K e' =>
          apply not_safe_fill' with K e' ; first reflexivity ;
          eapply not_safe_tick
        )
    end ;
    done.

  Lemma simulation_head_step_failure e1 σ1 κ e2 σ2 efs :
    head_step e1 σ1 κ e2 σ2 efs →
    ¬ safe «e1» S«σ1, 0».
  Proof.
    destruct 1 as
      [(* RecS *) f x e σ
      | | | | | | | | | | | |
      | (* ForkS *) e1 σ
      | | | | | | ] ;
    simpl_trans ;
    try not_safe_tick.
    (* RecS f x e σ : *)
    - eapply not_safe_prim_step ; last prim_step.
      not_safe_tick.
    (* ForkS e σ : *)
    - eapply not_safe_prim_step ; last prim_step.
      not_safe_tick.
  Qed.

  Lemma simulation_prim_step_failure e1 σ1 κ e2 σ2 efs :
    prim_step e1 σ1 κ e2 σ2 efs →
    ¬ safe «e1» S«σ1, 0».
  Proof.
    intros [ K e1' e2' -> -> H ].
    rewrite translation_fill.
    by eapply not_safe_fill, simulation_head_step_failure.
  Qed.

  Lemma simulation_step_failure t1 σ1 κ t2 σ2 :
    step (t1, σ1) κ (t2, σ2) →
    ∃ e1, e1 ∈ t1 ∧
    ¬ safe «e1» S«σ1, 0».
  Proof.
    intros [e1 σ1_ e2 σ2_ efs t t' E1 E2 Hstep] ;
    injection E1 as -> <- ; injection E2 as -> <-.
    exists e1 ; split ; first set_solver.
    by eapply simulation_prim_step_failure.
  Qed.

  Local Lemma simulation_exec_failure_now n t1 σ1 t2 σ2 :
    relations.nsteps erased_step (S n) (t1, σ1) (t2, σ2) →
    ∃ e1, e1 ∈ t1 ∧
    ¬ safe «e1» S«σ1, 0».
  Proof.
    make_eq (S n) as Sn En.
    make_eq (t1, σ1) as config1 E1.
    destruct 1 as [ ? | ? ? [] ? [? ?] _ ], E1.
    - discriminate En.
    - by eapply simulation_step_failure.
  Qed.

  Lemma simulation_exec_failure m n e1 σ1 t2 σ2 :
    σ2 !! ℓ = None →
    relations.nsteps erased_step (m + S n) ([e1], σ1) (t2, σ2) →
    ¬ safe «e1» S«σ1, m».
  Proof.
    intros Hℓ Hnsteps.
    assert (
      ∃ t3 σ3,
        rtc erased_step (T«[e1]», S«σ1, m») (T«t3», S«σ3, 0») ∧
        ∃ e3, e3 ∈ t3 ∧
        ¬ safe «e3» S«σ3, 0»
    ) as (t3 & σ3 & Hsteps & e3 & E3 & Hsafe).
    {
      apply nsteps_split in Hnsteps as ((t3, σ3) & Hnsteps1to3 & Hnsteps3to2).
      exists t3, σ3 ; repeat split.
      - assert (σ3 !! ℓ = None) by (eapply loc_fresh_in_dom_nsteps ; cycle 1 ; eassumption).
        replace m with (m+0)%nat by lia.
        apply simulation_exec_success ; assumption.
      - by eapply simulation_exec_failure_now.
    }
    apply (elem_of_list_fmap_1 translation) in E3.
    eapply not_safe_exec ; eassumption.
  Qed.

End Simulation.

(*
 * Soundness
 *)

Section Soundness.

(** Part of the proof of soundness which is specific to the case where
 ** time credits are used (m < max_tr). **)

  (* assuming the safety of the translated expression,
   * a proof that the computation time of the original expression is bounded. *)

  Local Lemma gt_sum m n :
    (m > n)%nat → ∃ (k : nat), m = (n + S k)%nat.
  Proof.
    intro. exists (m - S n)%nat. lia.
  Qed.

  Lemma safe_tctranslation__bounded {Hloc : TickCounter} {useTC : UseTC} m e σ t2 σ2 n :
    useTC = true →
    σ2 !! ℓ = None →
    safe «e» S«σ, m» →
    relations.nsteps erased_step n ([e], σ) (t2, σ2) →
    (n ≤ m)%nat.
  Proof.
    intros HuseTC Hfresh Hsafe Hnsteps.
    (* reasoning by contradiction: assume (n > m), ie. (n = m + S k) for some k: *)
    apply not_gt ; intros [k ->] % gt_sum.
    (* apply the simulation lemma: *)
    by eapply simulation_exec_failure.
  Qed.

  (* assuming the safety of the translated expression,
   * a proof that the original expression is safe. *)

  Lemma safe_tctranslation__safe_here {Hloc : TickCounter} {useTC : UseTC} m e σ :
    useTC = true →
    loc_fresh_in_expr ℓ e →
    safe «e» S«σ, m» →
    is_Some (to_val e) ∨ reducible e σ.
  Proof.
    intros HuseTC Hfresh Hsafe.
    (* case analysis on whether e is a value… *)
    destruct (to_val e) as [ v | ] eqn:Hnotval.
    (* — if e is a value, then we get the result immediately: *)
    - left. eauto.
    (* — if e is not a value, then we show that it is reducible: *)
    - right.
      (* we decompose e into a maximal evaluation context K and a head-redex: *)
      pose proof (not_val_fill_active_item _ Hnotval) as He ; clear Hnotval.
      destruct He as [ (K & x & ->) |
                     [ (K & e1 & ->) |
                     [ (K & f & x & e1 & ->) |
                       (K & ki & v & -> & Hactive) ]]].
      (* — either e = Var x: *)
      + (* then Var x is stuck *)
        exfalso. eapply stuck_not_safe; [|done]. rewrite translation_fill.
        apply stuck_fill, head_stuck_stuck.
        { split; [done|]. intros ???? Hstep. inversion Hstep. }
        apply ectxi_language_sub_redexes_are_values=>-[] //.
      (* — either e = K[Fork e1]: *)
      + (* then we easily derive a reduction from e: *)
        eexists _, _, _, _. apply Ectx_step', ForkS.
      (* — either e = K[Rec f x e1]: *)
      + (* then we easily derive a reduction from e: *)
        eexists _, _, _, _. apply Ectx_step', RecS.
      (* — or e = K[ki[v]] where ki is an active item: *)
      + (* it is enough to show that ki[v] is reducible: *)
        apply loc_fresh_in_expr_fill_inv in Hfresh ;
        rewrite -> translation_fill in Hsafe ; apply safe_fill_inv in Hsafe ;
        apply reducible_fill ;
        clear K.
        (* we deduce the reducibility of ki[v] from that of «ki»[«v»]: *)
        eapply active_item_translation_reducible ; [ done | done | ].
        (* remind that « ki[v] » = «ki»[tick «v»]: *)
        rewrite -> translation_fill_item_active in Hsafe ; last done.
        (* we have that «ki»[tick «v»] reduces to «ki»[«v»]
         * (thanks to the safety hypothesis, m ≥ 1 and ‘tick’ can be run): *)
        assert (
          prim_exec (fill_item Ki«ki» (tick V«v»)) S«σ, m»
                    (fill_item Ki«ki» V«v»)        S«σ, m-1» []
        ) as Hsteps % prim_exec_exec.
        {
          assert (fill [Ki«ki»] = fill_item Ki«ki») as E by reflexivity ; destruct E.
          apply prim_exec_fill. apply safe_fill_inv in Hsafe.
          (* This is where the unsafe behavior of “tick” is used: *)
          destruct m as [ | m ] ; first (exfalso ; eapply not_safe_tick ; eassumption).
          replace (S m - 1)%nat with m by lia.
          apply exec_tick_success.
        }
        (* using the safety of «ki»[tick «v»], we proceed by case analysis… *)
        eapply Hsafe in Hsteps as [ Hisval | Hred ] ; auto using elem_of_list_here.
        (* — either «ki»[«v»] is a value: this is not possible because ki is active. *)
        * simpl in Hisval. rewrite active_item_not_val in Hisval ;
          [ by apply is_Some_None in Hisval | by apply is_active_translationKi ].
        (* — or «ki»[«v»] reduces to something: this is precisely what we need. *)
        * exact Hred.
  Qed.

  Lemma safe_tctranslation__safe {Hloc : TickCounter} {useTC : UseTC} m e σ t2 σ2 e2 :
    useTC = true →
    loc_fresh_in_expr ℓ e2 →
    σ2 !! ℓ = None →
    safe «e» S«σ, m» →
    rtc erased_step ([e], σ) (t2, σ2) →
    e2 ∈ t2 →
    is_Some (to_val e2) ∨ reducible e2 σ2.
  Proof.
    intros HuseTC Hℓe Hℓσ Hsafe [n Hnsteps] % rtc_nsteps He2.
    assert (n ≤ m)%nat by by eapply safe_tctranslation__bounded.
    assert (safe «e2» S«σ2, m-n») as Hsafe2.
    {
      eapply safe_exec.
      - eapply elem_of_list_fmap_1. eassumption.
      - eassumption.
      - change [«e»] with T«[e]». apply simulation_exec_success' ; auto.
    }
    by eapply safe_tctranslation__safe_here.
  Qed.

  (* assuming the adequacy of the translated expression,
   * a proof that the original expression has adequate results. *)

  Lemma adequate_tctranslation__adequate_result {Hloc : TickCounter} {useTC : UseTC} m φ e σ t2 σ2 v2 :
    useTC = true →
    σ2 !! ℓ = None →
    adequate NotStuck «e» S«σ, m» (λ v σ, φ (invtranslationV v)) →
    rtc erased_step ([e], σ) (Val v2 :: t2, σ2) →
    φ v2.
  Proof.
    intros HuseTC Hfresh Hadq [n Hnsteps] % rtc_nsteps.
    assert (safe «e» S«σ, m») as Hsafe by by eapply safe_adequate.
    assert (n ≤ m)%nat by by eapply safe_tctranslation__bounded.
    replace (φ v2) with ((φ ∘ invtranslationV) (translationV v2))
      by (simpl ; by rewrite invtranslationV_translationV).
    eapply (adequate_result _ _ _ (λ v σ, φ (invtranslationV v))) ; first done.
    change [«e»%E] with T«[e]».
    replace (Val «v2» :: _) with (T«Val v2 :: t2») by done.
    eapply simulation_exec_success' ; eauto.
  Qed.

  (* now let’s combine the three results. *)

  Lemma adequate_tctranslation__adequate_and_bounded m φ e σ :
    let useTC : UseTC := true in
    (∀ `{TickCounter}, adequate NotStuck «e» S«σ, m» (λ v σ, φ (invtranslationV v))) →
    adequate NotStuck e σ (λ v σ, φ v)  ∧  bounded_time e σ m.
  Proof.
    intros useTC Hadq.
    split ; first split.
    (* (1) adequate result: *)
    - intros t2 σ2 v2 Hsteps.
      (* build a location ℓ which is not in the domain of σ2: *)
      pose (Build_TickCounter (fresh (dom (gset loc) σ2))) as Hloc.
      assert (σ2 !! ℓ = None)
        by (simpl ; eapply (not_elem_of_dom (D:=gset loc)), is_fresh).
      by eapply adequate_tctranslation__adequate_result.
    (* (2) safety: *)
    - intros t2 σ2 e2 _ Hsteps He2.
      (* build a location ℓ which is fresh in e2 and in the domain of σ2: *)
      pose (set1 := loc_set_of_expr e2 : gset loc).
      pose (set2 := dom (gset loc) σ2 : gset loc).
      pose (Build_TickCounter (fresh (set1 ∪ set2))) as Hloc.
      eassert (ℓ ∉ set1 ∪ set2) as [Hℓ1 Hℓ2] % not_elem_of_union
        by (unfold ℓ ; apply is_fresh).
      assert (loc_fresh_in_expr ℓ e2)
        by by apply loc_not_in_set_is_fresh_in_expr.
      assert (σ2 !! ℓ = None)
        by by (simpl ; eapply (not_elem_of_dom (D:=gset loc))).
      specialize (Hadq Hloc) as Hsafe % safe_adequate.
      by eapply safe_tctranslation__safe.
    (* (3) bounded time: *)
    - intros t2 σ2 k.
      (* build a location ℓ which is not in the domain of σ2: *)
      pose (Build_TickCounter (fresh (dom (gset loc) σ2))) as Hloc.
      assert (σ2 !! ℓ = None)
        by (unfold ℓ ; eapply (not_elem_of_dom (D:=gset loc)), is_fresh).
      specialize (Hadq Hloc) as Hsafe % safe_adequate.
      by eapply safe_tctranslation__bounded.
  Qed.

(** Part of the proof of soundness which is specific to the case where
 ** time credits are not used (m ≥ max_tr). **)

  (* assuming the adequacy of the translated expression,
   * a proof that the original expression is n-adequate. *)

  Definition adequate_trtranslation__nadequate := adequate_translation__nadequate loop.

(** Part of the proof which is common to both cases. **)

  (* from a Hoare triple in Iris,
   * derive the adequacy of the translated expression. *)

  Lemma spec_tctranslation__adequate_translation {Σ} max_tr m ψ e :
    (0 < max_tr)%nat →
    (∀ `{tctrHeapG Σ},
      TCTR_invariant max_tr -∗
      {{{ TC m }}} «e» {{{ v, RET v ; ⌜ψ v⌝ }}}
    ) →
    ∀ `{tctrHeapPreG Σ} `{TickCounter} σ,
      let useTC : UseTC := bool_decide (m < max_tr)%nat in
      let M : nat := min m (max_tr-1) in
      adequate NotStuck «e» S«σ,M» (λ v σ, ψ v).
  Proof.
    intros Imax_tr Hspec HpreG Hloc σ useTC M.
    assert (M ≤ m)%nat by (unfold M ; lia).
    assert (M < max_tr)%nat by (unfold M ; lia).
    (* apply the adequacy results. *)
    apply (wp_adequacy _ _) ; simpl ; intros HinvG.
    (* … now we have to prove a WP. *)
    set σ' := S«σ».
    (* allocate the heap, including cell ℓ (on which we need to keep an eye): *)
    iMod (gen_heap_init (<[ℓ := #M]> σ')) as (Hheap) "(Hh● & Hℓ◯ & _)".
    iDestruct (big_sepM_lookup _ _ ℓ with "Hℓ◯") as "Hℓ◯".
    { by rewrite lookup_insert. }
    (* allocate the ghost state associated with ℓ: *)
    iAssert (|==> ∃ γ,
        (if useTC then own γ (● M) else True)
      ∗ (if useTC then own γ (◯ m) else True)
    )%I as "Hγalloc".
    {
      rewrite /useTC ; case_bool_decide ; last by iExists inhabitant.
      rewrite (_ : M = m) ; last by (rewrite /M ; lia).
      iMod (auth_nat_alloc m) as (γ) "[Hγ● Hγ◯]".
      auto with iFrame.
    }
    iMod "Hγalloc" as (γ) "[Hγ● Hγ◯]".
    iMod (auth_nat_alloc (max_tr-1-M)) as (γ1) "[Hγ1● _]".
    iMod (auth_max_nat_alloc (max_tr-1-M)) as (γ2) "[Hγ2● _]".
    (* packing all those bits, build the heap instance necessary to use time credits: *)
    pose (Build_tctrHeapG Σ (HeapGS Σ _ Hheap) _ _ _ _ γ γ1 γ2 _)
      as HtcHeapG.
    (* create the invariant: *)
    iAssert (|={⊤}=> TCTR_invariant max_tr)%I with "[Hℓ◯ Hγ● Hγ1● Hγ2●]" as "> Hinv".
    {
      iApply inv_alloc.
      iExists M. by iFrame.
    }
    iIntros (?) "!>".
    (* finally, use the user-given specification: *)
    iExists (λ σ _, gen_heap_interp σ), (λ _, True%I). iFrame.
    iApply (Hspec $ HtcHeapG with "Hinv Hγ◯") ; auto.
  Qed.

  (* the final soundness theorem. *)

  Theorem tctr_sound {Σ} max_tr m φ e :
    (0 < max_tr)%nat →
    (∀ `{tctrHeapG Σ},
      TCTR_invariant max_tr -∗
      {{{ TC m }}} «e» {{{ v, RET v ; ⌜φ (invtranslationV v)⌝ }}}
    ) →
    ∀ {_ : tctrHeapPreG Σ} σ,
      if bool_decide (m < max_tr)%nat then
        adequate NotStuck e σ (λ v σ, φ v)  ∧  bounded_time e σ m
      else
        nadequate NotStuck (max_tr-1) e σ (λ v, φ v).
  Proof.
    intros Imax_tr Hspec HpreG σ.
    pose H := (spec_tctranslation__adequate_translation max_tr m _ e Imax_tr Hspec) ;
    clearbody H. clear Hspec.
    case_bool_decide.
    - rewrite (_ : min m (max_tr-1) = m)%nat in H ; last by lia.
      apply adequate_tctranslation__adequate_and_bounded.
      intros Hloc ; by apply H.
    - rewrite (_ : min m (max_tr-1) = (max_tr-1))%nat in H ; last by lia.
      apply adequate_trtranslation__nadequate.
      intros Hloc. by apply H.
  Qed.

  (* abstract version of the theorem. *)
  Theorem tctr_sound_abstract {Σ} max_tr m φ e :
    (0 < max_tr)%nat →
    (∀ `{heapGS Σ, Tick} (TC TR TRdup : nat → iProp Σ),
      TCTR_interface TC max_tr TR TRdup -∗
      {{{ TC m }}} «e» {{{ v, RET v ; ⌜φ (invtranslationV v)⌝ }}}
    ) →
    ∀ {_ : tctrHeapPreG Σ} σ,
      if bool_decide (m < max_tr)%nat then
        adequate NotStuck e σ (λ v σ, φ v)  ∧  bounded_time e σ m
      else
        nadequate NotStuck (max_tr-1) e σ (λ v, φ v).
  Proof.
    intros Imax_tr Hspec HpreG σ.
    eapply tctr_sound ; try done.
    clear HpreG. iIntros (HtcHeapG) "#Hinv".
    iApply Hspec. by iApply TC_implementation.
  Qed.

  (* A simplification for common use-cases: when the return value does not
   * contain a closure, there is no need to compose the postcondition φ with
   * the translation: *)
  Theorem tctr_sound_simple {Σ} max_tr m φ e :
    (∀ v, φ v → closure_free v) →
    (0 < max_tr)%nat →
    (∀ `{tctrHeapG Σ},
      TCTR_invariant max_tr -∗
      {{{ TC m }}} «e» {{{ v, RET v ; ⌜φ v⌝ }}}
    ) →
    ∀ {_ : tctrHeapPreG Σ} σ,
      if bool_decide (m < max_tr)%nat then
        adequate NotStuck e σ (λ v σ, φ v)  ∧  bounded_time e σ m
      else
        nadequate NotStuck (max_tr-1) e σ (λ v, φ v).
  Proof.
    intros Hφ Imax_tr Hspec HpreG σ.
    apply (tctr_sound (Σ:=Σ) max_tr) ; try assumption.
    intros HtcHeapG.
    iIntros "#Htickinv !#" (Φ) "Htc Post".
    wp_apply (Hspec with "Htickinv Htc"). iIntros (v Hv).
    iApply ("Post" with "[%]").
    by apply closure_free_predicate.
  Qed.

End Soundness.


(* TODO: Source: https://gist.github.com/wilcoxjay/88f64f6c2d8574263ef6 jwz *)

Require Export FMapAVL.
Require Export Coq.Structures.OrderedTypeEx.
Require Import Coq.Arith.Compare_dec.

Module M := FMapAVL.Make(Nat_as_OT).

Function ForallHashTable_ {A} (Q : A -> Prop) (h : M.t A) :=
  forall k v, M.MapsTo k v h -> Q v.

Lemma ForallHashTableEmpty_ : forall {A} (Q : A -> Prop),
                                ForallHashTable_ Q (M.empty _).
Proof.
  intros ? ? ? ? mapsto.
  inversion mapsto.
Qed.

Lemma add_MapsTo :
  forall A k (v : A) k' v' h,
    M.Raw.MapsTo k v (M.Raw.add k' v' h) ->
    (k = k' /\ v = v') \/ M.Raw.MapsTo k v h.
Proof.
  induction h; simpl; intros.
  - inversion H; subst; auto.
  - destruct (Nat_as_OT.compare k' k0) eqn:?;
    try match goal with
    | [ H : M.Raw.MapsTo _ _ (M.Raw.bal _ _ _ _) |- _ ] =>
      apply M.Raw.Proofs.bal_mapsto in H;
        unfold M.Raw.create in H
    end;
      inversion H; subst; clear H; intuition.
Qed.

Lemma add_MapsTo_ :
  forall A k (v : A) k' v' h,
    M.MapsTo k v (M.add k' v' h) ->
    (k = k' /\ v = v') \/ M.MapsTo k v h.
Proof.
  intros A k v k' v' h.
  unfold M.MapsTo.
  intro mt.
  apply add_MapsTo.
  auto.
Qed.

Lemma ForallHashTableAdd_ : forall {A} (Q : A -> Prop) (h : M.t A)
                                   k a,
                              Q a -> ForallHashTable_ Q h ->
                              ForallHashTable_ Q (M.add k a h).
Proof.
  intros A Q h k a Qa Qh.
  intros k2 a2.
  intro Hadd.
  apply add_MapsTo_ in Hadd.
  intuition.
  - subst. auto.
  - eapply Qh. eauto.
Qed.


Set Implicit Arguments.
Require Import LibLogic LibHeap.
Require Export JsSyntax.
Implicit Type h : heap.
Implicit Type l : loc.
Implicit Type f : field.

(**************************************************************)
(** ** Inhabitants and comparison functions for base types *)

(** Inhabitants *)

Global Instance loc_inhab : Inhab loc.
Proof. apply (prove_Inhab loc_null). Qed.

Global Instance value_inhab : Inhab value.
Proof. apply (prove_Inhab value_undef). Qed.

Global Instance field_inhab : Inhab field.
Proof. apply (prove_Inhab field_proto). Qed.

Global Instance ref_inhab : Inhab ref.
Proof. apply (prove_Inhab (Ref arbitrary arbitrary)). Qed.

(** Comparison functions *)

Definition loc_compare (l1 l2 : loc) :=
  match l1, l2 with
  | loc_normal n1, loc_normal n2 => decide (n1 = n2)
  | loc_null, loc_null => true
  | loc_eval, loc_eval => true
  | loc_scope, loc_scope => true
  | loc_global, loc_global => true
  | loc_obj_proto, loc_obj_proto => true
  | loc_func_proto, loc_func_proto => true
  | loc_eval_proto, loc_eval_proto => true
  | _, _ => false
  end.

Global Instance loc_comparable : Comparable loc.
Proof.
  applys (comparable_beq loc_compare). intros x y.
  destruct x; destruct y; simpl; rew_refl; iff;
   tryfalse; auto; try congruence.
Qed.

Definition field_compare (f1 f2 : field) :=
  match f1, f2 with
  | field_normal s1, field_normal s2 => decide (s1 = s2)
  | field_proto, field_proto => true
  | field_body, field_body => true
  | field_scope, field_scope => true
  | field_this, field_this => true
  | _, _ => false
  end.

Global Instance field_comparable : Comparable field.
Proof.
  applys (comparable_beq field_compare). intros x y.
  destruct x; destruct y; simpl; rew_refl; iff;
   tryfalse; auto; try congruence.
Qed.

Definition ref_compare r1 r2 :=
  match r1, r2 with Ref l1 f1, Ref l2 f2 =>
    decide (l1 = l2) && decide (f1 = f2) end.

Global Instance ref_comparable : Comparable ref.
Proof.
  applys (comparable_beq ref_compare). intros x y.
  destruct x; destruct y; simpl; rew_refl.
  iff M; inverts~ M.
Qed.

Global Instance number_comparable : Comparable number.
Proof. Admitted.
(* ARTHUR: use Rcompare to implement this *)

Definition value_compare (v1 v2 : value) :=
  match v1, v2 with
  | value_undef, value_undef => true
  | value_bool b1, value_bool b2 => decide (b1 = b2)
  | value_number n1, value_number n2 => decide (n1 = n2)
  | value_string s1, value_string s2 => decide (s1 = s2)
  | value_loc l1, value_loc l2 => decide (l1 = l2)
  | _, _ => false
  end.


Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Reducible.
Require Import ExtLib.Structures.Traversable.
Require Import ExtLib.Structures.Applicative.
Require Import ExtLib.Structures.Functor.
Require Import ExtLib.Structures.FunctorLaws.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Tactics.Injection.
Require Import ExtLib.Tactics.Consider.

Set Implicit Arguments.
Set Strict Implicit.

(** For backwards compatibility with hint locality attributes. *)
Set Warnings "-unsupported-attributes".

Global Instance Foldable_option {T} : Foldable (option T) T :=
  fun _ f d v =>
    match v with
      | None => d
      | Some x => f x d
    end.

Global Instance Traversable_option : Traversable option :=
{| mapT := fun F _ _ _ f o =>
  match o with
    | None => pure None
    | Some o => ap (pure (@Some _)) (f o)
  end
|}.

Global Instance Applicative_option : Applicative option :=
{| pure := @Some
 ; ap := fun _ _ f x =>
           match f , x with
             | Some f , Some x => Some (f x)
             | _ , _ => None
           end
|}.

Global Instance Functor_option : Functor option :=
{| fmap := fun _ _ f x => match x with
                            | None => None
                            | Some x => Some (f x)
                          end |}.

Section relation.
  Context {T : Type}.
  Variable (R : relation T).

  Inductive Roption : Relation_Definitions.relation (option T) :=
  | Roption_None : Roption None None
  | Roption_Some : forall x y, R x y -> Roption (Some x) (Some y).

  Lemma Reflexive_Roption : Reflexive R -> Reflexive Roption.
  Proof. clear. compute. destruct x; try constructor; auto. Qed.

  Lemma Symmetric_Roption : Symmetric R -> Symmetric Roption.
  Proof. clear. compute. intros.
         destruct H0; constructor. auto.
  Qed.

  Lemma Transitive_Roption : Transitive R -> Transitive Roption.
  Proof.
    clear. compute. intros.
    destruct H0; auto.
    inversion H1. constructor; auto. subst. eapply H; eassumption.
  Qed.

  Global Instance Injective_Roption_None
  : Injective (Roption None None).
  refine {| result := True |}.
  auto.
  Defined.

  Global Instance Injective_Roption_None_Some a
  : Injective (Roption None (Some a)).
  refine {| result := False |}.
  inversion 1.
  Defined.

  Global Instance Injective_Roption_Some_None a
  : Injective (Roption (Some a) None).
  refine {| result := False |}.
  inversion 1.
  Defined.

  Global Instance Injective_Roption_Some_Some a b
  : Injective (Roption (Some a) (Some b)).
  refine {| result := R a b |}.
  inversion 1. auto.
  Defined.

  Global Instance Injective_Proper_Roption_Some x
  : Injective (Proper Roption (Some x)).
  refine {| result := R x x |}.
  abstract (inversion 1; assumption).
  Defined.

End relation.

(*
Global Instance FunctorLaws_option : FunctorLaws Functor_option type_option.
Proof.
  constructor.
  { simpl. red. destruct x; destruct y; simpl; auto.
    inversion 1; simpl. red in H0.
    unfold id. constructor. etransitivity. eapply H0. 2: eauto.
    eapply proper_left; eauto.
    inversion 1. }
  { intros. simpl in *.
    red. intros.
    destruct H4; simpl.
    - unfold compose. constructor.
    - unfold compose. constructor.
      eapply H3. eapply H2. assumption. }
  { intros; simpl in *.
    red. red. inversion 2. constructor.
    constructor. apply H1. assumption. }
Qed.
*)

Global Instance Injective_Some (T : Type) (a b : T) : Injective (Some a = Some b) :=
{ result := a = b
; injection :=
    fun P : Some a = Some b =>
      match P with
      | eq_refl => eq_refl
      end
}.

Require ExtLib.Core.EquivDec.

Global Instance EqDec_option (T : Type) (EDT : EquivDec.EqDec T (@eq T)) : EquivDec.EqDec (option T) (@eq _).
Proof.
  red. unfold Equivalence.equiv, RelationClasses.complement. intros.
  change (x = y -> False) with (x <> y).
  decide equality. apply EDT.
Qed.

Section OptionEq.
  Variable T : Type.
  Variable EDT : RelDec (@eq T).

  (** Specialization for equality **)
  Global Instance RelDec_eq_option : RelDec (@eq (option T)) :=
  { rel_dec := fun x y =>
    match x , y with
      | None , None => true
      | Some x , Some y => eq_dec x y
      | _ , _ => false
    end }.

  Variable EDCT : RelDec_Correct EDT.

  Global Instance RelDec_Correct_eq_option : RelDec_Correct RelDec_eq_option.
  Proof.
    constructor; destruct x; destruct y; split; simpl in *; intros; try congruence;
      f_equal; try match goal with
                     | [ H : context [ eq_dec ?X ?Y ] |- _ ] =>
                       consider (eq_dec X Y)
                     | [ |- context [ eq_dec ?X ?Y ] ] =>
                       consider (eq_dec X Y)
                   end; auto; congruence.
  Qed.

End OptionEq.

Lemma eq_option_eq
: forall T (a b : T) (pf : a = b) (F : _ -> Type) val,
    match pf in _ = x return option (F x) with
      | eq_refl => val
    end = match val with
            | None => None
            | Some val => Some match pf in _ = x return F x with
                                 | eq_refl => val
                               end
          end.
Proof.
  destruct pf. destruct val; reflexivity.
Defined.

#[global]
Hint Rewrite eq_option_eq : eq_rw.


(** ** Consistency *)

From FOL Require Export ND.

Section Consistency.
  Context {Sigma : Signature}.
  Context {HdF : eq_dec Funcs} {HdP : eq_dec Preds}.
  Context {HeF : enumT Funcs} {HeP : enumT Preds}.

  Definition consistent (T : theory) := ~ T ⊩CE ⊥.
  Definition consistent_max T := consistent T /\ forall f, consistent (T ⋄ f) -> f ∈ T.

  Lemma consistent_prv T phi :
    consistent T -> T ⊩CE phi -> consistent (T ⋄ phi).
  Proof.
    intros HT Hphi. intros Hpsi2. now apply HT, (prv_T_remove Hphi).
  Qed.

  Lemma consistency_inheritance T1 T2 :
    consistent T2 -> T1 ⊑ T2 -> consistent T1.
  Proof.
    intros H H2 H3. now eapply H, Weak_T, H2.
  Qed.

  Fact consistent_neg T phi :
    consistent T -> (¬ phi) ∈ T -> ~ phi ∈ T.
  Proof.
    intros HT H H2. apply HT.
    use_theory [phi; ¬ phi]. oapply 1. ctx.
  Qed.

  Fact consistent_neg2 T phi :
    consistent T -> (T ⋄ phi) ⊩CE ⊥ -> consistent (T ⋄ (¬ phi)).
  Proof.
    intros HT H. now apply consistent_prv, prv_T_impl.
  Qed.

  Fact consistent_max_out T phi :
    consistent_max T -> ~ phi ∈ T -> ~ consistent (T ⋄ phi).
  Proof.
    intros []; intuition.
  Qed.

  Lemma consistent_max_impl T phi psi :
    consistent_max T -> (phi --> psi ∈ T <-> (phi ∈ T -> psi ∈ T)).
  Proof.
    intros; split; destruct H as [H1 H2].
    - intros H H'. apply H2. apply consistent_prv; try assumption.
      use_theory [phi; phi --> psi]. oapply 1. ctx.

    - intros H. apply H2. intros (A & HA1 & HA2) % prv_T_impl.
      apply H1. apply (prv_T_remove (phi := psi)).
      + apply elem_prv, H, H2, consistent_prv. assumption. use_theory A.
        oindirect. oimport HA2. oapply 0. ointros. oexfalso. oapply 2. ctx.
      + use_theory (psi :: A). oimport HA2. oapply 0. ointros. ctx.
  Qed.

  Section Classical.
    Hypothesis XM : forall X, X \/ ~ X.
    Ltac indirect := match goal with
                      | [ |- ?H ] => destruct (XM H); [assumption | exfalso]
                    end.

    Lemma inconsistent T phi :
      ~ consistent (T ⋄ phi) -> T ⋄ phi ⊩CE ⊥.
    Proof.
      destruct (XM (T ⋄ phi ⊩CE ⊥)); tauto.
    Qed.

    Lemma consistent_max_out2 T phi :
      consistent_max T -> ~ phi ∈ T -> (¬ phi) ∈ T.
    Proof.
      intros [HT1 HT2] H2. now apply consistent_max_out, inconsistent, consistent_neg2, HT2 in H2.
    Qed.
  End Classical.
End Consistency.


Require Import Metalib.Metatheory.
Require Import Metalib.LibTactics.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Import Strings.String.
Require Import Lia.

Require Import Language.
Require Import Tactical.
Require Import Subtyping.Subtyping.
Require Import Subtyping.Splitable.
Require Import Appsub.

Require Import Value.
Require Import PrincipalTyping.
Require Import Typing.
Require Import Casting.
Require Import LocallyNameless.
Require Import Application.

(** * Definition *)

Inductive step : term -> term -> Prop :=
| St_Lit : forall n,
    step (Lit n) (Ann (Lit n) Int)
| St_Lam : forall e A B,
    step (Lam A e B) (Ann (Lam A e B) (Arr A B))
| St_Spl : forall p A A1 A2,
    pvalue p ->
    splitable A A1 A2 ->
    step (Ann p A) (Mrg (Ann p A1) (Ann p A2))
| St_App : forall f v e,
    value f -> value v ->
    papp f (Av v) e ->
    step (App f v) e
| St_Prj : forall l v e,
    value v ->
    papp v (Al l) e ->
    step (Prj v l) e
| St_Val : forall v v' A,
    value v ->
    casting v A v' ->
    step (Ann v A) v'
| St_Ann : forall e e' A,
    not (pvalue e) ->
    step e e' ->
    step (Ann e A) (Ann e' A)
| St_App_L : forall e1 e1' e2,
    lc e2 ->
    step e1 e1' ->
    step (App e1 e2) (App e1' e2)
| St_App_R : forall v e2 e2',
    value v ->
    step e2 e2' ->
    step (App v e2) (App v e2')
| St_Rcd : forall l e e',
    step e e' ->
    step (Fld l e) (Fld l e')
| St_Prj_L : forall e e' l,
    step e e' ->
    step (Prj e l) (Prj e' l)
| St_Mrg_L : forall e1 e1' e2,
    step e1 e1' ->
    step (Mrg e1 e2) (Mrg e1' e2)
| St_Mrg_R : forall v e2 e2',
    value v ->
    step e2 e2' ->
    step (Mrg v e2) (Mrg v e2').

Hint Constructors step : core.

Notation "e ⟾ e'" := (step e e') (at level 68).

(** * Value *)

Lemma value_no_step :
  forall v,
    value v -> forall e, ~ step v e.
Proof.
  introv Val.
  induction v; intros; eauto.
  - intros St.
    dependent destruction Val. dependent destruction St; eauto.
    + eapply IHv1; eauto.
    + eapply IHv2; eauto.
  - dependent destruction Val.
    destruct H.
    + intros St. dependent destruction St; eauto.
    + intros St. dependent destruction St; eauto.
  - intros St.
    dependent destruction St.
    dependent destruction Val.
    pose proof (IHv Val e'). contradiction.
Qed.

Lemma step_lc :
  forall e e',
    lc e -> step e e' -> lc e'.
Proof.
  introv Lc St. gen e'.
  induction Lc; intros;
    try solve [dependent destruction St; eauto 3].
  - dependent destruction St. eapply Lc_Ann. eapply Lc_Lam; eauto.
  - Case "App".
    dependent destruction St; try solve [econstructor; eauto].
    pose proof (papp_lc_v e1 e2 e). eauto 3.
  - dependent destruction St; econstructor; eauto.
  - dependent destruction St.
    + econstructor; eapply Lc_Ann; eapply lc_pvalue; eauto.
    + eapply casting_lc; eauto.
    + econstructor. eauto.
  - dependent destruction St. econstructor. eauto.
  - Case "Prj".
    dependent destruction St; try solve [econstructor; eauto].
    pose proof (papp_lc_l e l e0). eauto 3.
Qed.

(** * Preservation *)

Ltac ind_term_size s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : term |- _ ] => (gen h) end;
  induction i as [|i IH]; [
      intros; match goal with | [ H : _ < 0 |- _ ] => (dependent destruction H) end
    | intros ].

Theorem preservation :
  forall e e' A,
    typing nil e Inf A ->
    step e e' ->
    (exists B, typing nil e' Inf B /\ isosub B A).
Proof.
  introv Typ St. gen e' A.
  ind_term_size (size_term e). (* shelved item *)
  dependent destruction Typ; simpl in SizeInd.
  - Case "Lit".
    dependent destruction St; eauto.
    exists Int; eauto.
  - Case "Var".
    dependent destruction St.
  - Case "Lam".
    dependent destruction St; eauto.
    exists (Arr A B). split; eauto.
  - Case "Rcd".
    dependent destruction St; eauto.
    exploit (IH e); eauto; try lia. intros IH'. destruct_conjs.
    eexists. split; eauto.
  - Case "Ann".
    dependent destruction St.
    + SCase "Split".
      dependent destruction Typ.
      exists (And A1 A2). split; eauto.
      pose proof (sub_inv_splitable_r A B A1 A2) as Sub. destruct Sub; eauto.
      eapply Ty_Mrg; eauto.
    + SCase "Value".
      dependent destruction Typ.
      eapply casting_preservation; eauto.
    + SCase "Ann".
      dependent destruction Typ.
      eapply IH in St; eauto; try lia.
      destruct St as [C Typ']. destruct Typ' as [Typ'1 Typ'2].
      pose proof (isosub_to_sub1 _ _ Typ'2).
      exists B. split; eauto. eapply Ty_Ann; eauto; try solve [eapply sub_transitivity; eauto].
      eapply Ty_Sub; eauto. eapply sub_transitivity; eauto.
  - Case "App".
    dependent destruction St.
    + pose proof (papp_preservation_v e1 e2 e) as P.
      eapply P; eauto. eapply psub_sound_appsub; eauto.
    + eapply IH in St; eauto; try lia. destruct_conjs.
      eapply psub_sound_appsub in H0.
      eapply appsub_iso_v in H0; eauto. destruct_conjs.
      eexists. split; eauto.
     eapply Ty_App; eauto. eapply psub_complete_appsub; eauto.
    + eapply IH in St; eauto; try lia. destruct_conjs.
      eapply psub_sound_appsub in H0.
      eapply appsub_iso_v in H0; eauto. destruct_conjs.
      eexists. split; eauto.
      eapply Ty_App; eauto. eapply psub_complete_appsub; eauto.
  - Case "Prj".
    dependent destruction St.
    + pose proof (papp_preservation_l e l e0) as P.
      eapply P; eauto.
      eapply psub_sound_appsub; eauto.
    + eapply IH in St; eauto; try lia. destruct_conjs.
      eapply psub_sound_appsub in H.
      eapply appsub_iso_l in H; eauto. destruct_conjs.
      eexists; split; eauto.
      eapply Ty_Prj; eauto. eapply psub_complete_appsub; eauto.
  - Case "Merge".
    dependent destruction St.
    + eapply IH in St; eauto; try lia. destruct_conjs. eauto.
    + eapply IH in St; eauto; try lia. destruct_conjs. eauto.
Qed.

Theorem preservation_chk :
  forall e e' A,
    typing nil e Chk A ->
    step e e' ->
    typing nil e' Chk A.
Proof.
  introv Typ St.
  dependent destruction Typ.
  pose proof (preservation _ _ _ Typ St). destruct_conjs.
  eapply Ty_Sub; eauto. eapply isosub_to_sub1 in H2. eapply sub_transitivity; eauto.
Qed.

Theorem preservation_gen :
  forall e e' A dir,
    typing nil e dir A ->
    step e e' ->
    typing nil e' Chk A.
Proof.
  introv Typ St.
  destruct dir.
  - pose proof (preservation _ _ _ Typ St). destruct_conjs.
    eapply Ty_Sub; eauto. eapply isosub_to_sub1 in H1. auto.
  - eapply preservation_chk; eauto.
Qed.

(** * Progress *)

Theorem progress :
  forall e A dir,
    typing nil e dir A ->
    value e \/ exists e', step e e'.
Proof.
  introv Typ.
  dependent induction Typ; eauto 3.
  - Case "Rcd".
    destruct IHTyp as [Val | St] ; eauto.
    right. destruct St. exists (Fld l x); eauto.
  - Case "Anno".
    destruct IHTyp as [Val | St] ; eauto.
    + right. eapply casting_progress in Typ; eauto. destruct Typ.
      exists x. eapply St_Val; eauto.
    + destruct (pvalue_decidable e) as [Pv | nPv];
        destruct (splitable_or_ordinary A) as [Spl | Ord]; eauto.
      * destruct Pv; right; destruct_conjs; eexists; eauto.
      * destruct St. right. eexists; eauto.
      * destruct St. right. eexists; eauto.
  - Case "App".
    right. destruct IHTyp1; destruct IHTyp2; eauto 3; try solve [destruct_conjs; eauto].
    pose proof (papp_progress_v e1 e2 A B C) as Pa. destruct Pa; eauto.
    eapply psub_sound_appsub; eauto.
  - Case "Prj".
    right. destruct IHTyp; eauto 3; try solve [destruct_conjs; eauto].
    pose proof (papp_progress_l e A B l) as Pa. destruct Pa; eauto.
    eapply psub_sound_appsub; eauto.
  - Case "Merge".
    destruct IHTyp1; destruct IHTyp2; eauto 3; try solve [destruct_conjs; eauto].
Qed.

(** * Soundness *)

Definition relation (X : Type) := X -> X -> Prop.

Inductive multi {X : Type} (R : relation X) : relation X :=
| multi_refl : forall (x : X), multi R x x
| multi_step : forall (x y z : X), R x y -> multi R y z -> multi R x z.

Notation multistep := (multi step).

Definition normal_form {X : Type} (R : relation X) (e : X) : Prop :=
  not (exists e', R e e').

Definition stuck (e : term) : Prop :=
  (normal_form step) e /\ ~ value e.

Corollary soundness :
  forall e e' A dir,
    typing nil e dir A ->
    multistep e e' ->
    ~ (stuck e').
Proof.
  introv Typ Mult. unfold stuck.
  intros [Nf Nval]. unfold normal_form in Nf. gen A dir.
  dependent induction Mult; intros.
  - pose proof (progress _ _ _ Typ). destruct H; eauto.
  - destruct dir.
    + pose proof (preservation _ _ _ Typ H) as Prv.
      destruct Prv. destruct H0.
      eapply IHMult; eauto.
    + pose proof (preservation_chk _ _ _ Typ H) as Prv.
      dependent destruction Prv.
      eapply IHMult; eauto.
Qed.


(** * Opfibrations

-largely copied and past from UniMath fibrations (but not all the UniMath file was readapted to the opfibration def)
- some complements that should be moved to Displayedcats.Core (Cf 2 lemmas at the beginning
of this file)
 *)

(** Definitions of various kinds of _fibraitions_, using displayed categories. *)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.Presheaf.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.

Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.graphs.coequalizers.

Local Open Scope cat.
Local Open Scope type_scope.
Local Open Scope mor_disp_scope.

(* COpied from Core *)
(** Note: closely analogous to [idtoiso_precompose].  We name it differently to fit the convention of naming equalities according to their LHS, for reference during calculation. *)
Lemma transportf_postcompose_disp {C} {D : disp_cat C}
    {c d : C} (f : d --> c )
    {cc cc' : D c} (e : cc' = cc) {dd} (ff : dd -->[f] cc')
  : transportf (λ xx : D c, dd -->[f] xx) e ff
  = transportf _ (id_right _)
    (ff ;; ( (idtoiso_disp (idpath _) e) )).
Proof.
  destruct e; cbn; unfold idfun; cbn.
  rewrite id_right_disp.
  apply pathsinv0, transportfbinv.
Qed.
Definition postcomp_with_z_iso_disp_is_inj
    {C : category} {D : disp_cat C}
    {a b c : C} {i : z_iso c a} {f : b --> c}
    {aa : D a} {bb} {cc} (ii : z_iso_disp i cc aa) {ff ff' : bb -->[f] cc}
  : ( ff ;; ii = ff' ;; ii) -> ff = ff'.
Proof.
  intros e.
  use pathscomp0.
  - use (transportf _ _ (ff ;; ( ii ;; z_iso_inv_from_z_iso_disp ii) )).
    etrans; [ apply cancel_precomposition, z_iso_inv_after_z_iso | apply id_right ].
  - apply pathsinv0.
    etrans. eapply transportf_bind.
      eapply cancel_precomposition_disp, (inv_mor_after_z_iso_disp ii).
    rewrite id_right_disp.
    etrans. apply transport_f_f.
    use (@maponpaths_2 _ _ _ _ _ (idpath _)).
    apply homset_property.
  - etrans. eapply transportf_bind, assoc_disp.
    rewrite e.
    etrans. eapply transportf_bind, assoc_disp_var.
    etrans. eapply transportf_bind.
      eapply cancel_precomposition_disp, (inv_mor_after_z_iso_disp ii).
    rewrite id_right_disp.
    etrans. apply transport_f_f.
    use (@maponpaths_2 _ _ _ _ _ (idpath _)).
    apply homset_property.
Qed.

(* copied from fibrations *)
(** * Opfibrations *)
Section Opfibrations.

Definition is_cocartesian {C : category} {D : disp_cat C}
    {c c' : C} {f : c' --> c}
    {d : D c} {d' : D c'} (ff : d' -->[f] d)
  : UU
:= forall c'' (g : c --> c'') (d'' : D c'') (hh : d' -->[f·g] d''),
  ∃! (gg : d -->[g] d''), ff ;; gg = hh.

(** See also [cocartesian_factorisation'] below, for when the map one wishes to factor is not judgementally over [g;;f], but over some equal map. *)
Definition cocartesian_factorisation {C : category} {D : disp_cat C}
    {c c' : C} {f : c' --> c}
    {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_cocartesian ff)
    {c''} (g : c --> c'') {d'' : D c''} (hh : d' -->[f·g] d'')
  : d -->[g] d''
:= pr1 (pr1 (H _ g _ hh)).

Definition cocartesian_factorisation_commutes
    {C : category} {D : disp_cat C}
    {c c' : C} {f : c' --> c}
    {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_cocartesian ff)
    {c''} (g : c --> c'') {d'' : D c''} (hh : d' -->[f·g] d'')
  : ff ;; cocartesian_factorisation H g hh = hh
:= pr2 (pr1 (H _ g _ hh)).

(** This is essentially the third access function for [is_cocartesian], but given in a more usable form than [pr2 (H …)] would be. *)
Definition cocartesian_factorisation_unique
    {C : category} {D : disp_cat C}
    {c c' : C} {f : c' --> c}
    {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_cocartesian ff)
    {c''} {g : c --> c''} {d'' : D c''} (gg gg' : d -->[g] d'')
  : (ff ;; gg = ff ;; gg') -> gg = gg'.
Proof.
  revert gg gg'.
  assert (goal' : forall gg : d -->[g] d'',
                    gg = cocartesian_factorisation H g (ff ;; gg)).
  {
    intros gg.
    exact (maponpaths pr1
      (pr2 (H _ g _ (ff ;; gg)) (gg,,idpath _))).
  }
  intros gg gg' Hggff.
  eapply pathscomp0. apply goal'.
  eapply pathscomp0. apply maponpaths, Hggff.
  apply pathsinv0, goal'.
Qed.

Definition cocartesian_factorisation' {C : category} {D : disp_cat C}
    {c c' : C} {f : c' --> c}
    {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_cocartesian ff)
    {c''} (g : c --> c'')
    {h : c' --> c''} {d'' : D c''} (hh : d' -->[h] d'')
    (e : (f · g = h))
  : d -->[g] d''.
Proof.
  use (cocartesian_factorisation H g).
  exact (transportb _ e hh).
Defined.

Definition cocartesian_factorisation_commutes'
    {C : category} {D : disp_cat C}
    {c c' : C} {f : c' --> c}
    {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_cocartesian ff)
    {c''} (g : c --> c'')
    {h : c' --> c''} {d'' : D c''} (hh : d' -->[h] d'')
    (e : (f · g = h))
  : ff ;; (cocartesian_factorisation' H g hh e)
  = transportb _ e hh.
Proof.
  apply cocartesian_factorisation_commutes.
Qed.

Definition cocartesian_lift {C : category} {D : disp_cat C}
    {c'} (d' : D c') {c : C} (f : c' --> c)
  : UU
:= ∑ (d : D c) (ff : d' -->[f] d), is_cocartesian ff.

Definition object_of_cocartesian_lift  {C : category} {D : disp_cat C}
    {c'} (d' : D c') {c : C} (f : c' --> c)
    (fd : cocartesian_lift d' f)
  : D c
:= pr1 fd.
Coercion object_of_cocartesian_lift : cocartesian_lift >-> ob_disp.

Definition mor_disp_of_cocartesian_lift  {C : category} {D : disp_cat C}
    {c'} (d' : D c') {c : C} (f : c' --> c)
    (fd : cocartesian_lift d' f)
  : d'  -->[f] (fd : D c)
:= pr1 (pr2 fd).
Coercion mor_disp_of_cocartesian_lift : cocartesian_lift >-> mor_disp.

Definition cocartesian_lift_is_cocartesian {C : category} {D : disp_cat C}
    {c'} (d' : D c') {c : C} (f : c' --> c)
    (fd : cocartesian_lift d' f)
  : is_cocartesian fd
:= pr2 (pr2 fd).
Coercion cocartesian_lift_is_cocartesian : cocartesian_lift >-> is_cocartesian.

Definition is_cocartesian_disp_functor
  {C C' : category} {F : functor C C'}
  {D : disp_cat C} {D' : disp_cat C'} (FF : disp_functor F D D') : UU
:= ∏  (c c' : C) (f : c' --> c)
      (d : D c) (d' : D c') (ff : d' -->[f] d),
   is_cocartesian ff -> is_cocartesian (#FF ff).

Lemma isaprop_is_cocartesian
    {C : category} {D : disp_cat C}
    {c c' : C} {f : c' --> c}
    {d : D c} {d' : D c'} (ff : d' -->[f] d)
  : isaprop (is_cocartesian ff).
Proof.
  repeat (apply impred_isaprop; intro).
  apply isapropiscontr.
Defined.

(* TODO: should the arguments be re-ordered as in [cocartesian_lift]? If so, reorder in [isoopfibration] etc as well, for consistency. *)
(* TODO: consider renaming to e.g. [cleaving] to follow convention that [is_] is reserved for hprops. *)
Definition opcleaving {C : category} (D : disp_cat C) : UU
:=
  forall (c c' : C) (f : c' --> c) (d' : D c'), cocartesian_lift d' f.

(** ** (Cloven) opfibration *)

Definition opfibration (C : category) : UU
:=
  ∑ D : disp_cat C, cleaving D.

(** ** Weak opfibration *)

(* TODO: give access functions! *)

Definition is_opcleaving {C : category} (D : disp_cat C) : UU
:=
  forall (c c' : C) (f : c' --> c) (d' : D c'), ∥ cocartesian_lift d' f ∥.

Definition weak_opfibration (C : category) : UU
:= ∑ D : disp_cat C, is_opcleaving D.

(*
(** ** Connection with isoopfibrations *)

Lemma is_iso_from_is_cocartesian {C : category} {D : disp_cat C}
    {c c' : C} (i : iso c' c) {d : D c} {d'} (ff : d' -->[i] d)
  : is_cocartesian ff -> is_iso_disp i ff.
Proof.
  intros Hff.
  use (_,,_); try split.
  - use
      (cocartesian_factorisation' Hff (inv_from_iso i) (id_disp _)).
    apply iso_after_iso_inv.
  - apply cocartesian_factorisation_commutes'.
  - apply (cocartesian_factorisation_unique Hff).
    etrans. apply assoc_disp_var.
    rewrite cocartesian_factorisation_commutes'.
    etrans. eapply transportf_bind.
      etrans. apply mor_disp_transportf_prewhisker.
      eapply transportf_bind, id_right_disp.
    apply pathsinv0.
    etrans. apply mor_disp_transportf_postwhisker.
    etrans. eapply transportf_bind, id_left_disp.
    apply maponpaths_2, homset_property.
Qed.

Lemma is_isoopfibration_from_is_opfibration {C : category} {D : disp_cat C}
  : cleaving D -> iso_cleaving D.
Proof.
  intros D_fib c c' f d.
  assert (fd := D_fib _ _ f d).
  exists (fd : D _).
  exists (fd : _ -->[_] _).
  apply is_iso_from_is_cocartesian; exact fd.
Defined.
*)

(** ** Uniqueness of cocartesian lifts *)

Lemma transportf_bind {X : UU} {P : X → UU}
  {x x' x'' : X} (e : x' = x) (e' : x = x'')
  y y'
: y = transportf P e y' -> transportf _ e' y = transportf _ (e @ e') y'.
Proof.
  intro H; destruct e, e'; exact H.
Defined.
(* TODO: show that when [D] is _univalent_, cocartesian lifts are literally unique, and so any uncloven opfibration (isoopfibration, etc) is in fact cloven. *)
Definition cocartesian_lifts_z_iso {C : category} {D : disp_cat C}
    {c'} {d' : D c'} {c : C} {f : c' --> c} (fd fd' : cocartesian_lift d' f)
  : z_iso_disp (identity_z_iso c) fd fd'.
Proof.
  use (_,,(_,,_)).
  - exact (cocartesian_factorisation' fd (identity _) fd' (id_right _)).
  - exact (cocartesian_factorisation' fd' (identity _) fd (id_right _)).
  - cbn; split.
    + apply (cocartesian_factorisation_unique fd').
      etrans. apply assoc_disp.
      rewrite cocartesian_factorisation_commutes'.
      etrans. eapply transportf_bind,  mor_disp_transportf_postwhisker.
      rewrite cocartesian_factorisation_commutes'.
      etrans. apply transport_f_f.
      apply pathsinv0.
      etrans. apply mor_disp_transportf_prewhisker.
      rewrite id_right_disp.
      etrans. apply transport_f_f.
      apply maponpaths_2, homset_property.
    + apply (cocartesian_factorisation_unique fd).
      etrans. apply assoc_disp.
      rewrite cocartesian_factorisation_commutes'.
      etrans. eapply transportf_bind, mor_disp_transportf_postwhisker.
      rewrite cocartesian_factorisation_commutes'.
      etrans. apply transport_f_f.
      apply pathsinv0.
      etrans. apply mor_disp_transportf_prewhisker.
      rewrite id_right_disp.
      etrans. apply transport_f_f.
      apply maponpaths_2, homset_property.
Defined.

Definition cocartesian_lifts_z_iso_commutes {C : category} {D : disp_cat C}
    {c'} {d' : D c'} {c : C} {f : c' --> c} (fd fd' : cocartesian_lift d' f)
  : fd ;; (cocartesian_lifts_z_iso fd fd')
  = transportb _ (id_right _) (fd' : _ -->[_] _).
Proof.
  cbn. apply cocartesian_factorisation_commutes'.
Qed.

(** In a displayed _category_ (i.e. _univalent_), cocartesian lifts are literally unique, if they exist; that is, the type of cocartesian lifts is always a proposition. *)
Definition isaprop_cocartesian_lifts
    {C : category} {D : disp_cat C} (D_cat : is_univalent_disp D)
    {c'} (d' : D c') {c : C} (f : c' --> c)
  : isaprop (cocartesian_lift d' f).
Proof.
  apply invproofirrelevance; intros fd fd'.
  use total2_paths_f.
  { apply (isotoid_disp D_cat (idpath _)); cbn.
    apply cocartesian_lifts_z_iso. }
  apply subtypePath.
  { intros ff. repeat (apply impred; intro).
    apply isapropiscontr. }
  etrans.
    use ( ! (@transport_map (D c) _ _ (λ x, pr1) _ _ _ _ )).
  cbn. etrans. apply transportf_postcompose_disp.
  rewrite idtoiso_isotoid_disp.
  use (pathscomp0 (maponpaths _ _) (transportfbinv _ _ _)).
  apply (postcomp_with_z_iso_disp_is_inj (z_iso_inv_from_z_iso_disp (cocartesian_lifts_z_iso fd fd'))).
  etrans. apply assoc_disp_var.
  etrans. eapply transportf_bind, cancel_precomposition_disp.
    use (inv_mor_after_z_iso_disp (pr2 (cocartesian_lifts_z_iso fd fd')))  .
  etrans. eapply transportf_bind, id_right_disp.
  apply pathsinv0.
  etrans. apply mor_disp_transportf_postwhisker.
  etrans. eapply transportf_bind, cocartesian_lifts_z_iso_commutes.
  apply maponpaths_2, homset_property.
Defined.

Definition univalent_opfibration_is_cloven
    {C : category} {D : disp_cat C} (D_cat : is_univalent_disp D)
  : is_opcleaving D -> opcleaving D.
Proof.
  intros D_fib c c' f d.
  apply (squash_to_prop (D_fib c c' f d)).
  apply isaprop_cocartesian_lifts; assumption.
  auto.
Defined.

End Opfibrations.

(** Copied from Fibration in UniMath *)
Section Discrete_OpFibrations.

Definition is_discrete_opfibration {C : category} (D : disp_cat C) : UU
:=
  (forall (c c' : C) (f : c' --> c) (d' : D c'),
          ∃! d : D c, d' -->[f] d)
  ×
  (forall c, isaset (D c)).

Definition discrete_opfibration C : UU
  := ∑ D : disp_cat C, is_discrete_opfibration D.

Coercion disp_cat_from_discrete_opfibration C (D : discrete_opfibration C)
  : disp_cat C := pr1 D.
Definition unique_lift_op {C} {D : discrete_opfibration C} {c c'}
           (f : c' --> c) (d' : D c')
  : ∃! d : D c, d' -->[f] d
  := pr1 (pr2 D) c c' f d'.

Definition isaset_fiber_discrete_opfibration {C} (D : discrete_opfibration C)
           (c : C) : isaset (D c) := pr2 (pr2 D) c.

Lemma disp_mor_unique_disc_opfib C (D : discrete_opfibration C)
  : ∏ (c c' : C) (f : c --> c') (d : D c) (d' : D c')
      (ff ff' : d -->[f] d'), ff = ff'.
Proof.
  intros.
  assert (XR := unique_lift_op f d).
  assert (foo : ((d',,ff) : ∑ d0, d -->[f] d0) = (d',,ff')).
  { apply proofirrelevance.
    apply isapropifcontr. apply XR.
  }
  apply (pair_inj (isaset_fiber_discrete_opfibration _ _ ) foo).
Defined.

Lemma isaprop_disc_opfib_hom C (D : discrete_opfibration C)
  : ∏ (c c' : C) (f : c --> c') (d : D c) (d' : D c'),
    isaprop (d -->[f] d').
Proof.
  intros.
  apply invproofirrelevance.
  intros x x'. apply disp_mor_unique_disc_opfib.
Qed.

Definition opfibration_from_discrete_opfibration C (D : discrete_opfibration C)
  : opcleaving D.
Proof.
  intros c c' f d.
  use tpair.
  - exact (pr1 (iscontrpr1 (unique_lift_op f d))).
  - use tpair.
    + exact (pr2 (iscontrpr1 (unique_lift_op f d))).
    + intros c'' g db hh.
      set (ff := pr2 (iscontrpr1 (unique_lift_op f d))  ). cbn in ff.
      set (d' := pr1 (iscontrpr1 (unique_lift_op f d))) in *.
      set (ggff := pr2 (iscontrpr1 (unique_lift_op (f·g) d))  ). cbn in ggff.
      set (d'' := pr1 (iscontrpr1 (unique_lift_op (f·g) d))) in *.
      set (gg := pr2 (iscontrpr1 (unique_lift_op g d'))). cbn in gg.
      set (d3 := pr1 (iscontrpr1 (unique_lift_op g d'))) in *.
      assert (XR : ((d'',, ggff) : ∑ r, d -->[f·g] r) = (db,,hh)).
      { apply proofirrelevance. apply isapropifcontr. apply (pr2 D). }
      assert (XR1 : ((d'',, ggff) : ∑ r, d -->[f·g] r) = (d3 ,,ff;;gg)).
      { apply proofirrelevance. apply isapropifcontr. apply (pr2 D). }
      assert (XT := maponpaths pr1 XR). cbn in XT.
      assert (XT1 := maponpaths pr1 XR1). cbn in XT1.
      generalize XR.
      generalize XR1; clear XR1.
      destruct XT.
      generalize gg; clear gg.
      destruct XT1.
      intros gg XR1 XR0.
      apply iscontraprop1.
      * apply invproofirrelevance.
        intros x x'. apply subtypePath.
        { intro. apply homsets_disp. }
        apply disp_mor_unique_disc_opfib.
      * exists gg.
        cbn.
        assert (XX := pair_inj (isaset_fiber_discrete_opfibration _ _ ) XR1).
        assert (YY := pair_inj (isaset_fiber_discrete_opfibration _ _ ) XR0).
        etrans. apply (!XX). apply YY.
Defined.

End Discrete_OpFibrations.

(** * Split fibrations *)

Definition opcleaving_ob {C : category} {D : disp_cat C}
           (X : opcleaving D) {c c' : C} (f : c' --> c) (d : D c')
  : D c := X _ _ f d.

Definition opcleaving_mor {C : category} {D : disp_cat C}
           (X : opcleaving D) {c c' : C} (f : c' --> c) (d' : D c')
  : d' -->[f] opcleaving_ob X f d' := X _ _ f d'.


Require Import Coq.Lists.List.
Import ListNotations.

Require Export Parser.HasConflictInd.

Lemma matches_nil_unicity_helper:
  forall A (s: Syntax A) ts v1,
    matches s ts v1 ->
    ts = [] ->
    ~ has_conflict_ind s ->
    forall v2,
      matches s [] v2 ->
      v1 = v2.
Proof.
  induction 1;
    repeat light || invert_matches || f_equal || lists || invert_constructor_equalities;
    eauto with matches has_conflict_ind exfalso.
Qed.

Lemma matches_nil_unicity:
  forall A (s: Syntax A) v1 v2,
    ~ has_conflict_ind s ->
    matches s [] v1 ->
    matches s [] v2 ->
    v1 = v2.
Proof.
  eauto using matches_nil_unicity_helper.
Qed.

Ltac matches_nil_unicity :=
  match goal with
  | H: has_conflict_ind ?s -> False, H1: matches ?s [] ?v1, H2: matches ?s [] ?v2 |- _ =>
    pose proof (matches_nil_unicity _ _ _ _ H H1 H2); clear H1
  end.

Ltac matches_nil_unicity2 :=
  match goal with
  | H1: matches ?s [] ?v1, H2: matches ?s [] ?v2 |- _ =>
    unshelve epose proof (matches_nil_unicity _ _ _ _ _ H1 H2); clear H1
  end.