From Hammer Require Import Hammer.
Require Vector Strings.String.
Require Import List.
From Lambda Require Import first_index_foldl.

Inductive AST :=
  | Name : String.string -> AST
  | Abstraction : String.string -> AST -> AST
  (* parameter, then the term under abstraction *)
  | Application : AST -> AST -> AST
  (* function, then argument *)
.

Definition NameList := list (String.string).

Inductive NamelessAST (abs_level : nat) :=
  | Reference : {n : nat | n < abs_level} -> NamelessAST abs_level
  (* Bruijn index *)
  | NamelessAbstraction : NamelessAST (S abs_level) -> NamelessAST abs_level
  (* term under abstraction *)
  | NamelessApplication : NamelessAST abs_level -> NamelessAST abs_level -> NamelessAST abs_level
  (* function, then argument *)
.

Definition search_namelist (l : NameList) (name : String.string) : option {n | n < length l}.
Proof.
 pose (cmp_fun := fun e => name = e).
 pose (cmp_dec := String.string_dec name).
 destruct (first_index l cmp_fun cmp_dec) as [found|not_found].
 - refine (Some _). exists (proj1_sig found).
   destruct found as [found_n found_prop]; simpl.
   destruct (Nat.ltb found_n (length l)) eqn:l_ltb;
   Reconstr.rsimple (@Coq.Lists.List.nth_error_Some) (@NameList).
 - exact None.
Defined.

Local Fixpoint remove_ast_names_h (env : NameList) (ast : AST) : option (NamelessAST (length env)).
Proof.
  destruct ast as [name|parameter abstracted_term|function argument].
  { destruct (search_namelist env name) as [found|].
      - refine (Some _). constructor 1. destruct found as [n n_prop].
        exists (n). assumption.
      - constructor 2. }
  { pose (new_env := parameter :: env).
    destruct (remove_ast_names_h new_env abstracted_term) as [found|].
    - assert (new_env_len : (length new_env) = (S (length env))).
      {  auto. }
      rewrite new_env_len in found.
      exact (Some (NamelessAbstraction _ found)).
    - exact None. }
  { destruct (remove_ast_names_h env function) as [nameless_fun|].
    - destruct (remove_ast_names_h env argument) as [nameless_arg|].
      + exact (Some (NamelessApplication _ nameless_fun nameless_arg)).
      + exact None.
    - exact None. }
Defined.

Definition remove_ast_names (ast : AST) := Eval compute in remove_ast_names_h nil ast.

Inductive Closure := Lambda :
                       {abs_level
                        & ((NamelessAST (abs_level))
                           (* The term under abstraction *)
                           * (Vector.t Closure (abs_level)))%type}
                           (* The environment *)
                       -> Closure.
Definition Applicative := {abs_level
                           & ((NamelessAST (S abs_level))
                              * (Vector.t Closure (abs_level)))%type}.
  (* An abstraction requiring an argument before being applied *)

Definition ProgramState : Set :=
  Closure *
  (* term to evaluate *)
  (list
    (* Continuations *)
      (Closure
      (* we are evaluating the operator, the continuation holds the operand *)
      + Applicative)).
      (* we are evaluating the operand, this is the evaluated operator*)

Definition load_ast : NamelessAST O -> ProgramState.
Proof.
  intros ast. destruct ast as [reference|abstracted_term|function argument].
  - exfalso. Reconstr.scrush.
  - constructor.
    + constructor. exists O. split.
      * constructor 2. exact abstracted_term.
      * constructor 1.
    + constructor 1.
  - constructor.
    + constructor. exists O. split.
      * exact function.
      * constructor 1.
    + constructor 2.
      * left. constructor. exists O. split.
        { exact argument. }
        { constructor 1. }
      * constructor 1.
Defined.

Definition step : ProgramState -> ProgramState.
Proof.
  intros initial_state.
  destruct initial_state as [evaluating_term continuation].
  destruct evaluating_term as [evaluating_closure].
  destruct evaluating_closure as [evaluating_abs_level evaluating_contents].
  destruct evaluating_contents as [evaluating_ast evaluating_environment].
  destruct evaluating_ast as [evaluating_reference
                             |evaluating_abstracted_term
                             |evaluating_function evaluating_argument].
  - (* replace the reference with the element at its index *)
    constructor.
    + exact (Vector.nth_order evaluating_environment (proj2_sig evaluating_reference)).
    + exact continuation.
  - (* this is a lambda; see what's in the continuation *)
    destruct continuation as [|continuation_head continuation_tail].
    + (* the continuation is empty, the program has halted *)
      constructor.
      * constructor. exists evaluating_abs_level. split.
        { constructor 2. exact evaluating_abstracted_term. }
        { exact evaluating_environment. }
      * constructor 1.
    + destruct continuation_head as [continuation_operand
                                    |continuation_applicative].
      * (* put the evaluated operator in the continuation and prepare to
           evaluate the operand *)
        constructor.
        { exact continuation_operand. }
        { constructor 2.
          - right. unfold Applicative. exists evaluating_abs_level.
            split.
            + exact evaluating_abstracted_term.
            + exact evaluating_environment.
          - exact continuation_tail. }
      * (* apply the operator in the continuation to the argument;
           make sure to reconstruct the argument first *)
        constructor.
        { destruct continuation_applicative as [applicative_abs_level applicative_contents].
          destruct applicative_contents as [applicative_term applicative_env].
          constructor. exists (S applicative_abs_level). split.
          - exact applicative_term.
          - constructor 2.
            + constructor. exists evaluating_abs_level. split.
              * constructor 2. exact evaluating_abstracted_term.
              * exact evaluating_environment.
            + exact applicative_env. }
        exact continuation_tail.
  - (* an application; put the argument on the stack and prepare to evaluate
       the operator *)
    constructor.
    + constructor. exists evaluating_abs_level. split.
      * exact evaluating_function.
      * exact evaluating_environment.
    + constructor 2.
      * left. constructor. exists evaluating_abs_level. split.
        { exact evaluating_argument. }
        { exact evaluating_environment. }
      * exact continuation.
Defined.


From caml5 Require Import
  prelude.
From caml5.lang Require Import
  notations
  proofmode.
From caml5.std Require Export
  base.

Implicit Types t : val.

Record mutex `{!heapGS Σ} {unboxed : bool} := {
  mutex_make : val ;
  mutex_lock : val ;
  mutex_unlock : val ;

  mutex_inv : val → iProp Σ → iProp Σ ;
  mutex_locked : val → iProp Σ ;

  mutex_inv_contractive t :
    Contractive (mutex_inv t) ;

  mutex_inv_persistent t P :
    Persistent (mutex_inv t P) ;
  mutex_locked_timeless t :
    Timeless (mutex_locked t) ;

  mutex_locked_exclusive t :
    mutex_locked t -∗
    mutex_locked t -∗
    False ;

  mutex_make_spec P :
    {{{ P }}}
      mutex_make #()
    {{{ t, RET t; mutex_inv t P }}} ;

  mutex_lock_spec t P :
    {{{ mutex_inv t P }}}
      mutex_lock t
    {{{ RET #(); mutex_locked t ∗ P }}} ;

  mutex_unlock_spec t P :
    {{{ mutex_inv t P ∗ mutex_locked t ∗ P }}}
      mutex_unlock t
    {{{ RET #(); True }}} ;

  mutex_unboxed :
    if unboxed then ∀ t P,
      mutex_inv t P -∗
      ⌜val_is_unboxed t⌝
    else
      True ;
}.
#[global] Arguments mutex _ {_} _ : assert.
#[global] Arguments Build_mutex {_ _} _ {_ _ _ _ _ _ _ _ _} _ _ _ _ : assert.
#[global] Existing Instance mutex_inv_contractive.
#[global] Existing Instance mutex_inv_persistent.
#[global] Existing Instance mutex_locked_timeless.

Section mutex.
  Context `{!heapGS Σ} {unboxed} (mutex : mutex Σ unboxed).

  #[global] Instance mutex_inv_ne t :
    NonExpansive (mutex.(mutex_inv) t).
  Proof.
    apply _.
  Qed.
  #[global] Instance mutex_inv_proper t :
    Proper ((≡) ==> (≡)) (mutex.(mutex_inv) t).
  Proof.
    apply _.
  Qed.

  Definition mutex_protect : val :=
    λ: "t" "fn",
      mutex.(mutex_lock) "t" ;;
      let: "res" := "fn" #() in
      mutex.(mutex_unlock) "t" ;;
      "res".

  Lemma mutex_protect_spec t P (fn : val) Φ :
    {{{ mutex.(mutex_inv) t P ∗ {{{ P }}} fn #() {{{ v, RET v; P ∗ Φ v }}} }}}
      mutex_protect t fn
    {{{ v, RET v; Φ v }}}.
  Proof.
    iIntros "%Ψ (#Hinv & Hfn) HΨ".
    wp_rec. wp_pures.
    wp_apply (mutex_lock_spec with "Hinv"). iIntros "(Hlocked & HP)".
    wp_pures.
    wp_apply ("Hfn" with "HP"). iIntros "%v (HP & HΦ)".
    wp_pures.
    wp_apply (mutex_unlock_spec with "[$Hinv $Hlocked $HP]"). iIntros "_".
    wp_pures.
    iApply "HΨ". done.
  Qed.
End mutex.

#[global] Opaque mutex_protect.


From FOL Require Import FullSyntax Arithmetics Theories.
From FOL.Tennenbaum Require Import SyntheticInType NumberUtils Peano.
From Undecidability.Shared Require Import ListAutomation.
Require Import List Lia.
Import Vector.VectorNotations.
Import ListNotations ListAutomationNotations.

Require Import Setoid Morphisms.

Notation Q := PA_compatible_Qeq.
Notation Qeq := PA_compatible_Qeq.
Notation PA := PAeq.

Notation "x ∣ y" := (exists k, x * k = y) (at level 50).

Lemma switch_nat_num α rho (n : nat) : sat interp_nat rho (α[(num n)..]) <-> sat interp_nat (n.:rho) α.
Proof.
  split; intros H.
  - rewrite <- (inu_nat_id n). erewrite <-eval_num. apply sat_single, H.
  - apply sat_single. setoid_rewrite eval_num. now setoid_rewrite inu_nat_id.
Qed.

Definition unary α := bounded 1 α.
Definition binary α := bounded 2 α.

Ltac invert_bounds1 :=
  match goal with
    H : bounded _ _ |- _ => inversion H; subst; clear H
  end.

Ltac invert_bounds :=
  invert_bounds1;
  repeat match goal with
    H : existT _ _ _ = existT _ _ _ |- _ => apply Eqdep_dec.inj_pair2_eq_dec in H; try decide equality; subst
  end.

Lemma inversion_bounded_bin α β n b :
  bounded n (bin b α β) -> bounded n α /\ bounded n β.
Proof.
  intros H. destruct b.
  all: now invert_bounds.
Qed.

(** * PA and Q are consistent in Coq. *)

Lemma PA_consistent : ~ PAeq ⊢TI ⊥.
Proof.
  intros H. eapply tsoundness in H.
  2: instantiate (1 := fun _ => 0).
  apply H.
  intros ax Hax.
  now apply PA_std_axioms.
Qed.
Corollary Q_consistent : ~ Q ⊢I ⊥.
Proof.
  intros H. eapply soundness in H. eapply (H nat interp_nat (fun _ => 0)).
  intros ax Hax.
  now apply Q_std_axioms.
Qed.

(** * Δ1 Formulas. *)

Class Delta1 : Type :=
  mk_Delta1{
    delta1 : form -> Prop
  ; delta1_Q : forall ϕ s, delta1 ϕ -> bounded 0 (ϕ[s]) -> Q ⊢I ϕ[s] \/ Q ⊢I ¬ ϕ[s]
  ; delta1_HA : forall ϕ, delta1 ϕ -> PA ⊢TI ϕ ∨ ¬ ϕ
  ; delta1_subst : forall ϕ s, delta1 ϕ -> delta1 (ϕ[s])
  }.

(* Numerals are closed terms. *)

Lemma closed_num n k : bounded_t k (num n).
Proof.
  eapply bounded_up_t. instantiate (1 := 0).
  induction n; cbn; now solve_bounds. lia.
Qed.

Lemma vec_map_preimage {X N} (v : Vector.t term N) f (x : X) :
  Vector.In x (Vector.map f v) -> exists t, Vector.In t v /\ x = f t.
Proof.
  induction v; cbn; intros H.
  - inversion H.
  - inversion H.
    exists h. split. constructor. reflexivity.
    apply Eqdep_dec.inj_pair2_eq_dec in H3. subst.
    destruct (IHv H2) as [t Ht].
    exists t. split. constructor. all: try apply Ht.
    decide equality.
Qed.

Lemma subst_bound_t t N B sigma :
  bounded_t N t -> (forall n, n < N -> bounded_t B (sigma n) ) -> bounded_t B (t`[sigma]).
Proof.
  induction 1 as [| f v H IH]; intros HN; cbn.
  - now apply HN.
  - constructor. intros s (t & Ht & ->)%vec_map_preimage.
    now apply IH.
Qed.

Lemma subst_bound phi :
  forall sigma N B, bounded N phi -> (forall n, n < N -> bounded_t B (sigma n) ) -> bounded B phi[sigma].
Proof.
  intros sigma N B H1 H2. eapply subst_bounded_max; eauto.
Qed.

Fact Faster1 {X} A (x : X) : A <<= x :: A.
Proof.
  firstorder.
Qed.

Fact Faster2 {X} A (x y : X) : A <<= x :: y :: A.
Proof.
  firstorder.
Qed.

Section Delta1.

  Context {Δ1 : Delta1}.

Lemma Q_neg_equiv ϕ s :
  delta1 ϕ -> bounded 0 ϕ[s] -> (~ Q ⊢I ϕ[s]) <-> Q ⊢I ¬ ϕ[s].
Proof.
  intros d0. split.
    - intros. destruct (@delta1_Q _ ϕ s); tauto.
    - intros H1 H2.
      apply Q_consistent.
      eapply IE. apply H1. apply H2.
Qed.

(** Results concerning Delta_0 formulas. *)

Section Closed.

  Notation "⊨ phi" := (forall rho, rho ⊨ phi) (at level 21).

  Variable phi : form.
  Variable Hcl : bounded 0 phi.
  Variable H0 : delta1 phi.

  Variable D : Type.
  Variable I : interp D.
  Variable axioms : forall ax, PA ax -> ⊨ ax.

  Theorem Q_dec_closed_delta1 :
    Q ⊢I phi \/ Q ⊢I ¬ phi.
  Proof.
    setoid_rewrite <-subst_var. cbn.
    apply delta1_Q; auto.
    now rewrite subst_var.
  Qed.

  Corollary Q_neg_equiv_delta1 :
    (~ Q ⊢I phi) <-> Q ⊢I ¬ phi.
  Proof.
    setoid_rewrite <-subst_var. cbn.
    apply Q_neg_equiv; auto.
    now rewrite subst_var.
  Qed.

  Corollary dec_closed_delta1: PA ⊢TI phi \/ PA ⊢TI ¬ phi.
  Proof.
    destruct Q_dec_closed_delta1 as [H|H].
    - left. exists Q. split; try easy.
      intros psi Hin. now apply PA_compatible_Qeq_PAeq.
    - right. exists Q. split; try easy.
      intros psi Hin. now apply PA_compatible_Qeq_PAeq.
  Qed.

  Corollary neg_equiv_delta1 : (~ PA ⊢TI phi) <-> PA ⊢TI ¬ phi.
  Proof.
    split.
    - intros. now destruct dec_closed_delta1.
    - intros [Γ1 []] [Γ2 []].
      apply PA_consistent.
      exists (Γ1 ++ Γ2)%list.
      split.
      + intros psi [Hl|Hl]%in_app_iff; [apply H|apply H2]; apply Hl.
      + eapply IE. eapply Weak. apply H1. intuition.
        eapply Weak. apply H3. intuition.
  Qed.

  (** ** Δ1 Completeness  *)
  Lemma delta1_complete rho :
    sat interp_nat rho phi -> PA ⊢TI phi.
  Proof.
    intros H. destruct dec_closed_delta1 as [C|C]. assumption.
    specialize (@tsoundness _ _ _ _ _ C _ interp_nat rho) as F.
    exfalso. apply F. apply PA_std_axioms. apply H.
  Qed.

  Lemma Q_delta1_complete rho :
    sat interp_nat rho phi -> Q ⊢I phi.
  Proof.
    intros H. destruct Q_dec_closed_delta1 as [C|C]. assumption.
    specialize (@soundness _ _ _ _ _ C _ interp_nat rho) as F.
    exfalso. apply F.
    apply Q_std_axioms. apply H.
  Qed.

  Lemma delta1_complete' rho :
    sat I rho phi -> PA ⊢TI phi.
  Proof.
    intros H. destruct dec_closed_delta1 as [C|C]. assumption.
    specialize (@tsoundness _ _ _ _ _ C _ I rho) as F.
    exfalso. apply F. intuition. apply H.
  Qed.

  Lemma Q_delta1_complete' rho :
    sat I rho phi -> Q ⊢I phi.
  Proof.
    intros H. destruct Q_dec_closed_delta1 as [C|C]. assumption.
    specialize (@soundness _ _ _ _ _  C _ I rho) as F.
    exfalso. apply F. 2:apply H.
    intros psi Hin. apply axioms. cbv in Hin.
    now apply PA_compatible_Qeq_PAeq.
  Qed.

  (** ** Δ1 Absolutness *)
  Lemma delta1_absolutness' rho :
    sat I rho phi -> PA⊨ phi.
  Proof.
    intros H. apply tsoundness.
    destruct dec_closed_delta1 as [C|C]. assumption.
    specialize (@tsoundness _ _ _ _ _  C _ I rho) as F.
    exfalso. apply F. intuition. apply H.
  Qed.

End Closed.

Notation "N⊨ phi" := (forall rho, @sat _ _ nat (extensional_model interp_nat) _ rho phi) (at level 40).

(** ** sigma1 Completeness  *)
Section Sigma1.

  Variable α : form.
  Variable binary_α : binary α.
  Variable delta1_α : delta1 α.

  Lemma sigma1_complete' n :
    N⊨ (∃ α)[(num n)..] -> exists m, Q ⊢I α[up (num n)..][(num m)..].
  Proof.
    intros [m Hm]%(fun h => h (fun _ => 0)).
    rewrite <-switch_nat_num in Hm. exists m.
    eapply Q_delta1_complete; eauto.
    - eapply subst_bound with (N:=1); eauto.
      eapply subst_bound; eauto.
      intros [|[]] H; try lia; cbn. 1:solve_bounds. rewrite bounded_t_0_subst; apply closed_num.
      intros [|] H; try lia; cbn. 1:solve_bounds.  apply closed_num.
    - rewrite subst_comp.
      now apply delta1_subst.
  Qed.

  Lemma sigma1_complete n :
    N⊨ (∃ α)[(num n)..] -> Q ⊢I (∃ α)[(num n)..].
  Proof.
    intros [m Hm]%sigma1_complete'.
    cbn.
    change (∃ α[up (num n)..]) with (Peano.exist_times 1 (α[up (num n)..])).
    eapply subst_exist_prv; eauto.
    eapply subst_bound; eauto.
    intros [|[]] H; try lia; cbn. 1:solve_bounds. rewrite bounded_t_0_subst; apply closed_num.
  Qed.

  Lemma sigma1_complete'' n :
    Q ⊢I (∃ α)[(num n)..] -> exists m, Q ⊢I α[up (num n)..][(num m)..].
  Proof.
    intros H%soundness.
    apply sigma1_complete'.
    specialize (H nat interp_nat).
    intros ?. apply H.
    intros ??. now apply Q_std_axioms.
  Qed.

End Sigma1.

Section Sigma1.

  Variable α : form.
  Variable ternary_α : bounded 3 α.
  Variable delta1_α : delta1 α.

  Lemma sigma1_ternary_complete' n :
    N⊨ (∃∃α)[(num n)..] -> exists a b, Q ⊢I α[up (up (num n)..)][(num b)..][(num a)..].
  Proof.
    intros [a [b Hab]]%(fun h => h (fun _ => 0)).
    rewrite <-!switch_nat_num in Hab. exists a, b.
    eapply Q_delta1_complete; eauto.
    - eapply subst_bound with (N:=1); eauto.
      eapply subst_bound with (N:=2); eauto.
      eapply subst_bound with (N:=3); eauto.
      intros [|[|[]]] H; try lia; cbn. all:try cbn;solve_bounds. rewrite bounded_t_0_subst.
      1-2: rewrite bounded_t_0_subst; apply closed_num.
      intros [|[]] H; try lia; cbn. 1:solve_bounds. 1: apply closed_num. 1: solve_bounds.
      intros [|] H; try lia; cbn. 1:solve_bounds.  apply closed_num.
    - rewrite !subst_comp.
      now apply delta1_subst.
  Qed.

  Lemma sigma1_ternary_complete n :
    N⊨ (∃∃α)[(num n)..] -> Q ⊢I (∃∃α)[(num n)..].
  Proof.
    intros (a & b & Hab)%sigma1_ternary_complete'.
    cbn.
    change (∃∃ α[up (up (num n)..)]) with (Peano.exist_times 2 (α[up (up (num n)..)])).
    rewrite subst_comp in Hab.
    eapply subst_exist_prv; eauto.
    eapply subst_bound; eauto.
    intros [|[|[]]] H; try lia; solve_bounds. cbn.
    rewrite !num_subst.
    apply closed_num.
  Qed.

End Sigma1.

End Delta1.


(** * Limits and Colimits *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Functor.Composition.Core.
Require Import ExponentialLaws.Law1.Functors FunctorCategory.Core.
Require Import UniversalProperties KanExtensions.Core InitialTerminalCategory.Core NatCategory.
Require Import Functor.Paths NaturalTransformation.Paths.
Require Comma.Core.
Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *)
Import Comma.Core.
Local Set Warnings Append "notation-overridden".
Require Import Equivalences.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope functor_scope.
Local Open Scope category_scope.

(** ** The diagonal or "constant diagram" functor Δ *)
Section diagonal_functor.
  Context `{Funext}.
  Variables C D : PreCategory.

  (**
     Quoting Dwyer and Spalinski:

     There is a diagonal or ``constant diagram'' functor

<<
     Δ : C → Cᴰ,
>>

     which carries an object [X : C] to the constant functor [Δ X : D
     -> C] (by definition, this ``constant functor'' sends each object
     of [D] to [X] and each morphism of [D] to [Identity X]). The
     functor Δ assigns to each morphism [f : X -> X'] of [C] the
     constant natural transformation [t(f) : Δ X -> Δ X'] determined
     by the formula [t(f) d = f] for each object [d] of [D].  **)

  (** We use [C¹] rather than [C] for judgemental compatibility with
      Kan extensions. *)

  Definition diagonal_functor : Functor (1 -> C) (D -> C)
    := @pullback_along _ D 1 C (Functors.to_terminal _).

  Definition diagonal_functor' : Functor C (D -> C)
    := diagonal_functor o ExponentialLaws.Law1.Functors.inverse _.

  Section convert.
    Lemma diagonal_functor_diagonal_functor' X
    : diagonal_functor X = diagonal_functor' (X (center _)).
    Proof.
      path_functor.
      simpl.
      repeat (apply path_forall || intro).
      apply identity_of.
    Qed.
  End convert.
End diagonal_functor.

Arguments diagonal_functor : simpl never.

Section diagonal_functor_lemmas.
  Context `{Funext}.
  Variables C D D' : PreCategory.

  Lemma compose_diagonal_functor x (F : Functor D' D)
  : diagonal_functor C D x o F = diagonal_functor _ _ x.
  Proof.
    path_functor.
  Qed.

  Definition compose_diagonal_functor_natural_transformation
             x (F : Functor D' D)
  : NaturalTransformation (diagonal_functor C D x o F) (diagonal_functor _ _ x)
    := Build_NaturalTransformation
         (diagonal_functor C D x o F)
         (diagonal_functor _ _ x)
         (fun z => identity _)
         (fun _ _ _ => transitivity
                         (left_identity _ _ _ _)
                         (symmetry
                            _ _
                            (right_identity _ _ _ _))).
End diagonal_functor_lemmas.

Hint Rewrite @compose_diagonal_functor : category.

Section Limit.
  Context `{Funext}.
  Variables C D : PreCategory.
  Variable F : Functor D C.

  (** ** Definition of Limit *)
  (**
     Quoting Dwyer and Spalinski:

     Let [D] be a small category and [F : D -> C] a functor. A limit
     for [F] is an object [L] of [C] together with a natural
     transformation [t : Δ L -> F] such that for every object [X] of
     [C] and every natural transformation [s : Δ X -> F], there exists
     a unique map [s' : X -> L] in [C] such that [t (Δ s') = s].  **)

  Definition IsLimit
    := @IsRightKanExtensionAlong _ D 1 C (Functors.to_terminal _) F.
  (*Definition IsLimit' := @IsTerminalMorphism (_ -> _) (_ -> _) (diagonal_functor C D) F.*)
  (*  Definition Limit (L : C) :=
    { t : SmallNaturalTransformation ((diagonal_functor C D) L) F &
      forall X : C, forall s : SmallNaturalTransformation ((diagonal_functor C D) X) F,
        { s' : C.(Morphism) X L |
          unique
          (fun s' => SNTComposeT t ((diagonal_functor C D).(MorphismOf) s') = s)
          s'
        }
    }.*)

  (**
     Quoting Dwyer and Spalinski:

     Let [D] be a small category and [F : D -> C] a functor. A colimit
     for [F] is an object [c] of [C] together with a natural
     transformation [t : F -> Δ c] such that for every object [X] of
     [C] and every natural transformation [s : F -> Δ X], there exists
     a unique map [s' : c -> X] in [C] such that [(Δ s') t = s].  **)

  (** ** Definition of Colimit *)
  Definition IsColimit
    := @IsLeftKanExtensionAlong _ D 1 C (Functors.to_terminal _) F.
  (*Definition IsColimit' := @IsInitialMorphism (_ -> _) (_ -> _) F (diagonal_functor C D).*)
  (*  Definition Colimit (c : C) :=
    { t : SmallNaturalTransformation F ((diagonal_functor C D) c) &
      forall X : C, forall s : SmallNaturalTransformation F ((diagonal_functor C D) X),
        { s' : C.(Morphism) c X | is_unique s' /\
          SNTComposeT ((diagonal_functor C D).(MorphismOf) s') t = s
        }
    }.*)
  (** TODO(JasonGross): Figure out how to get good introduction and elimination rules working, which don't mention spurious identities. *)
  (*Section AbstractionBarrier.
    Section Limit.
      Set Printing  Implicit.
      Section IntroductionAbstractionBarrier.
        Local Open Scope morphism_scope.

        Definition Build_IsLimit
                 (lim_obj : C)
                 (lim_mor : morphism (D -> C)
                                     (diagonal_functor' C D lim_obj)
                                     F)
                 (lim := CommaCategory.Build_object
                           (diagonal_functor C D)
                           !(F : object (_ -> _))
                           !lim_obj
                           (center _)
                           lim_mor)
                 (UniversalProperty
                  : forall (lim_obj' : C)
                           (lim_mor' : morphism (D -> C)
                                                (diagonal_functor' C D lim_obj')
                                                F),
                      Contr { m : morphism C lim_obj' lim_obj
                            | lim_mor o morphism_of (diagonal_functor' C D) m = lim_mor' })
        : IsTerminalMorphism lim.
        Proof.
          apply Build_IsTerminalMorphism.
          intros A' p'.
          specialize (UniversalProperty (A' (center _))).*)
End Limit.

(** TODO(JasonGross): Port MorphismsBetweenLimits from catdb *)


Require Import Omega.
Require Import RelationClasses.

Require Import sflib.

Require Import Axioms.
Require Import Basic.
Require Import DataStructure.
Require Import Loc.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.

Set Implicit Arguments.

(** * Thread View *)
Module TView <: JoinableType.
  (** Thread view includes:
      - [rel]: release view;
      - [cur]: current view;
      - [acq]: acq view.

  In our paper, to simplify the presentation,
  the thread view only contains the current view.

  Release and acquire views are used to model the
  semantics of fence operations. *)
  Structure t_ := mk {
    rel: LocFun.t View.t;
    cur: View.t;
    acq: View.t;
  }.
  Definition t := t_.

  Definition bot: t := mk (LocFun.init View.bot) View.bot View.bot.

  Inductive wf (tview:t): Prop :=
  | wf_intro
      (REL: forall loc, View.wf ((rel tview) loc))
      (CUR: View.wf (cur tview))
      (ACQ: View.wf (acq tview))
      (REL_CUR: forall loc, View.le ((rel tview) loc) (cur tview))
      (CUR_ACQ: View.le (cur tview) (acq tview))
  .

  Inductive closed (tview:t) (mem:Memory.t): Prop :=
  | closed_intro
      (REL: forall loc, Memory.closed_view ((rel tview) loc) mem)
      (CUR: Memory.closed_view (cur tview) mem)
      (ACQ: Memory.closed_view (acq tview) mem)
  .

  Lemma bot_wf: wf bot.
  Proof.
    econs; i; econs; refl.
  Qed.

  Lemma bot_closed: closed bot Memory.init.
  Proof.
    econs; i; eapply Memory.closed_view_bot; apply Memory.init_closed.
  Qed.

  Lemma future_closed
        tview mem1 mem2
        (CLOSED: closed tview mem1)
        (FUTURE: Memory.future mem1 mem2):
    closed tview mem2.
  Proof.
    inv CLOSED. econs; i; eapply Memory.future_closed_view; eauto.
  Qed.

  Lemma future_weak_closed
        tview mem1 mem2
        (CLOSED: closed tview mem1)
        (FUTURE: Memory.future_weak mem1 mem2):
    closed tview mem2.
  Proof.
    inv CLOSED. econs; i; eapply Memory.future_weak_closed_view; eauto.
  Qed.

  Lemma cap_closed
        tview mem1 mem2
        (CLOSED: closed tview mem1)
        (CAP: Memory.cap mem1 mem2):
    closed tview mem2.
  Proof.
    inv CLOSED. econs; i; eapply Memory.cap_closed_view; eauto.
  Qed.

  Lemma promise_closed
        tview1
        promises1 mem1 loc from to msg promises2 mem2 kind
        (CLOSED: closed tview1 mem1)
        (PROMISE: Memory.promise promises1 mem1 loc from to msg promises2 mem2 kind):
    closed tview1 mem2.
  Proof.
    inv CLOSED. econs; i; eapply Memory.promise_closed_view; eauto.
  Qed.

  Definition eq := @eq t.

  Inductive le_ (lhs rhs:t): Prop := (*TODO: what's le? *)
  | le_intro
      (REL: forall (loc:Loc.t), View.le (LocFun.find loc (rel lhs)) (LocFun.find loc (rel rhs)))
      (CUR: View.le (cur lhs) (cur rhs))
      (ACQ: View.le (acq lhs) (acq rhs))
  .
  Definition le := le_.

  Global Program Instance le_PreOrder: PreOrder le.
  Next Obligation.
    ii. econs; refl.
  Qed.
  Next Obligation.
    ii. inv H. inv H0. econs; etrans; eauto.
  Qed.

  Definition join (lhs rhs:t): t :=
    mk (fun loc => View.join ((rel lhs) loc) ((rel rhs) loc))
       (View.join (cur lhs) (cur rhs))
       (View.join (acq lhs) (acq rhs)).

  Lemma join_comm lhs rhs: join lhs rhs = join rhs lhs.
  Proof.
    unfold join. f_equal.
    - apply LocFun.ext. i. apply View.join_comm.
    - apply View.join_comm.
    - apply View.join_comm.
  Qed.

  Lemma join_assoc a b c: join (join a b) c = join a (join b c).
  Proof.
    unfold join. s. f_equal.
    - apply LocFun.ext. i. apply View.join_assoc.
    - apply View.join_assoc.
    - apply View.join_assoc.
  Qed.

  Lemma join_l lhs rhs: le lhs (join lhs rhs).
  Proof.
    econs.
    - i. apply View.join_l.
    - apply View.join_l.
    - apply View.join_l.
  Qed.

  Lemma join_r lhs rhs: le rhs (join lhs rhs).
  Proof.
    econs.
    - i. apply View.join_r.
    - apply View.join_r.
    - apply View.join_r.
  Qed.

  Lemma join_spec lhs rhs o
        (LHS: le lhs o)
        (RHS: le rhs o):
    le (join lhs rhs) o.
  Proof.
    inv LHS. inv RHS. econs.
    - i. apply View.join_spec; eauto.
    - apply View.join_spec; eauto.
    - apply View.join_spec; eauto.
  Qed.

  Inductive readable
            (view1:View.t) (loc:Loc.t) (ts:Time.t) (released:option View.t) (ord:Ordering.t): Prop :=
  | readable_intro
      (PLN: Time.le ((View.pln view1) loc) ts)
      (RLX: Ordering.le Ordering.relaxed ord ->
            Time.le ((View.rlx view1) loc) ts)
  .

  Definition read_tview
             (tview1:t) (loc:Loc.t) (ts:Time.t) (released:option View.t) (ord:Ordering.t): t :=
    mk (rel tview1)
       (View.join
          (View.join
             (cur tview1)
             (View.singleton_ur_if (Ordering.le Ordering.relaxed ord) loc ts))
          (if Ordering.le Ordering.acqrel ord then (View.unwrap released) else View.bot))
       (View.join
          (View.join
             (acq tview1)
             (View.singleton_ur_if (Ordering.le Ordering.relaxed ord) loc ts))
          (if Ordering.le Ordering.relaxed ord then (View.unwrap released) else View.bot)).

  Inductive writable
            (view1:View.t) (sc1:TimeMap.t) (loc:Loc.t) (ts:Time.t) (ord:Ordering.t): Prop :=
  | writable_intro
      (TS: Time.lt ((View.rlx view1) loc) ts)
  .

  Definition write_tview
             (tview1:t) (sc1:TimeMap.t) (loc:Loc.t) (ts:Time.t) (ord:Ordering.t): t :=
    let cur2 := View.join
                  (cur tview1)
                  (View.singleton_ur loc ts)
    in
    let acq2 := View.join
                  (acq tview1)
                  (View.singleton_ur loc ts)
    in
    let rel2 := LocFun.add loc
                     (if Ordering.le Ordering.acqrel ord then cur2 else View.join ((rel tview1) loc) (View.singleton_ur loc ts))
                  (rel tview1)
    in
    mk rel2 cur2 acq2.

  Definition write_released tview sc loc ts releasedm ord :=
    if Ordering.le Ordering.relaxed ord
    then Some (View.join
                 (View.unwrap releasedm)
                 ((rel (write_tview tview sc loc ts ord)) loc))
    else None.

  Definition read_fence_tview
             (tview1:t) (ord:Ordering.t): t :=
    mk (rel tview1)
                (if Ordering.le Ordering.acqrel ord
                 then (acq tview1)
                 else (cur tview1))
                (acq tview1).

  Definition write_fence_sc
             (tview1:t) (sc1:TimeMap.t) (ord:Ordering.t): TimeMap.t :=
    if Ordering.le Ordering.seqcst ord
    then TimeMap.join sc1 (View.rlx (cur tview1))
    else sc1.

  Definition write_fence_tview
             (tview1:t) (sc1:TimeMap.t) (ord:Ordering.t): t :=
    let sc2 := write_fence_sc tview1 sc1 ord in
	  let cur2 := if Ordering.le Ordering.seqcst ord then View.mk sc2 sc2 else (cur tview1)
	  in
	  let acq2 := View.join
                  (acq tview1)
				          (if Ordering.le Ordering.seqcst ord then View.mk sc2 sc2 else View.bot)
	  in
	  let rel2 := fun l => if Ordering.le Ordering.acqrel ord then cur2 else ((rel tview1) l)
    in
    mk rel2 cur2 acq2.

  Lemma antisym l r
        (LR: le l r)
        (RL: le r l):
    l = r.
  Proof.
    destruct l, r. inv LR. inv RL. ss. f_equal.
    - apply LocFun.ext. i. apply View.antisym; auto.
    - apply View.antisym; auto.
    - apply View.antisym; auto.
  Qed.
End TView.

Module TViewFacts.
  Lemma rlx_le_view_le
        c tm
        (WF: View.wf c)
        (SC: TimeMap.le (View.rlx c) tm):
    View.le c (View.mk tm tm).
  Proof.
    econs; auto.
    - etrans; eauto. apply WF.
  Qed.

  Ltac tac :=
    repeat
      (try match goal with
           | [H: ?a <> ?a |- _] => congr
           | [H: Memory.closed ?mem |- Memory.inhabited ?mem] =>
             apply H
           | [|- View.le ?s ?s] =>
             refl
           | [|- TimeMap.le ?s ?s] =>
             refl
           | [|- View.le View.bot ?s] =>
             apply View.bot_spec
           | [|- TimeMap.le TimeMap.bot _] =>
             apply TimeMap.bot_spec
           | [|- Time.le (TimeMap.bot _) _] =>
             apply Time.bot_spec
           | [|- Time.le (LocFun.init Time.bot _) _] =>
             apply Time.bot_spec
           | [|- View.le ?s (View.join _ ?s)] =>
             apply View.join_r
           | [|- View.le ?s (View.join ?s _)] =>
             apply View.join_l
           | [|- TimeMap.le ?s (TimeMap.join _ ?s)] =>
             apply TimeMap.join_r
           | [|- TimeMap.le ?s (TimeMap.join ?s _)] =>
             apply TimeMap.join_l
           | [|- Memory.closed_view View.bot ?m] =>
             apply Memory.closed_view_bot
           | [|- Memory.closed_timemap TimeMap.bot ?m] =>
             apply Memory.closed_timemap_bot
           | [WF: TView.wf ?c |- View.le ((TView.rel ?c) ?l) (TView.cur ?c)] =>
             apply WF
           | [WF: TView.wf ?c |- View.le ((TView.rel ?c) ?l) (TView.acq ?c)] =>
             etrans; apply WF
           | [WF: TView.wf ?c |- View.le (TView.cur ?c) (TView.acq ?c)] =>
             apply WF
           | [WF: View.wf ?c |- TimeMap.le (View.pln ?c) (View.rlx ?c)] =>
             apply WF
           | [WF: View.opt_wf ?released |- View.wf (View.unwrap ?released)] =>
             apply View.unwrap_opt_wf
           | [WF: View.opt_le ?rel1 ?rel2 |- View.le (View.unwrap ?rel1) (View.unwrap ?rel2)] =>
             apply View.unwrap_opt_le
           | [WF: Memory.closed_opt_view ?view ?mem |- Memory.closed_view (View.unwrap ?view) ?mem] =>
             apply Memory.unwrap_closed_opt_view
           | [|- View.opt_wf None] =>
             econs
           | [|- Memory.closed_opt_view None ?mem] =>
             econs

           | [H1: is_true (Ordering.le ?o Ordering.relaxed),
              H2: Ordering.le Ordering.acqrel ?o = true |- _] =>
               by destruct o; inv H1; inv H2
           | [H1: is_true (Ordering.le ?o Ordering.relaxed),
              H2: Ordering.le Ordering.seqcst ?o = true |- _] =>
               by destruct o; inv H1; inv H2
           | [H1: is_true (Ordering.le ?o Ordering.acqrel),
              H2: Ordering.le Ordering.seqcst ?o = true |- _] =>
               by destruct o; inv H1; inv H2
           | [H1: is_true (Ordering.le ?o Ordering.plain),
              H2: Ordering.le Ordering.acqrel ?o = true |- _] =>
               by destruct o; inv H1; inv H2
           | [H1: is_true (Ordering.le ?o Ordering.plain),
              H2: Ordering.le Ordering.relaxed ?o = true |- _] =>
               by destruct o; inv H1; inv H2
           | [H1: is_true (Ordering.le ?o Ordering.plain),
              H2: is_true (Ordering.le Ordering.relaxed ?o) |- _] =>
               by destruct o; inv H1; inv H2
           | [H1: is_true (Ordering.le ?o Ordering.plain),
              H2: is_true (Ordering.le Ordering.seqcst ?o) |- _] =>
               by destruct o; inv H1; inv H2
           | [H1: is_true (Ordering.le ?o Ordering.acqrel),
              H2: is_true (Ordering.le Ordering.seqcst ?o) |- _] =>
               by destruct o; inv H1; inv H2
           | [H1: is_true (Ordering.le ?o Ordering.relaxed),
              H2: is_true (Ordering.le Ordering.seqcst ?o) |- _] =>
               by destruct o; inv H1; inv H2
           | [H1: is_true (Ordering.le ?o1 ?o2),
              H2: Ordering.le ?o0 ?o1 = true,
              H3: Ordering.le ?o0 ?o2 = false |- _] =>
               by destruct o1, o2; inv H1; inv H2; inv H3
           | [|- View.wf (View.mk ?tm ?tm)] =>
               by econs; refl
           | [|- View.wf (View.mk TimeMap.bot TimeMap.bot _)] =>
             econs; apply TimeMap.bot_spec

           | [|- View.le (View.join _ _) _] =>
             apply View.join_spec
           | [|- View.le (View.singleton_ur _ _) _] =>
             apply View.singleton_ur_spec
           | [|- View.le (View.singleton_rw _ _) _] =>
             apply View.singleton_rw_spec
           | [|- View.le (View.singleton_ur_if _ _ _) _] =>
             apply View.singleton_ur_if_spec
           | [|- TimeMap.le (TimeMap.singleton _ _) _] =>
             apply TimeMap.singleton_spec
           | [|- TimeMap.le (TimeMap.join _ _) _] =>
             apply TimeMap.join_spec
           | [|- Time.le (TimeMap.join _ _ _) _] =>
             apply Time.join_spec
           | [|- Time.lt (TimeMap.join _ _ _) _] =>
             apply TimeFacts.join_spec_lt

           | [|- Memory.closed_view (View.join _ _) _] =>
             eapply Memory.join_closed_view; eauto
           | [|- Memory.closed_view (View.singleton_ur _ _) _] =>
             eapply Memory.singleton_ur_closed_view; eauto
           | [|- Memory.closed_view (View.singleton_rw _ _) _] =>
             eapply Memory.singleton_rw_closed_view; eauto
           | [|- Memory.closed_view (View.singleton_ur_if _ _ _) _] =>
             eapply Memory.singleton_ur_if_closed_view; eauto
           | [|- Memory.closed_timemap (TimeMap.join _ _) _] =>
             eapply Memory.join_closed_timemap; eauto
           | [|- Memory.closed_timemap (TimeMap.singleton _ _) _] =>
             eapply Memory.singleton_closed_timemap; eauto

           | [H1: Memory.closed_view ?c ?m1,
              H2: Memory.future ?m1 ?m2 |-
              Memory.closed_view ?c ?m2] =>
             eapply Memory.future_closed_view; [exact H2|exact H1]
           | [H1: Memory.closed_opt_view ?c ?m1,
              H2: Memory.future ?m1 ?m2 |-
              Memory.closed_opt_view ?c ?m2] =>
             eapply Memory.future_closed_opt_view; [exact H2|exact H1]
           | [H1: Memory.closed_timemap ?tm ?m1,
              H2: Memory.future ?m1 ?m2 |-
              Memory.closed_timemap ?tm ?m2] =>
             eapply Memory.future_closed_timemap; [exact H2|exact H1]

           | [|- View.wf (View.join _ _)] =>
             eapply View.join_wf; eauto
           | [|- View.wf (View.singleton_ur _ _)] =>
             eapply View.singleton_ur_wf; eauto
           | [|- View.wf (View.singleton_rw _ _)] =>
             eapply View.singleton_rw_wf; eauto
           | [|- View.wf (View.singleton_ur_if _ _ _)] =>
             eapply View.singleton_ur_if_wf; eauto
           | [|- View.wf View.bot] =>
             apply View.bot_wf

           | [H: Time.lt ?a ?b |- Time.le ?a ?b] =>
             left; apply H
           | [|- Time.le ?a ?a] =>
             refl
           | [|- View.le (View.mk ?tm1 ?tm1) (View.mk ?tm2 ?tm2)] =>
             apply View.timemap_le_le
           | [|- context[LocFun.find _ (LocFun.add _ _ _)]] =>
             rewrite LocFun.add_spec
           | [|- context[TimeMap.singleton ?l _ ?l]] =>
             unfold TimeMap.singleton
           | [|- context[LocFun.add ?l _ _ ?l]] =>
             unfold LocFun.add;
             match goal with
             | [|- context[Loc.eq_dec ?l ?l]] =>
               destruct (Loc.eq_dec l l); [|congr]
             end
           | [|- context[LocFun.find _ _]] =>
             unfold LocFun.find
           | [|- context[LocFun.add _ _ _]] =>
             unfold LocFun.add

           (* | [H: _ <> _ |- _] => inv H *)
           end; subst; ss; i).

  Ltac aggrtac :=
    repeat
      (tac;
       try match goal with
           | [|- Time.le ?t1 (TimeMap.singleton ?l ?t2 ?l)] =>
             unfold TimeMap.singleton, LocFun.add; condtac; [|congr]
           | [|- View.le _ (View.join _ _)] =>
             try (by rewrite <- View.join_l; aggrtac);
             try (by rewrite <- View.join_r; aggrtac)
           | [|- TimeMap.le _ (TimeMap.join _ _)] =>
             try (by rewrite <- TimeMap.join_l; aggrtac);
             try (by rewrite <- TimeMap.join_r; aggrtac)
           | [|- Time.le _ (TimeMap.join _ _ _)] =>
             try (by etrans; [|by apply Time.join_l]; aggrtac);
             try (by etrans; [|by apply Time.join_r]; aggrtac)

           | [|- View.le _ (View.mk ?tm ?tm)] =>
             apply rlx_le_view_le
           end).

  Lemma read_tview_incr
        tview1 loc ts released ord:
    TView.le tview1 (TView.read_tview tview1 loc ts released ord).
  Proof.
    econs; tac.
    - rewrite <- ? View.join_l. refl.
    - rewrite <- ? View.join_l. refl.
  Qed.

  Lemma write_tview_incr
        tview1 sc1 loc ts ord
        (WF1: TView.wf tview1):
    TView.le tview1 (TView.write_tview tview1 sc1 loc ts ord).
  Proof.
    econs; repeat (try condtac; aggrtac).
  Qed.

  Lemma read_fence_tview_incr
        tview1 ord
        (WF1: TView.wf tview1):
    TView.le tview1 (TView.read_fence_tview tview1 ord).
  Proof.
    econs; tac. condtac; tac.
  Qed.

  Lemma write_fence_tview_incr
        tview1 sc1 ord
        (WF1: TView.wf tview1):
    TView.le tview1 (TView.write_fence_tview tview1 sc1 ord).
  Proof.
    unfold TView.write_fence_tview, TView.write_fence_sc.
    econs; repeat (try condtac; aggrtac; try apply WF1).
    - etrans; [apply WF1|]. tac.
  Qed.

  Lemma write_fence_sc_incr
        tview1 sc1 ord:
    TimeMap.le sc1 (TView.write_fence_sc tview1 sc1 ord).
  Proof.
    unfold TView.write_fence_sc. condtac; tac.
  Qed.

  Lemma readable_mon
        view1 view2 loc ts released1 released2 ord1 ord2
        (VIEW: View.le view1 view2)
        (REL: View.opt_le released1 released2)
        (ORD: Ordering.le ord1 ord2)
        (READABLE: TView.readable view2 loc ts released2 ord2):
    TView.readable view1 loc ts released1 ord1.
  Proof.
    inv READABLE. econs; eauto.
    - etrans; try apply VIEW; auto.
    - etrans; [apply VIEW|]. apply RLX. etrans; eauto.
  Qed.

  Lemma writable_mon
        view1 view2 sc1 sc2 loc ts ord1 ord2
        (VIEW: View.le view1 view2)
        (SC: TimeMap.le sc1 sc2)
        (ORD: Ordering.le ord1 ord2)
        (WRITABLE: TView.writable view2 sc2 loc ts ord2):
    TView.writable view1 sc1 loc ts ord1.
  Proof.
    inv WRITABLE. econs; eauto.
    - eapply TimeFacts.le_lt_lt; try apply VIEW; auto.
  Qed.

  Lemma read_tview_mon
        tview1 tview2 loc ts released1 released2 ord1 ord2
        (TVIEW: TView.le tview1 tview2)
        (REL: View.opt_le released1 released2)
        (WF2: TView.wf tview2)
        (WF_REL2: View.opt_wf released2)
        (ORD: Ordering.le ord1 ord2):
    TView.le
      (TView.read_tview tview1 loc ts released1 ord1)
      (TView.read_tview tview2 loc ts released2 ord2).
  Proof.
    unfold TView.read_tview, View.singleton_ur_if.
    econs; repeat (condtac; aggrtac);
      (try by etrans; [apply TVIEW|aggrtac]);
      (try by rewrite <- ? View.join_r; econs; aggrtac);
      (try apply WF2).
  Qed.

  Lemma write_tview_mon
        tview1 tview2 sc1 sc2 loc ts ord1 ord2
        (TVIEW: TView.le tview1 tview2)
        (SC: TimeMap.le sc1 sc2)
        (WF2: TView.wf tview2)
        (ORD: Ordering.le ord1 ord2):
    TView.le
      (TView.write_tview tview1 sc1 loc ts ord1)
      (TView.write_tview tview2 sc2 loc ts ord2).
  Proof.
    unfold TView.write_tview, View.singleton_ur_if.
    econs; repeat (condtac; aggrtac);
      (try by etrans; [apply TVIEW|aggrtac]);
      (try by rewrite <- ? View.join_r; econs; aggrtac);
      (try apply WF2).
  Qed.

  Lemma write_released_mon
        tview1 tview2 sc1 sc2 loc ts releasedm1 releasedm2 ord1 ord2
        (TVIEW: TView.le tview1 tview2)
        (SC: TimeMap.le sc1 sc2)
        (WF2: TView.wf tview2)
        (RELM_LE: View.opt_le releasedm1 releasedm2)
        (RELM_WF2: View.opt_wf releasedm2)
        (ORD: Ordering.le ord1 ord2):
    View.opt_le
      (TView.write_released tview1 sc1 loc ts releasedm1 ord1)
      (TView.write_released tview2 sc2 loc ts releasedm2 ord2).
  Proof.
    unfold TView.write_released, TView.write_tview.
    destruct (Ordering.le Ordering.relaxed ord1) eqn:ORD1,
             (Ordering.le Ordering.relaxed ord2) eqn:ORD2; tac;
      try econs; repeat (condtac; aggrtac);
      (try by etrans; [apply TVIEW|aggrtac]);
      (try by rewrite <- ? View.join_r; econs; aggrtac);
      (try by rewrite <- ? TimeMap.join_l; apply RELM);
      (try by rewrite <- TimeMap.join_r, <- ? TimeMap.join_l; etrans; [apply TVIEW|apply WF2]);
      (try apply WF2).
  Qed.

  Lemma write_released_mon'
        tview1 tview2 sc1 sc2 loc ts releasedm1 releasedm2 ord1 ord2
        (TVIEW: TView.le tview1 tview2)
        (WF2: TView.wf tview2)
        (RELM_LE: View.opt_le releasedm1 releasedm2)
        (RELM_WF2: View.opt_wf releasedm2)
        (ORD: Ordering.le ord1 ord2):
    View.opt_le
      (TView.write_released tview1 sc1 loc ts releasedm1 ord1)
      (TView.write_released tview2 sc2 loc ts releasedm2 ord2).
  Proof.
    unfold TView.write_released, TView.write_tview.
    destruct (Ordering.le Ordering.relaxed ord1) eqn:ORD1,
             (Ordering.le Ordering.relaxed ord2) eqn:ORD2; tac;
      try econs; repeat (condtac; aggrtac);
      (try by etrans; [apply TVIEW|aggrtac]);
      (try by rewrite <- ? View.join_r; econs; aggrtac);
      (try by rewrite <- ? TimeMap.join_l; apply RELM);
      (try by rewrite <- TimeMap.join_r, <- ? TimeMap.join_l; etrans; [apply TVIEW|apply WF2]);
      (try apply WF2).
  Qed.

  Lemma read_fence_tview_mon
        tview1 tview2 ord1 ord2
        (TVIEW: TView.le tview1 tview2)
        (WF2: TView.wf tview2)
        (ORD: Ordering.le ord1 ord2):
    TView.le
      (TView.read_fence_tview tview1 ord1)
      (TView.read_fence_tview tview2 ord2).
  Proof.
    unfold TView.read_fence_tview.
    econs; repeat (condtac; aggrtac);
      (try by etrans; [apply TVIEW|aggrtac]);
      (try by rewrite <- ? View.join_r; aggrtac;
       rewrite <- ? TimeMap.join_r; apply TVIEW).
  Qed.

  Lemma write_fence_tview_mon
        tview1 tview2 sc1 sc2 ord1 ord2
        (TVIEW: TView.le tview1 tview2)
        (SC: TimeMap.le sc1 sc2)
        (ORD: Ordering.le ord1 ord2)
        (WF1: TView.wf tview1):
    TView.le
      (TView.write_fence_tview tview1 sc1 ord1)
      (TView.write_fence_tview tview2 sc2 ord2).
  Proof.
    unfold TView.write_fence_tview, TView.write_fence_sc.
    econs; repeat (condtac; aggrtac).
    all: try by etrans; [apply TVIEW|aggrtac].
    all: try by apply WF1.
    all: try by rewrite <- ? View.join_r; aggrtac;
      (rewrite <- ? TimeMap.join_r; apply TVIEW);
      (try by apply WF1).
    - rewrite <- TimeMap.join_r. etrans; [apply WF1|]. apply TVIEW.
    - etrans; [apply WF1|]. apply TVIEW.
  Qed.

  Lemma write_fence_sc_mon
        tview1 tview2 sc1 sc2 ord1 ord2
        (TVIEW: TView.le tview1 tview2)
        (SC: TimeMap.le sc1 sc2)
        (ORD: Ordering.le ord1 ord2):
    TimeMap.le
      (TView.write_fence_sc tview1 sc1 ord1)
      (TView.write_fence_sc tview2 sc2 ord2).
  Proof.
    unfold TView.write_fence_sc.
    repeat (condtac; aggrtac);
      (try by etrans; [apply TVIEW|aggrtac]);
      (try rewrite <- ? View.join_r; aggrtac;
       rewrite <- ? TimeMap.join_r; apply TVIEW).
  Qed.

  Lemma write_tview_acqrel
        tview sc1 sc2 loc ts ordw
        (ORDW: Ordering.le ordw Ordering.acqrel):
    TView.write_tview tview sc1 loc ts ordw = TView.write_tview tview sc2 loc ts ordw.
  Proof.
    unfold TView.write_tview.
    apply TView.antisym; repeat (condtac; tac; try refl).
  Qed.

  Lemma write_fence_sc_acqrel
        tview sc ordw
        (ORDW: Ordering.le ordw Ordering.acqrel):
    TView.write_fence_sc tview sc ordw = sc.
  Proof.
    unfold TView.write_fence_sc. condtac; tac.
  Qed.

  Lemma write_fence_tview_acqrel
        tview sc1 sc2 ordw
        (ORDW: Ordering.le ordw Ordering.acqrel):
    TView.write_fence_tview tview sc1 ordw = TView.write_fence_tview tview sc2 ordw.
  Proof.
    unfold TView.write_fence_tview.
    apply TView.antisym; repeat (condtac; tac; try refl).
  Qed.

  Lemma write_fence_tview_strong_relaxed
        tview sc o (ORD: Ordering.le o Ordering.strong_relaxed):
    TView.write_fence_tview tview sc o = tview.
  Proof.
    unfold TView.write_fence_tview, TView.write_fence_sc.
    destruct tview. ss.
    f_equal; repeat (condtac; aggrtac); try by destruct o.
    rewrite View.join_comm, View.join_bot_l. ss.
  Qed.

  Lemma read_future1
        loc from to val released ord tview mem
        (WF_TVIEW: TView.wf tview)
        (RELEASED: View.opt_wf released)
        (GET: Memory.get loc to mem = Some (from, Message.concrete val released)):
    <<WF_TVIEW: TView.wf (TView.read_tview tview loc to released ord)>>.
  Proof.
    econs; repeat (try condtac; tac);
        try by rewrite <- ? View.join_l; apply WF_TVIEW.
    - apply TimeMap.singleton_inv.
      rewrite <- TimeMap.join_l. tac.
    - apply TimeMap.singleton_inv.
      rewrite <- TimeMap.join_l. tac.
    - destruct ord; inv COND; inv COND0.
  Qed.

  Lemma read_future
        loc from to val released ord tview mem
        (MEM: Memory.closed mem)
        (WF_TVIEW: TView.wf tview)
        (CLOSED_TVIEW: TView.closed tview mem)
        (RELEASED: View.opt_wf released)
        (GET: Memory.get loc to mem = Some (from, Message.concrete val released)):
    <<WF_TVIEW: TView.wf (TView.read_tview tview loc to released ord)>> /\
    <<CLOSED_TVIEW: TView.closed (TView.read_tview tview loc to released ord) mem>>.
  Proof.
    splits; try eapply read_future1; eauto.
    inv MEM. exploit CLOSED; eauto. i. des. inv MSG_CLOSED.
    econs; tac; try apply CLOSED_TVIEW; condtac; tac.
  Qed.

  Lemma op_closed_tview
        mem1 tview1 sc1 loc from to val released ord mem2 kind
        (CLOSED1: Memory.closed mem1)
        (CLOSED2: TView.closed tview1 mem1)
        (OP: Memory.op mem1 loc from to (Message.concrete val released) mem2 kind):
    TView.closed (TView.write_tview tview1 sc1 loc to ord) mem2.
  Proof.
    hexploit Memory.op_inhabited; eauto; try by tac. i. des.
    unfold TView.write_tview.
    destruct (Memory.op_kind_is_cancel kind) eqn:KIND.
    { destruct kind; ss. inv OP. ss. }
    econs; repeat (try condtac; tac);
      (try by eapply Memory.op_closed_view; eauto; apply CLOSED2);
      (try by econs; tac; eapply Memory.op_closed_timemap; eauto; apply CLOSED0);
      (try by eapply Memory.op_get2; eauto).
  Qed.

  Lemma op_closed_sc
        mem1 sc1 loc from to msg mem2 kind
        (CLOSED0: Memory.closed_timemap sc1 mem1)
        (CLOSED1: Memory.closed mem1)
        (OP: Memory.op mem1 loc from to msg mem2 kind):
    Memory.closed_timemap sc1 mem2.
  Proof.
    hexploit Memory.op_inhabited; eauto; try by tac. i. des.
    eapply Memory.op_closed_timemap; eauto.
  Qed.

  Lemma op_closed_released
        mem1 tview1 sc1 loc from to val releasedm released ord mem2 kind
        (CLOSED1: Memory.closed mem1)
        (CLOSED2: TView.closed tview1 mem1)
        (CLOSED3: Memory.closed_opt_view releasedm mem1)
        (OP: Memory.op mem1 loc from to (Message.concrete val released) mem2 kind):
    Memory.closed_opt_view (TView.write_released tview1 sc1 loc to releasedm ord) mem2.
  Proof.
    hexploit Memory.op_inhabited; eauto; try by tac. i. des.
    unfold TView.write_released. condtac; econs.
    apply Memory.join_closed_view.
    - eapply Memory.op_closed_view; eauto.
      apply Memory.unwrap_closed_opt_view; tac.
    - eapply op_closed_tview; eauto.
  Qed.

  Lemma get_closed_tview
        mem1 tview1 sc1 loc from to val released ord
        (CLOSED1: Memory.closed mem1)
        (CLOSED2: TView.closed tview1 mem1)
        (GET: Memory.get loc to mem1 = Some (from, Message.concrete val released)):
    TView.closed (TView.write_tview tview1 sc1 loc to ord) mem1.
  Proof.
    econs; tac; (try by apply CLOSED2).
    unfold LocFun.add. repeat condtac; tac; (try by apply CLOSED2).
  Qed.

  Lemma get_closed_released
        mem1 tview1 sc1 loc from to val releasedm released ord
        (CLOSED1: Memory.closed mem1)
        (CLOSED2: TView.closed tview1 mem1)
        (CLOSED3: Memory.closed_opt_view releasedm mem1)
        (GET: Memory.get loc to mem1 = Some (from, Message.concrete val released)):
    Memory.closed_opt_view (TView.write_released tview1 sc1 loc to releasedm ord) mem1.
  Proof.
    unfold TView.write_released. condtac; econs.
    apply Memory.join_closed_view.
    - apply Memory.unwrap_closed_opt_view; tac.
    - eapply get_closed_tview; eauto.
  Qed.

  Lemma write_future0
        loc to releasedm ord tview sc
        (WF_TVIEW: TView.wf tview)
        (WF_RELM: View.opt_wf releasedm):
    <<WF_TVIEW: TView.wf (TView.write_tview tview sc loc to ord)>> /\
    <<WF_RELEASED: View.opt_wf (TView.write_released tview sc loc to releasedm ord)>>.
  Proof.
    splits; tac.
    - econs; tac; try apply WF_TVIEW.
      + unfold LocFun.add, LocFun.find. repeat condtac; tac; try apply WF_TVIEW.
      + repeat condtac; aggrtac; rewrite <- ? View.join_l; try apply WF_TVIEW.
      + repeat condtac; tac; rewrite <- ? View.join_l; apply WF_TVIEW.
    - unfold TView.write_released. condtac; econs. repeat (try condtac; aggrtac; try apply WF_TVIEW).
  Qed.

  Lemma write_future
        loc from to val releasedm ord tview sc mem1 mem2 kind
        (MEM: Memory.closed mem1)
        (WF_TVIEW: TView.wf tview)
        (WF_RELM: View.opt_wf releasedm)
        (CLOSED_TVIEW: TView.closed tview mem1)
        (CLOSED_RELM: Memory.closed_opt_view releasedm mem1)
        (OP: Memory.op mem1 loc from to
                       (Message.concrete val (TView.write_released tview sc loc to releasedm ord))
                       mem2 kind):
    <<WF_TVIEW: TView.wf (TView.write_tview tview sc loc to ord)>> /\
    <<WF_RELEASED: View.opt_wf (TView.write_released tview sc loc to releasedm ord)>> /\
    <<CLOSED_TVIEW: TView.closed (TView.write_tview tview sc loc to ord) mem2>> /\
    <<CLOSED_RELEASED: Memory.closed_opt_view (TView.write_released tview sc loc to releasedm ord) mem2>>.
  Proof.
    exploit write_future0; eauto. i. des. splits; eauto.
    - eapply op_closed_tview; eauto.
    - eapply op_closed_released; eauto.
  Qed.

  Lemma write_future_fulfill
        loc from to val releasedm released ord tview sc mem
        (MEM: Memory.closed mem)
        (WF_TVIEW: TView.wf tview)
        (WF_RELM: View.opt_wf releasedm)
        (CLOSED_TVIEW: TView.closed tview mem)
        (CLOSED_RELM: Memory.closed_opt_view releasedm mem)
        (GET: Memory.get loc to mem = Some (from, Message.concrete val released)):
    <<WF_TVIEW: TView.wf (TView.write_tview tview sc loc to ord)>> /\
    <<WF_RELEASED: View.opt_wf (TView.write_released tview sc loc to releasedm ord)>> /\
    <<CLOSED_TVIEW: TView.closed (TView.write_tview tview sc loc to ord) mem>> /\
    <<CLOSED_RELEASED: Memory.closed_opt_view (TView.write_released tview sc loc to releasedm ord) mem>>.
  Proof.
    exploit write_future0; eauto. i. des. splits; eauto.
    - eapply get_closed_tview; eauto.
    - eapply get_closed_released; eauto.
  Qed.

  Lemma read_fence_future
        ord tview mem
        (WF_TVIEW: TView.wf tview)
        (CLOSED_TVIEW: TView.closed tview mem):
    <<WF_TVIEW: TView.wf (TView.read_fence_tview tview ord)>> /\
    <<CLOSED_TVIEW: TView.closed (TView.read_fence_tview tview ord) mem>>.
  Proof.
    splits.
    - econs; tac; try apply WF_TVIEW.
      + condtac; try apply WF_TVIEW.
      + condtac; try apply WF_TVIEW.
        etrans; apply WF_TVIEW.
      + condtac; try apply WF_TVIEW. refl.
    - econs; tac; try apply CLOSED_TVIEW.
      condtac; try apply CLOSED_TVIEW.
  Qed.

  Lemma write_fence_future
        ord tview sc mem
        (MEM: Memory.closed mem)
        (WF_TVIEW: TView.wf tview)
        (CLOSED_TVIEW: TView.closed tview mem)
        (CLOSED_SC: Memory.closed_timemap sc mem):
    <<WF_TVIEW: TView.wf (TView.write_fence_tview tview sc ord)>> /\
    <<CLOSED_TVIEW: TView.closed (TView.write_fence_tview tview sc ord) mem>> /\
    <<CLOSED_SC: Memory.closed_timemap (TView.write_fence_sc tview sc ord) mem>>.
  Proof.
    splits; tac.
    - econs; tac; try apply WF_TVIEW.
      + repeat condtac; tac; try apply WF_TVIEW.
      + repeat condtac; tac; try apply WF_TVIEW.
      + repeat condtac; tac.
      + repeat (try condtac; aggrtac; try apply WF_TVIEW).
        unfold TView.write_fence_sc. condtac; tac.
        rewrite <- TimeMap.join_r. apply WF_TVIEW.
      + repeat condtac; tac; rewrite <- View.join_l; apply WF_TVIEW.
    - econs; tac; try apply CLOSED_TVIEW.
      + unfold TView.write_fence_sc.
        repeat condtac; tac; try apply CLOSED_TVIEW.
        econs; tac; try apply CLOSED_TVIEW.
      + unfold TView.write_fence_sc.
        repeat condtac; tac; try apply CLOSED_TVIEW.
        econs; tac; try apply CLOSED_TVIEW.
      + unfold TView.write_fence_sc.
        repeat condtac; tac; try apply CLOSED_TVIEW.
        econs; tac; try apply CLOSED_TVIEW.
    - unfold TView.write_fence_sc.
      condtac; tac; try apply CLOSED_TVIEW.
  Qed.
End TViewFacts.

Ltac viewtac := TViewFacts.tac.
Ltac aggrtac := TViewFacts.aggrtac.


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L.Datatypes Require Import LNat LTerm LBool LProd List.List_enc LOptions.

(* ** Extracted encoding of natural numbers *)

Instance term_nat_enc : computableTime' (nat_enc) (fun n _ => (n * 14 + 12,tt)).
Proof.
  extract. solverec.
Qed.

(* ** Extracted term encoding *)

Instance term_term_enc : computableTime' (term_enc) (fun s _ => (size s * 30,tt)).
Proof.
  extract. solverec.
Qed.

Instance bool_enc :computableTime' (@bool_enc) (fun l _ => (12,tt)).
Proof.
  unfold bool_enc. extract. solverec.
Qed.

(* ** Extracted tuple encoding *)

Instance term_prod_enc X Y (R1:registered X) (R2:registered Y) t__X t__Y
         `{computableTime' (@enc X _) t__X} `{computableTime' (@enc Y _) t__Y}
  :computableTime' (@prod_enc X Y R1 R2) (fun w _ => (let '(x,y):= w in  fst (t__X x tt) + fst (t__Y y tt) + 15,tt)).
Proof.
  unfold prod_enc.
  change (match R1 with
          | @mk_registered _ enc _ _ => enc
          end) with (enc (registered:=R1)).
  change (match R2 with
          | @mk_registered _ enc _ _ => enc
          end) with (enc (registered:=R2)).
  extract. solverec.
Qed.

Instance term_list_enc X (R:registered X) t__X
         `{computableTime' (@enc X _) t__X}
  :computableTime' (@list_enc X R) (fun l _ => (sumn (map (fun x => fst (t__X x tt) + 17) l) + 12,tt)).
Proof.
  unfold list_enc.
  change (match R with
          | @mk_registered _ enc _ _ => enc
          end) with (enc (registered:=R)).
  extract. solverec.
Qed.

Import LOptions.

Instance term_option_enc X (R:registered X) t__X
         `{computableTime' (@enc X _) t__X}
  :computableTime' (@option_enc X R) (fun x _ => (match x with Some x => fst (t__X x tt) | _ => 0 end + 15,tt)).
Proof.
  unfold option_enc.
  change (match R with
          | @mk_registered _ enc _ _ => enc
          end) with (enc (registered:=R)).
  extract. solverec.
Qed.

(*
Set Printing Implicit.
Check (extT (@enc (nat*(nat*nat)) _)).
*)
(*
Definition prod_enc' {X Y} (enc_x : X -> term) (enc_y : Y -> term) : X * Y -> term :=
  fix f w := let '(x,y) := w in
             lam (var 0 (enc_x x) (enc_y y)).

Lemma enc_prod_eq {X Y} {H__x:registered X} {H__y : registered Y}:
  @enc (X*Y) _ = prod_enc' (@enc _ H__x) (@enc _ H__y).
Proof.
  unfold enc. destruct H__x, H__y. reflexivity.
Qed.

Instance term_prod_enc' {X Y} {H__x : registered X} {H__Y : registered Y}:
  computableTime' (@prod_enc' X Y) (fun _ t__X => (1,fun _ t__Y => (1,fun w _ => (let '(x,y):= w in  fst (t__X x tt) + fst (t__Y y tt) + 15,tt)))).
Proof.
  extract. solverec.
Qed.
*)


Require Import VST.msl.msl_direct.
Require Import RamifyCoq.msl_ext.ramify_tactics.
Require Import RamifyCoq.msl_ext.overlapping_direct.
Require Import VST.msl.predicates_sa.

Lemma precise_left_sepcon_andp_distr_d {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {CA : Canc_alg A}:
  forall P P1 P2 Q R, precise P -> P1 |-- P -> P2 |-- P -> (P1 * Q) && (P2 * R) |-- (P1 && P2) * (Q && R).
Proof.
  intros.
  unfold sepcon, andp, derives; simpl.
  intros.
  destruct H2 as [[?y [?z [? [? ?]]]] [?y [?z [? [? ?]]]]].
  exists y, z.
  assert (P y) by auto.
  assert (P y0) by auto.
  equate_precise_direct y y0.
  equate_canc z z0.
  repeat split; auto.
Qed.

(* derives_precise, precise_emp is in predicates_sa.v. *)

Lemma precise_sepcon_d {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A}:
  forall P Q, precise Q -> precise P -> precise (P * Q).
Proof.
  repeat intro; destruct H1 as [w11 [w12 [? [? ?]]]], H2 as [w21 [w22 [? [? ?]]]].
  assert (w11 = w21) by (apply join_join_sub in H1; generalize (join_sub_trans H1 H3); intro;
                         apply join_join_sub in H2; generalize (join_sub_trans H2 H4); intro;
                         hnf in H0; apply H0 with (w := w); trivial).
  assert (w12 = w22) by (apply join_join_sub' in H1; generalize (join_sub_trans H1 H3); intro;
                         apply join_join_sub' in H2; generalize (join_sub_trans H2 H4); intro;
                         hnf in H; apply H with (w := w); trivial).
  rewrite H9 in *; rewrite H10 in *; equate_join w1 w2; auto.
Qed.

Lemma precise_wand_ewand_d {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {CA : Canc_alg A}:
  forall R P Q R', precise P -> R |-- P * (Q -* R') -> Q * (ewand P R) |-- R'.
Proof.
  intros. intro w. intros. destruct_sepcon H1 h. destruct H3 as [h3 [h4 [? [? ?]]]].
  specialize (H0 h4 H5). destruct_sepcon H0 h. equate_precise_direct h3 h0.
  equate_canc h2 h5. apply (H7 h1); auto.
Qed.


(** * Definition of Context Free Grammars *)
Require Import Coq.Strings.String Coq.Lists.List.
Require Export Fiat.Parsers.StringLike.Core.

Set Implicit Arguments.

Local Open Scope string_like_scope.
Local Open Scope type_scope.

Section cfg.
  Context {Char : Type}.

  Section definitions.
    (** An [item] is the basic building block of a context-free
        grammar; it is either a terminal (a set of [Char]-literal
        options) or a nonterminal ([string]). *)
    Inductive item :=
    | Terminal (_ : Char -> bool)
    | NonTerminal (_ : string).

    (** A [productions] is a list of possible [production]s; a
        [production] is a list of [item]s.  A string matches a
        [production] if it can be broken up into components that match
        the relevant element of the [production]. *)
    Definition production := list item.
    Definition productions := list production.

    (** A [grammar] consists of [productions] to match a string
        against, and a function mapping names to [productions]. *)
    Record grammar :=
      {
        Start_symbol :> string;
        Lookup :> string -> productions;
        Start_productions :> productions := Lookup Start_symbol;
        Valid_nonterminals : list string;
        Valid_productions : list productions := map Lookup Valid_nonterminals
      }.
  End definitions.

  Section parse.
    Context {HSLM} {HSL : @StringLike Char HSLM}.
    Variable G : grammar.
    (** A parse of a string into [productions] is a [production] in
        that list, together with a list of substrings which cover the
        original string, each of which is a parse of the relevant
        component of the [production]. *)
    Inductive parse_of (str : String) : productions -> Type :=
    | ParseHead : forall pat pats, parse_of_production str pat
                                   -> parse_of str (pat::pats)
    | ParseTail : forall pat pats, parse_of str pats
                                   -> parse_of str (pat::pats)
    with parse_of_production (str : String) : production -> Type :=
    | ParseProductionNil : length str = 0 -> parse_of_production str nil
    | ParseProductionCons : forall n pat pats,
                              parse_of_item (take n str) pat
                              -> parse_of_production (drop n str) pats
                              -> parse_of_production str (pat::pats)
    with parse_of_item (str : String) : item -> Type :=
    | ParseTerminal : forall ch P, is_true (P ch) -> is_true (str ~= [ ch ]) -> parse_of_item str (Terminal P)
    | ParseNonTerminal : forall nt,
                           List.In nt (Valid_nonterminals G)
                           -> parse_of str (Lookup G nt)
                           -> parse_of_item str (NonTerminal nt).

    (** A simple parse tree is a simply typed version of the above *)
    Inductive simple_parse_of :=
    | SimpleParseHead : simple_parse_of_production -> simple_parse_of
    | SimpleParseTail : simple_parse_of -> simple_parse_of
    with simple_parse_of_production :=
    | SimpleParseProductionNil : simple_parse_of_production
    | SimpleParseProductionCons
      : simple_parse_of_item
        -> simple_parse_of_production
        -> simple_parse_of_production
    with simple_parse_of_item :=
    | SimpleParseTerminal : Char -> simple_parse_of_item
    | SimpleParseNonTerminal : forall nt : string,
                                 simple_parse_of
                                 -> simple_parse_of_item.
  End parse.

  Definition parse_of_grammar {HSLM} {HSL : @StringLike Char HSLM} (str : String) (G : grammar) :=
    parse_of G str G.
End cfg.

Arguments item _ : clear implicits.
Arguments production _ : clear implicits.
Arguments productions _ : clear implicits.
Arguments grammar _ : clear implicits.

(** A production is reachable if it is the tail of a production
    associated to a valid nonterminal. *)
Definition production_is_reachable {Char} (G : grammar Char) (p : production Char)
: Prop
  := exists nt prefix,
       List.In nt (Valid_nonterminals G)
       /\ List.In
            (prefix ++ p)
            (Lookup G nt).

Delimit Scope simple_parse_of_scope with simple_parse_of.
Delimit Scope simple_parse_of_production_scope with simple_parse_of_production.
Delimit Scope simple_parse_of_item_scope with simple_parse_of_item.
Bind Scope simple_parse_of_scope with simple_parse_of.
Bind Scope simple_parse_of_production_scope with simple_parse_of_production.
Bind Scope simple_parse_of_item_scope with simple_parse_of_item.

Arguments SimpleParseHead _%type _%simple_parse_of_production.
Arguments SimpleParseTail _%type _%simple_parse_of.
Arguments SimpleParseProductionNil _%type.
Arguments SimpleParseProductionCons _%type _%simple_parse_of_item _%simple_parse_of_production.
Arguments SimpleParseNonTerminal _%type _%string _%simple_parse_of.

Arguments simple_parse_of {_}, _.
Arguments simple_parse_of_production {_}, _.
Arguments simple_parse_of_item {_}, _.

Infix "::" := SimpleParseProductionCons : simple_parse_of_production_scope.
Notation "[ ]" := SimpleParseProductionNil : simple_parse_of_production_scope.