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

Definition newcounter : val := λ: <>, ref #0.
Definition incr : val := rec: "incr" "l" :=
    let: "n" := !"l" in
    if: CAS "l" "n" (#1 + "n") then #() else "incr" "l".
Definition read : val := λ: "l", !"l".

(** Monotone counter *)
Class mcounterG Σ := MCounterG { mcounter_inG :> inG Σ (authR mnatUR) }.
Definition mcounterΣ : gFunctors := #[GFunctor (authR mnatUR)].

Instance subG_mcounterΣ {Σ} : subG mcounterΣ Σ → mcounterG Σ.
Proof. solve_inG. Qed.

Section mono_proof.
  Context `{!heapG Σ, !probG Σ, !mcounterG Σ} (N : namespace).

  Definition mcounter_inv (γ : gname) (l : loc) : iProp Σ :=
    (∃ n, own γ (● (n : mnat)) ∗ l ↦ #n)%I.

  Definition mcounter (l : loc) (n : nat) : iProp Σ :=
    (∃ γ, inv N (mcounter_inv γ l) ∧ own γ (◯ (n : mnat)))%I.

  (** The main proofs. *)
  Global Instance mcounter_persistent l n : Persistent (mcounter l n).
  Proof. apply _. Qed.

  Lemma newcounter_mono_spec :
    {{{ True }}} newcounter #() {{{ l, RET #l; mcounter l 0 }}}.
  Proof.
    iIntros (Φ) "_ HΦ". rewrite -wp_fupd /newcounter /=. wp_seq. wp_alloc l as "Hl".
    iMod (own_alloc (● (O:mnat) ⋅ ◯ (O:mnat))) as (γ) "[Hγ Hγ']"; first done.
    iMod (inv_alloc N _ (mcounter_inv γ l) with "[Hl Hγ]").
    { iNext. iExists 0%nat. by iFrame. }
    iModIntro. iApply "HΦ". rewrite /mcounter; eauto 10.
  Qed.

  Lemma incr_mono_spec l n :
    {{{ mcounter l n }}} incr #l {{{ RET #(); mcounter l (S n) }}}.
  Proof.
    iIntros (Φ) "Hl HΦ". iLöb as "IH". wp_rec.
    iDestruct "Hl" as (γ) "[#Hinv Hγf]".
    wp_bind (! _)%E. iInv N as (c) ">[Hγ Hl]" "Hclose".
    wp_load. iMod ("Hclose" with "[Hl Hγ]") as "_"; [iNext; iExists c; by iFrame|].
    iModIntro. wp_let. wp_op.
    wp_bind (CAS _ _ _). iInv N as (c') ">[Hγ Hl]" "Hclose".
    destruct (decide (c' = c)) as [->|].
    - iDestruct (own_valid_2 with "Hγ Hγf")
        as %[?%mnat_included _]%auth_valid_discrete_2.
      iMod (own_update_2 with "Hγ Hγf") as "[Hγ Hγf]".
      { apply auth_update, (mnat_local_update _ _ (S c)); auto. }
      wp_cas_suc. iMod ("Hclose" with "[Hl Hγ]") as "_".
      { iNext. iExists (S c). rewrite Nat2Z.inj_succ Z.add_1_l. by iFrame. }
      iModIntro. wp_if. iApply "HΦ"; iExists γ; repeat iSplit; eauto.
      iApply (own_mono with "Hγf"). apply: auth_frag_mono.
      by apply mnat_included, le_n_S.
    - wp_cas_fail; first (by intros [= ?%Nat2Z.inj]).
      iMod ("Hclose" with "[Hl Hγ]") as "_"; [iNext; iExists c'; by iFrame|].
      iModIntro. wp_if. iApply ("IH" with "[Hγf] [HΦ]"); last by auto.
      rewrite {3}/mcounter; eauto 10.
  Qed.

  Lemma read_mono_spec l j :
    {{{ mcounter l j }}} read #l {{{ i, RET #i; ⌜j ≤ i⌝%nat ∧ mcounter l i }}}.
  Proof.
    iIntros (ϕ) "Hc HΦ". iDestruct "Hc" as (γ) "[#Hinv Hγf]".
    rewrite /read /=. wp_let. iInv N as (c) ">[Hγ Hl]" "Hclose". wp_load.
    iDestruct (own_valid_2 with "Hγ Hγf")
      as %[?%mnat_included _]%auth_valid_discrete_2.
    iMod (own_update_2 with "Hγ Hγf") as "[Hγ Hγf]".
    { apply auth_update, (mnat_local_update _ _ c); auto. }
    iMod ("Hclose" with "[Hl Hγ]") as "_"; [iNext; iExists c; by iFrame|].
    iApply ("HΦ" with "[-]"). rewrite /mcounter; eauto 10.
  Qed.
End mono_proof.

(** Counter with contributions *)
Class ccounterG Σ :=
  CCounterG { ccounter_inG :> inG Σ (frac_authR natR) }.
Definition ccounterΣ : gFunctors :=
  #[GFunctor (frac_authR natR)].

Instance subG_ccounterΣ {Σ} : subG ccounterΣ Σ → ccounterG Σ.
Proof. solve_inG. Qed.

Section contrib_spec.
  Context `{!heapG Σ, !probG Σ, !ccounterG Σ} (N : namespace).

  Definition ccounter_inv (γ : gname) (l : loc) : iProp Σ :=
    (∃ n, own γ (●! n) ∗ l ↦ #n)%I.

  Definition ccounter_ctx (γ : gname) (l : loc) : iProp Σ :=
    inv N (ccounter_inv γ l).

  Definition ccounter (γ : gname) (q : frac) (n : nat) : iProp Σ :=
    own γ (◯!{q} n).

  (** The main proofs. *)
  Lemma ccounter_op γ q1 q2 n1 n2 :
    ccounter γ (q1 + q2) (n1 + n2) ⊣⊢ ccounter γ q1 n1 ∗ ccounter γ q2 n2.
  Proof. by rewrite /ccounter frag_auth_op -own_op. Qed.

  Lemma newcounter_contrib_spec (R : iProp Σ) :
    {{{ True }}} newcounter #()
    {{{ γ l, RET #l; ccounter_ctx γ l ∗ ccounter γ 1 0 }}}.
  Proof.
    iIntros (Φ) "_ HΦ". rewrite -wp_fupd /newcounter /=. wp_seq. wp_alloc l as "Hl".
    iMod (own_alloc (●! O%nat ⋅ ◯! 0%nat)) as (γ) "[Hγ Hγ']"; first done.
    iMod (inv_alloc N _ (ccounter_inv γ l) with "[Hl Hγ]").
    { iNext. iExists 0%nat. by iFrame. }
    iModIntro. iApply "HΦ". rewrite /ccounter_ctx /ccounter; eauto 10.
  Qed.

  Lemma incr_contrib_spec γ l q n :
    {{{ ccounter_ctx γ l ∗ ccounter γ q n }}} incr #l
    {{{ RET #(); ccounter γ q (S n) }}}.
  Proof.
    iIntros (Φ) "[#? Hγf] HΦ". iLöb as "IH". wp_rec.
    wp_bind (! _)%E. iInv N as (c) ">[Hγ Hl]" "Hclose".
    wp_load. iMod ("Hclose" with "[Hl Hγ]") as "_"; [iNext; iExists c; by iFrame|].
    iModIntro. wp_let. wp_op.
    wp_bind (CAS _ _ _). iInv N as (c') ">[Hγ Hl]" "Hclose".
    destruct (decide (c' = c)) as [->|].
    - iMod (own_update_2 with "Hγ Hγf") as "[Hγ Hγf]".
      { apply frac_auth_update, (nat_local_update _ _ (S c) (S n)); omega. }
      wp_cas_suc. iMod ("Hclose" with "[Hl Hγ]") as "_".
      { iNext. iExists (S c). rewrite Nat2Z.inj_succ Z.add_1_l. by iFrame. }
      iModIntro. wp_if. by iApply "HΦ".
    - wp_cas_fail; first (by intros [= ?%Nat2Z.inj]).
      iMod ("Hclose" with "[Hl Hγ]") as "_"; [iNext; iExists c'; by iFrame|].
      iModIntro. wp_if. by iApply ("IH" with "[Hγf] [HΦ]"); auto.
  Qed.

  Lemma read_contrib_spec γ l q n :
    {{{ ccounter_ctx γ l ∗ ccounter γ q n }}} read #l
    {{{ c, RET #c; ⌜n ≤ c⌝%nat ∧ ccounter γ q n }}}.
  Proof.
    iIntros (Φ) "[#? Hγf] HΦ".
    rewrite /read /=. wp_let. iInv N as (c) ">[Hγ Hl]" "Hclose". wp_load.
    iDestruct (own_valid_2 with "Hγ Hγf") as % ?%frac_auth_included_total%nat_included.
    iMod ("Hclose" with "[Hl Hγ]") as "_"; [iNext; iExists c; by iFrame|].
    iApply ("HΦ" with "[-]"); rewrite /ccounter; eauto 10.
  Qed.

  Lemma read_contrib_spec_1 γ l n :
    {{{ ccounter_ctx γ l ∗ ccounter γ 1 n }}} read #l
    {{{ n, RET #n; ccounter γ 1 n }}}.
  Proof.
    iIntros (Φ) "[#? Hγf] HΦ".
    rewrite /read /=. wp_let. iInv N as (c) ">[Hγ Hl]" "Hclose". wp_load.
    iDestruct (own_valid_2 with "Hγ Hγf") as % <-%frac_auth_agreeL.
    iMod ("Hclose" with "[Hl Hγ]") as "_"; [iNext; iExists c; by iFrame|].
    by iApply "HΦ".
  Qed.
End contrib_spec.


(*******************************************************************************
*                                                                              *
*   DistAnd.v                                                                  *
*   Xuejing Huang 2021                                                         *
*   Distributed under the terms of the GPL-v3 license                          *
*                                                                              *
*   This file is part of DistributingTypes.                                    *
*                                                                              *
*   DistributingTypes is free software: you can redistribute it and/or modify  *
*   it under the terms of the GNU General Public License as published by       *
*   the Free Software Foundation, either version 3 of the License, or          *
*   (at your option) any later version.                                        *
*                                                                              *
*   DistributingTypes is distributed in the hope that it will be useful,       *
*   but WITHOUT ANY WARRANTY; without even the implied warranty of             *
*   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *
*   GNU General Public License for more details.                               *
*                                                                              *
*   You should have received a copy of the GNU General Public License          *
*   along with DistributingTypes.  If not, see <https://www.gnu.org/licenses/>.*
*                                                                              *
*******************************************************************************)

(** This file is to prove rule DS-distAnd in Fig. 4
    can be derived by the rest rules.
    So removing it does not affect the expressiveness
    of the declarative system.
*)

Require Import LibTactics.
Require Import Definitions.

#[local]
 Hint Constructors declarative_subtyping_distor : core.
(** declarative_subtyping_distor is the declarative subtyping (Fig. 4) minus
DS-distAnd. It is only used here. *)

Lemma distor_symm_or : forall A1 A2,
    declarative_subtyping_distor (t_or A1 A2) (t_or A2 A1).
Proof.
  introv.
  applys~ DSO_or.
Qed.

Theorem distor_eqv_distand : forall A1 A2 B,
    declarative_subtyping_distor (t_and (t_or A1 A2) B) (t_or (t_and A1 B) (t_and A2 B)).
Proof.
  introv.
  applys DSO_trans.
  2: { applys DSO_distOr. }
  applys DSO_and.
  1: { applys DSO_trans (t_or (t_and A2 B) A1).
       applys DSO_trans.
       2: { applys DSO_distOr. }
       applys~ DSO_and.
       1: { applys DSO_trans. applys~ DSO_andl. applys~ DSO_or.
       }
       2: { applys~ DSO_or. }
       applys DSO_trans. applys~ DSO_andr. applys~ DSO_orl.
  }
  applys DSO_trans. applys~ DSO_andr. applys~ DSO_orl.
Qed.


(** ****************************************************************************

Theory about set-valued presheaves. We write PreShv C for [C^op,HSET].

Contents:

- Limits ([Lims_PreShv_of_shape])
- Colimits ([Colims_PreShv_of_shape])
- Binary products ([BinProducts_PreShv])
- Indexed products ([Products_PreShv])
- Binary coproducts ([BinCoproducts_PreShv])
- Indexed coproducts ([Coproducts_PreShv])
- Initial object ([Initial_PreShv])
- Terminal object ([Terminal_PreShv])
- Pullbacks ([Pullbacks_PreShv])
- Exponentials ([Exponentials_PreShv])
- Constant presheaf ([constant_PreShv])
- Definition of the subobject classifier (without proof) ([Ω_PreShv], [Ω_mor])
- Proof that [Ω_PreShv] is a bounded lattice object ([Ω_PreShv_lattice],
  [Ω_PreShv_bounded_lattice])
- Construction of isomorphisms of functors between presheaf categories
  ([make_PreShv_functor_iso])

Written by: Anders Mörtberg, 2017-2019

********************************************************************************)

Require Import UniMath.MoreFoundations.All.

Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.Lattice.Lattice.
Require Import UniMath.Algebra.Lattice.Bounded.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.exponentials.
Require Import UniMath.CategoryTheory.Monics.
Require Import UniMath.CategoryTheory.LatticeObject.

Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Colimits.
Require Import UniMath.CategoryTheory.categories.HSET.Structures.

Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.products.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.pullbacks.

Local Open Scope cat.

Notation "'PreShv' C" := [C^op, HSET] (at level 4) : cat.

Section basics.

Lemma transportf_PreShv {C : category} (F : PreShv C) {x y z : C}
  (e : x = y) (f : C⟦x,z⟧) (u : ((F : functor _ _) z : hSet)) :
  transportf (λ x, pr1 (pr1 F x)) e (# (pr1 F) f u) =
  # (pr1 F) (transportf (@precategory_morphisms C^op z) e f) u.
Proof.
now induction e.
Qed.

End basics.

(** Various limits and colimits in PreShv C *)
Section limits.

Context {C : category}.

(* This should be only small limits *)
(* Lemma Lims_PreShv : Lims (PreShv C). *)
(* Proof. *)
(* now apply LimsFunctorCategory, LimsHSET. *)
(* Defined. *)

Lemma Lims_PreShv_of_shape (g : graph) : Lims_of_shape g (PreShv C).
Proof.
now apply LimsFunctorCategory_of_shape, LimsHSET_of_shape.
Defined.

(* This should be only small colimits *)
(* Lemma Colims_PreShv : Colims (PreShv C). *)
(* Proof. *)
(* now apply ColimsFunctorCategory, ColimsHSET. *)
(* Defined. *)

Lemma Colims_PreShv_of_shape (g : graph) : Colims_of_shape g (PreShv C).
Proof.
now apply ColimsFunctorCategory_of_shape, ColimsHSET_of_shape.
Defined.

Lemma BinProducts_PreShv : BinProducts (PreShv C).
Proof.
now apply BinProducts_functor_precat, BinProductsHSET.
Defined.

Lemma Products_PreShv I : Products I (PreShv C).
Proof.
now apply Products_functor_precat, ProductsHSET.
Defined.

Lemma BinCoproducts_PreShv : BinCoproducts (PreShv C).
Proof.
now apply BinCoproducts_functor_precat, BinCoproductsHSET.
Defined.

Lemma Coproducts_PreShv I (HI : isaset I) : Coproducts I (PreShv C).
Proof.
now apply Coproducts_functor_precat, CoproductsHSET, HI.
Defined.

Lemma Initial_PreShv : Initial (PreShv C).
Proof.
now apply Initial_functor_precat, InitialHSET.
Defined.

Lemma Terminal_PreShv : Terminal (PreShv C).
Proof.
now apply Terminal_functor_precat, TerminalHSET.
Defined.

Lemma Pullbacks_PreShv : Pullbacks (PreShv C).
Proof.
now apply FunctorcategoryPullbacks, PullbacksHSET.
Defined.

Lemma Exponentials_PreShv :
  Exponentials BinProducts_PreShv.
Proof.
now apply Exponentials_functor_HSET.
Defined.

End limits.

(** * Define some standard presheaves *)
Section presheaves.

Context {C : category}.

Definition constant_PreShv (A : HSET) : PreShv C.
Proof.
use make_functor.
+ use tpair.
  - intros _; apply A.
  - cbn. intros a b f. apply idfun.
+ now split.
Defined.

Definition empty_PreShv : PreShv C := constant_PreShv emptyHSET.

End presheaves.

(** * Definition of the subobject classifier in a presheaf. *)
(**
See: "Sheaves in Geometry and Logic" by Mac Lane and Moerdijk (page 37)
*)
(* TODO: Prove that Ω actually is the subobject classifier  *)
Section Ω_PreShv.

Context {C : category}.

Definition sieve_def (c : C) : UU.
Proof.
use total2.
- apply (hsubtype (∑ (x : C),C⟦x,c⟧)).
- intros S.
  apply (∏ (s1 : ∑ (x : C),C⟦x,c⟧), S s1 →
         ∏ y (f : C⟦y,pr1 s1⟧), S (y,, f · pr2 s1)).
Defined.

Lemma isaset_sieve (c : C) : isaset (sieve_def c).
Proof.
use isaset_total2.
- apply isasethsubtype.
- intros S; repeat (apply impred_isaset; intro); apply isasetaprop, propproperty.
Qed.

(* If I use HSET here the coercion isn't triggered later and I need to insert pr1 explicitly *)
Definition sieve (c : C) : hSet := (sieve_def c,,isaset_sieve c).

Definition pr1sieve {c : C} : sieve_def c → hsubtype _ := @pr1 _ _.
Coercion pr1sieve : sieve_def >-> hsubtype.

Lemma sieve_eq (c : C) (s t : sieve c) (H : pr1 s = pr1 t) : s = t.
Proof.
apply subtypePath; [|apply H].
now intros x; repeat (apply impred; intros); apply propproperty.
Qed.

Definition maximal_sieve (c : C) : sieve c.
Proof.
use tpair.
- intro S; apply htrue.
- cbn. intros; apply tt.
Defined.

Definition empty_sieve (c : C) : sieve c.
Proof.
use tpair.
- intros S; apply hfalse.
- intros f S y g; apply S.
Defined.

Definition intersection_sieve (c : C) : binop (sieve c).
Proof.
simpl; intros S1 S2.
use tpair.
- intros f.
  apply (S1 f ∧ S2 f).
- simpl; intros f S f'.
  split.
  + apply (pr2 S1 _ (pr1 S)).
  + apply (pr2 S2 _ (pr2 S)).
Defined.

Definition union_sieve (c : C) : binop (sieve c).
Proof.
simpl; intros S1 S2.
use tpair.
- intros f.
  apply (S1 f ∨ S2 f).
- intros f S y f'; simpl in S; apply S; clear S; intro S.
  apply hinhpr.
  induction S as [S|S].
  + apply ii1, (pr2 S1 _ S).
  + apply ii2, (pr2 S2 _ S).
Defined.

Definition sieve_lattice (c : C) : lattice (sieve c).
Proof.
use make_lattice.
- apply intersection_sieve.
- apply union_sieve.
- repeat split; intros S1; intros;
  apply sieve_eq, funextsec; intro f; simpl.
  + apply (isassoc_Lmin hProp_lattice).
  + apply (iscomm_Lmin hProp_lattice).
  + apply (isassoc_Lmax hProp_lattice).
  + apply (iscomm_Lmax hProp_lattice).
  + apply (Lmin_absorb hProp_lattice).
  + apply (Lmax_absorb hProp_lattice).
Defined.

Definition sieve_bounded_lattice (c : C) : bounded_lattice (sieve c).
Proof.
use make_bounded_lattice.
- apply sieve_lattice.
- apply empty_sieve.
- apply maximal_sieve.
- split; intros S; apply sieve_eq, funextsec; intro f; simpl.
  + apply (islunit_Lmax_Lbot hProp_bounded_lattice).
  + apply (islunit_Lmin_Ltop hProp_bounded_lattice).
Defined.

Definition sieve_mor a b (f : C⟦b,a⟧) : sieve a → sieve b.
Proof.
simpl; intros S.
use tpair.
- intros g.
  apply (S (pr1 g,,pr2 g · f)).
- abstract (intros g H y h; simpl; rewrite <- assoc; apply (pr2 S (pr1 g,,pr2 g · f)), H).
Defined.

Local Definition Ω_PreShv_data : functor_data C^op HSET := (sieve,,sieve_mor).

Local Lemma is_functor_Ω_PreShv_data : is_functor Ω_PreShv_data.
Proof.
split.
- intros x; apply funextfun; intros [S hS]; simpl.
  apply subtypePath; simpl.
  + intros X; repeat (apply impred; intro); apply propproperty.
  + now apply funextsec; intro; rewrite id_right.
- intros x y z f g; apply funextfun; intros [S hS]; simpl.
  apply subtypePath; simpl.
  + intros X; repeat (apply impred; intro); apply propproperty.
  + now repeat (apply funextsec; intro); rewrite <- assoc.
Qed.

Definition Ω_PreShv : PreShv C := (Ω_PreShv_data,,is_functor_Ω_PreShv_data).

Definition Ω_mor : (PreShv C)⟦Terminal_PreShv,Ω_PreShv⟧.
Proof.
use make_nat_trans.
- red; simpl; apply (λ c _, maximal_sieve c).
- intros x y f; simpl in *; apply funextfun; cbn; intros _.
  apply sieve_eq; simpl.
  now repeat (apply funextsec; intros).
Defined.

Lemma isMonic_Ω_mor : isMonic Ω_mor.
Proof.
now apply from_terminal_isMonic.
Qed.

Local Notation "c ⊗ d" := (BinProductObject _ (BinProducts_PreShv c d)) : cat.

Definition Ω_PreShv_meet : PreShv(C)⟦Ω_PreShv ⊗ Ω_PreShv,Ω_PreShv⟧.
Proof.
use make_nat_trans.
+ intros c S1S2.
  apply (intersection_sieve c (pr1 S1S2) (pr2 S1S2)).
+ intros x y f.
  apply funextsec; cbn; intros [S1 S2].
  now apply sieve_eq.
Defined.

Definition Ω_PreShv_join : PreShv(C)⟦Ω_PreShv ⊗ Ω_PreShv,Ω_PreShv⟧.
Proof.
use make_nat_trans.
+ intros c S1S2.
  apply (union_sieve c (pr1 S1S2) (pr2 S1S2)).
+ intros x y f.
  apply funextsec; cbn; intros [S1 S2].
  now apply sieve_eq.
Defined.

Definition Ω_PreShv_lattice : latticeob BinProducts_PreShv Ω_PreShv.
Proof.
use make_latticeob.
+ apply Ω_PreShv_meet.
+ apply Ω_PreShv_join.
+ repeat split; apply (nat_trans_eq has_homsets_HSET); intro c;
                apply funextsec; intros S; simpl.
  - apply (isassoc_Lmin (sieve_lattice c)).
  - apply (iscomm_Lmin (sieve_lattice c)).
  - apply (isassoc_Lmax (sieve_lattice c)).
  - apply (iscomm_Lmax (sieve_lattice c)).
  - apply (Lmin_absorb (sieve_lattice c)).
  - apply (Lmax_absorb (sieve_lattice c)).
Defined.

Definition Ω_PreShv_bottom : PreShv(C)⟦Terminal_PreShv,Ω_PreShv⟧.
Proof.
use make_nat_trans.
+ intros c _; apply empty_sieve.
+ now intros x y f; apply funextsec; intros []; apply sieve_eq.
Defined.

Definition Ω_PreShv_top : PreShv(C)⟦Terminal_PreShv,Ω_PreShv⟧.
Proof.
use make_nat_trans.
+ intros c _; apply maximal_sieve.
+ now intros x y f; apply funextsec; intros []; apply sieve_eq.
Defined.

Definition Ω_PreShv_bounded_lattice :
  bounded_latticeob BinProducts_PreShv Terminal_PreShv Ω_PreShv.
Proof.
use make_bounded_latticeob.
- exact Ω_PreShv_lattice.
- exact Ω_PreShv_bottom.
- exact Ω_PreShv_top.
- split; apply (nat_trans_eq has_homsets_HSET); intro c;
         apply funextsec; cbn; intros S.
  + apply (islunit_Lmax_Lbot (sieve_bounded_lattice c)).
  + apply (islunit_Lmin_Ltop (sieve_bounded_lattice c)).
Defined.

End Ω_PreShv.

(** Construction of isomorphisms of functors between presheaf categories *)
Section iso_presheaf.

Context {C : category}.

Local Definition make_PreShv_functor_z_iso_helper (F G : functor (PreShv C) (PreShv C))
      (set_iso : ∏ X c, z_iso (pr1 (F X) c) (pr1 (G X) c))
      (nat_in_c : ∏ X, is_nat_trans _ _ (λ c, set_iso X c))
      (nat_in_X : is_nat_trans F G (λ X, make_nat_trans _ _ _ (nat_in_c X))) :
      [PreShv C, PreShv C] ⟦ F, G ⟧.
Proof.
  use make_nat_trans.
    + intros X.
      use make_nat_trans.
      * intros c.
        exact (set_iso X c).
      * use nat_in_c.
    + exact nat_in_X.
Defined.

Lemma make_PreShv_functor_z_iso (F G : functor (PreShv C) (PreShv C))
      (set_iso : ∏ X c, z_iso (pr1 (F X) c) (pr1 (G X) c))
      (nat_in_c : ∏ X, is_nat_trans _ _ (λ c, set_iso X c))
      (nat_in_X : is_nat_trans F G (λ X, make_nat_trans _ _ _ (nat_in_c X))) :
      @z_iso [PreShv C, PreShv C] F G.
Proof.
  exists (make_PreShv_functor_z_iso_helper F G set_iso nat_in_c nat_in_X).
  use make_is_z_isomorphism.
  + use make_PreShv_functor_z_iso_helper.
      * intros X c.
        exact (z_iso_inv_from_z_iso (set_iso X c)).
      * abstract (intros X c y f;
                  apply pathsinv0, z_iso_inv_on_left; rewrite <- assoc;
                  now apply pathsinv0, z_iso_inv_on_right, (nat_in_c X)).
      * abstract (intros X Y α;
                  apply nat_trans_eq; [ apply homset_property|];
                  intro x; simpl;
                  apply pathsinv0, (z_iso_inv_on_left _ _ _ _ (set_iso Y x));
                  rewrite <- assoc; apply pathsinv0, (z_iso_inv_on_right (C:=HSET));
                  exact (eqtohomot (maponpaths pr1 (nat_in_X X Y α)) x)).
    + abstract (use make_is_inverse_in_precat;
                [ apply nat_trans_eq; [ apply homset_property |]; intro X;
                  apply nat_trans_eq; [ apply homset_property |]; intro x;
                  exact (z_iso_inv_after_z_iso (set_iso X x))
                | apply nat_trans_eq; [ apply homset_property |]; intro X;
                  apply nat_trans_eq; [ apply homset_property |]; intro x;
                  apply funextsec; intros y;
                  exact (eqtohomot (z_iso_after_z_iso_inv (set_iso X x)) y) ]).
Defined.

End iso_presheaf.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(*******************************
 * Algebra contexts *
 *******************************)

Require Import Equivalence.
Require Import Morphisms.
Require Import Setoid.
Require Import EquivDec.
Require Import Program.
Require Import List.
Require Import String.
Require Import NPeano.
Require Import Arith.
Require Import Utils.
Require Import DataRuntime.
Require Import NRARuntime.
Require Import NRAOptim.
Require Import cNRAEnv.
Require Import cNRAEnvIgnore.
Require Import cNRAEnvEq.
Require Import cNRAEnvContext.

Section cNRAEnvContext.
(*
    Lemma aec_substs_prop_part2 c ps1 ps2 :
    Forall2 (fun xy1 xy2 => (fst xy1) = (fst xy2)
                            /\ nraenv_core_eq (snd xy1) (snd xy2)) ps1 ps2
    -> nraenv_core_ctxt_equiv_strict (aec_substs c ps1) (aec_substs c ps2).
    Proof.
    intros F; revert c.
    induction F; simpl.
    - reflexivity.
    - destruct x; destruct y; destruct H; simpl in *. subst.
      intros. rewrite IHF.
      rewrite H0.
      reflexivity.
    Qed.
*)

  Context {fruntime:foreign_runtime}.

  Fixpoint lift_nra_context (c:nra_ctxt) : nraenv_core_ctxt :=
    match c with
      | CNRAHole x'
        => CcNRAEnvHole x'
      | CNRAPlug a
        => CcNRAEnvPlug (nraenv_core_of_nra a)
      | CNRABinop b c1 c2
        => CcNRAEnvBinop b (lift_nra_context c1) (lift_nra_context c2)
      | CNRAUnop u c
        => CcNRAEnvUnop u (lift_nra_context c)
      | CNRAMap c1 c2
        => CcNRAEnvMap (lift_nra_context c1) (lift_nra_context c2)
      | CNRAMapProduct c1 c2
        => CcNRAEnvMapProduct (lift_nra_context c1) (lift_nra_context c2)
      | CNRAProduct c1 c2
        => CcNRAEnvProduct (lift_nra_context c1) (lift_nra_context c2)
      | CNRASelect c1 c2
        => CcNRAEnvSelect (lift_nra_context c1) (lift_nra_context c2)
      | CNRADefault c1 c2
        => CcNRAEnvDefault (lift_nra_context c1) (lift_nra_context c2)
      | CNRAEither c1 c2
        => CcNRAEnvEither (lift_nra_context c1) (lift_nra_context c2)
      | CNRAEitherConcat c1 c2
        => CcNRAEnvEitherConcat (lift_nra_context c1) (lift_nra_context c2)
      | CNRAApp c1 c2
        => CcNRAEnvApp (lift_nra_context c1) (lift_nra_context c2)
    end.

  Lemma aec_simplify_lift_commute c :
    aec_simplify (lift_nra_context c) = lift_nra_context (ac_simplify c).
  Proof.
    induction c; simpl; trivial
    ; try rewrite IHc; try rewrite IHc1; try rewrite IHc2
    ; first [destruct (ac_simplify c) | destruct (ac_simplify c1); simpl; trivial
    ; destruct (ac_simplify c2)]; simpl; trivial.
  Qed.

  Lemma  aec_holes_lift c:
    aec_holes (lift_nra_context c) = ac_holes c.
  Proof.
    induction c; simpl; try congruence.
  Qed.

  Lemma lift_nra_context_subst c n a :
    lift_nra_context (ac_subst c n a) =
    aec_subst (lift_nra_context c) n (nraenv_core_of_nra a).
  Proof.
    induction c; simpl; try congruence.
    match_destr.
  Qed.

  Lemma lift_nra_context_substs c ps :
    lift_nra_context (ac_substs c ps) =
    aec_substs (lift_nra_context c)
               (map (fun xy => (fst xy, nraenv_core_of_nra (snd xy))) ps).
  Proof.
    revert c.
    induction ps; simpl; trivial.
    destruct a; simpl; intros.
    rewrite IHps, lift_nra_context_subst.
    trivial.
  Qed.

  Definition nraenv_core_eq_under h c env (op1 op2:nraenv_core) : Prop :=
        (forall (x:data)
                (dn_x:data_normalized h x),
          h ⊢ₑ op1 @ₑ x ⊣ c;env = h ⊢ₑ op2 @ₑ x ⊣ c;env)%nraenv_core.

  Definition nraenv_core_ctxt_equiv_under h c env (c1 c2 : nraenv_core_ctxt)
    := forall (ps:list (nat * nraenv_core)),
      match aec_simplify (aec_substs c1 ps),
            aec_simplify (aec_substs c2 ps)
      with
      | CcNRAEnvPlug a1, CcNRAEnvPlug a2 => nraenv_core_eq_under h c env a1 a2
      | _, _ => True
      end.

  Lemma nraenv_core_eq_under_equiv (op1 op2:nraenv_core) :
    (forall h c env (dn_c:Forall (fun x => data_normalized h (snd x)) c) (dn_env:data_normalized h env), nraenv_core_eq_under h c env op1 op2) <->
    nraenv_core_eq op1 op2.
  Proof.
    unfold nraenv_core_eq, nraenv_core_eq_under; intuition.
  Qed.

  Lemma nraenv_core_ctxt_equiv_under_equiv (op1 op2:nraenv_core_ctxt) :
    (forall h c env (dn_c:Forall (fun x => data_normalized h (snd x)) c) (dn_env:data_normalized h env), nraenv_core_ctxt_equiv_under h c env op1 op2) <->
    nraenv_core_ctxt_equiv nraenv_core_eq op1 op2.
  Proof.
    unfold nraenv_core_ctxt_equiv, nraenv_core_ctxt_equiv_under; split; intros.
    -match_case; match_case; intros.
     apply nraenv_core_eq_under_equiv; intros h dl env dn_c dn_env.
     specialize (H h dl env dn_c dn_env ps). rewrite H0, H1 in H. trivial.
    - specialize (H ps). match_destr; match_destr.
      apply nraenv_core_eq_under_equiv; auto.
  Qed.

  Lemma roundtrip_env e h c env :
    Forall (fun x => data_normalized h (snd x)) c ->
    data_normalized h env ->
    nraenv_core_eq_under h c env
                    ((nraenv_core_of_nra (nra_of_nraenv_core e )
                                    ◯ (‵[| ("PBIND", ‵(env))|] ⊕ ‵[| ("PDATA", ID)|]))%nraenv_core)
                    e.
  Proof.
    red; intros.
    simpl.
    rewrite <- nraenv_core_eval_of_nra.
    rewrite unfold_env_nra.
    unfold nra_context_data.
    f_equal.
    f_equal.
    rewrite (normalize_normalized_eq h H0).
    trivial.
  Qed.

  Instance ae_under_equiv h c env : Equivalence (nraenv_core_eq_under h c env).
  Proof.
    unfold nraenv_core_eq_under.
    constructor; red; intros.
    - reflexivity.
    - symmetry; auto.
    - transitivity ((h ⊢ₑ y @ₑ x0 ⊣ c;env)%nraenv_core); eauto.
  Qed.

  Ltac goal_eq_simpler
    := repeat match goal with
              | [|- lift dcoll _ = lift dcoll _ ] => f_equal
              | [|- lift_oncoll _ ?x = lift_oncoll _ ?x ] => apply lift_oncoll_ext; intros
              | [|- lift_map _ ?x = lift_map _ ?x ] => apply lift_map_ext; intros
              | [|- omap_product _ ?x = omap_product _ ?x ] => apply omap_product_ext; intros
              | [|- olift _ ?x = olift _ ?x ] => apply olift_ext; intros
              | [|- lift_filter _ ?x = lift_filter _ ?x ] => apply lift_filter_ext; intros
              end; try subst.

  Ltac dn_inverter
    := repeat match goal with
              | [H: data_normalized _ (dleft _) |- _ ] => inversion H; clear H; try subst
              | [H: data_normalized _ (dright _) |- _ ] => inversion H; clear H; try subst
              end.

  Hint Resolve nraenv_core_eval_normalized : qcert.
  Hint Resolve data_normalized_dcoll_in : qcert.

  Instance aeu_Binop_proper h c env :
    Proper
      (eq ==>
          nraenv_core_eq_under h c env ==>
          nraenv_core_eq_under h c env ==>
          nraenv_core_eq_under h c env) cNRAEnvBinop.
  Proof.
    unfold Proper, respectful, nraenv_core_eq_under; simpl; intros.
    rewrite H, H0, H1 by trivial; trivial.
  Qed.

  Instance aeu_Unop_proper h c env :
    Proper
      (eq ==>
          nraenv_core_eq_under h c env ==>
          nraenv_core_eq_under h c env) cNRAEnvUnop.
  Proof.
    unfold Proper, respectful, nraenv_core_eq_under; simpl; intros.
    rewrite H, H0 by trivial.
    trivial.
  Qed.

  Instance aeu_Map_proper h c env (dn_c:Forall (fun x => data_normalized h (snd x)) c) (dn_env:data_normalized h env):
    Proper
      (nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env) cNRAEnvMap.
  Proof.
    unfold Proper, respectful, nraenv_core_eq_under; simpl; intros.
    rewrite H0 by trivial.
    goal_eq_simpler; qeauto.
  Qed.

  Instance aeu_MapProduct_proper h c env (dn_c:Forall (fun x => data_normalized h (snd x)) c) (dn_env:data_normalized h env) :
    Proper
      (nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env) cNRAEnvMapProduct.
  Proof.
    unfold Proper, respectful, nraenv_core_eq_under; simpl; intros.
    rewrite H0 by trivial.
    goal_eq_simpler; qeauto.
  Qed.

  Instance aeu_Product_proper h c env (dn_c:Forall (fun x => data_normalized h (snd x)) c) (dn_env:data_normalized h env) :
    Proper
      (nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env) cNRAEnvProduct.
  Proof.
    unfold Proper, respectful, nraenv_core_eq_under; simpl; intros.
    rewrite H, H0 by trivial.
    goal_eq_simpler; qeauto.
  Qed.

  Instance aeu_Select_proper h c env (dn_c:Forall (fun x => data_normalized h (snd x)) c) (dn_env:data_normalized h env):
    Proper
      (nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env) cNRAEnvSelect.
  Proof.
    unfold Proper, respectful, nraenv_core_eq_under; simpl; intros.
    rewrite H0 by trivial.
    goal_eq_simpler; qeauto.
    rewrite H; qeauto.
  Qed.

  Instance aeu_Default_proper h c env :
    Proper
      (nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env) cNRAEnvDefault.
  Proof.
    unfold Proper, respectful, nraenv_core_eq_under; simpl; intros.
    rewrite H, H0 by trivial.
    trivial.
  Qed.

  Instance aeu_Either_proper h c env :
    Proper
      (nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env) cNRAEnvEither.
  Proof.
    unfold Proper, respectful, nraenv_core_eq_under; simpl; intros.
    match_destr; dn_inverter; qeauto.
  Qed.

  Instance aeu_EitherConcat_proper h c env :
    Proper
      (nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env) cNRAEnvEitherConcat.
  Proof.
    unfold Proper, respectful, nraenv_core_eq_under; simpl; intros.
    rewrite H0 by trivial.
    goal_eq_simpler; qeauto.
    rewrite H; qeauto.
  Qed.

  Instance aeu_App_proper h c env (dn_c:Forall (fun x => data_normalized h (snd x)) c) (dn_env:data_normalized h env) :
    Proper
      (nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env ==>
                       nraenv_core_eq_under h c env) cNRAEnvApp.
  Proof.
    unfold Proper, respectful, nraenv_core_eq_under; simpl; intros.
    rewrite H0 by trivial.
    goal_eq_simpler; qeauto.
  Qed.

  Instance aec_under_refl h c env : Reflexive (nraenv_core_ctxt_equiv_under h c env).
  Proof.
    red; unfold nraenv_core_ctxt_equiv_under; intros.
    match_destr.
    reflexivity.
  Qed.

  Instance aecu_Plug_proper h c env : Proper (nraenv_core_eq_under h c env ==> nraenv_core_ctxt_equiv_under h c env) CcNRAEnvPlug.
  Proof.
    unfold Proper, respectful, nraenv_core_ctxt_equiv_under, nraenv_core_eq_under; intros.
    autorewrite with aec_substs.
    simpl.
    trivial.
  Qed.

  Instance aecu_Binop_proper h c env :
    Proper
      (eq ==>
          nraenv_core_ctxt_equiv_under h c env ==>
          nraenv_core_ctxt_equiv_under h c env ==>
          nraenv_core_ctxt_equiv_under h c env) CcNRAEnvBinop.
  Proof.
    unfold Proper, respectful, nraenv_core_ctxt_equiv_under.
    intros; subst.
    autorewrite with aec_substs; simpl.
    specialize (H0 ps); specialize (H1 ps).
    do 2 (match_destr_in H0; match_destr_in H1).
    apply aeu_Binop_proper; trivial.
  Qed.

  Instance aecu_Unop_proper h c env :
    Proper
      (eq ==>
          nraenv_core_ctxt_equiv_under h c env ==>
          nraenv_core_ctxt_equiv_under h c env) CcNRAEnvUnop.
  Proof.
    unfold Proper, respectful, nraenv_core_ctxt_equiv_under.
    intros; subst.
    autorewrite with aec_substs; simpl.
    specialize (H0 ps).
    do 2 (match_destr_in H0).
    apply aeu_Unop_proper; trivial.
  Qed.

   Instance aecu_Map_proper h c env (dn_c:Forall (fun x => data_normalized h (snd x)) c) (dn_env:data_normalized h env):
     Proper
       (nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env) CcNRAEnvMap.
   Proof.
     unfold Proper, respectful, nraenv_core_ctxt_equiv_under.
     intros; subst.
     autorewrite with aec_substs; simpl.
     specialize (H ps); specialize (H0 ps).
     do 2 (match_destr_in H; match_destr_in H0).
     apply aeu_Map_proper; trivial.
   Qed.

   Instance aecu_MapProduct_proper h c env (dn_c:Forall (fun x => data_normalized h (snd x)) c) (dn_env:data_normalized h env) :
     Proper
       (nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env) CcNRAEnvMapProduct.
   Proof.
     unfold Proper, respectful, nraenv_core_ctxt_equiv_under.
     intros; subst.
     autorewrite with aec_substs; simpl.
     specialize (H ps); specialize (H0 ps).
     do 2 (match_destr_in H; match_destr_in H0).
     apply aeu_MapProduct_proper; trivial.
   Qed.

   Instance aecu_Product_proper h c env (dn_c:Forall (fun x => data_normalized h (snd x)) c) (dn_env:data_normalized h env) :
     Proper
       (nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env) CcNRAEnvProduct.
   Proof.
     unfold Proper, respectful, nraenv_core_ctxt_equiv_under.
     intros; subst.
     autorewrite with aec_substs; simpl.
     specialize (H ps); specialize (H0 ps).
     do 2 (match_destr_in H; match_destr_in H0).
     apply aeu_Product_proper; trivial.
   Qed.

   Instance aecu_Select_proper h c env (dn_c:Forall (fun x => data_normalized h (snd x)) c) (dn_env:data_normalized h env) :
     Proper
       (nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env) CcNRAEnvSelect.
   Proof.
     unfold Proper, respectful, nraenv_core_ctxt_equiv_under.
     intros; subst.
     autorewrite with aec_substs; simpl.
     specialize (H ps); specialize (H0 ps).
     do 2 (match_destr_in H; match_destr_in H0).
     apply aeu_Select_proper; trivial.
   Qed.

   Instance aecu_Default_proper h c env :
     Proper
       (nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env) CcNRAEnvDefault.
   Proof.
     unfold Proper, respectful, nraenv_core_ctxt_equiv_under.
     intros; subst.
     autorewrite with aec_substs; simpl.
     specialize (H ps); specialize (H0 ps).
     do 2 (match_destr_in H; match_destr_in H0).
     apply aeu_Default_proper; trivial.
   Qed.

   Instance aecu_Either_proper h c env :
     Proper
       (nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env) CcNRAEnvEither.
   Proof.
     unfold Proper, respectful, nraenv_core_ctxt_equiv_under.
     intros; subst.
     autorewrite with aec_substs; simpl.
     specialize (H ps); specialize (H0 ps).
     do 2 (match_destr_in H; match_destr_in H0).
     apply aeu_Either_proper; trivial.
   Qed.

   Instance aecu_EitherConcat_proper h c env :
     Proper
       (nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env) CcNRAEnvEitherConcat.
   Proof.
     unfold Proper, respectful, nraenv_core_ctxt_equiv_under.
     intros; subst.
     autorewrite with aec_substs; simpl.
     specialize (H ps); specialize (H0 ps).
     do 2 (match_destr_in H; match_destr_in H0).
     apply aeu_EitherConcat_proper; trivial.
   Qed.

   Instance aecu_App_proper h c env (dn_c:Forall (fun x => data_normalized h (snd x)) c) (dn_env:data_normalized h env) :
     Proper
       (nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env ==>
                        nraenv_core_ctxt_equiv_under h c env) CcNRAEnvApp.
   Proof.
     unfold Proper, respectful, nraenv_core_ctxt_equiv_under.
     intros; subst.
     autorewrite with aec_substs; simpl.
     specialize (H ps); specialize (H0 ps).
     do 2 (match_destr_in H; match_destr_in H0).
     apply aeu_App_proper; trivial.
   Qed.

 Lemma aec_substs_under_prop_part2 h c env (dn_c:Forall (fun x => data_normalized h (snd x)) c) (dn_env:data_normalized h env) e ps1 ps2 :
     Forall2 (fun xy1 xy2 => (fst xy1) = (fst xy2)
            /\ nraenv_core_eq_under h c env (snd xy1) (snd xy2)) ps1 ps2
     -> nraenv_core_ctxt_equiv_under
          h c env
          (aec_substs (lift_nra_context e) ps1)
          (aec_substs (lift_nra_context e) ps2).
   Proof.
     induction e; simpl; intros f2; autorewrite with aec_substs.
     - induction f2; simpl.
       + reflexivity.
       + destruct x; destruct y; destruct H; simpl in *; subst.
          match_destr.
          autorewrite with aec_substs.
          apply aecu_Plug_proper; trivial.
     - reflexivity.
     - apply aecu_Binop_proper; auto.
     - apply aecu_Unop_proper; auto.
     - apply aecu_Map_proper; auto.
     - apply aecu_MapProduct_proper; auto.
     - apply aecu_Product_proper; auto.
     - apply aecu_Select_proper; auto.
     - apply aecu_Default_proper; auto.
     - apply aecu_Either_proper; auto.
     - apply aecu_EitherConcat_proper; auto.
     - apply aecu_App_proper; auto.
   Qed.

   Lemma f2_roundtrip h c env ps
     (dn_c:Forall (fun x => data_normalized h (snd x)) c)
       (dn_env:data_normalized h env) :
   Forall2
           (fun xy1 xy2 : nat * nraenv_core =>
            fst xy1 = fst xy2 /\ nraenv_core_eq_under h c env (snd xy1) (snd xy2))
           (map
              (fun x : nat * nraenv_core =>
               (fst x,
               (nraenv_core_of_nra (nra_of_nraenv_core (snd x))
                ◯ (‵[| ("PBIND", ‵(env))|] ⊕ ‵[| ("PDATA", ID)|]))%nraenv_core))
              ps) ps.
   Proof.
     induction ps; simpl; trivial.
     - constructor; auto 2.
       simpl. split; trivial.
       apply roundtrip_env; trivial.
   Qed.

   Global Instance lift_nra_context_proper : Proper (nra_ctxt_equiv nra_eq ==> nraenv_core_ctxt_equiv nraenv_core_eq) lift_nra_context.
  Proof.
    unfold Proper, respectful.
    intros c1 c2 H.
    apply <- nraenv_core_ctxt_equiv_strict_equiv.

    red; intros ps Hsort Hequiv.
    match_case; match_case; intros.
    red; intros h dl dnc env dnenv d dnd.
    specialize (H (map (fun xy => (fst xy,
                                   (NRAApp (nra_of_nraenv_core (snd xy)) (make_fixed_nra_context_data env)))) ps)).

      symmetry in Hequiv.
       generalize (equivlist_in Hequiv); intros Hin.
       assert (c1incl:incl (ac_holes c1) (domain ps)).
       { intros x xin; apply (Hin x); rewrite in_app_iff;
         repeat rewrite aec_holes_lift; intuition. }
       assert (c2incl:incl (ac_holes c2) (domain ps)).
       { intros x xin; apply (Hin x); rewrite in_app_iff;
         repeat rewrite aec_holes_lift; intuition. }
       repeat rewrite map_map in H.
       simpl in H.
       generalize (ac_holes_saturated_subst (fun x => (nra_of_nraenv_core x ◯ make_fixed_nra_context_data env)%nra) c1 ps c1incl);
         intros c1nholes.
       generalize (ac_holes_saturated_subst (fun x => (nra_of_nraenv_core x ◯ make_fixed_nra_context_data env)%nra) c2 ps c2incl);
         intros c2nholes.
       destruct (ac_simplify_nholes _ c1nholes) as [c1s c1seq].
       destruct (ac_simplify_nholes _ c2nholes) as [c2s c2seq].
       generalize (aec_simplify_lift_commute (ac_substs c1
             (map
                (fun xy : nat * nraenv_core =>
                   (fst xy, NRAApp (nra_of_nraenv_core (snd xy)) (make_fixed_nra_context_data env))) ps)));
        intros leq1.
      generalize (aec_simplify_lift_commute (ac_substs c2
             (map
                (fun xy : nat * nraenv_core =>
                   (fst xy, NRAApp (nra_of_nraenv_core (snd xy)) (make_fixed_nra_context_data env))) ps)));
        intros leq2.
      rewrite lift_nra_context_substs in leq1, leq2.
      rewrite map_map in leq1, leq2. simpl in leq1, leq2.
      rewrite c1seq, c2seq in *.
      intros.
      generalize
        (aec_substs_under_prop_part2 h dl env dnc dnenv c1
                                     (map (fun x => (fst x,
                                     ((nraenv_core_of_nra (nra_of_nraenv_core (snd x)))
                                        ◯ (‵[| ("PBIND", ‵(env))|] ⊕ ‵[| ("PDATA", ID)|]))%nraenv_core)) ps) ps (f2_roundtrip _ _ _ _ dnc dnenv)); intros s1eq.

      generalize
        (aec_substs_under_prop_part2 h dl env dnc dnenv c2
                                     (map (fun x => (fst x,
                                     ((nraenv_core_of_nra (nra_of_nraenv_core (snd x)))
                                        ◯ (‵[| ("PBIND", ‵(env))|] ⊕ ‵[| ("PDATA", ID)|]))%nraenv_core)) ps) ps (f2_roundtrip _ _ _ _ dnc dnenv)); intros s2eq.
      simpl in s1eq, s2eq.
      simpl in *.
      specialize (s1eq nil); specialize (s2eq nil).
      simpl in s1eq, s2eq.
      rewrite leq1, H1 in s1eq.
      rewrite leq2, H0 in s2eq.
      assert (cseq: ((nraenv_core_of_nra c1s) ≡ₑ (nraenv_core_of_nra c2s))%nraenv_core).
      { apply nraenv_core_of_nra_proper. trivial. }
      rewrite <- nraenv_core_eq_under_equiv in cseq.
      specialize (cseq h dl env).
      rewrite s1eq, s2eq in cseq.
      red in cseq.
      apply cseq; auto.
  Qed.

  Global Instance lift_nra_context_strict_proper : Proper (nra_ctxt_equiv_strict nra_eq ==> nraenv_core_ctxt_equiv_strict nraenv_core_eq) lift_nra_context.
  Proof.
    unfold Proper, respectful.
    intros c1 c2 H.
    apply nraenv_core_ctxt_equiv_strict_equiv.
    apply nra_ctxt_equiv_strict_equiv in H.
    apply lift_nra_context_proper; trivial.
  Qed.

  Local Open Scope nra_ctxt.
  Local Open Scope nraenv_core_ctxt.

  (** This is just a restatement of lift_nra_context_proper
        which visually looks more like the paper version.
        For the mechanization, lift_nra_context_proper
        is nicer, since it explicitly states that lift_nra_context
        is a morphism between the two equivalences
        and registers that relationship with the rewriting infrastructure
        of Coq.
   *)
  Theorem contextual_equivalence_lifting (c₁ c₂:nra_ctxt) :
    c₁ ≡ₐ c₂ -> lift_nra_context c₁ ≡ₑ lift_nra_context c₂.
  Proof.
    apply lift_nra_context_proper.
  Qed.

End cNRAEnvContext.


Require Import Bool String List BinNums Lia.
Require Import Lib.CommonTactics Lib.ilist Lib.Word.
Require Import Lib.Struct Lib.FMap Lib.StringEq Lib.Indexer.
Require Import Kami.Syntax Kami.Semantics Kami.RefinementFacts Kami.Renaming Kami.Wf.
Require Import Kami.Renaming Kami.Specialize Kami.Inline Kami.InlineFacts Kami.Decomposition.
Require Import Kami.Tactics Kami.Notations.
Require Import Ex.MemTypes Ex.SC Ex.NativeFifo Ex.MemAsync Ex.ProcDec Ex.ProcDecInl.
Require Import Eqdep ProofIrrelevance.

Set Implicit Arguments.

Local Hint Unfold listIsEmpty listEnq listDeq listFirstElt: MethDefs.

Lemma wnot_not_zero_wplusone:
  forall {sz} (w2: word sz),
    wnot w2 <> $0 ->
    #(w2 ^+ $1) = #w2 + 1.
Proof.
  intros.
  assert (w2 < wones _).
  { apply lt_wlt.
    rewrite wones_pow2_minus_one.
    pose proof (wordToNat_bound w2).
    pose proof (NatLib.pow2_zero sz).
    assert (#w2 = NatLib.pow2 sz - 1 \/ (#w2 < NatLib.pow2 sz - 1)%nat) by lia.
    destruct H2; [|assumption].
    assert (natToWord sz (#w2) = natToWord sz (NatLib.pow2 sz - 1)) by congruence.
    rewrite natToWord_wordToNat, <-wones_natToWord in H3; subst.
    rewrite wnot_ones in H.
    exfalso; auto.
  }
  erewrite wordToNat_plusone; [|eassumption].
  lia.
Qed.

Lemma wminus_wplus_transpose:
  forall {sz} (w1 w2 w3: word sz),
    w1 ^- w2 = w3 -> w1 = w3 ^+ w2.
Proof.
  intros.
  replace (w3 ^+ w2) with (w1 ^- w2 ^+ w2).
  - rewrite wminus_def, <-wplus_assoc.
    rewrite wplus_comm with (x:= ^~ w2), wminus_inv.
    rewrite wplus_wzero_1; reflexivity.
  - congruence.
Qed.

Lemma wnot_zero_wones:
  forall {sz} (w: word sz), wnot w = $0 -> w = wones _.
Proof.
  intros.
  rewrite wneg_wnot in H.
  apply wminus_wplus_transpose in H.
  rewrite wplus_unit in H.
  rewrite <- @wneg_idempotent with (w:= w), H.
  apply eq_sym, wones_wneg_one.
Qed.

Section Invariants.
  Variables addrSize iaddrSize instBytes dataBytes rfIdx: nat.

  Variables (fetch: AbsFetch addrSize iaddrSize instBytes dataBytes)
            (dec: AbsDec addrSize instBytes dataBytes rfIdx)
            (exec: AbsExec addrSize instBytes dataBytes rfIdx).

  Definition RqFromProc := MemTypes.RqFromProc dataBytes (Bit addrSize).
  Definition RsToProc := MemTypes.RsToProc dataBytes.

  Variable (init: ProcInit addrSize dataBytes rfIdx).

  Definition pdecInl := projT1 (pdecInl fetch dec exec init).

  Fixpoint pgm_init_rq_inv
           (pinitRqv: type Bool)
           (pinitRqOfsv: type (Bit iaddrSize))
           (ieltv: listEltT (Struct RqFromProc) type) :=
    match ieltv with
    | nil => True
    | rq :: rqs =>
      rq = evalExpr
             (STRUCT { "addr" ::=
                         toAddr _ (natToWord _ ((if pinitRqv
                                                 then NatLib.pow2 iaddrSize
                                                 else wordToNat pinitRqOfsv)
                                                - List.length ieltv));
                       "op" ::= $$false;
                       "byteEn" ::= $$Default;
                       "data" ::= $0 })%kami_expr /\
      pgm_init_rq_inv pinitRqv pinitRqOfsv rqs
    end.

  Definition pgm_init_rq_rs_inv
             (pinitRqv: type Bool)
             (pinitRqOfsv pinitRsOfsv: type (Bit iaddrSize))
             (ieltv: listEltT (Struct RqFromProc) type)
             (oeltv: listEltT (Struct RsToProc) type) :=
    (if pinitRqv then NatLib.pow2 iaddrSize else #pinitRqOfsv) =
    #pinitRsOfsv + List.length ieltv + List.length oeltv.

  Definition fifo_empty_inv {k: Kind} (eltv: listEltT k type) :=
    eltv = nil.

  Definition fifo_not_empty_inv {k: Kind} (eltv: listEltT k type) :=
    List.length eltv = 1.

  Definition mem_request_inv
             (rawInst: fullType type (SyntaxKind (Data instBytes)))
             (rf: fullType type (SyntaxKind (Vector (Data dataBytes) rfIdx)))
             (insElt: listEltT (Struct RqFromProc) type): Prop.
  Proof.
    destruct insElt as [|rq rqs]; [exact True|].
    refine (_ /\ _).
    - exact ((rq (RqFromProc !! "op") = false ->
              evalExpr (getOptype _ rawInst) = opLd) /\
             (evalExpr (getOptype _ rawInst) = opLd ->
              (rq (RqFromProc !! "op") = false /\
               rq (RqFromProc !! "addr") =
               evalExpr
                 (calcLdAddr
                    _ (evalExpr (getLdAddr _ rawInst))
                    (evalExpr (#rf@[getLdSrc _ rawInst])%kami_expr)) /\
               rq (RqFromProc !! "data") =
               evalConstT (getDefaultConst (Data dataBytes)) /\
               rq (RqFromProc !! "byteEn") =
               evalConstT (getDefaultConst (Array Bool dataBytes)))))%kami_expr.
    - exact ((rq (RqFromProc !! "op") = true ->
              evalExpr (getOptype _ rawInst) = opSt) /\
             (evalExpr (getOptype _ rawInst) = opSt ->
              (rq (RqFromProc !! "op") = true /\
               rq (RqFromProc !! "addr") =
               evalExpr (calcStAddr
                           _ (evalExpr (getStAddr _ rawInst))
                           (evalExpr (#rf@[getStSrc _ rawInst]))) /\
               rq (RqFromProc !! "data") =
               evalExpr (#rf@[getStVSrc _ rawInst ]) /\
               rq (RqFromProc !! "byteEn") =
               evalExpr (calcStByteEn _ rawInst))))%kami_expr.
  Defined.
  #[local] Hint Unfold pgm_init_rq_rs_inv fifo_empty_inv fifo_not_empty_inv
       mem_request_inv: InvDefs.

  Record procDec_inv (o: RegsT) : Prop :=
    { pcv : fullType type (SyntaxKind (Pc addrSize));
      Hpcv : M.find "pc"%string o = Some (existT _ _ pcv);
      rfv : fullType type (SyntaxKind (Vector (Data dataBytes) rfIdx));
      Hrfv : M.find "rf"%string o = Some (existT _ _ rfv);

      pinitv : fullType type (SyntaxKind Bool);
      Hpinitv : M.find "pinit"%string o = Some (existT _ _ pinitv);
      pinitRqv : fullType type (SyntaxKind Bool);
      HpinitRqv : M.find "pinitRq"%string o = Some (existT _ _ pinitRqv);
      pinitRqOfsv : fullType type (SyntaxKind (Bit iaddrSize));
      HpinitRqOfsv : M.find "pinitRqOfs"%string o = Some (existT _ _ pinitRqOfsv);
      pinitRsOfsv : fullType type (SyntaxKind (Bit iaddrSize));
      HpinitRsOfsv : M.find "pinitRsOfs"%string o = Some (existT _ _ pinitRsOfsv);

      pgmv : fullType type (SyntaxKind (Vector (Data instBytes) iaddrSize));
      Hpgmv : M.find "pgm"%string o = Some (existT _ _ pgmv);
      stallv : fullType type (SyntaxKind Bool);
      Hstallv : M.find "stall"%string o = Some (existT _ _ stallv);

      ieltv : fullType type (listEltK (Struct RqFromProc) type);
      Hieltv : M.find "rqFromProc"--"elt"%string o = Some (existT _ _ ieltv);
      oeltv : fullType type (listEltK (Struct RsToProc) type);
      Hoeltv : M.find "rsToProc"--"elt"%string o = Some (existT _ _ oeltv);

      Hinv :
        (pinitv = false ->
         pgm_init_rq_inv pinitRqv pinitRqOfsv ieltv /\
         pgm_init_rq_rs_inv pinitRqv pinitRqOfsv pinitRsOfsv ieltv oeltv /\
         stallv = false) /\
        (pinitv = true ->
         or3 (stallv = false /\ fifo_empty_inv ieltv /\ fifo_empty_inv oeltv)
             ((stallv = true /\ fifo_not_empty_inv ieltv /\ fifo_empty_inv oeltv) /\
              (mem_request_inv (pgmv (evalExpr (toIAddr _ pcv))) rfv ieltv))
             (stallv = true /\ fifo_empty_inv ieltv /\ fifo_not_empty_inv oeltv))
        }.

  Ltac procDec_inv_old :=
    try match goal with
        | [H: procDec_inv _ |- _] => destruct H
        end;
    kinv_red; kinv_or3;
    (* decide the current state by giving contradictions for all other states *)
    kinv_red; kinv_contra.

  Ltac procDec_inv_new :=
    econstructor; (* let's prove that the invariant holds for the next state *)
    try (findReify; (reflexivity || eassumption); fail);
    kregmap_clear. (* for improving performance *)

  Ltac procDec_inv_tac := procDec_inv_old; procDec_inv_new.

  Ltac procDec_inv_next ph :=
    match ph with
    | 0 => or3_fst (* intact *)
    | 1 => or3_snd (* requested *)
    | 2 => or3_thd (* responded *)
    end; intuition idtac.

  Lemma pgm_init_rq_inv_enq_not_last:
    forall elts rqOfs,
      wnot rqOfs <> $0 ->
      pgm_init_rq_inv false rqOfs elts ->
      forall elt,
        elt = evalExpr
                (STRUCT { "addr" ::= toAddr _ rqOfs;
                          "op" ::= $$false;
                          "byteEn" ::= $$Default;
                          "data" ::= $0})%kami_expr ->
        pgm_init_rq_inv false (rqOfs ^+ $1) (listEnq elt elts).
  Proof.
    induction elts; intros.
    - simpl; split; auto.
      rewrite H1; simpl; kinv_eq.
      rewrite wnot_not_zero_wplusone by assumption.
      rewrite PeanoNat.Nat.add_sub.
      rewrite natToWord_wordToNat.
      reflexivity.
    - simpl in H0; dest; subst.
      split.
      + simpl; kinv_eq.
        rewrite app_length; simpl.
        rewrite wnot_not_zero_wplusone by assumption.
        unfold type, ilist_to_fun_m; simpl.
        do 3 f_equal; lia.
      + apply IHelts; auto.
  Qed.

  Lemma pgm_init_rq_inv_enq_last:
    forall elts rqOfs,
      wnot rqOfs = $0 ->
      pgm_init_rq_inv false rqOfs elts ->
      forall elt,
        elt = evalExpr
                (STRUCT { "addr" ::= toAddr _ rqOfs;
                          "op" ::= $$false;
                          "byteEn" ::= $$Default;
                          "data" ::= $0})%kami_expr ->
        pgm_init_rq_inv true $0 (listEnq elt elts).
  Proof.
    induction elts; intros.
    - simpl; split; auto.
      rewrite H1; simpl; kinv_eq.
      rewrite wnot_zero_wones with (w:= rqOfs) by assumption.
      rewrite wones_natToWord; reflexivity.
    - simpl in H0; dest; subst.
      split.
      + simpl; kinv_eq.
        rewrite app_length; simpl.
        rewrite wnot_zero_wones with (w:= rqOfs) by assumption.
        rewrite wones_natToWord.
        unfold type, ilist_to_fun_m; simpl.
        do 3 f_equal.
        pose proof (NatLib.pow2_zero iaddrSize).
        rewrite wordToNat_natToWord_2; lia.
      + apply IHelts; auto.
  Qed.

  Lemma pgm_init_rq_inv_deq:
    forall elts rqf rqOfs,
      pgm_init_rq_inv rqf rqOfs elts ->
      pgm_init_rq_inv rqf rqOfs (listDeq elts).
  Proof.
    induction elts; intros; auto.
    simpl in H; dest; subst.
    simpl; assumption.
  Qed.

  Lemma pgm_init_rq_rs_inv_last:
    forall (pinitRqv: type Bool) (pinitRqOfsv: type (Bit iaddrSize))
           (ieltv: listEltT (Struct RqFromProc) type)
           (oeltv: listEltT (Struct RsToProc) type),
      oeltv <> nil ->
      (if pinitRqv then NatLib.pow2 iaddrSize else # (pinitRqOfsv)) =
      NatLib.pow2 iaddrSize - 1 + Datatypes.length ieltv + Datatypes.length oeltv ->
      pinitRqv = true /\ ieltv = nil /\ List.length oeltv = 1.
  Proof.
    intros.
    find_if_inside.
    - destruct oeltv; [exfalso; auto|].
      destruct ieltv; simpl in H0; [|lia].
      destruct oeltv; simpl in H0; [|lia].
      auto.
    - destruct oeltv; [exfalso; auto|].
      simpl in H0.
      exfalso.
      pose proof (wordToNat_bound pinitRqOfsv); lia.
  Qed.

  Lemma procDec_inv_ok':
    forall init n ll,
      init = initRegs (getRegInits pdecInl) ->
      Multistep pdecInl init n ll ->
      procDec_inv n.
  Proof. (* SKIP_PROOF_ON
    induction 2.

    - kinv_dest_custom procDec_inv_tac.
      kinv_constr.
      + simpl; auto.
      + cbn; repeat rewrite wordToNat_wzero; split; intros; reflexivity.
      + procDec_inv_next 0.

    - kinvert; [mred|mred|..].
      + kinv_dest_custom procDec_inv_tac; kinv_constr.
        * kinv_regmap_red.
          apply pgm_init_rq_inv_enq_not_last; auto.
        * kinv_regmap_red.
          rewrite app_length; simpl in *.
          rewrite wnot_not_zero_wplusone by assumption.
          unfold type in *; simpl in *.
          lia.

      + kinv_dest_custom procDec_inv_tac; kinv_constr.
        * eapply pgm_init_rq_inv_enq_last; eauto.
        * kinv_regmap_red.
          rewrite app_length; simpl in *.
          replace #x1 with (NatLib.pow2 iaddrSize - 1) in H2.
          { pose proof (NatLib.pow2_zero iaddrSize).
            unfold type in *; simpl in *; lia.
          }
          { replace x1 with (wones iaddrSize).
            { apply eq_sym, wones_pow2_minus_one. }
            { apply wnot_zero_wones in e; auto. }
          }

      + kinv_dest_custom procDec_inv_tac; kinv_constr.
        * assumption.
        * kinv_regmap_red.
          rewrite wnot_not_zero_wplusone by assumption.
          destruct x1; [discriminate|].
          simpl in *; lia.

      + kinv_dest_custom procDec_inv_tac; kinv_constr.
        apply wnot_zero_wones in e; subst.
        rewrite wones_pow2_minus_one in H2.
        eapply pgm_init_rq_rs_inv_last in H2; [|destruct x1; discriminate].
        dest; subst.
        destruct x1; [discriminate|].
        destruct x1; [|discriminate].
        procDec_inv_next 0.

      + kinv_dest_custom procDec_inv_tac; kinv_constr.
        procDec_inv_next 1; kinv_eq.
        simpl; kinv_constr; kinv_finish.
      + kinv_dest_custom procDec_inv_tac; kinv_constr.
        procDec_inv_next 1; kinv_eq.
        simpl; kinv_constr; kinv_finish.
      + kinv_dest_custom procDec_inv_tac; kinv_constr.
        procDec_inv_next 0.
        destruct x; [discriminate|].
        destruct x; [reflexivity|discriminate].
      + kinv_dest_custom procDec_inv_tac; kinv_constr.
        procDec_inv_next 0.
        destruct x; [discriminate|].
        destruct x; [reflexivity|discriminate].
      + kinv_dest_custom procDec_inv_tac; kinv_constr.
        procDec_inv_next 0.
        destruct x; [discriminate|].
        destruct x; [reflexivity|discriminate].
      + kinv_dest_custom procDec_inv_tac; kinv_constr.
        procDec_inv_next 0.
      + kinv_dest_custom procDec_inv_tac; kinv_constr.
        procDec_inv_next 0.

      + kinv_dest_custom procDec_inv_tac; kinv_constr.
        * apply pgm_init_rq_inv_deq; assumption.
        * rewrite H2.
          destruct x; [discriminate|].
          kinv_regmap_red.
          unfold type in *; simpl in *.
          rewrite app_length; simpl; lia.
        * procDec_inv_old; procDec_inv_next 2.
          destruct x; [discriminate|].
          destruct x; [reflexivity|discriminate].
      + kinv_dest_custom procDec_inv_tac; kinv_constr.
        * apply pgm_init_rq_inv_deq; assumption.
        * rewrite H2.
          destruct x; [discriminate|].
          kinv_regmap_red.
          unfold type in *; simpl in *.
          rewrite app_length; simpl; lia.
        * procDec_inv_old; procDec_inv_next 2.
          destruct x; [discriminate|].
          destruct x; [reflexivity|discriminate].
          END_SKIP_PROOF_ON *) apply cheat.
  Qed.

  Lemma procDec_inv_ok:
    forall o,
      reachable o pdecInl ->
      procDec_inv o.
  Proof.
    intros; inv H; inv H0.
    eapply procDec_inv_ok'; eauto.
  Qed.

End Invariants.

#[global] Hint Unfold RqFromProc RsToProc: MethDefs.
#[global] Hint Unfold pgm_init_rq_rs_inv fifo_empty_inv fifo_not_empty_inv
       mem_request_inv: InvDefs.


Require Import List Arith.
Require Import MetaCoq.Template.All.
Import ListNotations MCMonadNotation.

MetaCoq Run (x <- tmFreshName ("x" ++ "y")%bs ;;
             tmDefinition x 0).

Check (eq_refl : xy = 0).

MetaCoq Run (x <- tmFreshName ("x" ++ "y")%bs ;;
             tmDefinition x 1).

Check (eq_refl : xy0 = 1).


(** * The coproduct of categories *)
Require Export Category.Core.

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

(** ** Definition of [+] for categories *)
Section internals.
  Variables C D : PreCategory.

  Definition sum_morphism (s d : C + D) : Type
    := match s, d with
         | inl s, inl d => morphism C s d
         | inr s, inr d => morphism D s d
         | _, _ => Empty
       end.

  Global Arguments sum_morphism _ _ / .

  Definition sum_identity (x : C + D) : sum_morphism x x
    := match x with
         | inl x => identity x
         | inr x => identity x
       end.

  Global Arguments sum_identity _ / .

  Definition sum_compose (s d d' : C + D)
             (m1 : sum_morphism d d') (m2 : sum_morphism s d)
  : sum_morphism s d'.
  Proof.
    case s, d, d'; simpl in *;
    solve [ case m1
          | case m2
          | eapply compose; eassumption ].
  Defined.

  Global Arguments sum_compose [_ _ _] _ _ / .
End internals.

Definition sum (C D : PreCategory) : PreCategory.
Proof.
  refine (@Build_PreCategory
            (C + D)%type
            (sum_morphism C D)
            (sum_identity C D)
            (sum_compose C D)
            _
            _
            _
            _);
  abstract (
      repeat (simpl || intros [] || intro);
      auto with morphism;
      typeclasses eauto
    ).
Defined.

Module Export CategorySumNotations.
  Infix "+" := sum : category_scope.
End CategorySumNotations.


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Floats.
Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import Coq.micromega.Lia.
Require Import VST.msl.eq_dec.

Definition address : Type := (block * Z)%type.

Instance EqDec_block: EqDec block := eq_block.

Instance EqDec_address: EqDec address.
Proof.
 intros [b1 z1] [b2 z2].
 destruct (eq_dec b1 b2).
 destruct (Z.eq_dec z1 z2).
 left; congruence.
 right; congruence.
 right; congruence.
Qed.

Instance EqDec_int: EqDec int := Int.eq_dec.
Instance EqDec_float: EqDec float := Float.eq_dec.

Instance EqDec_val: EqDec val.
Proof.
 hnf. decide equality.
 apply Int.eq_dec.
 apply Int64.eq_dec.
 apply Float.eq_dec.
 apply Float32.eq_dec.
 apply Ptrofs.eq_dec. (* apply Int.eq_dec.*)
 apply eq_block.
Qed.

Definition adr_range (base: address) (size: Z) (loc: address) : Prop :=
 match base, loc with
 | (b, ofs) , (b', ofs') => b=b' /\ (ofs <= ofs' < ofs + size)
 end.

Lemma adr_range_dec: forall base n loc, {adr_range base n loc} + {~adr_range base n loc}.
Proof.
unfold adr_range; intros.
destruct base as [b z]; destruct loc as [b' z'].
destruct (eq_block b b').
subst b'.
destruct (zle z z').
destruct (zlt z' (z+n)).
left; auto.
right; intros [? ?]; lia.
right; intros [? ?]; lia.
right; intros [? ?]; lia.
Qed.

(*
Definition size_chunk (chunk: memory_chunk) : Z :=
  match chunk with
  | Mint8signed => 1
  | Mint8unsigned => 1
  | Mint16signed => 2
  | Mint16unsigned => 2
  | Mint32 => 4
  | Mfloat32 => 4
  | Mfloat64 => 8
  | Mfloat64al32 => 4
  end.
*)

Remark size_chunk_pos:
  forall chunk1, size_chunk chunk1 > 0.
Proof.
  destruct chunk1; simpl; lia.
Qed.

Lemma zero_in_chunk: forall ch, 0 <= 0 < size_chunk ch.
Proof.
  intros; generalize (size_chunk_pos ch); lia.
Qed.

#[export] Hint Resolve zero_in_chunk : mem.

Definition range_overlap (base1: address) (sz1: Z) (base2: address) (sz2: Z) : Prop :=
  exists loc, adr_range base1 sz1 loc /\ adr_range base2 sz2 loc.

Definition adr_add (loc: address) (ofs: Z) : address := (fst loc, snd loc + ofs).

Definition val2adr (v: val) (l: address) : Prop :=
(*     match v with Vptr b ofs => l = (b, Int.unsigned ofs) | _ => False end.*)
     match v with Vptr b ofs => l = (b, Ptrofs.unsigned ofs) | _ => False end.

Lemma adr_range_non_zero: forall l1 n l2, adr_range l1 n l2 -> n > 0.
Proof.
  intros.
  unfold adr_range in H.
  destruct l1, l2.
  destruct (zlt 0 n); lia.
Qed.

Lemma adr_range_shift_1: forall bl ofs n l, adr_range (bl, ofs + 1) (Z.of_nat n) l -> adr_range (bl, ofs) (Z.of_nat (S n)) l.
Proof.
  intros.
  destruct l.
  unfold adr_range in *.
  rewrite Nat2Z.inj_succ.
  destruct H.
  repeat split; auto; lia.
Qed.

Lemma adr_range_S_split: forall bl ofs n l, adr_range (bl, ofs) (Z.of_nat (S n)) l -> adr_range (bl, ofs + 1) (Z.of_nat n) l \/ l = (bl, ofs).
Proof.
  intros.
  destruct l.
  unfold adr_range in *.
  rewrite Nat2Z.inj_succ in H.
  destruct H.
  subst bl.
  destruct (zlt ofs z); [left | right].
  + split; auto; lia.
  + f_equal; lia.
Qed.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.
Require Import Coq.Bool.Bool.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Category.Trv.
Require Import Blech.Category.Mt.
Require Import Blech.Groupoid.
Require Import Blech.Groupoid.Core.
Require Import Blech.Functor.
Require Import Blech.Bicategory.

Require Blech.Reflect.

Import BishopNotations.
Import CategoryNotations.
Import GroupoidNotations.
Import CoreNotations.

Open Scope bishop_scope.
Open Scope category_scope.

Reserved Notation "'I₊'".

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
Definition Interval: Bicategory := {|
  Obj := bool ;
  Mor A B := if implb A B then Trv else Mt ;

  id A :=
    match A with
    | true => I
    | false => I
    end ;
  compose A B C :=
    {|
      op _ := _ ;
      map _ _ _ := _ ;
    |} ;
|}.

Next Obligation.
Proof.
  destruct A, B, C.
  all: cbn in *.
  all: try apply I.
  all: destruct H.
  all: contradiction.
Defined.

Next Obligation.
Proof.
  destruct A, B, C.
  all: cbn in *.
  all: try apply I.
  all: destruct H.
  all: cbn in *.
  all: contradiction.
Defined.

Next Obligation.
Proof.
  destruct A, B, C.
  all: cbn in *.
  - exists.
    all: cbn in *.
    all: intros.
    + apply I.
    + apply I.
    + intros ? ? ?.
      apply I.
  - exists.
    all: cbn in *.
    + intros [? ?].
      contradiction.
    + intros [? ?].
      contradiction.
    + intros [? ?].
      contradiction.
  - exists.
    all: cbn in *.
    all: intros.
    + apply I.
    + apply I.
    + intros ? ? ?.
      apply I.
  - exists.
    all: cbn in *.
    + intros [? ?].
      contradiction.
    + intros [? ?].
      contradiction.
    + intros [? ?].
      contradiction.
  - exists.
    all: cbn in *.
    all: intros.
    + apply I.
    + apply I.
    + intros ? ? ?.
      apply I.
  - exists.
    all: cbn in *.
    + intros [? ?].
      contradiction.
    + intros [? ?].
      contradiction.
    + intros [? ?].
      contradiction.
  - exists.
    all: cbn in *.
    all: intros.
    + apply I.
    + apply I.
    + intros ? ? ?.
      apply I.
  - exists.
    all: cbn in *.
    all: intros.
    + apply I.
    + apply I.
    + intros ? ? ?.
      apply I.
Qed.

Next Obligation.
Proof.
  destruct A, B.
  all: cbn in *.
  all: try contradiction.
  all: destruct F.
  all: apply (Category.id (I: Core Trv)).
Qed.

Next Obligation.
Proof.
  destruct A, B.
  all: cbn in *.
  all: destruct F.
  all: apply (Category.id (I: Core Trv)).
Qed.

Next Obligation.
Proof.
  destruct A, B, C, D.
  all: cbn in *.
  all: try contradiction.
  all: apply (Category.id (I: Core Trv)).
Defined.

Module IntervalNotations.
  Notation "'I₊'" := Interval.
End IntervalNotations.


(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

From Coq Require Import List Syntax.
From Coq.ssr Require Import ssreflect.
Require Automaton.
Require Import Alphabet Grammar Validator_safe.

Module Make(Import A:Automaton.T).
Module Import ValidSafe := Validator_safe.Make A.

(** A few helpers for dependent types. *)

(** Decidable propositions. *)
Class Decidable (P : Prop) := decide : {P} + {~P}.
Arguments decide _ {_}.

(** A [Comparable] type has decidable equality. *)
Instance comparable_decidable_eq T `{ComparableLeibnizEq T} (x y : T) :
  Decidable (x = y).
Proof.
  unfold Decidable.
  destruct (compare x y) eqn:EQ; [left; apply compare_eq; intuition | ..];
    right; intros ->; by rewrite compare_refl in EQ.
Defined.

Instance list_decidable_eq T :
  (forall x y : T, Decidable (x = y)) ->
  (forall l1 l2 : list T, Decidable (l1 = l2)).
Proof. unfold Decidable. decide equality. Defined.

Ltac subst_existT :=
  repeat
    match goal with
    | _ => progress subst
    | H : @existT ?A ?P ?x ?y1 = @existT ?A ?P ?x ?y2 |- _ =>
      let DEC := fresh in
      assert (DEC : forall u1 u2 : A, Decidable (u1 = u2)) by apply _;
      apply Eqdep_dec.inj_pair2_eq_dec in H; [|by apply DEC];
      clear DEC
    end.

(** The interpreter is written using dependent types. In order to
  avoid reducing proof terms while executing the parser, we thunk all
  the propositions behind an arrow.
  Note that thunkP is still in Prop so that it is erased by
  extraction.
 *)
Definition thunkP (P : Prop) : Prop := True -> P.

(** Sometimes, we actually need a reduced proof in a program (for
  example when using an equality to cast a value). In that case,
  instead of reducing the proof we already have, we reprove the
  assertion by using decidability. *)
Definition reprove {P} `{Decidable P} (p : thunkP P) : P :=
  match decide P with
  | left p => p
  | right np => False_ind _ (np (p I))
  end.

(** Combination of reprove with eq_rect. *)
Definition cast {T : Type} (F : T -> Type) {x y : T} (eq : thunkP (x = y))
                {DEC : unit -> Decidable (x = y)}:
                F x -> F y :=
  fun a => eq_rect x F a y (@reprove _ (DEC ()) eq).

Lemma cast_eq T F (x : T) (eq : thunkP (x = x)) `{forall x y, Decidable (x = y)} a :
  cast F eq a = a.
Proof. by rewrite /cast -Eqdep_dec.eq_rect_eq_dec. Qed.

(** Input buffers and operations on them. **)
CoInductive buffer : Type :=
  Buf_cons { buf_head : token; buf_tail : buffer }.

Delimit Scope buffer_scope with buf.
Bind Scope buffer_scope with buffer.

Infix "::" := Buf_cons (at level 60, right associativity) : buffer_scope.

(** Concatenation of a list and an input buffer **)
Fixpoint app_buf (l:list token) (buf:buffer) :=
  match l with
    | nil => buf
    | cons t q => (t :: app_buf q buf)%buf
  end.
Infix "++" := app_buf (at level 60, right associativity) : buffer_scope.

Lemma app_buf_assoc (l1 l2:list token) (buf:buffer) :
  (l1 ++ (l2 ++ buf) = (l1 ++ l2) ++ buf)%buf.
Proof. induction l1 as [|?? IH]=>//=. rewrite IH //. Qed.

(** The type of a non initial state: the type of semantic values associated
   with the last symbol of this state. *)
Definition noninitstate_type state :=
  symbol_semantic_type (last_symb_of_non_init_state state).

(** The stack of the automaton : it can be either nil or contains a non
    initial state, a semantic value for the symbol associted with this state,
    and a nested stack. **)
Definition stack := list (sigT noninitstate_type). (* eg. list {state & state_type state} *)

Section Interpreter.

Hypothesis safe: safe.

(* Properties of the automaton deduced from safety validation. *)
Proposition shift_head_symbs: shift_head_symbs.
Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.
Proposition goto_head_symbs: goto_head_symbs.
Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.
Proposition shift_past_state: shift_past_state.
Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.
Proposition goto_past_state: goto_past_state.
Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.
Proposition reduce_ok: reduce_ok.
Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.

Variable init : initstate.

(** The top state of a stack **)
Definition state_of_stack (stack:stack): state :=
  match stack with
    | [] => init
    | existT _ s _::_ => s
  end.

(** The stack of states of an automaton stack **)
Definition state_stack_of_stack (stack:stack) :=
  (List.map
    (fun cell:sigT noninitstate_type => singleton_state_pred (projT1 cell))
    stack ++ [singleton_state_pred init])%list.

(** The stack of symbols of an automaton stack **)
Definition symb_stack_of_stack (stack:stack) :=
  List.map
    (fun cell:sigT noninitstate_type => last_symb_of_non_init_state (projT1 cell))
    stack.

(** The stack invariant : it basically states that the assumptions on the
    states are true. **)
Inductive stack_invariant: stack -> Prop :=
  | stack_invariant_constr:
    forall stack,
      prefix      (head_symbs_of_state (state_of_stack stack))
                  (symb_stack_of_stack stack) ->
      prefix_pred (head_states_of_state (state_of_stack stack))
                  (state_stack_of_stack stack) ->
      stack_invariant_next stack ->
      stack_invariant stack
with stack_invariant_next: stack -> Prop :=
  | stack_invariant_next_nil:
      stack_invariant_next []
  | stack_invariant_next_cons:
    forall state_cur st stack_rec,
      stack_invariant stack_rec ->
      stack_invariant_next (existT _ state_cur st::stack_rec).

(** [pop] pops some symbols from the stack. It returns the popped semantic
    values using [sem_popped] as an accumulator and discards the popped
    states.**)
Fixpoint pop (symbols_to_pop:list symbol) {A:Type} (stk:stack) :
  thunkP (prefix symbols_to_pop (symb_stack_of_stack stk)) ->
  forall (action:arrows_right A (map symbol_semantic_type symbols_to_pop)),
    stack * A.
unshelve refine
  (match symbols_to_pop
      return
         (thunkP (prefix symbols_to_pop (symb_stack_of_stack stk))) ->
         forall (action:arrows_right A (map _ symbols_to_pop)), stack * A
   with
     | [] => fun _ action => (stk, action)
     | t::q => fun Hp action =>
       match stk
          return thunkP (prefix (t::q) (symb_stack_of_stack stk)) -> stack * A
       with
         | existT _ state_cur sem::stack_rec => fun Hp =>
           let sem_conv := cast symbol_semantic_type _ sem in
           pop q _ stack_rec _ (action sem_conv)
         | [] => fun Hp => False_rect _ _
       end Hp
   end).
Proof.
  - simpl in Hp. clear -Hp. abstract (intros _ ; specialize (Hp I); now inversion Hp).
  - clear -Hp. abstract (specialize (Hp I); now inversion Hp).
  - simpl in Hp. clear -Hp. abstract (intros _ ; specialize (Hp I); now inversion Hp).
Defined.

(* Equivalent declarative specification for pop, so that we avoid
   (part of) the dependent types nightmare. *)
Inductive pop_spec {A:Type} :
    forall (symbols_to_pop:list symbol) (stk : stack)
           (action : arrows_right A (map symbol_semantic_type symbols_to_pop))
           (stk' : stack) (sem : A),
      Prop :=
  | Nil_pop_spec stk sem : pop_spec [] stk sem stk sem
  | Cons_pop_spec symbols_to_pop st stk action sem stk' res :
      pop_spec symbols_to_pop stk (action sem) stk' res ->
      pop_spec (last_symb_of_non_init_state st::symbols_to_pop)
               (existT _ st sem :: stk) action stk' res.

Lemma pop_spec_ok {A:Type} symbols_to_pop stk Hp action stk' res:
  pop symbols_to_pop stk Hp action = (stk', res) <->
  pop_spec (A:=A) symbols_to_pop stk action stk' res.
Proof.
  revert stk Hp action.
  induction symbols_to_pop as [|t symbols_to_pop IH]=>stk Hp action /=.
  - split.
    + intros [= <- <-]. constructor.
    + intros H. inversion H. by subst_existT.
  - destruct stk as [|[st sem]]=>/=; [by destruct pop_subproof0|].
    remember (pop_subproof t symbols_to_pop stk st Hp) as EQ eqn:eq. clear eq.
    generalize EQ. revert Hp action. rewrite <-(EQ I)=>Hp action ?.
    rewrite cast_eq. rewrite IH. split.
    + intros. by constructor.
    + intros H. inversion H. by subst_existT.
Qed.

Lemma pop_preserves_invariant symbols_to_pop stk Hp A action :
  stack_invariant stk ->
  stack_invariant (fst (pop symbols_to_pop stk Hp (A:=A) action)).
Proof.
  revert stk Hp A action. induction symbols_to_pop as [|t q IH]=>//=.
  intros stk Hp A action Hi.
  destruct Hi as [stack Hp' Hpp [|state st stk']].
  - destruct pop_subproof0.
  - now apply IH.
Qed.

Lemma pop_state_valid symbols_to_pop stk Hp A action lpred :
  prefix_pred lpred (state_stack_of_stack stk) ->
  let stk' := fst (pop symbols_to_pop stk Hp (A:=A) action) in
  state_valid_after_pop (state_of_stack stk') symbols_to_pop lpred.
Proof.
  revert stk Hp A action lpred. induction symbols_to_pop as [|t q IH]=>/=.
  - intros stk Hp A a lpred Hpp. destruct lpred as [|pred lpred]; constructor.
    inversion Hpp as [|? lpred' ? pred' Himpl Hpp' eq1 eq2]; subst.
    specialize (Himpl (state_of_stack stk)).
    destruct (pred' (state_of_stack stk)) as [] eqn:Heqpred'=>//.
    destruct stk as [|[]]; simpl in *.
    + inversion eq2; subst; clear eq2.
      unfold singleton_state_pred in Heqpred'.
      now rewrite compare_refl in Heqpred'; discriminate.
    + inversion eq2; subst; clear eq2.
      unfold singleton_state_pred in Heqpred'.
      now rewrite compare_refl in Heqpred'; discriminate.
  - intros stk Hp A a lpred Hpp. destruct stk as [|[] stk]=>//=.
    + destruct pop_subproof0.
    + destruct lpred as [|pred lpred]; [by constructor|].
      constructor. apply IH. by inversion Hpp.
Qed.

(** [step_result] represents the result of one step of the automaton : it can
    fail, accept or progress. [Fail_sr] means that the input is incorrect.
    [Accept_sr] means that this is the last step of the automaton, and it
    returns the semantic value of the input word. [Progress_sr] means that
    some progress has been made, but new steps are needed in order to accept
    a word.

    For [Accept_sr] and [Progress_sr], the result contains the new input buffer.

    [Fail_sr] means that the input word is rejected by the automaton. It is
    different to [Err] (from the error monad), which mean that the automaton is
    bogus and has perfomed a forbidden action. **)
Inductive step_result :=
  | Fail_sr: step_result
  | Accept_sr: symbol_semantic_type (NT (start_nt init)) -> buffer -> step_result
  | Progress_sr: stack -> buffer -> step_result.

(** [reduce_step] does a reduce action :
   - pops some elements from the stack
   - execute the action of the production
   - follows the goto for the produced non terminal symbol **)
Definition reduce_step stk prod (buffer : buffer)
        (Hval : thunkP (valid_for_reduce (state_of_stack stk) prod))
        (Hi : thunkP (stack_invariant stk))
  : step_result.
refine
  ((let '(stk', sem) as ss := pop (prod_rhs_rev prod) stk _ (prod_action prod)
      return thunkP (state_valid_after_pop (state_of_stack (fst ss)) _
                               (head_states_of_state (state_of_stack stk))) -> _
    in fun Hval' =>
    match goto_table (state_of_stack stk') (prod_lhs prod) as goto
      return (thunkP (goto = None ->
                      match state_of_stack stk' with
                      | Init i => prod_lhs prod = start_nt i
                      | Ninit _ => False
                      end)) -> _
    with
    | Some (exist _ state_new e) => fun _ =>
      let sem := eq_rect _ _ sem _ e in
      Progress_sr (existT noninitstate_type state_new sem::stk') buffer
    | None => fun Hval =>
      let sem := cast symbol_semantic_type _ sem in
      Accept_sr sem buffer
    end (fun _ => _))
   (fun _ => pop_state_valid _ _ _ _ _ _ _)).
Proof.
  - clear -Hi Hval.
    abstract (intros _; destruct Hi=>//; eapply prefix_trans; [by apply Hval|eassumption]).
  - clear -Hval.
    abstract (intros _; f_equal; specialize (Hval I eq_refl); destruct stk' as [|[]]=>//).
  - simpl in Hval'. clear -Hval Hval'.
    abstract (move : Hval => /(_ I) [_ /(_ _ (Hval' I))] Hval2 Hgoto; by rewrite Hgoto in Hval2).
  - clear -Hi. abstract by destruct Hi.
Defined.

Lemma reduce_step_stack_invariant_preserved stk prod buffer Hv Hi stk' buffer':
  reduce_step stk prod buffer Hv Hi = Progress_sr stk' buffer' ->
  stack_invariant stk'.
Proof.
  unfold reduce_step.
  match goal with
  | |- context [pop ?symbols_to_pop stk ?Hp ?action] =>
    assert (Hi':=pop_preserves_invariant symbols_to_pop stk Hp _ action (Hi I));
    generalize (pop_state_valid symbols_to_pop stk Hp _ action)
  end.
  destruct pop as [stk0 sem]=>/=. simpl in Hi'. intros Hv'.
  assert (Hgoto1:=goto_head_symbs (state_of_stack stk0) (prod_lhs prod)).
  assert (Hgoto2:=goto_past_state (state_of_stack stk0) (prod_lhs prod)).
  match goal with | |- context [fun _ : True => ?X] => generalize X end.
  destruct goto_table as [[state_new e]|] eqn:EQgoto=>//.
  intros _ [= <- <-]. constructor=>/=.
  - constructor. eapply prefix_trans. apply Hgoto1. by destruct Hi'.
  - unfold state_stack_of_stack; simpl; constructor.
    + intros ?. by destruct singleton_state_pred.
    + eapply prefix_pred_trans. apply Hgoto2. by destruct Hi'.
  - by constructor.
Qed.

(** One step of parsing. **)
Definition step stk buffer (Hi : thunkP (stack_invariant stk)): step_result :=
  match action_table (state_of_stack stk) as a return
    thunkP
      match a return Prop with
      | Default_reduce_act prod => _
      | Lookahead_act awt => forall t : terminal,
        match awt t with
        | Reduce_act p => _
        | _ => True
        end
      end -> _
  with
  | Default_reduce_act prod => fun Hv =>
    reduce_step stk prod buffer Hv Hi
  | Lookahead_act awt => fun Hv =>
    match buf_head buffer with
    | tok =>
      match awt (token_term tok) as a return
        thunkP match a return Prop with Reduce_act p => _ | _ => _ end -> _
      with
      | Shift_act state_new e => fun _ =>
        let sem_conv := eq_rect _ symbol_semantic_type (token_sem tok) _ e in
        Progress_sr (existT noninitstate_type state_new sem_conv::stk)
                    (buf_tail buffer)
      | Reduce_act prod => fun Hv =>
        reduce_step stk prod buffer Hv Hi
      | Fail_act => fun _ =>
        Fail_sr
      end (fun _ => Hv I (token_term tok))
    end
  end (fun _ => reduce_ok _).

Lemma step_stack_invariant_preserved stk buffer Hi stk' buffer':
  step stk buffer Hi = Progress_sr stk' buffer' ->
  stack_invariant stk'.
Proof.
  unfold step.
  generalize (reduce_ok (state_of_stack stk))=>Hred.
  assert (Hshift1 := shift_head_symbs (state_of_stack stk)).
  assert (Hshift2 := shift_past_state (state_of_stack stk)).
  destruct action_table as [prod|awt]=>/=.
  - eauto using reduce_step_stack_invariant_preserved.
  - set (term := token_term (buf_head buffer)).
    generalize (Hred term). clear Hred. intros Hred.
    specialize (Hshift1 term). specialize (Hshift2 term).
    destruct (awt term) as [state_new e|prod|]=>//.
    + intros [= <- <-]. constructor=>/=.
      * constructor. eapply prefix_trans. apply Hshift1. by destruct Hi.
      * unfold state_stack_of_stack; simpl; constructor.
        -- intros ?. by destruct singleton_state_pred.
        -- eapply prefix_pred_trans. apply Hshift2. by destruct Hi.
      * constructor; by apply Hi.
    + eauto using reduce_step_stack_invariant_preserved.
Qed.

(** The parsing use a [nat] fuel parameter [log_n_steps], so that we
    do not have to prove terminaison, which is difficult.

    Note that [log_n_steps] is *not* the fuel in the conventionnal
    sense: this parameter contains the logarithm (in base 2) of the
    number of steps to perform. Hence, a value of, e.g., 50 will
    usually be enough to ensure termination. *)
Fixpoint parse_fix stk buffer (log_n_steps : nat) (Hi : thunkP (stack_invariant stk)):
  { sr : step_result |
    forall stk' buffer', sr = Progress_sr stk' buffer' -> stack_invariant stk' } :=
  match log_n_steps with
  | O => exist _ (step stk buffer Hi)
                 (step_stack_invariant_preserved _ _ Hi)
  | S log_n_steps =>
    match parse_fix stk buffer log_n_steps Hi with
    | exist _ (Progress_sr stk buffer) Hi' =>
      parse_fix stk buffer log_n_steps (fun _ => Hi' _ buffer eq_refl)
    | sr => sr
    end
  end.

(** The final result of a parsing is either a failure (the automaton
    has rejected the input word), either a timeout (the automaton has
    spent all the given [2^log_n_steps]), either a parsed semantic value
    with a rest of the input buffer.

    Note that we do not make parse_result depend on start_nt for the
    result type, so that this inductive is extracted without the use
    of Obj.t in OCaml.  **)
Inductive parse_result {A : Type} :=
  | Fail_pr: parse_result
  | Timeout_pr: parse_result
  | Parsed_pr: A -> buffer -> parse_result.
Global Arguments parse_result _ : clear implicits.

Definition parse (buffer : buffer) (log_n_steps : nat):
  parse_result (symbol_semantic_type (NT (start_nt init))).
refine (match proj1_sig (parse_fix [] buffer log_n_steps _) with
        | Fail_sr => Fail_pr
        | Accept_sr sem buffer' => Parsed_pr sem buffer'
        | Progress_sr _ _ => Timeout_pr
        end).
Proof.
  abstract (repeat constructor; intros; by destruct singleton_state_pred).
Defined.

End Interpreter.

Arguments Fail_sr {init}.
Arguments Accept_sr {init} _ _.
Arguments Progress_sr {init} _ _.

End Make.

Module Type T(A:Automaton.T).
  Include (Make A).
End T.


(** printing ⊢k #⊢k# *)
(** printing ⊢! #⊢# *)
(** printing k⊣ #⊣# *)
(** printing |- #⊢# *)
(** printing ⦂ #:# *)
(** printing <⦂ #<:# *)
(** printing [<=] #⊆# *)
(** printing `union` #∪# *)
(** printing \u #∪# *)
(** printing `notin` #∉# *)
(** printing `in` #∈# *)
(** printing ⊆<⦂ #⊆<:# *)

Set Implicit Arguments.
Require Import Definitions.
Require Import OperationProperties.
Require Import StructuralProperties.

(** * OPE#<:#

    This file defines the order-preserving sub-environment, or OPE#<:#
 and examines its properties. In a nutshell, this concept captures weakening and
 narrowing at the same time, which serves very well when examine more than one
 contexts at the same time.
 *)

Reserved Notation "G1 ⊆<⦂ G2" (at level 90).
Inductive ope_sub : env -> env -> Prop :=
(** [――――――] Ope-Nil #
#
    [⋅ ⊆<⦂ ⋅]  *)
| os_nil : nil ⊆<⦂ nil
(** [G2 ⊆<⦂ G1] #
#
    [――――――――――――――――] Ope-Drop #
#
    [G2 ; x : T ⊆<⦂ G1]  *)
| os_drop : forall G1 G2 x T,
    G2 ⊆<⦂ G1 ->
    (x, T) :: G2 ⊆<⦂ G1
(** [G2 ⊆<⦂ G1] #
#
    [G2 ⊢ T1 <: T2] #
#
    [――――――――――――――――] Ope-Keep #
#
    [G2 ; x : T1 ⊆<⦂ G1 ; x : T2]  *)
| os_keep : forall G1 G2 x T1 T2,
    G2 ⊆<⦂ G1 ->
    G2 ⊢ T1 <⦂ T2 ->
    (x, T1) :: G2 ⊆<⦂ (x, T2) :: G1
where "G1 ⊆<⦂ G2" := (ope_sub G2 G1).
Local Hint Constructors ope_sub.

Section OpeProperties.

  Lemma ope_sub_length : forall G1 G2,
    G2 ⊆<⦂ G1 ->
    length G1 <= length G2.
  Proof.
    induction on ope_sub; routine.
  Qed.

  Hint Resolve weaken_subty.

  Lemma ope_narrow_var :
    forall G G' x T,
      G' ⊆<⦂ G ->
      binds x T G ->
      G' ⊢ trm_var (avar_f x) ⦂ T.
  Proof.
    induction on ope_sub; intros.
    - routine.
    - apply IHope_sub in H.
      reassoc 2 with 1. apply weaken_typing.
      trivial.
    - tidy_up.
      + eapply ty_sub; simpl_env; eauto.
      + apply IHope_sub in H0.
        simpl_env. apply weaken_typing.
        trivial.
  Qed.
  Hint Resolve ope_narrow_var.

  Lemma ope_narrow_trm : forall G t T,
      G ⊢ t ⦂ T ->
      forall G',
        G' ⊆<⦂ G ->
        G' ⊢ t ⦂ T
  with ope_narrow_subty : forall G T U,
      G ⊢ T <⦂ U ->
      forall G',
        G' ⊆<⦂ G ->
        G' ⊢ T <⦂ U.
  Proof.
    - clear ope_narrow_trm.
      induction on typing; intros; eauto.
      + econstructor. cofinite.
        apply H0; simpl; auto.
      + econstructor; auto. cofinite.
        apply H0; simpl; auto.
      + eapply ty_sub; eauto.

    - clear ope_narrow_subty.
      induction on subty; intros; eauto.

      eapply st_all. auto.
      cofinite.
      apply H0; simpl; auto.
  Qed.
  Hint Resolve ope_narrow_subty.

  Lemma ope_sub_trans : forall G1 G2 G3,
      G2 ⊆<⦂ G1 ->
      G3 ⊆<⦂ G2 ->
      G3 ⊆<⦂ G1.
  Proof.
    intros. gen G1. induction H0; intros; auto.
    invert H1; subst; eauto.
  Qed.

  Lemma ope_sub_refl : forall G,
      G ⊆<⦂ G.
  Proof. induction on env; routine. Qed.

  Lemma ope_sub_nil : forall G,
      G ⊆<⦂ nil.
  Proof. induction on env; routine. Qed.

  Lemma ope_sub_app : forall G G1 G2,
      G2 ⊆<⦂ G ->
      G1 ++ G2 ⊆<⦂ G.
  Proof. induction G1; routine. Qed.

End OpeProperties.