diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 44b8e6e..7fcfe94 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -4,12 +4,22 @@ name: Docker CI on: [push, pull_request] jobs: + build_nix: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + - uses: cachix/install-nix-action@v24 + with: + github_access_token: ${{ secrets.GITHUB_TOKEN }} + - run: nix build .#coq-artifact + build: runs-on: ubuntu-latest strategy: matrix: image: - 'coqorg/coq:8.17' + - 'coqorg/coq:8.18' max-parallel: 4 fail-fast: false @@ -21,7 +31,6 @@ jobs: install: | startGroup "Install dependencies" sudo apt-get update -y -q - opam repo add iris-dev https://gitlab.mpi-sws.org/iris/opam.git opam pin add -n -y -k path $PACKAGE $WORKDIR opam update -y opam install --confirm-level=unsafe-yes -j 2 $PACKAGE --deps-only diff --git a/README.md b/README.md index 865ab57..c74eddd 100644 --- a/README.md +++ b/README.md @@ -1,15 +1,15 @@ # Guarded Interaction Trees This is the Coq formalization of guarded interaction trees, associated examples and case studies. +Read the [GITrees POPL paper](https://iris-project.org/pdfs/2024-popl-gitrees.pdf) describing our work. ## Installation instructions -To install the formalization you will need the Iris, std++, and Equations packages. +To install the formalization you will need Iris and std++ libraries. The dependencies can be easily installed using [Opam](https://opam.ocaml.org/) with the following commands: ``` opam repo add coq-released https://coq.inria.fr/opam/released -opam repo add iris-dev https://gitlab.mpi-sws.org/iris/opam.git opam update opam install . --deps-only ``` @@ -25,14 +25,24 @@ All the code lives in the `theories` folder. Below is the quick guide to the code structure. - `gitree/` -- contains the core definitions related to guarded interaction trees -- `input_lang/` -- formalization of the language with io, the soundness and adequacy -- `affine_lang/` -- formalization of the affine language, type safety of the language interoperability -- `examples/` -- some other smaller examples -- `lang_generic.v` -- generic facts about languages with binders and their interpretations, shared by `input_lang` and `affine_lang` +- `lib/` -- derived combinators for gitrees +- `effects/` -- concrete effects, their semantics, and program logic rules +- `examples/input_lang/` -- formalization of the language with io, the soundness and adequacy +- `examples/affine_lang/` -- formalization of the affine language, type safety of the language interoperability +- `examples/input_lang_callcc/` -- formalization of the language with io, throw and call/cc, the soundness and adequacy +- `examples/delim_lang/` -- formalization shift/reset effects, of a language with delimited continuations and its soundness - `prelude.v` -- some stuff that is missing from Iris +- `lang_generic.v` -- generic facts about languages with binders and their interpretations, shared by `input_lang` and `affine_lang` + +For the representation of binders we use a library implemented by +Filip Sieczkowski and Piotr Polesiuk, located in the `vendor/Binding/` +folder. ### References from the paper to the code +The version of the formalization that corresponds to the paper can be found under the [tag `popl24`](https://github.com/logsem/gitrees/releases/tag/popl24). +Below we describe the correspondence per-section. + - **Section 3** + Definition of guarded interaction trees, constructors, the recursion principle, and the destructors are in `gitree/core.v` @@ -42,7 +52,7 @@ to the code structure. + The factorial example is in `examples/factorial.v`, and the pairs example is in `examples/pairs.v` - **Section 4** - + The definition of reifiers and the reify function are in `gitree/reify.v` + + The definition of context-dependent versions of reifiers and the reify function are in `gitree/reify.v` + The reduction relation is in `gitree/reductions.v` + The specific reifiers for IO and state are in `examples/store.v` and `input_lang/interp.v` @@ -70,12 +80,6 @@ to the code structure. ## Notes -### Representations of binders -For the representation of languages with binders, we follow the -approach of (Benton, Hur, Kennedy, McBride, JAR 2012) with well-scoped -terms and substitutions/renamings. - - ### Disjunction property Some results in the formalization make use of the disjunction property of Iris: if (P ∨ Q) is provable, then either P or Q are provable on diff --git a/_CoqProject b/_CoqProject index fd559b8..2337a45 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,6 +1,19 @@ -Q theories gitrees +-Q vendor/Binding Binding -arg -w -arg -ssr-search-moved +vendor/Binding/Properties.v +vendor/Binding/Lib.v +vendor/Binding/Set.v +vendor/Binding/Auto.v +vendor/Binding/Core.v +vendor/Binding/Inc.v +vendor/Binding/Intrinsic.v +vendor/Binding/TermSimpl.v +vendor/Binding/Product.v +vendor/Binding/Env.v +vendor/Binding/Resolver.v + theories/prelude.v theories/lang_generic.v @@ -15,18 +28,30 @@ theories/gitree.v theories/program_logic.v -theories/input_lang/lang.v -theories/input_lang/interp.v -theories/input_lang/logpred.v -theories/input_lang/logrel.v +theories/effects/store.v +theories/effects/io_tape.v + +theories/lib/pairs.v +theories/lib/while.v +theories/lib/factorial.v +theories/lib/iter.v + +theories/examples/delim_lang/lang.v +theories/examples/delim_lang/interp.v +theories/examples/delim_lang/example.v + +theories/examples/input_lang_callcc/lang.v +theories/examples/input_lang_callcc/interp.v +theories/examples/input_lang_callcc/hom.v +theories/examples/input_lang_callcc/logrel.v -theories/affine_lang/lang.v -theories/affine_lang/logrel1.v -theories/affine_lang/logrel2.v +theories/examples/input_lang/lang.v +theories/examples/input_lang/interp.v +theories/examples/input_lang/logpred.v +theories/examples/input_lang/logrel.v -theories/examples/store.v -theories/examples/pairs.v -theories/examples/while.v -theories/examples/factorial.v -theories/examples/iter.v +theories/examples/affine_lang/lang.v +theories/examples/affine_lang/logrel1.v +theories/examples/affine_lang/logrel2.v +theories/utils/finite_sets.v diff --git a/check_admits.sh b/check_admits.sh new file mode 100755 index 0000000..e694cc9 --- /dev/null +++ b/check_admits.sh @@ -0,0 +1,3 @@ +#! /bin/sh + +grep -n -e 'admit' -e 'Admitted' $(find . -name '*.v' -type f) diff --git a/coq-gitrees.opam b/coq-gitrees.opam index d34f9db..3056b98 100644 --- a/coq-gitrees.opam +++ b/coq-gitrees.opam @@ -2,16 +2,15 @@ opam-version: "2.0" name: "coq-gitrees" synopsis: "Guarded Interaction Trees" version: "dev" -maintainer: "..." -authors: "..." +maintainer: "Logsem" +authors: "Logsem" license: "BSD" build: [make "-j%{jobs}%"] install: [make "install"] remove: ["rm" "-rf" "%{lib}%/coq/user-contrib/gitrees"] depends: [ - "coq-equations" { (= "1.3+8.17") } - "coq-iris" { (= "dev.2023-09-29.0.4f3a385f") } - "coq-iris-heap-lang" { (= "dev.2023-09-29.0.4f3a385f") } - "coq-stdpp" { (= "dev.2023-09-21.2.7f6df4fa") } + "coq-iris" { (= "4.1.0") } + "coq-iris-heap-lang" { (= "4.1.0") } + "coq-stdpp" { (= "1.9.0") } "coq" { (>= "8.17") | (= "dev") } ] diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..0890c9c --- /dev/null +++ b/flake.lock @@ -0,0 +1,61 @@ +{ + "nodes": { + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1694529238, + "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1701952659, + "narHash": "sha256-TJv2srXt6fYPUjxgLAL0cy4nuf1OZD4KuA1TrCiQqg0=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "b4372c4924d9182034066c823df76d6eaf1f4ec4", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-23.11", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..e05e6a3 --- /dev/null +++ b/flake.nix @@ -0,0 +1,35 @@ +{ + description = "gitrees"; + inputs = { + nixpkgs.url = github:NixOS/nixpkgs/nixos-23.11; + flake-utils.url = github:numtide/flake-utils; + }; + outputs = { self, nixpkgs, flake-utils }: + with flake-utils.lib; eachSystem allSystems (system: + let + pkgs = nixpkgs.legacyPackages.${system}; + lib = pkgs.lib; + coq = pkgs.coq_8_17; + coqPkgs = pkgs.coqPackages_8_17; + in { + packages = { + coq-artifact = coqPkgs.mkCoqDerivation { + pname = "coq-artifact"; + version = "main"; + src = ./.; + buildPhase = "make"; + propagatedBuildInputs = [ + coqPkgs.stdpp + coqPkgs.iris + coqPkgs.equations + ]; + }; + }; + devShell = pkgs.mkShell { + buildInputs = with pkgs; [ + coq + ]; + inputsFrom = [ self.packages.${system}.coq-artifact ]; + }; + }); +} diff --git a/theories/effects/io_tape.v b/theories/effects/io_tape.v new file mode 100644 index 0000000..fd34746 --- /dev/null +++ b/theories/effects/io_tape.v @@ -0,0 +1,144 @@ +(** I/O on a tape effect *) +From gitrees Require Import prelude gitree. + +Record state := State { + inputs : list nat; + outputs : list nat; + }. +#[export] Instance state_inhabited : Inhabited state := populate (State [] []). + +Definition update_input (s : state) : nat * state := + match s.(inputs) with + | [] => (0, s) + | n::ns => + (n, {| inputs := ns; outputs := s.(outputs) |}) + end. +Definition update_output (n:nat) (s : state) : state := + {| inputs := s.(inputs); outputs := n::s.(outputs) |}. + +Notation stateO := (leibnizO state). + +Program Definition inputE : opInterp := + {| + Ins := unitO; + Outs := natO; + |}. + +Program Definition outputE : opInterp := + {| + Ins := natO; + Outs := unitO; + |}. + +Definition ioE := @[inputE;outputE]. + +(* INPUT *) +Definition reify_input X `{Cofe X} : unitO * stateO → + option (natO * stateO) := + λ '(o, σ), Some (update_input σ : prodO natO stateO). +#[export] Instance reify_input_ne X `{Cofe X} : + NonExpansive (reify_input X). +Proof. + intros ?[[]][[]][_?]. simpl in *. f_equiv. + repeat f_equiv. done. +Qed. + +(* OUTPUT *) +Definition reify_output X `{Cofe X} : (natO * stateO) → + option (unitO * stateO) := + λ '(n, σ), Some((), update_output n σ : stateO). +#[export] Instance reify_output_ne X `{Cofe X} : + NonExpansive (reify_output X). +Proof. + intros ?[][][]. simpl in *. + repeat f_equiv; done. +Qed. + +Canonical Structure reify_io : sReifier NotCtxDep. +Proof. + simple refine {| sReifier_ops := ioE; + sReifier_state := stateO + |}. + intros X HX op. + destruct op as [[] | [ | []]]; simpl. + - simple refine (OfeMor (reify_input X)). + - simple refine (OfeMor (reify_output X)). +Defined. + +Section constructors. + Context {E : opsInterp} {A} `{!Cofe A}. + Context {subEff0 : subEff ioE E}. + Context {subOfe0 : SubOfe natO A}. + Notation IT := (IT E A). + Notation ITV := (ITV E A). + + Program Definition INPUT : (nat -n> IT) -n> IT := λne k, Vis (E:=E) (subEff_opid (inl ())) + (subEff_ins (F:=ioE) (op:=(inl ())) ()) + (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inl ())))^-1). + Solve Obligations with solve_proper. + Program Definition OUTPUT_ : nat -n> IT -n> IT := + λne m α, Vis (E:=E) (subEff_opid (inr (inl ()))) + (subEff_ins (F:=ioE) (op:=(inr (inl ()))) m) + (λne _, NextO α). + Solve All Obligations with solve_proper_please. + Program Definition OUTPUT : nat -n> IT := λne m, OUTPUT_ m (Ret 0). + + Lemma hom_INPUT k f `{!IT_hom f} : f (INPUT k) ≡ INPUT (OfeMor f ◎ k). + Proof. + unfold INPUT. + rewrite hom_vis/=. repeat f_equiv. + intro x. cbn-[laterO_map]. rewrite laterO_map_Next. + done. + Qed. + Lemma hom_OUTPUT_ m α f `{!IT_hom f} : f (OUTPUT_ m α) ≡ OUTPUT_ m (f α). + Proof. + unfold OUTPUT. + rewrite hom_vis/=. repeat f_equiv. + intro x. cbn-[laterO_map]. rewrite laterO_map_Next. + done. + Qed. + +End constructors. + +Section weakestpre. + Context {sz : nat}. + Variable (rs : gReifiers NotCtxDep sz). + Context {subR : subReifier reify_io rs}. + Notation F := (gReifiers_ops rs). + Context {R} `{!Cofe R}. + Context `{!SubOfe natO R}. + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : + update_input σ = (n, σ') → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ + WP@{rs} (INPUT k) @ s {{ Φ }}. + Proof. + intros Hs. iIntros "Hs Ha". + unfold INPUT. simpl. + iApply (wp_subreify_ctx_indep with "Hs"). + { simpl. rewrite Hs//=. } + { simpl. by rewrite ofe_iso_21. } + iModIntro. done. + Qed. + + Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : + update_output n σ = σ' → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ + WP@{rs} (OUTPUT n) @ s {{ Φ }}. + Proof. + intros Hs. iIntros "Hs Ha". + unfold OUTPUT. simpl. + iApply (wp_subreify_ctx_indep rs with "Hs"). + { simpl. by rewrite Hs. } + { simpl. done. } + iModIntro. iIntros "H1 H2". + iApply wp_val. by iApply ("Ha" with "H1 H2"). + Qed. + +End weakestpre. diff --git a/theories/examples/store.v b/theories/effects/store.v similarity index 73% rename from theories/examples/store.v rename to theories/effects/store.v index b855f73..f11e23e 100644 --- a/theories/examples/store.v +++ b/theories/effects/store.v @@ -1,4 +1,4 @@ -From Equations Require Import Equations. +(** Higher-order store effect *) From iris.algebra Require Import gmap excl auth gmap_view. From iris.proofmode Require Import classes tactics. From iris.base_logic Require Import algebra. @@ -83,7 +83,7 @@ Program Definition DeallocE : opInterp := {| |}. Definition storeE : opsInterp := @[ReadE;WriteE;AllocE;DeallocE]. -Canonical Structure reify_store : sReifier. +Canonical Structure reify_store : sReifier NotCtxDep. Proof. simple refine {| sReifier_ops := storeE |}. intros X HX op. @@ -126,10 +126,9 @@ Section constructors. (λne _, Next (Ret ())). End constructors. - Section wp. Context {n : nat}. - Variable (rs : gReifiers n). + Variable (rs : gReifiers NotCtxDep n). Context {R} `{!Cofe R}. Context `{!SubOfe unitO R}. @@ -226,7 +225,7 @@ Section wp. Proof. iIntros (Hee) "#Hcxt H". unfold READ. simpl. - iApply wp_subreify'. + iApply wp_subreify_ctx_indep'. simpl. iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". iApply (fupd_mask_weaken E1). { set_solver. } @@ -247,13 +246,10 @@ Section wp. iExists σ,(Next β'),σ,β'. iFrame "Hs". repeat iSplit. - - iAssert ((option_bind _ _ (λ x, Some (x, σ)) (σ !! l)) ≡ - (option_bind _ _ (λ x, Some (x, σ)) (Some (Next β'))))%I as "H". - + iApply (f_equivI with "[]"). - { intros k x1 y1 Hxy. - apply option_mbind_ne; solve_proper. } - iPureIntro. rewrite Hx Hb'//. - + unfold mbind. iSimpl in "H". iRewrite "H". done. + - assert ((option_bind _ _ (λ x, Some (x, σ)) (σ !! l)) ≡ + (option_bind _ _ (λ x, Some (x, σ)) (Some (Next β')))) as <-. + { rewrite Hx /= ; solve_proper. } + simpl. iPureIntro. by f_equiv. - iPureIntro. apply ofe_iso_21. - iNext. iIntros "Hlc Hs". iMod ("Hback" with "Hp") as "Hback". @@ -285,8 +281,7 @@ Section wp. WP@{rs} WRITE l β @ s {{ Φ }}. Proof. iIntros (Hee) "#Hcxt H". - unfold READ. simpl. - iApply wp_subreify'. + iApply wp_subreify_ctx_indep'. simpl. iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". iApply (fupd_mask_weaken E1). { set_solver. } @@ -332,7 +327,7 @@ Section wp. WP@{rs} ALLOC α k @ s {{ Φ }}. Proof. iIntros "Hh H". - iApply wp_subreify'. + iApply wp_subreify_ctx_indep'. simpl. iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". iApply (lc_fupd_elim_later with "Hlc"). iModIntro. @@ -360,8 +355,7 @@ Section wp. WP@{rs} DEALLOC l @ s {{ Φ }}. Proof. iIntros (Hee) "#Hcxt H". - unfold DEALLOC. simpl. - iApply wp_subreify'. + iApply wp_subreify_ctx_indep'. simpl. iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". iApply (fupd_mask_weaken E1). { set_solver. } @@ -399,105 +393,6 @@ Section wp. iModIntro. done. Qed. - (** * The logical relation TODO *) - (* Definition N := nroot.@"heh". *) - (* Definition logrel_expr V (α : IT) : iProp := *) - (* (heap_ctx -∗ WP@{rs} α {{ V }})%I. *) - - (* Context `{!SubOfe natO R, !Inhabited R}. *) - - (* Definition logrel_nat (βv : ITV) : iProp := *) - (* (∃ n : nat, βv ≡ RetV n)%I. *) - (* Definition logrel_arr V1 V2 (βv : ITV) : iProp := *) - (* (∃ f, IT_of_V βv ≡ Fun f ∧ □ ∀ αv, V1 αv -∗ *) - (* logrel_expr V2 (APP' (Fun f) (IT_of_V αv)))%I. *) - (* Definition logrel_ref V (l : loc) : iProp := *) - (* (inv (N.@l) (∃ βv, pointsto l (IT_of_V βv) ∗ V βv))%I. *) - - (* Lemma logrel_alloc V V2 (αv :ITV) (k : locO -n> IT) `{!forall v, Persistent (V v)} *) - (* `{NonExpansive V2} : *) - (* V αv -∗ *) - (* (∀ l, logrel_ref V l -∗ logrel_expr V2 (k l)) -∗ *) - (* logrel_expr V2 (ALLOC (IT_of_V αv) k). *) - (* Proof. *) - (* iIntros "#HV H". *) - (* iIntros "#Hh". *) - (* iApply (wp_alloc with "Hh"). *) - (* iNext. iNext. *) - (* iIntros (l) "Hl". *) - (* iMod (inv_alloc (N.@l) _ (∃ βv, pointsto l (IT_of_V βv) ∗ V βv)%I with "[Hl]") *) - (* as "#Hinv". *) - (* { eauto with iFrame. } *) - (* iSpecialize ("H" with "Hinv"). *) - (* by iApply "H". *) - (* Qed. *) - - (* Opaque Ret. (*TODO*) *) - (* Lemma logrel_write V αv l `{!forall v, Persistent (V v)} : *) - (* logrel_ref V l -∗ *) - (* V αv -∗ *) - (* logrel_expr logrel_nat (WRITE l (IT_of_V αv)). *) - (* Proof. *) - (* iIntros "#Hl #Hav #Hctx". *) - (* iApply wp_subreify'. *) - (* iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl1". *) - (* iInv (N.@l) as "HH" "Hcl2". *) - (* iDestruct "HH" as (βv) "[Hbv #HV]". *) - (* iApply (lc_fupd_elim_later with "Hlc"). *) - (* iNext. *) - (* iAssert (⌜is_Some (σ !! l)⌝)%I as "%Hdom". *) - (* { iApply (istate_loc_dom with "Hh Hbv"). } *) - (* iExists σ, (),(<[l:=Next (IT_of_V αv)]>σ),(Ret ()). *) - (* iFrame "Hs". *) - (* iSimpl. repeat iSplit; [ done | done | ]. *) - (* iNext. iIntros "Hlc Hs". *) - (* iMod (istate_write _ _ (IT_of_V αv) with "Hh Hbv") as "[Hh Hlav]". *) - (* iMod ("Hcl2" with "[Hlav]") as "_". *) - (* { iNext. iExists _; by iFrame. } *) - (* iMod ("Hcl1" with "[Hlc Hh Hs]") as "_". *) - (* { iNext. iExists _; by iFrame. } *) - (* iModIntro. *) - (* iApply wp_val. iModIntro. *) - (* iExists (). unfold RetV. done. *) - (* Qed. *) - - (* Lemma logrel_read V l `{!forall v, Persistent (V v)} : *) - (* logrel_ref V l -∗ *) - (* logrel_expr V (READ l). *) - (* Proof. *) - (* iIntros "#Hr #Hctx". *) - (* iApply wp_subreify'. *) - (* iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl1". *) - (* iInv (N.@l) as "HH" "Hcl2". *) - (* iDestruct "HH" as (βv) "[Hbv #HV]". *) - (* iAssert (▷ (σ !! l ≡ Some (Next (IT_of_V βv))))%I as "#Hlookup". *) - (* { iNext. iApply (istate_read with "Hh Hbv"). } *) - (* iAssert (▷ ⌜is_Some (σ !! l)⌝)%I as "#Hdom". *) - (* { iNext. iApply (istate_loc_dom with "Hh Hbv"). } *) - (* iDestruct "Hdom" as ">%Hdom". *) - (* destruct Hdom as [x Hx]. *) - (* destruct (Next_uninj x) as [β' Hb']. *) - (* iAssert (▷ ▷ (β' ≡ IT_of_V βv))%I as "#Hbv'". *) - (* { iNext. rewrite Hx. rewrite option_equivI. *) - (* rewrite Hb'. by iNext. } *) - (* iClear "Hlookup". *) - (* iApply (lc_fupd_elim_later with "Hlc"). *) - (* iNext. iSimpl. *) - (* iExists σ,(Next β'),σ,β'. iFrame "Hs". *) - (* repeat iSplit. *) - (* { iPureIntro. rewrite Hx/= Hb'. done. } *) - (* { rewrite ofe_iso_21//. } *) - (* iNext. iIntros "Hlc Hs". *) - (* iMod ("Hcl2" with "[Hbv]") as "_". *) - (* { iNext. eauto with iFrame. } *) - (* iMod ("Hcl1" with "[Hlc Hh Hs]") as "_". *) - (* { iNext. eauto with iFrame. } *) - (* iModIntro. *) - (* iRewrite "Hbv'". *) - (* iApply wp_val. *) - (* iModIntro. done. *) - (* Qed. *) - End wp. Arguments heapG {_} rs R {_} Σ. diff --git a/theories/affine_lang/lang.v b/theories/examples/affine_lang/lang.v similarity index 64% rename from theories/affine_lang/lang.v rename to theories/examples/affine_lang/lang.v index 3096ec2..6076ca1 100644 --- a/theories/affine_lang/lang.v +++ b/theories/examples/affine_lang/lang.v @@ -1,26 +1,26 @@ From gitrees Require Export lang_generic gitree program_logic. -From gitrees.input_lang Require Import lang interp. -From gitrees.examples Require Import store pairs. +From gitrees.examples.input_lang Require Import lang interp. +From gitrees.effects Require Import store. +From gitrees.lib Require Import pairs. + +Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. (* for namespace sake *) Module io_lang. - Definition state := input_lang.lang.state. + Definition state := io_tape.state. Definition ty := input_lang.lang.ty. Definition expr := input_lang.lang.expr. - Definition tyctx := tyctx ty. - Definition typed {S} := input_lang.lang.typed (S:=S). - Definition interp_closed {sz} (rs : gReifiers sz) `{!subReifier reify_io rs} (e : expr []) {R} `{!Cofe R, !SubOfe natO R} : IT (gReifiers_ops rs) R := - input_lang.interp.interp_expr rs e (). + Definition tyctx {S : Set} := S → ty. + Definition typed {S : Set} := input_lang.lang.typed (S:=S). + Definition interp_closed {sz} (rs : gReifiers NotCtxDep sz) `{!subReifier reify_io rs} (e : expr ∅) {R} `{!Cofe R, !SubOfe natO R} : IT (gReifiers_ops rs) R := + input_lang.interp.interp_expr rs e ı_scope. End io_lang. - Inductive ty := tBool | tInt | tUnit | tArr (τ1 τ2 : ty) | tPair (τ1 τ2 : ty) | tRef (τ : ty). -Local Notation tyctx := (tyctx ty). - Inductive ty_conv : ty → io_lang.ty → Type := | ty_conv_bool : ty_conv tBool Tnat | ty_conv_int : ty_conv tInt Tnat @@ -30,24 +30,24 @@ Inductive ty_conv : ty → io_lang.ty → Type := ty_conv (tArr τ1 τ2) (Tarr (Tarr Tnat t1) t2) . -Inductive expr : scope → Type := -| LitBool (b : bool) {S} : expr S -| LitNat (n : nat) {S} : expr S -| LitUnit {S} : expr S -| Lam {S} : expr (tt::S) → expr S -| Var {S} : var S → expr S -| App {S1 S2} : expr S1 → expr S2 → expr (S1++S2) -| EPair {S1 S2} : expr S1 → expr S2 → expr (S1++S2) -| EDestruct {S1 S2} : expr S1 → expr (()::()::S2) → expr (S1++S2) -| Alloc {S} : expr S → expr S -| Replace {S1 S2} : expr S1 → expr S2 → expr (S1++S2) -| Dealloc {S} : expr S → expr S -| EEmbed {τ1 τ1' S} : io_lang.expr [] → ty_conv τ1 τ1' → expr S +Inductive expr : ∀ (S : Set), Type := +| LitBool {S : Set} (b : bool) : expr S +| LitNat {S : Set} (n : nat) : expr S +| LitUnit {S : Set} : expr S +| Lam {S : Set} : expr (inc S) → expr S +| Var {S : Set} : S → expr S +| App {S1 S2 : Set} : expr S1 → expr S2 → expr (sum S1 S2) +| EPair {S1 S2 : Set} : expr S1 → expr S2 → expr (sum S1 S2) +| EDestruct {S1 S2 : Set} : expr S1 → expr (inc (inc S2)) → expr (sum S1 S2) +| Alloc {S : Set} : expr S → expr S +| Replace {S1 S2 : Set} : expr S1 → expr S2 → expr (sum S1 S2) +| Dealloc {S : Set} : expr S → expr S +| EEmbed {S : Set} {τ1 τ1'} : io_lang.expr ∅ → ty_conv τ1 τ1' → expr S . Section affine. Context {sz : nat}. - Variable rs : gReifiers sz. + Variable rs : gReifiers NotCtxDep sz. Context `{!subReifier reify_store rs}. Context `{!subReifier reify_io rs}. Notation F := (gReifiers_ops rs). @@ -62,9 +62,11 @@ Section affine. λit _, IF (READ ℓ) (Err OtherError) (SEQ (WRITE ℓ (Ret 1)) e). Solve All Obligations with first [solve_proper|solve_proper_please]. + Program Definition thunkedV : IT -n> locO -n> ITV := λne e ℓ, FunV $ Next (λne _, IF (READ ℓ) (Err OtherError) (SEQ (WRITE ℓ (Ret 1)) e)). Solve All Obligations with first [solve_proper|solve_proper_please]. + #[export] Instance thunked_into_val e l : IntoVal (thunked e l) (thunkedV e l). Proof. unfold IntoVal. simpl. f_equiv. f_equiv. intro. done. @@ -73,45 +75,52 @@ Section affine. Program Definition Thunk : IT -n> IT := λne e, ALLOC (Ret 0) (thunked e). Solve All Obligations with first [solve_proper|solve_proper_please]. + Program Definition Force : IT -n> IT := λne e, e ⊙ (Ret 0). Local Open Scope type. Definition interp_litbool {A} (b : bool) : A -n> IT := λne _, - Ret (if b then 1 else 0). + Ret (if b then 1 else 0). + Definition interp_litnat {A} (n : nat) : A -n> IT := λne _, - Ret n. + Ret n. + Definition interp_litunit {A} : A -n> IT := λne _, Ret tt. + Program Definition interp_pair {A1 A2} (t1 : A1 -n> IT) (t2 : A2 -n> IT) - : A1*A2 -n> IT := λne env, + : A1 * A2 -n> IT := λne env, pairIT (t1 env.1) (t2 env.2). (* we don't need to evaluate the pair here, i.e. lazy pairs? *) Next Obligation. solve_proper_please. Qed. - Program Definition interp_lam {A : ofe} (b : (IT * A) -n> IT) : A -n> IT := λne env, - λit x, b (x,env). - Solve All Obligations with solve_proper_please. + + Program Definition interp_lam {S : Set} (b : @interp_scope F R _ (inc S) -n> IT) : @interp_scope F R _ S -n> IT := λne env, (λit x, (b (@extend_scope F R _ _ env x))). + Next Obligation. + intros; repeat intro; repeat f_equiv; assumption. + Qed. + Next Obligation. + intros; repeat intro; repeat f_equiv; intro; simpl; + f_equiv; intro z; simpl. + destruct z; done. + Qed. + Program Definition interp_app {A1 A2 : ofe} (t1 : A1 -n> IT) (t2 : A2 -n> IT) : A1*A2 -n> IT := λne env, LET (t2 env.2) $ λne x, LET (t1 env.1) $ λne f, APP' f (Thunk x). Solve All Obligations with solve_proper_please. - Program Definition interp_destruct {A1 A2 : ofe} - (ps : A1 -n> IT) (t : IT*(IT*A2) -n> IT) - : A1*A2 -n> IT := λne env, - LET (ps env.1) $ λne ps, - LET (Thunk (projIT1 ps)) $ λne x, - LET (Thunk (projIT2 ps)) $ λne y, - t (x, (y, env.2)). - Solve All Obligations with solve_proper_please. + Program Definition interp_alloc {A} (α : A -n> IT) : A -n> IT := λne env, LET (α env) $ λne α, ALLOC α Ret. Solve All Obligations with solve_proper_please. + Program Definition interp_replace {A1 A2} (α : A1 -n> IT) (β : A2 -n> IT) : A1*A2 -n> IT := λne env, LET (β env.2) $ λne β, flip get_ret (α env.1) $ λne (l : loc), LET (READ l) $ λne γ, SEQ (WRITE l β) (pairIT γ (Ret l)). Solve All Obligations with solve_proper_please. + Program Definition interp_dealloc {A} (α : A -n> IT) : A -n> IT := λne env, get_ret DEALLOC (α env). Solve All Obligations with solve_proper_please. @@ -152,6 +161,35 @@ Section affine. | ty_conv_fun conv1 conv2 => glue_from_affine_fun (glue_from_affine conv2) (glue_to_affine conv1) end. + Program Definition interp_destruct {S1 S2 : Set} + (ps : @interp_scope F R _ S1 -n> IT) + (t : (@interp_scope F R _ (inc (inc S2)) -n> IT)) + : (@interp_scope F R _ S1 * @interp_scope F R _ S2) -n> IT + := λne env, + LET (ps env.1) $ λne z, + LET (Thunk (projIT1 z)) $ λne x, + LET (Thunk (projIT2 z)) $ λne y, + (t (@extend_scope F R _ _ (@extend_scope F R _ _ env.2 y) x)). + Next Obligation. + intros; repeat intro; repeat f_equiv; assumption. + Qed. + Next Obligation. + intros; repeat intro; repeat f_equiv; intro; simpl; f_equiv; intro A; simpl. + destruct A as [| [|]]; [assumption | reflexivity | reflexivity]. + Qed. + Next Obligation. + intros; repeat intro; repeat f_equiv; first assumption. + intro; simpl; f_equiv; intro; simpl. + repeat f_equiv; intro; simpl; repeat f_equiv; intro; simpl. + repeat f_equiv; assumption. + Qed. + Next Obligation. + intros; repeat intro; repeat f_equiv; first assumption. + intro; simpl; f_equiv; intro; simpl. + repeat f_equiv; intro; simpl; repeat f_equiv; intro A; simpl. + destruct A as [| [|]]; [reflexivity | reflexivity |]. + repeat f_equiv; assumption. + Qed. Fixpoint interp_expr {S} (e : expr S) : interp_scope S -n> IT := match e with @@ -160,12 +198,16 @@ Section affine. | LitUnit => interp_litunit | Var v => Force ◎ interp_var v | Lam e => interp_lam (interp_expr e) - | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) ◎ interp_scope_split - | EPair e1 e2 => interp_pair (interp_expr e1) (interp_expr e2) ◎ interp_scope_split - | EDestruct e1 e2 => interp_destruct (interp_expr e1) (interp_expr e2) ◎ interp_scope_split + | App e1 e2 => + interp_app (interp_expr e1) (interp_expr e2) ◎ interp_scope_split + | EPair e1 e2 => + interp_pair (interp_expr e1) (interp_expr e2) ◎ interp_scope_split + | EDestruct e1 e2 => + interp_destruct (interp_expr e1) (interp_expr e2) ◎ interp_scope_split | Alloc e => interp_alloc (interp_expr e) | Dealloc e => interp_dealloc (interp_expr e) - | Replace e1 e2 => interp_replace (interp_expr e1) (interp_expr e2) ◎ interp_scope_split + | Replace e1 e2 => + interp_replace (interp_expr e1) (interp_expr e2) ◎ interp_scope_split | EEmbed e tconv => constO $ glue_to_affine tconv (io_lang.interp_closed _ e) end. diff --git a/theories/affine_lang/logrel1.v b/theories/examples/affine_lang/logrel1.v similarity index 55% rename from theories/affine_lang/logrel1.v rename to theories/examples/affine_lang/logrel1.v index e2ae89c..c5d68af 100644 --- a/theories/affine_lang/logrel1.v +++ b/theories/examples/affine_lang/logrel1.v @@ -1,58 +1,57 @@ (** Unary (Kripke) logical relation for the affine lang *) -From Equations Require Import Equations. -From gitrees Require Export lang_generic gitree program_logic. -From gitrees.affine_lang Require Import lang. -From gitrees.examples Require Import store pairs. +From gitrees Require Export gitree program_logic greifiers. +From gitrees.examples.affine_lang Require Import lang. +From gitrees.effects Require Import io_tape store. +From gitrees.lib Require Import pairs. +From gitrees.utils Require Import finite_sets. -Local Notation tyctx := (tyctx ty). -Inductive typed : forall {S}, tyctx S → expr S → ty → Prop := +Inductive typed : forall {S : Set}, (S → ty) → expr S → ty → Prop := (** functions *) -| typed_Var {S} (Ω : tyctx S) (τ : ty) (v : var S) : - typed_var Ω v τ → - typed Ω (Var v) τ -| typed_Lam {S} (Ω : tyctx S) (τ1 τ2 : ty) (e : expr (()::S) ) : - typed (consC τ1 Ω) e τ2 → +| typed_Var {S : Set} (Ω : S → ty) (v : S) : + typed Ω (Var v) (Ω v) +| typed_Lam {S : Set} (Ω : S → ty) (τ1 τ2 : ty) (e : expr (inc S) ) : + typed (Ω ▹ τ1) e τ2 → typed Ω (Lam e) (tArr τ1 τ2) -| typed_App {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 : ty) e1 e2 : +| typed_App {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 : ty) e1 e2 : typed Ω1 e1 (tArr τ1 τ2) → typed Ω2 e2 τ1 → - typed (tyctx_app Ω1 Ω2) (App e1 e2) τ2 + typed (sum_map' Ω1 Ω2) (App e1 e2) τ2 (** pairs *) -| typed_Pair {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 : ty) e1 e2 : +| typed_Pair {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 : ty) e1 e2 : typed Ω1 e1 τ1 → typed Ω2 e2 τ2 → - typed (tyctx_app Ω1 Ω2) (EPair e1 e2) (tPair τ1 τ2) -| typed_Destruct {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 τ : ty) - (e1 : expr S1) (e2 : expr (()::()::S2)) : + typed (sum_map' Ω1 Ω2) (EPair e1 e2) (tPair τ1 τ2) +| typed_Destruct {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 τ : ty) + (e1 : expr S1) (e2 : expr (inc (inc S2))) : typed Ω1 e1 (tPair τ1 τ2) → - typed (consC τ1 (consC τ2 Ω2)) e2 τ → - typed (tyctx_app Ω1 Ω2) (EDestruct e1 e2) τ + typed ((Ω2 ▹ τ2) ▹ τ1) e2 τ → + typed (sum_map' Ω1 Ω2) (EDestruct e1 e2) τ (** references *) -| typed_Alloc {S} (Ω : tyctx S) τ e : +| typed_Alloc {S : Set} (Ω : S → ty) τ e : typed Ω e τ → typed Ω (Alloc e) (tRef τ) -| typed_Replace {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 : ty) e1 e2 : +| typed_Replace {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 : ty) e1 e2 : typed Ω1 e1 (tRef τ1) → typed Ω2 e2 τ2 → - typed (tyctx_app Ω1 Ω2) (Replace e1 e2) (tPair τ1 (tRef τ2)) -| typed_Dealloc {S} (Ω : tyctx S) e τ : + typed (sum_map' Ω1 Ω2) (Replace e1 e2) (tPair τ1 (tRef τ2)) +| typed_Dealloc {S : Set} (Ω : S → ty) e τ : typed Ω e (tRef τ) → typed Ω (Dealloc e) tUnit (** literals *) -| typed_Nat {S} (Ω : tyctx S) n : +| typed_Nat {S : Set} (Ω : S → ty) n : typed Ω (LitNat n) tInt -| typed_Bool {S} (Ω : tyctx S) b : +| typed_Bool {S : Set} (Ω : S → ty) b : typed Ω (LitBool b) tBool -| typed_Unit {S} (Ω : tyctx S) : +| typed_Unit {S : Set} (Ω : S → ty) : typed Ω LitUnit tUnit . Section logrel. Context {sz : nat}. - Variable rs : gReifiers sz. + Variable rs : gReifiers NotCtxDep sz. Context `{!subReifier reify_store rs}. - Context `{!subReifier input_lang.interp.reify_io rs}. + Context `{!subReifier reify_io rs}. Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. @@ -66,8 +65,7 @@ Section logrel. (* parameters for the kripke logical relation *) Variable s : stuckness. Context `{A:ofe}. - Variable (P : A → iProp). - Context `{!NonExpansive P}. + Variable (P : A -n> iProp). Local Notation expr_pred := (expr_pred s rs P). (* interpreting tys *) @@ -85,14 +83,14 @@ Section logrel. Solve All Obligations with solve_proper_please. Program Definition interp_tpair (Φ1 Φ2 : ITV -n> iProp) : ITV -n> iProp := λne αv, (∃ β1v β2v, IT_of_V αv ≡ pairITV (IT_of_V β1v) (IT_of_V β2v) ∗ - Φ1 β1v ∗ Φ2 β2v)%I. + Φ1 β1v ∗ Φ2 β2v)%I. Solve All Obligations with solve_proper_please. Program Definition interp_tarr (Φ1 Φ2 : ITV -n> iProp) : ITV -n> iProp := λne αv, (∀ βv, Φ1 βv -∗ expr_pred ((IT_of_V αv) ⊙ (Thunk (IT_of_V βv))) Φ2)%I. Solve All Obligations with solve_proper_please. Program Definition interp_ref (Φ : ITV -n> iProp) : ITV -n> iProp := λne αv, - (∃ (l : loc) βv, αv ≡ RetV l ∗ pointsto l (IT_of_V βv) ∗ Φ βv)%I. + (∃ (l : loc), αv ≡ RetV l ∗ ∃ βv, pointsto l (IT_of_V βv) ∗ Φ βv)%I. Solve All Obligations with solve_proper_please. Fixpoint interp_ty (τ : ty) : ITV -n> iProp := @@ -101,28 +99,32 @@ Section logrel. | tUnit => interp_tunit | tInt => interp_tnat | tPair τ1 τ2 => interp_tpair (interp_ty τ1) (interp_ty τ2) - | tArr τ1 τ2 => interp_tarr (interp_ty τ1) (interp_ty τ2) - | tRef τ => interp_ref (interp_ty τ) + | tArr τ1 τ2 => interp_tarr (interp_ty τ1) (interp_ty τ2) + | tRef τ => interp_ref (interp_ty τ) end. - Definition ssubst_valid {S} (Ω : tyctx S) ss := - lang_generic.ssubst_valid rs (λ τ, protected (interp_ty τ)) Ω ss. + Notation ssubst_valid := (ssubst_valid_fin1 rs ty (λ x, protected (interp_ty x)) expr_pred). - Definition valid1 {S} (Ω : tyctx S) (α : interp_scope S -n> IT) (τ : ty) : iProp := - ∀ ss, heap_ctx -∗ ssubst_valid Ω ss -∗ expr_pred (α (interp_ssubst ss)) (interp_ty τ). + Definition valid1 {S : Set} `{!EqDecision S} `{!Finite S} (Ω : S → ty) + (α : interp_scope S -n> IT) (τ : ty) : iProp := + ∀ ss, heap_ctx + -∗ (ssubst_valid Ω ss) + -∗ expr_pred (α ss) (interp_ty τ). - Lemma compat_pair {S1 S2} (Ω1: tyctx S1) (Ω2:tyctx S2) α β τ1 τ2 : + Lemma compat_pair {S1 S2 : Set} + `(!EqDecision S1) `(!Finite S1) + `(!EqDecision S2) `(!Finite S2) + `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} + (Ω1 : S1 → ty) (Ω2 : S2 → ty) α β τ1 τ2 : ⊢ valid1 Ω1 α τ1 -∗ valid1 Ω2 β τ2 -∗ - valid1 (tyctx_app Ω1 Ω2) (interp_pair α β ◎ interp_scope_split) (tPair τ1 τ2). + valid1 (sum_map' Ω1 Ω2) (interp_pair α β ◎ interp_scope_split) (tPair τ1 τ2). Proof. Opaque pairITV. iIntros "H1 H2". iIntros (αs) "#Hctx Has". cbn-[interp_pair]. - unfold ssubst_valid. - rewrite ssubst_valid_app. - rewrite interp_scope_ssubst_split. + rewrite ssubst_valid_fin_app1. iDestruct "Has" as "[Ha1 Ha2]". cbn-[interp_app]. iSpecialize ("H1" with "Hctx Ha1"). iSpecialize ("H2" with "Hctx Ha2"). @@ -133,78 +135,125 @@ Section logrel. iIntros (αv) "Ha". simpl. rewrite -> get_val_ITV. simpl. iApply expr_pred_ret. - iExists _,_. iFrame. done. + simpl. + iExists _,_. + by iFrame. Qed. - Lemma compat_destruct {S1 S2} (Ω1: tyctx S1) (Ω2:tyctx S2) α β τ1 τ2 τ : - ⊢ valid1 Ω1 α (tPair τ1 τ2) -∗ - valid1 (consC τ1 $ consC τ2 Ω2) β τ -∗ - valid1 (tyctx_app Ω1 Ω2) (interp_destruct α β ◎ interp_scope_split) τ. + Lemma compat_destruct {S1 S2 : Set} + `(!EqDecision S1) `(!Finite S1) + `(!EqDecision S2) `(!Finite S2) + `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} + (Ω1 : S1 → ty) (Ω2 : S2 → ty) + α β τ1 τ2 τ : + ⊢ valid1 Ω1 α (tPair τ1 τ2) + -∗ valid1 (Ω2 ▹ τ2 ▹ τ1) β τ + -∗ valid1 (sum_map' Ω1 Ω2) (interp_destruct α β ◎ interp_scope_split) τ. Proof. Opaque pairITV thunked thunkedV projIT1 projIT2. iIntros "H1 H2". iIntros (αs) "#Hctx Has". cbn-[interp_destruct]. - unfold ssubst_valid. - rewrite ssubst_valid_app. - rewrite interp_scope_ssubst_split. + rewrite ssubst_valid_fin_app1. iDestruct "Has" as "[Ha1 Ha2]". iSpecialize ("H1" with "Hctx Ha1"). - simpl. iApply (expr_pred_bind (LETCTX _) with "H1"). + iApply (expr_pred_bind (LETCTX _) with "H1"). iIntros (αv) "Ha". unfold LETCTX. simpl. rewrite LET_Val/=. iDestruct "Ha" as (β1 β2) "[#Ha [Hb1 Hb2]]". iIntros (x) "Hx". iApply wp_let. - { solve_proper. } iApply (wp_Thunk with "Hctx"). - { solve_proper_please. } + { + repeat intro; simpl. + repeat f_equiv. + intro; simpl. + f_equiv. + intro B; simpl. + destruct B as [| [|]]; [by f_equiv | reflexivity | reflexivity]. + } iNext. iIntros (l1) "Hl1". simpl. iApply wp_let. { solve_proper. } iApply (wp_Thunk with "Hctx"). - { solve_proper_please. } + { + repeat intro; simpl. + repeat f_equiv. + intro B; simpl. + destruct B as [| [|]]; [reflexivity | by f_equiv | reflexivity]. + } iNext. iIntros (l2) "Hl2". simpl. - iSpecialize ("H2" $! (cons_ssubst (thunkedV (projIT1 (IT_of_V αv)) l1) - $ cons_ssubst (thunkedV (projIT2 (IT_of_V αv)) l2) (ssubst_split αs).2) - with "Hctx [-Hx] Hx"). - { unfold ssubst_valid. rewrite !ssubst_valid_cons. - iFrame. Transparent thunkedV thunked. - iSplitL "Hb1 Hl1". - - simpl. iApply wp_lam. simpl. iNext. + pose (ss' := (extend_scope + (extend_scope + (interp_scope_split αs).2 + (IT_of_V (thunkedV (projIT2 (IT_of_V αv)) l2))) + (IT_of_V (thunkedV (projIT1 (IT_of_V αv)) l1)))). + iSpecialize ("H2" $! ss' + with "Hctx [-Hx] Hx"). + { + iApply ssubst_valid_fin_cons1. + iSplitR "Hl1 Hb1". + - iApply ssubst_valid_fin_cons1. + iSplitL "Ha2"; first done. + Transparent thunkedV thunked. + simpl. + iIntros (z) "Hz". + simpl. + iApply wp_val. + iModIntro. + iExists z; iFrame. + iApply wp_lam. + iNext. + simpl. iApply (wp_bind _ (IFSCtx _ _)). - iApply (wp_read with "Hctx Hl1"). - iNext. iNext. iIntros "Hl1". - iApply wp_val. iModIntro. unfold IFSCtx. + iApply (wp_read with "Hctx Hl2"). + iNext. iNext. iIntros "Hl2". + iApply wp_val. iModIntro. + unfold IFSCtx. simpl. rewrite IF_False; last lia. iApply wp_seq. { solve_proper. } - iApply (wp_write with "Hctx Hl1"). - iNext. iNext. iIntros "Hl1". + iApply (wp_write with "Hctx Hl2"). + iNext. iNext. iIntros "Hl2". iRewrite "Ha". - rewrite projIT1_pairV. simpl. - repeat iApply wp_tick. - repeat iNext. iApply wp_val. done. - - simpl. iApply wp_lam. simpl. iNext. + simpl. + rewrite projIT2_pairV. + do 3 (iApply wp_tick; iNext). + iApply wp_val. iModIntro. + iApply "Hb2". + - Transparent thunkedV thunked. + simpl. + iIntros (z) "Hz". + simpl. + iApply wp_val. + iModIntro. + iExists z; iFrame. + iApply wp_lam. + iNext. + simpl. iApply (wp_bind _ (IFSCtx _ _)). - iApply (wp_read with "Hctx Hl2"). - iNext. iNext. iIntros "Hl2". - iApply wp_val. iModIntro. unfold IFSCtx. + iApply (wp_read with "Hctx Hl1"). + iNext. iNext. iIntros "Hl1". + iApply wp_val. iModIntro. + unfold IFSCtx. simpl. rewrite IF_False; last lia. iApply wp_seq. { solve_proper. } - iApply (wp_write with "Hctx Hl2"). - iNext. iNext. iIntros "Hl2". + iApply (wp_write with "Hctx Hl1"). + iNext. iNext. iIntros "Hl1". iRewrite "Ha". - rewrite projIT2_pairV. simpl. - repeat iApply wp_tick. - repeat iNext. iApply wp_val. done. + simpl. + rewrite projIT1_pairV. + do 3 (iApply wp_tick; iNext). + iApply wp_val. iModIntro. + iApply "Hb1". } - simp interp_ssubst. iApply "H2". Qed. - Lemma compat_alloc {S} (Ω : tyctx S) α τ: + Lemma compat_alloc {S : Set} + `{!EqDecision S} `{!Finite S} + (Ω : S → ty) α τ: ⊢ valid1 Ω α τ -∗ valid1 Ω (interp_alloc α) (tRef τ). Proof. @@ -218,21 +267,27 @@ Section logrel. iApply (wp_alloc with "Hctx"). iNext. iNext. iIntros (l) "Hl". iApply wp_val. iModIntro. simpl. - eauto with iFrame. + iExists l. + iSplit; first done. + iExists αv. + iFrame "Hl". + iFrame. Qed. - Lemma compat_replace {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) α β τ τ' : + Lemma compat_replace {S1 S2 : Set} + `(!EqDecision S1) `(!Finite S1) + `(!EqDecision S2) `(!Finite S2) + `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} + (Ω1 : S1 → ty) (Ω2 : S2 → ty) α β τ τ' : ⊢ valid1 Ω1 α (tRef τ) -∗ valid1 Ω2 β τ' -∗ - valid1 (tyctx_app Ω1 Ω2) (interp_replace α β ◎ interp_scope_split) (tPair τ (tRef τ')). + valid1 (sum_map' Ω1 Ω2) (interp_replace α β ◎ interp_scope_split) (tPair τ (tRef τ')). Proof. Opaque pairITV. iIntros "H1 H2". iIntros (αs) "#Hctx Has". cbn-[interp_replace]. - unfold ssubst_valid. - rewrite ssubst_valid_app. - rewrite interp_scope_ssubst_split. + rewrite ssubst_valid_fin_app1. iDestruct "Has" as "[Ha1 Ha2]". cbn-[interp_app]. iSpecialize ("H1" with "Hctx Ha1"). iSpecialize ("H2" with "Hctx Ha2"). @@ -241,7 +296,8 @@ Section logrel. rewrite LET_Val/=. iApply (expr_pred_bind with "H1"). iIntros (αv) "Ha". simpl. - iDestruct "Ha" as (l γ) "[Ha [Hl Hg]]". + iDestruct "Ha" as (l) "[Ha Ha']". + iDestruct "Ha'" as (γ) "[Hl Hg]". iApply expr_pred_frame. iRewrite "Ha". simpl. rewrite IT_of_V_Ret. @@ -258,12 +314,14 @@ Section logrel. rewrite get_val_ITV. simpl. rewrite get_val_ITV. simpl. iApply wp_val. iModIntro. - iExists γ,(RetV l). + iExists γ, (RetV l). iSplit; first done. iFrame. eauto with iFrame. Qed. - Lemma compat_dealloc {S} (Ω : tyctx S) α τ: + Lemma compat_dealloc {S : Set} + `{!EqDecision S} `{!Finite S} + (Ω : S → ty) α τ: ⊢ valid1 Ω α (tRef τ) -∗ valid1 Ω (interp_dealloc α) tUnit. Proof. @@ -272,65 +330,86 @@ Section logrel. iSpecialize ("H" with "Hctx Has"). iApply (expr_pred_bind with "H"). iIntros (αv) "Ha /=". - iDestruct "Ha" as (l βv) "[Ha [Hl Hb]]". + iDestruct "Ha" as (l) "[Ha Ha']". + iDestruct "Ha'" as (βv) "[Hl Hb]". iRewrite "Ha". iApply expr_pred_frame. simpl. rewrite IT_of_V_Ret. rewrite -> get_ret_ret. simpl. iApply (wp_dealloc with "Hctx Hl"). iNext. iNext. eauto with iFrame. Qed. - Lemma compat_bool {S} b (Ω : tyctx S) : + Lemma compat_bool {S : Set} + `{!EqDecision S} `{!Finite S} + b (Ω : S → ty) : ⊢ valid1 Ω (interp_litbool b) tBool. Proof. iIntros (αs) "#Hctx Has". iApply expr_pred_ret. destruct b; simpl; eauto. Qed. - Lemma compat_nat {S} n (Ω : tyctx S) : + + Lemma compat_nat {S : Set} + `{!EqDecision S} `{!Finite S} + n (Ω : S → ty) : ⊢ valid1 Ω (interp_litnat n) tInt. Proof. iIntros (αs) "#Hctx Has". iApply expr_pred_ret. eauto with iFrame. Qed. - Lemma compat_unit {S} (Ω : tyctx S) : + + Lemma compat_unit {S : Set} + `{!EqDecision S} `{!Finite S} + (Ω : S → ty) : ⊢ valid1 Ω interp_litunit tUnit. Proof. iIntros (αs) "#Hctx Has". iApply expr_pred_ret. eauto with iFrame. Qed. - Lemma compat_var {S} Ω τ (v : var S) : - typed_var Ω v τ → - ⊢ valid1 Ω (Force ◎ interp_var v) τ. + + Lemma compat_var {S : Set} + `{!EqDecision S} `{!Finite S} + Ω (v : S) : + ⊢ valid1 Ω (Force ◎ interp_var v) (Ω v). Proof. - iIntros (Hv ss) "#Hctx Has". - iApply expr_pred_frame. - unfold ssubst_valid. - iInduction Hv as [|? ? ? Ω v] "IH" forall (ss); simpl. - - dependent elimination ss as [cons_ssubst αv ss]. - rewrite ssubst_valid_cons. - simp interp_var. simpl. - iDestruct "Has" as "[H _]". - simp interp_ssubst. simpl. done. - - dependent elimination ss as [cons_ssubst αv ss]. - rewrite ssubst_valid_cons. - simp interp_var. simpl. - iDestruct "Has" as "[_ H]". - simp interp_ssubst. simpl. - by iApply ("IH" with "H"). + iIntros (ss) "#Hctx Has". + iIntros (x) "Hx". + unfold Force. + simpl. + iApply (wp_bind rs (AppRSCtx (ss v))). + { solve_proper. } + iApply wp_val. + iModIntro. + unfold AppRSCtx. + iApply (wp_bind rs (AppLSCtx (IT_of_V (RetV 0)))). + { solve_proper. } + unfold AppLSCtx. + simpl. + iDestruct (ssubst_valid_fin_lookup1 _ _ _ _ _ _ v with "Has Hx") as "Has". + iApply (wp_wand with "Has"). + iIntros (w) "(%y & Hw1 & Hw2)"; simpl. + iModIntro. + rewrite IT_of_V_Ret. + iApply (wp_wand with "Hw1 [Hw2]"). + iIntros (z) "Hz". + iModIntro. + iExists y. + iFrame. Qed. - Lemma compat_app {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) + Lemma compat_app {S1 S2 : Set} + `(!EqDecision S1) `(!Finite S1) + `(!EqDecision S2) `(!Finite S2) + `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} + (Ω1 : S1 → ty) (Ω2 : S2 → ty) α β τ1 τ2 : ⊢ valid1 Ω1 α (tArr τ1 τ2) -∗ valid1 Ω2 β τ1 -∗ - valid1 (tyctx_app Ω1 Ω2) (interp_app α β ◎ interp_scope_split) τ2. + valid1 (sum_map' Ω1 Ω2) (interp_app α β ◎ interp_scope_split) τ2. Proof. iIntros "H1 H2". iIntros (αs) "#Hctx Has". iEval(cbn-[interp_app]). - unfold ssubst_valid. - rewrite ssubst_valid_app. - rewrite interp_scope_ssubst_split. + rewrite ssubst_valid_fin_app1. iDestruct "Has" as "[Ha1 Ha2]". cbn-[interp_app]. iSpecialize ("H1" with "Hctx Ha1"). iSpecialize ("H2" with "Hctx Ha2"). @@ -345,8 +424,10 @@ Section logrel. by iApply "H1". Qed. - Lemma compat_lam {S} (Ω : tyctx S) τ1 τ2 α : - ⊢ valid1 (consC τ1 Ω) α τ2 -∗ + Lemma compat_lam {S : Set} + `{!EqDecision S} `{!Finite S} + (Ω : S → ty) τ1 τ2 α : + ⊢ valid1 (Ω ▹ τ1) α τ2 -∗ valid1 Ω (interp_lam α) (tArr τ1 τ2). Proof. iIntros "H". @@ -358,7 +439,6 @@ Section logrel. iIntros (βv) "Hb". clear x. iIntros (x) "Hx". iApply (wp_bind _ (AppRSCtx _)). - { solve_proper. } Local Transparent Thunk. Local Opaque thunked thunkedV. iSimpl. iApply (wp_alloc with "Hctx"). @@ -368,12 +448,21 @@ Section logrel. unfold AppRSCtx. iApply wp_lam. iNext. iEval(cbn-[thunked]). - iSpecialize ("H" $! (cons_ssubst (thunkedV (IT_of_V βv) l) αs) + pose (ss' := extend_scope αs (IT_of_V (thunkedV (IT_of_V βv) l))). + iSpecialize ("H" $! ss' with "Hctx [-Hx] Hx"). - { unfold ssubst_valid. - rewrite ssubst_valid_cons. iFrame. + { + iApply ssubst_valid_fin_cons1. + iFrame "Has". Local Transparent thunked thunkedV. - iApply wp_lam. iNext. simpl. + simpl. + iIntros (x') "Hx". + iApply wp_val. + iModIntro. + iExists x'. + iFrame "Hx". + iApply wp_lam. + iNext. iApply (wp_bind _ (IFSCtx _ _)). iApply (wp_read with "Hctx Hl"). iNext. iNext. iIntros "Hl". @@ -385,23 +474,28 @@ Section logrel. iApply (wp_write with "Hctx Hl"). iNext. iNext. iIntros "Hl". iApply wp_val. iModIntro. - iApply "Hb". } - simp interp_ssubst. + iApply "Hb". + } iApply "H". Qed. - Lemma fundamental_affine {S} (Ω : tyctx S) (e : expr S) τ : + Lemma fundamental_affine (S : Set) + (HE : EqDecision S) (HF : Finite S) + (Ω : S → ty) + (e : expr S) τ : typed Ω e τ → ⊢ valid1 Ω (interp_expr _ e) τ. Proof. - induction 1; simpl. + intros H. + iStartProof. + iInduction H as [| | | | | | | | | |] "IH". - by iApply compat_var. - by iApply compat_lam. - - by iApply compat_app. - - by iApply compat_pair. - - by iApply compat_destruct. + - by iApply (compat_app EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (compat_pair EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (compat_destruct EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - by iApply compat_alloc. - - by iApply compat_replace. + - by iApply (compat_replace EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - by iApply compat_dealloc. - by iApply compat_nat. - by iApply compat_bool. @@ -416,25 +510,31 @@ Arguments interp_tnat {_ _ _ _ _ _}. Arguments interp_tunit {_ _ _ _ _ _}. Arguments interp_ty {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} τ. -Local Definition rs : gReifiers 2 := gReifiers_cons reify_store (gReifiers_cons input_lang.interp.reify_io gReifiers_nil). +Arguments compat_app {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. +Arguments compat_pair {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. +Arguments compat_destruct {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. +Arguments compat_replace {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. + +Local Definition rs : gReifiers NotCtxDep 2 := + gReifiers_cons reify_store (gReifiers_cons reify_io gReifiers_nil). Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. Lemma logrel1_adequacy cr Σ R `{!Cofe R, !SubOfe natO R, !SubOfe unitO R, !SubOfe locO R} `{!invGpreS Σ} `{!statePreG rs R Σ} `{!heapPreG rs R Σ} τ - (α : unitO -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k : + (α : interp_scope ∅ -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ} `{H3: !heapG rs R Σ}, - (£ cr ⊢ valid1 rs notStuck (λ _:unitO, True)%I empC α τ)%I) → - ssteps (gReifiers_sReifier rs) (α ()) st β st' k → + (£ cr ⊢ valid1 rs notStuck (λne _: unitO, True)%I □ α τ)%I) → + ssteps (gReifiers_sReifier rs) (α ı_scope) st β st' k → (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) - ∨ (∃ βv, IT_of_V βv ≡ β). + ∨ (∃ βv, (IT_of_V βv ≡ β)%stdpp). Proof. intros Hlog Hst. destruct (IT_to_V β) as [βv|] eqn:Hb. { right. exists βv. apply IT_of_to_V'. rewrite Hb; eauto. } left. cut ((∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) - ∨ (∃ e, β ≡ Err e ∧ notStuck e)). + ∨ (∃ e, (β ≡ Err e)%stdpp ∧ notStuck e)). { intros [?|He]; first done. destruct He as [? [? []]]. } eapply (wp_safety (S cr)); eauto. @@ -451,7 +551,7 @@ Proof. { unfold has_substate, has_full_state. assert (of_state rs (IT (gReifiers_ops rs) _) st ≡ of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state σ) - ⋅ of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state ios)) as ->; last first. + ⋅ of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state ios))%stdpp as ->; last first. { rewrite -own_op. done. } unfold sR_idx. simpl. intro j. @@ -468,8 +568,8 @@ Proof. { iNext. iExists _. iFrame. } simpl. iPoseProof (@Hlog _ _ _ with "Hcr") as "Hlog". - iSpecialize ("Hlog" $! emp_ssubst with "Hinv []"). - { iApply ssubst_valid_nil. } + iSpecialize ("Hlog" $! ı_scope with "Hinv []"). + { iApply ssubst_valid_fin_empty1. } iSpecialize ("Hlog" $! tt with "[//]"). iModIntro. iApply (wp_wand with "Hlog"). @@ -477,16 +577,17 @@ Proof. Qed. Definition R := sumO locO (sumO unitO natO). + Lemma logrel1_safety e τ (β : IT (gReifiers_ops rs) R) st st' k : - typed empC e τ → - ssteps (gReifiers_sReifier rs) (interp_expr rs e ()) st β st' k → + typed □ e τ → + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) st β st' k → (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) - ∨ (∃ βv, IT_of_V βv ≡ β). + ∨ (∃ βv, (IT_of_V βv ≡ β)%stdpp). Proof. intros Hty Hst. pose (Σ:=#[invΣ;stateΣ rs R;heapΣ rs R]). eapply (logrel1_adequacy 0 Σ); eauto; try apply _. iIntros (? ? ?) "_". - by iApply fundamental_affine. + iApply (fundamental_affine rs notStuck (λne _ : unitO, True)%I). + apply Hty. Qed. - diff --git a/theories/affine_lang/logrel2.v b/theories/examples/affine_lang/logrel2.v similarity index 66% rename from theories/affine_lang/logrel2.v rename to theories/examples/affine_lang/logrel2.v index 9370caa..3eaeb0c 100644 --- a/theories/affine_lang/logrel2.v +++ b/theories/examples/affine_lang/logrel2.v @@ -1,62 +1,62 @@ -From Equations Require Import Equations. From iris.base_logic.lib Require Import na_invariants. -From gitrees Require Export lang_generic gitree program_logic. -From gitrees.input_lang Require Import lang interp logpred. -From gitrees.affine_lang Require Import lang logrel1. -From gitrees.examples Require Import store pairs. +From gitrees Require Export gitree program_logic greifiers. +From gitrees.examples.input_lang Require Import lang interp logpred. +From gitrees.examples.affine_lang Require Import lang logrel1. +From gitrees.effects Require Import store. +From gitrees.lib Require Import pairs. +From gitrees.utils Require Import finite_sets. -Local Notation tyctx := (tyctx ty). +Require Import Binding.Lib Binding.Set Binding.Env. -Inductive typed_glued : forall {S}, tyctx S → expr S → ty → Type := +Inductive typed_glued : forall {S : Set}, (S → ty) → expr S → ty → Type := (** FFI *) -| typed_Glue {S} (Ω : tyctx S) τ' τ e +| typed_Glue {S : Set} (Ω : S → ty) τ' τ e (tconv : ty_conv τ τ') : - io_lang.typed empC e τ' → + io_lang.typed □ e τ' → typed_glued Ω (EEmbed e tconv) τ (** functions *) -| typed_VarG {S} (Ω : tyctx S) (τ : ty) (v : var S) : - typed_var Ω v τ → - typed_glued Ω (Var v) τ -| typed_LamG {S} (Ω : tyctx S) (τ1 τ2 : ty) (e : expr (()::S) ) : - typed_glued (consC τ1 Ω) e τ2 → +| typed_VarG {S : Set} (Ω : S → ty) (τ : ty) (v : S) : + typed_glued Ω (Var v) (Ω v) +| typed_LamG {S : Set} (Ω : S → ty) (τ1 τ2 : ty) (e : expr (inc S) ) : + typed_glued (Ω ▹ τ1) e τ2 → typed_glued Ω (Lam e) (tArr τ1 τ2) -| typed_AppG {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 : ty) e1 e2 : +| typed_AppG {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 : ty) e1 e2 : typed_glued Ω1 e1 (tArr τ1 τ2) → typed_glued Ω2 e2 τ1 → - typed_glued (tyctx_app Ω1 Ω2) (App e1 e2) τ2 + typed_glued (sum_map' Ω1 Ω2) (App e1 e2) τ2 (** pairs *) -| typed_PairG {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 : ty) e1 e2 : +| typed_PairG {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 : ty) e1 e2 : typed_glued Ω1 e1 τ1 → typed_glued Ω2 e2 τ2 → - typed_glued (tyctx_app Ω1 Ω2) (EPair e1 e2) (tPair τ1 τ2) -| typed_DestructG {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 τ : ty) - (e1 : expr S1) (e2 : expr (()::()::S2)) : + typed_glued (sum_map' Ω1 Ω2) (EPair e1 e2) (tPair τ1 τ2) +| typed_DestructG {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 τ : ty) + (e1 : expr S1) (e2 : expr (inc (inc S2))) : typed_glued Ω1 e1 (tPair τ1 τ2) → - typed_glued (consC τ1 (consC τ2 Ω2)) e2 τ → - typed_glued (tyctx_app Ω1 Ω2) (EDestruct e1 e2) τ + typed_glued ((Ω2 ▹ τ2) ▹ τ1) e2 τ → + typed_glued (sum_map' Ω1 Ω2) (EDestruct e1 e2) τ (** references *) -| typed_AllocG {S} (Ω : tyctx S) τ e : +| typed_AllocG {S : Set} (Ω : S → ty) τ e : typed_glued Ω e τ → typed_glued Ω (Alloc e) (tRef τ) -| typed_ReplaceG {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 : ty) e1 e2 : +| typed_ReplaceG {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 : ty) e1 e2 : typed_glued Ω1 e1 (tRef τ1) → typed_glued Ω2 e2 τ2 → - typed_glued (tyctx_app Ω1 Ω2) (Replace e1 e2) (tPair τ1 (tRef τ2)) -| typed_DeallocG {S} (Ω : tyctx S) e τ : + typed_glued (sum_map' Ω1 Ω2) (Replace e1 e2) (tPair τ1 (tRef τ2)) +| typed_DeallocG {S : Set} (Ω : S → ty) e τ : typed_glued Ω e (tRef τ) → typed_glued Ω (Dealloc e) tUnit (** literals *) -| typed_NatG {S} (Ω : tyctx S) n : +| typed_NatG {S : Set} (Ω : S → ty) n : typed_glued Ω (LitNat n) tInt -| typed_BoolG {S} (Ω : tyctx S) b : +| typed_BoolG {S : Set} (Ω : S → ty) b : typed_glued Ω (LitBool b) tBool -| typed_UnitG {S} (Ω : tyctx S) : +| typed_UnitG {S : Set} (Ω : S → ty) : typed_glued Ω LitUnit tUnit . Section glue. Context {sz : nat}. - Variable rs : gReifiers sz. + Variable rs : gReifiers NotCtxDep sz. Context `{!subReifier reify_store rs}. Context `{!subReifier reify_io rs}. Notation F := (gReifiers_ops rs). @@ -72,25 +72,27 @@ Section glue. Definition s : stuckness := λ e, e = OtherError. Variable p : na_inv_pool_name. - Definition valid2 {S} (Ω : tyctx S) (α : interp_scope (E:=F) S -n> IT) (τ : ty) : iProp := - valid1 rs s (λ σ, has_substate σ ∗ na_own p ⊤)%I Ω α τ. + Definition valid2 {S : Set} `{HE : EqDecision S} `{!Finite S} (Ω : S → ty) (α : interp_scope (E:=F) S -n> IT) + (τ : ty) : iProp := + valid1 rs s (λne σ, has_substate σ ∗ na_own p ⊤)%I Ω α τ. - Definition io_valid {S} (Γ : io_lang.tyctx S) α (τ' : io_lang.ty) : iProp := - input_lang.logpred.valid1 rs s (λ _ : unitO, na_own p ⊤) Γ α τ'. + Definition io_valid {S : Set} (Γ : S → io_lang.ty) α (τ' : io_lang.ty) + : iProp := + input_lang.logpred.valid1 rs s (λne _ : unitO, na_own p ⊤) Γ α τ'. Local Opaque thunked thunkedV Thunk. - Lemma compat_glue_to_affine_bool {S} (Ω : tyctx S) α : - io_valid empC α Tnat ⊢ - valid2 Ω (constO (glue2_bool _ (α ()))) tBool. + + Lemma compat_glue_to_affine_bool {S : Set} `{HE : EqDecision S} `{!Finite S} (Ω : S → ty) α : + io_valid □ α Tnat ⊢ + valid2 Ω (constO (glue2_bool _ (α ı_scope))) tBool. Proof. iIntros "H". iIntros (ss) "#Hctx Has". simpl. iIntros (σ) "[Hs Hp]". - iSpecialize ("H" $! σ emp_ssubst with "Hs []"). - { unfold logpred.ssubst_valid. - iApply ssubst_valid_nil. } + iSpecialize ("H" $! σ ı_scope with "Hs []"). + { iIntros ([]). } iSpecialize ("H" $! tt with "Hp"). - simp interp_ssubst. simpl. + simpl. iApply (wp_bind _ (IFSCtx _ _)). { solve_proper. } iApply (wp_wand with "H"). @@ -105,61 +107,61 @@ Section glue. * rewrite IF_True ; last lia. iApply wp_val; eauto with iFrame. Qed. - Lemma compat_glue_to_affine_nat {S} (Ω : tyctx S) α : - io_valid empC α Tnat ⊢ - valid2 Ω (constO (α ())) tInt. + + Lemma compat_glue_to_affine_nat {S : Set} `{HE : EqDecision S} `{!Finite S} (Ω : S → ty) α : + io_valid □ α Tnat ⊢ + valid2 Ω (constO (α ı_scope)) tInt. Proof. iIntros "H". iIntros (ss) "#Hctx Has". simpl. iIntros (σ) "[Hs Hp]". - iSpecialize ("H" $! σ emp_ssubst with "Hs []"). - { unfold logpred.ssubst_valid. - iApply ssubst_valid_nil. } + iSpecialize ("H" $! σ ı_scope with "Hs []"). + { iIntros ([]). } iSpecialize ("H" $! tt with "Hp"). - simp interp_ssubst. simpl. + simpl. iApply (wp_wand with "H"). iIntros (αv). iDestruct 1 as (_) "[Ha Hp]". iDestruct "Ha" as (σ') "[Ha Hs]". iModIntro. eauto with iFrame. - Qed. + Lemma compat_glue_from_affine_bool α : - valid2 empC α tBool ⊢ - heap_ctx -∗ io_valid empC α Tnat. + valid2 □ α tBool ⊢ + heap_ctx -∗ io_valid □ α Tnat. Proof. iIntros "H #Hctx". iIntros (σ ss) "Hs Hss". - iIntros (_) "Hp". - iSpecialize ("H" $! emp_ssubst with "Hctx [] [$Hs $Hp]"). - { iApply ssubst_valid_nil. } - dependent elimination ss as [emp_ssubst]. + iIntros (?) "Hp". + iSpecialize ("H" $! ss with "Hctx [] [$Hs $Hp]"). + { iApply ssubst_valid_fin_empty1. } + simpl. iApply (wp_wand with "H"). iIntros (αv) "Ha". iDestruct "Ha" as (σ') "[Ha [Hs Hp]]". iModIntro. simpl. iFrame. iExists tt,_; iFrame. iDestruct "Ha" as "[Ha|Ha]"; iExists _; eauto. Qed. + Lemma compat_glue_from_affine_nat α : - valid2 empC α tInt ⊢ - heap_ctx -∗ io_valid empC α Tnat. + valid2 □ α tInt ⊢ + heap_ctx -∗ io_valid □ α Tnat. Proof. iIntros "H #Hctx". iIntros (σ ss) "Hs Hss". - iIntros (_) "Hp". - iSpecialize ("H" $! emp_ssubst with "Hctx [] [$Hs $Hp]"). - { iApply ssubst_valid_nil. } - dependent elimination ss as [emp_ssubst]. + iIntros (?) "Hp". + iSpecialize ("H" $! ss with "Hctx [] [$Hs $Hp]"). + { iApply ssubst_valid_fin_empty1. } iApply (wp_wand with "H"). iIntros (αv) "Ha". iDestruct "Ha" as (σ') "[Ha [Hs Hp]]". iModIntro. iExists tt. eauto with iFrame. Qed. Lemma compat_glue_from_affine_unit α : - valid2 empC α tUnit ⊢ - heap_ctx -∗ io_valid empC (constO (glue_from_affine _ ty_conv_unit (α ()))) Tnat. + valid2 □ α tUnit ⊢ + heap_ctx -∗ io_valid □ (constO (glue_from_affine _ ty_conv_unit (α ı_scope))) Tnat. Proof. iIntros "H #Hctx". iIntros (σ ss) "Hs Hss". - iIntros (_) "Hp". + iIntros (?) "Hp". simpl. iApply wp_val. iModIntro. iExists tt. iFrame. simpl. eauto with iFrame. @@ -169,21 +171,25 @@ Section glue. Lemma compat_glue_from_affine_fun (τ1 τ2 : ty) (τ1' τ2' : io_lang.ty) α (glue_to_affine glue_from_affine : IT -n> IT) : - (∀ α, io_valid empC α τ1' - ⊢ valid2 empC (constO (glue_to_affine (α ()))) τ1) → - (∀ α, valid2 empC (constO α) τ2 - ⊢ heap_ctx -∗ io_valid empC (constO (glue_from_affine α)) τ2') → - valid2 empC (constO α) (tArr τ1 τ2) + (∀ α, io_valid □ α τ1' + ⊢ valid2 □ (constO (glue_to_affine (α ı_scope))) τ1) → + (∀ α, valid2 □ (constO α) τ2 + ⊢ heap_ctx -∗ io_valid □ (constO (glue_from_affine α)) τ2') → + valid2 □ (constO α) (tArr τ1 τ2) ⊢ heap_ctx -∗ - io_valid empC + io_valid □ (constO (glue_from_affine_fun _ glue_from_affine glue_to_affine α)) (Tarr (Tarr Tnat τ1') τ2'). Proof. intros G1 G2. - iIntros "H #Hctx". iIntros (σ ss) "Hs _ _ Hp". - simpl. clear ss. - iSpecialize ("H" $! emp_ssubst with "Hctx [] [$Hs $Hp]"). - { iApply ssubst_valid_nil. } + iIntros "H #Hctx". + unfold io_valid. + unfold logpred.valid1. + iIntros (σ ss) "Hs ?". + simpl. + iIntros (?) "Hp". + iSpecialize ("H" $! ss with "Hctx [] [$Hs $Hp]"). + { iApply ssubst_valid_fin_empty1. } simpl. iApply wp_let. { solve_proper. } iApply (wp_wand with "H"). @@ -204,7 +210,7 @@ Section glue. iModIntro. simpl. iApply wp_val. iModIntro. iExists tt. iFrame. iExists σ'. iFrame. iModIntro. clear σ σ'. iIntros (σ βv) "Hs #Hb". - iIntros (_) "Hp". + iIntros (?) "Hp". iApply wp_lam. iNext. simpl. iApply wp_let. { solve_proper. } @@ -244,7 +250,7 @@ Section glue. { eauto with iFrame. } iSpecialize ("Hb" $! tt with "Hp"). iApply (wp_wand with "Hb"). - iIntros (γv). iDestruct 1 as (_) "[Hg Hp]". + iIntros (γv). iDestruct 1 as (?) "[Hg Hp]". iDestruct "Hg" as (σ') "[Hg Hst]". iModIntro. simpl. iApply wp_let. @@ -253,8 +259,8 @@ Section glue. iSpecialize ("G1" with "[Hg]"). { iIntros (σ0 ss0) "Hs Has". simpl. iApply expr_pred_ret. simpl. eauto with iFrame. } - iSpecialize ("G1" $! emp_ssubst with "Hctx [] [$Hst $Hp]"). - { iApply ssubst_valid_nil. } + iSpecialize ("G1" $! ss with "Hctx [] [$Hst $Hp]"). + { iApply ssubst_valid_fin_empty1. } iApply (wp_wand with "G1"). clear βv σ'. iIntros (βv). iDestruct 1 as (σ') "[Hb [Hst Hp]]". @@ -270,30 +276,32 @@ Section glue. iSpecialize ("G1" with "[Hg] Hctx"). { iIntros (ss0) "_ _". by iApply expr_pred_ret. } - iSpecialize ("G1" $! _ emp_ssubst with "Hst []"). - { iApply ssubst_valid_nil. } + iSpecialize ("G1" $! _ ı_scope with "Hst []"). + { + iIntros ([]). + } iApply ("G1" $! tt with "Hp"). Qed. - Lemma compat_glue_to_affine_fun {S} (Ω : tyctx S) (τ1 τ2 : ty) + Lemma compat_glue_to_affine_fun {S : Set} `{HE : EqDecision S} `{!Finite S} (Ω : S → ty) (τ1 τ2 : ty) (τ1' τ2' : io_lang.ty) α (glue_to_affine glue_from_affine : IT -n> IT) : - (∀ α, io_valid empC α τ2' - ⊢ valid2 Ω (constO (glue_to_affine (α ()))) τ2) → - (∀ α, valid2 empC (constO α) τ1 - ⊢ heap_ctx -∗ io_valid empC (constO (glue_from_affine α)) τ1') → - io_valid empC α (Tarr (Tarr Tnat τ1') τ2') + (∀ α, io_valid □ α τ2' + ⊢ valid2 Ω (constO (glue_to_affine (α ı_scope))) τ2) → + (∀ α, valid2 □ (constO α) τ1 + ⊢ heap_ctx -∗ io_valid □ (constO (glue_from_affine α)) τ1') → + io_valid □ α (Tarr (Tarr Tnat τ1') τ2') ⊢ valid2 Ω - (constO (glue_to_affine_fun _ glue_from_affine glue_to_affine (α ()))) + (constO (glue_to_affine_fun _ glue_from_affine glue_to_affine (α ı_scope))) (tArr τ1 τ2). Proof. intros G1 G2. iIntros "H". iIntros (αs) "#Hctx Has". iIntros (σ) "[Hs Hp]". simpl. - iSpecialize ("H" $! _ emp_ssubst with "Hs []"). - { iApply ssubst_valid_nil. } + iSpecialize ("H" $! _ ı_scope with "Hs []"). + { iIntros ([]). } iSpecialize ("H" $! tt with "Hp"). - simp interp_ssubst. simpl. + simpl. iApply wp_let. { solve_proper. } iApply (wp_wand with "H"). @@ -307,7 +315,6 @@ Section glue. iSimpl. clear σ σ'. iIntros (σ) "[Hs Hp]". iApply (wp_bind _ (AppRSCtx _)). - { solve_proper. } iApply (wp_Thunk with "Hctx"). { solve_proper. } iNext. iIntros (l) "Hl". @@ -340,12 +347,14 @@ Section glue. iIntros (σ0) "Hs". simpl. iApply wp_val. eauto with iFrame. } iSpecialize ("G2" with "Hctx"). - iSpecialize ("G2" $! _ emp_ssubst with "Hs []"). - { iApply ssubst_valid_nil. } + iSpecialize ("G2" $! _ ı_scope with "Hs []"). + { + iIntros ([]). + } iSpecialize ("G2" $! tt with "Hp"). iApply (wp_wand with "G2"). iIntros (β'v). - iDestruct 1 as (_) "[Hb Hp]". iModIntro. + iDestruct 1 as (?) "[Hb Hp]". iModIntro. simpl. clear σ. iDestruct "Hb" as (σ) "[#Hb Hs]". (* calling the original function *) iApply wp_let. @@ -364,7 +373,7 @@ Section glue. iPoseProof ("Ha" $! _ (thunkedV (IT_of_V β'v) l') with "Hs [-Has Hp]") as "H1". { iModIntro. iIntros (σ' βn) "Hs Hbm". iDestruct "Hbm" as (m) "Hbm". - iIntros (_) "Hp". + iIntros (?) "Hp". iApply wp_lam. iNext. iSimpl. iApply (wp_bind _ (IFSCtx _ _)). { solve_proper. } @@ -396,7 +405,7 @@ Section glue. iModIntro. iSpecialize ("H1" $! tt with "Hp"). iApply (wp_wand with "H1"). - iIntros (γv). iDestruct 1 as (_) "[H2 Hp]". + iIntros (γv). iDestruct 1 as (?) "[H2 Hp]". iModIntro. simpl. iDestruct "H2" as (σ') "[#H2 Hs]". iPoseProof (G1 (constO (IT_of_V γv))) as "G1". iSpecialize ("G1" with "[H2]"). @@ -408,12 +417,12 @@ Section glue. simpl. done. Qed. - Lemma glue_to_affine_compatibility {S} (Ω : tyctx S) (τ1 : ty) (τ1' : io_lang.ty) + Lemma glue_to_affine_compatibility {S : Set} `{HE : EqDecision S} `{!Finite S} (Ω : S → ty) (τ1 : ty) (τ1' : io_lang.ty) (Hconv : ty_conv τ1 τ1') α : - io_valid empC α τ1' ⊢ valid2 Ω (constO (glue_to_affine _ Hconv (α ()))) τ1 + io_valid □ α τ1' ⊢ valid2 Ω (constO (glue_to_affine _ Hconv (α ı_scope))) τ1 with glue_from_affine_compatibility (τ1 : ty) (τ1' : io_lang.ty) (Hconv : ty_conv τ1 τ1') (α : IT) : - valid2 empC (constO α) τ1 ⊢ heap_ctx -∗ io_valid empC (constO (glue_from_affine _ Hconv α)) τ1'. + valid2 □ (constO α) τ1 ⊢ heap_ctx -∗ io_valid □ (constO (glue_from_affine _ Hconv α)) τ1'. Proof. - destruct Hconv. + by iApply compat_glue_to_affine_bool. @@ -421,7 +430,7 @@ Section glue. + iIntros "_". simpl. iApply compat_unit. + simpl. iApply compat_glue_to_affine_fun. - * apply glue_to_affine_compatibility. + * by apply glue_to_affine_compatibility. * apply glue_from_affine_compatibility. - destruct Hconv. + iApply compat_glue_from_affine_bool. @@ -432,20 +441,22 @@ Section glue. * apply glue_from_affine_compatibility. Qed. - Lemma fundamental_affine_glued {S} (Ω : tyctx S) (e : expr S) τ : + Lemma fundamental_affine_glued {S : Set} `{HE : EqDecision S} `{!Finite S} (Ω : S → ty) (e : expr S) τ : typed_glued Ω e τ → ⊢ valid2 Ω (interp_expr _ e) τ. Proof. - intros typed. induction typed; simpl. + intros typed. + iStartProof. + iInduction typed as [| | | | | | | | | | |] "IH". - iApply glue_to_affine_compatibility. by iApply fundamental. - by iApply compat_var. - by iApply compat_lam. - - by iApply compat_app. - - by iApply compat_pair. - - by iApply compat_destruct. + - by iApply (compat_app EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (compat_pair EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (compat_destruct EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - by iApply compat_alloc. - - by iApply compat_replace. + - by iApply (compat_replace EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - by iApply compat_dealloc. - by iApply compat_nat. - by iApply compat_bool. @@ -454,27 +465,30 @@ Section glue. End glue. -Local Definition rs : gReifiers 2 := gReifiers_cons reify_store (gReifiers_cons input_lang.interp.reify_io gReifiers_nil). +Local Definition rs : gReifiers NotCtxDep 2 + := gReifiers_cons reify_store + (gReifiers_cons reify_io gReifiers_nil). Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. -Lemma logrel2_adequacy cr R `{!Cofe R, !SubOfe locO R, !SubOfe natO R, !SubOfe unitO R} Σ `{!invGpreS Σ}`{!statePreG rs R Σ} `{!heapPreG rs R Σ} `{!na_invG Σ} - τ (α : unitO -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k : +Lemma logrel2_adequacy (cr : nat) R `{!Cofe R, !SubOfe locO R, !SubOfe natO R, !SubOfe unitO R} + Σ `{!invGpreS Σ}`{!statePreG rs R Σ} `{!heapPreG rs R Σ} `{!na_invG Σ} + (τ : ty) (α : interp_scope Empty_set -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ} `{H3: !heapG rs R Σ} p, - (£ cr ⊢ valid2 rs p empC α τ)%I) → - ssteps (gReifiers_sReifier rs) (α ()) st β st' k → + (£ cr ⊢ valid2 rs p □ α τ)%I) → + ssteps (gReifiers_sReifier rs) (α ı_scope) st β st' k → (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) - ∨ (β ≡ Err OtherError) - ∨ (∃ βv, IT_of_V βv ≡ β). + ∨ (β ≡ Err OtherError)%stdpp + ∨ (∃ βv, (IT_of_V βv ≡ β)%stdpp). Proof. intros Hlog Hst. destruct (IT_to_V β) as [βv|] eqn:Hb. { right. right. exists βv. apply IT_of_to_V'. rewrite Hb; eauto. } cut ((∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) - ∨ (∃ e, β ≡ Err e ∧ s e)). + ∨ (∃ e, (β ≡ Err e)%stdpp ∧ s e)). { intros [?|He]; first eauto. right. left. destruct He as [? [? ->]]. done. } - eapply (wp_safety (S cr) _ _ rs s); eauto. + eapply (wp_safety (S cr) _ _ NotCtxDep rs s); eauto. { apply Hdisj. } { by rewrite Hb. } intros H1 H2. @@ -488,7 +502,7 @@ Proof. { unfold has_substate, has_full_state. assert (of_state rs (IT (gReifiers_ops rs) _) st ≡ of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state σ) - ⋅ of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state ios)) as ->; last first. + ⋅ of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state ios))%stdpp as ->; last first. { rewrite -own_op. done. } unfold sR_idx. simpl. intro j. @@ -506,11 +520,11 @@ Proof. simpl. iMod na_alloc as (p) "Hp". iPoseProof (@Hlog _ _ _ p with "Hcr") as "Hlog". - iSpecialize ("Hlog" $! emp_ssubst with "Hinv []"). - { iApply ssubst_valid_nil. } + iSpecialize ("Hlog" $! ı_scope with "Hinv []"). + { iApply ssubst_valid_fin_empty1. } unfold expr_pred. simpl. iSpecialize ("Hlog" $! ios with "[$Hio $Hp]"). - iModIntro. simp interp_ssubst. + iModIntro. simpl. iApply (wp_wand with "Hlog"). eauto with iFrame. Qed. @@ -518,11 +532,11 @@ Qed. Definition R := sumO locO (sumO natO unitO). Lemma logrel2_safety e τ (β : IT (gReifiers_ops rs) R) st st' k : - typed_glued empC e τ → - ssteps (gReifiers_sReifier rs) (interp_expr rs e ()) st β st' k → + typed_glued □ e τ → + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) st β st' k → (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) - ∨ (β ≡ Err OtherError) - ∨ (∃ βv, IT_of_V βv ≡ β). + ∨ (β ≡ Err OtherError)%stdpp + ∨ (∃ βv, (IT_of_V βv ≡ β)%stdpp). Proof. intros Hty Hst. pose (Σ:=#[invΣ;stateΣ rs R;heapΣ rs R;na_invΣ]). @@ -530,5 +544,3 @@ Proof. iIntros (? ? ? ?) "_". by iApply fundamental_affine_glued. Qed. - - diff --git a/theories/examples/delim_lang/example.v b/theories/examples/delim_lang/example.v new file mode 100644 index 0000000..60d32fc --- /dev/null +++ b/theories/examples/delim_lang/example.v @@ -0,0 +1,109 @@ +From gitrees Require Import gitree lang_generic. +From gitrees.examples.delim_lang Require Import lang interp. +From iris.proofmode Require Import base classes tactics environments. +From iris.base_logic Require Import algebra. + +Open Scope syn_scope. + +Example p : expr Empty_set := + ((#1) + (reset ((#3) + (shift/cc ((($0) @k #5) + (($0) @k #6)))))). + +Local Definition rs : gReifiers _ _ := gReifiers_cons reify_delim gReifiers_nil. +(* Local Definition Hrs : subReifier reify_delim rs. *) +(* Proof. unfold rs. apply subReifier_here. Qed. *) + +Notation F := (gReifiers_ops rs). +Context {R} `{!Cofe R}. +Context `{!SubOfe natO R, !SubOfe unitO R}. +Notation IT := (IT F R). +Notation ITV := (ITV F R). +Context (env : @interp_scope F R _ Empty_set). + +Example ts := interp_config rs (Cexpr p) env. +Definition t := fst ts. +Definition σ := snd ts. + + +Context `{!invGS Σ, !stateG rs R Σ, !heapG rs R Σ}. +Notation iProp := (iProp Σ). + + +Ltac shift_hom := + match goal with + | |- envs_entails _ (wp _ (ofe_mor_car _ _ (λne x, ?k1 x) (?k2 ?t)) _ _ _) => + assert ((ofe_mor_car _ _ (λne x, k1 x) (k2 t)) ≡ (λne x, k1 (k2 x)) t) as -> by done + | |- envs_entails _ (wp _ (?k ?t) _ _ _) => + assert (k t ≡ (λne x, k x) t) as -> by done + end. + +Ltac shift_natop_l := + match goal with + | |- envs_entails _ (wp _ (ofe_mor_car _ _ (λne x, ?k1 x) + (ofe_mor_car _ _ + (ofe_mor_car _ _ + (NATOP (do_natop lang.Add)) ?t) (IT_of_V ?e))) _ _ _) => + assert ((ofe_mor_car _ _ (λne x, k1 x) (NATOP (do_natop lang.Add) t (IT_of_V e))) ≡ + (λne x, k1 (NATOP (do_natop lang.Add) x (IT_of_V e))) t) as -> by done + end. + +Lemma wp_t (s : gitree.weakestpre.stuckness) : + has_substate σ -∗ + WP@{rs} t @ s {{βv, βv ≡ RetV 18}}. +Proof. + Opaque SHIFT APP_CONT. + iIntros "Hσ". + cbn. + (* first, reset *) + do 2 shift_hom. + iApply (wp_reset with "Hσ"). + iIntros "!> _ Hσ". simpl. + + (* then, shift *) + do 2 shift_hom. + iApply (wp_shift with "Hσ"). + { rewrite laterO_map_Next. done. } + iIntros "!>_ Hσ". + simpl. + + (* the rest *) + rewrite -(IT_of_V_Ret 6) get_val_ITV'. simpl. + rewrite get_fun_fun. simpl. + do 2 shift_hom. + iApply (wp_app_cont with "Hσ"); first done. + iIntros "!> _ Hσ". simpl. + rewrite later_map_Next -Tick_eq. + iApply wp_tick. iNext. + shift_hom. + rewrite IT_of_V_Ret NATOP_Ret. simpl. + rewrite -(IT_of_V_Ret 9). + iApply (wp_pop_cons with "Hσ"). + iIntros "!> _ Hσ". + simpl. + + shift_hom. shift_natop_l. + rewrite -(IT_of_V_Ret 5) get_val_ITV'. simpl. + shift_hom. shift_natop_l. + rewrite get_fun_fun. simpl. + shift_hom. shift_natop_l. + iApply (wp_app_cont with "Hσ"); first done. + iIntros "!> _ Hσ". simpl. + rewrite later_map_Next -Tick_eq. + iApply wp_tick. iNext. + rewrite (IT_of_V_Ret 5) NATOP_Ret. simpl. + rewrite -(IT_of_V_Ret 8). + iApply (wp_pop_cons with "Hσ"). + iIntros "!> _ Hσ". + simpl. + shift_hom. + shift_natop_l. + rewrite (IT_of_V_Ret 8). + simpl. rewrite IT_of_V_Ret NATOP_Ret. + simpl. rewrite -(IT_of_V_Ret 17). + iApply (wp_pop_cons with "Hσ"). + iIntros "!> _ Hσ". simpl. + rewrite IT_of_V_Ret NATOP_Ret. + simpl. rewrite -(IT_of_V_Ret 18). + iApply (wp_pop_end with "Hσ"). + iIntros "!> _ _". + iApply wp_val. done. +Qed. diff --git a/theories/examples/delim_lang/interp.v b/theories/examples/delim_lang/interp.v new file mode 100644 index 0000000..5578614 --- /dev/null +++ b/theories/examples/delim_lang/interp.v @@ -0,0 +1,1075 @@ +(* From Equations Require Import Equations. *) +From gitrees Require Import gitree lang_generic. +From gitrees.examples.delim_lang Require Import lang. +From iris.algebra Require Import list. +From iris.proofmode Require Import classes tactics. +From iris.base_logic Require Import algebra. + +Require Import Binding.Lib Binding.Set. + + +(** * State, corresponding to a meta-continuation *) +Definition stateF : oFunctor := (listOF (▶ ∙ -n> ▶ ∙))%OF. + +#[local] Instance state_inhabited : Inhabited (stateF ♯ unitO). +Proof. apply _. Qed. + +#[local] Instance state_cofe X `{!Cofe X} : Cofe (stateF ♯ X). +Proof. apply _. Qed. + +(* We store a list of meta continuations in the state. *) + + +(** * Signatures *) + +Program Definition shiftE : opInterp := + {| + Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙); + Outs := (▶ ∙); + |}. + +Program Definition resetE : opInterp := + {| + Ins := (▶ ∙); + Outs := (▶ ∙); + |}. + +(* to apply the head of the meta continuation *) +Program Definition popE : opInterp := + {| + Ins := (▶ ∙); + Outs := Empty_setO; + |}. + +(* apply continuation, pushes outer context in meta *) +Program Definition appContE : opInterp := + {| + Ins := (▶ ∙ * (▶ (∙ -n> ∙))); + Outs := ▶ ∙; + |} . + +Definition delimE := @[shiftE; resetE; popE;appContE]. + + + +Notation op_shift := (inl ()). +Notation op_reset := (inr (inl ())). +Notation op_pop := (inr (inr (inl ()))). +Notation op_app_cont := (inr (inr (inr (inl ())))). + + + +Section reifiers. + + Context {X} `{!Cofe X}. + Notation state := (stateF ♯ X). + + + Definition reify_shift : ((laterO X -n> laterO X) -n> laterO X) * + state * (laterO X -n> laterO X) → + option (laterO X * state) := + λ '(f, σ, k), Some ((f k): laterO X, σ : state). + #[export] Instance reify_shift_ne : + NonExpansive (reify_shift : + prodO (prodO ((laterO X -n> laterO X) -n> laterO X) state) + (laterO X -n> laterO X) → + optionO (prodO (laterO X) state)). + Proof. intros ?[[]][[]][[]]. simpl in *. repeat f_equiv; auto. Qed. + + Definition reify_reset : (laterO X) * state * (laterO X -n> laterO X) → + option (laterO X * state) := + λ '(e, σ, k), Some (e, (k :: σ)). + #[export] Instance reify_reset_ne : + NonExpansive (reify_reset : + prodO (prodO (laterO X) state) (laterO X -n> laterO X) → + optionO (prodO (laterO X) state)). + Proof. intros ?[[]][[]][[]]. simpl in *. by repeat f_equiv. Qed. + + + Definition reify_pop : (laterO X) * state * (Empty_setO -n> laterO X) → + option (laterO X * state) := + λ '(e, σ, _), + match σ with + | [] => Some (e, σ) + | k' :: σ' => Some (k' e, σ') + end. + #[export] Instance reify_pop_ne : + NonExpansive (reify_pop : + prodO (prodO (laterO X) state) (Empty_setO -n> laterO X) → + optionO (prodO (laterO X) state)). + Proof. intros ?[[]][[]][[]]. simpl in *. by repeat f_equiv. Qed. + + + Definition reify_app_cont : ((laterO X * (laterO (X -n> X))) * state * (laterO X -n> laterO X)) → + option (laterO X * state) := + λ '((e, k'), σ, k), + Some (((laterO_ap k' : laterO X -n> laterO X) e : laterO X), k::σ : state). + #[export] Instance reify_app_cont_ne : + NonExpansive (reify_app_cont : + prodO (prodO (prodO (laterO X) (laterO (X -n> X))) state) + (laterO X -n> laterO X) → + optionO (prodO (laterO X) (state))). + Proof. + intros ?[[[]]][[[]]]?. rewrite /reify_app_cont. + repeat f_equiv; apply H. + Qed. + +End reifiers. + +Canonical Structure reify_delim : sReifier CtxDep. +Proof. + simple refine {| + sReifier_ops := delimE; + sReifier_state := stateF + |}. + intros X HX op. + destruct op as [ | [ | [ | [| []]]]]; simpl. + - simple refine (OfeMor (reify_shift)). + - simple refine (OfeMor (reify_reset)). + - simple refine (OfeMor (reify_pop)). + - simple refine (OfeMor (reify_app_cont)). +Defined. + + + +Section constructors. + Context {E : opsInterp} {A} `{!Cofe A}. + Context {subEff0 : subEff delimE E}. + Context {subOfe0 : SubOfe natO A}. + Context {subOfe1 : SubOfe unitO A}. + Notation IT := (IT E A). + Notation ITV := (ITV E A). + + + + (** ** POP *) + + Program Definition POP : IT -n> IT := + λne e, Vis (E:=E) (subEff_opid op_pop) + (subEff_ins (F:=delimE) (op:=op_pop) (Next e)) + (Empty_setO_rec _ ◎ (subEff_outs (F:=delimE) (op:=op_pop))^-1). + Solve All Obligations with solve_proper. + + Notation 𝒫 := (get_val POP). + + (** ** RESET *) + + Program Definition RESET_ : (laterO IT -n> laterO IT) -n> + laterO IT -n> + IT := + λne k e, Vis (E:=E) (subEff_opid op_reset) + (subEff_ins (F := delimE) (op := op_reset) (laterO_map 𝒫 e)) + (k ◎ subEff_outs (F := delimE) (op := op_reset)^-1). + Solve Obligations with solve_proper. + + Program Definition RESET : laterO IT -n> IT := + RESET_ idfun. + + (** ** SHIFT *) + + Program Definition SHIFT_ : ((laterO IT -n> laterO IT) -n> laterO IT) -n> + (laterO IT -n> laterO IT) -n> + IT := + λne f k, Vis (E:=E) (subEff_opid op_shift) + (subEff_ins (F:=delimE) (op:=op_shift) ((laterO_map $ 𝒫) ◎ f)) + (k ◎ (subEff_outs (F:=delimE) (op:=op_shift))^-1). + Solve All Obligations with solve_proper. + + Program Definition SHIFT : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := + λne f, SHIFT_ f (idfun). + Solve Obligations with solve_proper. + + Lemma hom_SHIFT_ k e f `{!IT_hom f} : + f (SHIFT_ e k) ≡ SHIFT_ e (laterO_map (OfeMor f) ◎ k). + Proof. + unfold SHIFT_. + rewrite hom_vis/=. + f_equiv. by intro. + Qed. + + + (** ** APP_CONT *) + + Program Definition APP_CONT_ : laterO IT -n> (laterO (IT -n> IT)) -n> + (laterO IT -n> laterO IT) -n> + IT := + λne e k k', Vis (E := E) (subEff_opid op_app_cont) + (subEff_ins (F:=delimE) (op:=op_app_cont) (e, k)) + (k' ◎ (subEff_outs (F:=delimE) (op:=op_app_cont))^-1). + Solve All Obligations with solve_proper. + + Program Definition APP_CONT : laterO IT -n> (laterO (IT -n> IT)) -n> + IT := + λne e k, APP_CONT_ e k idfun. + Solve All Obligations with solve_proper. + +End constructors. + +Notation 𝒫 := (get_val POP). + +Section weakestpre. + Context {sz : nat}. + Variable (rs : gReifiers CtxDep sz). + Context {subR : subReifier reify_delim rs}. + Notation F := (gReifiers_ops rs). + Context {R} `{!Cofe R}. + Context `{!SubOfe natO R}. + Context `{!SubOfe unitO R}. + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Notation state := (stateF ♯ IT). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + (** * The symbolic execution rules *) + + (** ** SHIFT *) + + Lemma wp_shift (σ : state) (f : (laterO IT -n> laterO IT) -n> laterO IT) + (k : IT -n> IT) β {Hk : IT_hom k} Φ s : + laterO_map 𝒫 (f (laterO_map k)) ≡ Next β → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} β @ s {{ Φ }}) -∗ + WP@{rs} (k (SHIFT f)) @ s {{ Φ }}. + Proof. + iIntros (Hp) "Hs Ha". + unfold SHIFT. simpl. + rewrite hom_vis. + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (laterO_map 𝒫 $ f (laterO_map k)) with "Hs"). + { + simpl. do 2 f_equiv; last done. do 2 f_equiv. + rewrite ccompose_id_l. intro. simpl. by rewrite ofe_iso_21. + } + { exact Hp. } + iModIntro. + iApply "Ha". + Qed. + + Lemma wp_reset (σ : state) (e : IT) (k : IT -n> IT) {Hk : IT_hom k} + Φ s : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate ((laterO_map k) :: σ) -∗ + WP@{rs} 𝒫 e @ s {{ Φ }}) -∗ + WP@{rs} k $ (RESET (Next e)) @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". + unfold RESET. simpl. rewrite hom_vis. + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (Next $ 𝒫 e) with "Hs"). + - simpl. repeat f_equiv. rewrite ccompose_id_l. + trans ((laterO_map k) :: σ); last reflexivity. + f_equiv. intro. simpl. by rewrite ofe_iso_21. + - reflexivity. + - iApply "Ha". + Qed. + + (** XXX: Formulate the rules using AsVal *) + Lemma wp_pop_end (v : ITV) + Φ s : + has_substate [] -∗ + ▷ (£ 1 -∗ has_substate [] -∗ WP@{rs} IT_of_V v @ s {{ Φ }}) -∗ + WP@{rs} 𝒫 (IT_of_V v) @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". + rewrite get_val_ITV. simpl. + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ ((Next $ IT_of_V v)) with "Hs"). + - simpl. reflexivity. + - reflexivity. + - done. + Qed. + + Lemma wp_pop_cons (σ : state) (v : ITV) (k : IT -n> IT) + Φ s : + has_substate ((laterO_map k) :: σ) -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k $ IT_of_V v @ s {{ Φ }}) -∗ + WP@{rs} 𝒫 (IT_of_V v) @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". + rewrite get_val_ITV. simpl. + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ ((laterO_map k (Next $ IT_of_V v))) with "Hs"). + - simpl. reflexivity. + - reflexivity. + - done. + Qed. + + Lemma wp_app_cont (σ : state) (e : laterO IT) (k' : laterO (IT -n> IT)) + (k : IT -n> IT) β {Hk : IT_hom k} + Φ s : + laterO_ap k' e ≡ Next β → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate ((laterO_map k) :: σ) -∗ + WP@{rs} β @ s {{ Φ }}) -∗ + WP@{rs} k (APP_CONT e k') @ s {{ Φ }}. + Proof. + iIntros (Hb) "Hs Ha". + unfold APP_CONT. simpl. rewrite hom_vis. + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (Next β) with "Hs"). + - cbn-[laterO_ap]. rewrite Hb. do 2 f_equiv. + trans (laterO_map k :: σ); last reflexivity. + rewrite ccompose_id_l. f_equiv. intro. simpl. by rewrite ofe_iso_21. + - reflexivity. + - iApply "Ha". + Qed. + +End weakestpre. + +Section interp. + Context {sz : nat}. + Variable (rs : gReifiers CtxDep sz). + Context {subR : subReifier reify_delim rs}. + Context {R} `{CR : !Cofe R}. + Context `{!SubOfe natO R}. + Context `{!SubOfe unitO R}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Notation state := (stateF ♯ IT). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Global Instance denot_cont_ne (κ : IT -n> IT) : + NonExpansive (λ x : IT, Tau (laterO_map κ (Next x))). + Proof. + solve_proper. + Qed. + + (** * Interpreting individual operators *) + + (** ** RESET *) + + Program Definition interp_reset {S} (e : S -n> IT) : S -n> IT := + λne env, RESET (Next $ e env). + Solve All Obligations with solve_proper. + + (** ** SHIFT *) + + Program Definition interp_shift {S} (e : @interp_scope F R _ (inc S) -n> IT) : + interp_scope S -n> IT := + λne env, SHIFT (λne (k : laterO IT -n> laterO IT), + Next (e (extend_scope env (λit x, Tau (k (Next x)))))). + Next Obligation. solve_proper. Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros [| a]; simpl; last solve_proper. + repeat f_equiv. solve_proper. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + intros [| a]; simpl; last solve_proper. + repeat f_equiv. + Qed. + + + (** ** NATOP *) + Program Definition interp_natop {A} (op : nat_op) (t1 t2 : A -n> IT) : A -n> IT := + λne env, NATOP (do_natop op) (t1 env) (t2 env). + Solve All Obligations with solve_proper_please. + + Global Instance interp_natop_ne A op : NonExpansive2 (@interp_natop A op). + Proof. solve_proper. Qed. + Typeclasses Opaque interp_natop. + + + (** ** REC *) + Opaque laterO_map. + Program Definition interp_rec_pre {S : Set} (body : interp_scope (inc (inc S)) -n> IT) + : laterO (interp_scope S -n> IT) -n> interp_scope S -n> IT := + λne self env, Fun $ laterO_map (λne (self : interp_scope S -n> IT) (a : IT), + body (extend_scope (extend_scope env (self env)) a)) self. + Next Obligation. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + solve_proper_prepare. + do 3 f_equiv; intros ??; simpl; f_equiv; + intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + solve_proper_prepare. + by do 2 f_equiv. + Qed. + + Program Definition interp_rec {S : Set} + (body : interp_scope (inc (inc S)) -n> IT) : interp_scope S -n> IT := + mmuu (interp_rec_pre body). + + Program Definition ir_unf {S : Set} + (body : interp_scope (inc (inc S)) -n> IT) env : IT -n> IT := + λne a, body (extend_scope + (extend_scope env (interp_rec body env)) a). + Next Obligation. + solve_proper_prepare. + f_equiv. intros [| [| y']]; simpl; solve_proper. + Qed. + + Lemma interp_rec_unfold {S : Set} (body : interp_scope (inc (inc S)) -n> IT) env : + interp_rec body env ≡ Fun $ Next $ ir_unf body env. + Proof. + trans (interp_rec_pre body (Next (interp_rec body)) env). + { f_equiv. rewrite /interp_rec. apply mmuu_unfold. } + simpl. rewrite laterO_map_Next. repeat f_equiv. + simpl. unfold ir_unf. intro. simpl. reflexivity. + Qed. + + + (** ** APP *) + Program Definition interp_app {A} (t1 t2 : A -n> IT) : A -n> IT := + λne env, APP' (t1 env) (t2 env). + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Global Instance interp_app_ne A : NonExpansive2 (@interp_app A). + Proof. solve_proper. Qed. + Typeclasses Opaque interp_app. + + (** ** APP_CONT *) + + Program Definition interp_app_cont {A} (k e : A -n> IT) : A -n> IT := + λne env, get_val (λne x, get_fun + (λne (f : laterO (IT -n> IT)), + APP_CONT (Next x) f) + (k env)) + (e env). + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Global Instance interp_app_cont_ne A : NonExpansive2 (@interp_app_cont A). + Proof. + intros n??????. rewrite /interp_app_cont. intro. simpl. + repeat f_equiv; last done. intro. simpl. by repeat f_equiv. + Qed. + (* Typeclasses Opaque interp_app_cont. *) + + (** ** IF *) + Program Definition interp_if {A} (t0 t1 t2 : A -n> IT) : A -n> IT := + λne env, IF (t0 env) (t1 env) (t2 env). + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Global Instance interp_if_ne A n : + Proper ((dist n) ==> (dist n) ==> (dist n) ==> (dist n)) (@interp_if A). + Proof. solve_proper. Qed. + + (** ** NAT *) + Program Definition interp_nat (n : nat) {A} : A -n> IT := + λne env, Ret n. + + (** ** CONT *) + (** XXX DF: why do we need a tick here? Seems to be necessary for soundness *) + Program Definition interp_cont_val {S} (K : S -n> (IT -n> IT)) : S -n> IT := + λne env, (λit x, Tick $ 𝒫 (K env x)). + Solve All Obligations with solve_proper_please. + + Program Definition interp_ifk {A} (e1 e2 : A -n> IT) (K : A -n> IT -n> IT) : + A -n> (IT -n> IT) := + λne env b, (K env) $ interp_if (λne env, b) e1 e2 env. + Solve All Obligations with solve_proper. + + Program Definition interp_apprk {A} (q : A -n> IT) (K : A -n> IT -n> IT) : + A -n> IT -n> IT := + λne env t, (K env) $ interp_app q (λne env, t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_applk {A} (q : A -n> IT) (K : A -n> IT -n> IT) : + A -n> IT -n> IT := + λne env t, (K env) $ interp_app (λne env, t) q env. + Solve All Obligations with solve_proper. + + Program Definition interp_app_contrk {A} (q : A -n> IT) (K : A -n> IT -n> IT) : + A -n> IT -n> IT := + λne env t, (K env) $ interp_app_cont q (λne env, t) env. + Next Obligation. intros A q K t n ????. done. Qed. + Next Obligation. + intros A q K env n ???. simpl. by repeat f_equiv. + Qed. + Next Obligation. + intros A q K n ???. intro. simpl. f_equiv. + - by f_equiv. + - f_equiv. f_equiv. intro. simpl. by repeat f_equiv. + Qed. + + Program Definition interp_app_contlk {A} (q : A -n> IT) (K : A -n> IT -n> IT) : + A -n> IT -n> IT := + λne env t, (K env) $ interp_app_cont (λne env, t) q env. + Next Obligation. intros A q K t n ????. done. Qed. + Next Obligation. + intros A q K env n ???. simpl. repeat f_equiv. + intro. simpl. by repeat f_equiv. + Qed. + Next Obligation. + intros A q K n ???. intro. simpl. f_equiv. + - by f_equiv. + - f_equiv; last by f_equiv. f_equiv. intro. simpl. repeat f_equiv. + Qed. + + Program Definition interp_natoprk {A} (op : nat_op) (q : A -n> IT) (K : A -n> IT -n> IT) : + A -n> IT -n> IT := + λne env t, (K env) $ interp_natop op q (λne env, t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoplk {A} (op : nat_op) (q : A -n> IT) (K : A -n> IT -n> IT) : + A -n> IT -n> IT := + λne env t, (K env) $ interp_natop op (λne env, t) q env. + Solve All Obligations with solve_proper. + + (** Interpretation for all the syntactic categories: values, expressions, contexts *) + Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := + match v with + | LitV n => interp_nat n + | RecV e => interp_rec (interp_expr e) + | ContV K => interp_cont_val (interp_cont K) + end + with + interp_expr {S} (e : expr S) : interp_scope S -n> IT := + match e with + | Val v => interp_val v + | Var x => interp_var x + | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) + | AppCont e1 e2 => interp_app_cont (interp_expr e1) (interp_expr e2) + | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) + | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) + | Shift e => interp_shift (interp_expr e) + | Reset e => interp_reset (interp_expr e) + end + with + interp_cont {S} (K : cont S) : interp_scope S -n> (IT -n> IT) := + match K with + | END => λne env x, x + | IfK e1 e2 K => interp_ifk (interp_expr e1) (interp_expr e2) (interp_cont K) + | AppLK v K => interp_applk (interp_val v) (interp_cont K) + | AppRK e K => interp_apprk (interp_expr e) (interp_cont K) + | AppContLK v K => interp_app_contlk (interp_val v) (interp_cont K) + | AppContRK e K => interp_app_contrk (interp_expr e) (interp_cont K) + | NatOpLK op v K => interp_natoplk op (interp_val v) (interp_cont K) + | NatOpRK op e K => interp_natoprk op (interp_expr e) (interp_cont K) + end. + + (** ** Interpretation of configurations *) + + Program Definition map_meta_cont {S} (mk : Mcont S) : @interp_scope F R _ S -n> state := + λne env, list_fmap _ _ (λ k, laterO_map (𝒫 ◎ (interp_cont k env))) mk. + Next Obligation. intros S mk n ???. apply list_fmap_ext_ne. intro. by repeat f_equiv. Qed. + + Lemma map_meta_cont_nil {S} env : + map_meta_cont ([] : Mcont S) env = []. + Proof. done. Qed. + + Lemma map_meta_cont_cons {S} (k : cont S) (mk : Mcont S) env : + map_meta_cont (k::mk) env = (laterO_map (𝒫 ◎ interp_cont k env)) :: (map_meta_cont mk env). + Proof. done. Qed. + + Program Definition interp_config {S} (C : config S) : @interp_scope F R _ S -n> (prodO IT state) := + match C with + | Cexpr e => λne env, (𝒫 (interp_expr e env), []) : prodO IT state + | Ceval e K mk => λne env, (𝒫 (interp_cont K env (interp_expr e env)), + map_meta_cont mk env) + | Ccont K v mk => λne env, (𝒫 (interp_cont K env (interp_val v env)), + map_meta_cont mk env) + | Cmcont mk v => λne env, (𝒫 (interp_val v env), + map_meta_cont mk env) + | Cret v => λne env, (interp_val v env, []) + end. + Solve Obligations with try solve_proper. + Next Obligation. + intros S C e K mk <- n???. by repeat f_equiv. + Qed. + Next Obligation. + intros S C v K mk <- n???. by repeat f_equiv. + Qed. + Next Obligation. + intros S C v mk <- n???. by repeat f_equiv. + Qed. + + + Global Instance interp_val_asval {S} {D : interp_scope S} (v : val S) + : AsVal (interp_val v D). + Proof. + destruct v; simpl. + - apply _. + - rewrite interp_rec_unfold. apply _. + - apply _. + Qed. + + Global Instance ArrEquiv {A B : Set} : Equiv (A [→] B) := + fun f g => ∀ x, f x = g x. + + Global Instance ArrDist {A B : Set} `{Dist B} : Dist (A [→] B) := + fun n => fun f g => ∀ x, f x ≡{n}≡ g x. + + Global Instance ren_scope_proper {S S'} : + Proper ((≡) ==> (≡) ==> (≡)) (@ren_scope F _ CR S S'). + Proof. + intros D D' HE s1 s2 Hs. + intros x; simpl. + f_equiv. + - apply Hs. + - apply HE. + Qed. + + Lemma interp_expr_ren {S S'} env + (δ : S [→] S') (e : expr S) : + interp_expr (fmap δ e) env ≡ interp_expr e (ren_scope δ env) + with interp_val_ren {S S'} env + (δ : S [→] S') (e : val S) : + interp_val (fmap δ e) env ≡ interp_val e (ren_scope δ env) + with interp_cont_ren {S S'} env + (δ : S [→] S') (K : cont S) : + interp_cont (fmap δ K) env ≡ interp_cont K (ren_scope δ env). + Proof. + - destruct e; simpl; try by repeat f_equiv. + + f_equiv; last by rewrite interp_expr_ren. + f_equiv. intro. simpl. by f_equiv. + + repeat f_equiv. intro; simpl; repeat f_equiv. + rewrite interp_expr_ren. f_equiv. + intros [|a]; simpl; last done. + by repeat f_equiv. + - destruct e; simpl. + + reflexivity. + + clear -interp_expr_ren. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + do 1 iApply f_equivI. iNext. + iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_ren. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (y'). + destruct y' as [| [| y]]; simpl; first done; last done. + by iRewrite - "IH". + + repeat f_equiv. + intro. simpl. repeat f_equiv. + apply interp_cont_ren. + - destruct K; try solve [simpl; repeat f_equiv; intro; simpl; repeat f_equiv; + (apply interp_expr_ren || apply interp_val_ren || apply interp_cont_ren)]. + + intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. + intro. simpl. by repeat f_equiv. + + intro. simpl. f_equiv; eauto. do 2 f_equiv. + intro. simpl. by repeat f_equiv. + Qed. + + Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : cont S): + interp_expr (fill K e) env ≡ (interp_cont K) env ((interp_expr e) env). + Proof. elim : K e env; eauto. + intros. simpl. rewrite H. f_equiv. simpl. + do 2 f_equiv. intro. simpl. by repeat f_equiv. + Qed. + + Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') + : interp_scope S := λne x, interp_expr (δ x) env. + + Global Instance SubEquiv {A B : Set} : Equiv (A [⇒] B) := fun f g => ∀ x, f x = g x. + + Global Instance sub_scope_proper {S S'} : + Proper ((≡) ==> (≡) ==> (≡)) (@sub_scope S S'). + Proof. + intros D D' HE s1 s2 Hs. + intros x; simpl. + f_equiv. + - f_equiv. + apply HE. + - apply Hs. + Qed. + + Lemma interp_expr_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_expr (bind δ e) env ≡ interp_expr e (sub_scope δ env) + with interp_val_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_val (bind δ e) env ≡ interp_val e (sub_scope δ env) + with interp_cont_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') K : + interp_cont (bind δ K) env ≡ interp_cont K (sub_scope δ env). + Proof. + - destruct e; simpl; try by repeat f_equiv. + + f_equiv; last eauto. f_equiv. intro. simpl. by repeat f_equiv. + + repeat f_equiv. repeat (intro; simpl; repeat f_equiv). + rewrite interp_expr_subst. f_equiv. + intros [|a]; simpl; repeat f_equiv. rewrite interp_expr_ren. + f_equiv. intro. done. + - destruct e; simpl. + + reflexivity. + + clear -interp_expr_subst. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + do 1 iApply f_equivI. iNext. + iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_subst. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (y'). + destruct y' as [| [| y]]; simpl; first done. + * by iRewrite - "IH". + * do 2 rewrite interp_expr_ren. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (z). + done. + + repeat f_equiv. intro. simpl. repeat f_equiv. + by rewrite interp_cont_subst. + - destruct K; try solve [simpl; repeat f_equiv; intro; simpl; repeat f_equiv; + (apply interp_expr_subst || apply interp_val_subst || apply interp_cont_subst)]. + + simpl. intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. intro. simpl. by repeat f_equiv. + + simpl. intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. intro. simpl. by repeat f_equiv. + Qed. + + + + (** ** Interpretation of continuations is a homormophism *) + + #[local] Instance interp_cont_hom_emp {S} env : + IT_hom (interp_cont (END : cont S) env). + Proof. + simple refine (IT_HOM _ _ _ _ _); intros; auto. + simpl. f_equiv. intro. simpl. + by rewrite laterO_map_id. + Qed. + + #[local] Instance interp_cont_hom_if {S} + (K : cont S) (e1 e2 : expr S) env : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (IfK e1 e2 K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite -hom_tick -IF_Tick. + - trans (Vis op i (laterO_map (λne y, + (λne t : IT, interp_cont K env (IF t (interp_expr e1 env) (interp_expr e2 env))) + y) ◎ ko)); + last (simpl; do 3 f_equiv; by intro). + by rewrite -hom_vis. + - trans (interp_cont K env (Err e)); first (f_equiv; apply IF_Err). + apply hom_err. + Qed. + + + #[local] Instance interp_cont_hom_appr {S} (K : cont S) + (e : expr S) env : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (AppRK e K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite !hom_tick. + - rewrite !hom_vis. f_equiv. intro x. simpl. + by rewrite -laterO_map_compose. + - by rewrite !hom_err. + Qed. + + #[local] Instance interp_cont_hom_appl {S} (K : cont S) + (v : val S) (env : interp_scope S) : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (AppLK v K) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -hom_tick. f_equiv. apply APP'_Tick_l. apply interp_val_asval. + - trans (Vis op i (laterO_map (λne y, + (λne t : IT, interp_cont K env (t ⊙ (interp_val v env))) + y) ◎ ko)); + last (simpl; do 3 f_equiv; by intro). + by rewrite -hom_vis. + - trans (interp_cont K env (Err e)); + first (f_equiv; apply APP'_Err_l; apply interp_val_asval). + apply hom_err. + Qed. + + + #[local] Instance interp_cont_hom_app_contr {S} (K : cont S) + (e : expr S) env : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (AppContRK e K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite -!hom_tick. + - rewrite !hom_vis. f_equiv. intro x. simpl. + by rewrite -laterO_map_compose. + - by rewrite !hom_err. + Qed. + + #[local] Instance interp_cont_hom_app_contl {S} (K : cont S) + (v : val S) (env : interp_scope S) : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (AppContLK v K) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -hom_tick. f_equiv. + rewrite get_val_ITV. simpl. rewrite hom_tick. + f_equiv. by rewrite get_val_ITV. + - rewrite get_val_ITV. simpl. rewrite get_fun_vis. rewrite hom_vis. + f_equiv. intro. simpl. rewrite -laterO_map_compose. + f_equiv. f_equiv. intro. simpl. + f_equiv. by rewrite get_val_ITV. + - rewrite get_val_ITV. simpl. rewrite get_fun_err. apply hom_err. + Qed. + + + #[local] Instance interp_cont_hom_natopr {S} (K : cont S) + (e : expr S) op env : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (NatOpRK op e K) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite !hom_tick. + - rewrite !hom_vis. f_equiv. intro x. simpl. + by rewrite -laterO_map_compose. + - by rewrite !hom_err. + Qed. + + #[local] Instance interp_cont_hom_natopl {S} (K : cont S) + (v : val S) op (env : interp_scope S) : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (NatOpLK op v K) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -hom_tick. f_equiv. by rewrite -NATOP_ITV_Tick_l. + - trans (Vis op0 i (laterO_map (λne y, + (λne t : IT, interp_cont K env (NATOP (do_natop op) t (interp_val v env))) y) ◎ ko)); + last (simpl; do 3 f_equiv; by intro). + rewrite NATOP_ITV_Vis_l hom_vis. f_equiv. intro. simpl. + by rewrite -laterO_map_compose. + - trans (interp_cont K env (Err e)). + + f_equiv. by apply NATOP_Err_l, interp_val_asval. + + apply hom_err. + Qed. + + #[global] Instance interp_cont_hom {S} + (K : cont S) env : + IT_hom (interp_cont K env). + Proof. + induction K; simpl; apply _. + Qed. + + (** ** Finally, preservation of reductions *) + Lemma interp_cred_no_reify {S : Set} (env : interp_scope S) (C C' : config S) + (t t' : IT) (σ σ' : state) n : + C ===> C' / (n, 0) -> + (interp_config C env) = (t, σ) -> + (interp_config C' env) = (t', σ') -> + t ≡ Tick_n n $ t'. + Proof. + inversion 1; cbn-[IF APP' Tick get_ret2]; intros Ht Ht'; inversion Ht; inversion Ht'; try done. + - do 4 f_equiv. intro. simpl. by repeat f_equiv. + - rewrite -hom_tick. f_equiv. + erewrite APP_APP'_ITV; last apply _. + trans (interp_cont k env (APP (Fun (Next (ir_unf (interp_expr e) env))) (Next $ interp_val v env))). + { repeat f_equiv. apply interp_rec_unfold. } + rewrite APP_Fun. simpl. rewrite hom_tick. do 2 f_equiv. + simplify_eq. + rewrite !interp_expr_subst. + f_equiv. + intros [| [| x]]; simpl; [| reflexivity | reflexivity]. + rewrite interp_val_ren. + f_equiv. + intros ?; simpl; reflexivity. + - subst. + destruct n0; simpl. + + by rewrite IF_False; last lia. + + by rewrite IF_True; last lia. + - do 2 f_equiv. simplify_eq. + destruct v1,v0; try naive_solver. simpl in *. + rewrite NATOP_Ret. + destruct op; simplify_eq/=; done. + Qed. + + Lemma interp_cred_no_reify_state {S : Set} (env : interp_scope S) (C C' : config S) + (t t' : IT) (σ σ' : state) n : + C ===> C' / (n, 0) -> + (interp_config C env) = (t, σ) -> + (interp_config C' env) = (t', σ') -> + σ = σ'. + Proof. + inversion 1; cbn; intros Ht Ht'; inversion Ht; inversion Ht'; subst; reflexivity. + Qed. + + Opaque map_meta_cont. + Opaque extend_scope. + + Lemma interp_cred_yes_reify {S : Set} (env : interp_scope S) (C C' : config S) + (t t' : IT) (σ σ' : state) (σr : gState_rest sR_idx rs ♯ IT) n : + C ===> C' / (n, 1) -> + (interp_config C env) = (t, σ) -> + (interp_config C' env) = (t', σ') -> + reify (gReifiers_sReifier rs) t (gState_recomp σr (sR_state σ)) + ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ t'). + Proof. + inversion 1; cbn-[IF APP' Tick get_ret2 gState_recomp]; intros Ht Ht'; inversion Ht; inversion Ht'; subst; + try rewrite !map_meta_cont_cons in Ht, Ht'|-*. + - trans (reify (gReifiers_sReifier rs) + (RESET_ (laterO_map (𝒫 ◎ (interp_cont k env))) + (Next (interp_expr e env))) + (gState_recomp σr (sR_state (map_meta_cont mk env)))). + { + repeat f_equiv. rewrite !hom_vis. simpl. f_equiv. + rewrite ccompose_id_l. by intro. + } + rewrite reify_vis_eq_ctx_dep//; last first. + { + epose proof (@subReifier_reify sz CtxDep reify_delim rs _ IT _ (op_reset) + (laterO_map 𝒫 (Next (interp_expr e env))) + _ (laterO_map (𝒫 ◎ interp_cont k env)) (map_meta_cont mk env) + (laterO_map (𝒫 ◎ interp_cont k env) :: map_meta_cont mk env) σr) as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; last done. solve_proper. + } + f_equiv. by rewrite laterO_map_Next. + - remember (map_meta_cont mk env) as σ. + match goal with + | |- context G [Vis ?o ?f ?κ] => set (fin := f); set (op := o); set (kout := κ) + end. + trans (reify (gReifiers_sReifier rs) + (Vis op fin ((laterO_map (𝒫 ◎ interp_cont k env)) ◎ kout)) + (gState_recomp σr (sR_state σ))). + { + repeat f_equiv. rewrite !hom_vis. f_equiv. by intro. + } + rewrite reify_vis_eq_ctx_dep//; last first. + { + epose proof (@subReifier_reify sz CtxDep reify_delim rs _ IT _ (op_shift) + _ _ (laterO_map (𝒫 ◎ interp_cont k env)) + σ σ σr) as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; last first. + - subst kout. by rewrite ccompose_id_l. + - subst fin. reflexivity. + - solve_proper. + } + simpl. + rewrite -Tick_eq. do 3 f_equiv. + rewrite interp_expr_subst. + simpl. f_equiv. + intros [|s]; simpl; eauto. + Transparent extend_scope. + simpl. f_equiv. f_equiv. by intro. + Opaque extend_scope. + - remember (map_meta_cont mk env) as σ. + remember (laterO_map (𝒫 ◎ interp_cont k env)) as kk. + match goal with + | |- context G [ofe_mor_car _ _ (get_fun _) + (ofe_mor_car _ _ Fun ?f)] => set (fin := f) + end. + trans (reify (gReifiers_sReifier rs) + (APP_CONT_ (Next (interp_val v env)) + fin kk) + (gState_recomp σr (sR_state (σ)))). + { + repeat f_equiv. rewrite get_val_ITV. simpl. rewrite get_fun_fun. simpl. + rewrite !hom_vis. f_equiv. subst kk. rewrite ccompose_id_l. intro. simpl. + rewrite laterO_map_compose. done. + } + rewrite reify_vis_eq_ctx_dep//; last first. + { + epose proof (@subReifier_reify sz CtxDep reify_delim rs _ IT _ (op_app_cont) + (Next (interp_val v env), fin) _ kk σ (kk :: σ) σr) + as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; eauto. solve_proper. + } + f_equiv. by rewrite -!Tick_eq. + - remember (map_meta_cont mk env) as σ. + trans (reify (gReifiers_sReifier rs) (POP (interp_val v env)) + (gState_recomp σr (sR_state (laterO_map (𝒫 ◎ interp_cont k env) :: σ)))). + { + do 2 f_equiv; last repeat f_equiv. + apply get_val_ITV. + } + rewrite reify_vis_eq_ctx_dep//; last first. + { + epose proof (@subReifier_reify sz CtxDep reify_delim rs _ IT _ (op_pop) + (Next (interp_val v env)) _ _ + (laterO_map (𝒫 ◎ interp_cont k env) :: σ) σ σr) + as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; last reflexivity. + solve_proper. + } + f_equiv. rewrite laterO_map_Next -Tick_eq. + by f_equiv. + - trans (reify (gReifiers_sReifier rs) (POP (interp_val v env)) + (gState_recomp σr (sR_state []))). + { + do 2 f_equiv; last first. + { f_equiv. by rewrite map_meta_cont_nil. } + apply get_val_ITV. + } + rewrite reify_vis_eq_ctx_dep//; last first. + { + epose proof (@subReifier_reify sz CtxDep reify_delim rs _ IT _ (op_pop) + (Next (interp_val v env)) _ _ + [] [] σr) + as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; last reflexivity. + solve_proper. + } + f_equiv. by rewrite -Tick_eq. + Qed. + + + (** * SOUNDNESS *) + Lemma soundness {S : Set} (env : interp_scope S) (C C' : config S) + (t t' : IT) (σ σ' : state) (σr : gState_rest sR_idx rs ♯ IT) n nm : + steps C C' nm -> + fst nm = n -> + (interp_config C env) = (t, σ) -> + (interp_config C' env) = (t', σ') -> + ssteps (gReifiers_sReifier rs) + t (gState_recomp σr (sR_state σ)) + t' (gState_recomp σr (sR_state σ')) n. + Proof. + intros H. + revert n t t' σ σ'. + induction (H); intros n0 t t' σ σ' Hnm Ht Ht'; subst; simpl. + - rewrite Ht' in Ht. constructor; inversion Ht; done. + - destruct (interp_config c2 env) as [t2 σ2] eqn:Heqc2. + assert ((n', m').1 = n') as Hn' by done. + rewrite <-Heqc2 in IHs. + specialize (IHs s n' t2 t' σ2 σ' Hn' Heqc2 Ht'). + inversion H0; subst; + try solve [specialize (interp_cred_no_reify env _ _ _ _ _ _ _ H0 Ht Heqc2) as Heq; + specialize (interp_cred_no_reify_state env _ _ _ _ _ _ _ H0 Ht Heqc2) as <-; + simpl in Heq|-*; rewrite Heq; eapply IHs]; + try solve + [eapply ssteps_many with t2 (gState_recomp σr (sR_state σ2)); last done; + specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H0 Ht Heqc2) as Heq; + cbn in Ht; eapply sstep_reify; last done; + inversion Ht; rewrite !hom_vis; done]. + + eapply ssteps_many with t2 (gState_recomp σr (sR_state σ2)); last done. + specialize (interp_cred_no_reify env _ _ _ _ _ _ _ H0 Ht Heqc2) as Heq. + specialize (interp_cred_no_reify_state env _ _ _ _ _ _ _ H0 Ht Heqc2) as <-. + simpl in Heq|-*; rewrite Heq. constructor; eauto. + + specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H0 Ht Heqc2) as Heq. + simpl in Heq|-*. + change (2+n') with (1+(1+n')). + eapply ssteps_many; last first. + * eapply ssteps_many with t2 (gState_recomp σr (sR_state σ2)); last done. + eapply sstep_tick; reflexivity. + * eapply sstep_reify; last apply Heq. + cbn in Ht. inversion Ht. + rewrite get_val_ITV. simpl. rewrite get_fun_fun. simpl. + rewrite !hom_vis. done. + + eapply ssteps_many with t2 (gState_recomp σr (sR_state σ2)); last done. + specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H0 Ht Heqc2) as Heq. + cbn in Ht; inversion Ht. subst. rewrite get_val_ITV. simpl. + eapply sstep_reify; simpl in Heq; last first. + * rewrite -Heq. f_equiv. f_equiv. rewrite get_val_ITV. simpl. done. + * f_equiv. reflexivity. + + eapply ssteps_many with t2 (gState_recomp σr (sR_state σ2)); last done. + specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H0 Ht Heqc2) as Heq. + cbn in Ht; inversion Ht. subst. rewrite get_val_ITV. simpl. + eapply sstep_reify; simpl in Heq; last first. + * rewrite -Heq. repeat f_equiv. by rewrite get_val_ITV. + * f_equiv. reflexivity. + Qed. + +End interp. +#[global] Opaque SHIFT_ RESET_ POP APP_CONT_. diff --git a/theories/examples/delim_lang/lang.v b/theories/examples/delim_lang/lang.v new file mode 100644 index 0000000..dbd9688 --- /dev/null +++ b/theories/examples/delim_lang/lang.v @@ -0,0 +1,788 @@ +From gitrees Require Export prelude. + +Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. +(* Require Import FunctionalExtensionality. *) + +Variant nat_op := Add | Sub | Mult. + +Inductive expr {X : Set} := +(* Values *) +| Val (v : val) : expr +| Var (x : X) : expr +(* Base lambda calculus *) +| App (e₁ : expr) (e₂ : expr) : expr +(* special application for continuations *) +| AppCont (e₁ : expr) (e₂ : expr) : expr +(* Base types and their operations *) +| NatOp (op : nat_op) (e₁ : expr) (e₂ : expr) : expr +| If (e₁ : expr) (e₂ : expr) (e₃ : expr) : expr +(* The effects *) +| Shift (e : @expr (inc X)) : expr +| Reset (e : expr) : expr +with val {X : Set} := +| LitV (n : nat) : val +| RecV (e : @expr (inc (inc X))) : val +| ContV (k : cont) : val +with cont {X : Set} := +| END : cont +| IfK (e1 : expr) (e2 : expr) : cont -> cont +| AppLK (v : val) : cont -> cont (* ◻ v *) +| AppRK (e : expr) : cont -> cont (* e ◻ *) +| AppContLK (v : val) : cont -> cont (* ◻ v *) +| AppContRK (e : expr) : cont -> cont (* e ◻ *) +| NatOpLK (op : nat_op) (v : val) : cont -> cont (* ◻ + v *) +| NatOpRK (op : nat_op) (e : expr) : cont -> cont. (* e + ◻ *) + +(* conts are inside-out contexts: eg + IfK e1 e2 (AppLK v ◻) ==> App (if ◻ then e1 else e2) v*) + + +Arguments val X%bind : clear implicits. +Arguments expr X%bind : clear implicits. +Arguments cont X%bind : clear implicits. + +Local Open Scope bind_scope. + +Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := + match e with + | Val v => Val (vmap f v) + | Var x => Var (f x) + | App e₁ e₂ => App (emap f e₁) (emap f e₂) + | AppCont e₁ e₂ => AppCont (emap f e₁) (emap f e₂) + | NatOp o e₁ e₂ => NatOp o (emap f e₁) (emap f e₂) + | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) + | Shift e => Shift (emap (f ↑) e) + | Reset e => Reset (emap f e) + end +with +vmap {A B : Set} (f : A [→] B) (v : val A) : val B := + match v with + | LitV n => LitV n + | RecV e => RecV (emap ((f ↑) ↑) e) + | ContV k => ContV (kmap f k) + end +with kmap {A B : Set} (f : A [→] B) (K : cont A) : cont B := + match K with + | END => END + | IfK e1 e2 k => IfK (emap f e1) (emap f e2) (kmap f k) + | AppLK v k => AppLK (vmap f v) (kmap f k) + | AppRK e k => AppRK (emap f e) (kmap f k) + | AppContLK v k => AppContLK (vmap f v) (kmap f k) + | AppContRK e k => AppContRK (emap f e) (kmap f k) + | NatOpLK op v k => NatOpLK op (vmap f v) (kmap f k) + | NatOpRK op e k => NatOpRK op (emap f e) (kmap f k) + end. + + +#[export] Instance FMap_expr : FunctorCore expr := @emap. +#[export] Instance FMap_val : FunctorCore val := @vmap. +#[export] Instance FMap_cont : FunctorCore cont := @kmap. + +#[export] Instance SPC_expr : SetPureCore expr := @Var. + +Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := + match e with + | Val v => Val (vbind f v) + | Var x => f x + | App e₁ e₂ => App (ebind f e₁) (ebind f e₂) + | AppCont e₁ e₂ => AppCont (ebind f e₁) (ebind f e₂) + | NatOp o e₁ e₂ => NatOp o (ebind f e₁) (ebind f e₂) + | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) + | Shift e => Shift (ebind (f ↑) e) + | Reset e => Reset (ebind f e) + end +with +vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := + match v with + | LitV n => LitV n + | RecV e => RecV (ebind ((f ↑) ↑) e) + | ContV k => ContV (kbind f k) + end +with kbind {A B : Set} (f : A [⇒] B) (K : cont A) : cont B := + match K with + | END => END + | IfK e1 e2 k => IfK (ebind f e1) (ebind f e2) (kbind f k) + | AppLK v k => AppLK (vbind f v) (kbind f k) + | AppRK e k => AppRK (ebind f e) (kbind f k) + | AppContLK v k => AppContLK (vbind f v) (kbind f k) + | AppContRK e k => AppContRK (ebind f e) (kbind f k) + | NatOpLK op v k => NatOpLK op (vbind f v) (kbind f k) + | NatOpRK op e k => NatOpRK op (ebind f e) (kbind f k) + end. + +#[export] Instance BindCore_expr : BindCore expr := @ebind. +#[export] Instance BindCore_val : BindCore val := @vbind. +#[export] Instance BindCore_cont : BindCore cont := @kbind. + +#[export] Instance IP_typ : SetPure expr. +Proof. + split; intros; reflexivity. +Qed. + +Fixpoint vmap_id X (δ : X [→] X) (v : val X) : δ ≡ ı → fmap δ v = v +with emap_id X (δ : X [→] X) (e : expr X) : δ ≡ ı → fmap δ e = e +with kmap_id X (δ : X [→] X) (k : cont X) : δ ≡ ı → fmap δ k = k. +Proof. + - auto_map_id. + - auto_map_id. + - auto_map_id. +Qed. + +Fixpoint vmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (v : val A) : + f ∘ g ≡ h → fmap f (fmap g v) = fmap h v +with emap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : expr A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e +with kmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : cont A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e. +Proof. + - auto_map_comp. + - auto_map_comp. + - auto_map_comp. +Qed. + +#[export] Instance Functor_val : Functor val. +Proof. + split; [exact vmap_id | exact vmap_comp]. +Qed. +#[export] Instance Functor_expr : Functor expr. +Proof. + split; [exact emap_id | exact emap_comp]. +Qed. +#[export] Instance Functor_cont : Functor cont. +Proof. + split; [exact kmap_id | exact kmap_comp]. +Qed. + +Fixpoint vmap_vbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (v : val A) : + f ̂ ≡ g → fmap f v = bind g v +with emap_ebind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : expr A) : + f ̂ ≡ g → fmap f e = bind g e +with kmap_kbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : cont A) : + f ̂ ≡ g → fmap f e = bind g e. +Proof. + - auto_map_bind_pure. + erewrite emap_ebind_pure; [reflexivity |]. + intros [| [| x]]; term_simpl; [reflexivity | reflexivity |]. + rewrite <-(EQ x). + reflexivity. + - auto_map_bind_pure. + - auto_map_bind_pure. +Qed. + +#[export] Instance BindMapPure_val : BindMapPure val. +Proof. + split; intros; now apply vmap_vbind_pure. +Qed. +#[export] Instance BindMapPure_expr : BindMapPure expr. +Proof. + split; intros; now apply emap_ebind_pure. +Qed. +#[export] Instance BindMapPure_cont : BindMapPure cont. +Proof. + split; intros; now apply kmap_kbind_pure. +Qed. + +Fixpoint vmap_vbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (v : val A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ v) = fmap f₁ (bind g₁ v) +with emap_ebind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : expr A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e) +with kmap_kbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : cont A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e). +Proof. + - auto_map_bind_comm. + erewrite emap_ebind_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity | assumption]. + - auto_map_bind_comm. + - auto_map_bind_comm. +Qed. + +#[export] Instance BindMapComm_val : BindMapComm val. +Proof. + split; intros; now apply vmap_vbind_comm. +Qed. +#[export] Instance BindMapComm_expr : BindMapComm expr. +Proof. + split; intros; now apply emap_ebind_comm. +Qed. +#[export] Instance BindMapComm_cont : BindMapComm cont. +Proof. + split; intros; now apply kmap_kbind_comm. +Qed. + +Fixpoint vbind_id (A : Set) (f : A [⇒] A) (v : val A) : + f ≡ ı → bind f v = v +with ebind_id (A : Set) (f : A [⇒] A) (e : expr A) : + f ≡ ı → bind f e = e +with kbind_id (A : Set) (f : A [⇒] A) (e : cont A) : + f ≡ ı → bind f e = e. +Proof. + - auto_bind_id. + rewrite ebind_id; [reflexivity |]. + apply lift_id, lift_id; assumption. + - auto_bind_id. + - auto_bind_id. +Qed. + + +Fixpoint vbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (v : val A) : + f ∘ g ≡ h → bind f (bind g v) = bind h v +with ebind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : expr A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e +with kbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : cont A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e. +Proof. + - auto_bind_comp. + erewrite ebind_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity | assumption]. + - auto_bind_comp. + - auto_bind_comp. +Qed. + + +#[export] Instance Bind_val : Bind val. +Proof. + split; intros; [now apply vbind_id | now apply vbind_comp]. +Qed. +#[export] Instance Bind_expr : Bind expr. +Proof. + split; intros; [now apply ebind_id | now apply ebind_comp]. +Qed. +#[export] Instance Bind_cont : Bind cont. +Proof. + split; intros; [now apply kbind_id | now apply kbind_comp]. +Qed. + + +Definition to_val {S} (e : expr S) : option (val S) := + match e with + | Val v => Some v + | _ => None + end. + +Definition do_natop (op : nat_op) (x y : nat) : nat := + match op with + | Add => plus x y + | Sub => minus x y + | Mult => mult x y + end. + +Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := + match x, y with + | LitV x, LitV y => Some $ LitV $ do_natop n x y + | _,_ => None + end. + +Fixpoint fill {X : Set} (K : cont X) (e : expr X) : expr X := + match K with + | IfK e1 e2 K => fill K (If e e1 e2) + | END => e + | AppLK v K => fill K (App e (Val v)) + | AppRK el K => fill K (App el e) + | AppContLK v K => fill K (AppCont e (Val v)) + | AppContRK el K => fill K (AppCont el e) + | NatOpLK op v K => fill K (NatOp op e (Val v)) + | NatOpRK op el K => fill K (NatOp op el e) + end. + + +(*** Continuation operations *) + + +Global Instance fill_inj {S} (Ki : cont S) : Inj (=) (=) (fill Ki). +Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. + +Lemma fill_val {S} Ki (e : expr S) : + is_Some (to_val (fill Ki e)) → is_Some (to_val e). +Proof. + elim: Ki e; simpl in *; intros; first done; + apply H in H0; simpl in H0; contradiction (is_Some_None H0). +Qed. + +(* K1 ∘ K2 *) +Fixpoint cont_compose {S} (K1 K2 : cont S) : cont S := + match K2 with + | END => K1 + | IfK e1 e2 K => IfK e1 e2 (cont_compose K1 K) + | AppLK v K => AppLK v (cont_compose K1 K) + | AppRK e K => AppRK e (cont_compose K1 K) + | AppContLK v K => AppContLK v (cont_compose K1 K) + | AppContRK e K => AppContRK e (cont_compose K1 K) + | NatOpLK op v K => NatOpLK op v (cont_compose K1 K) + | NatOpRK op e K => NatOpRK op e (cont_compose K1 K) + end. + +Lemma fill_comp {S} (K1 K2 : cont S) e : fill (cont_compose K1 K2) e = fill K1 (fill K2 e). +Proof. + elim: K2 K1 e =>>; eauto; + intros H K1 e; simpl; by rewrite H. +Qed. + + +Lemma fill_not_val : ∀ {S} K (e : expr S), to_val e = None → to_val (fill K e) = None. +Proof. + intros S K e. rewrite !eq_None_not_Some. + eauto using fill_val. +Qed. + + +(*** Abstract Machine semantics *) + +Definition Mcont {S} := list $ cont S. + +Variant config {S} : Type := + | Ceval : expr S -> cont S -> @Mcont S -> config + | Ccont : cont S -> val S -> @Mcont S -> config + | Cmcont : @Mcont S -> val S -> config + | Cexpr : expr S -> config + | Cret : val S -> config. + +Reserved Notation "c '===>' c' / nm" + (at level 40, c', nm at level 30). + +Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := + + (* init *) + | Ceval_init : forall (e : expr S), + Cexpr e ===> Ceval e END [] / (0,0) + + (* eval *) + | Ceval_val : forall v k mk, + Ceval (Val v) k mk ===> Ccont k v mk / (0,0) + + | Ceval_app : forall e0 e1 k mk, + Ceval (App e0 e1) k mk ===> Ceval e1 (AppRK e0 k) mk / (0,0) + + | Ceval_app_cont : forall e0 e1 k mk, + Ceval (AppCont e0 e1) k mk ===> Ceval e1 (AppContRK e0 k) mk / (0,0) + + | Ceval_natop : forall op e0 e1 k mk, + Ceval (NatOp op e0 e1) k mk ===> Ceval e1 (NatOpRK op e0 k) mk / (0,0) + + | Ceval_if : forall eb et ef k mk, + Ceval (If eb et ef) k mk ===> Ceval eb (IfK et ef k) mk / (0,0) + + | Ceval_reset : forall e k mk, + Ceval (Reset e) k mk ===> Ceval e END (k :: mk) / (1, 1) + + | Ceval_shift : forall (e : expr $ inc S) k mk, + Ceval (Shift e) k mk ===> + Ceval (subst (Inc := inc) e (Val $ ContV k)) + END mk / (1, 1) + + (* cont *) + | Ccont_end : forall v mk, + Ccont END v mk ===> Cmcont mk v / (0,0) + + | Ccont_appr : forall e v k mk, + Ccont (AppRK e k) v mk ===> Ceval e (AppLK v k) mk / (0, 0) + + | Ccont_app_contr : forall e v k mk, + Ccont (AppContRK e k) v mk ===> Ceval e (AppContLK v k) mk / (0, 0) + + | Ccont_appl : forall e v k mk, + Ccont (AppLK v k) (RecV e) mk ===> + Ceval (subst (Inc := inc) + (subst (F := expr) (Inc := inc) e + (Val (shift (Inc := inc) v))) + (Val (RecV e))) k mk / (1, 0) + + | Ccont_cont : forall v k k' mk, + Ccont (AppContLK v k) (ContV k') mk ===> + Ccont k' v (k :: mk) / (2, 1) + + | Ccont_if : forall et ef n k mk, + Ccont (IfK et ef k) (LitV n) mk ===> + Ceval (if (n =? 0) then ef else et) k mk / (0, 0) + + | Ccont_natopr : forall op e v k mk, + Ccont (NatOpRK op e k) v mk ===> + Ceval e (NatOpLK op v k) mk / (0, 0) + + | Ccont_natopl : forall op v0 v1 v2 k mk, + nat_op_interp op v0 v1 = Some v2 -> + Ccont (NatOpLK op v1 k) v0 mk ===> + Ceval (Val v2) k mk / (0,0) + + (* meta-cont *) + | Cmcont_cont : forall k mk v, + Cmcont (k :: mk) v ===> Ccont k v mk / (1,1) + + | Cmcont_ret : forall v, + Cmcont [] v ===> Cret v / (1, 1) + +where "c ===> c' / nm" := (Cred c c' nm). + +Arguments Mcont S%bind : clear implicits. +Arguments config S%bind : clear implicits. + +Inductive steps {S} : config S -> config S -> (nat * nat) -> Prop := +| steps_zero : forall c, + steps c c (0,0) +| steps_many : forall c1 c2 c3 n m n' m', + c1 ===> c2 / (n,m) -> + steps c2 c3 (n',m') -> + steps c1 c3 (n+n',m+m'). + +Definition meta_fill {S} (mk : Mcont S) e := + fold_left (λ e k, fill k e) mk e. + +(*** Type system *) +(* Type system from [Filinski, Danvy 89] : A Functional Abstraction of Typed Contexts *) + +Coercion Val : val >-> expr. + +Inductive ty := +| Tnat : ty +| Tarr : ty -> ty -> ty -> ty -> ty +| TarrCont : ty -> ty -> ty -> ty -> ty. + + +(* Notation "'T' τ '/' α '->' σ '/' β" := (Tarr τ α σ β) (at level 99, only parsing). *) +(* Notation "τ '/' α '→k' σ '/' β" := (TarrCont τ α σ β) (at level 60). *) + +(* Reserved Notation " Γ , α ⊢ e : τ , β" *) +(* (at level 90, e at next level, τ at level 20, no associativity). *) + +(* Inductive typed {S : Set} (Γ : S -> ty) : ty -> expr S -> ty -> ty -> Prop := *) + +(* | typed_Lit α n : *) +(* Γ, α ⊢ (LitV n) : Tnat, α *) + +(* | typed_Rec (δ σ τ α β : ty) (e : expr (inc (inc S))) : *) +(* (Γ ▹ (Tarr σ α τ β) ▹ σ) , α ⊢ e : τ , β -> *) +(* Γ,δ ⊢ (RecV e) : (Tarr σ α τ β) , δ *) + +(* | typed_Cont (δ σ τ α : ty) (k : cont S) : *) +(* typed_cont Γ α k (TarrCont σ α τ α) α -> *) +(* Γ,δ ⊢ (ContV k) : (TarrCont σ α τ α) , δ *) + +(* with typed_cont {S : Set} (Γ : S -> ty) : ty -> cont S -> ty -> ty -> Prop := *) + +(* | typed_END τ α δ : *) +(* typed_cont Γ δ END (TarrCont τ α τ α) δ *) + +(* | typed_IfK τ τ' α ε e1 e2 : *) +(* Γ, α ⊢ e1 : τ, α -> *) +(* Γ, α ⊢ e2 : τ, α -> *) +(* typed_cont Γ α K *) +(* typed_cont Γ α (IfK e1 e2 K) (TarrCont Tnat ε τ' ε) α *) + +(* where "Γ , α ⊢ e : τ , β" := (typed Γ α e τ β). *) + +(* | typed_Val (τ : ty) (v : val S) : *) +(* typed_val Γ v τ → *) +(* typed Γ (Val v) τ *) +(* | typed_Var (τ : ty) (v : S) : *) +(* Γ v = τ → *) +(* typed Γ (Var v) τ *) +(* | typed_App (τ1 τ2 : ty) e1 e2 : *) +(* typed Γ e1 (Tarr τ1 τ2) → *) +(* typed Γ e2 τ1 → *) +(* typed Γ (App e1 e2) τ2 *) +(* | typed_NatOp e1 e2 op : *) +(* typed Γ e1 Tnat → *) +(* typed Γ e2 Tnat → *) +(* typed Γ (NatOp op e1 e2) Tnat *) +(* | typed_If e0 e1 e2 τ : *) +(* typed Γ e0 Tnat → *) +(* typed Γ e1 τ → *) +(* typed Γ e2 τ → *) +(* typed Γ (If e0 e1 e2) τ *) +(* | typed_Shift (e : expr (inc S)) τ : *) +(* typed (Γ ▹ Tcont τ) e τ -> *) +(* typed Γ (Shift e) τ *) +(* | typed_App_Cont (τ τ' : ty) e1 e2 : *) +(* typed Γ e1 (Tcont τ) -> *) +(* typed Γ e2 τ -> *) +(* typed Γ (App e1 e2) τ' *) +(* | type_Reset e τ : *) +(* typed Γ e τ -> *) +(* typed Γ (Reset e) τ *) +(* (* CHECK *) *) +(* with typed_val {S : Set} (Γ : S -> ty) : ty -> val S -> ty -> ty -> Prop := *) +(* | typed_Lit n : *) +(* typed_val Γ (LitV n) Tnat *) +(* | typed_RecV (τ1 τ2 : ty) (e : expr (inc (inc S))) : *) +(* typed (Γ ▹ (Tarr τ1 τ2) ▹ σ) e τ2 → *) +(* typed_val Γ (RecV e) (Tarr τ1 τ2) *) +(* . *) + +(*** Notations *) + +Declare Scope syn_scope. +Delimit Scope syn_scope with syn. + + +Coercion App : expr >-> Funclass. +(* Coercion AppLK : expr >-> Funclass. *) +(* Coercion AppRK : expr >-> Funclass. *) + +Class AsSynExpr (F : Set -> Type) := { __asSynExpr : ∀ S, F S -> expr S }. + +Arguments __asSynExpr {_} {_} {_}. + +Global Instance AsSynExprValue : AsSynExpr val := { + __asSynExpr _ v := Val v + }. +Global Instance AsSynExprExpr : AsSynExpr expr := { + __asSynExpr _ e := e + }. + +Class OpNotation (A B C D : Type) := { __op : A -> B -> C -> D }. + +Global Instance OpNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : OpNotation (F S) nat_op (G S) (expr S) := { + __op e₁ op e₂ := NatOp op (__asSynExpr e₁) (__asSynExpr e₂) + }. + +Global Instance OpNotationLK {S : Set} : OpNotation (cont S) (nat_op) (val S) (cont S) := { + __op K op v := cont_compose K (NatOpLK op v END) + }. + +Global Instance OpNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : OpNotation (F S) (nat_op) (cont S) (cont S) := { + __op e op K := cont_compose K (NatOpRK op (__asSynExpr e) END) + }. + +Class IfNotation (A B C D : Type) := { __if : A -> B -> C -> D }. + +Global Instance IfNotationExpr {S : Set} {F G H : Set -> Type} `{AsSynExpr F, AsSynExpr G, AsSynExpr H} : IfNotation (F S) (G S) (H S) (expr S) := { + __if e₁ e₂ e₃ := If (__asSynExpr e₁) (__asSynExpr e₂) (__asSynExpr e₃) + }. + +Global Instance IfNotationK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : + IfNotation (cont S) (F S) (G S) (cont S) := { + __if K e₂ e₃ := cont_compose K (IfK (__asSynExpr e₂) (__asSynExpr e₃) END) + }. + + +(* Class OutputNotation (A B : Type) := { __output : A -> B }. *) + +(* Global Instance OutputNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : OutputNotation (F S) (expr S) := { *) +(* __output e := Output (__asSynExpr e) *) +(* }. *) + +(* Global Instance OutputNotationK {S : Set} : OutputNotation (cont S) (cont S) := { *) +(* __output K := cont_compose K (OutputK END) *) +(* }. *) + +Class ResetNotation (A B : Type) := { __reset : A -> B }. + +Global Instance ResetNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : + ResetNotation (F S) (expr S) := { __reset e := Reset (__asSynExpr e) }. + +(* Global Instance ResetNotationK {S : Set} : ResetNotation (cont S) (cont S) := *) +(* { __reset K := cont_compose K (ResetK END) }. *) + +(* Class ThrowNotation (A B C : Type) := { __throw : A -> B -> C }. *) + +(* Global Instance ThrowNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : ThrowNotation (F S) (G S) (expr S) := { *) +(* __throw e₁ e₂ := Throw (__asSynExpr e₁) (__asSynExpr e₂) *) +(* }. *) + +(* Global Instance ThrowNotationLK {S : Set} {F : Set -> Type} `{AsSynExpr F} : ThrowNotation (cont S) (F S) (cont S) := { *) +(* __throw K e₂ := ThrowLK K (__asSynExpr e₂) *) +(* }. *) + +(* Global Instance ThrowNotationRK {S : Set} : ThrowNotation (val S) (cont S) (cont S) := { *) +(* __throw v K := ThrowRK v K *) +(* }. *) + +Class AppNotation (A B C : Type) := { __app : A -> B -> C }. + +Global Instance AppNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : AppNotation (F S) (G S) (expr S) := { + __app e₁ e₂ := App (__asSynExpr e₁) (__asSynExpr e₂) + }. + +Global Instance AppNotationLK {S : Set} : AppNotation (cont S) (val S) (cont S) := { + __app K v := cont_compose K (AppLK v END) + }. + +Global Instance AppNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : AppNotation (F S) (cont S) (cont S) := { + __app e K := cont_compose K (AppRK (__asSynExpr e) END) + }. + +Class AppContNotation (A B C : Type) := { __app_cont : A -> B -> C }. + +Global Instance AppContNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : AppContNotation (F S) (G S) (expr S) := { + __app_cont e₁ e₂ := AppCont (__asSynExpr e₁) (__asSynExpr e₂) + }. + +Global Instance AppContNotationLK {S : Set} : AppContNotation (cont S) (val S) (cont S) := { + __app_cont K v := cont_compose K (AppContLK v END) + }. + +Global Instance AppContNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : AppContNotation (F S) (cont S) (cont S) := { + __app_cont e K := cont_compose K (AppContRK (__asSynExpr e) END) + }. + +Notation of_val := Val (only parsing). + +Notation "x '⋆' y" := (__app x%syn y%syn) (at level 40, y at next level, left associativity) : syn_scope. +Notation "x '@k' y" := (__app_cont x%syn y%syn) (at level 40, y at next level, left associativity) : syn_scope. +Notation "x '+' y" := (__op x%syn Add y%syn) : syn_scope. +Notation "x '-' y" := (__op x%syn Sub y%syn) : syn_scope. +Notation "x '*' y" := (__op x%syn Mult y%syn) : syn_scope. +Notation "'if' x 'then' y 'else' z" := (__if x%syn y%syn z%syn) : syn_scope. +(* Notation "'output' x" := (__output x%syn) (at level 60) : syn_scope. *) +(* Notation "'throw' e₁ e₂" := (__throw e₁%syn e₂%syn) (at level 60) : syn_scope. *) +Notation "'#' n" := (LitV n) (at level 60) : syn_scope. +(* Notation "'input'" := (Input) : syn_scope. *) +Notation "'rec' e" := (RecV e%syn) (at level 60) : syn_scope. +Notation "'shift/cc' e" := (Shift e%syn) (at level 60) : syn_scope. +Notation "'reset' e" := (Reset e%syn) (at level 60) : syn_scope. +(* Notation "'cont' K" := (ContV K%syn) (at level 60) : syn_scope. *) +Notation "'$' fn" := (set_pure_resolver fn) (at level 60) : syn_scope. +(* Notation "□" := (EmptyK) : syn_scope. *) +Notation "K '⟪' e '⟫'" := (fill K%syn e%syn) (at level 60) : syn_scope. + + +(* Notation "'lam' e" := (LamV e%syn) (at level 60) : syn_scope. *) + +(* Definition LetE {S : Set} (e : expr S) (e' : expr (inc S)) : expr S := *) +(* App (LamV e') (e). *) + +(* Notation "'let_' e₁ 'in' e₂" := (LetE e₁%syn e₂%syn) (at level 60, right associativity) : syn_scope. *) + +(* Definition SeqE {S : Set} (e e' : expr S) : expr S := *) +(* App (LamV (shift e)) e'. *) + +(* Notation "e₁ ';;' e₂" := (SeqE e₁%syn e₂%syn) : syn_scope. *) + +Declare Scope typ_scope. +Delimit Scope typ_scope with typ. + +Notation "'ℕ'" := (Tnat) (at level 1) : typ_scope. +Notation "A →ₜ B" := (Tarr A%typ B%typ) + (right associativity, at level 60) : typ_scope. +(* Notation "A 'Cont'" := (Tcont A%typ) *) +(* (at level 60) : typ_scope. *) + +Declare Scope typing_scope. +Delimit Scope typing_scope with typing. + +Class TypingNotation (A B C : Type) := { __typing : A -> B -> C -> Prop }. + +Notation "Γ ⊢ e : τ" := (__typing Γ e%syn τ%typ) (at level 70, e at level 60) : typing_scope. + +(* Global Instance TypingNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : TypingNotation (S -> ty) (F S) ty := { *) +(* __typing Γ e τ := typed Γ (__asSynExpr e) τ *) +(* }. *) + +(* Global Instance TypingNotationVal {S : Set} : TypingNotation (S -> ty) (val S) ty := { *) +(* __typing Γ e τ := typed_val Γ e τ *) +(* }. *) + +Module SynExamples. + + Open Scope syn_scope. + + Example test1 : expr (inc ∅) := ($ 0). + Example test2 : val ∅ := (rec (if ($ 1) then # 1 else # 0)). + (* Example test21 : val ∅ := (lam (if ($ 0) then # 1 else #0)). *) + Example test3 : expr ∅ := (shift/cc (rec ($ 0))). + Example test4 : expr ∅ := ((# 1) + (# 0)). + Example test5 : val ∅ := (rec (if ($ 1) then # 1 else (($ 0) ⋆ (($ 1) - (# 1))))). + Example test6 : expr (inc (inc ∅)) := ($ 0) ⋆ ($ 1). + (* Example test7 : expr ∅ := (let_ ((rec (if ($ 1) then # 1 else (($ 0) ⋆ (($ 1) - (# 1))))) ⋆ (# 5)) in (output ($ 0))). *) + + Open Scope typing_scope. + + (* Example test8 : Prop := (empty_env ⊢ (# 0) : ℕ). *) +End SynExamples. + +(* Definition compute_head_step {S} *) +(* (e : expr S) (K : cont S) : *) +(* option (expr S * cont S * (nat * nat)) := *) +(* match e with *) +(* | (App (Val (RecV e1)) (Val v2)) => *) +(* Some ((subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) *) +(* (Val (shift (Inc := inc) v2))) *) +(* (Val (RecV e1))), K, (1,0)) *) +(* (* | Input => *) *) +(* (* let '(n, σ') := update_input σ in *) *) +(* (* Some ((Val (LitV n)), σ', K, (1, 1)) *) *) +(* (* | Output (Val (LitV n)) => *) *) +(* (* (* let := update_output n σ in *) *) *) +(* (* Some ((Val (LitV 0)), σ', K, (1, 1)) *) *) +(* | (NatOp op (Val v1) (Val v2)) => *) +(* let res := nat_op_interp op v1 v2 in *) +(* option_rect (fun _ => option _) (fun v3 => Some ((Val v3), K, (0, 0))) None res *) +(* | (If (Val (LitV n)) e1 e2) => *) +(* if (decide (0 < n)) *) +(* then Some (e1, K, (0, 0)) *) +(* else *) +(* if (decide (n = 0)) *) +(* then Some (e2, K, (0, 0)) *) +(* else None *) +(* (* | (Shift e) => *) *) +(* (* let (Ki, Ko) := shift_context K in *) *) +(* (* let f := cont_to_rec Ki in *) *) +(* (* Some ((subst (Inc := inc) e (Val f)), Ko, (1, 1)) *) *) +(* | (Reset (Val v)) => Some (Val v, K, (1, 1)) *) +(* (* | (Reset (fill E (Shift e))) => None *) *) +(* | _ => None *) +(* end. *) +(* (* CHECK *) *) + +(* Example test21 : val ∅ := (rec (if ($ 0) then # 1 else #0))%syn. *) + + +(* Example testc : option (expr (inc ∅) * cont (inc ∅) * (nat * nat)) := *) +(* (compute_head_step (App (Val test1) (Val $ LitV 5)) []). *) +(* Eval compute in testc. *) + + +(* Lemma head_step_reflect {S : Set} (e : expr S) (K Ko : cont S) *) +(* : option_reflect (fun '(e', K', nm) => head_step e K e' K' Ko nm) *) +(* True *) +(* (compute_head_step e K). *) +(* Proof. *) +(* destruct e; try (by constructor). *) +(* - destruct e1; try (by constructor). *) +(* destruct v; try (by constructor). *) +(* destruct e2; try (by constructor). *) +(* constructor. *) +(* constructor. *) +(* - destruct e1; try (by constructor). *) +(* destruct e2; try (by constructor). *) +(* destruct (nat_op_interp op v v0) eqn:Heqn. *) +(* + simpl; rewrite Heqn. *) +(* simpl. *) +(* constructor. *) +(* by constructor. *) +(* + simpl; rewrite Heqn. *) +(* simpl. *) +(* constructor. *) +(* constructor. *) +(* - destruct e1; try (by constructor). *) +(* destruct v; try (by constructor). *) +(* simpl. *) +(* case_match; simpl. *) +(* + constructor. *) +(* constructor. *) +(* assumption. *) +(* + case_match; simpl. *) +(* * constructor. *) +(* constructor. *) +(* assumption. *) +(* * constructor. *) +(* constructor. *) +(* (* - simpl. *) *) +(* (* destruct (update_input σ) eqn:Heqn. *) *) +(* (* by do 2 constructor. *) *) +(* (* - simpl. *) *) +(* (* destruct e; try (by constructor). *) *) +(* (* destruct v; try (by constructor). *) *) +(* (* destruct (update_output n σ) eqn:Heqn. *) *) +(* (* by do 2 constructor. *) *) +(* (* - simpl. *) *) +(* (* destruct (shift_context K) as [Ki Ko] eqn:HK. *) *) +(* (* constructor. apply ShiftS with Ki =>//=. *) *) +(* - simpl. *) +(* destruct e; try (by constructor). *) +(* do 2 constructor. *) +(* Qed. *) diff --git a/theories/examples/input_lang/interp.v b/theories/examples/input_lang/interp.v new file mode 100644 index 0000000..202bc12 --- /dev/null +++ b/theories/examples/input_lang/interp.v @@ -0,0 +1,581 @@ +From gitrees Require Import gitree lang_generic. +From gitrees.effects Require Export io_tape. +From gitrees.examples.input_lang Require Import lang. + +Require Import Binding.Lib Binding.Set. + + +Section interp. + Context {sz : nat}. + Variable (rs : gReifiers NotCtxDep sz). + Context {subR : subReifier reify_io rs}. + Context {R} `{CR : !Cofe R}. + Context `{!SubOfe natO R}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + + Global Instance denot_cont_ne (κ : IT -n> IT) : + NonExpansive (λ x : IT, Tau (laterO_map κ (Next x))). + Proof. + solve_proper. + Qed. + + (** Interpreting individual operators *) + Program Definition interp_input {A} : A -n> IT := + λne env, INPUT Ret. + Program Definition interp_output {A} (t : A -n> IT) : A -n> IT := + get_ret OUTPUT ◎ t. + Local Instance interp_ouput_ne {A} : NonExpansive2 (@interp_output A). + Proof. solve_proper. Qed. + + Program Definition interp_natop {A} (op : nat_op) (t1 t2 : A -n> IT) : A -n> IT := + λne env, NATOP (do_natop op) (t1 env) (t2 env). + Solve All Obligations with solve_proper_please. + + Global Instance interp_natop_ne A op : NonExpansive2 (@interp_natop A op). + Proof. solve_proper. Qed. + Typeclasses Opaque interp_natop. + + Opaque laterO_map. + Program Definition interp_rec_pre {S : Set} (body : interp_scope (inc (inc S)) -n> IT) + : laterO (interp_scope S -n> IT) -n> interp_scope S -n> IT := + λne self env, Fun $ laterO_map (λne (self : interp_scope S -n> IT) (a : IT), + body (extend_scope (extend_scope env (self env)) a)) self. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + do 3 f_equiv; intros ??; simpl; f_equiv; + intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + by do 2 f_equiv. + Qed. + + Program Definition interp_rec {S : Set} + (body : interp_scope (inc (inc S)) -n> IT) : + interp_scope S -n> IT := + mmuu (interp_rec_pre body). + + Program Definition ir_unf {S : Set} + (body : interp_scope (inc (inc S)) -n> IT) env : IT -n> IT := + λne a, body (extend_scope + (extend_scope env (interp_rec body env)) + a). + Next Obligation. + intros. + solve_proper_prepare. + f_equiv. intros [| [| y']]; simpl; solve_proper. + Qed. + + Lemma interp_rec_unfold {S : Set} (body : interp_scope (inc (inc S)) -n> IT) env : + interp_rec body env ≡ Fun $ Next $ ir_unf body env. + Proof. + trans (interp_rec_pre body (Next (interp_rec body)) env). + { f_equiv. rewrite /interp_rec. apply mmuu_unfold. } + simpl. rewrite laterO_map_Next. repeat f_equiv. + simpl. unfold ir_unf. intro. simpl. reflexivity. + Qed. + + Program Definition interp_app {A} (t1 t2 : A -n> IT) : A -n> IT := + λne env, APP' (t1 env) (t2 env). + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Global Instance interp_app_ne A : NonExpansive2 (@interp_app A). + Proof. solve_proper. Qed. + Typeclasses Opaque interp_app. + + Program Definition interp_if {A} (t0 t1 t2 : A -n> IT) : A -n> IT := + λne env, IF (t0 env) (t1 env) (t2 env). + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Global Instance interp_if_ne A n : + Proper ((dist n) ==> (dist n) ==> (dist n) ==> (dist n)) (@interp_if A). + Proof. solve_proper. Qed. + + Program Definition interp_nat (n : nat) {A} : A -n> IT := + λne env, Ret n. + + Program Definition interp_applk {A} + (K : A -n> (IT -n> IT)) + (q : A -n> IT) + : A -n> (IT -n> IT) := + λne env t, interp_app (λne env, K env t) q env. + Solve All Obligations with solve_proper. + + Program Definition interp_apprk {A} + (q : A -n> IT) + (K : A -n> (IT -n> IT)) + : A -n> (IT -n> IT) := + λne env t, interp_app q (λne env, K env t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoprk {A} (op : nat_op) + (q : A -n> IT) + (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := + λne env t, interp_natop op q (λne env, K env t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoplk {A} (op : nat_op) + (K : A -n> (IT -n> IT)) + (q : A -n> IT) : A -n> (IT -n> IT) := + λne env t, interp_natop op (λne env, K env t) q env. + Solve All Obligations with solve_proper. + + Program Definition interp_ifk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) + (p : A -n> IT) : A -n> (IT -n> IT) := + λne env t, interp_if (λne env, K env t) q p env. + Solve All Obligations with solve_proper. + + Program Definition interp_outputk {A} (K : A -n> (IT -n> IT)) : + A -n> (IT -n> IT) := + λne env t, interp_output (λne env, K env t) env. + Solve All Obligations with solve_proper. + + (** Interpretation for all the syntactic categories: values, expressions, contexts *) + Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := + match v with + | LitV n => interp_nat n + | RecV e => interp_rec (interp_expr e) + end + with interp_expr {S} (e : expr S) : interp_scope S -n> IT := + match e with + | Val v => interp_val v + | Var x => interp_var x + | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) + | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) + | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) + | Input => interp_input + | Output e => interp_output (interp_expr e) + end + with interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := + match K with + | EmptyK => λne env, idfun + | AppRK e1 K => interp_apprk (interp_expr e1) (interp_ectx K) + | AppLK K v2 => interp_applk (interp_ectx K) (interp_val v2) + | NatOpRK op e1 K => interp_natoprk op (interp_expr e1) (interp_ectx K) + | NatOpLK op K v2 => interp_natoplk op (interp_ectx K) (interp_val v2) + | IfK K e1 e2 => interp_ifk (interp_ectx K) (interp_expr e1) (interp_expr e2) + | OutputK K => interp_outputk (interp_ectx K) + end. + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + + Global Instance interp_val_asval {S} {D : interp_scope S} (v : val S) + : AsVal (interp_val v D). + Proof. + destruct v; simpl. + - apply _. + - rewrite interp_rec_unfold. apply _. + Qed. + + Global Instance ArrEquiv {A B : Set} : Equiv (A [→] B) := + fun f g => ∀ x, f x = g x. + + Global Instance ArrDist {A B : Set} `{Dist B} : Dist (A [→] B) := + fun n => fun f g => ∀ x, f x ≡{n}≡ g x. + + Global Instance ren_scope_proper {S S'} : + Proper ((≡) ==> (≡) ==> (≡)) (@ren_scope F _ CR S S'). + Proof. + intros D D' HE s1 s2 Hs. + intros x; simpl. + f_equiv. + - apply Hs. + - apply HE. + Qed. + + Lemma interp_expr_ren {S S'} env + (δ : S [→] S') (e : expr S) : + interp_expr (fmap δ e) env ≡ interp_expr e (ren_scope δ env) + with interp_val_ren {S S'} env + (δ : S [→] S') (e : val S) : + interp_val (fmap δ e) env ≡ interp_val e (ren_scope δ env) + with interp_ectx_ren {S S'} env + (δ : S [→] S') (e : ectx S) : + interp_ectx (fmap δ e) env ≡ interp_ectx e (ren_scope δ env). + Proof. + - destruct e; simpl. + + by apply interp_val_ren. + + reflexivity. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + - destruct e; simpl. + + reflexivity. + + clear -interp_expr_ren. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + do 1 iApply f_equivI. iNext. + iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_ren. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (y'). + destruct y' as [| [| y]]; simpl; first done. + * by iRewrite - "IH". + * done. + - destruct e; simpl; intros ?; simpl. + + reflexivity. + + repeat f_equiv; by apply interp_ectx_ren. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_expr_ren | by apply interp_expr_ren]. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. + + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. + + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. + Qed. + + Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S): + interp_expr (fill K e) env ≡ (interp_ectx K) env ((interp_expr e) env). + Proof. + revert env. + induction K; simpl; intros env; first reflexivity; try (by rewrite IHK). + - repeat f_equiv. + by rewrite IHK. + - repeat f_equiv. + by rewrite IHK. + - repeat f_equiv. + by rewrite IHK. + Qed. + + Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') + : interp_scope S := λne x, interp_expr (δ x) env. + + Global Instance SubEquiv {A B : Set} : Equiv (A [⇒] B) := fun f g => ∀ x, f x = g x. + + Global Instance sub_scope_proper {S S'} : + Proper ((≡) ==> (≡) ==> (≡)) (@sub_scope S S'). + Proof. + intros D D' HE s1 s2 Hs. + intros x; simpl. + f_equiv. + - f_equiv. + apply HE. + - apply Hs. + Qed. + + Lemma interp_expr_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_expr (bind δ e) env ≡ interp_expr e (sub_scope δ env) + with interp_val_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_val (bind δ e) env ≡ interp_val e (sub_scope δ env) + with interp_ectx_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_ectx (bind δ e) env ≡ interp_ectx e (sub_scope δ env). + Proof. + - destruct e; simpl. + + by apply interp_val_subst. + + term_simpl. + reflexivity. + + repeat f_equiv; by apply interp_expr_subst. + + repeat f_equiv; by apply interp_expr_subst. + + repeat f_equiv; by apply interp_expr_subst. + + f_equiv. + + repeat f_equiv; by apply interp_expr_subst. + - destruct e; simpl. + + reflexivity. + + clear -interp_expr_subst. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + do 1 iApply f_equivI. iNext. + iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_subst. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (y'). + destruct y' as [| [| y]]; simpl; first done. + * by iRewrite - "IH". + * do 2 rewrite interp_expr_ren. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (z). + done. + - destruct e; simpl; intros ?; simpl. + + reflexivity. + + repeat f_equiv; by apply interp_ectx_subst. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_expr_subst | by apply interp_expr_subst]. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. + + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. + Qed. + + (** ** Interpretation of evaluation contexts induces homomorphism *) + + #[local] Instance interp_ectx_hom_emp {S} env : + IT_hom (interp_ectx (EmptyK : ectx S) env). + Proof. + simple refine (IT_HOM _ _ _ _ _); intros; auto. + simpl. fold (@idfun IT). f_equiv. intro. simpl. + by rewrite laterO_map_id. + Qed. + + #[local] Instance interp_ectx_hom_output {S} (K : ectx S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (OutputK K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite !hom_tick. + - rewrite !hom_vis. + f_equiv. intro. simpl. rewrite -laterO_map_compose. + do 2 f_equiv. by intro. + - by rewrite !hom_err. + Qed. + + #[local] Instance interp_ectx_hom_if {S} + (K : ectx S) (e1 e2 : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (IfK K e1 e2) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -IF_Tick. do 3 f_equiv. apply hom_tick. + - assert ((interp_ectx K env (Vis op i ko)) ≡ + (Vis op i (laterO_map (λne y, interp_ectx K env y) ◎ ko))). + { by rewrite hom_vis. } + trans (IF (Vis op i (laterO_map (λne y : IT, interp_ectx K env y) ◎ ko)) + (interp_expr e1 env) (interp_expr e2 env)). + { do 3 f_equiv. by rewrite hom_vis. } + rewrite IF_Vis. f_equiv. simpl. + intro. simpl. by rewrite -laterO_map_compose. + - trans (IF (Err e) (interp_expr e1 env) (interp_expr e2 env)). + { repeat f_equiv. apply hom_err. } + apply IF_Err. + Qed. + + #[local] Instance interp_ectx_hom_appr {S} (K : ectx S) + (e : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (AppRK e K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite !hom_tick. + - rewrite !hom_vis. f_equiv. intro x. simpl. + by rewrite laterO_map_compose. + - by rewrite !hom_err. + Qed. + + #[local] Instance interp_ectx_hom_appl {S} (K : ectx S) + (v : val S) (env : interp_scope S) : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (AppLK K v) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -APP'_Tick_l. do 2 f_equiv. apply hom_tick. + - trans (APP' (Vis op i (laterO_map (interp_ectx K env) ◎ ko)) + (interp_val v env)). + + do 2f_equiv. rewrite hom_vis. do 3 f_equiv. by intro. + + rewrite APP'_Vis_l. f_equiv. intro x. simpl. + by rewrite -laterO_map_compose. + - trans (APP' (Err e) (interp_val v env)). + { do 2f_equiv. apply hom_err. } + apply APP'_Err_l, interp_val_asval. + Qed. + + #[local] Instance interp_ectx_hom_natopr {S} (K : ectx S) + (e : expr S) op env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (NatOpRK op e K) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite !hom_tick. + - rewrite !hom_vis. f_equiv. intro x. simpl. + by rewrite laterO_map_compose. + - by rewrite !hom_err. + Qed. + + #[local] Instance interp_ectx_hom_natopl {S} (K : ectx S) + (v : val S) op (env : interp_scope S) : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (NatOpLK op K v) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -NATOP_ITV_Tick_l. do 2 f_equiv. apply hom_tick. + - trans (NATOP (do_natop op) + (Vis op0 i (laterO_map (interp_ectx K env) ◎ ko)) + (interp_val v env)). + { do 2 f_equiv. rewrite hom_vis. f_equiv. by intro. } + rewrite NATOP_ITV_Vis_l. f_equiv. intro x. simpl. + by rewrite -laterO_map_compose. + - trans (NATOP (do_natop op) (Err e) (interp_val v env)). + + do 2 f_equiv. apply hom_err. + + by apply NATOP_Err_l, interp_val_asval. + Qed. + + #[global] Instance interp_ectx_hom {S} (K : ectx S) env : + IT_hom (interp_ectx K env). + Proof. + induction K; apply _. + Qed. + + (** ** Finally, preservation of reductions *) + Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (e : expr S) e' σ σ' n : + head_step e σ e' σ' (n, 0) → + interp_expr e env ≡ Tick_n n $ interp_expr e' env. + Proof. + inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. + - (* app lemma *) + subst. + erewrite APP_APP'_ITV; last apply _. + trans (APP (Fun (Next (ir_unf (interp_expr e1) env))) (Next $ interp_val v2 env)). + { repeat f_equiv. apply interp_rec_unfold. } + rewrite APP_Fun. simpl. rewrite Tick_eq. do 2 f_equiv. + simplify_eq. + rewrite !interp_expr_subst. + f_equiv. + intros [| [| x]]; simpl; [| reflexivity | reflexivity]. + rewrite interp_val_ren. + f_equiv. + intros ?; simpl; reflexivity. + - (* the natop stuff *) + simplify_eq. + destruct v1,v2; try naive_solver. simpl in *. + rewrite NATOP_Ret. + destruct op; simplify_eq/=; done. + - rewrite IF_True; last lia. + reflexivity. + - rewrite IF_False; last lia. + reflexivity. + Qed. + + Lemma interp_expr_fill_no_reify {S} K (env : interp_scope S) (e e' : expr S) σ σ' n : + head_step e σ e' σ' (n, 0) → + interp_expr (fill K e) env + ≡ + Tick_n n $ interp_expr (fill K e') env. + Proof. + intros He. + rewrite !interp_comp. + erewrite <-hom_tick_n. + - apply (interp_expr_head_step env) in He. + rewrite He. + reflexivity. + - apply _. + Qed. + + Opaque INPUT OUTPUT_. + Opaque extend_scope. + Opaque Ret. + + Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) + (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : + head_step e σ e' σ' (n, 1) → + reify (gReifiers_sReifier rs) + (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) + ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). + Proof. + intros Hst. + trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) + (gState_recomp σr (sR_state σ))). + { f_equiv. by rewrite interp_comp. } + inversion Hst; simplify_eq; cbn-[gState_recomp]. + - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). + { + repeat f_equiv; eauto. + rewrite hom_INPUT. + do 2 f_equiv. by intro. + } + rewrite reify_vis_eq_ctx_indep //; first last. + { + epose proof (@subReifier_reify sz NotCtxDep reify_io rs _ IT _ (inl ()) () _ σ σ' σr) as H. + simpl in H. + simpl. + erewrite <-H; last first. + - rewrite H4. reflexivity. + - f_equiv; + solve_proper. + } + repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. + rewrite interp_comp. + rewrite ofe_iso_21. + simpl. + reflexivity. + - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). + { + do 3 f_equiv; eauto. + rewrite get_ret_ret//. + } + trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). + { + do 2 f_equiv; eauto. + by rewrite hom_OUTPUT_. + } + rewrite reify_vis_eq_ctx_indep //; last first. + { + epose proof (@subReifier_reify sz _ reify_io rs _ IT _ (inr (inl ())) n0 _ σ (update_output n0 σ) σr) as H. + simpl in H. + simpl. + erewrite <-H; last reflexivity. + f_equiv. + intros ???. by rewrite /prod_map H0. + } + repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. + rewrite interp_comp. + reflexivity. + Qed. + + Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : + prim_step e1 σ1 e2 σ2 (n,m) → + ssteps (gReifiers_sReifier rs) + (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) + (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. + Proof. + Opaque gState_decomp gState_recomp. + inversion 1; simplify_eq/=. + destruct (head_step_io_01 _ _ _ _ _ _ H2); subst. + - assert (σ1 = σ2) as ->. + { eapply head_step_no_io; eauto. } + unshelve eapply (interp_expr_fill_no_reify K) in H2; first apply env. + rewrite H2. + rewrite interp_comp. + eapply ssteps_tick_n. + - inversion H2;subst. + + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. + rewrite interp_comp. + rewrite hom_INPUT. + change 1 with (Nat.add 1 0). econstructor; last first. + { apply ssteps_zero; reflexivity. } + eapply sstep_reify. + { Transparent INPUT. unfold INPUT. simpl. + f_equiv. reflexivity. } + simpl in H2. + rewrite -H2. + repeat f_equiv; eauto. + rewrite interp_comp hom_INPUT. + eauto. + + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. + rewrite interp_comp. simpl. + rewrite get_ret_ret. + rewrite hom_OUTPUT_. + change 1 with (Nat.add 1 0). econstructor; last first. + { apply ssteps_zero; reflexivity. } + eapply sstep_reify. + { Transparent OUTPUT_. unfold OUTPUT_. simpl. + f_equiv. reflexivity. } + simpl in H2. + rewrite -H2. + repeat f_equiv; eauto. + Opaque OUTPUT_. + rewrite interp_comp /= get_ret_ret hom_OUTPUT_. + eauto. + Qed. + +End interp. +#[global] Opaque INPUT OUTPUT_. diff --git a/theories/examples/input_lang/lang.v b/theories/examples/input_lang/lang.v new file mode 100644 index 0000000..0afca04 --- /dev/null +++ b/theories/examples/input_lang/lang.v @@ -0,0 +1,593 @@ +From gitrees Require Export prelude effects.io_tape. +Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. + + +Inductive nat_op := Add | Sub | Mult. + +Inductive expr {X : Set} : Type := + (* Values *) +| Val (v : val) : expr +| Var (x : X) : expr +(* Base lambda calculus *) +| App (e₁ : expr) (e₂ : expr) : expr +(* Base types and their operations *) +| NatOp (op : nat_op) (e₁ : expr) (e₂ : expr) : expr +| If (e₁ : expr) (e₂ : expr) (e₃ : expr) : expr +(* The effects *) +| Input : expr +| Output (e : expr) : expr +with val {X : Set} := +| LitV (n : nat) : val +| RecV (e : @expr (inc (inc X))) : val +with ectx {X : Set} := +| EmptyK : ectx +| OutputK (K : ectx) : ectx +| IfK (K : ectx) (e₁ : expr) (e₂ : expr) : ectx +| AppLK (K : ectx) (v : val) : ectx +| AppRK (e : expr) (K : ectx) : ectx +| NatOpRK (op : nat_op) (e : expr) (K : ectx) : ectx +| NatOpLK (op : nat_op) (K : ectx) (v : val) : ectx. + +Arguments val X%bind : clear implicits. +Arguments expr X%bind : clear implicits. +Arguments ectx X%bind : clear implicits. + +Local Open Scope bind_scope. + +Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := + match e with + | Val v => Val (vmap f v) + | Var x => Var (f x) + | App e₁ e₂ => App (emap f e₁) (emap f e₂) + | NatOp o e₁ e₂ => NatOp o (emap f e₁) (emap f e₂) + | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) + | Input => Input + | Output e => Output (emap f e) + end +with vmap {A B : Set} (f : A [→] B) (v : val A) : val B := + match v with + | LitV n => LitV n + | RecV e => RecV (emap ((f ↑) ↑) e) + end +with kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := + match K with + | EmptyK => EmptyK + | OutputK K => OutputK (kmap f K) + | IfK K e₁ e₂ => IfK (kmap f K) (emap f e₁) (emap f e₂) + | AppLK K v => AppLK (kmap f K) (vmap f v) + | AppRK e K => AppRK (emap f e) (kmap f K) + | NatOpRK op e K => NatOpRK op (emap f e) (kmap f K) + | NatOpLK op K v => NatOpLK op (kmap f K) (vmap f v) + end. +#[export] Instance FMap_expr : FunctorCore expr := @emap. +#[export] Instance FMap_val : FunctorCore val := @vmap. +#[export] Instance FMap_ectx : FunctorCore ectx := @kmap. + +#[export] Instance SPC_expr : SetPureCore expr := @Var. + +Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := + match e with + | Val v => Val (vbind f v) + | Var x => f x + | App e₁ e₂ => App (ebind f e₁) (ebind f e₂) + | NatOp o e₁ e₂ => NatOp o (ebind f e₁) (ebind f e₂) + | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) + | Input => Input + | Output e => Output (ebind f e) + end +with vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := + match v with + | LitV n => LitV n + | RecV e => RecV (ebind ((f ↑) ↑) e) + end +with kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := + match K with + | EmptyK => EmptyK + | OutputK K => OutputK (kbind f K) + | IfK K e₁ e₂ => IfK (kbind f K) (ebind f e₁) (ebind f e₂) + | AppLK K v => AppLK (kbind f K) (vbind f v) + | AppRK e K => AppRK (ebind f e) (kbind f K) + | NatOpRK op e K => NatOpRK op (ebind f e) (kbind f K) + | NatOpLK op K v => NatOpLK op (kbind f K) (vbind f v) + end. + +#[export] Instance BindCore_expr : BindCore expr := @ebind. +#[export] Instance BindCore_val : BindCore val := @vbind. +#[export] Instance BindCore_ectx : BindCore ectx := @kbind. + +#[export] Instance IP_typ : SetPure expr. +Proof. + split; intros; reflexivity. +Qed. + +Fixpoint vmap_id X (δ : X [→] X) (v : val X) : δ ≡ ı → fmap δ v = v +with emap_id X (δ : X [→] X) (e : expr X) : δ ≡ ı → fmap δ e = e +with kmap_id X (δ : X [→] X) (e : ectx X) : δ ≡ ı → fmap δ e = e. +Proof. + - auto_map_id. + - auto_map_id. + - auto_map_id. +Qed. + +Fixpoint vmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (v : val A) : + f ∘ g ≡ h → fmap f (fmap g v) = fmap h v +with emap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : expr A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e +with kmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : ectx A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e. +Proof. + - auto_map_comp. + - auto_map_comp. + - auto_map_comp. +Qed. + +#[export] Instance Functor_val : Functor val. +Proof. + split; [exact vmap_id | exact vmap_comp]. +Qed. +#[export] Instance Functor_expr : Functor expr. +Proof. + split; [exact emap_id | exact emap_comp]. +Qed. +#[export] Instance Functor_ectx : Functor ectx. +Proof. + split; [exact kmap_id | exact kmap_comp]. +Qed. + +Fixpoint vmap_vbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (v : val A) : + f ̂ ≡ g → fmap f v = bind g v +with emap_ebind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : expr A) : + f ̂ ≡ g → fmap f e = bind g e +with kmap_kbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : ectx A) : + f ̂ ≡ g → fmap f e = bind g e. +Proof. + - auto_map_bind_pure. + erewrite emap_ebind_pure; [reflexivity |]. + intros [| [| x]]; term_simpl; [reflexivity | reflexivity |]. + rewrite <-(EQ x). + reflexivity. + - auto_map_bind_pure. + - auto_map_bind_pure. +Qed. + +#[export] Instance BindMapPure_val : BindMapPure val. +Proof. + split; intros; now apply vmap_vbind_pure. +Qed. +#[export] Instance BindMapPure_expr : BindMapPure expr. +Proof. + split; intros; now apply emap_ebind_pure. +Qed. +#[export] Instance BindMapPure_ectx : BindMapPure ectx. +Proof. + split; intros; now apply kmap_kbind_pure. +Qed. + +Fixpoint vmap_vbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (v : val A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ v) = fmap f₁ (bind g₁ v) +with emap_ebind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : expr A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e) +with kmap_kbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : ectx A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e). +Proof. + - auto_map_bind_comm. + erewrite emap_ebind_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity | assumption]. + - auto_map_bind_comm. + - auto_map_bind_comm. +Qed. + +#[export] Instance BindMapComm_val : BindMapComm val. +Proof. + split; intros; now apply vmap_vbind_comm. +Qed. +#[export] Instance BindMapComm_expr : BindMapComm expr. +Proof. + split; intros; now apply emap_ebind_comm. +Qed. +#[export] Instance BindMapComm_ectx : BindMapComm ectx. +Proof. + split; intros; now apply kmap_kbind_comm. +Qed. + +Fixpoint vbind_id (A : Set) (f : A [⇒] A) (v : val A) : + f ≡ ı → bind f v = v +with ebind_id (A : Set) (f : A [⇒] A) (e : expr A) : + f ≡ ı → bind f e = e +with kbind_id (A : Set) (f : A [⇒] A) (e : ectx A) : + f ≡ ı → bind f e = e. +Proof. + - auto_bind_id. + rewrite ebind_id; [reflexivity |]. + apply lift_id, lift_id; assumption. + - auto_bind_id. + - auto_bind_id. +Qed. + +Fixpoint vbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (v : val A) : + f ∘ g ≡ h → bind f (bind g v) = bind h v +with ebind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : expr A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e +with kbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : ectx A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e. +Proof. + - auto_bind_comp. + erewrite ebind_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity | assumption]. + - auto_bind_comp. + - auto_bind_comp. +Qed. + +#[export] Instance Bind_val : Bind val. +Proof. + split; intros; [now apply vbind_id | now apply vbind_comp]. +Qed. +#[export] Instance Bind_expr : Bind expr. +Proof. + split; intros; [now apply ebind_id | now apply ebind_comp]. +Qed. +#[export] Instance Bind_ectx : Bind ectx. +Proof. + split; intros; [now apply kbind_id | now apply kbind_comp]. +Qed. + +Definition to_val {S} (e : expr S) : option (val S) := + match e with + | Val v => Some v + | _ => None + end. + +Definition do_natop (op : nat_op) (x y : nat) : nat := + match op with + | Add => plus x y + | Sub => minus x y + | Mult => mult x y + end. + +Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := + match x, y with + | LitV x, LitV y => Some $ LitV $ do_natop n x y + | _,_ => None + end. + +Fixpoint fill {X : Set} (K : ectx X) (e : expr X) : expr X := + match K with + | EmptyK => e + | OutputK K => Output (fill K e) + | IfK K e₁ e₂ => If (fill K e) e₁ e₂ + | AppLK K v => App (fill K e) (Val v) + | AppRK e' K => App e' (fill K e) + | NatOpRK op e' K => NatOp op e' (fill K e) + | NatOpLK op K v => NatOp op (fill K e) (Val v) + end. + +Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) + : fmap f (fill K e) = fill (fmap f K) (fmap f e). +Proof. + revert f. + induction K as [| ?? IH + | ?? IH + | ?? IH + | ??? IH + | ???? IH + | ??? IH]; + intros f; term_simpl; first done; rewrite IH; reflexivity. +Qed. + +(*** Operational semantics *) + +Inductive head_step {S} : expr S → state → expr S → state → nat*nat → Prop := +| BetaS e1 v2 σ : + head_step (App (Val $ RecV e1) (Val v2)) σ (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) (Val (shift (Inc := inc) v2))) (Val (RecV e1))) σ (1,0) +| InputS σ n σ' : + update_input σ = (n,σ') → + head_step Input σ (Val (LitV n)) σ' (1,1) +| OutputS σ n σ' : + update_output n σ = σ' → + head_step (Output (Val (LitV n))) σ (Val (LitV 0)) σ' (1,1) +| NatOpS op v1 v2 v3 σ : + nat_op_interp op v1 v2 = Some v3 → + head_step (NatOp op (Val v1) (Val v2)) σ + (Val v3) σ (0,0) +| IfTrueS n e1 e2 σ : + n > 0 → + head_step (If (Val (LitV n)) e1 e2) σ + e1 σ (0,0) +| IfFalseS n e1 e2 σ : + n = 0 → + head_step (If (Val (LitV n)) e1 e2) σ + e2 σ (0,0) +. + +Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 n m : + head_step e1 σ1 e2 σ2 (n,m) → m = 0 ∨ m = 1. +Proof. inversion 1; eauto. Qed. +Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 n m : + head_step e1 σ1 e2 σ2 (n,m) → n = 0 ∨ n = 1. +Proof. inversion 1; eauto. Qed. +Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 n : + head_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. +Proof. inversion 1; eauto. Qed. + +(** Carbonara from heap lang *) +Global Instance fill_item_inj {S} (Ki : ectx S) : Inj (=) (=) (fill Ki). +Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. + +Lemma fill_item_val {S} Ki (e : expr S) : + is_Some (to_val (fill Ki e)) → is_Some (to_val e). +Proof. intros [v ?]. induction Ki; simplify_option_eq; eauto. Qed. + +Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 m : head_step e1 σ1 e2 σ2 m → to_val e1 = None. +Proof. destruct 1; naive_solver. Qed. + +Fixpoint ectx_compose {S} (K1 K2 : ectx S) : ectx S + := match K1 with + | EmptyK => K2 + | OutputK K => OutputK (ectx_compose K K2) + | IfK K e₁ e₂ => IfK (ectx_compose K K2) e₁ e₂ + | AppLK K v => AppLK (ectx_compose K K2) v + | AppRK e K => AppRK e (ectx_compose K K2) + | NatOpRK op e K => NatOpRK op e (ectx_compose K K2) + | NatOpLK op K v => NatOpLK op (ectx_compose K K2) v + end. + +Lemma fill_app {S} (K1 K2 : ectx S) e : fill (ectx_compose K1 K2) e = fill K1 (fill K2 e). +Proof. + revert K2. + revert e. + induction K1 as [| ?? IH + | ?? IH + | ?? IH + | ??? IH + | ???? IH + | ??? IH]; + simpl; first done; intros e' K2; rewrite IH; reflexivity. +Qed. + +Lemma fill_val : ∀ {S} K (e : expr S), is_Some (to_val (fill K e)) → is_Some (to_val e). +Proof. + intros S K. + induction K as [| ?? IH + | ?? IH + | ?? IH + | ??? IH + | ???? IH + | ??? IH]=> e' //=; + inversion 1 as [? HH]; inversion HH. +Qed. + +Lemma fill_not_val : ∀ {S} K (e : expr S), to_val e = None → to_val (fill K e) = None. +Proof. + intros S K e. rewrite !eq_None_not_Some. + eauto using fill_val. +Qed. + +Lemma fill_empty {S} (e : expr S) : fill EmptyK e = e. +Proof. reflexivity. Qed. +Lemma fill_comp {S} K1 K2 (e : expr S) : fill K2 (fill K1 e) = fill (ectx_compose K2 K1) e. +Proof. by rewrite fill_app. Qed. +Global Instance fill_inj {S} (K : ectx S) : Inj (=) (=) (fill K). +Proof. + induction K as [| ?? IH + | ?? IH + | ?? IH + | ??? IH + | ???? IH + | ??? IH]; + rewrite /Inj; naive_solver. +Qed. + +Inductive prim_step {S} (e1 : expr S) (σ1 : state) + (e2 : expr S) (σ2 : state) (n : nat*nat) : Prop:= + Ectx_step (K : ectx S) e1' e2' : + e1 = fill K e1' → e2 = fill K e2' → + head_step e1' σ1 e2' σ2 n → prim_step e1 σ1 e2 σ2 n. + +Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : + prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. +Proof. + inversion 1; simplify_eq/=. + inversion H2; eauto. +Qed. + +Inductive prim_steps {S} : expr S → state → expr S → state → nat*nat → Prop := +| prim_steps_zero e σ : + prim_steps e σ e σ (0,0) +| prim_steps_abit e1 σ1 e2 σ2 e3 σ3 n1 m1 n2 m2 : + prim_step e1 σ1 e2 σ2 (n1,m1) → + prim_steps e2 σ2 e3 σ3 (n2,m2) → + prim_steps e1 σ1 e3 σ3 (n1+n2,m1+m2) +. + +Lemma Ectx_step' {S} (K : ectx S) e1 σ1 e2 σ2 efs : + head_step e1 σ1 e2 σ2 efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. +Proof. econstructor; eauto. Qed. + +Lemma prim_step_ctx {S} (K : ectx S) e1 σ1 e2 σ2 efs : + prim_step e1 σ1 e2 σ2 efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. +Proof. + destruct 1 as [K2 u1 u2 HK2]. + subst e1 e2. rewrite -!fill_app. + by econstructor; eauto. +Qed. + +Lemma prim_steps_ctx {S} (K : ectx S) e1 σ1 e2 σ2 efs : + prim_steps e1 σ1 e2 σ2 efs → prim_steps (fill K e1) σ1 (fill K e2) σ2 efs. +Proof. + induction 1; econstructor; eauto using prim_step_ctx. +Qed. + +Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) σ1 σ2 σ3 : + prim_steps e1 σ1 e2 σ2 nm1 → prim_steps e2 σ2 e3 σ3 nm2 → + prim_steps e1 σ1 e3 σ3 (nm1.1 + nm2.1, nm1.2 + nm2.2). +Proof. + intros Hst. revert nm2. + induction Hst; intros [n' m']; simplify_eq/=; first done. + rewrite -!Nat.add_assoc. intros Hsts. + econstructor; eauto. + by apply (IHHst (n',m')). +Qed. + +Lemma prim_step_steps {S} nm (e1 e2 : expr S) σ1 σ2 : + prim_step e1 σ1 e2 σ2 nm → prim_steps e1 σ1 e2 σ2 nm. +Proof. + destruct nm as [n m]. intro Hs. + rewrite -(Nat.add_0_r n). + rewrite -(Nat.add_0_r m). + econstructor; eauto. + by constructor. +Qed. + + +(*** Type system *) + + +Inductive ty := + | Tnat : ty | Tarr : ty → ty → ty. + +Inductive typed {S : Set} (Γ : S -> ty) : expr S → ty → Prop := +| typed_Val (τ : ty) (v : val S) : + typed_val Γ v τ → + typed Γ (Val v) τ +| typed_Var (τ : ty) (v : S) : + Γ v = τ → + typed Γ (Var v) τ +| typed_App (τ1 τ2 : ty) e1 e2 : + typed Γ e1 (Tarr τ1 τ2) → + typed Γ e2 τ1 → + typed Γ (App e1 e2) τ2 +| typed_NatOp e1 e2 op : + typed Γ e1 Tnat → + typed Γ e2 Tnat → + typed Γ (NatOp op e1 e2) Tnat +| typed_If e0 e1 e2 τ : + typed Γ e0 Tnat → + typed Γ e1 τ → + typed Γ e2 τ → + typed Γ (If e0 e1 e2) τ +| typed_Input : + typed Γ Input Tnat +| typed_Output e : + typed Γ e Tnat → + typed Γ (Output e) Tnat +with typed_val {S : Set} (Γ : S -> ty) : val S → ty → Prop := +| typed_Lit n : + typed_val Γ (LitV n) Tnat +| typed_RecV (τ1 τ2 : ty) (e : expr (inc (inc S))) : + typed (Γ ▹ (Tarr τ1 τ2) ▹ τ1) e τ2 → + typed_val Γ (RecV e) (Tarr τ1 τ2) +. + +Declare Scope syn_scope. +Delimit Scope syn_scope with syn. + +Coercion Val : val >-> expr. + +Coercion App : expr >-> Funclass. +Coercion AppLK : ectx >-> Funclass. +Coercion AppRK : expr >-> Funclass. + +(* XXX: We use these typeclasses to share the notaiton between the +expressions and the evaluation contexts, for readability. It will be +good to also share the notation between different languages. *) + +Class AsSynExpr (F : Set -> Type) := { __asSynExpr : ∀ S, F S -> expr S }. + +Arguments __asSynExpr {_} {_} {_}. + +Global Instance AsSynExprValue : AsSynExpr val := { + __asSynExpr _ v := Val v + }. +Global Instance AsSynExprExpr : AsSynExpr expr := { + __asSynExpr _ e := e + }. + +Class OpNotation (A B C D : Type) := { __op : A -> B -> C -> D }. + +Global Instance OpNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : OpNotation (F S) nat_op (G S) (expr S) := { + __op e₁ op e₂ := NatOp op (__asSynExpr e₁) (__asSynExpr e₂) + }. + +Global Instance OpNotationLK {S : Set} : OpNotation (ectx S) (nat_op) (val S) (ectx S) := { + __op K op v := NatOpLK op K v + }. + +Global Instance OpNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : OpNotation (F S) (nat_op) (ectx S) (ectx S) := { + __op e op K := NatOpRK op (__asSynExpr e) K + }. + +Class IfNotation (A B C D : Type) := { __if : A -> B -> C -> D }. + +Global Instance IfNotationExpr {S : Set} {F G H : Set -> Type} `{AsSynExpr F, AsSynExpr G, AsSynExpr H} : IfNotation (F S) (G S) (H S) (expr S) := { + __if e₁ e₂ e₃ := If (__asSynExpr e₁) (__asSynExpr e₂) (__asSynExpr e₃) + }. + +Global Instance IfNotationK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : IfNotation (ectx S) (F S) (G S) (ectx S) := { + __if K e₂ e₃ := IfK K (__asSynExpr e₂) (__asSynExpr e₃) + }. + +Class OutputNotation (A B : Type) := { __output : A -> B }. + +Global Instance OutputNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : OutputNotation (F S) (expr S) := { + __output e := Output (__asSynExpr e) + }. + +Global Instance OutputNotationK {S : Set} : OutputNotation (ectx S) (ectx S) := { + __output K := OutputK K + }. + +Class AppNotation (A B C : Type) := { __app : A -> B -> C }. + +Global Instance AppNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : AppNotation (F S) (G S) (expr S) := { + __app e₁ e₂ := App (__asSynExpr e₁) (__asSynExpr e₂) + }. + +Global Instance AppNotationLK {S : Set} : AppNotation (ectx S) (val S) (ectx S) := { + __app K v := AppLK K v + }. + +Global Instance AppNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : AppNotation (F S) (ectx S) (ectx S) := { + __app e K := AppRK (__asSynExpr e) K + }. + +Notation of_val := Val (only parsing). + +Notation "x '⋆' y" := (__app x%syn y%syn) (at level 40, y at next level, left associativity) : syn_scope. +Notation "x '+' y" := (__op x%syn Add y%syn) : syn_scope. +Notation "x '-' y" := (__op x%syn Sub y%syn) : syn_scope. +Notation "x '*' y" := (__op x%syn Mult y%syn) : syn_scope. +Notation "'if' x 'then' y 'else' z" := (__if x%syn y%syn z%syn) : syn_scope. +Notation "'output' x" := (__output x%syn) (at level 60) : syn_scope. +Notation "'#' n" := (LitV n) (at level 60) : syn_scope. +Notation "'input'" := (Input) : syn_scope. +Notation "'rec' e" := (RecV e%syn) (at level 60) : syn_scope. +Notation "'$' fn" := (set_pure_resolver fn) (at level 60) : syn_scope. +Notation "□" := (EmptyK) : syn_scope. +Notation "K '⟪' e '⟫'" := (fill K%syn e%syn) (at level 60) : syn_scope. + +Definition LamV {S : Set} (e : expr (inc S)) : val S := + RecV (shift e). + +Notation "'λ' . e" := (LamV e%syn) (at level 60) : syn_scope. + +Definition LetE {S : Set} (e : expr S) (e' : expr (inc S)) : expr S := + App (LamV e') (e). + +Notation "'let_' e₁ 'in' e₂" := (LetE e₁%syn e₂%syn) (at level 60, right associativity) : syn_scope. + +Definition SeqE {S : Set} (e e' : expr S) : expr S := + App (LamV (shift e)) e'. + +Notation "e₁ ';;' e₂" := (SeqE e₁%syn e₂%syn) : syn_scope. + +Declare Scope typ_scope. +Delimit Scope typ_scope with typ. + +Notation "'ℕ'" := (Tnat) (at level 1) : typ_scope. +Notation "A →ₜ B" := (Tarr A%typ B%typ) + (right associativity, at level 60) : typ_scope. diff --git a/theories/input_lang/logpred.v b/theories/examples/input_lang/logpred.v similarity index 68% rename from theories/input_lang/logpred.v rename to theories/examples/input_lang/logpred.v index eb1da93..6f1471b 100644 --- a/theories/input_lang/logpred.v +++ b/theories/examples/input_lang/logpred.v @@ -1,11 +1,12 @@ (** Unary (Kripke) logical relation for the IO lang *) -From Equations Require Import Equations. -From gitrees Require Import gitree program_logic. -From gitrees.input_lang Require Import lang interp. +From gitrees Require Import gitree program_logic lang_generic. +From gitrees.examples.input_lang Require Import lang interp. +Require Import Binding.Lib Binding.Set Binding.Env. +Require Import gitrees.gitree.greifiers. Section io_lang. Context {sz : nat}. - Variable rs : gReifiers sz. + Variable rs : gReifiers NotCtxDep sz. Context `{!subReifier reify_io rs}. Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. @@ -15,21 +16,24 @@ Section io_lang. Context `{!invGS Σ, !stateG rs R Σ, !na_invG Σ}. Notation iProp := (iProp Σ). + Canonical Structure exprO S := leibnizO (expr S). + Canonical Structure valO S := leibnizO (val S). + Variable s : stuckness. - Context {A:ofe}. - Variable (P : A → iProp). - Context `{!NonExpansive P}. + Context {A : ofe}. + Variable (P : A -n> iProp). - Local Notation tyctx := (tyctx ty). Local Notation expr_pred := (expr_pred s rs P). Program Definition interp_tnat : ITV -n> iProp := λne αv, (∃ n : nat, αv ≡ RetV n)%I. Solve All Obligations with solve_proper. + Program Definition interp_tarr (Φ1 Φ2 : ITV -n> iProp) := λne αv, - (□ ∀ σ βv, has_substate σ -∗ - Φ1 βv -∗ - expr_pred (IT_of_V αv ⊙ (IT_of_V βv)) (λne v, ∃ σ', Φ2 v ∗ has_substate σ'))%I. + (□ ∀ σ βv, has_substate σ + -∗ Φ1 βv + -∗ expr_pred (IT_of_V αv ⊙ (IT_of_V βv)) + (λne v, ∃ σ', Φ2 v ∗ has_substate σ'))%I. Solve All Obligations with solve_proper. Fixpoint interp_ty (τ : ty) : ITV -n> iProp := @@ -38,45 +42,43 @@ Section io_lang. | Tarr τ1 τ2 => interp_tarr (interp_ty τ1) (interp_ty τ2) end. - Definition ssubst_valid {S} (Γ : tyctx S) ss := ssubst_valid rs interp_ty Γ ss. + Notation ssubst_valid := (ssubst_valid1 rs ty interp_ty expr_pred). #[global] Instance io_lang_interp_ty_pers τ βv : Persistent (io_lang.interp_ty τ βv). Proof. induction τ; apply _. Qed. - #[global] Instance ssubst_valid_pers {S} (Γ : tyctx S) ss : Persistent (ssubst_valid Γ ss). - Proof. apply _. Qed. - Program Definition valid1 {S} (Γ : tyctx S) (α : interp_scope S -n> IT) (τ : ty) : iProp := + Program Definition valid1 {S : Set} (Γ : S → ty) (α : interp_scope S -n> IT) (τ : ty) : iProp := (∀ σ ss, has_substate σ -∗ ssubst_valid Γ ss -∗ - expr_pred (α (interp_ssubst ss)) (λne v, ∃ σ', interp_ty τ v ∗ has_substate σ'))%I. + expr_pred (α ss) (λne v, ∃ σ', interp_ty τ v ∗ has_substate σ'))%I. Solve Obligations with solve_proper. - Lemma compat_nat {S} n (Ω : tyctx S) : + Lemma compat_nat {S : Set} n (Ω : S → ty) : ⊢ valid1 Ω (interp_nat rs n) Tnat. Proof. iIntros (σ αs) "Hs Has". simpl. iApply expr_pred_ret. simpl. eauto with iFrame. Qed. - Lemma compat_var {S} Ω τ (v : var S) : - typed_var Ω v τ → - ⊢ valid1 Ω (interp_var v) τ. + + Lemma compat_var {S : Set} (Ω : S → ty) (v : S) : + ⊢ valid1 Ω (interp_var v) (Ω v). Proof. - intros Hv. iIntros (σ ss) "Hs Has". simpl. - unfold ssubst_valid. - iInduction Hv as [|? ? ? Ω v] "IH" forall (ss); simpl. - - dependent elimination ss as [cons_ssubst αv ss]. - rewrite ssubst_valid_cons. - simp interp_var. simpl. - iDestruct "Has" as "[H _]". - iApply expr_pred_ret; simpl; eauto with iFrame. - - dependent elimination ss as [cons_ssubst αv ss]. - rewrite ssubst_valid_cons. - simp interp_var. simpl. - iDestruct "Has" as "[_ H]". - by iApply ("IH" with "Hs H"). + iIntros (x) "HP". + simpl. + iSpecialize ("Has" $! v x with "HP"). + iApply (wp_wand with "Has"). + iIntros (v') "HH". + simpl. + iDestruct "HH" as "(%y & HH & HP')". + iModIntro. + iExists y. + iFrame "HP'". + iExists σ. + iFrame. Qed. - Lemma compat_if {S} (Γ : tyctx S) τ α β1 β2 : + + Lemma compat_if {S : Set} (Γ : S → ty) τ α β1 β2 : ⊢ valid1 Γ α Tnat -∗ valid1 Γ β1 τ -∗ valid1 Γ β2 τ -∗ @@ -85,7 +87,8 @@ Section io_lang. iIntros "H0 H1 H2". iIntros (σ ss) "Hs #Has". iSpecialize ("H0" with "Hs Has"). - simpl. iApply (expr_pred_bind (IFSCtx _ _) with "H0"). + simpl. + iApply (expr_pred_bind (IFSCtx _ _) with "H0"). iIntros (αv) "Ha/=". iDestruct "Ha" as (σ') "[Ha Hs]". iDestruct "Ha" as (n) "Hn". @@ -97,7 +100,8 @@ Section io_lang. - rewrite IF_True; last lia. iApply ("H1" with "Hs Has Hx"). Qed. - Lemma compat_input {S} (Γ : tyctx S) : + + Lemma compat_input {S : Set} (Γ : S → ty) : ⊢ valid1 Γ (interp_input rs) Tnat. Proof. iIntros (σ ss) "Hs #Has". @@ -108,7 +112,8 @@ Section io_lang. iNext. iIntros "_ Hs". iApply wp_val. simpl. eauto with iFrame. Qed. - Lemma compat_output {S} (Γ : tyctx S) α : + + Lemma compat_output {S : Set} (Γ : S → ty) α : ⊢ valid1 Γ α Tnat → valid1 Γ (interp_output rs α) Tnat. Proof. iIntros "H". @@ -127,7 +132,8 @@ Section io_lang. iNext. iIntros "_ Hs /=". eauto with iFrame. Qed. - Lemma compat_app {S} (Γ : tyctx S) α β τ1 τ2 : + + Lemma compat_app {S : Set} (Γ : S → ty) α β τ1 τ2 : ⊢ valid1 Γ α (Tarr τ1 τ2) -∗ valid1 Γ β τ1 -∗ valid1 Γ (interp_app rs α β) τ2. @@ -147,15 +153,14 @@ Section io_lang. iApply ("Ha" with "Hs Hb"). Qed. - Lemma compat_rec {S} (Γ : tyctx S) τ1 τ2 α : - ⊢ □ valid1 (consC (Tarr τ1 τ2) (consC τ1 Γ)) α τ2 -∗ + Lemma compat_rec {S : Set} (Γ : S → ty) τ1 τ2 α : + ⊢ □ valid1 (Γ ▹ (Tarr τ1 τ2) ▹ τ1) α τ2 -∗ valid1 Γ (interp_rec rs α) (Tarr τ1 τ2). Proof. iIntros "#H". iIntros (σ ss) "Hs #Hss". - pose (env := (interp_ssubst ss)). fold env. - simp subst_expr. - pose (f := (ir_unf rs α env)). - iAssert (interp_rec rs α env ≡ IT_of_V $ FunV (Next f))%I as "Hf". + term_simpl. + pose (f := (ir_unf rs α ss)). + iAssert (interp_rec rs α ss ≡ IT_of_V $ FunV (Next f))%I as "Hf". { iPureIntro. apply interp_rec_unfold. } iRewrite "Hf". iApply expr_pred_ret. simpl. iExists _. iFrame. iModIntro. @@ -165,20 +170,30 @@ Section io_lang. iIntros (x) "Hx". iApply wp_lam. iNext. - pose (ss' := cons_ssubst (FunV (Next f)) (cons_ssubst βv ss)). + pose (ss' := (extend_scope (extend_scope ss (interp_rec rs α ss)) (IT_of_V βv))). iSpecialize ("H" $! _ ss' with "Hs []"). - { unfold ssubst_valid. - unfold ss'. - rewrite !ssubst_valid_cons. - by iFrame "IH Hw Hss". } - unfold f. simpl. - unfold ss'. simp interp_ssubst. - iAssert (IT_of_V (FunV (Next f)) ≡ interp_rec rs α env)%I as "Heq". + { + unfold ssubst_valid. + iIntros ([| [|]]); term_simpl. + - iModIntro; by iApply expr_pred_ret. + - iModIntro. + iRewrite "Hf". + iIntros (x') "Hx". + iApply wp_val. + iModIntro. + iExists x'. + iFrame "Hx". + iModIntro. + iApply "IH". + - iApply "Hss". + } + unfold f. + iAssert (IT_of_V (FunV (Next f)) ≡ interp_rec rs α ss)%I as "Heq". { rewrite interp_rec_unfold. done. } iRewrite -"Heq". by iApply "H". Qed. - Lemma compat_natop {S} (Γ : tyctx S) op α β : + Lemma compat_natop {S : Set} (Γ : S → ty) op α β : ⊢ valid1 Γ α Tnat -∗ valid1 Γ β Tnat -∗ valid1 Γ (interp_natop _ op α β) Tnat. @@ -203,15 +218,14 @@ Section io_lang. eauto with iFrame. Qed. - Lemma fundamental {S} (Γ : tyctx S) e τ : + Lemma fundamental {S : Set} (Γ : S → ty) e τ : typed Γ e τ → ⊢ valid1 Γ (interp_expr rs e) τ - with fundamental_val {S} (Γ : tyctx S) v τ : + with fundamental_val {S : Set} (Γ : S → ty) v τ : typed_val Γ v τ → ⊢ valid1 Γ (interp_val rs v) τ. Proof. - destruct 1. + by iApply fundamental_val. - + by iApply compat_var. - + iApply compat_rec; iApply fundamental; eauto. + + subst. by iApply compat_var. + iApply compat_app; iApply fundamental; eauto. + iApply compat_natop; iApply fundamental; eauto. + iApply compat_if; iApply fundamental; eauto. @@ -221,9 +235,10 @@ Section io_lang. + iApply compat_nat. + iApply compat_rec; iApply fundamental; eauto. Qed. - Lemma fundmanetal_closed (e : expr []) (τ : ty) : - typed empC e τ → - ⊢ valid1 empC (interp_expr rs e) τ. + + Lemma fundmanetal_closed (e : expr ∅) (τ : ty) : + typed □ e τ → + ⊢ valid1 □ (interp_expr rs e) τ. Proof. apply fundamental. Qed. End io_lang. @@ -231,14 +246,17 @@ End io_lang. Arguments interp_ty {_ _ _ _ _ _ _ _ _ _ _ _} τ. Arguments interp_tarr {_ _ _ _ _ _ _ _ _ _ _} Φ1 Φ2. -Local Definition rs : gReifiers _ := gReifiers_cons reify_io gReifiers_nil. +Local Definition rs : gReifiers NotCtxDep _ := gReifiers_cons reify_io gReifiers_nil. Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. -Lemma logpred_adequacy cr Σ R `{!Cofe R, SubOfe natO R}`{!invGpreS Σ}`{!statePreG rs R Σ} τ (α : unitO -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k : +Lemma logpred_adequacy cr Σ R `{!Cofe R, SubOfe natO R} + `{!invGpreS Σ} `{!statePreG rs R Σ} τ + (α : interp_scope ∅ -n> IT (gReifiers_ops rs) R) + (β : IT (gReifiers_ops rs) R) st st' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ}, - (£ cr ⊢ valid1 rs notStuck (λ _:unitO, True)%I empC α τ)%I) → - ssteps (gReifiers_sReifier rs) (α ()) st β st' k → + (£ cr ⊢ valid1 rs notStuck (λne _ : unitO, True)%I □ α τ)%I) → + ssteps (gReifiers_sReifier rs) (α ı_scope) st β st' k → (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) ∨ (∃ βv, IT_of_V βv ≡ β). Proof. @@ -254,7 +272,7 @@ Proof. { apply Hdisj. } { by rewrite Hb. } intros H1 H2. - exists (interp_ty (s:=notStuck) (P:=(λ _:unitO, True)) τ)%I. split. + exists (interp_ty (s:=notStuck) (P:=(λne _:unitO, True)) τ)%I. split. { apply _. } iIntros "[Hcr Hst]". iPoseProof (Hlog with "Hcr") as "Hlog". @@ -273,7 +291,10 @@ Proof. rewrite (eq_pi _ _ Heq eq_refl)//. } iSpecialize ("Hlog" $! σ with "Hs []"). - { iApply ssubst_valid_nil. } + { + iIntros (x). + destruct x. + } iSpecialize ("Hlog" $! tt with "[//]"). iApply (wp_wand with"Hlog"). iIntros ( βv). simpl. iDestruct 1 as (_) "[H _]". @@ -282,8 +303,8 @@ Proof. Qed. Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier rs)) natO) k : - typed empC e τ → - ssteps (gReifiers_sReifier rs) (interp_expr _ e ()) (σ,()) β st' k → + typed □ e τ → + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ, ()) β st' k → (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) ∨ (∃ βv, IT_of_V βv ≡ β). Proof. diff --git a/theories/input_lang/logrel.v b/theories/examples/input_lang/logrel.v similarity index 53% rename from theories/input_lang/logrel.v rename to theories/examples/input_lang/logrel.v index 534a185..30b1a2d 100644 --- a/theories/input_lang/logrel.v +++ b/theories/examples/input_lang/logrel.v @@ -1,11 +1,12 @@ (** Logical relation for adequacy for the IO lang *) -From Equations Require Import Equations. -From gitrees Require Import gitree. -From gitrees.input_lang Require Import lang interp. +From gitrees Require Import gitree lang_generic. +From gitrees.examples.input_lang Require Import lang interp. +Require Import gitrees.gitree.greifiers. +Require Import Binding.Lib Binding.Set Binding.Env. Section logrel. Context {sz : nat}. - Variable (rs : gReifiers sz). + Variable (rs : gReifiers NotCtxDep sz). Context {subR : subReifier reify_io rs}. Notation F := (gReifiers_ops rs). Notation IT := (IT F natO). @@ -16,7 +17,6 @@ Section logrel. Canonical Structure exprO S := leibnizO (expr S). Canonical Structure valO S := leibnizO (val S). - Local Notation tyctx := (tyctx ty). Notation "'WP' α {{ β , Φ } }" := (wp rs α notStuck ⊤ (λ β, Φ)) (at level 20, α, Φ at level 200, @@ -32,7 +32,7 @@ Section logrel. WP α {{ βv, ∃ m v σ', ⌜prim_steps e σ (Val v) σ' m⌝ ∗ V βv v ∗ has_substate σ' }})%I. Definition logrel_nat {S} (βv : ITV) (v : val S) : iProp := - (∃ n, βv ≡ RetV n ∧ ⌜v = Lit n⌝)%I. + (∃ n, βv ≡ RetV n ∧ ⌜v = LitV n⌝)%I. Definition logrel_arr {S} V1 V2 (βv : ITV) (vf : val S) : iProp := (∃ f, IT_of_V βv ≡ Fun f ∧ □ ∀ αv v, V1 αv v -∗ logrel_expr V2 (APP' (Fun f) (IT_of_V αv)) (App (Val vf) (Val v)))%I. @@ -99,8 +99,8 @@ Section logrel. by econstructor. Qed. - Lemma logrel_step_pure {S} (e' e : expr S) α V : - (∀ σ, prim_step e σ e' σ (0,0)) → + Lemma logrel_step_pure {S} n (e' e : expr S) α V : + (∀ σ, prim_step e σ e' σ (n,0)) → logrel_expr V α e' ⊢ logrel_expr V α e. Proof. intros Hpure. @@ -109,219 +109,167 @@ Section logrel. iSpecialize ("H" with "Hs"). iApply (wp_wand with "H"). iIntros (βv). iDestruct 1 as ([m m'] v σ' Hsteps) "[H2 Hs]". - iExists (m,m'),v,σ'. iFrame "H2 Hs". + iExists ((Nat.add n m),m'),v,σ'. iFrame "H2 Hs". iPureIntro. - eapply (prim_steps_app (0,0) (m,m')); eauto. + eapply (prim_steps_app (n,0) (m,m')); eauto. { eapply prim_step_steps, Hpure. } Qed. - (* a matching list of closing substitutions *) - Inductive subs2 : scope → Type := - | emp_subs2 : subs2 [] - | cons_subs2 {S} : val [] → ITV → subs2 S → subs2 (()::S) - . + Definition ssubst2_valid {S : Set} + (Γ : S -> ty) + (ss : @interp_scope F natO _ S) + (γ : S [⇒] Empty_set) : iProp := + (∀ x, □ logrel (Γ x) (ss x) (γ x))%I. - Equations subs_of_subs2 {S} (ss : subs2 S) : subs S [] := - subs_of_subs2 emp_subs2 v => idsub v; - subs_of_subs2 (cons_subs2 t α ss) Vz := Val t; - subs_of_subs2 (cons_subs2 t α ss) (Vs v) := subs_of_subs2 ss v. + Definition logrel_valid {S : Set} + (Γ : S -> ty) + (e : expr S) + (α : @interp_scope F natO _ S -n> IT) + (τ : ty) : iProp := + (□ ∀ (ss : @interp_scope F natO _ S) + (γ : S [⇒] Empty_set), + ssubst2_valid Γ ss γ → logrel τ (α ss) (bind γ e))%I. - Equations its_of_subs2 {S} (ss : subs2 S) : interp_scope (E:=F) (R:=natO) S := - its_of_subs2 emp_subs2 := (); - its_of_subs2 (cons_subs2 t α ss) := (IT_of_V α, its_of_subs2 ss). - - Equations list_of_subs2 {S} (ss : subs2 S) : list (val []*ITV) := - list_of_subs2 emp_subs2 := []; - list_of_subs2 (cons_subs2 v α ss) := (v,α)::(list_of_subs2 ss). - - Lemma subs_of_emp_subs2 : subs_of_subs2 emp_subs2 ≡ idsub. - Proof. intros v. dependent elimination v. Qed. - - Definition subs2_valid {S} (Γ : tyctx S) (ss : subs2 S) : iProp := - ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_subs2 ss), - logrel_val (τx.1) (τx.2.2) (τx.2.1))%I. - - Definition logrel_valid {S} (Γ : tyctx S) (e : expr S) (α : interp_scope S -n> IT) (τ : ty) : iProp := - (∀ ss, subs2_valid Γ ss → logrel τ - (α (its_of_subs2 ss)) - (subst_expr e (subs_of_subs2 ss)))%I. - - Lemma compat_var {S} (Γ : tyctx S) (x : var S) τ : - typed_var Γ x τ → ⊢ logrel_valid Γ (Var x) (interp_var x) τ. + Lemma compat_var {S : Set} (Γ : S → ty) (x : S): + ⊢ logrel_valid Γ (Var x) (interp_var x) (Γ x). Proof. - intros Hx. iIntros (ss) "Hss". - simp subst_expr. - iInduction Hx as [|Hx] "IH". - - dependent elimination ss. simp subs_of_subs2. - simp interp_var. rewrite /subs2_valid. - simp list_of_tyctx list_of_subs2 its_of_subs2. simpl. - iDestruct "Hss" as "[Hv Hss]". - iApply (logrel_of_val with "Hv"). - - dependent elimination ss. simp subs_of_subs2. - simp interp_var. rewrite /subs2_valid. - simp list_of_tyctx list_of_subs2 its_of_subs2. simpl. - iDestruct "Hss" as "[Hv Hss]". by iApply "IH". + iModIntro. iIntros (ss γ) "Hss". iApply "Hss". Qed. - Lemma compat_if {S} (Γ : tyctx S) (e0 e1 e2 : expr S) α0 α1 α2 τ : + Lemma compat_if {S : Set} (Γ : S → ty) (e0 e1 e2 : expr S) α0 α1 α2 τ : ⊢ logrel_valid Γ e0 α0 Tnat -∗ logrel_valid Γ e1 α1 τ -∗ logrel_valid Γ e2 α2 τ -∗ logrel_valid Γ (If e0 e1 e2) (interp_if rs α0 α1 α2) τ. Proof. - iIntros "H0 H1 H2". iIntros (ss) "#Hss". - simpl. simp subst_expr. - pose (s := (subs_of_subs2 ss)). fold s. + iIntros "#H0 #H1 #H2". + iModIntro. + iIntros (ss γ) "#Hss". + simpl. iSpecialize ("H0" with "Hss"). - iApply (logrel_bind (IFSCtx (α1 (its_of_subs2 ss)) (α2 (its_of_subs2 ss))) - [IfCtx (subst_expr e1 s) (subst_expr e2 s)] - with "H0"). + term_simpl. + iApply (@logrel_bind Empty_set + (IFSCtx (α1 ss) (α2 ss)) + (IfK EmptyK (bind γ e1) (bind γ e2)) _ (bind γ e0) (α0 ss) Tnat with "H0"). iIntros (v βv). iDestruct 1 as (n) "[Hb ->]". iRewrite "Hb". simpl. unfold IFSCtx. destruct (decide (0 < n)). - - rewrite IF_True//. + - rewrite IF_True; last done. iSpecialize ("H1" with "Hss"). iApply (logrel_step_pure with "H1"). - intros ?. apply (Ectx_step' []). + intros ?. apply (Ectx_step' EmptyK). econstructor; eauto. - rewrite IF_False; last lia. iSpecialize ("H2" with "Hss"). iApply (logrel_step_pure with "H2"). - intros ?. apply (Ectx_step' []). + intros ?. apply (Ectx_step' EmptyK). econstructor; eauto. lia. Qed. - Lemma compat_recV {S} Γ (e : expr (()::()::S)) τ1 τ2 α : - ⊢ □ logrel_valid (consC (Tarr τ1 τ2) (consC τ1 Γ)) e α τ2 -∗ + Lemma compat_recV {S : Set} (Γ : S -> ty) (e : expr (inc (inc S))) τ1 τ2 α : + ⊢ □ logrel_valid ((Γ ▹ (Tarr τ1 τ2) ▹ τ1)) e α τ2 -∗ logrel_valid Γ (Val $ RecV e) (interp_rec rs α) (Tarr τ1 τ2). Proof. - iIntros "#H". iIntros (ss) "#Hss". - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := (its_of_subs2 ss)). fold env. - simp subst_expr. - pose (f := (ir_unf rs α env)). + iIntros "#H !> %env %γ #Henv". + set (f := (ir_unf rs α env)). iAssert (interp_rec rs α env ≡ IT_of_V $ FunV (Next f))%I as "Hf". { iPureIntro. apply interp_rec_unfold. } iRewrite "Hf". - iApply logrel_of_val. iLöb as "IH". iSimpl. - iExists (Next f). iSplit; eauto. + Opaque IT_of_V. + iApply logrel_of_val; term_simpl. + iExists _. iSplit. + { iPureIntro. apply into_val. } iModIntro. - iIntros (βv w) "#Hw". - iAssert ((APP' (Fun $ Next f) (IT_of_V βv)) ≡ (Tick (ir_unf rs α env (IT_of_V βv))))%I - as "Htick". - { iPureIntro. rewrite APP_APP'_ITV. - rewrite APP_Fun. simpl. done. } - iRewrite "Htick". iClear "Htick". + iLöb as "IH". + iIntros (αv v) "#Hw". + rewrite APP_APP'_ITV APP_Fun laterO_map_Next -Tick_eq. + pose (ss' := (extend_scope (extend_scope env (interp_rec rs α env)) (IT_of_V αv))). + set (γ' := ((mk_subst (Val (rec bind ((γ ↑) ↑)%bind e)%syn)) + ∘ ((mk_subst (shift (Val v))) ∘ ((γ ↑) ↑)))%bind). + rewrite /logrel. + iSpecialize ("H" $! ss' γ'). + set (γ1 := ((γ ↑) ↑)%bind). + iApply (logrel_step_pure 1 ((bind γ' e)%syn) with "[]"). + { + intros ?. eapply (Ectx_step' EmptyK). term_simpl. subst γ1 γ'. + rewrite -!bind_bind_comp'. + apply BetaS. + } + rewrite {2}/ss'. rewrite /f. iIntros (σ) "Hs". - iApply wp_tick. iNext. simpl. - pose (ss' := cons_subs2 (RecV (subst_expr e (subs_lift (subs_lift s)))) (FunV (Next (ir_unf rs α env))) (cons_subs2 w βv ss)). - iSpecialize ("H" $! ss' with "[Hss]"). - { rewrite {2}/subs2_valid /ss'. simp list_of_tyctx list_of_subs2. - cbn-[logrel_val]. iFrame "Hss Hw". fold f. iRewrite -"Hf". - by iApply "IH". } - iSpecialize ("H" with "Hs"). - iClear "IH Hss Hw". - unfold ss'. simpl. simp its_of_subs2. fold f env. - iRewrite "Hf". simpl. - iApply (wp_wand with "H"). - iIntros (v). - iDestruct 1 as ([m m'] v0 σ0 Hsteps) "[Hv Hs]". - iExists (1+m,0+m'),v0,σ0. iFrame "Hv Hs". - iPureIntro. econstructor; eauto. - apply (Ectx_step' []). - apply BetaS. - clear. - unfold subst2. - rewrite subst_expr_appsub. - apply subst_expr_proper. - intro v. - dependent elimination v. - { simp subs_of_subs2. unfold appsub. - simp subs_lift. simp subst_expr. - simp conssub. reflexivity. } - dependent elimination v. - { simp subs_of_subs2. unfold appsub. - simp subs_lift. unfold expr_lift. - simp ren_expr. simp subst_expr. - simp conssub. reflexivity. } - { simp subs_of_subs2. unfold appsub. - simp subs_lift. unfold expr_lift. - fold s. remember (s v) as e1. - rewrite ren_ren_expr. - rewrite subst_ren_expr. - trans (subst_expr e1 idsub). - - symmetry. apply subst_expr_idsub. - - apply subst_expr_proper. - intro v'. simpl. simp conssub. - reflexivity. } + iApply wp_tick. iNext. + iApply "H"; eauto; iClear "H". + rewrite /ss' /γ'. + iIntros (x'); destruct x' as [| [| x']]; term_simpl; iModIntro. + * by iApply logrel_of_val. + * iRewrite "Hf". + iApply logrel_of_val. + simpl. + iExists (Next (ir_unf rs α env)). + iSplit; first done. + iModIntro. + iApply "IH". + * iApply "Henv". Qed. - Lemma compat_rec {S} Γ (e : expr (()::()::S)) τ1 τ2 α : - ⊢ □ logrel_valid (consC (Tarr τ1 τ2) (consC τ1 Γ)) e α τ2 -∗ - logrel_valid Γ (Rec e) (interp_rec rs α) (Tarr τ1 τ2). - Proof. - iIntros "#H". iIntros (ss) "#Hss". - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := (its_of_subs2 ss)). fold env. - simp subst_expr. - iApply (logrel_step_pure (Val (RecV (subst_expr e (subs_lift (subs_lift s)))))). - { intros ?. eapply (Ectx_step' []). econstructor. } - iPoseProof (compat_recV with "H") as "H2". - iSpecialize ("H2" with "Hss"). - simp subst_expr. iApply "H2". - Qed. - - Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : + Lemma compat_app {S : Set} (Γ : S → ty) (e1 e2 : expr S) τ1 τ2 α1 α2 : ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ logrel_valid Γ e2 α2 τ1 -∗ logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. Proof. - iIntros "H1 H2". iIntros (ss) "#Hss". + iIntros "#H1 #H2". + iIntros (ss). + iModIntro. + iIntros (γ). + iIntros "#Hss". iSpecialize ("H1" with "Hss"). iSpecialize ("H2" with "Hss"). - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := its_of_subs2 ss). fold env. - simp subst_expr. simpl. - iApply (logrel_bind (AppRSCtx (α1 env)) [AppRCtx (subst_expr e1 s)] with "H2"). - iIntros (v2 β2) "H2". iSimpl. - iApply (logrel_bind (AppLSCtx (IT_of_V β2)) [AppLCtx v2] with "H1"). - iIntros (v1 β1) "H1". simpl. - iDestruct "H1" as (f) "[Hα H1]". + unfold interp_app. simpl. - unfold AppLSCtx. iRewrite "Hα". (** XXX why doesn't simpl work here? *) - iApply ("H1" with "H2"). + assert ((bind γ (App e1 e2))%syn = (fill (AppRK (bind γ e1) EmptyK) (bind γ e2))) as ->. + { reflexivity. } + iApply (logrel_bind (AppRSCtx (α1 ss)) (AppRK (bind γ e1) EmptyK) with "H2"). + iIntros (v2 β2) "#H2'". iSimpl. + iApply (logrel_bind (AppLSCtx (IT_of_V β2)) (AppLK EmptyK v2) with "H1"). + iIntros (v1 β1) "#H1'". iSimpl. + iDestruct "H1'" as (f) "[Hα H1']". + simpl. + unfold AppLSCtx. iRewrite "Hα". + iApply ("H1'" with "H2'"). Qed. - Lemma compat_input {S} Γ : + Lemma compat_input {S : Set} (Γ : S → ty) : ⊢ logrel_valid Γ (Input : expr S) (interp_input rs) Tnat. Proof. - iIntros (ss) "Hss". + iModIntro. + iIntros (ss γ) "Hss". iIntros (σ) "Hs". destruct (update_input σ) as [n σ'] eqn:Hinp. iApply (wp_input with "Hs []"); first eauto. iNext. iIntros "Hlc Hs". iApply wp_val. - iExists (1,1),(Lit n),σ'. + iExists (1,1),(LitV n),σ'. iFrame "Hs". iModIntro. iSplit. { iPureIntro. - simp subst_expr. + term_simpl. apply prim_step_steps. - apply (Ectx_step' []). - by constructor. } + apply (Ectx_step' EmptyK). + by constructor. + } iExists n. eauto. Qed. - Lemma compat_output {S} Γ (e: expr S) α : + + Lemma compat_output {S : Set} (Γ : S → ty) (e: expr S) α : ⊢ logrel_valid Γ e α Tnat -∗ logrel_valid Γ (Output e) (interp_output rs α) Tnat. Proof. - iIntros "H1". - iIntros (ss) "Hss". + iIntros "#H1". + iModIntro. + iIntros (ss γ) "#Hss". iSpecialize ("H1" with "Hss"). - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := its_of_subs2 ss). fold env. - simp subst_expr. simpl. - iApply (logrel_bind (get_ret _) [OutputCtx] with "H1"). + term_simpl. + iApply (logrel_bind (get_ret _) (OutputK EmptyK) with "H1"). iIntros (v βv). iDestruct 1 as (m) "[Hb ->]". iRewrite "Hb". simpl. @@ -329,55 +277,53 @@ Section logrel. rewrite get_ret_ret. iApply (wp_output with "Hs []"); first done. iNext. iIntros "Hlc Hs". - iExists (1,1),(Lit 0),_. + iExists (1,1),(LitV 0),_. iFrame "Hs". iSplit. { iPureIntro. apply prim_step_steps. - apply (Ectx_step' []). + apply (Ectx_step' EmptyK). by constructor. } iExists 0. eauto. Qed. - Lemma compat_natop {S} (Γ : tyctx S) e1 e2 α1 α2 op : + Lemma compat_natop {S : Set} (Γ : S → ty) e1 e2 α1 α2 op : ⊢ logrel_valid Γ e1 α1 Tnat -∗ logrel_valid Γ e2 α2 Tnat -∗ logrel_valid Γ (NatOp op e1 e2) (interp_natop rs op α1 α2) Tnat. Proof. - iIntros "H1 H2". iIntros (ss) "#Hss". + iIntros "#H1 #H2". iModIntro. iIntros (ss γ) "#Hss". iSpecialize ("H1" with "Hss"). iSpecialize ("H2" with "Hss"). - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := its_of_subs2 ss). fold env. - simp subst_expr. simpl. - iApply (logrel_bind (NatOpRSCtx (do_natop op) (α1 env)) [NatOpRCtx op (subst_expr e1 s)] with "H2"). - iIntros (v2 β2) "H2". iSimpl. - iApply (logrel_bind (NatOpLSCtx (do_natop op) (IT_of_V β2)) [NatOpLCtx op v2] with "H1"). - iIntros (v1 β1) "H1". simpl. - iDestruct "H1" as (n1) "[Hn1 ->]". - iDestruct "H2" as (n2) "[Hn2 ->]". + term_simpl. + iApply (logrel_bind (NatOpRSCtx (do_natop op) (α1 ss)) (NatOpRK op (bind γ e1) EmptyK) with "H2"). + iIntros (v2 β2) "H2'". iSimpl. + iApply (logrel_bind (NatOpLSCtx (do_natop op) (IT_of_V β2)) (NatOpLK op EmptyK v2) with "H1"). + iIntros (v1 β1) "H1'". simpl. + iDestruct "H1'" as (n1) "[Hn1 ->]". + iDestruct "H2'" as (n2) "[Hn2 ->]". unfold NatOpLSCtx. iAssert ((NATOP (do_natop op) (IT_of_V β1) (IT_of_V β2)) ≡ Ret (do_natop op n1 n2))%I with "[Hn1 Hn2]" as "Hr". { iRewrite "Hn1". simpl. iRewrite "Hn2". simpl. iPureIntro. by rewrite NATOP_Ret. } - iApply (logrel_step_pure (Val (Lit (do_natop op n1 n2)))). - { intro. apply (Ectx_step' []). constructor. + iApply (logrel_step_pure _ (Val (LitV (do_natop op n1 n2)))). + { intro. apply (Ectx_step' EmptyK). constructor. destruct op; simpl; eauto. } iRewrite "Hr". iApply (logrel_of_val (RetV $ do_natop op n1 n2)). iExists _. iSplit; eauto. Qed. - Lemma fundamental {S} (Γ : tyctx S) τ e : + Lemma fundamental {S : Set} (Γ : S → ty) τ e : typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ - with fundamental_val {S} (Γ : tyctx S) τ v : + with fundamental_val {S : Set} (Γ : S → ty) τ v : typed_val Γ v τ → ⊢ logrel_valid Γ (Val v) (interp_val rs v) τ. Proof. - induction 1; simpl. + by apply fundamental_val. - + by apply compat_var. - + iApply compat_rec. iApply IHtyped. + + subst. + by apply compat_var. + iApply compat_app. ++ iApply IHtyped1. ++ iApply IHtyped2. @@ -392,7 +338,7 @@ Section logrel. + iApply compat_output. iApply IHtyped. - induction 1; simpl. - + iIntros (ss) "Hss". simp subst_expr. simpl. + + iModIntro. iIntros (ss γ) "Hss". term_simpl. iApply (logrel_of_val (RetV n)). iExists n. eauto. + iApply compat_recV. by iApply fundamental. Qed. @@ -401,19 +347,19 @@ End logrel. Definition κ {S} {E} : ITV E natO → val S := λ x, match x with - | core.RetV n => Lit n - | _ => Lit 0 + | core.RetV n => LitV n + | _ => LitV 0 end. -Lemma κ_Ret {S} {E} n : κ ((RetV n) : ITV E natO) = (Lit n : val S). +Lemma κ_Ret {S} {E} n : κ ((RetV n) : ITV E natO) = (LitV n : val S). Proof. Transparent RetV. unfold RetV. simpl. done. Opaque RetV. Qed. -Definition rs : gReifiers 1 := gReifiers_cons reify_io gReifiers_nil. +Definition rs : gReifiers NotCtxDep 1 := gReifiers_cons reify_io gReifiers_nil. Lemma logrel_nat_adequacy Σ `{!invGpreS Σ}`{!statePreG rs natO Σ} {S} (α : IT (gReifiers_ops rs) natO) (e : expr S) n σ σ' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (True ⊢ logrel rs Tnat α e)%I) → - ssteps (gReifiers_sReifier rs) α (σ,()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ Lit n) σ' m. + ssteps (gReifiers_sReifier rs) α (σ,()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. Proof. intros Hlog Hst. pose (ϕ := λ (βv : ITV (gReifiers_ops rs) natO), @@ -423,8 +369,8 @@ Proof. exists m', σ2. revert Hm. by rewrite κ_Ret. } eapply (wp_adequacy 0); eauto. intros Hinv1 Hst1. - pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (Lit n) - ∗ ⌜∃ m σ', prim_steps e σ (Val $ Lit n) σ' m⌝)%I). + pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (LitV n) + ∗ ⌜∃ m σ', prim_steps e σ (Val $ LitV n) σ' m⌝)%I). assert (NonExpansive Φ). { unfold Φ. intros l a1 a2 Ha. repeat f_equiv. done. } @@ -446,7 +392,7 @@ Proof. iAssert (has_substate σ) with "[Hs]" as "Hs". { unfold has_substate, has_full_state. assert (of_state rs (IT (gReifiers_ops rs) natO) (σ, ()) ≡ - of_idx rs (IT (gReifiers_ops rs) natO) sR_idx (sR_state σ)) as -> ; last done. + of_idx rs (IT (gReifiers_ops rs) natO) 0 σ)%stdpp as ->; last done. intro j. unfold sR_idx. simpl. unfold of_state, of_idx. destruct decide as [Heq|]; last first. @@ -465,24 +411,22 @@ Proof. iExists l. iSplit; eauto. Qed. - -Theorem adequacy (e : expr []) (k : nat) σ σ' n : - typed empC e Tnat → - ssteps (gReifiers_sReifier rs) (interp_expr rs e ()) (σ,()) (Ret k : IT _ natO) σ' n → - ∃ mm σ', prim_steps e σ (Val $ Lit k) σ' mm. +Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : + typed □ e Tnat → + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ,()) (Ret k : IT _ natO) σ' n → + ∃ mm σ', prim_steps e σ (Val $ LitV k) σ' mm. Proof. intros Hty Hst. pose (Σ:=#[invΣ;stateΣ rs natO]). - eapply (logrel_nat_adequacy Σ (interp_expr rs e ())); last eassumption. + eapply (logrel_nat_adequacy Σ (interp_expr rs e ı_scope)); last eassumption. intros ? ?. iPoseProof (fundamental rs) as "H". { apply Hty. } unfold logrel_valid. iIntros "_". - iSpecialize ("H" $! (emp_subs2 rs)). - simp its_of_subs2. - rewrite subs_of_emp_subs2. - rewrite subst_expr_idsub. + iSpecialize ("H" $! ı_scope ı%bind with "[]"). + { iIntros (x); destruct x. } + rewrite ebind_id; first last. + { intros ?; reflexivity. } iApply "H". - unfold subs2_valid. done. Qed. diff --git a/theories/examples/input_lang_callcc/hom.v b/theories/examples/input_lang_callcc/hom.v new file mode 100644 index 0000000..17d197e --- /dev/null +++ b/theories/examples/input_lang_callcc/hom.v @@ -0,0 +1,132 @@ +(** In this module, we package up IT homomorphism in a sigma type, and +we will use it as a domain for logical relations on continuations *) +From gitrees Require Import gitree lang_generic. +From gitrees.examples.input_lang_callcc Require Import lang interp. +Require Import Binding.Lib Binding.Set Binding.Env. + +Open Scope stdpp_scope. + +Section hom. + Context {sz : nat}. + Context {rs : gReifiers CtxDep sz}. + Context `{!subReifier reify_cont rs}. + Context `{!subReifier (sReifier_NotCtxDep_CtxDep reify_io) rs}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F natO). + Notation ITV := (ITV F natO). + + Definition HOM : ofe := @sigO (IT -n> IT) IT_hom. + + Global Instance HOM_hom (κ : HOM) : IT_hom (`κ). + Proof. + apply (proj2_sig κ). + Qed. + + Program Definition HOM_id : HOM := exist _ idfun _. + Next Obligation. + apply _. + Qed. + + Lemma HOM_ccompose (f g : HOM) : + ∀ α, `f (`g α) = (`f ◎ `g) α. + Proof. + intro; reflexivity. + Qed. + + Program Definition HOM_compose (f g : HOM) : HOM := exist _ (`f ◎ `g) _. + Next Obligation. + intros f g; simpl. + apply _. + Qed. + + Lemma HOM_compose_ccompose (f g h : HOM) : + h = HOM_compose f g -> + `f ◎ `g = `h. + Proof. intros ->. done. Qed. + + (** Specific packaged homomorphisms *) + Program Definition IFSCtx_HOM α β : HOM := exist _ (λne x, IFSCtx α β x) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition NatOpRSCtx_HOM {S : Set} (op : nat_op) + (α : @interp_scope F natO _ S -n> IT) (env : @interp_scope F natO _ S) + : HOM := exist _ (interp_natoprk rs op α (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition NatOpLSCtx_HOM {S : Set} (op : nat_op) + (α : IT) (env : @interp_scope F natO _ S) + (Hv : AsVal α) + : HOM := exist _ (interp_natoplk rs op (λne env, idfun) (constO α) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition ThrowLSCtx_HOM {S : Set} + (α : @interp_scope F natO _ S -n> IT) + (env : @interp_scope F natO _ S) + : HOM := exist _ ((interp_throwlk rs (λne env, idfun) α env)) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition ThrowRSCtx_HOM {S : Set} + (β : IT) (env : @interp_scope F natO _ S) + (Hv : AsVal β) + : HOM := exist _ (interp_throwrk rs (constO β) (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - solve_proper_please. + - destruct Hv as [? <-]. + rewrite ->2 get_val_ITV. + simpl. by rewrite get_fun_tick. + - destruct Hv as [x Hv]. + rewrite <- Hv. + rewrite -> get_val_ITV. + simpl. + rewrite get_fun_vis. + repeat f_equiv. + intro; simpl. + rewrite <- Hv. + by rewrite -> get_val_ITV. + - destruct Hv as [? <-]. + rewrite get_val_ITV. + simpl. + by rewrite get_fun_err. + Qed. + + Program Definition OutputSCtx_HOM {S : Set} + (env : @interp_scope F natO _ S) + : HOM := exist _ ((interp_outputk rs (λne env, idfun) env)) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition AppRSCtx_HOM {S : Set} + (α : @interp_scope F natO _ S -n> IT) + (env : @interp_scope F natO _ S) + : HOM := exist _ (interp_apprk rs α (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition AppLSCtx_HOM {S : Set} + (β : IT) (env : @interp_scope F natO _ S) + (Hv : AsVal β) + : HOM := exist _ (interp_applk rs (λne env, idfun) (constO β) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + +End hom. diff --git a/theories/examples/input_lang_callcc/interp.v b/theories/examples/input_lang_callcc/interp.v new file mode 100644 index 0000000..e87f55d --- /dev/null +++ b/theories/examples/input_lang_callcc/interp.v @@ -0,0 +1,1054 @@ +From gitrees Require Import gitree lang_generic effects.io_tape. +From gitrees.examples.input_lang_callcc Require Import lang. +Require Import Binding.Lib Binding.Set. + +Program Definition callccE : opInterp := + {| + Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙); + Outs := (▶ ∙); + |}. +Program Definition throwE : opInterp := + {| + Ins := (▶ ∙ * (▶ (∙ -n> ∙))); + Outs := Empty_setO; + |}. + +Definition contE := @[callccE;throwE]. + +Definition reify_callcc X `{Cofe X} : ((laterO X -n> laterO X) -n> laterO X) * + unitO * (laterO X -n> laterO X) → + option (laterO X * unitO) := + λ '(f, σ, k), Some ((k (f k): laterO X), σ : unitO). +#[export] Instance reify_callcc_ne X `{Cofe X} : + NonExpansive (reify_callcc X : + prodO (prodO ((laterO X -n> laterO X) -n> laterO X) unitO) + (laterO X -n> laterO X) → + optionO (prodO (laterO X) unitO)). +Proof. intros ?[[]][[]][[]]. simpl in *. repeat f_equiv; auto. Qed. + +Definition reify_throw X `{Cofe X} : + ((laterO X * (laterO (X -n> X))) * unitO * (Empty_setO -n> laterO X)) → + option (laterO X * unitO) := + λ '((e, k'), σ, _), + Some (((laterO_ap k' : laterO X -n> laterO X) e : laterO X), σ : unitO). +#[export] Instance reify_throw_ne X `{Cofe X} : + NonExpansive (reify_throw X : + prodO (prodO (prodO (laterO X) (laterO (X -n> X))) unitO) + (Empty_setO -n> laterO X) → + optionO (prodO (laterO X) (unitO))). +Proof. + intros ?[[[]]][[[]]]?. rewrite /reify_throw. + repeat f_equiv; apply H0. +Qed. + +Canonical Structure reify_cont : sReifier CtxDep. +Proof. + simple refine {| sReifier_ops := contE; + sReifier_state := unitO + |}. + intros X HX op. + destruct op as [|[|[]]]; simpl. + - simple refine (OfeMor (reify_callcc X)). + - simple refine (OfeMor (reify_throw X)). +Defined. + +Section constructors. + Context {E : opsInterp} {A} `{!Cofe A}. + Context {subEff0 : subEff contE E}. + Notation IT := (IT E A). + Notation ITV := (ITV E A). + + Program Definition CALLCC_ : ((laterO IT -n> laterO IT) -n> laterO IT) -n> + (laterO IT -n> laterO IT) -n> + IT := + λne f k, Vis (E:=E) (subEff_opid (inl ())) + (subEff_ins (F:=contE) (op:=(inl ())) f) + (k ◎ (subEff_outs (F:=contE) (op:=(inl ())))^-1). + Solve All Obligations with solve_proper. + + Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := + λne f, CALLCC_ f (idfun). + Solve Obligations with solve_proper. + + Lemma hom_CALLCC_ k e f `{!IT_hom f} : + f (CALLCC_ e k) ≡ CALLCC_ e (laterO_map (OfeMor f) ◎ k). + Proof. + unfold CALLCC_. + rewrite hom_vis/=. + f_equiv. by intro. + Qed. + + Program Definition THROW : IT -n> (laterO (IT -n> IT)) -n> IT := + λne e k, Vis (E:=E) (subEff_opid (inr (inl ()))) + (subEff_ins (F:=contE) (op:=(inr (inl ()))) + (NextO e, k)) + (λne x, Empty_setO_rec _ ((subEff_outs (F:=contE) (op:=(inr (inl ()))))^-1 x)). + Next Obligation. + solve_proper_prepare. + destruct ((subEff_outs ^-1) x). + Qed. + Next Obligation. + intros; intros ???; simpl. + repeat f_equiv. assumption. + Qed. + Next Obligation. + intros ?????; simpl. + repeat f_equiv; assumption. + Qed. + +End constructors. + +Section weakestpre. + Context {sz : nat}. + Variable (rs : gReifiers CtxDep sz). + Context {subR : subReifier reify_cont rs}. + Notation F := (gReifiers_ops rs). + Context {R} `{!Cofe R}. + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Implicit Type σ : unitO. + Implicit Type κ : IT -n> IT. + Implicit Type x : IT. + + Lemma wp_throw' σ κ (f : IT -n> IT) (x : IT) + `{!IT_hom κ} Φ s : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} f x @ s {{ Φ }}) -∗ + WP@{rs} κ (THROW x (Next f)) @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". rewrite /THROW. simpl. + rewrite hom_vis. + iApply (wp_subreify_ctx_dep with "Hs"); simpl; done. + Qed. + + Lemma wp_throw σ (f : IT -n> IT) (x : IT) Φ s : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} f x @ s {{ Φ }}) -∗ + WP@{rs} (THROW x (Next f)) @ s {{ Φ }}. + Proof. + iApply (wp_throw' _ idfun). + Qed. + + Lemma wp_callcc σ (f : (laterO IT -n> laterO IT) -n> laterO IT) (k : IT -n> IT) {Hk : IT_hom k} β Φ s : + f (laterO_map k) ≡ Next β → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k β @ s {{ Φ }}) -∗ + WP@{rs} (k (CALLCC f)) @ s {{ Φ }}. + Proof. + iIntros (Hp) "Hs Ha". + unfold CALLCC. simpl. + rewrite hom_vis. + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (laterO_map k (Next β)) with "Hs"). + { + simpl. rewrite -Hp. repeat f_equiv; last done. + rewrite ccompose_id_l. rewrite ofe_iso_21. + repeat f_equiv. intro. + simpl. f_equiv. + apply ofe_iso_21. + } + { + simpl. by rewrite later_map_Next. + } + iModIntro. + iApply "Ha". + Qed. + + (* XXX TODO: this duplicates wp_input and wp_output *) + Context `{!subReifier (sReifier_NotCtxDep_CtxDep reify_io) rs}. + Context `{!SubOfe natO R}. + Lemma wp_input' (σ σ' : stateO) (n : nat) (k : natO -n> IT) (κ : IT -n> IT) + `{!IT_hom κ} Φ s : + update_input σ = (n, σ') -> + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (κ ◎ k $ n) @ s {{ Φ }}) -∗ + WP@{rs} κ (INPUT k) @ s {{ Φ }}. + Proof. + iIntros (Hσ) "Hs Ha". + rewrite hom_INPUT. + iApply (wp_subreify_ctx_dep with "Hs"). + + simpl. rewrite Hσ. simpl. done. + + by rewrite ofe_iso_21. + + done. + Qed. + Lemma wp_output' (σ σ' : stateO) (n : nat) (κ : IT -n> IT) + `{!IT_hom κ} Φ s : + update_output n σ = σ' → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (κ (Ret 0)) @ s {{ Φ }}) -∗ + WP@{rs} κ (OUTPUT n) @ s {{ Φ }}. + Proof. + iIntros (Hσ) "Hs Ha". + rewrite /OUTPUT hom_OUTPUT_. + iApply (wp_subreify_ctx_dep with "Hs"). + + simpl. by rewrite Hσ. + + done. + + done. + Qed. + +End weakestpre. + +Section interp. + Context {sz : nat}. + Variable (rs : gReifiers CtxDep sz). + Context {subR1 : subReifier reify_cont rs}. + Context {subR2 : subReifier (sReifier_NotCtxDep_CtxDep reify_io) rs}. + Context {R} `{CR : !Cofe R}. + Context `{!SubOfe natO R}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + + Global Instance denot_cont_ne (κ : IT -n> IT) : + NonExpansive (λ x : IT, Tau (laterO_map κ (Next x))). + Proof. + solve_proper. + Qed. + + (** Interpreting individual operators *) + Program Definition interp_input {A} : A -n> IT := + λne env, INPUT Ret. + Program Definition interp_output {A} (t : A -n> IT) : A -n> IT := + get_ret OUTPUT ◎ t. + Local Instance interp_ouput_ne {A} : NonExpansive2 (@interp_output A). + Proof. solve_proper. Qed. + + Program Definition interp_callcc {S} + (e : @interp_scope F R _ (inc S) -n> IT) : interp_scope S -n> IT := + λne env, CALLCC (λne (f : laterO IT -n> laterO IT), + (Next (e (@extend_scope F R _ _ env + (Fun (Next (λne x, Tau (f (Next x))))))))). + Next Obligation. + solve_proper. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros [| a]; simpl; last solve_proper. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + intros [| a]; simpl; last solve_proper. + repeat f_equiv. + Qed. + + Program Definition interp_throw {A} (e : A -n> IT) (k : A -n> IT) + : A -n> IT := + λne env, get_val (λne x, get_fun (λne (f : laterO (IT -n> IT)), + THROW x f) (k env)) (e env). + Next Obligation. + solve_proper. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intro; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv; last done. + intro; simpl. + by repeat f_equiv. + Qed. + + Program Definition interp_natop {A} (op : nat_op) (t1 t2 : A -n> IT) : A -n> IT := + λne env, NATOP (do_natop op) (t1 env) (t2 env). + Solve All Obligations with solve_proper_please. + + Global Instance interp_natop_ne A op : NonExpansive2 (@interp_natop A op). + Proof. solve_proper. Qed. + Typeclasses Opaque interp_natop. + + Opaque laterO_map. + Program Definition interp_rec_pre {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) + : laterO (@interp_scope F R _ S -n> IT) -n> @interp_scope F R _ S -n> IT := + λne self env, Fun $ laterO_map (λne (self : @interp_scope F R _ S -n> IT) (a : IT), + body (@extend_scope F R _ _ (@extend_scope F R _ _ env (self env)) a)) self. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + do 3 f_equiv; intros ??; simpl; f_equiv; + intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + by do 2 f_equiv. + Qed. + + Program Definition interp_rec {S : Set} + (body : @interp_scope F R _ (inc (inc S)) -n> IT) : + @interp_scope F R _ S -n> IT := + mmuu (interp_rec_pre body). + + Program Definition ir_unf {S : Set} + (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : IT -n> IT := + λne a, body (@extend_scope F R _ _ + (@extend_scope F R _ _ env (interp_rec body env)) + a). + Next Obligation. + intros. + solve_proper_prepare. + f_equiv. intros [| [| y']]; simpl; solve_proper. + Qed. + + Lemma interp_rec_unfold {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : + interp_rec body env ≡ Fun $ Next $ ir_unf body env. + Proof. + trans (interp_rec_pre body (Next (interp_rec body)) env). + { f_equiv. rewrite /interp_rec. apply mmuu_unfold. } + simpl. rewrite laterO_map_Next. repeat f_equiv. + simpl. unfold ir_unf. intro. simpl. reflexivity. + Qed. + + Program Definition interp_app {A} (t1 t2 : A -n> IT) : A -n> IT := + λne env, APP' (t1 env) (t2 env). + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Global Instance interp_app_ne A : NonExpansive2 (@interp_app A). + Proof. solve_proper. Qed. + Typeclasses Opaque interp_app. + + Program Definition interp_if {A} (t0 t1 t2 : A -n> IT) : A -n> IT := + λne env, IF (t0 env) (t1 env) (t2 env). + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Global Instance interp_if_ne A n : + Proper ((dist n) ==> (dist n) ==> (dist n) ==> (dist n)) (@interp_if A). + Proof. solve_proper. Qed. + + Program Definition interp_nat (n : nat) {A} : A -n> IT := + λne env, Ret n. + + Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := + λne env, (Fun (Next (λne x, Tau (laterO_map (K env) (Next x))))). + Solve All Obligations with solve_proper_please. + + Program Definition interp_applk {A} + (K : A -n> (IT -n> IT)) + (q : A -n> IT) + : A -n> (IT -n> IT) := + λne env t, interp_app (λne env, K env t) q env. + Solve All Obligations with solve_proper. + + Program Definition interp_apprk {A} + (q : A -n> IT) + (K : A -n> (IT -n> IT)) + : A -n> (IT -n> IT) := + λne env t, interp_app q (λne env, K env t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoprk {A} (op : nat_op) + (q : A -n> IT) + (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := + λne env t, interp_natop op q (λne env, K env t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoplk {A} (op : nat_op) + (K : A -n> (IT -n> IT)) + (q : A -n> IT) : A -n> (IT -n> IT) := + λne env t, interp_natop op (λne env, K env t) q env. + Solve All Obligations with solve_proper. + + Program Definition interp_ifk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) + (p : A -n> IT) : A -n> (IT -n> IT) := + λne env t, interp_if (λne env, K env t) q p env. + Solve All Obligations with solve_proper. + + Program Definition interp_outputk {A} (K : A -n> (IT -n> IT)) : + A -n> (IT -n> IT) := + λne env t, interp_output (λne env, K env t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_throwlk {A} (K : A -n> (IT -n> IT)) (k : A -n> IT) : + A -n> (IT -n> IT) := + λne env t, interp_throw (λne env, K env t) k env. + Solve All Obligations with solve_proper_please. + + Program Definition interp_throwrk {A} (e : A -n> IT) (K : A -n> (IT -n> IT)) : + A -n> (IT -n> IT) := + λne env t, interp_throw e (λne env, K env t) env. + Solve All Obligations with solve_proper_please. + + (** Interpretation for all the syntactic categories: values, expressions, contexts *) + Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := + match v with + | LitV n => interp_nat n + | RecV e => interp_rec (interp_expr e) + | ContV K => interp_cont (interp_ectx K) + end + with interp_expr {S} (e : expr S) : interp_scope S -n> IT := + match e with + | Val v => interp_val v + | Var x => interp_var x + | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) + | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) + | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) + | Input => interp_input + | Output e => interp_output (interp_expr e) + | Callcc e => interp_callcc (interp_expr e) + | Throw e1 e2 => interp_throw (interp_expr e1) (interp_expr e2) + end + with interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := + match K with + | EmptyK => λne env, idfun + | AppRK e1 K => interp_apprk (interp_expr e1) (interp_ectx K) + | AppLK K v2 => interp_applk (interp_ectx K) (interp_val v2) + | NatOpRK op e1 K => interp_natoprk op (interp_expr e1) (interp_ectx K) + | NatOpLK op K v2 => interp_natoplk op (interp_ectx K) (interp_val v2) + | IfK K e1 e2 => interp_ifk (interp_ectx K) (interp_expr e1) (interp_expr e2) + | OutputK K => interp_outputk (interp_ectx K) + | ThrowLK K e => interp_throwlk (interp_ectx K) (interp_expr e) + | ThrowRK v K => interp_throwrk (interp_val v) (interp_ectx K) + end. + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + + Global Instance interp_val_asval {S} {D : interp_scope S} (v : val S) + : AsVal (interp_val v D). + Proof. + destruct v; simpl. + - apply _. + - rewrite interp_rec_unfold. apply _. + - apply _. + Qed. + + Global Instance ArrEquiv {A B : Set} : Equiv (A [→] B) := + fun f g => ∀ x, f x = g x. + + Global Instance ArrDist {A B : Set} `{Dist B} : Dist (A [→] B) := + fun n => fun f g => ∀ x, f x ≡{n}≡ g x. + + Global Instance ren_scope_proper {S S'} : + Proper ((≡) ==> (≡) ==> (≡)) (@ren_scope F _ CR S S'). + Proof. + intros D D' HE s1 s2 Hs. + intros x; simpl. + f_equiv. + - apply Hs. + - apply HE. + Qed. + + Lemma interp_expr_ren {S S'} env + (δ : S [→] S') (e : expr S) : + interp_expr (fmap δ e) env ≡ interp_expr e (ren_scope δ env) + with interp_val_ren {S S'} env + (δ : S [→] S') (e : val S) : + interp_val (fmap δ e) env ≡ interp_val e (ren_scope δ env) + with interp_ectx_ren {S S'} env + (δ : S [→] S') (e : ectx S) : + interp_ectx (fmap δ e) env ≡ interp_ectx e (ren_scope δ env). + Proof. + - destruct e; simpl. + + by apply interp_val_ren. + + reflexivity. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + simpl; rewrite interp_expr_ren. + f_equiv. + intros [| y]; simpl. + * reflexivity. + * reflexivity. + + repeat f_equiv. + * intros ?; simpl. + repeat f_equiv; first by apply interp_expr_ren. + * by apply interp_expr_ren. + - destruct e; simpl. + + reflexivity. + + clear -interp_expr_ren. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + do 1 iApply f_equivI. iNext. + iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_ren. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (y'). + destruct y' as [| [| y]]; simpl; first done. + * by iRewrite - "IH". + * done. + + repeat f_equiv. + intros ?; simpl. + repeat f_equiv; by apply interp_ectx_ren. + - destruct e; simpl; intros ?; simpl. + + reflexivity. + + repeat f_equiv; by apply interp_ectx_ren. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_expr_ren | by apply interp_expr_ren]. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. + + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. + + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. + + repeat f_equiv; last by apply interp_ectx_ren. + intros ?; simpl; repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; last by apply interp_val_ren. + intros ?; simpl; repeat f_equiv; first by apply interp_ectx_ren. + Qed. + + Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S): + interp_expr (fill K e) env ≡ (interp_ectx K) env ((interp_expr e) env). + Proof. + revert env. + induction K; simpl; intros env; first reflexivity; try (by rewrite IHK). + - repeat f_equiv. + by rewrite IHK. + - repeat f_equiv. + by rewrite IHK. + - repeat f_equiv. + by rewrite IHK. + - repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + by rewrite IHK. + Qed. + + Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') + : interp_scope S := λne x, interp_expr (δ x) env. + + Global Instance SubEquiv {A B : Set} : Equiv (A [⇒] B) := fun f g => ∀ x, f x = g x. + + Global Instance sub_scope_proper {S S'} : + Proper ((≡) ==> (≡) ==> (≡)) (@sub_scope S S'). + Proof. + intros D D' HE s1 s2 Hs. + intros x; simpl. + f_equiv. + - f_equiv. + apply HE. + - apply Hs. + Qed. + + Lemma interp_expr_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_expr (bind δ e) env ≡ interp_expr e (sub_scope δ env) + with interp_val_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_val (bind δ e) env ≡ interp_val e (sub_scope δ env) + with interp_ectx_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_ectx (bind δ e) env ≡ interp_ectx e (sub_scope δ env). + Proof. + - destruct e; simpl. + + by apply interp_val_subst. + + term_simpl. + reflexivity. + + repeat f_equiv; by apply interp_expr_subst. + + repeat f_equiv; by apply interp_expr_subst. + + repeat f_equiv; by apply interp_expr_subst. + + f_equiv. + + repeat f_equiv; by apply interp_expr_subst. + + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + rewrite interp_expr_subst. + f_equiv. + intros [| x']; simpl. + * reflexivity. + * rewrite interp_expr_ren. + f_equiv. + intros ?; reflexivity. + + repeat f_equiv. + * intros ?; simpl. + repeat f_equiv; first by apply interp_expr_subst. + * by apply interp_expr_subst. + - destruct e; simpl. + + reflexivity. + + clear -interp_expr_subst. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + do 1 iApply f_equivI. iNext. + iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_subst. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (y'). + destruct y' as [| [| y]]; simpl; first done. + * by iRewrite - "IH". + * do 2 rewrite interp_expr_ren. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (z). + done. + + repeat f_equiv; intro; simpl; repeat f_equiv. + by apply interp_ectx_subst. + - destruct e; simpl; intros ?; simpl. + + reflexivity. + + repeat f_equiv; by apply interp_ectx_subst. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_expr_subst | by apply interp_expr_subst]. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. + + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. + + repeat f_equiv; last by apply interp_ectx_subst. + intros ?; simpl; repeat f_equiv; first by apply interp_expr_subst. + + repeat f_equiv; last by apply interp_val_subst. + intros ?; simpl; repeat f_equiv; first by apply interp_ectx_subst. + Qed. + + (** ** Interpretation of evaluation contexts induces homomorphism *) + + #[local] Instance interp_ectx_hom_emp {S} env : + IT_hom (interp_ectx (EmptyK : ectx S) env). + Proof. + simple refine (IT_HOM _ _ _ _ _); intros; auto. + simpl. fold (@idfun IT). f_equiv. intro. simpl. + by rewrite laterO_map_id. + Qed. + + #[local] Instance interp_ectx_hom_output {S} (K : ectx S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (OutputK K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite !hom_tick. + - rewrite !hom_vis. + f_equiv. intro. simpl. rewrite -laterO_map_compose. + do 2 f_equiv. by intro. + - by rewrite !hom_err. + Qed. + + #[local] Instance interp_ectx_hom_if {S} + (K : ectx S) (e1 e2 : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (IfK K e1 e2) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -IF_Tick. do 3 f_equiv. apply hom_tick. + - assert ((interp_ectx K env (Vis op i ko)) ≡ + (Vis op i (laterO_map (λne y, interp_ectx K env y) ◎ ko))). + { by rewrite hom_vis. } + trans (IF (Vis op i (laterO_map (λne y : IT, interp_ectx K env y) ◎ ko)) + (interp_expr e1 env) (interp_expr e2 env)). + { do 3 f_equiv. by rewrite hom_vis. } + rewrite IF_Vis. f_equiv. simpl. + intro. simpl. by rewrite -laterO_map_compose. + - trans (IF (Err e) (interp_expr e1 env) (interp_expr e2 env)). + { repeat f_equiv. apply hom_err. } + apply IF_Err. + Qed. + + #[local] Instance interp_ectx_hom_appr {S} (K : ectx S) + (e : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (AppRK e K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite !hom_tick. + - rewrite !hom_vis. f_equiv. intro x. simpl. + by rewrite laterO_map_compose. + - by rewrite !hom_err. + Qed. + + #[local] Instance interp_ectx_hom_appl {S} (K : ectx S) + (v : val S) (env : interp_scope S) : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (AppLK K v) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -APP'_Tick_l. do 2 f_equiv. apply hom_tick. + - trans (APP' (Vis op i (laterO_map (interp_ectx K env) ◎ ko)) + (interp_val v env)). + + do 2f_equiv. rewrite hom_vis. do 3 f_equiv. by intro. + + rewrite APP'_Vis_l. f_equiv. intro x. simpl. + by rewrite -laterO_map_compose. + - trans (APP' (Err e) (interp_val v env)). + { do 2f_equiv. apply hom_err. } + apply APP'_Err_l, interp_val_asval. + Qed. + + #[local] Instance interp_ectx_hom_natopr {S} (K : ectx S) + (e : expr S) op env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (NatOpRK op e K) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite !hom_tick. + - rewrite !hom_vis. f_equiv. intro x. simpl. + by rewrite laterO_map_compose. + - by rewrite !hom_err. + Qed. + + #[local] Instance interp_ectx_hom_natopl {S} (K : ectx S) + (v : val S) op (env : interp_scope S) : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (NatOpLK op K v) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -NATOP_ITV_Tick_l. do 2 f_equiv. apply hom_tick. + - trans (NATOP (do_natop op) + (Vis op0 i (laterO_map (interp_ectx K env) ◎ ko)) + (interp_val v env)). + { do 2 f_equiv. rewrite hom_vis. f_equiv. by intro. } + rewrite NATOP_ITV_Vis_l. f_equiv. intro x. simpl. + by rewrite -laterO_map_compose. + - trans (NATOP (do_natop op) (Err e) (interp_val v env)). + + do 2 f_equiv. apply hom_err. + + by apply NATOP_Err_l, interp_val_asval. + Qed. + + #[local] Instance interp_ectx_hom_throwr {S} + (K : ectx S) (v : val S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (ThrowRK v K) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - pose proof (interp_val_asval v (D := env)). + rewrite ->2 get_val_ITV. + simpl. + rewrite hom_tick. + destruct (IT_dont_confuse ((interp_ectx K env α))) as [(e' & HEQ) |[(n & HEQ) |[(f & HEQ) |[(β & HEQ) | (op & i & k & HEQ)]]]]. + + rewrite HEQ !get_fun_tick !get_fun_err. + reflexivity. + + rewrite HEQ !get_fun_tick. + reflexivity. + + rewrite HEQ !get_fun_tick !get_fun_fun//=. + + rewrite HEQ !get_fun_tick. + reflexivity. + + rewrite HEQ !get_fun_tick !get_fun_vis. + reflexivity. + - pose proof (interp_val_asval v (D := env)). + rewrite get_val_ITV. + simpl. + rewrite hom_vis. + rewrite get_fun_vis. + f_equiv. + intro; simpl. + rewrite -laterO_map_compose. + repeat f_equiv. + intro; simpl. + rewrite get_val_ITV. + simpl. + reflexivity. + - pose proof (interp_val_asval v (D := env)). + rewrite get_val_ITV. + simpl. + rewrite hom_err. + rewrite get_fun_err. + reflexivity. + Qed. + + #[local] Instance interp_ectx_hom_throwl {S} + (K : ectx S) (e : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (ThrowLK K e) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl; [by rewrite !hom_tick| | by rewrite !hom_err]. + rewrite !hom_vis. + f_equiv. + intro; simpl. + rewrite -laterO_map_compose. + reflexivity. + Qed. + + #[global] Instance interp_ectx_hom {S} + (K : ectx S) env : + IT_hom (interp_ectx K env). + Proof. + induction K; apply _. + Qed. + + (** ** Finally, preservation of reductions *) + Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (e : expr S) e' σ σ' K n : + head_step e σ e' σ' K (n, 0) → + interp_expr e env ≡ Tick_n n $ interp_expr e' env. + Proof. + inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. + - (* app lemma *) + subst. + erewrite APP_APP'_ITV; last apply _. + trans (APP (Fun (Next (ir_unf (interp_expr e1) env))) (Next $ interp_val v2 env)). + { repeat f_equiv. apply interp_rec_unfold. } + rewrite APP_Fun. simpl. rewrite Tick_eq. do 2 f_equiv. + simplify_eq. + rewrite !interp_expr_subst. + f_equiv. + intros [| [| x]]; simpl; [| reflexivity | reflexivity]. + rewrite interp_val_ren. + f_equiv. + intros ?; simpl; reflexivity. + - (* the natop stuff *) + simplify_eq. + destruct v1,v2; try naive_solver. simpl in *. + rewrite NATOP_Ret. + destruct op; simplify_eq/=; done. + - rewrite IF_True; last lia. + reflexivity. + - rewrite IF_False; last lia. + reflexivity. + Qed. + + Lemma interp_expr_fill_no_reify {S} K (env : interp_scope S) (e e' : expr S) σ σ' n : + head_step e σ e' σ' K (n, 0) → + interp_expr (fill K e) env + ≡ + Tick_n n $ interp_expr (fill K e') env. + Proof. + intros He. + rewrite !interp_comp. + erewrite <-hom_tick_n. + - apply (interp_expr_head_step env) in He. + rewrite He. + reflexivity. + - apply _. + Qed. + + Opaque INPUT OUTPUT_ CALLCC CALLCC_ THROW. + Opaque extend_scope. + Opaque Ret. + + Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) + (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : + head_step e σ e' σ' K (n, 1) → + reify (gReifiers_sReifier rs) + (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) + ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). + Proof. + intros Hst. + trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) + (gState_recomp σr (sR_state σ))). + { f_equiv. by rewrite interp_comp. } + inversion Hst; simplify_eq; cbn-[gState_recomp]. + - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). + { + repeat f_equiv; eauto. + rewrite hom_INPUT. + do 2 f_equiv. by intro. + } + rewrite reify_vis_eq_ctx_dep //; first last. + { + apply (subReifier_reify + (sReifier_NotCtxDep_CtxDep reify_io) rs (inl ()) + () (Next (interp_ectx K env (Ret n0))) + (NextO ◎ (interp_ectx K env ◎ Ret)) σ σ' σr). + simpl. rewrite H5. reflexivity. + } + repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. + rewrite interp_comp. + reflexivity. + - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). + { + do 3 f_equiv; eauto. + rewrite get_ret_ret//. + } + trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). + { + do 2 f_equiv; eauto. + by rewrite hom_OUTPUT_. + } + rewrite reify_vis_eq_ctx_dep //; last first. + { + simpl. + pose proof (subReifier_reify + (sReifier_NotCtxDep_CtxDep reify_io) rs (inr (inl ())) + n0 (Next (interp_ectx K env (Ret 0))) + (constO (Next (interp_ectx K env ((Ret 0))))) σ (update_output n0 σ) σr) as H. + simpl in H. erewrite <-H; last reflexivity. + f_equiv. + + do 3 intro. by rewrite /prod_map H0. + + do 2 f_equiv. by intro. + } + repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. + rewrite interp_comp. + reflexivity. + - match goal with + | |- context G [ofe_mor_car _ _ (CALLCC) ?g] => set (f := g) + end. + match goal with + | |- context G [(?s, _)] => set (gσ := s) end. + Transparent CALLCC. + unfold CALLCC. + simpl. + trans (reify (gReifiers_sReifier rs) (CALLCC_ f (laterO_map (interp_ectx K env))) gσ). + { + do 2 f_equiv. + rewrite hom_CALLCC_. + f_equiv. by intro. + } + rewrite reify_vis_eq_ctx_dep//; last first. + { + simpl. + set (ss := gState_decomp (@sR_idx _ _ _ _ subR1) gσ). + pose (s1 := (sR_state^-1 ss.1)). simpl in s1. + epose proof (subReifier_reify reify_cont rs (inl ()) f _ + (laterO_map (interp_ectx K env)) + s1 s1 (ss.2)) as H. + simpl in H. + erewrite <-H; last reflexivity. + f_equiv. + + intros ???. rewrite /prod_map H0. repeat f_equiv. + rewrite ofe_iso_12. + destruct ss; f_equiv; eauto. simpl. + symmetry. apply ofe_iso_12. + + repeat f_equiv; eauto. + rewrite ofe_iso_12. + destruct ss; f_equiv; eauto. + symmetry. apply ofe_iso_12. + } + rewrite interp_comp. + rewrite interp_expr_subst. + f_equiv. + { setoid_rewrite ofe_iso_12. + by apply gState_recomp_decomp. } + rewrite Tick_eq. + f_equiv. + rewrite laterO_map_Next. + do 3 f_equiv. + Transparent extend_scope. + intros [| x]; term_simpl; last reflexivity. + do 2 f_equiv. by intro. + Qed. + + Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : + prim_step e1 σ1 e2 σ2 (n,m) → + ssteps (gReifiers_sReifier rs) + (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) + (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. + Proof. + Opaque gState_decomp gState_recomp. + inversion 1; simplify_eq/=. + { + destruct (head_step_io_01 _ _ _ _ _ _ _ H2); subst. + - assert (σ1 = σ2) as ->. + { eapply head_step_no_io; eauto. } + unshelve eapply (interp_expr_fill_no_reify K) in H2; first apply env. + rewrite H2. + rewrite interp_comp. + eapply ssteps_tick_n. + - inversion H2;subst. + + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. + rewrite interp_comp. + rewrite hom_INPUT. + change 1 with (Nat.add 1 0). econstructor; last first. + { apply ssteps_zero; reflexivity. } + eapply sstep_reify. + { Transparent INPUT. unfold INPUT. simpl. + f_equiv. reflexivity. } + simpl in H2. + rewrite -H2. + repeat f_equiv; eauto. + rewrite interp_comp hom_INPUT. + eauto. + + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. + rewrite interp_comp. simpl. + rewrite get_ret_ret. + rewrite hom_OUTPUT_. + change 1 with (Nat.add 1 0). econstructor; last first. + { apply ssteps_zero; reflexivity. } + eapply sstep_reify. + { Transparent OUTPUT_. unfold OUTPUT_. simpl. + f_equiv. reflexivity. } + simpl in H2. + rewrite -H2. + repeat f_equiv; eauto. + Opaque OUTPUT_. + rewrite interp_comp /= get_ret_ret hom_OUTPUT_. + eauto. + + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. + rewrite !interp_comp interp_expr_subst. + change 1 with (Nat.add 1 0). econstructor; last first. + { apply ssteps_zero; reflexivity. } + rewrite -interp_comp. + eapply sstep_reify. + { Transparent CALLCC. unfold CALLCC. rewrite interp_comp hom_vis. + f_equiv. reflexivity. + } + rewrite H2. + simpl. + repeat f_equiv. + rewrite -interp_expr_subst. + rewrite interp_comp. + reflexivity. + } + { + rewrite !interp_comp. + simpl. + pose proof (interp_val_asval v (D := env)). + rewrite get_val_ITV. + simpl. + rewrite get_fun_fun. + simpl. + change 2 with (Nat.add (Nat.add 1 1) 0). + econstructor; last first. + { apply ssteps_tick_n. } + eapply sstep_reify; first (rewrite hom_vis; reflexivity). + match goal with + | |- context G [ofe_mor_car _ _ _ (Next ?f)] => set (f' := f) + end. + trans (reify (gReifiers_sReifier rs) (THROW (interp_val v env) (Next f')) (gState_recomp σr (sR_state σ2))). + { + f_equiv; last done. + f_equiv. + rewrite hom_vis. + Transparent THROW. + unfold THROW. + simpl. + repeat f_equiv. + intros x; simpl. + destruct ((subEff_outs ^-1) x). + } + rewrite reify_vis_eq_ctx_dep; first (rewrite Tick_eq; reflexivity). + simpl. + match goal with + | |- context G [(_, _, ?a)] => set (κ := a) + end. + set (gσ := (gState_recomp σr (sR_state (σ2 : sReifier_state (sReifier_NotCtxDep_CtxDep reify_io) ♯ IT)))). + (* set (gσ := (gState_recomp σr (sR_state σ2))). *) + set (ss := gState_decomp (@sR_idx _ _ _ _ subR1) gσ). + pose (s1 := (sR_state^-1 ss.1)). simpl in gσ, s1. + epose proof (subReifier_reify reify_cont rs (inr (inl ())) + (Next (interp_val v env), Next f') + (Next (Tau (Next ((interp_ectx K' env) (interp_val v env))))) + (Empty_setO_rec _) s1 s1 ss.2) as H'. + simpl in H'. + subst κ. + simpl. trans (Some + (Next (Tau (Next (interp_ectx K' env (interp_val v env)))), + gState_recomp ss.2 (sR_state (s1 : sReifier_state reify_cont ♯ IT)))). + - erewrite <-H'; last reflexivity. + rewrite /prod_map. + f_equiv. + + repeat intro. repeat f_equiv; eauto. + unfold s1. + setoid_rewrite ofe_iso_12. + symmetry. by apply gState_recomp_decomp. + + do 2 f_equiv. + * repeat f_equiv. unfold s1. + setoid_rewrite ofe_iso_12. + symmetry. by apply gState_recomp_decomp. + * intro; simpl. + f_equiv. done. + - rewrite Tick_eq. repeat f_equiv. + unfold s1. + setoid_rewrite ofe_iso_12. + by apply gState_recomp_decomp. } + Qed. + +End interp. +#[global] Opaque INPUT OUTPUT_ CALLCC THROW. diff --git a/theories/examples/input_lang_callcc/lang.v b/theories/examples/input_lang_callcc/lang.v new file mode 100644 index 0000000..8f5cb94 --- /dev/null +++ b/theories/examples/input_lang_callcc/lang.v @@ -0,0 +1,753 @@ +From gitrees Require Export prelude effects.io_tape. +Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. + +Inductive nat_op := Add | Sub | Mult. + +Inductive expr {X : Set} : Type := +(* Values *) +| Val (v : val) : expr +| Var (x : X) : expr +(* Base lambda calculus *) +| App (e₁ : expr) (e₂ : expr) : expr +(* Base types and their operations *) +| NatOp (op : nat_op) (e₁ : expr) (e₂ : expr) : expr +| If (e₁ : expr) (e₂ : expr) (e₃ : expr) : expr +(* The effects *) +| Input : expr +| Output (e : expr) : expr +| Callcc (e : @expr (inc X)) : expr +| Throw (e₁ : expr) (e₂ : expr) : expr +with val {X : Set} := +| LitV (n : nat) : val +| RecV (e : @expr (inc (inc X))) : val +| ContV (K : ectx) : val +with ectx {X : Set} := +| EmptyK : ectx +| OutputK (K : ectx) : ectx +| IfK (K : ectx) (e₁ : expr) (e₂ : expr) : ectx +| AppLK (K : ectx) (v : val) : ectx +| AppRK (e : expr) (K : ectx) : ectx +| NatOpRK (op : nat_op) (e : expr) (K : ectx) : ectx +| NatOpLK (op : nat_op) (K : ectx) (v : val) : ectx +| ThrowLK (K : ectx) (e : expr) : ectx +| ThrowRK (v : val) (K : ectx) : ectx. + +Arguments val X%bind : clear implicits. +Arguments expr X%bind : clear implicits. +Arguments ectx X%bind : clear implicits. + +Local Open Scope bind_scope. + +Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := + match e with + | Val v => Val (vmap f v) + | Var x => Var (f x) + | App e₁ e₂ => App (emap f e₁) (emap f e₂) + | NatOp o e₁ e₂ => NatOp o (emap f e₁) (emap f e₂) + | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) + | Input => Input + | Output e => Output (emap f e) + | Callcc e => Callcc (emap (f ↑) e) + | Throw e₁ e₂ => Throw (emap f e₁) (emap f e₂) + end +with vmap {A B : Set} (f : A [→] B) (v : val A) : val B := + match v with + | LitV n => LitV n + | RecV e => RecV (emap ((f ↑) ↑) e) + | ContV K => ContV (kmap f K) + end +with kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := + match K with + | EmptyK => EmptyK + | OutputK K => OutputK (kmap f K) + | IfK K e₁ e₂ => IfK (kmap f K) (emap f e₁) (emap f e₂) + | AppLK K v => AppLK (kmap f K) (vmap f v) + | AppRK e K => AppRK (emap f e) (kmap f K) + | NatOpRK op e K => NatOpRK op (emap f e) (kmap f K) + | NatOpLK op K v => NatOpLK op (kmap f K) (vmap f v) + | ThrowLK K e => ThrowLK (kmap f K) (emap f e) + | ThrowRK v K => ThrowRK (vmap f v) (kmap f K) + end. +#[export] Instance FMap_expr : FunctorCore expr := @emap. +#[export] Instance FMap_val : FunctorCore val := @vmap. +#[export] Instance FMap_ectx : FunctorCore ectx := @kmap. + +#[export] Instance SPC_expr : SetPureCore expr := @Var. + +Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := + match e with + | Val v => Val (vbind f v) + | Var x => f x + | App e₁ e₂ => App (ebind f e₁) (ebind f e₂) + | NatOp o e₁ e₂ => NatOp o (ebind f e₁) (ebind f e₂) + | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) + | Input => Input + | Output e => Output (ebind f e) + | Callcc e => Callcc (ebind (f ↑) e) + | Throw e₁ e₂ => Throw (ebind f e₁) (ebind f e₂) + end +with vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := + match v with + | LitV n => LitV n + | RecV e => RecV (ebind ((f ↑) ↑) e) + | ContV K => ContV (kbind f K) + end +with kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := + match K with + | EmptyK => EmptyK + | OutputK K => OutputK (kbind f K) + | IfK K e₁ e₂ => IfK (kbind f K) (ebind f e₁) (ebind f e₂) + | AppLK K v => AppLK (kbind f K) (vbind f v) + | AppRK e K => AppRK (ebind f e) (kbind f K) + | NatOpRK op e K => NatOpRK op (ebind f e) (kbind f K) + | NatOpLK op K v => NatOpLK op (kbind f K) (vbind f v) + | ThrowLK K e => ThrowLK (kbind f K) (ebind f e) + | ThrowRK v K => ThrowRK (vbind f v) (kbind f K) + end. + +#[export] Instance BindCore_expr : BindCore expr := @ebind. +#[export] Instance BindCore_val : BindCore val := @vbind. +#[export] Instance BindCore_ectx : BindCore ectx := @kbind. + +#[export] Instance IP_typ : SetPure expr. +Proof. + split; intros; reflexivity. +Qed. + +Fixpoint vmap_id X (δ : X [→] X) (v : val X) : δ ≡ ı → fmap δ v = v +with emap_id X (δ : X [→] X) (e : expr X) : δ ≡ ı → fmap δ e = e +with kmap_id X (δ : X [→] X) (e : ectx X) : δ ≡ ı → fmap δ e = e. +Proof. + - auto_map_id. + - auto_map_id. + - auto_map_id. +Qed. + +Fixpoint vmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (v : val A) : + f ∘ g ≡ h → fmap f (fmap g v) = fmap h v +with emap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : expr A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e +with kmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : ectx A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e. +Proof. + - auto_map_comp. + - auto_map_comp. + - auto_map_comp. +Qed. + +#[export] Instance Functor_val : Functor val. +Proof. + split; [exact vmap_id | exact vmap_comp]. +Qed. +#[export] Instance Functor_expr : Functor expr. +Proof. + split; [exact emap_id | exact emap_comp]. +Qed. +#[export] Instance Functor_ectx : Functor ectx. +Proof. + split; [exact kmap_id | exact kmap_comp]. +Qed. + +Fixpoint vmap_vbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (v : val A) : + f ̂ ≡ g → fmap f v = bind g v +with emap_ebind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : expr A) : + f ̂ ≡ g → fmap f e = bind g e +with kmap_kbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : ectx A) : + f ̂ ≡ g → fmap f e = bind g e. +Proof. + - auto_map_bind_pure. + erewrite emap_ebind_pure; [reflexivity |]. + intros [| [| x]]; term_simpl; [reflexivity | reflexivity |]. + rewrite <-(EQ x). + reflexivity. + - auto_map_bind_pure. + - auto_map_bind_pure. +Qed. + +#[export] Instance BindMapPure_val : BindMapPure val. +Proof. + split; intros; now apply vmap_vbind_pure. +Qed. +#[export] Instance BindMapPure_expr : BindMapPure expr. +Proof. + split; intros; now apply emap_ebind_pure. +Qed. +#[export] Instance BindMapPure_ectx : BindMapPure ectx. +Proof. + split; intros; now apply kmap_kbind_pure. +Qed. + +Fixpoint vmap_vbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (v : val A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ v) = fmap f₁ (bind g₁ v) +with emap_ebind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : expr A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e) +with kmap_kbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : ectx A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e). +Proof. + - auto_map_bind_comm. + erewrite emap_ebind_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity | assumption]. + - auto_map_bind_comm. + - auto_map_bind_comm. +Qed. + +#[export] Instance BindMapComm_val : BindMapComm val. +Proof. + split; intros; now apply vmap_vbind_comm. +Qed. +#[export] Instance BindMapComm_expr : BindMapComm expr. +Proof. + split; intros; now apply emap_ebind_comm. +Qed. +#[export] Instance BindMapComm_ectx : BindMapComm ectx. +Proof. + split; intros; now apply kmap_kbind_comm. +Qed. + +Fixpoint vbind_id (A : Set) (f : A [⇒] A) (v : val A) : + f ≡ ı → bind f v = v +with ebind_id (A : Set) (f : A [⇒] A) (e : expr A) : + f ≡ ı → bind f e = e +with kbind_id (A : Set) (f : A [⇒] A) (e : ectx A) : + f ≡ ı → bind f e = e. +Proof. + - auto_bind_id. + rewrite ebind_id; [reflexivity |]. + apply lift_id, lift_id; assumption. + - auto_bind_id. + - auto_bind_id. +Qed. + +Fixpoint vbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (v : val A) : + f ∘ g ≡ h → bind f (bind g v) = bind h v +with ebind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : expr A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e +with kbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : ectx A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e. +Proof. + - auto_bind_comp. + erewrite ebind_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity | assumption]. + - auto_bind_comp. + - auto_bind_comp. +Qed. + +#[export] Instance Bind_val : Bind val. +Proof. + split; intros; [now apply vbind_id | now apply vbind_comp]. +Qed. +#[export] Instance Bind_expr : Bind expr. +Proof. + split; intros; [now apply ebind_id | now apply ebind_comp]. +Qed. +#[export] Instance Bind_ectx : Bind ectx. +Proof. + split; intros; [now apply kbind_id | now apply kbind_comp]. +Qed. + +Definition to_val {S} (e : expr S) : option (val S) := + match e with + | Val v => Some v + | _ => None + end. + +Definition do_natop (op : nat_op) (x y : nat) : nat := + match op with + | Add => plus x y + | Sub => minus x y + | Mult => mult x y + end. + +Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := + match x, y with + | LitV x, LitV y => Some $ LitV $ do_natop n x y + | _,_ => None + end. + +Fixpoint fill {X : Set} (K : ectx X) (e : expr X) : expr X := + match K with + | EmptyK => e + | OutputK K => Output (fill K e) + | IfK K e₁ e₂ => If (fill K e) e₁ e₂ + | AppLK K v => App (fill K e) (Val v) + | AppRK e' K => App e' (fill K e) + | NatOpRK op e' K => NatOp op e' (fill K e) + | NatOpLK op K v => NatOp op (fill K e) (Val v) + | ThrowLK K e' => Throw (fill K e) e' + | ThrowRK v K => Throw (Val v) (fill K e) + end. + +Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) + : fmap f (fill K e) = fill (fmap f K) (fmap f e). +Proof. + revert f. + induction K as [| ?? IH + | ?? IH + | ?? IH + | ??? IH + | ???? IH + | ??? IH + | ?? IH + | ??? IH]; + intros f; term_simpl; first done; rewrite IH; reflexivity. +Qed. + +(*** Operational semantics *) + +Inductive head_step {S} : expr S → state → expr S → state → ectx S → nat * nat → Prop := +| BetaS e1 v2 σ K : + head_step (App (Val $ RecV e1) (Val v2)) σ (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) (Val (shift (Inc := inc) v2))) (Val (RecV e1))) σ K (1,0) +| InputS σ n σ' K : + update_input σ = (n, σ') → + head_step Input σ (Val (LitV n)) σ' K (1, 1) +| OutputS σ n σ' K : + update_output n σ = σ' → + head_step (Output (Val (LitV n))) σ (Val (LitV 0)) σ' K (1, 1) +| NatOpS op v1 v2 v3 σ K : + nat_op_interp op v1 v2 = Some v3 → + head_step (NatOp op (Val v1) (Val v2)) σ + (Val v3) σ K (0, 0) +| IfTrueS n e1 e2 σ K : + n > 0 → + head_step (If (Val (LitV n)) e1 e2) σ + e1 σ K (0, 0) +| IfFalseS n e1 e2 σ K : + n = 0 → + head_step (If (Val (LitV n)) e1 e2) σ + e2 σ K (0, 0) +| CallccS e σ K : + head_step (Callcc e) σ (subst (Inc := inc) e (Val (ContV K))) σ K (1, 1) +. + +Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : + head_step e1 σ1 e2 σ2 K (n,m) → m = 0 ∨ m = 1. +Proof. inversion 1; eauto. Qed. +Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : + head_step e1 σ1 e2 σ2 K (n,m) → n = 0 ∨ n = 1. +Proof. inversion 1; eauto. Qed. +Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K n : + head_step e1 σ1 e2 σ2 K (n,0) → σ1 = σ2. +Proof. inversion 1; eauto. Qed. + +(** Carbonara from heap lang *) +Global Instance fill_item_inj {S} (Ki : ectx S) : Inj (=) (=) (fill Ki). +Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. + +Lemma fill_item_val {S} Ki (e : expr S) : + is_Some (to_val (fill Ki e)) → is_Some (to_val e). +Proof. intros [v ?]. induction Ki; simplify_option_eq; eauto. Qed. + +Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 K m : head_step e1 σ1 e2 σ2 K m → to_val e1 = None. +Proof. destruct 1; naive_solver. Qed. + +Fixpoint ectx_compose {S} (K1 K2 : ectx S) : ectx S + := match K1 with + | EmptyK => K2 + | OutputK K => OutputK (ectx_compose K K2) + | IfK K e₁ e₂ => IfK (ectx_compose K K2) e₁ e₂ + | AppLK K v => AppLK (ectx_compose K K2) v + | AppRK e K => AppRK e (ectx_compose K K2) + | NatOpRK op e K => NatOpRK op e (ectx_compose K K2) + | NatOpLK op K v => NatOpLK op (ectx_compose K K2) v + | ThrowLK K e => ThrowLK (ectx_compose K K2) e + | ThrowRK v K => ThrowRK v (ectx_compose K K2) + end. + +Lemma fill_app {S} (K1 K2 : ectx S) e : fill (ectx_compose K1 K2) e = fill K1 (fill K2 e). +Proof. + revert K2. + revert e. + induction K1 as [| ?? IH + | ?? IH + | ?? IH + | ??? IH + | ???? IH + | ??? IH + | ?? IH + | ??? IH]; + simpl; first done; intros e' K2; rewrite IH; reflexivity. +Qed. + +Lemma fill_val : ∀ {S} K (e : expr S), is_Some (to_val (fill K e)) → is_Some (to_val e). +Proof. + intros S K. + induction K as [| ?? IH + | ?? IH + | ?? IH + | ??? IH + | ???? IH + | ??? IH + | ?? IH + | ??? IH]=> e' //=; + inversion 1 as [? HH]; inversion HH. +Qed. + +Lemma fill_not_val : ∀ {S} K (e : expr S), to_val e = None → to_val (fill K e) = None. +Proof. + intros S K e. rewrite !eq_None_not_Some. + eauto using fill_val. +Qed. + +Lemma fill_empty {S} (e : expr S) : fill EmptyK e = e. +Proof. reflexivity. Qed. +Lemma fill_comp {S} K1 K2 (e : expr S) : fill K2 (fill K1 e) = fill (ectx_compose K2 K1) e. +Proof. by rewrite fill_app. Qed. +Global Instance fill_inj {S} (K : ectx S) : Inj (=) (=) (fill K). +Proof. + induction K as [| ?? IH + | ?? IH + | ?? IH + | ??? IH + | ???? IH + | ??? IH + | ?? IH + | ??? IH]; + rewrite /Inj; naive_solver. +Qed. + +Inductive prim_step {S} : ∀ (e1 : expr S) (σ1 : state) + (e2 : expr S) (σ2 : state) (n : nat * nat), Prop := +| Ectx_step e1 σ1 e2 σ2 n (K : ectx S) e1' e2' : + e1 = fill K e1' → e2 = fill K e2' → + head_step e1' σ1 e2' σ2 K n → prim_step e1 σ1 e2 σ2 n +| Throw_step e1 σ e2 (K : ectx S) v K' : + e1 = (fill K (Throw (Val v) (Val (ContV K')))) -> + e2 = (fill K' (Val v)) -> + prim_step e1 σ e2 σ (2, 0). + +Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : + prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. +Proof. + inversion 1; simplify_eq/=. + - inversion H2; eauto. + - reflexivity. +Qed. + +Inductive prim_steps {S} : expr S → state → expr S → state → nat * nat → Prop := +| prim_steps_zero e σ : + prim_steps e σ e σ (0, 0) +| prim_steps_abit e1 σ1 e2 σ2 e3 σ3 n1 m1 n2 m2 : + prim_step e1 σ1 e2 σ2 (n1, m1) → + prim_steps e2 σ2 e3 σ3 (n2, m2) → + prim_steps e1 σ1 e3 σ3 (plus n1 n2, plus m1 m2) +. + +Lemma Ectx_step' {S} (K : ectx S) e1 σ1 e2 σ2 efs : + head_step e1 σ1 e2 σ2 K efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. +Proof. econstructor; eauto. Qed. + +Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) σ1 σ2 σ3 : + prim_steps e1 σ1 e2 σ2 nm1 → prim_steps e2 σ2 e3 σ3 nm2 → + prim_steps e1 σ1 e3 σ3 (plus nm1.1 nm2.1, plus nm1.2 nm2.2). +Proof. + intros Hst. revert nm2. + induction Hst; intros [n' m']; simplify_eq/=; first done. + rewrite -!Nat.add_assoc. intros Hsts. + econstructor; eauto. + by apply (IHHst (n',m')). +Qed. + +Lemma prim_step_steps {S} nm (e1 e2 : expr S) σ1 σ2 : + prim_step e1 σ1 e2 σ2 nm → prim_steps e1 σ1 e2 σ2 nm. +Proof. + destruct nm as [n m]. intro Hs. + rewrite -(Nat.add_0_r n). + rewrite -(Nat.add_0_r m). + econstructor; eauto. + by constructor. +Qed. + +Lemma prim_step_steps_steps {S} (e1 e2 e3 : expr S) σ1 σ2 σ3 nm1 nm2 nm3 : + nm3 = (plus nm1.1 nm2.1, plus nm1.2 nm2.2) -> + prim_step e1 σ1 e2 σ2 nm1 → prim_steps e2 σ2 e3 σ3 nm2 -> prim_steps e1 σ1 e3 σ3 nm3. +Proof. + intros -> H G. + eapply prim_steps_app; last apply G. + apply prim_step_steps, H. +Qed. + +Lemma head_step_prim_step {S} (e1 e2 : expr S) σ1 σ2 nm : + head_step e1 σ1 e2 σ2 EmptyK nm -> prim_step e1 σ1 e2 σ2 nm. +Proof. + assert (e1 = fill EmptyK e1) as Heq1; first done. + rewrite ->Heq1 at 2. + assert (e2 = fill EmptyK e2) as Heq2; first done. + rewrite ->Heq2 at 2. + apply Ectx_step'. +Qed. + +(*** Type system *) + +Inductive ty := + | Tnat : ty | Tarr : ty → ty → ty | Tcont : ty → ty. + +Inductive typed {S : Set} (Γ : S -> ty) : expr S → ty → Prop := +| typed_Val (τ : ty) (v : val S) : + typed_val Γ v τ → + typed Γ (Val v) τ +| typed_Var (τ : ty) (v : S) : + Γ v = τ → + typed Γ (Var v) τ +| typed_App (τ1 τ2 : ty) e1 e2 : + typed Γ e1 (Tarr τ1 τ2) → + typed Γ e2 τ1 → + typed Γ (App e1 e2) τ2 +| typed_NatOp e1 e2 op : + typed Γ e1 Tnat → + typed Γ e2 Tnat → + typed Γ (NatOp op e1 e2) Tnat +| typed_If e0 e1 e2 τ : + typed Γ e0 Tnat → + typed Γ e1 τ → + typed Γ e2 τ → + typed Γ (If e0 e1 e2) τ +| typed_Input : + typed Γ Input Tnat +| typed_Output e : + typed Γ e Tnat → + typed Γ (Output e) Tnat +| typed_Throw e1 e2 τ τ' : + typed Γ e1 τ -> + typed Γ e2 (Tcont τ) -> + typed Γ (Throw e1 e2) τ' +| typed_Callcc e τ : + typed (Γ ▹ Tcont τ) e τ -> + typed Γ (Callcc e) τ +with typed_val {S : Set} (Γ : S -> ty) : val S → ty → Prop := +| typed_Lit n : + typed_val Γ (LitV n) Tnat +| typed_RecV (τ1 τ2 : ty) (e : expr (inc (inc S))) : + typed (Γ ▹ (Tarr τ1 τ2) ▹ τ1) e τ2 → + typed_val Γ (RecV e) (Tarr τ1 τ2) +. + +Declare Scope syn_scope. +Delimit Scope syn_scope with syn. + +Coercion Val : val >-> expr. + +Coercion App : expr >-> Funclass. +Coercion AppLK : ectx >-> Funclass. +Coercion AppRK : expr >-> Funclass. + +Class AsSynExpr (F : Set -> Type) := { __asSynExpr : ∀ S, F S -> expr S }. + +Arguments __asSynExpr {_} {_} {_}. + +Global Instance AsSynExprValue : AsSynExpr val := { + __asSynExpr _ v := Val v + }. +Global Instance AsSynExprExpr : AsSynExpr expr := { + __asSynExpr _ e := e + }. + +Class OpNotation (A B C D : Type) := { __op : A -> B -> C -> D }. + +Global Instance OpNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : OpNotation (F S) nat_op (G S) (expr S) := { + __op e₁ op e₂ := NatOp op (__asSynExpr e₁) (__asSynExpr e₂) + }. + +Global Instance OpNotationLK {S : Set} : OpNotation (ectx S) (nat_op) (val S) (ectx S) := { + __op K op v := NatOpLK op K v + }. + +Global Instance OpNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : OpNotation (F S) (nat_op) (ectx S) (ectx S) := { + __op e op K := NatOpRK op (__asSynExpr e) K + }. + +Class IfNotation (A B C D : Type) := { __if : A -> B -> C -> D }. + +Global Instance IfNotationExpr {S : Set} {F G H : Set -> Type} `{AsSynExpr F, AsSynExpr G, AsSynExpr H} : IfNotation (F S) (G S) (H S) (expr S) := { + __if e₁ e₂ e₃ := If (__asSynExpr e₁) (__asSynExpr e₂) (__asSynExpr e₃) + }. + +Global Instance IfNotationK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : IfNotation (ectx S) (F S) (G S) (ectx S) := { + __if K e₂ e₃ := IfK K (__asSynExpr e₂) (__asSynExpr e₃) + }. + +Class OutputNotation (A B : Type) := { __output : A -> B }. + +Global Instance OutputNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : OutputNotation (F S) (expr S) := { + __output e := Output (__asSynExpr e) + }. + +Global Instance OutputNotationK {S : Set} : OutputNotation (ectx S) (ectx S) := { + __output K := OutputK K + }. + +Class ThrowNotation (A B C : Type) := { __throw : A -> B -> C }. + +Global Instance ThrowNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : ThrowNotation (F S) (G S) (expr S) := { + __throw e₁ e₂ := Throw (__asSynExpr e₁) (__asSynExpr e₂) + }. + +Global Instance ThrowNotationLK {S : Set} {F : Set -> Type} `{AsSynExpr F} : ThrowNotation (ectx S) (F S) (ectx S) := { + __throw K e₂ := ThrowLK K (__asSynExpr e₂) + }. + +Global Instance ThrowNotationRK {S : Set} : ThrowNotation (val S) (ectx S) (ectx S) := { + __throw v K := ThrowRK v K + }. + +Class AppNotation (A B C : Type) := { __app : A -> B -> C }. + +Global Instance AppNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : AppNotation (F S) (G S) (expr S) := { + __app e₁ e₂ := App (__asSynExpr e₁) (__asSynExpr e₂) + }. + +Global Instance AppNotationLK {S : Set} : AppNotation (ectx S) (val S) (ectx S) := { + __app K v := AppLK K v + }. + +Global Instance AppNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : AppNotation (F S) (ectx S) (ectx S) := { + __app e K := AppRK (__asSynExpr e) K + }. + +Notation of_val := Val (only parsing). + +Notation "x '⋆' y" := (__app x%syn y%syn) (at level 40, y at next level, left associativity) : syn_scope. +Notation "x '+' y" := (__op x%syn Add y%syn) : syn_scope. +Notation "x '-' y" := (__op x%syn Sub y%syn) : syn_scope. +Notation "x '*' y" := (__op x%syn Mult y%syn) : syn_scope. +Notation "'if' x 'then' y 'else' z" := (__if x%syn y%syn z%syn) : syn_scope. +Notation "'output' x" := (__output x%syn) (at level 60) : syn_scope. +Notation "'throw' e₁ e₂" := (__throw e₁%syn e₂%syn) (at level 60) : syn_scope. +Notation "'#' n" := (LitV n) (at level 60) : syn_scope. +Notation "'input'" := (Input) : syn_scope. +Notation "'rec' e" := (RecV e%syn) (at level 60) : syn_scope. +Notation "'callcc' e" := (Callcc e%syn) (at level 60) : syn_scope. +Notation "'cont' K" := (ContV K%syn) (at level 60) : syn_scope. +Notation "'$' fn" := (set_pure_resolver fn) (at level 60) : syn_scope. +Notation "□" := (EmptyK) : syn_scope. +Notation "K '⟪' e '⟫'" := (fill K%syn e%syn) (at level 60) : syn_scope. + +Definition LamV {S : Set} (e : expr (inc S)) : val S := + RecV (shift e). + +Notation "'λ' . e" := (LamV e%syn) (at level 60) : syn_scope. + +Definition LetE {S : Set} (e : expr S) (e' : expr (inc S)) : expr S := + App (LamV e') (e). + +Notation "'let_' e₁ 'in' e₂" := (LetE e₁%syn e₂%syn) (at level 60, right associativity) : syn_scope. + +Definition SeqE {S : Set} (e e' : expr S) : expr S := + App (LamV (shift e)) e'. + +Notation "e₁ ';;' e₂" := (SeqE e₁%syn e₂%syn) : syn_scope. + +Declare Scope typ_scope. +Delimit Scope typ_scope with typ. + +Notation "'ℕ'" := (Tnat) (at level 1) : typ_scope. +Notation "A →ₜ B" := (Tarr A%typ B%typ) + (right associativity, at level 60) : typ_scope. +Notation "A 'cont'" := (Tcont A%typ) + (at level 60) : typ_scope. + +Declare Scope typing_scope. +Delimit Scope typing_scope with typing. + +Class TypingNotation (A B C : Type) := { __typing : A -> B -> C -> Prop }. + +Notation "Γ ⊢ e : τ" := (__typing Γ e%syn τ%typ) (at level 70, e at level 60) : typing_scope. + +Global Instance TypingNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : TypingNotation (S -> ty) (F S) ty := { + __typing Γ e τ := typed Γ (__asSynExpr e) τ + }. + +Global Instance TypingNotationVal {S : Set} : TypingNotation (S -> ty) (val S) ty := { + __typing Γ e τ := typed_val Γ e τ + }. + +Module SynExamples. + + Open Scope syn_scope. + + Example test1 : expr (inc ∅) := ($ 0). + Example test2 : val ∅ := (rec (if ($ 1) then # 1 else # 0)). + Example test3 : expr ∅ := (callcc ($ 0)). + Example test4 : expr ∅ := ((# 1) + (# 0)). + Example test5 : val ∅ := (rec (if ($ 1) then # 1 else (($ 0) ⋆ (($ 1) - (# 1))))). + Example test6 : expr (inc (inc ∅)) := ($ 0) ⋆ ($ 1). + Example test7 : expr ∅ := (let_ ((rec (if ($ 1) then # 1 else (($ 0) ⋆ (($ 1) - (# 1))))) ⋆ (# 5)) in (output ($ 0))). + + Open Scope typing_scope. + + Example test8 : Prop := (empty_env ⊢ (# 0) : ℕ). +End SynExamples. + +Definition compute_head_step {S} (e : expr S) (σ : state) (K : ectx S) : option (expr S * state * (nat * nat)) := + match e with + | (App (Val (RecV e1)) (Val v2)) => Some ((subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) (Val (shift (Inc := inc) v2))) (Val (RecV e1))), σ, (1,0)) + | Input => + let '(n, σ') := update_input σ in + Some ((Val (LitV n)), σ', (1, 1)) + | Output (Val (LitV n)) => + let σ' := update_output n σ in + Some ((Val (LitV 0)), σ', (1, 1)) + | (NatOp op (Val v1) (Val v2)) => + let res := nat_op_interp op v1 v2 in + option_rect (fun _ => option _) (fun v3 => Some ((Val v3), σ, (0, 0))) None res + | (If (Val (LitV n)) e1 e2) => + if (decide (0 < n)) + then Some (e1, σ, (0, 0)) + else + if (decide (n = 0)) + then Some (e2, σ, (0, 0)) + else None + | (Callcc e) => Some ((subst (Inc := inc) e (Val (ContV K))), σ, (1, 1)) + | _ => None + end. + +Lemma head_step_reflect {S : Set} (e : expr S) (σ : state) (K : ectx S) + : option_reflect (fun '(e', σ', nm) => head_step e σ e' σ' K nm) + True + (compute_head_step e σ K). +Proof. + destruct e; try (by constructor). + - destruct e1; try (by constructor). + destruct v; try (by constructor). + destruct e2; try (by constructor). + constructor. + constructor. + - destruct e1; try (by constructor). + destruct e2; try (by constructor). + destruct (nat_op_interp op v v0) eqn:Heqn. + + simpl; rewrite Heqn. + simpl. + constructor. + by constructor. + + simpl; rewrite Heqn. + simpl. + constructor. + constructor. + - destruct e1; try (by constructor). + destruct v; try (by constructor). + simpl. + case_match; simpl. + + constructor. + constructor. + assumption. + + case_match; simpl. + * constructor. + constructor. + assumption. + * constructor. + constructor. + - simpl. + destruct (update_input σ) eqn:Heqn. + by do 2 constructor. + - simpl. + destruct e; try (by constructor). + destruct v; try (by constructor). + destruct (update_output n σ) eqn:Heqn. + by do 2 constructor. + - simpl. + do 2 constructor. +Qed. diff --git a/theories/examples/input_lang_callcc/logrel.v b/theories/examples/input_lang_callcc/logrel.v new file mode 100644 index 0000000..677579a --- /dev/null +++ b/theories/examples/input_lang_callcc/logrel.v @@ -0,0 +1,791 @@ +(** Logical relation for adequacy for the IO lang *) +From gitrees Require Import gitree lang_generic effects.io_tape. +From gitrees.examples.input_lang_callcc Require Import lang interp hom. +Require Import Binding.Lib Binding.Set Binding.Env. + +Open Scope stdpp_scope. + +Section logrel. + Context {sz : nat}. + Variable (rs : gReifiers CtxDep sz). + Context `{!subReifier reify_cont rs}. + Context `{!subReifier (sReifier_NotCtxDep_CtxDep reify_io) rs}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F natO). + Notation ITV := (ITV F natO). + Context `{!invGS Σ, !stateG rs natO Σ}. + Notation iProp := (iProp Σ). + Notation restO := (gState_rest (@sR_idx _ _ (sReifier_NotCtxDep_CtxDep reify_io)) rs ♯ IT). + + Canonical Structure exprO S := leibnizO (expr S). + Canonical Structure valO S := leibnizO (val S). + Canonical Structure ectxO S := leibnizO (ectx S). + + Notation "'WP' α {{ β , Φ } }" := (wp rs α notStuck ⊤ (λ β, Φ)) + (at level 20, α, Φ at level 200, + format "'WP' α {{ β , Φ } }") : bi_scope. + + Notation "'WP' α {{ Φ } }" := (wp rs α notStuck ⊤ Φ) + (at level 20, α, Φ at level 200, + format "'WP' α {{ Φ } }") : bi_scope. + + Definition logrel_nat {S} (βv : ITV) (v : val S) : iProp := + (∃ n, βv ≡ RetV n ∧ ⌜v = LitV n⌝)%I. + + Definition cont_ctx : iProp := has_substate (() : sReifier_state reify_cont ♯ IT). + + Definition obs_ref {S} (α : IT) (e : expr S) : iProp := + (∀ (σ : stateO), + has_substate σ -∗ cont_ctx -∗ + WP α {{ βv, ∃ m v σ', ⌜prim_steps e σ (Val v) σ' m⌝ + ∗ logrel_nat βv v ∗ has_substate σ' ∗ cont_ctx }})%I. + + Definition logrel_ectx {S} V (κ : HOM) (K : ectx S) : iProp := + (□ ∀ (βv : ITV) (v : val S), V βv v -∗ obs_ref (`κ (IT_of_V βv)) (fill K (Val v)))%I. + + Definition logrel_expr {S} V (α : IT) (e : expr S) : iProp := + (∀ (κ : HOM) (K : ectx S), + logrel_ectx V κ K -∗ obs_ref (`κ α) (fill K e))%I. + + Definition logrel_arr {S} V1 V2 (βv : ITV) (vf : val S) : iProp := + (∃ f, IT_of_V βv ≡ Fun f ∧ □ ∀ αv v, V1 αv v -∗ + logrel_expr V2 (APP' (Fun f) (IT_of_V αv)) (App (Val vf) (Val v)))%I. + + + Definition logrel_cont {S} V (βv : ITV) (v : val S) : iProp := + (∃ (κ : HOM) K, (IT_of_V βv) ≡ (Fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))) + ∧ ⌜v = ContV K⌝ + ∧ □ logrel_ectx V κ K)%I. + + Fixpoint logrel_val {S} (τ : ty) : ITV → (val S) → iProp + := match τ with + | Tnat => logrel_nat + | Tarr τ1 τ2 => logrel_arr (logrel_val τ1) (logrel_val τ2) + | Tcont τ => logrel_cont (logrel_val τ) + end. + + Definition logrel {S} (τ : ty) : IT → (expr S) → iProp + := logrel_expr (logrel_val τ). + + #[export] Instance obs_ref_ne {S} : + NonExpansive2 (@obs_ref S). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_expr_ne {S} (V : ITV → val S → iProp) : + NonExpansive2 V → NonExpansive2 (logrel_expr V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_nat_ne {S} : NonExpansive2 (@logrel_nat S). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_val_ne {S} (τ : ty) : NonExpansive2 (@logrel_val S τ). + Proof. + induction τ; simpl; solve_proper. + Qed. + + #[export] Instance logrel_ectx_ne {S} (V : ITV → val S → iProp) : + NonExpansive2 V → NonExpansive2 (logrel_ectx V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_arr_ne {S} (V1 V2 : ITV → val S → iProp) : + NonExpansive2 V1 -> NonExpansive2 V2 → NonExpansive2 (logrel_arr V1 V2). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_cont_ne {S} (V : ITV → val S → iProp) : + NonExpansive2 V -> NonExpansive2 (logrel_cont V). + Proof. + solve_proper. + Qed. + + #[export] Instance obs_ref_proper {S} : + Proper ((≡) ==> (≡) ==> (≡)) (@obs_ref S). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_expr_proper {S} (V : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V → + Proper ((≡) ==> (≡) ==> (≡)) (logrel_expr V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_nat_proper {S} : + Proper ((≡) ==> (≡) ==> (≡)) (@logrel_nat S). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_val_proper {S} (τ : ty) : + Proper ((≡) ==> (≡) ==> (≡)) (@logrel_val S τ). + Proof. + induction τ; simpl; solve_proper. + Qed. + + #[export] Instance logrel_ectx_proper {S} (V : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V → + Proper ((≡) ==> (≡) ==> (≡)) (logrel_ectx V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_arr_proper {S} (V1 V2 : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V1 -> + Proper ((≡) ==> (≡) ==> (≡)) V2 → + Proper ((≡) ==> (≡) ==> (≡)) (logrel_arr V1 V2). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_cont_proper {S} (V : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V -> + Proper ((≡) ==> (≡) ==> (≡)) (logrel_cont V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_val_persistent {S} (τ : ty) α v : + Persistent (@logrel_val S τ α v). + Proof. + revert α v. induction τ=> α v; simpl. + - unfold logrel_nat. apply _. + - unfold logrel_arr. apply _. + - unfold logrel_cont. apply _. + Qed. + + #[export] Instance logrel_ectx_persistent {S} V κ K : + Persistent (@logrel_ectx S V κ K). + Proof. + apply _. + Qed. + + Lemma logrel_of_val {S} τ αv (v : val S) : + logrel_val τ αv v -∗ logrel τ (IT_of_V αv) (Val v). + Proof. + iIntros "H1". iIntros (κ K) "HK". + iIntros (σ) "Hs". + by iApply ("HK" $! αv v with "[$H1] [$Hs]"). + Qed. + + Lemma logrel_head_step_pure_ectx {S} n K (e' e : expr S) α V : + (∀ σ K, head_step e σ e' σ K (n, 0)) → + ⊢ logrel_expr V α (fill K e') -∗ logrel_expr V α (fill K e). + Proof. + intros Hpure. + iIntros "H". + iIntros (κ' K') "#HK'". + iIntros (σ) "Hs Hcont". + iSpecialize ("H" with "HK' Hs Hcont"). + iApply (wp_wand with "H"). + iIntros (βv). iDestruct 1 as ([m m'] v σ' Hsteps) "[H2 Hs]". + iExists ((Nat.add n m),m'),v,σ'. iFrame "H2 Hs". + iPureIntro. + eapply (prim_steps_app (n, 0) (m, m')); eauto. + eapply prim_step_steps. + rewrite !fill_comp. + eapply Ectx_step; last apply Hpure; done. + Qed. + + Lemma obs_ref_bind {S} (f : HOM) (K : ectx S) e α τ1 : + ⊢ logrel τ1 α e -∗ + logrel_ectx (logrel_val τ1) f K -∗ + obs_ref (`f α) (fill K e). + Proof. + iIntros "H1 #H2". + iIntros (σ) "Hs Hcont". + iApply (wp_wand with "[H1 H2 Hs Hcont] []"); first iApply ("H1" with "[H2] [$Hs] Hcont"). + - iIntros (βv v). iModIntro. + iIntros "#Hv". + by iApply "H2". + - iIntros (βv). + iIntros "?". + iModIntro. + iFrame. + Qed. + + Definition ssubst2_valid {S : Set} + (Γ : S -> ty) + (ss : @interp_scope F natO _ S) + (γ : S [⇒] Empty_set) : iProp := + (∀ x, □ logrel (Γ x) (ss x) (γ x))%I. + + Definition logrel_valid {S : Set} + (Γ : S -> ty) + (e : expr S) + (α : @interp_scope F natO _ S -n> IT) + (τ : ty) : iProp := + (□ ∀ (ss : @interp_scope F natO _ S) + (γ : S [⇒] Empty_set), + ssubst2_valid Γ ss γ → logrel τ (α ss) (bind γ e))%I. + + Lemma compat_var {S : Set} (Γ : S -> ty) (x : S) : + ⊢ logrel_valid Γ (Var x) (interp_var x) (Γ x). + Proof. + iModIntro. iIntros (ss γ) "Hss". iApply "Hss". + Qed. + + Lemma compat_recV {S : Set} (Γ : S -> ty) (e : expr (inc (inc S))) τ1 τ2 α : + ⊢ □ logrel_valid ((Γ ▹ (Tarr τ1 τ2) ▹ τ1)) e α τ2 -∗ + logrel_valid Γ (Val $ RecV e) (interp_rec rs α) (Tarr τ1 τ2). + Proof. + iIntros "#H !> %env %γ #Henv". + set (f := (ir_unf rs α env)). + iAssert (interp_rec rs α env ≡ IT_of_V $ FunV (Next f))%I as "Hf". + { iPureIntro. apply interp_rec_unfold. } + iRewrite "Hf". + Opaque IT_of_V. + iApply logrel_of_val; term_simpl. + iExists _. iSplit. + { iPureIntro. apply into_val. } + iModIntro. + iLöb as "IH". + iIntros (αv v) "#Hw". + rewrite APP_APP'_ITV APP_Fun laterO_map_Next -Tick_eq. + pose (ss' := (extend_scope (extend_scope env (interp_rec rs α env)) (IT_of_V αv))). + set (γ' := ((mk_subst (Val (rec bind ((γ ↑) ↑)%bind e)%syn)) + ∘ ((mk_subst (shift (Val v))) ∘ ((γ ↑) ↑)))%bind). + rewrite /logrel. + iSpecialize ("H" $! ss' γ'). + set (γ1 := ((γ ↑) ↑)%bind). + iApply (logrel_head_step_pure_ectx _ EmptyK _ + ((rec bind γ1 e)%syn v) + (Tick (f (IT_of_V αv))) + (logrel_val τ2) with "[]"); last first. + + rewrite {2}/ss'. rewrite /f. + iIntros (κ K) "#HK". iIntros (σ) "Hs Hcont". + rewrite hom_tick. iApply wp_tick. iNext. + iApply ("H" with "[] [] Hs Hcont"); eauto. + rewrite /ss' /γ'. + iIntros (x'); destruct x' as [| [| x']]; term_simpl; iModIntro. + * by iApply logrel_of_val. + * iRewrite "Hf". + iIntros (κ' K') "#HK'". + iApply "HK'". + simpl. + unfold logrel_arr. + iExists (Next (ir_unf rs α env)). + iSplit; first done. + iModIntro. + iApply "IH". + * iApply "Henv". + + term_simpl. intros. subst γ1 γ'. + rewrite -!bind_bind_comp'. + apply BetaS. + Qed. + + Lemma compat_if {S : Set} (Γ : S -> ty) (e0 e1 e2 : expr S) α0 α1 α2 τ : + ⊢ logrel_valid Γ e0 α0 Tnat -∗ + logrel_valid Γ e1 α1 τ -∗ + logrel_valid Γ e2 α2 τ -∗ + logrel_valid Γ (If e0 e1 e2) (interp_if rs α0 α1 α2) τ. + Proof. + iIntros "#H0 #H1 #H2". + iModIntro. + iIntros (ss γ) "#Hss". + simpl. + pose (κ' := (IFSCtx_HOM (α1 ss) (α2 ss))). + assert ((IF (α0 ss) (α1 ss) (α2 ss)) = ((`κ') (α0 ss))) as -> by reflexivity. + term_simpl. + iIntros (κ K) "#HK". + assert ((`κ) ((IFSCtx (α1 ss) (α2 ss)) (α0 ss)) = ((`κ) ◎ (`κ')) (α0 ss)) + as -> by reflexivity. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (If (bind γ e0) (bind γ e1) (bind γ e2))%syn = + fill (ectx_compose K (IfK EmptyK (bind γ e1) (bind γ e2))) (bind γ e0)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply (obs_ref_bind with "[H0] [H1 H2]"); first by iApply "H0". + iIntros (βv v). iModIntro. iIntros "#HV". + term_simpl. + unfold logrel_nat. + iDestruct "HV" as "(%n & #Hn & ->)". + iRewrite "Hn". + unfold IFSCtx. + destruct (decide (0 < n)) as [H|H]. + - rewrite -fill_comp. + simpl. + rewrite IF_True//. + iSpecialize ("H1" with "Hss"). + term_simpl. rewrite /logrel. + iPoseProof (logrel_head_step_pure_ectx _ EmptyK + (bind γ e1)%syn _ (α1 ss) (logrel_val τ) with "H1") + as "Hrel"; last iApply ("Hrel" $! κ K with "HK"). + intros σ K0. by apply IfTrueS. + - rewrite -fill_comp. + simpl. + unfold IFSCtx. + rewrite IF_False//; last lia. + iSpecialize ("H2" with "Hss"). + term_simpl. rewrite /logrel. + iPoseProof (logrel_head_step_pure_ectx _ EmptyK + (bind γ e2)%syn _ (α2 ss) (logrel_val τ) with "H2") + as "Hrel"; last iApply ("Hrel" $! κ K with "HK"). + intros σ K0. apply IfFalseS. lia. + Qed. + + Lemma compat_input {S} Γ : + ⊢ logrel_valid Γ (Input : expr S) (interp_input rs) Tnat. + Proof. + iModIntro. + iIntros (ss γ) "#Hss". + iIntros (κ K) "#HK". + unfold interp_input. + term_simpl. + iIntros (σ) "Hs Hcont". + destruct (update_input σ) as [n σ'] eqn:Hinp. + iApply (wp_input' with "Hs [-]"); first done. + iNext. iIntros "Hlc Hs". term_simpl. + iSpecialize ("HK" $! (RetV n) (LitV n) with "[]"); first by iExists n. + iSpecialize ("HK" $! σ' with "Hs Hcont"). + rewrite IT_of_V_Ret. + iApply (wp_wand with "[$HK] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". + iModIntro. + destruct m as [m1 m2]. + iExists ((Nat.add 1 m1), (Nat.add 1 m2)), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (1, 1) (m1, m2)); eauto. + eapply prim_step_steps. + eapply Ectx_step; [reflexivity | reflexivity |]. + by constructor. + Qed. + + Lemma compat_natop {S : Set} (Γ : S -> ty) e1 e2 α1 α2 op : + ⊢ logrel_valid Γ e1 α1 Tnat -∗ + logrel_valid Γ e2 α2 Tnat -∗ + logrel_valid Γ (NatOp op e1 e2) (interp_natop rs op α1 α2) Tnat. + Proof. + iIntros "#H1 #H2". iIntros (ss γ). iModIntro. iIntros "#Hss". + iSpecialize ("H1" with "Hss"). + iSpecialize ("H2" with "Hss"). + term_simpl. + iIntros (κ K) "#HK". + set (κ' := (NatOpRSCtx_HOM op α1 ss)). + assert ((NATOP (do_natop op) (α1 ss) (α2 ss)) = ((`κ') (α2 ss))) as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (NatOp op (bind γ e1) (bind γ e2))%syn = + fill (ectx_compose K (NatOpRK op (bind γ e1) EmptyK)) (bind γ e2)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply (obs_ref_bind with "H2"). + iIntros (βv v). iModIntro. iIntros "(%n2 & #HV & ->)". + term_simpl. clear κ' sss. + rewrite -fill_comp. simpl. + pose (κ' := (NatOpLSCtx_HOM op (IT_of_V βv) ss _)). + assert ((NATOP (do_natop op) (α1 ss) (IT_of_V βv)) = ((`κ') (α1 ss))) as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (NatOp op (bind γ e1) (LitV n2))%syn = + fill (ectx_compose K (NatOpLK op EmptyK (LitV n2))) (bind γ e1)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply (obs_ref_bind with "H1"). + subst sss κ'. + term_simpl. + iIntros (t r). iModIntro. iIntros "(%n1 & #H & ->)". + simpl. + iAssert ((NATOP (do_natop op) (IT_of_V t) (IT_of_V βv)) ≡ Ret (do_natop op n1 n2))%I with "[HV H]" as "Hr". + { iRewrite "HV". simpl. + iRewrite "H". simpl. + iPureIntro. + by rewrite NATOP_Ret. + } + rewrite -fill_comp. simpl. + iApply (logrel_head_step_pure_ectx _ EmptyK (Val (LitV (do_natop op n1 n2))) with "[]"); + last done; last first. + + simpl. iRewrite "Hr". iApply (logrel_of_val Tnat (RetV (do_natop op n1 n2))). term_simpl. + iExists _. iSplit; eauto. + + intros. by constructor. + Qed. + + Lemma compat_throw {S : Set} (Γ : S -> ty) τ τ' α β e e' : + ⊢ logrel_valid Γ e α τ -∗ + logrel_valid Γ e' β (Tcont τ) -∗ + logrel_valid Γ (Throw e e') (interp_throw _ α β) τ'. + Proof. + iIntros "#H1 #H2". + iIntros (ss γ). iModIntro. iIntros "#Hss". + iIntros (κ K) "#HK". + Opaque interp_throw. + term_simpl. + pose (κ' := ThrowLSCtx_HOM β ss). + assert ((interp_throw rs α β ss) = ((`κ') (α ss))) as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (Throw (bind γ e) (bind γ e'))%syn = + fill (ectx_compose K (ThrowLK EmptyK (bind γ e'))) (bind γ e)) + as -> by by rewrite -fill_comp. + iApply obs_ref_bind; first by iApply "H1". + iIntros (βv v). iModIntro. iIntros "#Hv". + Transparent interp_throw. + simpl. + rewrite get_val_ITV' -!fill_comp. + simpl. + pose (κ'' := ThrowRSCtx_HOM (IT_of_V βv) ss _). + assert ((get_fun (λne f : laterO (IT -n> IT), THROW (IT_of_V βv) f) (β ss)) ≡ + ((`κ'') (β ss))) as ->. + { + subst κ''. simpl. by rewrite get_val_ITV. + } + rewrite HOM_ccompose. + pose (sss' := (HOM_compose κ κ'')). rewrite (HOM_compose_ccompose κ κ'' sss')//. + assert (fill K (Throw v (bind γ e'))%syn = + fill (ectx_compose K (ThrowRK v EmptyK)) (bind γ e')) + as -> by by rewrite -fill_comp. + iApply obs_ref_bind; first by iApply "H2". + iIntros (βv' v'). iModIntro. iIntros "#Hv'". + Transparent interp_throw. + simpl. + unfold logrel_cont. + iDestruct "Hv'" as "(%f & %F & HEQ & %H & #H)". + rewrite get_val_ITV. + simpl. + iRewrite "HEQ". + rewrite get_fun_fun. + simpl. + iIntros (σ) "Hs Hcont". + iApply (wp_throw' with "Hcont"). + iNext. iIntros "Hcl Hcont". term_simpl. + rewrite later_map_Next. iApply wp_tick. iNext. + iSpecialize ("H" $! βv v with "[]"); first done. + iSpecialize ("H" $! σ with "Hs Hcont"). + iApply (wp_wand with "[$H] []"). + iIntros (w) "(%m & %v'' & %σ'' & %Hstep & H)". + destruct m as [m m']. + iModIntro. + iExists ((Nat.add 2 m), m'), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (2, 0) (m, m')); eauto. + term_simpl. + eapply prim_step_steps. + eapply Throw_step; last done. + rewrite H. by rewrite -!fill_comp. + Qed. + + + Lemma compat_callcc {S : Set} (Γ : S -> ty) τ α e : + ⊢ logrel_valid (Γ ▹ Tcont τ) e α τ -∗ + logrel_valid Γ (Callcc e) (interp_callcc _ α) τ. + Proof. + iIntros "#H". + iIntros (ss γ). iModIntro. iIntros "#Hss". + iIntros (κ K) "#HK". + unfold interp_callcc. + Opaque extend_scope. + term_simpl. + iIntros (σ) "Hs Hcont". + + iApply (wp_callcc with "Hcont"). + { simpl. done. } + iNext. iIntros "Hcl Hcont". term_simpl. + + pose (ff := (λit x : IT, Tick ((`κ) x))). + match goal with + | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ extend_scope ss )?f] => set (fff := f) + end. + assert (ff ≡ fff) as <-. + { + subst ff fff. do 1 f_equiv. + epose proof (contractive_proper Next). + rewrite H; first reflexivity. + rewrite ofe_mor_ext. intro. simpl. + by rewrite later_map_Next. + } + pose (ss' := (extend_scope ss ff)). + pose (γ' := ((mk_subst (Val (ContV K)%syn)) ∘ (γ ↑)%bind)%bind : inc S [⇒] ∅). + iSpecialize ("H" $! ss' γ' with "[HK]"). + { + iIntros (x). iModIntro. + destruct x as [| x]; term_simpl; last iApply "Hss". + Transparent extend_scope. + subst ss'; simpl. + pose proof (asval_fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))). + subst ff. destruct H as [f H]. + iIntros (t r) "#H". + simpl. rewrite -H. iApply "H". + unfold logrel_cont. + iExists κ, K. + iSplit; first done. + iSplit; first done. + iModIntro. + iApply "HK". + } + iSpecialize ("H" $! κ K with "HK"). + Opaque extend_scope. + term_simpl. + iSpecialize ("H" $! σ with "Hs Hcont"). + subst ss' γ'. + iApply (wp_wand with "[$H] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". + destruct m as [m m']. + rewrite -bind_bind_comp' in Hstep. + iModIntro. + iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (1, 1) (m, m')); eauto. + eapply prim_step_steps. + eapply Ectx_step; [reflexivity | reflexivity |]. + term_simpl. + constructor. + Qed. + + Lemma compat_output {S} Γ (e: expr S) α : + ⊢ logrel_valid Γ e α Tnat -∗ + logrel_valid Γ (Output e) (interp_output rs α) Tnat. + Proof. + iIntros "#H". + iIntros (ss γ). iModIntro. iIntros "#Hss". + iIntros (κ K) "#HK". + term_simpl. + pose (κ' := OutputSCtx_HOM ss). + replace (get_ret OUTPUT (α ss)) with ((`κ') (α ss)) by reflexivity. + replace ((`κ) ((`κ') (α ss))) with (((`κ) ◎ (`κ')) (α ss)) by reflexivity. + pose (sss := (HOM_compose κ κ')). + replace (`κ ◎ `κ') with (`sss) by reflexivity. + assert (fill K (Output (bind γ e))%syn = + fill (ectx_compose K (OutputK EmptyK)) (bind γ e)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply obs_ref_bind; first by iApply "H". + iIntros (βv v). iModIntro. iIntros "#Hv". + iDestruct "Hv" as (n) "[Hb ->]". + iRewrite "Hb". simpl. + iIntros (σ) "Hs Hcont". + rewrite get_ret_ret. + iApply (wp_output' with "Hs"); first done. + iNext. iIntros "Hlc Hs". + iSpecialize ("HK" $! (RetV 0) (LitV 0) with "[]"); first by iExists 0. + iSpecialize ("HK" $! (update_output n σ) with "Hs Hcont"). + iApply (wp_wand with "[$HK] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H')". + destruct m as [m m']. + iModIntro. + iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H'". + iPureIntro. + eapply (prim_steps_app (1, 1) (m, m')); eauto. + eapply prim_step_steps. + rewrite -fill_comp. + eapply Ectx_step; [reflexivity | reflexivity |]. + by constructor. + Qed. + + Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : + ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ + logrel_valid Γ e2 α2 τ1 -∗ + logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. + Proof. + iIntros "#H1 #H2". + iIntros (ss). + iModIntro. + iIntros (γ). + iIntros "#Hss". + iSpecialize ("H1" with "Hss"). + iSpecialize ("H2" with "Hss"). + unfold interp_app. + simpl. + assert ((bind γ (App e1 e2))%syn = (fill (AppRK (bind γ e1) EmptyK) (bind γ e2))) as ->. + { reflexivity. } + pose (κ' := (AppRSCtx_HOM α1 ss)). + assert ((α1 ss ⊙ (α2 ss)) = ((`κ') (α2 ss))) as ->. + { simpl; unfold AppRSCtx. reflexivity. } + iIntros (κ K) "#HK". + assert ((`κ) ((`κ') (α2 ss)) = ((`κ) ◎ (`κ')) (α2 ss)) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ')). + assert ((`κ ◎ `κ') = (`sss)) as ->. + { reflexivity. } + rewrite fill_comp. + iApply obs_ref_bind; first by iApply "H2". + subst sss κ'. + iIntros (βv v). iModIntro. iIntros "#HV". + unfold AppRSCtx_HOM; simpl; unfold AppRSCtx. + rewrite -fill_comp. + simpl. + assert ((App (bind γ e1) v) = (fill (AppLK EmptyK v) (bind γ e1))) as ->. + { reflexivity. } + pose (κ'' := (AppLSCtx_HOM (IT_of_V βv) ss _)). + assert (((`κ) (α1 ss ⊙ (IT_of_V βv))) = (((`κ) ◎ (`κ'')) (α1 ss))) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ'')). + assert ((`κ ◎ `κ'') = (`sss)) as ->. + { reflexivity. } + rewrite fill_comp. + iApply obs_ref_bind; first by iApply "H1". + iIntros (βv' v'). iModIntro. iIntros "#HV'". + subst sss κ''. + rewrite -fill_comp. + simpl. + unfold logrel_arr. + iDestruct "HV'" as "(%f & #Hf & #HV')". + iRewrite "Hf". + iSpecialize ("HV'" $! βv v with "HV"). + iApply "HV'"; iApply "HK". + Qed. + + Lemma compat_nat {S : Set} (Γ : S -> ty) n : + ⊢ logrel_valid Γ (# n)%syn (interp_val rs (# n)%syn) ℕ%typ. + Proof. + iIntros (ss γ). iModIntro. iIntros "#Hss". + term_simpl. + iIntros (κ K) "#HK". + iSpecialize ("HK" $! (RetV n) (LitV n)). + rewrite IT_of_V_Ret. + iApply "HK". + simpl. + unfold logrel_nat. + iExists n; eauto. + Qed. + + Lemma fundamental {S : Set} (Γ : S -> ty) τ e : + typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ + with fundamental_val {S : Set} (Γ : S -> ty) τ v : + typed_val Γ v τ → ⊢ logrel_valid Γ (Val v) (interp_val rs v) τ. + Proof. + - intros H. + induction H. + + by iApply fundamental_val. + + rewrite -H. + by iApply compat_var. + + iApply compat_app. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + + iApply compat_natop. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + + iApply compat_if. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + ++ iApply IHtyped3. + + iApply compat_input. + + iApply compat_output. + iApply IHtyped. + + iApply compat_throw. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + + iApply compat_callcc. + iApply IHtyped. + - induction 1; simpl. + + iApply compat_nat. + + iApply compat_recV. by iApply fundamental. + Qed. + +End logrel. + +Definition κ {S} {E} : ITV E natO → val S := λ x, + match x with + | core.RetV n => LitV n + | _ => LitV 0 + end. +Lemma κ_Ret {S} {E} n : κ ((RetV n) : ITV E natO) = (LitV n : val S). +Proof. + Transparent RetV. unfold RetV. simpl. done. Opaque RetV. +Qed. +Definition rs : gReifiers CtxDep 2 := + gReifiers_cons (sReifier_NotCtxDep_CtxDep reify_io) + (gReifiers_cons reify_cont gReifiers_nil). + +Lemma logrel_nat_adequacy Σ `{!invGpreS Σ} `{!statePreG rs natO Σ} {S} + (α : IT (gReifiers_ops rs) natO) + (e : expr S) n σ σ' k : + (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (⊢ logrel rs Tnat α e)%I) → + ssteps (gReifiers_sReifier rs) α (σ, ((), ())) (Ret n) σ' k → + ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. +Proof. + intros Hlog Hst. + pose (ϕ := λ (βv : ITV (gReifiers_ops rs) natO), + ∃ m σ', prim_steps e σ (Val $ κ βv) σ' m). + cut (ϕ (RetV n)). + { + destruct 1 as ( m' & σ2 & Hm). + exists m', σ2. revert Hm. by rewrite κ_Ret. + } + eapply (wp_adequacy 0); eauto. + intros Hinv1 Hst1. + pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), + ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (LitV n) + ∗ ⌜∃ m σ', prim_steps e σ (Val $ LitV n) σ' m⌝)%I). + assert (NonExpansive Φ). + { + unfold Φ. + intros l a1 a2 Ha. repeat f_equiv. done. + } + exists Φ. split; first assumption. split. + - iIntros (βv). iDestruct 1 as (n'') "[H %]". + iDestruct "H" as (n') "[#H %]". simplify_eq/=. + iAssert (IT_of_V βv ≡ Ret n')%I as "#Hb". + { iRewrite "H". iPureIntro. by rewrite IT_of_V_Ret. } + iAssert (⌜βv = RetV n'⌝)%I with "[-]" as %Hfoo. + { destruct βv as [r|f]; simpl. + - iPoseProof (Ret_inj' with "Hb") as "%Hr". + fold_leibniz. eauto. + - iExFalso. iApply (IT_ret_fun_ne). + iApply internal_eq_sym. iExact "Hb". } + iPureIntro. rewrite Hfoo. unfold ϕ. + eauto. + - iIntros "[_ Hs]". + iPoseProof (Hlog) as "Hlog". + iAssert (has_substate σ ∗ cont_ctx rs)%I with "[Hs]" as "[Hs Hcont]". + { + unfold has_substate, has_full_state. + assert ((of_state rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) (σ, ((),()))) ≡ + (of_idx rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) sR_idx (sR_state σ)) + ⋅ of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state (() : sReifier_state reify_cont ♯ IT _ _))) + as -> ; last first. + { rewrite -own_op. done. } + unfold sR_idx. simpl. + intro j. + rewrite discrete_fun_lookup_op. + inv_fin j. + { unfold of_state, of_idx. simpl. + erewrite (eq_pi _ _ _ (@eq_refl _ 0%fin)). done. } + intros j. inv_fin j. + { unfold of_state, of_idx. simpl. + erewrite (eq_pi _ _ _ (@eq_refl _ 1%fin)). done. } + intros i. inversion i. + } + iSpecialize ("Hlog" $! HOM_id EmptyK with "[]"). + { + iIntros (βv v); iModIntro. iIntros "Hv". iIntros (σ'') "HS Hcont". + iApply wp_val. + iModIntro. + iExists (0, 0), v, σ''. + iSplit; first iPureIntro. + - apply prim_steps_zero. + - by iFrame. + } + simpl. + iSpecialize ("Hlog" $! σ with "Hs Hcont"). + iApply (wp_wand with"Hlog"). + iIntros ( βv). iIntros "H". + iDestruct "H" as (m' v σ1' Hsts) "[Hi Hsts]". + unfold Φ. iDestruct "Hi" as (l) "[Hβ %]". simplify_eq/=. + iExists l. iModIntro. iSplit; eauto. + iExists l. iSplit; eauto. +Qed. + +Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : + typed □ e Tnat → + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ,((), ())) (Ret k : IT _ natO) σ' n → + ∃ mm σ', prim_steps e σ (Val $ LitV k) σ' mm. +Proof. + intros Hty Hst. + pose (Σ:=#[invΣ;stateΣ rs natO]). + eapply (logrel_nat_adequacy Σ (interp_expr rs e ı_scope)); last eassumption. + intros ? ?. + iPoseProof (fundamental rs) as "H". + { apply Hty. } + unfold logrel_valid. + unshelve iSpecialize ("H" $! ı_scope _ with "[]"). + { apply ı%bind. } + { iIntros (x); destruct x. } + rewrite ebind_id; first last. + { intros ?; reflexivity. } + iApply "H". +Qed. diff --git a/theories/gitree/greifiers.v b/theories/gitree/greifiers.v index 6e224d7..db4d41c 100644 --- a/theories/gitree/greifiers.v +++ b/theories/gitree/greifiers.v @@ -3,11 +3,12 @@ From iris.base_logic.lib Require Export invariants. From gitrees Require Import prelude. From gitrees.gitree Require Import core reify. - -Section greifiers. +Section greifiers_generic. #[local] Open Scope type. + Context (a : is_ctx_dep). + Notation sReifier := (sReifier a). - (** Global reifiers: a collection of reifiers *) + (** Global reifiers: a collection of reifiers *) Inductive gReifiers : nat → Type := | gReifiers_nil : gReifiers 0 | gReifiers_cons {n} : sReifier → gReifiers n → gReifiers (S n) @@ -18,10 +19,11 @@ Section greifiers. Proof. revert P Hcons. refine match v with gReifiers_nil => tt - | gReifiers_cons sR v => λ P Hcons, Hcons sR v end. + | gReifiers_cons sR v => λ P Hcons, Hcons sR v end. Defined. - #[global] Instance gReifiers_lookup_total : ∀ m, LookupTotal (fin m) sReifier (gReifiers m) := + #[global] Instance gReifiers_lookup_total + : ∀ m, LookupTotal (fin m) sReifier (gReifiers m) := fix go m i {struct i} := let _ : ∀ m, LookupTotal _ _ _ := @go in match i in fin m return gReifiers m → sReifier with | 0%fin => grs_S_inv (λ _, sReifier) (λ x _, x) @@ -30,7 +32,7 @@ Section greifiers. Program Definition gReifiers_ops {n} (rs : gReifiers n) : opsInterp := {| opid := { i : fin n & opid (sReifier_ops (rs !!! i)) }; - opsInterp_lookup := λ iop, sReifier_ops (rs !!! projT1 iop) (projT2 iop) + opsInterp_lookup := λ iop, sReifier_ops (rs !!! projT1 iop) (projT2 iop) |}. Next Obligation. intros n rs. @@ -65,14 +67,14 @@ Section greifiers. Fixpoint gState_rest {m} (i : fin m) : gReifiers m → oFunctor := match i in fin m return gReifiers m → oFunctor with | 0%fin => grs_S_inv (λ _, oFunctor) - (λ sR rs, gReifiers_state rs) + (λ sR rs, gReifiers_state rs) | FS j => grs_S_inv (λ _, oFunctor) - (λ sR rs, sReifier_state sR * gState_rest j rs)%OF + (λ sR rs, sReifier_state sR * gState_rest j rs)%OF end. Lemma gState_decomp' {m} (i : fin m) (rs : gReifiers m) {X} `{!Cofe X} : gReifiers_state rs ♯ X ≃ - ((sReifier_state (rs !!! i) ♯ X) * (gState_rest i rs ♯ X))%type. + ((sReifier_state (rs !!! i) ♯ X) * (gState_rest i rs ♯ X))%type. Proof. revert i. induction rs as [|n r rs]=>i. { inversion i. } @@ -105,44 +107,98 @@ Section greifiers. Proof. rewrite ofe_iso_12. reflexivity. Qed. Lemma gState_recomp_decomp {m} (i : fin m) {rs : gReifiers m} {X} `{!Cofe X} (σ : sReifier_state (rs !!! i) ♯ X) rest fs : - gState_decomp i fs ≡ (σ, rest) → - gState_recomp rest σ ≡ fs. + gState_decomp i fs ≡ (σ, rest) → + gState_recomp rest σ ≡ fs. Proof. unfold gState_recomp. simpl. intros <-. rewrite ofe_iso_21//. Qed. Opaque gState_recomp gState_decomp. - Program Definition gReifiers_re {n} (rs : gReifiers n) {X} `{!Cofe X} - (op : opid (gReifiers_ops rs)) : - (Ins (gReifiers_ops rs op) ♯ X) * (gReifiers_state rs ♯ X) -n> - optionO ((Outs (gReifiers_ops rs op) ♯ X) * (gReifiers_state rs ♯ X)) +End greifiers_generic. + +Section greifiers. + #[local] Open Scope type. + + Program Definition gReifiers_re_ctx_indep {n} (rs : gReifiers NotCtxDep n) {X} `{!Cofe X} + (op : opid (gReifiers_ops NotCtxDep rs)) : + (Ins (gReifiers_ops NotCtxDep rs op) ♯ X) * (gReifiers_state NotCtxDep rs ♯ X) -n> + optionO ((Outs (gReifiers_ops NotCtxDep rs op) ♯ X) * (gReifiers_state NotCtxDep rs ♯ X)) := λne xst, let i := projT1 op in let op' := projT2 op in let x := xst.1 in let st := xst.2 in - let fs := gState_decomp i st in + let fs := gState_decomp NotCtxDep i st in let σ := fs.1 in let rest := fs.2 in let rx := sReifier_re (rs !!! i) op' (x, σ) in - optionO_map (prodO_map idfun (gState_recomp rest)) rx. + optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) rx. Next Obligation. solve_proper_please. Qed. + Program Definition gReifiers_re_ctx_dep {n} (rs : gReifiers CtxDep n) {X} `{!Cofe X} + (op : opid (gReifiers_ops CtxDep rs)) : + (Ins (gReifiers_ops CtxDep rs op) ♯ X) * (gReifiers_state CtxDep rs ♯ X) + * ((Outs (gReifiers_ops CtxDep rs op) ♯ X) -n> laterO X) -n> + optionO (laterO X * (gReifiers_state CtxDep rs ♯ X)) + := λne xst, + let i := projT1 op in + let op' := projT2 op in + let a := xst.1.1 in + let b := xst.1.2 in + let c := xst.2 in + let fs := gState_decomp CtxDep i b in + let σ := fs.1 in + let rest := fs.2 in + let rx := sReifier_re (rs !!! i) op' (a, σ, c) in + optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) rx. + Next Obligation. solve_proper_please. Qed. + + Program Definition gReifiers_re_type {n} + (a : is_ctx_dep) (rs : gReifiers a n) {X} `{!Cofe X} + (op : opid (gReifiers_ops a rs)) : ofe := + match a with + | CtxDep => + prodO (prodO (Ins (gReifiers_ops a rs op) ♯ X) (gReifiers_state a rs ♯ X)) + (Outs (gReifiers_ops a rs op) ♯ X -n> laterO X) -n> + optionO (prodO (laterO X) (gReifiers_state a rs ♯ X)) + | NotCtxDep => + prodO (Ins (gReifiers_ops a rs op) ♯ X) (gReifiers_state a rs ♯ X) -n> + optionO (prodO (Outs (gReifiers_ops a rs op) ♯ X) (gReifiers_state a rs ♯ X)) + end. + + Program Definition gReifiers_re {n} (a : is_ctx_dep) (rs : gReifiers a n) + {X} `{!Cofe X} + (op : opid (gReifiers_ops a rs)) : + @gReifiers_re_type n a rs X _ op. + Proof. + destruct a. + - apply gReifiers_re_ctx_dep. + - apply gReifiers_re_ctx_indep. + Defined. + (** We can turn a collection of reifiers into a single reifier *) - Definition gReifiers_sReifier {n} (rs : gReifiers n) : sReifier := - {| sReifier_ops := gReifiers_ops rs; - sReifier_state := gReifiers_state rs; - sReifier_re := @gReifiers_re n rs; + Program Definition gReifiers_sReifier {n} (a : is_ctx_dep) (rs : gReifiers a n) + : sReifier a := + {| sReifier_ops := gReifiers_ops a rs; + sReifier_state := gReifiers_state a rs; + sReifier_re X _ op := _; |}. + Next Obligation. + intros n [|] rs X ? op. + - apply (@gReifiers_re n CtxDep rs X _ op). + - apply (@gReifiers_re n NotCtxDep rs X _ op). + Defined. - Lemma gReifiers_re_idx {n} (i : fin n) (rs : gReifiers n) + Lemma gReifiers_re_idx_ctx_dep {n} (i : fin n) (rs : gReifiers CtxDep n) {X} `{!Cofe X} (op : opid (sReifier_ops (rs !!! i))) (x : Ins (sReifier_ops _ op) ♯ X) - (σ : sReifier_state (rs !!! i) ♯ X) (rest : gState_rest i rs ♯ X) : - gReifiers_re rs (existT i op) (x, gState_recomp rest σ) ≡ - optionO_map (prodO_map idfun (gState_recomp rest)) - (sReifier_re (rs !!! i) op (x,σ)). + (σ : sReifier_state (rs !!! i) ♯ X) + (rest : gState_rest CtxDep i rs ♯ X) + (κ : (Outs (sReifier_ops (rs !!! i) op) ♯ X -n> laterO X)) : + gReifiers_re CtxDep rs (existT i op) (x, gState_recomp CtxDep rest σ, κ) ≡ + optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) + (sReifier_re (rs !!! i) op (x, σ, κ)). Proof. unfold gReifiers_re. cbn-[prodO_map optionO_map]. f_equiv; last repeat f_equiv. @@ -153,49 +209,135 @@ Section greifiers. - rewrite gState_decomp_recomp//. Qed. - Class subReifier {n} (r : sReifier) (rs : gReifiers n) := + Lemma gReifiers_re_idx_ctx_indep {n} (i : fin n) (rs : gReifiers NotCtxDep n) + {X} `{!Cofe X} (op : opid (sReifier_ops (rs !!! i))) + (x : Ins (sReifier_ops _ op) ♯ X) + (σ : sReifier_state (rs !!! i) ♯ X) + (rest : gState_rest NotCtxDep i rs ♯ X) : + gReifiers_re NotCtxDep rs (existT i op) (x, gState_recomp NotCtxDep rest σ) ≡ + optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) + (sReifier_re (rs !!! i) op (x, σ)). + Proof. + unfold gReifiers_re. cbn-[prodO_map optionO_map]. + f_equiv; last repeat f_equiv. + - eapply optionO_map_proper. + intros [x1 x2]; simpl. f_equiv. + f_equiv. f_equiv. + rewrite gState_decomp_recomp//. + - rewrite gState_decomp_recomp//. + Qed. + + Program Definition gReifiers_re_idx_type {n} a (i : fin n) (rs : gReifiers a n) + {X} `{!Cofe X} (op : opid (sReifier_ops (rs !!! i))) + (x : Ins (sReifier_ops _ op) ♯ X) + (σ : sReifier_state (rs !!! i) ♯ X) + (rest : gState_rest a i rs ♯ X) : + Type. + Proof. + destruct a. + - apply (∀ (κ : (Outs (sReifier_ops (rs !!! i) op) ♯ X -n> laterO X)), + gReifiers_re CtxDep rs (existT i op) (x, gState_recomp CtxDep rest σ, κ) ≡ + optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) + (sReifier_re (rs !!! i) op (x, σ, κ))). + - apply (gReifiers_re NotCtxDep rs (existT i op) (x, gState_recomp NotCtxDep rest σ) ≡ + optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) + (sReifier_re (rs !!! i) op (x, σ))). + Defined. + + Lemma gReifiers_re_idx {n} a (i : fin n) (rs : gReifiers a n) + {X} `{!Cofe X} (op : opid (sReifier_ops (rs !!! i))) + (x : Ins (sReifier_ops _ op) ♯ X) + (σ : sReifier_state (rs !!! i) ♯ X) + (rest : gState_rest a i rs ♯ X) : gReifiers_re_idx_type a i rs op x σ rest. + Proof. + destruct a. + - intros κ. apply gReifiers_re_idx_ctx_dep. + - apply gReifiers_re_idx_ctx_indep. + Qed. + + Program Definition sR_re_type {n} + {X} `{!Cofe X} (a : is_ctx_dep) (r : sReifier a) (rs : gReifiers a n) + (sR_idx : fin n) + (sR_ops : subEff (sReifier_ops r) (sReifier_ops (rs !!! sR_idx))) + (sR_state : sReifier_state r ♯ X ≃ sReifier_state (rs !!! sR_idx) ♯ X) + (m : nat) (op : opid (sReifier_ops r)) : Type. + Proof. + destruct a. + - apply (∀ (x : Ins (sReifier_ops r op) ♯ X) + (y : laterO X) + (s1 s2 : sReifier_state r ♯ X) + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)), + sReifier_re r op (x, s1, k) ≡{m}≡ Some (y, s2) → + @sReifier_re CtxDep (rs !!! sR_idx) _ _ (subEff_opid op) + (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡{m}≡ + Some (y, sR_state s2)). + - apply (∀ (x : Ins (sReifier_ops _ op) ♯ X) + (y : Outs (sReifier_ops _ op) ♯ X) + (s1 s2 : sReifier_state r ♯ X), + sReifier_re r op (x, s1) ≡{m}≡ Some (y, s2) → + @sReifier_re NotCtxDep (rs !!! sR_idx) _ _ (subEff_opid op) + (subEff_ins x, sR_state s1) ≡{m}≡ + Some (subEff_outs y, sR_state s2)). + Defined. + + Class subReifier {n} {a : is_ctx_dep} (r : sReifier a) (rs : gReifiers a n) := { sR_idx : fin n; sR_ops :: subEff (sReifier_ops r) (sReifier_ops (rs !!! sR_idx)); - sR_state {X} `{!Cofe X} : - sReifier_state r ♯ X ≃ sReifier_state (rs !!! sR_idx) ♯ X; + sR_state {X} `{!Cofe X} : + sReifier_state r ♯ X ≃ sReifier_state (rs !!! sR_idx) ♯ X; sR_re (m : nat) {X} `{!Cofe X} (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops _ op) ♯ X) - (y : Outs (sReifier_ops _ op) ♯ X) - (s1 s2 : sReifier_state r ♯ X) : - sReifier_re r op (x, s1) ≡{m}≡ Some (y, s2) → - sReifier_re (rs !!! sR_idx) (subEff_opid op) - (subEff_ins x, sR_state s1) ≡{m}≡ - Some (subEff_outs y, sR_state s2) }. - - #[global] Instance subReifier_here {n} (r : sReifier) (rs : gReifiers n) : - subReifier r (gReifiers_cons r rs). + : sR_re_type a r rs sR_idx sR_ops (@sR_state X _) m op + }. + + #[global] Instance subReifier_here {n} {a : is_ctx_dep} + (r : sReifier a) (rs : gReifiers a n) : + subReifier r (gReifiers_cons a r rs). Proof. simple refine ({| sR_idx := 0%fin |}). - simpl. apply subEff_id. - simpl. intros. apply iso_ofe_refl. - - intros X ? op x y s1 s2. - simpl. eauto. + - destruct a. + + intros X ? op x y ? s1 s2 k HEQ; simpl. + unfold ofe_iso_1'; simpl. + rewrite ccompose_id_r HEQ. + reflexivity. + + intros X ? op x y s1 s2. + simpl. eauto. Defined. - #[global] Instance subReifier_there {n} (r r' : sReifier) (rs : gReifiers n) : + + #[global] Instance subReifier_there {n} {a : is_ctx_dep} + (r r' : sReifier a) (rs : gReifiers a n) : subReifier r rs → - subReifier r (gReifiers_cons r' rs). + subReifier r (gReifiers_cons a r' rs). Proof. intros SR. simple refine ({| sR_idx := FS sR_idx |}). - simpl. intros. apply sR_state. - - intros X ? op x y s1 s2. - simpl. apply sR_re. + - destruct a. + + intros ? X ? op x y s1 s2. + simpl. intros. + pose proof (@sR_re n CtxDep r rs _ m X _ op) as G. + simpl in G. + by apply G. + + intros ? X ? op x y s1 s2. + simpl. intros. + pose proof (@sR_re n NotCtxDep r rs _ m X _ op) as G. + simpl in G. + by apply G. Defined. - #[local] Definition subR_op {n} {r : sReifier} {rs : gReifiers n} `{!subReifier r rs} : - opid (sReifier_ops r) → opid (gReifiers_ops rs). + #[local] Definition subR_op {n} {a : is_ctx_dep} + {r : sReifier a} {rs : gReifiers a n} `{!subReifier r rs} : + opid (sReifier_ops r) → opid (gReifiers_ops a rs). Proof. intros op. simpl. refine (existT sR_idx (subEff_opid op)). Defined. - #[export] Instance subReifier_subEff {n} {r : sReifier} {rs : gReifiers n} `{!subReifier r rs} : - subEff (sReifier_ops r) (gReifiers_ops rs). + + #[export] Instance subReifier_subEff {n} {a : is_ctx_dep} + {r : sReifier a} {rs : gReifiers a n} `{!subReifier r rs} : + subEff (sReifier_ops r) (gReifiers_ops a rs). Proof. simple refine {| subEff_opid := subR_op |}. - intros op X ?. simpl. @@ -204,78 +346,243 @@ Section greifiers. apply subEff_outs. Defined. - Lemma subReifier_reify_idx {n} (r : sReifier) (rs : gReifiers n) + #[export] Instance reifier_coercion_subEff {sz} r (rs : gReifiers CtxDep sz) + `{H : !subReifier (sReifier_NotCtxDep_CtxDep r) rs} : + subEff (sReifier_ops r) (gReifiers_ops _ rs) | 100. + Proof. + simple refine + {| subEff_opid (op : opid (sReifier_ops (sReifier_NotCtxDep_CtxDep r))) + := subEff_opid op |}. + - intros. apply subEff_ins. + - intros. apply subEff_outs. + Defined. + + Program Definition subReifier_reify_idx_type {n} + (a : is_ctx_dep) (r : sReifier a) (rs : gReifiers a n) + `{!subReifier r rs} X `{!Cofe X} (op : opid (sReifier_ops r)) : Type. + Proof. + destruct a. + - apply (∀ (x : Ins (sReifier_ops r op) ♯ X) + (y : laterO X) + (s1 s2 : sReifier_state r ♯ X) + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)), + sReifier_re r op (x, s1, k) ≡ Some (y, s2) → + @sReifier_re CtxDep (rs !!! sR_idx) _ _ (subEff_opid op) + (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡ + Some (y, sR_state s2)). + - apply (∀ (x : Ins (sReifier_ops _ op) ♯ X) + (y : Outs (sReifier_ops _ op) ♯ X) + (s1 s2 : sReifier_state r ♯ X), + sReifier_re r op (x, s1) ≡ Some (y, s2) → + @sReifier_re NotCtxDep (rs !!! sR_idx) _ _ (subEff_opid op) + (subEff_ins x, sR_state s1) ≡ + Some (subEff_outs y, sR_state s2)). + Defined. + + Lemma subReifier_reify_idx {n} {a : is_ctx_dep} + (r : sReifier a) (rs : gReifiers a n) `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops _ op) ♯ X) - (y : Outs (sReifier_ops _ op) ♯ X) - (s1 s2 : sReifier_state r ♯ X) : - sReifier_re r op (x, s1) ≡ Some (y, s2) → - sReifier_re (rs !!! sR_idx) (subEff_opid op) - (subEff_ins x, sR_state s1) ≡ - Some (subEff_outs y, sR_state s2). + : subReifier_reify_idx_type a r rs X op. Proof. - intros Hx. apply equiv_dist=>m. - apply sR_re. by apply equiv_dist. + destruct a. + - intros Hx. intros. apply equiv_dist=>m. + pose proof (@sR_re n CtxDep r rs _ m X _ op Hx y s1 s2 k) as G. + simpl in G. + rewrite G; first done. + by apply equiv_dist. + - intros Hx. intros. apply equiv_dist=>m. + pose proof (@sR_re n NotCtxDep r rs _ m X _ op Hx y s1 s2) as G. + simpl in G. + rewrite G; first done. + by apply equiv_dist. Qed. - Lemma subReifier_reify {n} (r : sReifier) - (rs : gReifiers n) `{!subReifier r rs} {X} `{!Cofe X} - (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) - (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : - sReifier_re r op (x,σ) ≡ Some (y, σ') → - gReifiers_re rs (subEff_opid op) - (subEff_ins x, gState_recomp rest (sR_state σ)) - ≡ Some (subEff_outs y, gState_recomp rest (sR_state σ')). + Program Definition subReifier_reify_type {n} (a : is_ctx_dep) (r : sReifier a) + (rs : gReifiers a n) `{!subReifier r rs} X `{!Cofe X} + (op : opid (sReifier_ops r)) : Type. + Proof. + destruct a. + - apply (∀ (x : Ins (sReifier_ops _ op) ♯ X) (y : laterO X) + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) + (σ σ' : sReifier_state r ♯ X) (rest : gState_rest CtxDep sR_idx rs ♯ X), + sReifier_re r op (x, σ, k) ≡ Some (y, σ') → + gReifiers_re CtxDep rs (subEff_opid op) + (subEff_ins x, gState_recomp CtxDep rest (sR_state σ), k ◎ (subEff_outs ^-1)) + ≡ Some (y, gState_recomp CtxDep rest (sR_state σ'))). + - apply (∀ (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) + (σ σ' : sReifier_state r ♯ X) (rest : gState_rest NotCtxDep sR_idx rs ♯ X), + sReifier_re r op (x,σ) ≡ Some (y, σ') → + gReifiers_re NotCtxDep rs (subEff_opid op) + (subEff_ins x, gState_recomp NotCtxDep rest (sR_state σ)) + ≡ Some (subEff_outs y, gState_recomp NotCtxDep rest (sR_state σ'))). + Defined. + + Lemma subReifier_reify {n} {a : is_ctx_dep} (r : sReifier a) + (rs : gReifiers a n) `{!subReifier r rs} {X} `{!Cofe X} + (op : opid (sReifier_ops r)) : subReifier_reify_type a r rs X op. Proof. - intros Hre. - eapply subReifier_reify_idx in Hre. - rewrite gReifiers_re_idx//. - rewrite Hre. simpl. reflexivity. + destruct a. + - simpl. + intros x y k σ σ' H Hre. + pose proof (@subReifier_reify_idx n CtxDep r rs _ X _ op x y σ σ' k Hre) as J; clear Hre. + simpl in J. + pose proof (@gReifiers_re_idx n CtxDep sR_idx rs X _ (subEff_opid op)) as J'. + simpl in J'. + rewrite J'; clear J'. + transitivity (prod_map (λ x0 : laterO X, x0) + (λ st : sReifier_state (rs !!! sR_idx) ♯ X, + (gState_decomp' CtxDep sR_idx rs ^-1) (st, H)) <$> + (Some (y, sR_state σ'))). + + unfold prod_map. + rewrite option_fmap_proper; [reflexivity | intros ??? | apply J]. + do 2 f_equiv; first assumption. + do 2 f_equiv; assumption. + + simpl; reflexivity. + - simpl. + intros x y σ σ' rest Hre. + pose proof (@subReifier_reify_idx n NotCtxDep r rs _ X _ op x y σ σ' Hre) + as J; clear Hre. + simpl in J. + pose proof (@gReifiers_re_idx n NotCtxDep sR_idx rs X _ (subEff_opid op)) + as J'. + simpl in J'. + rewrite J'; clear J'. + transitivity (prod_map (λ x0 : Outs (sReifier_ops (rs !!! sR_idx) + (subEff_opid op)) ♯ X, x0) + (λ st : sReifier_state (rs !!! sR_idx) ♯ X, + (gState_decomp' NotCtxDep sR_idx rs ^-1) (st, rest)) <$> + (Some (subEff_outs y, sR_state σ'))). + + unfold prod_map. + rewrite option_fmap_proper; [reflexivity | intros ??? | apply J]. + do 2 f_equiv; first assumption. + do 2 f_equiv; assumption. + + simpl; reflexivity. Qed. (** Lemma for reasoning internally in iProp *) Context `{!invGS_gen hlc Σ}. Notation iProp := (iProp Σ). Context {sz : nat}. - Variable (rs : gReifiers sz). - Notation sr := (gReifiers_sReifier rs). + Notation sr a rs := (gReifiers_sReifier a rs). - Lemma reify_vis_eqI {A} `{!Cofe A} op i k o σ σ' : - (gReifiers_re rs op (i,σ) ≡ Some (o,σ') ⊢@{iProp} reify sr (Vis op i k : IT _ A) σ ≡ (σ', Tau $ k o))%I. + Lemma reify_vis_eqI_ctx_dep (rs : gReifiers CtxDep sz) + {A} `{!Cofe A} op i k o σ σ' : + (gReifiers_re CtxDep rs op (i, σ, k) ≡ Some (o,σ') + ⊢@{iProp} reify (sr CtxDep rs) (Vis op i k : IT _ A) σ ≡ (σ', Tau $ o))%I. Proof. apply uPred.internal_eq_entails=>m. - intros H. apply reify_vis_dist. exact H. + intros H. apply reify_vis_dist_ctx_dep. exact H. Qed. - Lemma subReifier_reify_idxI (r : sReifier) - `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) + + Lemma reify_vis_eqI_ctx_indep (rs : gReifiers NotCtxDep sz) + {A} `{!Cofe A} op i k o σ σ' : + (gReifiers_re NotCtxDep rs op (i, σ) ≡ Some (o,σ') + ⊢@{iProp} reify (sr NotCtxDep rs) (Vis op i k : IT _ A) σ ≡ (σ', Tau $ k o))%I. + Proof. + apply uPred.internal_eq_entails=>m. + intros H. apply reify_vis_dist_ctx_indep. exact H. + Qed. + + Lemma subReifier_reify_idxI_ctx_dep (r : sReifier CtxDep) + `{!@subReifier sz CtxDep r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) + (x : Ins (sReifier_ops _ op) ♯ X) + (y : laterO X) + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) + (s1 s2 : sReifier_state r ♯ X) : + sReifier_re r op (x, s1, k) ≡ Some (y, s2) + ⊢@{iProp} + sReifier_re (rs !!! sR_idx) (subEff_opid op) + (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡ + Some (y, sR_state s2). + Proof. + apply uPred.internal_eq_entails=>m. + intros H'. + rewrite (@sR_re _ CtxDep); last first. + - rewrite H'. + reflexivity. + - reflexivity. + Qed. + + Lemma subReifier_reify_idxI_ctx_indep (r : sReifier NotCtxDep) + `{!@subReifier sz NotCtxDep r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) (s1 s2 : sReifier_state r ♯ X) : - sReifier_re r op (x, s1) ≡ Some (y, s2) ⊢@{iProp} - sReifier_re (rs !!! sR_idx) (subEff_opid op) - (subEff_ins x, sR_state s1) ≡ - Some (subEff_outs y, sR_state s2). + sReifier_re r op (x, s1) ≡ Some (y, s2) + ⊢@{iProp} + sReifier_re (rs !!! sR_idx) (subEff_opid op) + (subEff_ins x, sR_state s1) ≡ + Some (subEff_outs y, sR_state s2). + Proof. + apply uPred.internal_eq_entails=>m. + apply (@sR_re _ NotCtxDep). + Qed. + + Lemma subReifier_reifyI_ctx_dep (r : sReifier CtxDep) + `{!@subReifier sz CtxDep r rs} {X} `{!Cofe X} + (op : opid (sReifier_ops r)) + (x : Ins (sReifier_ops _ op) ♯ X) (y : laterO X) + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) + (σ σ' : sReifier_state r ♯ X) (rest : gState_rest CtxDep sR_idx rs ♯ X) : + sReifier_re r op (x,σ, k) ≡ Some (y, σ') + ⊢@{iProp} + gReifiers_re CtxDep rs (subEff_opid op) + (subEff_ins x, gState_recomp CtxDep rest (sR_state σ), k ◎ (subEff_outs ^-1)) + ≡ Some (y, gState_recomp CtxDep rest (sR_state σ')). Proof. apply uPred.internal_eq_entails=>m. - apply sR_re. + intros He. + eapply (@sR_re _ CtxDep) in He. + rewrite (gReifiers_re_idx CtxDep)//. + rewrite He. simpl. + reflexivity. Qed. - Lemma subReifier_reifyI (r : sReifier) - `{!subReifier r rs} {X} `{!Cofe X} + Lemma subReifier_reifyI_ctx_indep (r : sReifier NotCtxDep) + `{!@subReifier sz NotCtxDep r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) - (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : - sReifier_re r op (x,σ) ≡ Some (y, σ') ⊢@{iProp} - gReifiers_re rs (subEff_opid op) - (subEff_ins x, gState_recomp rest (sR_state σ)) - ≡ Some (subEff_outs y, gState_recomp rest (sR_state σ')). + (σ σ' : sReifier_state r ♯ X) (rest : gState_rest NotCtxDep sR_idx rs ♯ X) : + sReifier_re r op (x,σ) ≡ Some (y, σ') + ⊢@{iProp} + gReifiers_re NotCtxDep rs (subEff_opid op) + (subEff_ins x, gState_recomp NotCtxDep rest (sR_state σ)) + ≡ Some (subEff_outs y, gState_recomp NotCtxDep rest (sR_state σ')). Proof. apply uPred.internal_eq_entails=>m. intros He. - eapply sR_re in He. - rewrite gReifiers_re_idx//. - rewrite He. simpl. reflexivity. + eapply (@sR_re _ NotCtxDep) in He. + pose proof (@gReifiers_re_idx sz NotCtxDep sR_idx rs X _ (subEff_opid op) + (subEff_ins x)) as J. + simpl in J. + simpl. + rewrite J//; clear J. + transitivity (prod_map (λ x0 : Outs (sReifier_ops (rs !!! sR_idx) + (subEff_opid op)) ♯ X, x0) + (λ st : sReifier_state (rs !!! sR_idx) ♯ X, + (gState_decomp' NotCtxDep sR_idx rs ^-1) (st, rest)) <$> + (Some + (subEff_outs y, sR_state σ'))). + - unfold prod_map. + rewrite option_fmap_ne; [reflexivity | intros ??? | apply He]. + do 2 f_equiv; first assumption. + do 2 f_equiv; assumption. + - simpl. + reflexivity. Qed. End greifiers. + +Arguments gReifiers_cons {_ _}. +Arguments gReifiers_nil {_}. +Arguments gReifiers_ops {_ _}. +Arguments gReifiers_re {_ _}. +Arguments gState_rest {_ _}. +Arguments gState_recomp {_ _ _ _ _ _}. +Arguments gState_decomp {_ _} _ {_ _ _}. +Arguments gState_decomp' {_ _} _ {_ _ _}. +Arguments gReifiers_state {_ _}. +Arguments gReifiers_re_idx {_ _}. +Arguments gReifiers_re_idx_type {_ _}. +Arguments gReifiers_re_type {_ _}. +Arguments gReifiers_sReifier {_ _}. diff --git a/theories/gitree/reductions.v b/theories/gitree/reductions.v index fbb86f1..e5833d9 100644 --- a/theories/gitree/reductions.v +++ b/theories/gitree/reductions.v @@ -4,16 +4,13 @@ From gitrees Require Import prelude. From gitrees.gitree Require Import core reify. Section sstep. - Context {A} `{!Cofe A}. - Context (r : sReifier). + Context {A} `{!Cofe A} {a : is_ctx_dep}. + Context (r : sReifier a). Notation F := (sReifier_ops r). Notation stateF := (sReifier_state r). Notation IT := (IT F A). Notation ITV := (ITV F A). Notation stateO := (stateF ♯ IT). - Implicit Type op : opid F. - Implicit Type α β : IT. - Implicit Type σ : stateO. (** ** Reductions at the Prop level *) Inductive sstep : IT → stateO → IT → stateO → Prop := @@ -25,7 +22,8 @@ Section sstep. α ≡ Vis op i k → reify r α σ1 ≡ (σ2, Tick β) → sstep α σ1 β σ2. - #[export] Instance sstep_proper : Proper ((≡) ==> (≡) ==> (≡) ==> (≡) ==> (iff)) sstep. + #[export] Instance sstep_proper + : Proper ((≡) ==> (≡) ==> (≡) ==> (≡) ==> (iff)) sstep. Proof. intros α1 α2 Ha σ1 σ2 Hs β1 β2 Hb σ'1 σ'2 Hs'. simplify_eq/=. split. @@ -47,13 +45,14 @@ Section sstep. rewrite -H0. repeat f_equiv; eauto. Qed. - Inductive ssteps : IT → stateO → IT → stateO → nat → Prop := + Inductive ssteps : IT → stateO → IT → stateO → nat → Prop := | ssteps_zero α β σ σ' : α ≡ β → σ ≡ σ' → ssteps α σ β σ' 0 | ssteps_many α1 σ1 α2 σ2 α3 σ3 n2 : sstep α1 σ1 α2 σ2 → ssteps α2 σ2 α3 σ3 n2 → ssteps α1 σ1 α3 σ3 (1+n2). - #[export] Instance ssteps_proper : Proper ((≡) ==> (≡) ==> (≡) ==> (≡) ==> (=) ==> (iff)) ssteps. + #[export] Instance ssteps_proper + : Proper ((≡) ==> (≡) ==> (≡) ==> (≡) ==> (=) ==> (iff)) ssteps. Proof. intros α α' Ha σ σ' Hs β β' Hb σ2 σ2' Hs2 n1 n2 Hnm. fold_leibniz. simplify_eq/=. @@ -87,8 +86,8 @@ Section sstep. End sstep. Section istep. - Context {A} `{!Cofe A}. - Context (r : sReifier). + Context {A} `{!Cofe A} {a : is_ctx_dep}. + Context (r : sReifier a). Notation F := (sReifier_ops r). Notation stateF := (sReifier_state r). Notation IT := (IT F A). @@ -105,11 +104,11 @@ Section istep. Solve All Obligations with solve_proper. Program Definition isteps_pre - (self : IT -n> stateO -n> IT -n> stateO -n> natO -n> iProp): + (self : IT -n> stateO -n> IT -n> stateO -n> natO -n> iProp): IT -n> stateO -n> IT -n> stateO -n> natO -n> iProp := λne α σ β σ' n, ((n ≡ 0 ∧ α ≡ β ∧ σ ≡ σ') - ∨ (∃ n' α0 σ0, n ≡ (1+n') ∧ istep α σ α0 σ0 ∧ - ▷ self α0 σ0 β σ' n'))%I. + ∨ (∃ n' α0 σ0, n ≡ (1+n') ∧ istep α σ α0 σ0 ∧ + ▷ self α0 σ0 β σ' n'))%I. Solve All Obligations with solve_proper. Global Instance isteps_pre_ne : NonExpansive isteps_pre. @@ -122,8 +121,8 @@ Section istep. Lemma isteps_unfold α β σ σ' n : isteps α σ β σ' n ≡ ((n ≡ 0 ∧ α ≡ β ∧ σ ≡ σ') - ∨ (∃ n' α0 σ0, n ≡ (1+n') ∧ istep α σ α0 σ0 ∧ - ▷ isteps α0 σ0 β σ' n'))%I. + ∨ (∃ n' α0 σ0, n ≡ (1+n') ∧ istep α σ α0 σ0 ∧ + ▷ isteps α0 σ0 β σ' n'))%I. Proof. unfold isteps. apply (fixpoint_unfold isteps_pre _ _ _ _ _) . Qed. @@ -179,7 +178,7 @@ Section istep. Proof. intros Hprf. destruct (IT_dont_confuse α) - as [[e Ha] | [[n Ha] | [ [g Ha] | [[α' Ha]|[op [i [k Ha]]]] ]]]. + as [[e Ha] | [[n Ha] | [ [g Ha] | [[α' Ha]|[op [i [k Ha]]]] ]]]. + exfalso. eapply uPred.pure_soundness. iPoseProof (Hprf) as "H". iDestruct "H" as (β σ') "[Ha Hs]". rewrite Ha. @@ -200,13 +199,14 @@ Section istep. iApply (IT_tick_vis_ne). by iApply (internal_eq_sym with "Ha"). Qed. + (* ctx-free steps *) Local Lemma effect_safe_externalize (α : IT) σ : (⊢ ∃ β σ', (∃ op i k, α ≡ Vis op i k ∧ reify r α σ ≡ (σ', Tick β)) : iProp) → ∃ β σ', sstep r α σ β σ'. Proof. intros Hprf. destruct (IT_dont_confuse α) - as [[e Ha] | [[n Ha] | [ [g Ha] | [[α' Ha]|[op [i [k Ha]]]] ]]]. + as [[e Ha] | [[n Ha] | [ [g Ha] | [[α' Ha]|[op [i [k Ha]]]] ]]]. + exfalso. eapply uPred.pure_soundness. iPoseProof (Hprf) as "H". iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. @@ -227,7 +227,8 @@ Section istep. + destruct (reify r (Vis op i k) σ) as [σ1 α1] eqn:Hr. assert ((∃ α' : IT, α1 ≡ Tick α') ∨ (α1 ≡ Err RuntimeErr)) as [[α' Ha']| Ha']. { eapply (reify_is_always_a_tick r op i k σ). - by rewrite Hr. } + by rewrite Hr. + } * exists α',σ1. eapply sstep_reify; eauto. rewrite -Ha' -Hr; repeat f_equiv; eauto. * exfalso. eapply uPred.pure_soundness. @@ -244,7 +245,7 @@ Section istep. Local Lemma istep_safe_disj α σ : (∃ β σ', istep α σ β σ') - ⊢ (∃ β σ', α ≡ Tick β ∧ σ ≡ σ') + ⊢ (∃ β σ', α ≡ Tick β ∧ σ ≡ σ') ∨ (∃ β σ', (∃ op i k, α ≡ Vis op i k ∧ reify r α σ ≡ (σ', Tick β))). Proof. rewrite -bi.or_exist. @@ -319,7 +320,8 @@ Section istep. ++ iApply (IT_fun_vis_ne with "Ht"). Qed. Lemma isteps_tick α βv σ σ' k : - isteps (Tick α) σ (IT_of_V βv) σ' k ⊢ ∃ k' : nat, ⌜k = (1 + k')%nat⌝ ∧ ▷ isteps α σ (IT_of_V βv) σ' k'. + isteps (Tick α) σ (IT_of_V βv) σ' k + ⊢ ∃ k' : nat, ⌜k = (1 + k')%nat⌝ ∧ ▷ isteps α σ (IT_of_V βv) σ' k'. Proof. rewrite isteps_unfold. iDestruct 1 as "[[Hk [Ht Hs]] | H]". @@ -335,8 +337,22 @@ Section istep. iRewrite -"Ha". iRewrite "Hs". done. Qed. +End istep. + +Section istep_ctx_indep. + Context {A} `{!Cofe A}. + Context (r : sReifier NotCtxDep). + Notation F := (sReifier_ops r). + Notation stateF := (sReifier_state r). + Notation IT := (IT F A). + Notation ITV := (ITV F A). + Notation stateO := (stateF ♯ IT). + + Context `{!invGS_gen hlc Σ}. + Notation iProp := (iProp Σ). + Lemma istep_hom (f : IT → IT) `{!IT_hom f} α σ β σ' : - istep α σ β σ' ⊢ istep (f α) σ (f β) σ' : iProp. + istep r α σ β σ' ⊢ istep r (f α) σ (f β) σ' : iProp. Proof. iDestruct 1 as "[[Ha Hs]|H]". - iRewrite "Ha". iLeft. iSplit; eauto. iPureIntro. apply hom_tick. @@ -350,14 +366,15 @@ Section istep. iApply (reify_vis_cont with "Hr"). Qed. - Lemma istep_hom_inv α σ β σ' `{!IT_hom f} : - istep (f α) σ β σ' ⊢@{iProp} ⌜is_Some (IT_to_V α)⌝ - ∨ (IT_to_V α ≡ None ∧ ∃ α', istep α σ α' σ' ∧ ▷ (β ≡ f α')). + Lemma istep_hom_inv α σ β σ' (f : IT → IT) `{!IT_hom f} : + istep r (f α) σ β σ' ⊢@{iProp} ⌜is_Some (IT_to_V α)⌝ + ∨ (IT_to_V α ≡ None ∧ ∃ α', istep r α σ α' σ' + ∧ ▷ (β ≡ f α')). Proof. iIntros "H". destruct (IT_dont_confuse α) as [[e Ha] | [[n Ha] | [ [g Ha] | [[la Ha]|[op [i [k Ha]]]] ]]]. - - iExFalso. iApply (istep_err σ e β σ'). + - iExFalso. iApply (istep_err r σ e β σ'). iAssert (f α ≡ Err e)%I as "Hf". { iPureIntro. by rewrite Ha hom_err. } iRewrite "Hf" in "H". done. @@ -394,7 +411,4 @@ Section istep. iExists op,i,k. iFrame "Hr". iPureIntro. apply Ha. Qed. - - -End istep. - +End istep_ctx_indep. diff --git a/theories/gitree/reify.v b/theories/gitree/reify.v index 63be7d0..84cc1d8 100644 --- a/theories/gitree/reify.v +++ b/theories/gitree/reify.v @@ -2,8 +2,12 @@ From iris.proofmode Require Import classes tactics. From gitrees Require Import prelude. From gitrees.gitree Require Import core. -Section reifiers. - Context {A} `{!Cofe A}. +Section reifier. + Inductive is_ctx_dep : Type := + | CtxDep + | NotCtxDep. + + Context {A} `{!Cofe A} (icd : is_ctx_dep). #[local] Open Scope type. (** A single reifier *) @@ -11,49 +15,108 @@ Section reifiers. { sReifier_ops : opsInterp; sReifier_state : oFunctor; sReifier_re {X} `{!Cofe X} : forall (op : opid sReifier_ops), - (Ins (sReifier_ops op) ♯ X) * (sReifier_state ♯ X) - -n> optionO ((Outs (sReifier_ops op) ♯ X) * (sReifier_state ♯ X)); + match icd with + | CtxDep => + (Ins (sReifier_ops op) ♯ X) + * (sReifier_state ♯ X) + * ((Outs (sReifier_ops op) ♯ X) -n> laterO X) + -n> optionO (laterO X * (sReifier_state ♯ X)) + | NotCtxDep => + (Ins (sReifier_ops op) ♯ X) + * (sReifier_state ♯ X) + -n> optionO ((Outs (sReifier_ops op) ♯ X) * (sReifier_state ♯ X)) + end; sReifier_inhab :: Inhabited (sReifier_state ♯ unitO); sReifier_cofe X (HX : Cofe X) :: Cofe (sReifier_state ♯ X); }. +End reifier. - Context (r : sReifier). - Notation F := (sReifier_ops r). - Notation stateF := (sReifier_state r). - Notation IT := (IT F A). - Notation ITV := (ITV F A). - Implicit Type op : opid F. - Implicit Type α β : IT. +Section reifier_coercion. + Context {A} `{!Cofe A}. + #[local] Open Scope type. + Program Definition sReifier_NotCtxDep_CtxDep (r : sReifier NotCtxDep) + : sReifier CtxDep := + {| + sReifier_ops := sReifier_ops _ r; + sReifier_state := sReifier_state _ r; + sReifier_re x xc op := + (λne y, (optionO_map (prodO_map y.2 idfun) + (sReifier_re _ r op (y.1.1, y.1.2)))); + sReifier_inhab := sReifier_inhab _ r; + sReifier_cofe := sReifier_cofe _ r; + |}. + Next Obligation. + intros. + repeat intro; repeat f_equiv; assumption. + Qed. +End reifier_coercion. + +Section reifier_cofe_inst. + Context {A} `{!Cofe A}. + #[local] Open Scope type. + Notation F a r := (sReifier_ops a r). + Notation stateF a r := (sReifier_state a r). + Notation IT a r := (IT (F a r) A). + Notation ITV a r := (ITV (F a r) A). + Notation stateM a r := ((stateF a r) ♯ (IT a r) -n> ((stateF a r) ♯ (IT a r)) * (IT a r)). - Notation stateM := ((stateF ♯ IT -n> (stateF ♯ IT) * IT)). - #[local] Instance stateT_inhab : Inhabited stateM. + #[global] Instance stateT_inhab {a r} : Inhabited (stateM a r). Proof. simple refine (populate (λne s, (s, inhabitant))). { apply _. } solve_proper. Qed. - #[local] Instance stateM_cofe : Cofe stateM. + #[global] Instance stateM_cofe {a r} : Cofe (stateM a r). Proof. unfold stateM. apply _. Qed. - Opaque laterO_map. +End reifier_cofe_inst. - Program Definition reify_fun : laterO (sumO IT stateM -n> prodO IT stateM) -n> stateM := - λne f s, (s, Fun $ laterO_map (λne f, fstO ◎ f ◎ inlO) f). - Solve All Obligations with solve_proper. +Section reifier_vis. + Context {A} `{!Cofe A}. + #[local] Open Scope type. + Notation F a r := (sReifier_ops a r). + Notation stateF a r := (sReifier_state a r). + Notation IT a r := (IT (F a r) A). + Notation ITV a r := (ITV (F a r) A). + Notation stateM a r := ((stateF a r) ♯ (IT a r) -n> ((stateF a r) ♯ (IT a r)) * (IT a r)). - Program Definition reify_tau : laterO (prodO IT stateM) -n> stateM := - λne x s, (s, Tau $ laterO_map fstO x). - Solve All Obligations with solve_proper. + Program Definition reify_vis_ctx_dep (r : sReifier CtxDep) ( op : opid (F CtxDep r)) : + oFunctor_car (Ins (F CtxDep r op)) + (sumO (IT CtxDep r) (stateM CtxDep r)) (prodO (IT CtxDep r) (stateM CtxDep r)) -n> + (oFunctor_car (Outs (F CtxDep r op)) (prodO (IT CtxDep r) (stateM CtxDep r)) + (sumO (IT CtxDep r) (stateM CtxDep r)) + -n> laterO (prodO (IT CtxDep r) (stateM CtxDep r))) -n> (stateM CtxDep r). + Proof. + simpl. + simple refine (λne i (k : _ -n> _) (s : stateF CtxDep r ♯ (IT CtxDep r)), _). + - simple refine + (let ns := sReifier_re CtxDep r op + (oFunctor_map _ (inlO,fstO) i, s, + (λne o, (laterO_map fstO $ k + $ oFunctor_map (Outs (F CtxDep r op)) (fstO, inlO) o))) in _). + + intros m s1 s2 Hs. solve_proper. + + simple refine (from_option (λ ns, + (ns.2, Tau $ ns.1)) + (s, Err RuntimeErr) ns). + - intros m s1 s2 Hs. simpl. eapply (from_option_ne (dist m)); solve_proper. + - intros m k1 k2 Hk s. simpl. eapply (from_option_ne (dist m)); [solve_proper | solve_proper |]. + do 2 f_equiv. + solve_proper. + - intros m i1 i2 Hi k s. simpl. eapply (from_option_ne (dist m)); solve_proper. + Defined. - Program Definition reify_vis ( op : opid F ) : - oFunctor_car (Ins (F op)) (sumO IT stateM) (prodO IT stateM) -n> - (oFunctor_car (Outs (F op)) (prodO IT stateM) (sumO IT stateM) -n> laterO (prodO IT stateM)) -n> stateM. + Program Definition reify_vis_ctx_indep (r : sReifier NotCtxDep) ( op : opid (F NotCtxDep r) ) : + oFunctor_car (Ins (F NotCtxDep r op)) (sumO (IT NotCtxDep r) (stateM NotCtxDep r)) + (prodO (IT NotCtxDep r) (stateM NotCtxDep r)) -n> + (oFunctor_car (Outs (F NotCtxDep r op)) (prodO (IT NotCtxDep r) (stateM NotCtxDep r)) + (sumO (IT NotCtxDep r) (stateM NotCtxDep r)) + -n> laterO (prodO (IT NotCtxDep r) (stateM NotCtxDep r))) -n> (stateM NotCtxDep r). Proof. simpl. - simple refine (λne i (k : _ -n> _) (s : stateF ♯ IT), _). - - simple refine (let ns := sReifier_re r op (oFunctor_map _ (inlO,fstO) i, s) in _). + simple refine (λne i (k : _ -n> _) (s : stateF NotCtxDep r ♯ (IT NotCtxDep r)), _). + - simple refine (let ns := sReifier_re NotCtxDep r op (oFunctor_map _ (inlO,fstO) i, s) in _). simple refine (from_option (λ ns, - let out2' := k $ oFunctor_map (Outs (F op)) (fstO,inlO) ns.1 in + let out2' := k $ oFunctor_map (Outs (F NotCtxDep r op)) (fstO,inlO) ns.1 in (ns.2, Tau $ laterO_map fstO out2')) (s, Err RuntimeErr) ns). - intros m s1 s2 Hs. simpl. eapply (from_option_ne (dist m)); solve_proper. @@ -61,6 +124,37 @@ Section reifiers. - intros m i1 i2 Hi k s. simpl. eapply (from_option_ne (dist m)); solve_proper. Defined. + Program Definition reify_vis (a : is_ctx_dep) (r : sReifier a) : ∀ ( op : opid (F a r)), + oFunctor_car (Ins (F a r op)) (sumO (IT a r) (stateM a r)) (prodO (IT a r) (stateM a r)) -n> + (oFunctor_car (Outs (F a r op)) (prodO (IT a r) (stateM a r)) + (sumO (IT a r) (stateM a r)) -n> laterO (prodO (IT a r) (stateM a r))) -n> (stateM a r). + Proof. + destruct a. + - apply reify_vis_ctx_dep. + - apply reify_vis_ctx_indep. + Defined. +End reifier_vis. + +Section reify. + Context {A} `{!Cofe A} {a : is_ctx_dep}. + #[local] Open Scope type. + Context {r : sReifier a}. + Notation F := (sReifier_ops a r). + Notation stateF := (sReifier_state a r). + Notation IT := (IT F A). + Notation ITV := (ITV F A). + Notation stateM := (stateF ♯ IT -n> (stateF ♯ IT) * IT). + + Opaque laterO_map. + + Program Definition reify_fun : laterO (sumO IT stateM -n> prodO IT stateM) -n> stateM := + λne f s, (s, Fun $ laterO_map (λne f, fstO ◎ f ◎ inlO) f). + Solve All Obligations with solve_proper. + + Program Definition reify_tau : laterO (prodO IT stateM) -n> stateM := + λne x s, (s, Tau $ laterO_map fstO x). + Solve All Obligations with solve_proper. + Program Definition reify_err : errorO -n> stateM := λne e s, (s, Err e). Solve All Obligations with solve_proper. @@ -68,35 +162,36 @@ Section reifiers. Solve All Obligations with solve_proper. Program Definition unr : stateM -n> - sumO (sumO (sumO (sumO A (laterO (stateM -n> stateM))) errorO) (laterO stateM)) - (sigTO (λ op : opid F, prodO (oFunctor_apply (Ins (F op)) stateM) (oFunctor_apply (Outs (F op)) stateM -n> laterO stateM))). + sumO (sumO (sumO (sumO A (laterO (stateM -n> stateM))) errorO) (laterO stateM)) + (sigTO (λ op : opid F, prodO (oFunctor_apply (Ins (F op)) stateM) + (oFunctor_apply (Outs (F op)) stateM -n> laterO stateM))). Proof. simple refine (λne d, inl (inl (inr (RuntimeErr)))). Qed. Definition reify : IT -n> stateM := IT_rec1 _ - reify_err - reify_ret - reify_fun - reify_tau - reify_vis - unr. + reify_err + reify_ret + reify_fun + reify_tau + (reify_vis a r) + unr. Definition unreify : stateM -n> IT := IT_rec2 _ - reify_err - reify_ret - reify_fun - reify_tau - reify_vis - unr. + reify_err + reify_ret + reify_fun + reify_tau + (reify_vis a r) + unr. Lemma reify_fun_eq f σ : reify (Fun f) σ ≡ (σ, Fun f). Proof. rewrite /reify/=. trans (reify_fun (laterO_map (sandwich (Perr:=reify_err) (Pret:=reify_ret) - (Parr:=reify_fun) (Ptau:=reify_tau) - (Pvis:=reify_vis) (Punfold:=unr) - stateM) f) σ). + (Parr:=reify_fun) (Ptau:=reify_tau) + (Pvis:=reify_vis a r) (Punfold:=unr) + (stateM)) f) σ). { f_equiv. apply IT_rec1_fun. } simpl. repeat f_equiv. rewrite -laterO_map_compose. @@ -105,22 +200,90 @@ Section reifiers. apply laterO_map_id. Qed. - Lemma reify_vis_dist m op i o k σ σ' : - sReifier_re r op (i,σ) ≡{m}≡ Some (o,σ') → +End reify. + +Section reify_props. + Context {A} `{!Cofe A}. + #[local] Open Scope type. + Notation F a r := (sReifier_ops a r). + Notation stateF a r := (sReifier_state a r). + Notation IT a r := (IT (F a r) A). + Notation ITV a r := (ITV (F a r) A). + Notation stateM a r := (stateF a r ♯ (IT a r) -n> (stateF a r ♯ (IT a r)) * (IT a r)). + + Opaque laterO_map. + + Lemma reify_vis_dist_ctx_dep (r : sReifier CtxDep) m op i o k σ σ' : + @sReifier_re CtxDep r (IT CtxDep r) _ op (i, σ, k) ≡{m}≡ Some (o, σ') → + reify (Vis op i k) σ ≡{m}≡ (σ', Tau o). + Proof. + intros Hst. + trans (reify_vis CtxDep r op + (oFunctor_map _ (sumO_rec idfun unreify,prod_in idfun reify) i) + (laterO_map (prod_in idfun reify) ◎ k + ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) + σ). + { f_equiv. rewrite IT_rec1_vis//. } + Opaque prod_in. simpl. + pose (rs := (sReifier_re _ r op + (oFunctor_map (Ins (F _ _ op)) (inlO, fstO) + (oFunctor_map (Ins (F _ _ op)) + (sumO_rec idfun unreify, prod_in idfun reify) i), σ, k))). + fold rs. + assert (rs ≡ sReifier_re _ r op (i,σ, k)) as Hr'. + { unfold rs. f_equiv. f_equiv. + rewrite -oFunctor_map_compose. + f_equiv. + etrans; last by apply oFunctor_map_id. + repeat f_equiv; intro; done. } + assert (rs ≡{m}≡ Some (o, σ')) as Hr. + { by rewrite Hr' Hst. } + trans (from_option (λ ns : laterO (IT _ _) * (stateF _ _) ♯ (IT _ _), (ns.2, Tau ns.1)) + (σ, Err RuntimeErr) + rs). + - subst rs. + eapply (from_option_ne (dist m)); [solve_proper | solve_proper |]. + do 2 f_equiv. + intros ?; simpl. + rewrite -laterO_map_compose. + rewrite -oFunctor_map_compose. + etrans; first (rewrite laterO_map_id; reflexivity). + f_equiv. + trans (oFunctor_map _ (idfun, idfun) x). + + do 3 f_equiv. + * intros y; simpl. + Transparent prod_in. + by unfold prod_in. + * intros y; simpl. + reflexivity. + + by rewrite oFunctor_map_id. + - subst rs. + trans (from_option (λ ns : laterO (IT _ _) * (stateF _ _) ♯ (IT _ _), (ns.2, Tau ns.1)) + (σ, Err RuntimeErr) + (Some (o, σ'))). + + eapply (from_option_ne (dist m)); [solve_proper | solve_proper |]. + by rewrite Hr. + + reflexivity. + Qed. + + Lemma reify_vis_dist_ctx_indep (r : sReifier NotCtxDep) m op i o k σ σ' : + @sReifier_re NotCtxDep r (IT NotCtxDep r) _ op (i,σ) ≡{m}≡ Some (o,σ') → reify (Vis op i k) σ ≡{m}≡ (σ', Tau $ k o). Proof. intros Hst. - trans (reify_vis op + trans (reify_vis _ _ op (oFunctor_map _ (sumO_rec idfun unreify,prod_in idfun reify) i) - (laterO_map (prod_in idfun reify) ◎ k ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) + (laterO_map (prod_in idfun reify) ◎ k + ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) σ). { f_equiv. rewrite IT_rec1_vis//. } Opaque prod_in. simpl. - pose (rs := (sReifier_re r op - (oFunctor_map (Ins (F op)) (inlO, fstO) - (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ))). + pose (rs := (@sReifier_re NotCtxDep r _ _ op + (oFunctor_map (Ins (F NotCtxDep r op)) (inlO, fstO) + (oFunctor_map (Ins (F NotCtxDep r op)) + (sumO_rec idfun unreify, prod_in idfun reify) i), σ))). fold rs. - assert (rs ≡ sReifier_re r op (i,σ)) as Hr'. + assert (rs ≡ sReifier_re NotCtxDep r op (i,σ)) as Hr'. { unfold rs. f_equiv. f_equiv. rewrite -oFunctor_map_compose. etrans; last by apply oFunctor_map_id. @@ -128,13 +291,14 @@ Section reifiers. assert (rs ≡{m}≡ Some (o,σ')) as Hr. { by rewrite Hr' Hst. } trans (from_option (λ ns, - (ns.2, - Tau - (laterO_map fstO - (laterO_map (prod_in idfun reify) - (k - (oFunctor_map (Outs (F op)) (prod_in idfun reify, sumO_rec idfun unreify) - (oFunctor_map (Outs (F op)) (fstO, inlO) ns.1))))))) + (ns.2, + Tau + (laterO_map fstO + (laterO_map (prod_in idfun reify) + (k + (oFunctor_map (Outs (F NotCtxDep r op)) + (prod_in idfun reify, sumO_rec idfun unreify) + (oFunctor_map (Outs (F NotCtxDep r op)) (fstO, inlO) ns.1))))))) (σ, Err RuntimeErr) (Some (o,σ'))). { eapply (from_option_ne (dist m)); solve_proper. } simpl. repeat f_equiv. @@ -150,32 +314,99 @@ Section reifiers. repeat f_equiv; intro; done. Qed. - Lemma reify_vis_eq op i o k σ σ' : - sReifier_re r op (i,σ) ≡ Some (o,σ') → + Lemma reify_vis_eq_ctx_dep r op i o k σ σ' : + @sReifier_re CtxDep r (IT CtxDep r) _ op (i,σ,k) ≡ Some (o,σ') → + reify (Vis op i k) σ ≡ (σ', Tau $ o). + Proof. + intros H. apply equiv_dist=>m. + apply reify_vis_dist_ctx_dep. + by apply equiv_dist. + Qed. + + Lemma reify_vis_eq_ctx_indep r op i o k σ σ' : + @sReifier_re NotCtxDep r (IT NotCtxDep r) _ op (i,σ) ≡ Some (o,σ') → reify (Vis op i k) σ ≡ (σ', Tau $ k o). Proof. intros H. apply equiv_dist=>m. - apply reify_vis_dist. + apply reify_vis_dist_ctx_indep. by apply equiv_dist. Qed. - Lemma reify_vis_None op i k σ : - sReifier_re r op (i,σ) ≡ None → + Lemma reify_vis_None_ctx_dep r op i k σ : + @sReifier_re CtxDep r (IT CtxDep r) _ op (i,σ,k) ≡ None → reify (Vis op i k) σ ≡ (σ, Err RuntimeErr). Proof. intros Hs. - trans (reify_vis op + trans (reify_vis _ _ op (oFunctor_map _ (sumO_rec idfun unreify,prod_in idfun reify) i) - (laterO_map (prod_in idfun reify) ◎ k ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) + (laterO_map (prod_in idfun reify) ◎ k + ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) σ). { f_equiv. apply IT_rec1_vis. } simpl. - pose (rs := (sReifier_re r op - (oFunctor_map (Ins (F op)) (inlO, fstO) - (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ))). + pose (rs := (sReifier_re CtxDep r op + (oFunctor_map (Ins (F CtxDep r op)) (inlO, fstO) + (oFunctor_map (Ins (F CtxDep r op)) + (sumO_rec idfun unreify, prod_in idfun reify) i), σ, k))). fold rs. - assert (rs ≡ sReifier_re r op (i,σ)) as Hr'. + assert (rs ≡ sReifier_re CtxDep r op (i,σ, k)) as Hr'. + { unfold rs. f_equiv. f_equiv. + rewrite -oFunctor_map_compose. + f_equiv. + etrans; last by apply oFunctor_map_id. + repeat f_equiv; intro; done. } + assert (rs ≡ None) as Hr. + { by rewrite Hr' Hs. } + trans (from_option (λ ns : laterO (IT _ _) * (stateF _ _) ♯ (IT _ _), (ns.2, Tau ns.1)) + (σ, Err RuntimeErr) + rs). + { + apply from_option_proper; [solve_proper | solve_proper |]. + subst rs. + do 2 f_equiv. + intros x; simpl. + rewrite -laterO_map_compose -oFunctor_map_compose. + trans (laterO_map idfun (k x)); last first. + { by rewrite laterO_map_id. } + f_equiv; first (f_equiv; intros ?; reflexivity). + f_equiv. + trans (oFunctor_map _ (idfun, idfun) x). + - do 3 f_equiv. + + intros y; simpl. + Transparent prod_in. + by unfold prod_in. + + intros y; simpl. + reflexivity. + - by rewrite oFunctor_map_id. + } + trans (from_option (λ ns : laterO (IT CtxDep r) * (stateF _ _) ♯ (IT _ _), + (ns.2, Tau ns.1)) (σ, Err RuntimeErr) None). + - f_equiv; [| assumption]. + intros [? ?] [? ?] [? ?]; simpl in *; f_equiv; [assumption | f_equiv; assumption]. + - reflexivity. + Qed. + + Lemma reify_vis_None_ctx_indep r op i k σ : + @sReifier_re NotCtxDep r (IT NotCtxDep r) _ op (i,σ) ≡ None → + reify (Vis op i k) σ ≡ (σ, Err RuntimeErr). + Proof. + intros Hs. + trans (reify_vis _ _ op + (oFunctor_map _ (sumO_rec idfun unreify,prod_in idfun reify) i) + (laterO_map (prod_in idfun reify) ◎ k + ◎ (oFunctor_map _ + (prod_in idfun reify,sumO_rec idfun unreify))) + σ). + { f_equiv. + apply IT_rec1_vis. } + simpl. + pose (rs := (sReifier_re NotCtxDep r op + (oFunctor_map (Ins (F _ _ op)) (inlO, fstO) + (oFunctor_map (Ins (F _ _ op)) + (sumO_rec idfun unreify, prod_in idfun reify) i), σ))). + fold rs. + assert (rs ≡ sReifier_re _ r op (i,σ)) as Hr'. { unfold rs. f_equiv. f_equiv. rewrite -oFunctor_map_compose. etrans; last by apply oFunctor_map_id. @@ -183,31 +414,64 @@ Section reifiers. assert (rs ≡ None) as Hr. { by rewrite Hr' Hs. } trans (from_option (λ ns, - (ns.2, - Tau - (laterO_map fstO - (laterO_map (prod_in idfun reify) - (k - (oFunctor_map (Outs (F op)) (prod_in idfun reify, sumO_rec idfun unreify) - (oFunctor_map (Outs (F op)) (fstO, inlO) ns.1))))))) + (ns.2, + Tau + (laterO_map fstO + (laterO_map (prod_in idfun reify) + (k + (oFunctor_map (Outs (F _ _ op)) + (prod_in idfun reify, sumO_rec idfun unreify) + (oFunctor_map (Outs (F _ _ op)) (fstO, inlO) ns.1))))))) (σ, Err RuntimeErr) None). { apply from_option_proper; solve_proper. } reflexivity. Qed. - Lemma reify_vis_cont op i k1 k2 σ1 σ2 β + Lemma reify_is_always_a_tick {a : is_ctx_dep} r op x k σ β σ' : + reify (a := a) (A := A) (r := r) (Vis op x k) σ ≡ (σ', β) + → (∃ β', β ≡ Tick β') ∨ (β ≡ Err RuntimeErr). + Proof. + destruct a. + { + destruct (sReifier_re _ r op (x, σ, k)) as [[o σ'']|] eqn:Hre; last first. + - rewrite reify_vis_None_ctx_dep; last by rewrite Hre//. + intros [_ ?]. by right. + - rewrite reify_vis_eq_ctx_dep;last by rewrite Hre. + intros [? Ho]. + left. + simpl in *. + destruct (Next_uninj o) as [t Ht]. + exists (t). + rewrite <-Ho. + rewrite Ht. + reflexivity. + } + { + destruct (sReifier_re _ r op (x, σ)) as [[o σ'']|] eqn:Hre; last first. + - rewrite reify_vis_None_ctx_indep; last by rewrite Hre//. + intros [_ ?]. by right. + - rewrite reify_vis_eq_ctx_indep;last by rewrite Hre. + intros [? Ho]. + destruct (Next_uninj (k o)) as [lβ Hlb]. + left. exists (lβ). + rewrite Tick_eq. + rewrite -Hlb. symmetry. apply Ho. + } + Qed. + + Lemma reify_vis_cont r op i k1 k2 σ1 σ2 β {PROP : bi} `{!BiInternalEq PROP} : - (reify (Vis op i k1) σ1 ≡ (σ2, Tick β) ⊢ + (reify (a := NotCtxDep) (A := A) (r := r) (Vis op i k1) σ1 ≡ (σ2, Tick β) ⊢ reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick (k2 β)) : PROP)%I. Proof. - destruct (sReifier_re r op (i,σ1)) as [[o σ2']|] eqn:Hre; last first. - - rewrite reify_vis_None; last by rewrite Hre//. + destruct (sReifier_re _ r op (i,σ1)) as [[o σ2']|] eqn:Hre; last first. + - rewrite reify_vis_None_ctx_indep; last by rewrite Hre//. iIntros "Hr". iExFalso. iPoseProof (prod_equivI with "Hr") as "[_ Hk]". simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. - - rewrite reify_vis_eq; last first. + - rewrite reify_vis_eq_ctx_indep; last first. { by rewrite Hre. } - rewrite reify_vis_eq; last first. + rewrite reify_vis_eq_ctx_indep; last first. { by rewrite Hre. } iIntros "Hr". iPoseProof (prod_equivI with "Hr") as "[Hs Hk]". @@ -217,18 +481,19 @@ Section reifiers. rewrite laterO_map_Next. done. Qed. - Lemma reify_input_cont_inv op i (k1 : _ -n> laterO IT) (k2 : IT -n> IT) σ1 σ2 β + Lemma reify_input_cont_inv r op i (k1 : _ -n> laterO (IT NotCtxDep r)) + (k2 : IT _ r -n> IT _ r) σ1 σ2 β {PROP : bi} `{!BiInternalEq PROP} : (reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick β) ⊢ ∃ α, reify (Vis op i k1) σ1 ≡ (σ2, Tick α) ∧ ▷ (β ≡ k2 α) - : PROP)%I. + : PROP)%I. Proof. - destruct (sReifier_re r op (i,σ1)) as [[o σ2']|] eqn:Hre; last first. - - rewrite reify_vis_None; last by rewrite Hre//. + destruct (sReifier_re _ r op (i,σ1)) as [[o σ2']|] eqn:Hre; last first. + - rewrite reify_vis_None_ctx_indep; last by rewrite Hre//. iIntros "Hr". iExFalso. iPoseProof (prod_equivI with "Hr") as "[_ Hk]". simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. - - rewrite reify_vis_eq; last first. + - rewrite reify_vis_eq_ctx_indep; last first. { by rewrite Hre. } iIntros "Hr". simpl. iPoseProof (prod_equivI with "Hr") as "[#Hs #Hk]". @@ -236,7 +501,7 @@ Section reifiers. iPoseProof (Tau_inj' with "Hk") as "Hk'". destruct (Next_uninj (k1 o)) as [a Hk1]. iExists (a). - rewrite reify_vis_eq; last first. + rewrite reify_vis_eq_ctx_indep; last first. { by rewrite Hre. } iSplit. + iApply prod_equivI. simpl. iSplit; eauto. @@ -249,20 +514,9 @@ Section reifiers. rewrite laterO_map_Next. done. } iNext. by iApply internal_eq_sym. Qed. +End reify_props. - Lemma reify_is_always_a_tick op x k σ β σ' : - reify (Vis op x k) σ ≡ (σ', β) → (∃ β', β ≡ Tick β') ∨ (β ≡ Err RuntimeErr). - Proof. - destruct (sReifier_re r op (x, σ)) as [[o σ'']|] eqn:Hre; last first. - - rewrite reify_vis_None; last by rewrite Hre//. - intros [_ ?]. by right. - - rewrite reify_vis_eq;last by rewrite Hre. - intros [? Ho]. - destruct (Next_uninj (k o)) as [lβ Hlb]. - left. exists (lβ). - rewrite Tick_eq. - rewrite -Hlb. symmetry. apply Ho. - Qed. - -End reifiers. - +Arguments reify {_ _ _} _. +Arguments sReifier_ops {_}. +Arguments sReifier_re {_} _ {_ _}. +Arguments sReifier_state {_}. diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index 873cf74..e6e343f 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -6,25 +6,32 @@ From gitrees.gitree Require Import core reify greifiers reductions. (** * Ghost state from gReifiers *) -Definition gReifiers_ucmra {n} (rs : gReifiers n) (X : ofe) `{!Cofe X} : ucmra := - discrete_funUR (λ (i : fin n), optionUR (exclR (sReifier_state (rs !!! i) ♯ X))). +Definition gReifiers_ucmra {n} {a : is_ctx_dep} (rs : gReifiers a n) + (X : ofe) `{!Cofe X} : ucmra := + discrete_funUR (λ (i : fin n), + optionUR (exclR (sReifier_state (rs !!! i) ♯ X))). (** The resource corresponding to the whole global state *) -Definition of_state {n} (rs : gReifiers n) (X : ofe) `{!Cofe X} (st : gReifiers_state rs ♯ X) : gReifiers_ucmra rs X := +Definition of_state {n} {a : is_ctx_dep} (rs : gReifiers a n) + (X : ofe) `{!Cofe X} (st : gReifiers_state rs ♯ X) + : gReifiers_ucmra rs X := λ i, Excl' (fstO (gState_decomp i st)). (** The resource corresponding to a speicific projection out of the global state *) -Definition of_idx {n} (rs : gReifiers n) (X : ofe) `{!Cofe X} (i : fin n) +Definition of_idx {n} {a : is_ctx_dep} (rs : gReifiers a n) + (X : ofe) `{!Cofe X} (i : fin n) (st : sReifier_state (rs !!! i) ♯ X) : gReifiers_ucmra rs X. Proof. simple refine (λ j, if (decide (j = i)) then _ else None). simpl. induction e. exact (Excl' st). Defined. -Lemma of_state_recomp_lookup_ne {n} (rs : gReifiers n) (X : ofe) `{!Cofe X} +Lemma of_state_recomp_lookup_ne {n} {a : is_ctx_dep} (rs : gReifiers a n) + (X : ofe) `{!Cofe X} i j (σ1 σ2 : sReifier_state (rs !!! i) ♯ X) rest : i ≠ j → - of_state rs X (gState_recomp rest σ1) j ≡ of_state rs X (gState_recomp rest σ2) j. + of_state rs X (gState_recomp rest σ1) j + ≡ of_state rs X (gState_recomp rest σ2) j. Proof. intros Hij. revert σ1 σ2 rest. unfold of_state. @@ -42,9 +49,8 @@ Proof. intro. simplify_eq/=. Qed. - Section ucmra. - Context {n : nat} (rs : gReifiers n). + Context {n : nat} {a : is_ctx_dep} (rs : gReifiers a n). Context (X : ofe) `{!Cofe X}. Notation gReifiers_ucmra := (gReifiers_ucmra rs X). Notation of_state := (of_state rs X). @@ -100,7 +106,7 @@ Section ucmra. End ucmra. Section weakestpre. - Context {n : nat} (rs : gReifiers n) {A} `{!Cofe A}. + Context {n : nat} {a : is_ctx_dep} (rs : gReifiers a n) {A} `{!Cofe A}. Notation rG := (gReifiers_sReifier rs). Notation F := (sReifier_ops rG). Notation IT := (IT F A). @@ -137,13 +143,14 @@ Section weakestpre. Definition has_state_idx `{!stateG Σ} (i : fin n) (σ : sReifier_state (rs !!! i) ♯ IT) : iProp Σ := (own stateG_name (◯ (of_idx i σ)))%I. - Definition has_substate {sR : sReifier} `{!stateG Σ} `{!subReifier sR rs} + Definition has_substate {sR : sReifier a} `{!stateG Σ} `{!subReifier sR rs} (σ : sReifier_state sR ♯ IT) : iProp Σ := (own stateG_name (◯ (of_idx sR_idx (sR_state σ))))%I. #[export] Instance state_interp_ne `{!stateG Σ} : NonExpansive state_interp. Proof. solve_proper. Qed. - #[export] Instance state_interp_proper `{!stateG Σ} : Proper ((≡) ==> (≡)) state_interp. + #[export] Instance state_interp_proper `{!stateG Σ} + : Proper ((≡) ==> (≡)) state_interp. Proof. solve_proper. Qed. Lemma new_state_interp σ `{!invGS_gen hlc Σ, !statePreG Σ} : @@ -209,7 +216,7 @@ Section weakestpre. #[local] Instance wp_pre_contractive s Φ : Contractive (wp_pre s Φ). Proof. unfold wp_pre. - intros m s1 s2 Hs E1 a. simpl. + intros m s1 s2 Hs E1 a'. simpl. (* repeat first [f_contractive | f_equiv; solve_proper *) (* | f_equiv ]. *) f_equiv. f_equiv. f_equiv. @@ -245,7 +252,9 @@ Section weakestpre. format "'WP' α @ s {{ Φ } }") : bi_scope. #[export] Instance wp_ne m : - Proper ((dist m) ==> (pointwise_relation _ (iff)) ==> (dist m) ==> (pointwise_relation _ (dist m)) ==> (dist m)) wp. + Proper ((dist m) ==> + (pointwise_relation _ (iff)) ==> + (dist m) ==> (pointwise_relation _ (dist m)) ==> (dist m)) wp. Proof. intros α1 α2 Ha s s' Hs E1 E2 HE Φ1 Φ2 Hp. assert (E1 = E2) as ->. @@ -267,7 +276,8 @@ Section weakestpre. eapply dist_le; [apply Hp|lia]. Qed. #[export] Instance wp_proper : - Proper ((≡) ==> (pointwise_relation _ (iff)) ==> (≡) ==> (pointwise_relation _ (≡)) ==> (≡)) wp. + Proper ((≡) ==> (pointwise_relation _ (iff)) ==> (≡) ==> + (pointwise_relation _ (≡)) ==> (≡)) wp. Proof. intros α1 α2 Ha s s' Hs E1 E2 HE Φ1 Φ2 Hp. apply equiv_dist=>m. @@ -371,62 +381,6 @@ Section weakestpre. iIntros "H". iApply (wp_wand with "H"); auto. Qed. - Lemma wp_bind (f : IT → IT) `{!IT_hom f} (α : IT) s Φ `{!NonExpansive Φ} E1 : - WP α @ s;E1 {{ βv, WP (f (IT_of_V βv)) @ s;E1 {{ βv, Φ βv }} }} ⊢ WP (f α) @ s;E1 {{ Φ }}. - Proof. - assert (NonExpansive (λ βv0, WP f (IT_of_V βv0) @ s;E1 {{ βv1, Φ βv1 }})%I). - { solve_proper. } - iIntros "H". iLöb as "IH" forall (α). - rewrite (wp_unfold (f _)). - destruct (IT_to_V (f α)) as [βv|] eqn:Hfa. - - iLeft. iExists βv. iSplit; first done. - assert (is_Some (IT_to_V α)) as [αv Ha]. - { apply (IT_hom_val_inv _ f). rewrite Hfa. - done. } - assert (IntoVal α αv). - { apply IT_of_to_V'. by rewrite Ha. } - rewrite wp_val_inv. - iApply wp_val_inv. - rewrite IT_of_to_V'; last by rewrite -Ha. - rewrite IT_of_to_V'; last by rewrite -Hfa. - by iApply fupd_wp. - - iRight. iSplit; eauto. - iIntros (σ) "Hs". - rewrite wp_unfold. - iDestruct "H" as "[H | H]". - + iDestruct "H" as (αv) "[Hav H]". - iPoseProof (IT_of_to_V with "Hav") as "Hav". - iMod "H" as "H". rewrite wp_unfold. - iDestruct "H" as "[H|H]". - { iExFalso. iDestruct "H" as (βv) "[H _]". - iRewrite "Hav" in "H". rewrite Hfa. - iApply (option_equivI with "H"). } - iDestruct "H" as "[_ H]". - iMod ("H" with "Hs") as "H". iModIntro. - iRewrite "Hav" in "H". done. - + iDestruct "H" as "[Hav H]". - iMod ("H" with "Hs") as "[Hsafe H]". iModIntro. - iSplit. - { (* safety *) - iDestruct "Hsafe" as "[Hsafe|Herr]". - - iDestruct "Hsafe" as (α' σ') "Hsafe". iLeft. - iExists (f α'), σ'. iApply (istep_hom with "Hsafe"). - - iDestruct "Herr" as (e) "[Herr %]". - iRight. iExists e. iSplit; last done. - iRewrite "Herr". rewrite hom_err//. } - iIntros (σ' β) "Hst". - rewrite {1}istep_hom_inv. iDestruct "Hst" as "[%Ha | [_ Hst]]". - { destruct Ha as [αv Ha]. rewrite Ha. - iExFalso. - iApply (option_equivI with "Hav"). } - iDestruct "Hst" as (α') "[Hst Hb]". - iIntros "Hlc". - iMod ("H" with "Hst Hlc") as "H". iModIntro. - iNext. iMod "H" as "H". iModIntro. - iMod "H" as "[$ H]". - iModIntro. iRewrite "Hb". by iApply "IH". - Qed. - (* XXX: strengthen it with later credits *) Lemma wp_tick α s E1 Φ : ▷ WP α @ s;E1 {{ Φ }} ⊢ WP (Tick α) @ s;E1 {{ Φ }}. @@ -445,7 +399,6 @@ Section weakestpre. iModIntro. iRewrite "Hb". by iFrame. Qed. - Opaque gState_recomp. (* We can generalize this based on the stuckness bit *) @@ -481,8 +434,8 @@ Section weakestpre. iSplit. { (* it is safe *) iLeft. - iExists β,(gState_recomp rest σ'). iRight. - iExists op,x,k; eauto. } + iExists β, (gState_recomp rest σ'). iRight. + iExists op, x, k; eauto. } iIntros (fs' α0) "Hst Hlc". rewrite istep_vis. iAssert (gState_recomp rest σ' ≡ fs' ∧ Tick β ≡ Tick α0)%I with "[Hreify Hst]" as "[Hst Hb]". @@ -497,35 +450,6 @@ Section weakestpre. iRewrite -"Hb". by iFrame. Qed. - Lemma wp_reify_idx' E1 E2 s Φ i (lop : opid (sReifier_ops (rs !!! i))) : - let op : opid F := (existT i lop) in - forall (x : Ins (F op) ♯ IT) - (k : Outs (F op) ♯ IT -n> laterO IT), - (|={E1,E2}=> ∃ σ y σ' β, has_state_idx i σ ∗ - sReifier_re (rs !!! i) lop (x, σ) ≡ Some (y, σ') ∗ - k y ≡ Next β ∗ - ▷ (£ 1 -∗ has_state_idx i σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) - -∗ WP (Vis op x k) @ s;E1 {{ Φ }}. - Proof. - intros op x k. - iIntros "H". - iApply wp_reify_idx. - iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". - iModIntro. iExists σ, σ', β. - iFrame "Hlst". - iIntros (rest). iFrame "H". - iAssert (gReifiers_re rs op (x, gState_recomp rest σ) ≡ Some (y,gState_recomp rest σ'))%I - with "[Hreify]" as "Hgreify". - { rewrite gReifiers_re_idx. - iAssert (optionO_map (prodO_map idfun (gState_recomp rest)) (sReifier_re (rs !!! i) lop (x, σ)) ≡ optionO_map (prodO_map idfun (gState_recomp rest)) (Some (y, σ')))%I with "[Hreify]" as "H". - - iApply (f_equivI with "Hreify"). - - simpl. iExact "H". - } - iPoseProof (reify_vis_eqI _ _ _ k with "Hgreify") as "Hreify". - iRewrite "Hk" in "Hreify". - by rewrite -Tick_eq. - Qed. - Lemma wp_reify E1 s Φ i (lop : opid (sReifier_ops (rs !!! i))) x k σ σ' β : let op : opid F := (existT i lop) in @@ -545,43 +469,6 @@ Section weakestpre. iModIntro. by iApply ("H" with "Hlc Hs"). Qed. - Lemma wp_subreify' E1 E2 s Φ sR `{!subReifier sR rs} - (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ IT) - (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) : - (|={E1,E2}=> ∃ σ y σ' β, has_substate σ ∗ - sReifier_re sR op (x, σ) ≡ Some (y, σ') ∗ - k (subEff_outs y) ≡ Next β ∗ - ▷ (£ 1 -∗ has_substate σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) - -∗ WP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. - Proof. - iIntros "H". - iApply wp_reify_idx'. - iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". - iModIntro. - iExists (sR_state σ),(subEff_outs y), (sR_state σ'), β. - iFrame "Hlst H Hk". - by iApply subReifier_reify_idxI. - Qed. - Lemma wp_subreify E1 s Φ sR `{!subReifier sR rs} - (op : opid (sReifier_ops sR)) - (x : Ins (sReifier_ops sR op) ♯ IT) (y : Outs (sReifier_ops sR op) ♯ IT) - (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) - (σ σ' : sReifier_state sR ♯ IT) β : - sReifier_re sR op (x, σ) ≡ Some (y, σ') → - k (subEff_outs y) ≡ Next β → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ WP β @ s;E1 {{ Φ }}) - -∗ WP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. - Proof. - intros HSR Hk. - iIntros "Hlst H". - iApply (wp_reify with "Hlst H"). - intros rest. - rewrite Tick_eq. rewrite -Hk. - rewrite reify_vis_eq //. - by apply subReifier_reify. - Qed. - Lemma wp_err E1 e (s : error → Prop) Φ : s e → ⊢ WP (Err e) @ s;E1 {{ Φ }}. @@ -597,6 +484,7 @@ Section weakestpre. iIntros (σ' β) "Hst". iExFalso. iApply istep_err. done. Qed. + Lemma wp_stuckness_mono α E1 (s1 s2 : error → Prop) Φ : (∀ e, s1 e → s2 e) → WP α @ s1;E1 {{ Φ }} ⊢ WP α @ s2;E1 {{ Φ }}. @@ -756,48 +644,364 @@ Section weakestpre. iExFalso. iApply (option_equivI with "Hb"). Qed. + Global Instance upd_ne {X : ofe} E (Φ : X -n> iProp) : + NonExpansive (λ (a : X), (|={E}=> Φ a)%I). + Proof. + solve_proper. + Qed. + + Global Instance upd_ast_l {X : ofe} R (Φ : X -n> iProp) : + NonExpansive (λ (a : X), (R ∗ Φ a)%I). + Proof. + solve_proper. + Qed. + + Global Instance upd_ast_r {X : ofe} R (Φ : X -n> iProp) : + NonExpansive (λ (a : X), (Φ a ∗ R)%I). + Proof. + solve_proper. + Qed. + End weakestpre. -Arguments wp {_} rs {_ _ _ _ _} α s E Φ. -Arguments has_full_state {n _ _ _ _ _} σ. -Arguments has_state_idx {n _ _ _ _ _} i σ. -Arguments has_substate {n _ _ _ _ _ _ _} σ. -Arguments stateG {n} rs A {_} Σ. -Arguments statePreG {n} rs A {_} Σ. -Arguments stateΣ {n} rs A {_}. +Section weakestpre_specific. + Context {n : nat} {A} `{!Cofe A}. + + Notation rG rs := (gReifiers_sReifier (n := n) rs). + Notation F rs := (sReifier_ops (rG rs)). + Notation IT rs := (IT (F rs) A). + Notation ITV rs := (ITV (F rs) A). + Notation stateF rs := (gReifiers_state rs). + Notation stateO rs := (stateF rs ♯ IT rs). + Notation stateR rs := (gReifiers_ucmra rs (IT rs)). + Let of_state {a} rs := (of_state (a:=a) rs (IT rs)). + Let of_idx {a} rs := (of_idx (a:=a) rs (IT rs)). + Notation reify rs := (reify (rG rs)). + Notation istep rs := (istep (rG rs)). + Notation isteps rs := (isteps (rG rs)). + Notation sstep rs := (sstep (rG rs)). + Notation ssteps rs := (ssteps (rG rs)). + + Context `{!invGS Σ}. + Notation iProp := (iProp Σ). + Notation coPsetO := (leibnizO coPset). + + Lemma wp_reify_idx_ctx_dep (rs : gReifiers CtxDep n) + `{!@stateG _ CtxDep rs A _ Σ} E1 E2 s Φ i + (lop : opid (sReifier_ops (rs !!! i))) : + let op : opid (F rs) := (existT i lop) in + forall (x : Ins (F rs op) ♯ IT rs) + (k : Outs (F rs op) ♯ IT rs -n> laterO (IT rs)), + (|={E1,E2}=> + ∃ σ y σ' β, has_state_idx rs i σ + ∗ sReifier_re (rs !!! i) lop (x, σ, k) ≡ Some (y, σ') + ∗ y ≡ Next β + ∗ ▷ (£ 1 -∗ has_state_idx rs i σ' ={E2,E1}=∗ wp rs β s E1 Φ)) + -∗ wp rs (Vis op x k) s E1 Φ. + Proof. + intros op x k. + iIntros "H". + iApply wp_reify_idx. + iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". + iModIntro. iExists σ, σ', β. + iFrame "Hlst". + iIntros (rest). + iFrame "H". + iAssert (gReifiers_re rs _ _ op (x, gState_recomp rest σ, _) + ≡ Some (y, gState_recomp rest σ'))%I + with "[Hreify]" as "Hgreify". + { rewrite (@gReifiers_re_idx _ CtxDep). + iAssert (optionO_map (prodO_map idfun (gState_recomp rest)) + (sReifier_re (rs !!! i) lop (x, σ, k)) + ≡ optionO_map (prodO_map idfun (gState_recomp rest)) + (Some (y, σ')))%I with "[Hreify]" as "H". + - iApply (f_equivI with "Hreify"). + - simpl. iExact "H". + } + iPoseProof (reify_vis_eqI_ctx_dep _ _ _ k with "Hgreify") as "Hreify". + iRewrite "Hk" in "Hreify". + by rewrite -Tick_eq. + Qed. + + Lemma wp_reify_idx_ctx_indep (rs : gReifiers NotCtxDep n) + `{!@stateG _ NotCtxDep rs A _ Σ} E1 E2 s Φ i + (lop : opid (sReifier_ops (rs !!! i))) : + let op : opid (F rs) := (existT i lop) in + forall (x : Ins (F rs op) ♯ IT rs) + (k : Outs (F rs op) ♯ IT rs -n> laterO (IT rs)), + (|={E1,E2}=> ∃ σ y σ' β, has_state_idx rs i σ + ∗ sReifier_re (rs !!! i) lop (x, σ) ≡ Some (y, σ') + ∗ k y ≡ Next β + ∗ ▷ (£ 1 -∗ has_state_idx rs i σ' ={E2,E1}=∗ wp rs β s E1 Φ)) + -∗ wp rs (Vis op x k) s E1 Φ. + Proof. + intros op x k. + iIntros "H". + iApply wp_reify_idx. + iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". + iModIntro. iExists σ, σ', β. + iFrame "Hlst". + iIntros (rest). + iFrame "H". + iAssert (@gReifiers_re _ NotCtxDep rs _ _ op (x, gState_recomp rest σ) + ≡ Some (y, gState_recomp rest σ'))%I + with "[Hreify]" as "Hgreify". + { pose proof (@gReifiers_re_idx n NotCtxDep i rs (IT rs)) as J. + simpl in J. + simpl. + rewrite J; clear J. + iAssert (optionO_map (prodO_map idfun (gState_recomp rest)) + (sReifier_re (rs !!! i) lop (x, σ)) + ≡ optionO_map (prodO_map idfun (gState_recomp rest)) + (Some (y, σ')))%I with "[Hreify]" as "H". + - iApply (f_equivI with "Hreify"). + - simpl. iExact "H". + } + iPoseProof (reify_vis_eqI_ctx_indep _ _ _ k with "Hgreify") as "Hreify". + iRewrite "Hk" in "Hreify". + by rewrite -Tick_eq. + Qed. + + Lemma wp_subreify_ctx_dep' (rs : gReifiers CtxDep n) + `{!@stateG _ CtxDep rs A _ Σ} E1 E2 s Φ sR `{!subReifier sR rs} + (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ (IT rs)) + (k : Outs (F rs (subEff_opid op)) ♯ IT rs -n> laterO (IT rs)) : + (|={E1,E2}=> ∃ σ y σ' β, has_substate rs σ ∗ + sReifier_re sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (y, σ') + ∗ y ≡ Next β + ∗ ▷ (£ 1 -∗ has_substate rs σ' ={E2,E1}=∗ wp rs β s E1 Φ)) + -∗ wp rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. + Proof. + iIntros "H". + iApply wp_reify_idx_ctx_dep. + iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". + iModIntro. + iExists (sR_state σ), y, (sR_state σ'), β. + simpl. + iFrame "Hlst H". + rewrite subReifier_reify_idxI_ctx_dep. + iFrame "Hk". + iRewrite - "Hreify". + iPureIntro. + do 2 f_equiv. + intros ?; simpl. + by rewrite ofe_iso_12. + Qed. + + Lemma wp_subreify_ctx_indep' (rs : gReifiers NotCtxDep n) + `{!@stateG _ NotCtxDep rs A _ Σ} E1 E2 s Φ sR `{!subReifier sR rs} + (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ (IT rs)) + (k : Outs (F rs (subEff_opid op)) ♯ IT rs -n> laterO (IT rs)) : + (|={E1,E2}=> ∃ σ y σ' β, has_substate rs σ ∗ + sReifier_re sR op (x, σ) ≡ Some (y, σ') + ∗ k (subEff_outs y) ≡ Next β + ∗ ▷ (£ 1 -∗ has_substate rs σ' ={E2,E1}=∗ wp rs β s E1 Φ)) + -∗ wp rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. + Proof. + iIntros "H". + iApply wp_reify_idx_ctx_indep. + iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". + iModIntro. + iExists (sR_state σ),(subEff_outs y), (sR_state σ'), β. + iFrame "Hlst H Hk". + by iApply subReifier_reify_idxI_ctx_indep. + Qed. + + Lemma wp_subreify_ctx_dep (rs : gReifiers CtxDep n) + `{!@stateG _ CtxDep rs A _ Σ} E1 s Φ sR `{!subReifier sR rs} + (op : opid (sReifier_ops sR)) + (x : Ins (sReifier_ops sR op) ♯ IT rs) (y : laterO (IT rs)) + (k : Outs (F rs (subEff_opid op)) ♯ IT rs -n> laterO (IT rs)) + (σ σ' : sReifier_state sR ♯ IT rs) β : + sReifier_re sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (y, σ') → + y ≡ Next β → + has_substate rs σ -∗ + ▷ (£ 1 -∗ has_substate rs σ' -∗ wp rs β s E1 Φ) + -∗ + wp rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. + Proof. + intros HSR Hk. + iIntros "Hlst H". + iApply (wp_reify with "Hlst H"). + intros rest. + rewrite Tick_eq. rewrite -Hk. + rewrite reify_vis_eq_ctx_dep //. + pose proof (@subReifier_reify n CtxDep sR rs _ + (IT rs) _ op x y (k ◎ subEff_outs) σ σ' rest) as H'. + simpl in H'. + rewrite <-H'. + - simpl. + repeat f_equiv. + + intros ???. + solve_proper. + + intros ?; simpl. + rewrite ofe_iso_12. + reflexivity. + - rewrite HSR. + reflexivity. + Qed. + + Lemma wp_subreify_ctx_indep (rs : gReifiers NotCtxDep n) + `{!@stateG _ NotCtxDep rs A _ Σ} E1 s Φ sR `{!subReifier sR rs} + (op : opid (sReifier_ops sR)) + (x : Ins (sReifier_ops sR op) ♯ IT rs) + (y : Outs (sReifier_ops sR op) ♯ IT rs) + (k : Outs (F rs (subEff_opid op)) ♯ IT rs -n> laterO (IT rs)) + (σ σ' : sReifier_state sR ♯ IT rs) β : + sReifier_re sR op (x, σ) ≡ Some (y, σ') → + k (subEff_outs y) ≡ Next β → + has_substate rs σ -∗ + ▷ (£ 1 -∗ has_substate rs σ' -∗ wp rs β s E1 Φ) + -∗ + wp rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. + Proof. + intros HSR Hk. + iIntros "Hlst H". + iApply (wp_reify with "Hlst H"). + intros rest. + rewrite Tick_eq. rewrite -Hk. + rewrite reify_vis_eq_ctx_indep //. + by apply (subReifier_reify (a := NotCtxDep)). + Qed. + +End weakestpre_specific. + +Section weakestpre_bind. + Context {n : nat} (rs : gReifiers NotCtxDep n) {A} `{!Cofe A}. + Notation rG := (gReifiers_sReifier rs). + Notation F := (sReifier_ops rG). + Notation IT := (IT F A). + Notation ITV := (ITV F A). + Notation stateF := (gReifiers_state rs). + Notation stateO := (stateF ♯ IT). + Notation stateR := (gReifiers_ucmra rs IT). + Let of_state := (of_state rs IT). + Let of_idx := (of_idx rs IT). + Notation reify := (reify rG). + Notation istep := (istep rG). + Notation isteps := (isteps rG). + Notation sstep := (sstep rG). + Notation ssteps := (ssteps rG). + Notation wp := (wp rs). + + Implicit Type op : opid F. + Implicit Type α β : IT. + + Context `{!invGS Σ} `{!stateG rs (A:=A) Σ}. + Notation iProp := (iProp Σ). + Notation coPsetO := (leibnizO coPset). + + Notation "'WP' α @ s ; E {{ Φ } }" := (wp α s E Φ) + (at level 20, α, s, Φ at level 200, only parsing) : bi_scope. + + Notation "'WP' α @ s ; E {{ v , Q } }" := (wp α s E (λ v, Q)) + (at level 20, α, s, Q at level 200, + format "'[hv' 'WP' α '/' @ s ; E '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. + + Lemma wp_bind (f : IT → IT) `{!IT_hom f} (α : IT) s Φ `{!NonExpansive Φ} E1 : + WP α @ s;E1 {{ βv, WP (f (IT_of_V βv)) @ s;E1 {{ βv, Φ βv }} }} ⊢ WP (f α) @ s;E1 {{ Φ }}. + Proof. + assert (NonExpansive (λ βv0, WP f (IT_of_V βv0) @ s;E1 {{ βv1, Φ βv1 }})%I). + { solve_proper. } + iIntros "H". iLöb as "IH" forall (α). + rewrite (wp_unfold _ (f _)). + destruct (IT_to_V (f α)) as [βv|] eqn:Hfa. + - iLeft. iExists βv. iSplit; first done. + assert (is_Some (IT_to_V α)) as [αv Ha]. + { apply (IT_hom_val_inv _ f). rewrite Hfa. + done. } + assert (IntoVal α αv). + { apply IT_of_to_V'. by rewrite Ha. } + rewrite wp_val_inv. + iApply wp_val_inv. + rewrite IT_of_to_V'; last by rewrite -Ha. + rewrite IT_of_to_V'; last by rewrite -Hfa. + by iApply fupd_wp. + - iRight. iSplit; eauto. + iIntros (σ) "Hs". + rewrite wp_unfold. + iDestruct "H" as "[H | H]". + + iDestruct "H" as (αv) "[Hav H]". + iPoseProof (IT_of_to_V with "Hav") as "Hav". + iMod "H" as "H". rewrite wp_unfold. + iDestruct "H" as "[H|H]". + { iExFalso. iDestruct "H" as (βv) "[H _]". + iRewrite "Hav" in "H". rewrite Hfa. + iApply (option_equivI with "H"). } + iDestruct "H" as "[_ H]". + iMod ("H" with "Hs") as "H". iModIntro. + iRewrite "Hav" in "H". done. + + iDestruct "H" as "[Hav H]". + iMod ("H" with "Hs") as "[Hsafe H]". iModIntro. + iSplit. + { (* safety *) + iDestruct "Hsafe" as "[Hsafe|Herr]". + - iDestruct "Hsafe" as (α' σ') "Hsafe". iLeft. + iExists (f α'), σ'. iApply (istep_hom with "Hsafe"). + - iDestruct "Herr" as (e) "[Herr %]". + iRight. iExists e. iSplit; last done. + iRewrite "Herr". rewrite hom_err//. } + iIntros (σ' β) "Hst". + rewrite {1}istep_hom_inv. iDestruct "Hst" as "[%Ha | [_ Hst]]". + { destruct Ha as [αv Ha]. rewrite Ha. + iExFalso. + iApply (option_equivI with "Hav"). } + iDestruct "Hst" as (α') "[Hst Hb]". + iIntros "Hlc". + iMod ("H" with "Hst Hlc") as "H". iModIntro. + iNext. iMod "H" as "H". iModIntro. + iMod "H" as "[$ H]". + iModIntro. iRewrite "Hb". by iApply "IH". + Qed. + +End weakestpre_bind. + +Arguments wp {_ _} rs {_ _ _ _ _} α s E Φ. +Arguments has_full_state {n _ _ _ _ _ _} σ. +Arguments has_state_idx {n _ _ _ _ _ _} i σ. +Arguments has_substate {n _ _ _ _ _ _ _ _} σ. +Arguments stateG {n _} rs A {_} Σ. +Arguments statePreG {n _} rs A {_} Σ. +Arguments stateΣ {n _} rs A {_}. Definition notStuck : stuckness := λ e, False. - Notation "'WP@{' re } α @ s ; E {{ Φ } }" := (wp re α s E Φ) +Notation "'WP@{' re } α @ s ; E {{ Φ } }" := + (wp re α s E Φ) (at level 20, α, s, Φ at level 200, only parsing) : bi_scope. - Notation "'WP@{' re } α @ s ; E {{ v , Q } }" := (wp re α s E (λ v, Q)) +Notation "'WP@{' re } α @ s ; E {{ v , Q } }" := + (wp re α s E (λ v, Q)) (at level 20, α, s, Q at level 200, - format "'[hv' 'WP@{' re } α '/' @ s ; E '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. + format "'[hv' 'WP@{' re } α '/' @ s ; E '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. - Notation "'WP@{' re } α @ s {{ β , Φ } }" := (wp re α s ⊤ (λ β, Φ)) +Notation "'WP@{' re } α @ s {{ β , Φ } }" := + (wp re α s ⊤ (λ β, Φ)) (at level 20, α, Φ at level 200, - format "'WP@{' re } α @ s {{ β , Φ } }") : bi_scope. + format "'WP@{' re } α @ s {{ β , Φ } }") : bi_scope. - Notation "'WP@{' re } α @ s {{ Φ } }" := (wp re α s ⊤ Φ) +Notation "'WP@{' re } α @ s {{ Φ } }" := + (wp re α s ⊤ Φ) (at level 20, α, Φ at level 200, - format "'WP@{' re } α @ s {{ Φ } }") : bi_scope. + format "'WP@{' re } α @ s {{ Φ } }") : bi_scope. - Notation "'WP@{' re } α {{ β , Φ } }" := (wp re α notStuck ⊤ (λ β, Φ)) +Notation "'WP@{' re } α {{ β , Φ } }" := + (wp re α notStuck ⊤ (λ β, Φ)) (at level 20, α, Φ at level 200, - format "'WP@{' re } α {{ β , Φ } }") : bi_scope. + format "'WP@{' re } α {{ β , Φ } }") : bi_scope. - Notation "'WP@{' re } α {{ Φ } }" := (wp re α notStuck ⊤ Φ) +Notation "'WP@{' re } α {{ Φ } }" := + (wp re α notStuck ⊤ Φ) (at level 20, α, Φ at level 200, - format "'WP@{' re } α {{ Φ } }") : bi_scope. + format "'WP@{' re } α {{ Φ } }") : bi_scope. -Lemma wp_adequacy cr Σ `{!invGpreS Σ} n (rs : gReifiers n) +Lemma wp_adequacy cr Σ `{!invGpreS Σ} n a (rs : gReifiers a n) {A} `{!Cofe A} `{!statePreG rs A Σ} (α : IT _ A) σ βv σ' s k (ψ : (ITV (gReifiers_ops rs) A) → Prop) : ssteps (gReifiers_sReifier rs) α σ (IT_of_V βv) σ' k → (∀ `{H1 : !invGS Σ} `{H2: !stateG rs A Σ}, - ∃ Φ, NonExpansive Φ ∧ (∀ βv, Φ βv ⊢ ⌜ψ βv⌝) - ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → + ∃ Φ, NonExpansive Φ ∧ (∀ βv, Φ βv ⊢ ⌜ψ βv⌝) + ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → ψ βv. Proof. intros Hst Hprf. @@ -817,21 +1021,21 @@ Proof. by iApply fupd_mask_intro_discard. Qed. -Lemma wp_safety cr Σ `{!invGpreS Σ} n (rs : gReifiers n) +Lemma wp_safety cr Σ `{!invGpreS Σ} n a (rs : gReifiers a n) {A} `{!Cofe A} `{!statePreG rs A Σ} s k (α β : IT (gReifiers_ops rs) A) (σ σ' : gReifiers_state rs ♯ IT (gReifiers_ops rs) A) : (∀ Σ P Q, @disjunction_property Σ P Q) → ssteps (gReifiers_sReifier rs) α σ β σ' k → IT_to_V β ≡ None → (∀ `{H1 : !invGS_gen HasLc Σ} `{H2: !stateG rs A Σ}, - ∃ Φ, NonExpansive Φ ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → + ∃ Φ, NonExpansive Φ ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → ((∃ β1 σ1, sstep (gReifiers_sReifier rs) β σ' β1 σ1) ∨ (∃ e, β ≡ Err e ∧ s e)). Proof. Opaque istep. intros Hdisj Hstep Hbv Hwp. cut (⊢@{iProp Σ} (∃ β1 σ1, istep (gReifiers_sReifier rs) β σ' β1 σ1) - ∨ (∃ e, β ≡ Err e ∧ ⌜s e⌝))%I. + ∨ (∃ e, β ≡ Err e ∧ ⌜s e⌝))%I. { intros [Hprf | Hprf]%Hdisj. - left. apply (istep_safe_sstep _ (Σ:=Σ)). diff --git a/theories/input_lang/interp.v b/theories/input_lang/interp.v deleted file mode 100644 index b167ae7..0000000 --- a/theories/input_lang/interp.v +++ /dev/null @@ -1,566 +0,0 @@ -From Equations Require Import Equations. -From gitrees Require Import gitree. -From gitrees.input_lang Require Import lang. - -Notation stateO := (leibnizO state). - -Program Definition inputE : opInterp := {| - Ins := unitO; - Outs := natO; -|}. -Program Definition outputE : opInterp := {| - Ins := natO; - Outs := unitO; -|}. -Definition ioE := @[inputE;outputE]. -Canonical Structure reify_io : sReifier. -Proof. - simple refine {| sReifier_ops := ioE; - sReifier_state := stateO - |}. - intros X HX op. - destruct op as [[] | [ | []]]; simpl. - - simple refine (λne (us : prodO unitO stateO), - Some $ update_input (sndO us) : optionO (prodO natO stateO)). - intros n [[] s1] [[] s2] [_ Hs]. - repeat f_equiv. apply Hs. - - simple refine (λne (us : prodO natO stateO), - Some $ ((), update_output (fstO us) (sndO us)) : optionO (prodO unitO stateO)). - intros n [m s1] [m' s2] [-> Hs]. solve_proper. -Defined. - - -Section constructors. - Context {E : opsInterp} {A} `{!Cofe A}. - Context {subEff0 : subEff ioE E}. - Context {subOfe0 : SubOfe natO A}. - Notation IT := (IT E A). - Notation ITV := (ITV E A). - - Program Definition INPUT : (nat -n> IT) -n> IT := λne k, Vis (E:=E) (subEff_opid (inl ())) - (subEff_ins (F:=ioE) (op:=(inl ())) ()) - (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inl ())))^-1). - Solve Obligations with solve_proper. - Program Definition OUTPUT_ : nat -n> IT -n> IT := - λne m α, Vis (E:=E) (subEff_opid (inr (inl ()))) - (subEff_ins (F:=ioE) (op:=(inr (inl ()))) m) - (λne _, NextO α). - Solve All Obligations with solve_proper_please. - Program Definition OUTPUT : nat -n> IT := λne m, OUTPUT_ m (Ret 0). - - Lemma hom_INPUT k f `{!IT_hom f} : f (INPUT k) ≡ INPUT (OfeMor f ◎ k). - Proof. - unfold INPUT. - rewrite hom_vis/=. repeat f_equiv. - intro x. cbn-[laterO_map]. rewrite laterO_map_Next. - done. - Qed. - Lemma hom_OUTPUT_ m α f `{!IT_hom f} : f (OUTPUT_ m α) ≡ OUTPUT_ m (f α). - Proof. - unfold OUTPUT. - rewrite hom_vis/=. repeat f_equiv. - intro x. cbn-[laterO_map]. rewrite laterO_map_Next. - done. - Qed. - -End constructors. - -Section weakestpre. - Context {sz : nat}. - Variable (rs : gReifiers sz). - Context {subR : subReifier reify_io rs}. - Notation F := (gReifiers_ops rs). - Context {R} `{!Cofe R}. - Context `{!SubOfe natO R}. - Notation IT := (IT F R). - Notation ITV := (ITV F R). - Context `{!invGS Σ, !stateG rs R Σ}. - Notation iProp := (iProp Σ). - - Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : - update_input σ = (n, σ') → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ - WP@{rs} (INPUT k) @ s {{ Φ }}. - Proof. - intros Hs. iIntros "Hs Ha". - unfold INPUT. simpl. - iApply (wp_subreify with "Hs"). - { simpl. by rewrite Hs. } - { simpl. by rewrite ofe_iso_21. } - iModIntro. done. - Qed. - Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : - update_output n σ = σ' → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ - WP@{rs} (OUTPUT n) @ s {{ Φ }}. - Proof. - intros Hs. iIntros "Hs Ha". - unfold OUTPUT. simpl. - iApply (wp_subreify with "Hs"). - { simpl. by rewrite Hs. } - { simpl. done. } - iModIntro. iIntros "H1 H2". - iApply wp_val. by iApply ("Ha" with "H1 H2"). - Qed. - -End weakestpre. - -Section interp. - Context {sz : nat}. - Variable (rs : gReifiers sz). - Context {subR : subReifier reify_io rs}. - Context {R} `{!Cofe R}. - Context `{!SubOfe natO R}. - Notation F := (gReifiers_ops rs). - Notation IT := (IT F R). - Notation ITV := (ITV F R). - - (** Interpreting individual operators *) - Program Definition interp_input {A} : A -n> IT := - λne env, INPUT Ret. - Program Definition interp_output {A} (t : A -n> IT) : A -n> IT := - get_ret OUTPUT ◎ t. - Local Instance interp_ouput_ne {A} : NonExpansive2 (@interp_output A). - Proof. solve_proper. Qed. - - Program Definition interp_natop {A} (op : nat_op) (t1 t2 : A -n> IT) : A -n> IT := - λne env, NATOP (do_natop op) (t1 env) (t2 env). - Solve All Obligations with solve_proper_please. - - Global Instance interp_natop_ne A op : NonExpansive2 (@interp_natop A op). - Proof. solve_proper. Qed. - Typeclasses Opaque interp_natop. - - Opaque laterO_map. - Program Definition interp_rec_pre {A} (body : prodO IT (prodO IT A) -n> IT) - : laterO (A -n> IT) -n> A -n> IT := - λne self env, Fun $ laterO_map (λne (self : A -n> IT) (a : IT), - body (self env,(a,env))) self. - Solve All Obligations with first [ solve_proper | solve_proper_please ]. - - Definition interp_rec {A} body : A -n> IT := mmuu (interp_rec_pre body). - Program Definition ir_unf {A} (body : prodO IT (prodO IT A) -n> IT) env : IT -n> IT := - λne a, body (interp_rec body env, (a,env)). - Solve All Obligations with first [ solve_proper | solve_proper_please ]. - - Lemma interp_rec_unfold {A} (body : prodO IT (prodO IT A) -n> IT) env : - interp_rec body env ≡ Fun $ Next $ ir_unf body env. - Proof. - trans (interp_rec_pre body (Next (interp_rec body)) env). - { f_equiv. rewrite /interp_rec. apply mmuu_unfold. } - simpl. rewrite laterO_map_Next. repeat f_equiv. - simpl. unfold ir_unf. intro. simpl. reflexivity. - Qed. - - Program Definition interp_app {A} (t1 t2 : A -n> IT) : A -n> IT := - λne env, APP' (t1 env) (t2 env). - Solve All Obligations with first [ solve_proper | solve_proper_please ]. - Global Instance interp_app_ne A : NonExpansive2 (@interp_app A). - Proof. solve_proper. Qed. - Typeclasses Opaque interp_app. - - Program Definition interp_if {A} (t0 t1 t2 : A -n> IT) : A -n> IT := - λne env, IF (t0 env) (t1 env) (t2 env). - Solve All Obligations with first [ solve_proper | solve_proper_please ]. - Global Instance interp_if_ne A n : - Proper ((dist n) ==> (dist n) ==> (dist n) ==> (dist n)) (@interp_if A). - Proof. solve_proper. Qed. - - Program Definition interp_nat (n : nat) {A} : A -n> IT := - λne env, Ret n. - - (** Interpretation for all the syntactic categories: values, expressions, contexts *) - Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := - match v with - | Lit n => interp_nat n - | RecV e => interp_rec (interp_expr e) - end - with interp_expr {S} (e : expr S) : interp_scope S -n> IT := - match e with - | Val v => interp_val v - | Var x => interp_var x - | Rec e => interp_rec (interp_expr e) - | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) - | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) - | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) - | Input => interp_input - | Output e => interp_output (interp_expr e) - end. - - Program Definition interp_ctx_item {S : scope} (K : ectx_item S) : interp_scope S -n> IT -n> IT := - match K with - | AppLCtx v2 => λne env t, interp_app (constO t) (interp_val v2) env - | AppRCtx e1 => λne env t, interp_app (interp_expr e1) (constO t) env - | NatOpLCtx op v2 => λne env t, interp_natop op (constO t) (interp_val v2) env - | NatOpRCtx op e1 => λne env t, interp_natop op (interp_expr e1) (constO t) env - | IfCtx e1 e2 => λne env t, interp_if (constO t) (interp_expr e1) (interp_expr e2) env - | OutputCtx => λne env t, interp_output (constO t) env - end. - Solve All Obligations with first [ solve_proper | solve_proper_please ]. - - #[global] Instance interp_val_asval {S} (v : val S) D : AsVal (interp_val v D). - Proof. - destruct v; simpl; first apply _. - rewrite interp_rec_unfold. apply _. - Qed. - Program Fixpoint interp_ectx {S} (K : ectx S) : interp_scope S -n> IT -n> IT - := - match K with - | [] => λne env, idfun - | Ki::K => λne env, interp_ectx K env ◎ interp_ctx_item Ki env - end. - Next Obligation. solve_proper. Defined. (* XXX why can't i qed here? *) - - Lemma interp_ctx_item_fill {S} (Ki : ectx_item S) e env : - interp_expr (fill_item Ki e) env ≡ interp_ctx_item Ki env (interp_expr e env). - Proof. destruct Ki; reflexivity. Qed. - - Lemma interp_ectx_fill {S} (K : ectx S) e env : - interp_expr (fill K e) env ≡ interp_ectx K env (interp_expr e env). - Proof. - revert e; induction K as [|Ki K]=>e; first done. - rewrite IHK. simpl. rewrite interp_ctx_item_fill. done. - Qed. - - (** Applying renamings and subsitutions to the interpretation of scopes *) - Equations interp_rens_scope {S S' : scope} - (E : interp_scope (E:=F) (R:=R) S') (s : rens S S') : interp_scope (E:=F) (R:=R) S := - interp_rens_scope (S:=[]) E s := tt : interp_scope []; - interp_rens_scope (S:=_::_) E s := - (interp_var (hd_ren s) E, interp_rens_scope E (tl_ren s)). - - Equations interp_subs_scope {S S' : scope} - (E : interp_scope (E:=F) (R:=R) S') (s : subs S S') : interp_scope (E:=F) (R:=R) S := - interp_subs_scope (S:=[]) E s := tt : interp_scope []; - interp_subs_scope (S:=_::_) E s := - (interp_expr (hd_sub s) E, interp_subs_scope E (tl_sub s)). - - - Global Instance interp_rens_scope_ne S S2 n : - Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_rens_scope S S2). - Proof. - intros D D' HE s1 s2 Hs. - induction S as [|τ' S]; simp interp_rens_scope; auto. - f_equiv. - - unfold hd_ren; rewrite Hs. by f_equiv. - - apply IHS. intros v. unfold tl_ren; by rewrite Hs. - Qed. - Global Instance interp_subs_scope_ne S S2 n : - Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_subs_scope S S2). - Proof. - intros D D' HE s1 s2 Hs. - induction S as [|τ' S]; simp interp_subs_scope; auto. - f_equiv. - - unfold hd_sub; by rewrite Hs HE. - - apply IHS. intros v. unfold tl_sub; by rewrite Hs. - Qed. - Global Instance interp_rens_scope_proper S S2 : - Proper ((≡) ==> (≡) ==> (≡)) (@interp_rens_scope S S2). - Proof. - intros D D' HE s1 s2 Hs. - induction S as [|τ' S]; simp interp_rens_scope; auto. - f_equiv. - - unfold hd_ren; rewrite Hs. - by rewrite HE. - - apply IHS. intros v. unfold tl_ren; by rewrite Hs. - Qed. - Global Instance interp_subs_scope_proper S S2 : - Proper ((≡) ==> (≡) ==> (≡)) (@interp_subs_scope S S2). - Proof. - intros D D' HE s1 s2 Hs. - induction S as [|τ' S]; simp interp_subs_scope; auto. - f_equiv. - - unfold hd_sub; by rewrite Hs HE. - - apply IHS. intros v. unfold tl_sub; by rewrite Hs. - Qed. - - (** ** The substituion lemma, for renamings and substitutions *) - Lemma interp_rens_scope_tl_ren {S S2} x D (r : rens S S2) : - interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift r)) - ≡ interp_rens_scope D r. - Proof. - induction S as [|τ' S]; simp interp_rens_scope; eauto. - f_equiv. - { unfold hd_ren, tl_ren. simp rens_lift interp_var. - done. } - { rewrite -IHS. f_equiv. clear. - intros v. dependent elimination v; - unfold hd_ren, tl_ren; simp rens_lift; auto. } - Qed. - - Lemma interp_rens_scope_idren {S} (D : interp_scope S) : - interp_rens_scope D (@idren S) ≡ D. - Proof. - induction S as [|[] S]; simp interp_rens_scope. - { by destruct D. } - destruct D as [x D]. simp interp_var. simpl. - f_equiv. - trans (interp_rens_scope ((x, D) : interp_scope (()::S)) (tl_ren (rens_lift idren))). - { f_equiv. intros v. unfold tl_ren. - reflexivity. } - rewrite interp_rens_scope_tl_ren. - apply IHS. - Qed. - - Lemma interp_expr_ren {S D : scope} (M : expr S) (r : rens S D) : - ∀ (E : interp_scope D), - interp_expr (ren_expr M r) E ≡ interp_expr M (interp_rens_scope E r) - with interp_val_ren {S D : scope} (v : val S) (r : rens S D) : - ∀ (E : interp_scope D), - interp_val (ren_val v r) E ≡ interp_val v (interp_rens_scope E r). - Proof. - - revert D r. induction M=> D r D2; simpl; simp ren_expr. - all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). - + (* variable *) revert r. - induction v=>r. - * simp interp_var interp_rens_scope. done. - * simp interp_var interp_rens_scope. simpl. - apply (IHv (tl_ren r)). - + (* recursive functions *) simp ren_expr. simpl. - apply bi.siProp.internal_eq_soundness. - iLöb as "IH". - rewrite {2}interp_rec_unfold. - rewrite {2}(interp_rec_unfold (interp_expr M)). - iApply f_equivI. iNext. iApply internal_eq_pointwise. - rewrite /ir_unf. iIntros (x). simpl. - rewrite interp_expr_ren. - iApply f_equivI. - simp interp_rens_scope interp_var. simpl. - rewrite !interp_rens_scope_tl_ren. - iRewrite "IH". - done. - - revert D r. induction v=> D r D2; simpl; simp ren_val; eauto. - (* recursive functions *) - simp ren_expr. simpl. - apply bi.siProp.internal_eq_soundness. - iLöb as "IH". - rewrite {2}interp_rec_unfold. - rewrite {2}(interp_rec_unfold (interp_expr e)). - iApply f_equivI. iNext. iApply internal_eq_pointwise. - rewrite /ir_unf. iIntros (x). simpl. - rewrite interp_expr_ren. - iApply f_equivI. - simp interp_rens_scope interp_var. simpl. - rewrite !interp_rens_scope_tl_ren. - iRewrite "IH". - done. - Qed. - - Lemma interp_subs_scope_tl_sub {S S2} x D (s : subs S S2) : - interp_subs_scope ((x, D) : interp_scope (()::S2)) (tl_sub (subs_lift s)) - ≡ interp_subs_scope D s. - Proof. - induction S as [|[] S]; simp interp_subs_scope; first done. - f_equiv. - { unfold hd_sub, tl_sub. simp subs_lift interp_var. - unfold expr_lift. rewrite interp_expr_ren. f_equiv. - trans (interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift idren))). - { f_equiv. intros v. unfold tl_ren. - simp rens_lift idren. done. } - rewrite interp_rens_scope_tl_ren. - apply interp_rens_scope_idren. } - { rewrite -IHS. f_equiv. clear. - intros v. dependent elimination v; - unfold hd_sub, tl_sub; simp subs_lift; auto. } - Qed. - - Lemma interp_subs_scope_idsub {S} (env : interp_scope S) : - interp_subs_scope env idsub ≡ env. - Proof. - induction S as [|[] S]; simp interp_subs_scope. - { by destruct env. } - destruct env as [x env]. - unfold hd_sub, idsub. simpl. - simp interp_var. simpl. f_equiv. - etrans; last first. - { apply IHS. } - rewrite -(interp_subs_scope_tl_sub x env idsub). - repeat f_equiv. intro v. unfold tl_sub, idsub; simpl. - simp subs_lift. unfold expr_lift. simp ren_expr. done. - Qed. - - Lemma interp_expr_subst {S D : scope} (M : expr S) (s : subs S D) : - ∀ (E : interp_scope D), - interp_expr (subst_expr M s) E ≡ interp_expr M (interp_subs_scope E s) - with interp_val_subst {S D : scope} (v : val S) (s : subs S D) : - ∀ (E : interp_scope D), - interp_val (subst_val v s) E ≡ interp_val v (interp_subs_scope E s). - Proof. - - revert D s. induction M=> D r D2; simpl; simp subst_expr. - all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). - + (* variable *) revert r. - induction v=>r. - * simp interp_var interp_rens_scope. done. - * simp interp_var interp_rens_scope. simpl. - apply (IHv (tl_sub r)). - + (* recursive functions *) simpl. - apply bi.siProp.internal_eq_soundness. - iLöb as "IH". - rewrite {2}interp_rec_unfold. - rewrite {2}(interp_rec_unfold (interp_expr M)). - iApply f_equivI. iNext. iApply internal_eq_pointwise. - rewrite /ir_unf. iIntros (x). simpl. - rewrite interp_expr_subst. - iApply f_equivI. - simp interp_subs_scope interp_var. simpl. - rewrite !interp_subs_scope_tl_sub. - iRewrite "IH". - done. - - revert D s. induction v=> D r D2; simpl; simp subst_val; eauto. - (* recursive functions *) - simp subst_expr. simpl. - apply bi.siProp.internal_eq_soundness. - iLöb as "IH". - rewrite {2}interp_rec_unfold. - rewrite {2}(interp_rec_unfold (interp_expr e)). - iApply f_equivI. iNext. iApply internal_eq_pointwise. - rewrite /ir_unf. iIntros (x). simpl. - rewrite interp_expr_subst. - iApply f_equivI. - simp interp_subs_scope interp_var. simpl. - rewrite !interp_subs_scope_tl_sub. - iRewrite "IH". - done. - Qed. - - (** ** Interpretation is a homomorphism *) - #[global] Instance interp_ectx_item_hom {S} (Ki : ectx_item S) env : - IT_hom (interp_ctx_item Ki env). - Proof. destruct Ki; simpl; apply _. Qed. - #[global] Instance interp_ectx_hom {S} (K : ectx S) env : - IT_hom (interp_ectx K env). - Proof. induction K; simpl; apply _. Qed. - - (** ** Finally, preservation of reductions *) - Lemma interp_expr_head_step {S} env (e : expr S) e' σ σ' n : - head_step e σ e' σ' (n,0) → - interp_expr e env ≡ Tick_n n $ interp_expr e' env. - Proof. - inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. - - (*fun->val*) - reflexivity. - - (* app lemma *) - rewrite APP_APP'_ITV. - trans (APP (Fun (Next (ir_unf (interp_expr e1) env))) (Next $ interp_val v2 env)). - { repeat f_equiv. apply interp_rec_unfold. } - rewrite APP_Fun. simpl. rewrite Tick_eq. do 2 f_equiv. - simplify_eq. - rewrite interp_expr_subst. f_equiv. - simp interp_subs_scope. unfold hd_sub, tl_sub. simp conssub. - simpl. repeat f_equiv. - generalize (Val (RecV e1)). - generalize (Val v2). - clear. - intros e1 e2. - trans (interp_subs_scope env idsub); last first. - { f_equiv. intro v. simp conssub. done. } - symmetry. - apply interp_subs_scope_idsub. - - (* the natop stuff *) - simplify_eq. - destruct v1,v2; try naive_solver. simpl in *. - rewrite NATOP_Ret. - destruct op; simplify_eq/=; done. - - by rewrite IF_True. - - rewrite IF_False; eauto. lia. - Qed. - - Lemma interp_expr_fill_no_reify {S} K env (e e' : expr S) σ σ' n : - head_step e σ e' σ' (n,0) → - interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K e') env. - Proof. - intros He. - trans (interp_ectx K env (interp_expr e env)). - { apply interp_ectx_fill. } - trans (interp_ectx K env (Tick_n n (interp_expr e' env))). - { f_equiv. apply (interp_expr_head_step env) in He. apply He. } - trans (Tick_n n $ interp_ectx K env (interp_expr e' env)); last first. - { f_equiv. symmetry. apply interp_ectx_fill. } - apply hom_tick_n. apply _. - Qed. - - Opaque INPUT OUTPUT_. - Opaque Ret. - - Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) - (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : - head_step e σ e' σ' (n,1) → - reify (gReifiers_sReifier rs) - (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) - ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). - Proof. - intros Hst. - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) - (gState_recomp σr (sR_state σ))). - { f_equiv. by rewrite interp_ectx_fill. } - inversion Hst; simplify_eq; cbn-[gState_recomp]. - - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). - { repeat f_equiv; eauto. - rewrite hom_INPUT. f_equiv. by intro. } - rewrite reify_vis_eq //; last first. - { rewrite subReifier_reify/=//. - rewrite H4. done. } - repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. - rewrite interp_ectx_fill. - by rewrite ofe_iso_21. - - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). - { do 3 f_equiv; eauto. - rewrite get_ret_ret//. } - trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). - { do 2 f_equiv; eauto. - rewrite hom_OUTPUT_//. } - rewrite reify_vis_eq //; last first. - { rewrite subReifier_reify/=//. } - repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. - rewrite interp_ectx_fill. - simpl. done. - Qed. - - Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m env : - prim_step e1 σ1 e2 σ2 (n,m) → - ssteps (gReifiers_sReifier rs) - (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) - (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. - Proof. - Opaque gState_decomp gState_recomp. - inversion 1; simplify_eq/=. - destruct (head_step_io_01 _ _ _ _ _ _ H2); subst. - - assert (σ1 = σ2) as ->. - { eapply head_step_no_io; eauto. } - eapply (interp_expr_fill_no_reify K) in H2. - rewrite H2. eapply ssteps_tick_n. - - inversion H2;subst. - + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. - rewrite interp_ectx_fill. - rewrite hom_INPUT. - change 1 with (1+0). econstructor; last first. - { apply ssteps_zero; reflexivity. } - eapply sstep_reify. - { Transparent INPUT. unfold INPUT. simpl. - f_equiv. reflexivity. } - simpl in H2. - rewrite -H2. - repeat f_equiv; eauto. - rewrite interp_ectx_fill hom_INPUT. - eauto. - + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. - rewrite interp_ectx_fill. simpl. - rewrite get_ret_ret. - rewrite hom_OUTPUT_. - change 1 with (1+0). econstructor; last first. - { apply ssteps_zero; reflexivity. } - eapply sstep_reify. - { Transparent OUTPUT_. unfold OUTPUT_. simpl. - f_equiv. reflexivity. } - simpl in H2. - rewrite -H2. - repeat f_equiv; eauto. - Opaque OUTPUT_. - rewrite interp_ectx_fill /= get_ret_ret hom_OUTPUT_. - eauto. - Qed. - -End interp. -#[global] Opaque INPUT OUTPUT_. diff --git a/theories/input_lang/lang.v b/theories/input_lang/lang.v deleted file mode 100644 index 82fac6c..0000000 --- a/theories/input_lang/lang.v +++ /dev/null @@ -1,509 +0,0 @@ -From stdpp Require Export strings. -From gitrees Require Export prelude lang_generic. -From Equations Require Import Equations. -Require Import List. -Import ListNotations. - -Delimit Scope expr_scope with E. - -Inductive nat_op := Add | Sub | Mult. - -Inductive expr : scope → Type := - (* Values *) - | Val : forall {S}, val S → expr S - (* Base lambda calculus *) - | Var : forall {S}, var S → expr S - | Rec : forall {S}, expr (()::()::S) → expr S - | App : forall {S}, expr S → expr S → expr S - (* Base types and their operations *) - | NatOp : forall {S}, - nat_op → expr S → expr S → expr S - | If : forall {S}, - expr S → expr S → expr S → expr S - (* The effects *) - | Input : forall {S}, expr S - | Output : forall {S}, expr S → expr S -with val : scope → Type := - | Lit : forall {S}, nat → val S - | RecV : forall {S}, expr (()::()::S) → val S. - -Bind Scope expr_scope with expr. -Notation of_val := Val (only parsing). - -Definition to_val {S} (e : expr S) : option (val S) := - match e with - | Val v => Some v - | _ => None - end. - -Definition do_natop (op : nat_op) (x y : nat) : nat := - match op with - | Add => x+y - | Sub => x-y - | Mult => x+y - end. - -Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := - match x, y with - | Lit x, Lit y => Some $ Lit $ do_natop n x y - | _,_ => None - end. - -(** substitution stuff *) -Definition rens S S' := var S → var S'. -Definition subs S S' := var S → expr S'. - -Definition idren {S} : rens S S := fun v => v. -Definition idsub {S} : subs S S := Var. - -Equations conssub {S S' τ} (M : expr S') (s : subs S S') : subs (τ::S) S' := - conssub M s Vz := M; - conssub M s (Vs v) := s v. - -Notation "{/ e ; .. ; f /}" := (conssub e .. (conssub f idsub) ..). - -Definition tl_sub {S S' τ} : subs (τ::S) S' → subs S S' := λ s v, s (Vs v). -Definition hd_sub {S S' τ} : subs (τ::S) S' → expr S' := λ s, s Vz. -Definition tl_ren {S S' τ} : rens (τ::S) S' → rens S S' := λ s v, s (Vs v). -Definition hd_ren {S S' τ} : rens (τ::S) S' → var S' := λ s, s Vz. - -(* Lifting a renaming, renaming terms, and lifting substitutions *) -Equations rens_lift {S S'} (s : rens S S') : rens (()::S) (()::S') := - rens_lift s Vz := Vz; - rens_lift s (Vs v) := Vs $ s v. - -Equations ren_expr {S S'} (M : expr S) (r : rens S S') : expr S' := -ren_expr (Val v) r := Val $ ren_val v r; -ren_expr (Var v) r := Var (r v); -ren_expr (Rec M) r := Rec (ren_expr M (rens_lift (rens_lift r))); -ren_expr (App M N) r := App (ren_expr M r) (ren_expr N r); -ren_expr (NatOp op e1 e2) r := NatOp op (ren_expr e1 r) (ren_expr e2 r); -ren_expr (If e0 e1 e2) r := If (ren_expr e0 r) (ren_expr e1 r) (ren_expr e2 r); -ren_expr Input r := Input; -ren_expr (Output e) r := Output (ren_expr e r); -with ren_val {S S'} (M : val S) (r : rens S S') : val S' := -ren_val (Lit n) _ := Lit n; -ren_val (RecV e) r := RecV (ren_expr e (rens_lift (rens_lift r))). - - -Definition expr_lift {S} (M : expr S) : expr (()::S) := ren_expr M Vs. - -Equations subs_lift {S S'} (s : subs S S') : subs (()::S) (()::S') := - subs_lift s Vz := Var Vz; - subs_lift s (Vs v) := expr_lift $ s v. - -(* We can now define the substitution operation *) -Equations subst_expr {S S'} (M : expr S) (s : subs S S') : expr S' := -subst_expr (Val v) r := Val $ subst_val v r; -subst_expr (Var v) r := r v; -subst_expr (Rec M) r := Rec (subst_expr M (subs_lift (subs_lift r))); -subst_expr (App M N) r := App (subst_expr M r) (subst_expr N r); -subst_expr (NatOp op e1 e2) r := NatOp op (subst_expr e1 r) (subst_expr e2 r); -subst_expr (If e0 e1 e2) r := If (subst_expr e0 r) (subst_expr e1 r) (subst_expr e2 r); -subst_expr (Input) r := Input; -subst_expr (Output e) r := Output (subst_expr e r); -with subst_val {S S'} (M : val S) (r : subs S S') : val S' := -subst_val (Lit n) _ := Lit n; -subst_val (RecV e) r := RecV (subst_expr e (subs_lift (subs_lift r))). - -Definition subst1 {S : scope} {τ} (M : expr (τ::S)) (N : expr S) : expr S - := subst_expr M {/ N /}. -Definition subst2 {S : scope} {i j} (M : expr (i::j::S)) (N1 : expr S) (N2 : expr S) : expr S - := subst_expr M {/ N1; N2 /}. - -Definition appsub {S1 S2 S3} (s : subs S1 S2) (s' : subs S2 S3) : subs S1 S3 := - λ v, subst_expr (s v) s'. - -Global Instance rens_equiv S S' : Equiv (rens S S') := λ s1 s2, ∀ v, s1 v = s2 v. -Global Instance subs_equiv S S' : Equiv (subs S S') := λ s1 s2, ∀ v, s1 v = s2 v. - -Global Instance rens_lift_proper S S' : Proper ((≡) ==> (≡)) (@rens_lift S S'). -Proof. - intros s1 s2 Hs v. dependent elimination v; simp rens_lift; eauto. - f_equiv. apply Hs. -Qed. - -Lemma ren_expr_proper {S S'} (e : expr S) : Proper ((≡) ==> (=)) (@ren_expr S S' e) - with ren_val_proper {S S'} v : Proper ((≡) ==> (=)) (@ren_val S S' v). -Proof. - - revert S'. - induction e; intros S' s1 s2 Hs; simp ren_expr; - f_equiv; try solve [eauto | apply ren_expr_proper; eauto ]. - + by apply ren_val_proper. - + apply ren_expr_proper. by repeat f_equiv. - - revert S'. - induction v; intros S' s1 s2 Hs; simp ren_expr; - f_equiv; try solve [eauto | apply ren_expr_proper; eauto ]. - apply ren_expr_proper. by repeat f_equiv. -Qed. - -#[export] Existing Instance ren_expr_proper. -#[export] Existing Instance ren_val_proper. - -#[export] Instance subs_lift_proper S S' : Proper ((≡) ==> (≡)) (@subs_lift S S'). -Proof. - intros s1 s2 Hs v. dependent elimination v; simp subs_lift; eauto. - f_equiv. apply Hs. -Qed. - -Lemma subst_expr_proper {S S'} (e : expr S) : Proper ((≡) ==> (=)) (@subst_expr S S' e) - with subst_val_proper {S S'} v : Proper ((≡) ==> (=)) (@subst_val S S' v). -Proof. - - revert S'. - induction e; intros S' s1 s2 Hs; simp subst_expr; - f_equiv; try solve [eauto | apply subst_expr_proper; eauto ]. - + by apply subst_val_proper. - + apply subst_expr_proper. by repeat f_equiv. - - revert S'. - induction v; intros S' s1 s2 Hs; simp subst_expr; - f_equiv; try solve [eauto | apply subst_expr_proper; eauto ]. - apply subst_expr_proper. by repeat f_equiv. -Qed. -#[export] Existing Instance subst_expr_proper. -#[export] Existing Instance subst_val_proper. - -Lemma subst_ren_expr {S1 S2 S3} e (s : subs S2 S3) (r : rens S1 S2) : - subst_expr (ren_expr e r) s = subst_expr e (compose s r) -with subst_ren_val {S1 S2 S3} v (s : subs S2 S3) (r : rens S1 S2) : - subst_val (ren_val v r) s = subst_val v (compose s r). -Proof. - - revert S2 S3 r s. - induction e=>S2 S3 r s; simp ren_expr; simp subst_expr; try f_equiv; eauto. - rewrite IHe. apply subst_expr_proper. - intro v. simpl. - dependent elimination v; simp rens_lift; simp subs_lift; eauto. - f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. - - revert S2 S3 r s. - induction v=>S2 S3 r s; simpl; simp ren_val; simp subst_val; try f_equiv. - rewrite subst_ren_expr. - apply subst_expr_proper. - intro v. simpl. - dependent elimination v; simp rens_lift; simp subs_lift; eauto. - f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. -Qed. - -Lemma ren_ren_expr {S1 S2 S3} e (s : rens S2 S3) (r : rens S1 S2) : - ren_expr (ren_expr e r) s = ren_expr e (compose s r) -with ren_ren_val {S1 S2 S3} v (s : rens S2 S3) (r : rens S1 S2) : - ren_val (ren_val v r) s = ren_val v (compose s r). -Proof. - - revert S2 S3 r s. - induction e=>S2 S3 r s; simp ren_expr; try f_equiv; eauto. - rewrite IHe. apply ren_expr_proper. - intro v. simpl. - dependent elimination v; simp rens_lift; simp subs_lift; eauto. - f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. - - revert S2 S3 r s. - induction v=>S2 S3 r s; simpl; simp ren_val; simp subst_val; try f_equiv. - rewrite ren_ren_expr. - apply ren_expr_proper. - intro v. simpl. - dependent elimination v; simp rens_lift; simp subs_lift; eauto. - f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. -Qed. - -Definition rcompose {S1 S2 S3} (r : rens S2 S3) (s : subs S1 S2) : subs S1 S3 := - λ v, ren_expr (s v) r. - -Lemma ren_subst_expr {S1 S2 S3} e (s : subs S1 S2) (r : rens S2 S3) : - ren_expr (subst_expr e s) r = subst_expr e (rcompose r s) -with ren_subst_val {S1 S2 S3} v (s : subs S1 S2) (r : rens S2 S3) : - ren_val (subst_val v s) r = subst_val v (rcompose r s). -Proof. - - revert S2 S3 r s. - induction e=>S2 S3 r s; simp subst_expr; simp ren_expr; try f_equiv; eauto. - rewrite IHe. apply subst_expr_proper. - intro v. simpl. unfold rcompose. - dependent elimination v; eauto. - dependent elimination v; eauto. - simp subs_lift. unfold expr_lift. - rewrite !ren_ren_expr. apply ren_expr_proper. - intro x. dependent elimination v; eauto. - - revert S2 S3 r s. - induction v=>S2 S3 r s; simp subst_expr; simp ren_expr; try f_equiv; eauto. - rewrite ren_subst_expr. apply subst_expr_proper. - intro v. simpl. unfold rcompose. - dependent elimination v; eauto. - dependent elimination v; eauto. - simp subs_lift. unfold expr_lift. - rewrite !ren_ren_expr. apply ren_expr_proper. - intro x. dependent elimination v; eauto. -Qed. - -Lemma appsub_lift {S1 S2 S3} (s : subs S1 S2) (s' : subs S2 S3) : - subs_lift (appsub s s') ≡ appsub (subs_lift s) (subs_lift s'). -Proof. - unfold appsub. - intro v. dependent elimination v; simp subs_lift; eauto. - unfold expr_lift. rewrite subst_ren_expr. - rewrite ren_subst_expr. apply subst_expr_proper. - intro x. unfold rcompose. simpl. simp subs_lift. done. -Qed. - -Lemma subst_expr_appsub {S1 S2 S3} (s1 : subs S1 S2) (s2 : subs S2 S3) e : - subst_expr (subst_expr e s1) s2 = subst_expr e (appsub s1 s2) -with subst_val_appsub {S1 S2 S3} (s1 : subs S1 S2) (s2 : subs S2 S3) v : - subst_val (subst_val v s1) s2 = subst_val v (appsub s1 s2). -Proof. - - revert S2 S3 s1 s2. - induction e=>S2 S3 s1 s2; simp subst_expr; try f_equiv; eauto. - rewrite !appsub_lift. apply IHe. - - revert S3 s2. - induction v=>S3 s2; simpl; f_equiv; eauto. - rewrite !appsub_lift. apply subst_expr_appsub. -Qed. - -Lemma subst_expr_lift {S S'} e e1 (s : subs S S') : - subst_expr (expr_lift e) (conssub e1 s) = subst_expr e s. -Proof. - unfold expr_lift. - rewrite subst_ren_expr. apply subst_expr_proper. - intro v. simpl. simp conssub. done. -Qed. - -Lemma subst_expr_idsub {S} (e : expr S) : - subst_expr e idsub = e -with subst_val_idsub {S} (v : val S) : - subst_val v idsub = v. -Proof. - - induction e; simp subst_expr; simpl; try f_equiv; eauto. - assert ((subs_lift (subs_lift idsub)) ≡ idsub) as ->; last auto. - intro v. - dependent elimination v; simp subs_lift; auto. - dependent elimination v; simp subs_lift; auto. - - induction v; simp subst_val; simpl; try f_equiv; eauto. - assert ((subs_lift (subs_lift idsub)) ≡ idsub) as ->; last auto. - intro v. - dependent elimination v; simp subs_lift; auto. - dependent elimination v; simp subs_lift; auto. -Qed. - -(*** Operational semantics *) - -Record state := State { - inputs : list nat; - outputs : list nat; - }. -#[export] Instance state_inhabited : Inhabited state := populate (State [] []). - - -Definition update_input (s : state) : nat * state := - match s.(inputs) with - | [] => (0, s) - | n::ns => - (n, {| inputs := ns; outputs := s.(outputs) |}) - end. -Definition update_output (n:nat) (s : state) : state := - {| inputs := s.(inputs); outputs := n::s.(outputs) |}. - - -Inductive head_step {S} : expr S → state → expr S → state → nat*nat → Prop := -| RecS e σ : - head_step (Rec e) σ (Val $ RecV e) σ (0,0) -| BetaS e1 v2 e' σ : - e' = subst2 e1 (Val $ RecV e1) (Val v2) → - head_step (App (Val $ RecV e1) (Val v2)) σ e' σ (1,0) -| InputS σ n σ' : - update_input σ = (n,σ') → - head_step Input σ (Val (Lit n)) σ' (1,1) -| OutputS σ n σ' : - update_output n σ = σ' → - head_step (Output (Val (Lit n))) σ (Val (Lit 0)) σ' (1,1) -| NatOpS op v1 v2 v3 σ : - nat_op_interp op v1 v2 = Some v3 → - head_step (NatOp op (Val v1) (Val v2)) σ - (Val v3) σ (0,0) -| IfTrueS n e1 e2 σ : - n > 0 → - head_step (If (Val (Lit n)) e1 e2) σ - e1 σ (0,0) -| IfFalseS n e1 e2 σ : - n = 0 → - head_step (If (Val (Lit n)) e1 e2) σ - e2 σ (0,0) -. - -Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 n m : - head_step e1 σ1 e2 σ2 (n,m) → m = 0 ∨ m = 1. -Proof. inversion 1; eauto. Qed. -Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 n m : - head_step e1 σ1 e2 σ2 (n,m) → n = 0 ∨ n = 1. -Proof. inversion 1; eauto. Qed. -Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 n : - head_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. -Proof. inversion 1; eauto. Qed. - -Inductive ectx_item {S} := - | AppLCtx (v2 : val S) - | AppRCtx (e1 : expr S) - | NatOpLCtx (op : nat_op) (v2 : val S) - | NatOpRCtx (op : nat_op) (e1 : expr S) - | IfCtx (e1 e2 : expr S) - | OutputCtx -. -Arguments ectx_item S : clear implicits. - -Definition fill_item {S} (Ki : ectx_item S) (e : expr S) : expr S := - match Ki with - | AppLCtx v2 => App e (of_val v2) - | AppRCtx e1 => App e1 e - | NatOpLCtx op v2 => NatOp op e (Val v2) - | NatOpRCtx op e1 => NatOp op e1 e - | IfCtx e1 e2 => If e e1 e2 - | OutputCtx => Output e - end. - -(** Carbonara from heap lang *) -Global Instance fill_item_inj {S} (Ki : ectx_item S) : Inj (=) (=) (fill_item Ki). -Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. - -Lemma fill_item_val {S} Ki (e : expr S) : - is_Some (to_val (fill_item Ki e)) → is_Some (to_val e). -Proof. intros [v ?]. induction Ki; simplify_option_eq; eauto. Qed. - -Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 m : head_step e1 σ1 e2 σ2 m → to_val e1 = None. -Proof. destruct 1; naive_solver. Qed. - -Lemma head_ctx_item_step_val {S} Ki (e : expr S) σ1 e2 σ2 m : - head_step (fill_item Ki e) σ1 e2 σ2 m → is_Some (to_val e). -Proof. revert m e2. induction Ki; simpl; inversion 1; simplify_option_eq; eauto. Qed. - -Lemma fill_item_no_val_inj {S} Ki1 Ki2 (e1 e2 : expr S) : - to_val e1 = None → to_val e2 = None → - fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2. -Proof. - revert Ki1. induction Ki2; intros Ki1; induction Ki1; naive_solver eauto with f_equal. -Qed. - -(** Lifting the head step **) - -Definition ectx S := (list (ectx_item S)). -Definition fill {S} (K : ectx S) (e : expr S) : expr S := foldl (flip fill_item) e K. - -Lemma fill_app {S} (K1 K2 : ectx S) e : fill (K1 ++ K2) e = fill K2 (fill K1 e). -Proof. apply foldl_app. Qed. - - -Lemma fill_val : ∀ {S} K (e : expr S), is_Some (to_val (fill K e)) → is_Some (to_val e). -Proof. intros S K. induction K as [|Ki K IH]=> e //=. by intros ?%IH%fill_item_val. Qed. - -Lemma fill_not_val : ∀ {S} K (e : expr S), to_val e = None → to_val (fill K e) = None. -Proof. - intros S K e. rewrite !eq_None_not_Some. - eauto using fill_val. -Qed. - -Lemma fill_empty {S} (e : expr S) : fill [] e = e. -Proof. reflexivity. Qed. -Lemma fill_comp {S} K1 K2 (e : expr S) : fill K1 (fill K2 e) = fill (K2 ++ K1) e. -Proof. by rewrite fill_app. Qed. -Global Instance fill_inj {S} (K:ectx S) : Inj (=) (=) (fill K). -Proof. induction K as [|Ki K IH]; rewrite /Inj; naive_solver. Qed. - - -Inductive prim_step {S} (e1 : expr S) (σ1 : state) - (e2 : expr S) (σ2 : state) (n : nat*nat) : Prop:= - Ectx_step (K : ectx S) e1' e2' : - e1 = fill K e1' → e2 = fill K e2' → - head_step e1' σ1 e2' σ2 n → prim_step e1 σ1 e2 σ2 n. - -Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : - prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. -Proof. - inversion 1; simplify_eq/=. - inversion H2; eauto. -Qed. - -Inductive prim_steps {S} : expr S → state → expr S → state → nat*nat → Prop := -| prim_steps_zero e σ : - prim_steps e σ e σ (0,0) -| prim_steps_abit e1 σ1 e2 σ2 e3 σ3 n1 m1 n2 m2 : - prim_step e1 σ1 e2 σ2 (n1,m1) → - prim_steps e2 σ2 e3 σ3 (n2,m2) → - prim_steps e1 σ1 e3 σ3 (n1+n2,m1+m2) -. - -Lemma Ectx_step' {S} (K : ectx S) e1 σ1 e2 σ2 efs : - head_step e1 σ1 e2 σ2 efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. -Proof. econstructor; eauto. Qed. - -Lemma prim_step_ctx {S} (K : ectx S) e1 σ1 e2 σ2 efs : - prim_step e1 σ1 e2 σ2 efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. -Proof. - destruct 1 as [K2 u1 u2 HK2]. - subst e1 e2. rewrite -!fill_app. - by econstructor; eauto. -Qed. - -Lemma prim_steps_ctx {S} (K : ectx S) e1 σ1 e2 σ2 efs : - prim_steps e1 σ1 e2 σ2 efs → prim_steps (fill K e1) σ1 (fill K e2) σ2 efs. -Proof. - induction 1; econstructor; eauto using prim_step_ctx. -Qed. - -Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) σ1 σ2 σ3 : - prim_steps e1 σ1 e2 σ2 nm1 → prim_steps e2 σ2 e3 σ3 nm2 → - prim_steps e1 σ1 e3 σ3 (nm1.1 + nm2.1, nm1.2 + nm2.2). -Proof. - intros Hst. revert nm2. - induction Hst; intros [n' m']; simplify_eq/=; first done. - rewrite -!Nat.add_assoc. intros Hsts. - econstructor; eauto. - by apply (IHHst (n',m')). -Qed. - -Lemma prim_step_steps {S} nm (e1 e2 : expr S) σ1 σ2 : - prim_step e1 σ1 e2 σ2 nm → prim_steps e1 σ1 e2 σ2 nm. -Proof. - destruct nm as [n m]. intro Hs. - rewrite -(Nat.add_0_r n). - rewrite -(Nat.add_0_r m). - econstructor; eauto. - by constructor. -Qed. - - -(*** Type system *) - - -Inductive ty := - | Tnat : ty | Tarr : ty → ty → ty. - -Local Notation tyctx := (tyctx ty). - -Inductive typed : forall {S}, tyctx S → expr S → ty → Prop := -| typed_Val {S} (Γ : tyctx S) (τ : ty) (v : val S) : - typed_val Γ v τ → - typed Γ (Val v) τ -| typed_Var {S} (Γ : tyctx S) (τ : ty) (v : var S) : - typed_var Γ v τ → - typed Γ (Var v) τ -| typed_Rec {S} (Γ : tyctx S) (τ1 τ2 : ty) (e : expr (()::()::S) ) : - typed (consC (Tarr τ1 τ2) (consC τ1 Γ)) e τ2 → - typed Γ (Rec e) (Tarr τ1 τ2) -| typed_App {S} (Γ : tyctx S) (τ1 τ2 : ty) e1 e2 : - typed Γ e1 (Tarr τ1 τ2) → - typed Γ e2 τ1 → - typed Γ (App e1 e2) τ2 -| typed_NatOp {S} (Γ : tyctx S) e1 e2 op : - typed Γ e1 Tnat → - typed Γ e2 Tnat → - typed Γ (NatOp op e1 e2) Tnat -| typed_If {S} (Γ : tyctx S) e0 e1 e2 τ : - typed Γ e0 Tnat → - typed Γ e1 τ → - typed Γ e2 τ → - typed Γ (If e0 e1 e2) τ -| typed_Input {S} (Γ : tyctx S) : - typed Γ Input Tnat -| typed_Output {S} (Γ : tyctx S) e : - typed Γ e Tnat → - typed Γ (Output e) Tnat -with typed_val : forall {S}, tyctx S → val S → ty → Prop := -| typed_Lit {S} (Γ : tyctx S) n : - typed_val Γ (Lit n) Tnat -| typed_RecV {S} (Γ : tyctx S) (τ1 τ2 : ty) (e : expr (()::()::S) ) : - typed (consC (Tarr τ1 τ2) (consC τ1 Γ)) e τ2 → - typed_val Γ (RecV e) (Tarr τ1 τ2) -. - diff --git a/theories/lang_generic.v b/theories/lang_generic.v index bd40796..79b5a69 100644 --- a/theories/lang_generic.v +++ b/theories/lang_generic.v @@ -1,130 +1,78 @@ -From gitrees Require Import prelude. -From gitrees Require Import gitree. -From Equations Require Import Equations. +From gitrees Require Import prelude gitree utils.finite_sets. Require Import List. Import ListNotations. -(** XXX: We /NEED/ this line for [Equations Derive] to work, - this flag is globally unset by std++, but Equations need obligations to be transparent. *) -Set Transparent Obligations. - -Derive NoConfusion NoConfusionHom for list. - -Definition scope := (list unit). - -(** Variables in a context *) -Inductive var : scope → Type := -| Vz : forall {S : scope} {s}, var (s::S) -| Vs : forall {S : scope} {s}, var S -> var (s::S) -. -Derive Signature NoConfusion for var. - -Inductive tyctx (ty : Type) : scope → Type := -| empC : tyctx ty [] -| consC : forall{Γ}, ty → tyctx ty Γ → tyctx ty (()::Γ) -. -Arguments empC {_}. -Arguments consC {_ _} _ _. - -Equations list_of_tyctx {S ty} (Γ : tyctx ty S) : list ty := - list_of_tyctx empC := []; - list_of_tyctx (consC τ Γ') := τ::list_of_tyctx Γ'. - -Equations tyctx_app {S1 S2 ty} (c1 : tyctx ty S1) (c2 : tyctx ty S2) : tyctx ty (S1++S2) := - tyctx_app empC c2 := c2; - tyctx_app (consC τ c1) c2 := consC τ (tyctx_app c1 c2). - -Inductive typed_var {ty : Type}: forall {S}, tyctx ty S → var S → ty → Prop := -| typed_var_Z S (τ : ty) (Γ : tyctx ty S) : - typed_var (consC τ Γ) Vz τ -| typed_var_S S (τ τ' : ty) (Γ : tyctx ty S) v : - typed_var Γ v τ → - typed_var (consC τ' Γ) (Vs v) τ -. - -Section interp. +Require Import Binding.Lib Binding.Set. + +Section ctx_interp. Local Open Scope type. Context {E: opsInterp}. Context {R} `{!Cofe R}. Notation IT := (IT E R). Notation ITV := (ITV E R). - Fixpoint interp_scope (S : scope) : ofe := - match S with - | [] => unitO - | τ::Sc => prodO IT (interp_scope Sc) - end. - - Instance interp_scope_cofe S : Cofe (interp_scope S). - Proof. induction S; simpl; apply _. Qed. + Definition interp_scope (S : Set) : ofe := (leibnizO S) -n> IT. - Instance interp_scope_inhab S : Inhabited (interp_scope S). - Proof. induction S; simpl; apply _. Defined. + Global Instance interp_scope_cofe S : Cofe (interp_scope S). + Proof. apply _. Qed. - Equations interp_var {S : scope} (v : var S) : interp_scope S -n> IT := - interp_var (S:=(_::_)) Vz := fstO; - interp_var (S:=(_::Sc)) (Vs v) := interp_var v ◎ sndO. + Global Instance interp_scope_inhab S : Inhabited (interp_scope S). + Proof. apply _. Defined. - Instance interp_var_ne S (v : var S) : NonExpansive (@interp_var S v). - Proof. - intros n D1 D2 HD12. induction v; simp interp_var. - - by f_equiv. - - eapply IHv. by f_equiv. + Program Definition interp_var {S : Set} (v : S) : interp_scope S -n> IT := + λne (f : interp_scope S), f v. + Next Obligation. + solve_proper. Qed. - Global Instance interp_var_proper S (v : var S) : Proper ((≡) ==> (≡)) (interp_var v). - Proof. apply ne_proper. apply _. Qed. + Program Definition ı_scope : interp_scope Empty_set + := λne (x : ∅), match x with end. - Definition interp_scope_split {S1 S2} : - interp_scope (S1 ++ S2) -n> interp_scope S1 * interp_scope S2. + Definition interp_scope_split {S1 S2 : Set} : + interp_scope (sum S1 S2) -n> interp_scope S1 * interp_scope S2. Proof. - induction S1 as [|? S1]; simpl. - - simple refine (λne x, (tt, x)). - solve_proper. - - simple refine (λne xy, let ss := IHS1 xy.2 in ((xy.1, ss.1), ss.2)). - solve_proper. + simple refine (λne (f : interp_scope (sum S1 S2)), _). + - split. + + simple refine (λne x, _). + apply (f (inl x)). + + simple refine (λne x, _). + apply (f (inr x)). + - repeat intro; simpl. + repeat f_equiv; intro; simpl; f_equiv; assumption. Defined. - (** scope substituions *) - Inductive ssubst : scope → Type := - | emp_ssubst : ssubst [] - | cons_ssubst {S} : ITV → ssubst S → ssubst (tt::S) - . - - Equations interp_ssubst {S} (ss : ssubst S) : interp_scope S := - interp_ssubst emp_ssubst := tt; - interp_ssubst (cons_ssubst αv ss) := (IT_of_V αv, interp_ssubst ss). - - Equations list_of_ssubst {S} (ss : ssubst S) : list ITV := - list_of_ssubst emp_ssubst := []; - list_of_ssubst (cons_ssubst αv ss) := αv::(list_of_ssubst ss). - - Equations ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : ssubst S1 * ssubst S2 := - ssubst_split (S1:=[]) αs := (emp_ssubst,αs); - ssubst_split (S1:=u::_) (cons_ssubst αv αs) := - (cons_ssubst αv (ssubst_split αs).1, (ssubst_split αs).2). - Lemma interp_scope_ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : - interp_scope_split (interp_ssubst αs) ≡ - (interp_ssubst (ssubst_split αs).1, interp_ssubst (ssubst_split αs).2). - Proof. - induction S1 as [|u S1]; simpl. - - simp ssubst_split. simpl. - simp interp_ssubst. done. - - dependent elimination αs as [cons_ssubst αv αs]. - simp ssubst_split. simpl. - simp interp_ssubst. repeat f_equiv; eauto; simpl. - + rewrite IHS1//. - + rewrite IHS1//. + Global Instance interp_var_proper {S : Set} (v : S) : Proper ((≡) ==> (≡)) (interp_var v). + Proof. apply ne_proper. apply _. Qed. + + Program Definition extend_scope {S : Set} : interp_scope S -n> IT -n> interp_scope (inc S) + := λne γ μ x, let x' : inc S := x in + match x' with + | VZ => μ + | VS x'' => γ x'' + end. + Next Obligation. + intros ???? [| x] [| y]; term_simpl; [solve_proper | inversion 1 | inversion 1 | inversion 1; by subst]. + Qed. + Next Obligation. + intros ??????. + intros [| a]; term_simpl; solve_proper. + Qed. + Next Obligation. + intros ??????. + intros [| a]; term_simpl; solve_proper. Qed. -End interp. + Program Definition ren_scope {S S'} (δ : S [→] S') (env : interp_scope S') + : interp_scope S := λne x, env (δ x). + +End ctx_interp. (* Common definitions and lemmas for Kripke logical relations *) Section kripke_logrel. Variable s : stuckness. - Context {sz : nat}. - Variable rs : gReifiers sz. + Context {sz : nat} {a : is_ctx_dep}. + Variable rs : gReifiers a sz. Context {R} `{!Cofe R}. Notation F := (gReifiers_ops rs). @@ -134,56 +82,26 @@ Section kripke_logrel. Notation iProp := (iProp Σ). Context {A:ofe}. (* The type & predicate for the explicit Kripke worlds *) - Variable (P : A → iProp). - Context `{!NonExpansive P}. + Variable (P : A -n> iProp). Implicit Types α β : IT. Implicit Types αv βv : ITV. Implicit Types Φ Ψ : ITV -n> iProp. Program Definition expr_pred (α : IT) (Φ : ITV -n> iProp) : iProp := - (∀ x : A, P x -∗ WP@{rs} α @ s {{ v, ∃ y : A, Φ v ∗ P y }}). - #[export] Instance expr_pred_ne : NonExpansive2 expr_pred. - Proof. solve_proper. Qed. - #[export] Instance expr_pred_proper : Proper ((≡) ==> (≡) ==> (≡)) expr_pred . - Proof. solve_proper. Qed. - - Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S} (Γ : tyctx ty S) (ss : ssubst S) : iProp := - ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_ssubst (E:=F) ss), - interp_ty (τx.1) (τx.2))%I. - - Lemma ssubst_valid_nil {ty} (interp_ty : ty → ITV -n> iProp) : - ⊢ ssubst_valid interp_ty empC emp_ssubst. - Proof. - unfold ssubst_valid. - by simp list_of_tyctx list_of_ssubst. + (∀ x : A, P x -∗ wp rs α s ⊤ (λne v, ∃ y : A, Φ v ∗ P y)). + Next Obligation. + solve_proper. Qed. - Lemma ssubst_valid_cons {ty} (interp_ty : ty → ITV -n> iProp) {S} - (Γ : tyctx ty S) (ss : ssubst S) τ αv : - ssubst_valid interp_ty (consC τ Γ) (cons_ssubst αv ss) - ⊣⊢ interp_ty τ αv ∗ ssubst_valid interp_ty Γ ss. + Global Instance expr_pred_ne {n} : Proper (dist n ==> dist n ==> dist n) expr_pred. Proof. - unfold ssubst_valid. - by simp list_of_tyctx list_of_ssubst. + solve_proper. Qed. - Lemma ssubst_valid_app {ty} (interp_ty : ty → ITV -n> iProp) - {S1 S2} (Ω1 : tyctx ty S1) (Ω2 : tyctx ty S2) αs : - ssubst_valid interp_ty (tyctx_app Ω1 Ω2) αs ⊢ - ssubst_valid interp_ty Ω1 (ssubst_split αs).1 - ∗ ssubst_valid interp_ty Ω2 (ssubst_split αs).2. + Global Instance expr_pred_proper : Proper (equiv ==> equiv ==> equiv) expr_pred. Proof. - iInduction Ω1 as [|τ Ω1] "IH" forall (Ω2); simp tyctx_app ssubst_split. - - simpl. iIntros "$". iApply ssubst_valid_nil. - - iIntros "H". - rewrite {4 5}/ssubst_valid. - simpl in αs. - dependent elimination αs as [cons_ssubst αv αs]. - simp ssubst_split. simpl. - simp list_of_ssubst list_of_tyctx. - simpl. iDestruct "H" as "[$ H]". - by iApply "IH". + solve_proper. Qed. Lemma expr_pred_ret α αv Φ `{!IntoVal α αv} : @@ -191,32 +109,215 @@ Section kripke_logrel. Proof. iIntros "H". iIntros (x) "Hx". iApply wp_val. - eauto with iFrame. + simpl. + iExists x. + by iFrame. Qed. - Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} : - expr_pred α Ψ ⊢ - (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ - expr_pred (f α) Φ. + Lemma expr_pred_frame α Φ : + WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. + Proof. + iIntros "H". + iIntros (x) "Hx". + iApply (wp_wand with "H"). + simpl. + iIntros (v) "Hv". + iExists x. + by iFrame. + Qed. + +End kripke_logrel. + +Section kripke_logrel_ctx_indep. + Variable s : stuckness. + + Context {sz : nat}. + Variable rs : gReifiers NotCtxDep sz. + Context {R} `{!Cofe R}. + + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Context {A : ofe}. + Variable (P : A -n> iProp). + + Implicit Types α β : IT. + Implicit Types αv βv : ITV. + Implicit Types Φ Ψ : ITV -n> iProp. + + Local Notation expr_pred := (expr_pred s rs P). + + Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} + : expr_pred α Ψ ⊢ + (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) + -∗ expr_pred (f α) Φ. Proof. iIntros "H1 H2". iIntros (x) "Hx". iApply wp_bind. - { solve_proper. } iSpecialize ("H1" with "Hx"). iApply (wp_wand with "H1"). iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". iModIntro. iApply ("H2" with "Hb Hy"). Qed. +End kripke_logrel_ctx_indep. - Lemma expr_pred_frame α Φ : - WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. +Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_ _}. + +Section tm_interp. + Context {sz : nat} {a : is_ctx_dep}. + Variable rs : gReifiers a sz. + Context {R} `{!Cofe R}. + + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Context {A : ofe}. + Variable (P : A -n> iProp). + + Variable (ty : Set). + Variable (interp_ty : ty → (ITV -n> iProp)). + Variable (kripke : IT → (ITV -n> iProp) → iProp). + + Definition ssubst_valid1 {S : Set} + (Γ : S -> ty) + (ss : interp_scope S) : iProp := + (∀ x, □ kripke (ss x) (interp_ty (Γ x)))%I. + + Global Instance ssubst_valid_pers `{∀ τ β, Persistent (interp_ty τ β)} + {S : Set} (Γ : S → ty) ss : Persistent (ssubst_valid1 Γ ss). + Proof. apply _. Qed. + +End tm_interp. + +Section tm_interp_fin. + Context {sz : nat} {a : is_ctx_dep}. + Variable rs : gReifiers a sz. + Context {R} `{!Cofe R}. + + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Context {A : ofe}. + Variable (P : A -n> iProp). + + Variable (ty : Set). + Variable (interp_ty : ty → (ITV -n> iProp)). + Variable (kripke : IT → (ITV -n> iProp) → iProp). + + Program Definition ssubst_valid_fin1 {S : Set} `{!EqDecision S} `{!Finite S} + (Ω : S → ty) (ss : interp_scope S) : iProp + := ([∗ set] x ∈ (fin_to_set S), + (kripke (ss x) (interp_ty (Ω x)))%I). + + Context (Q : iProp). + + Definition valid_fin1 {S : Set} `{!EqDecision S} `{!Finite S} (Ω : S → ty) + (α : interp_scope S -n> IT) (τ : ty) : iProp := + ∀ ss, Q + -∗ (ssubst_valid_fin1 Ω ss) + -∗ kripke (α ss) (interp_ty τ). + + Lemma ssubst_valid_fin_empty1 (αs : interp_scope ∅) : + ⊢ ssubst_valid_fin1 □ αs. + Proof. + iStartProof. + unfold ssubst_valid_fin1. + rewrite fin_to_set_empty. + by iApply big_sepS_empty. + Qed. + + Lemma ssubst_valid_fin_app1 + {S1 S2 : Set} `{!EqDecision S1} `{!Finite S1} + `{!EqDecision S2} `{!Finite S2} + `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} + (Ω1 : S1 → ty) (Ω2 : S2 → ty) + (αs : interp_scope (sum S1 S2)) : + (ssubst_valid_fin1 (sum_map' Ω1 Ω2) αs) ⊢ + (ssubst_valid_fin1 Ω1 (interp_scope_split αs).1) + ∗ (ssubst_valid_fin1 Ω2 (interp_scope_split αs).2). Proof. iIntros "H". - iIntros (x) "Hx". - iApply (wp_wand with "H"). - eauto with iFrame. + rewrite /ssubst_valid_fin1 fin_to_set_sum big_sepS_union; first last. + { + apply elem_of_disjoint. + intros [x | x]. + - rewrite !elem_of_list_to_set. + intros _ H2. + apply elem_of_list_fmap_2 in H2. + destruct H2 as [y [H2 H2']]; inversion H2. + - rewrite !elem_of_list_to_set. + intros H1 _. + apply elem_of_list_fmap_2 in H1. + destruct H1 as [y [H1 H1']]; inversion H1. + } + iDestruct "H" as "(H1 & H2)". + iSplitL "H1". + - rewrite big_opS_list_to_set; first last. + { + apply NoDup_fmap. + - intros ??; by inversion 1. + - apply NoDup_elements. + } + rewrite big_sepL_fmap /=. + rewrite big_sepS_elements. + iFrame "H1". + - rewrite big_opS_list_to_set; first last. + { + apply NoDup_fmap. + - intros ??; by inversion 1. + - apply NoDup_elements. + } + rewrite big_sepL_fmap /=. + rewrite big_sepS_elements. + iFrame "H2". Qed. -End kripke_logrel. -Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. + + Lemma ssubst_valid_fin_cons1 {S : Set} `{!EqDecision S} `{!Finite S} + (Ω : S → ty) (αs : interp_scope S) τ t : + ssubst_valid_fin1 Ω αs ∗ kripke t (interp_ty τ) ⊢ ssubst_valid_fin1 (Ω ▹ τ) (extend_scope αs t). + Proof. + iIntros "(H & G)". + rewrite /ssubst_valid_fin1. + rewrite fin_to_set_inc /=. + rewrite big_sepS_union; first last. + { + apply elem_of_disjoint. + intros [| x]. + - rewrite !elem_of_list_to_set. + intros _ H2. + apply elem_of_list_fmap_2 in H2. + destruct H2 as [y [H2 H2']]; inversion H2. + - rewrite !elem_of_list_to_set. + intros H1 _. + apply elem_of_singleton_1 in H1. + inversion H1. + } + iSplitL "G". + - rewrite big_opS_singleton. + iFrame "G". + - erewrite big_opS_set_map. + + iFrame "H". + + intros ?? H; by inversion H. + Qed. + + Lemma ssubst_valid_fin_lookup1 {S : Set} `{!EqDecision S} `{!Finite S} + (Ω : S → ty) (αs : interp_scope S) x : + ssubst_valid_fin1 Ω αs ⊢ kripke (αs x) (interp_ty (Ω x)). + Proof. + iIntros "H". + iDestruct (big_sepS_elem_of_acc _ _ x with "H") as "($ & _)"; + first apply elem_of_fin_to_set. + Qed. + +End tm_interp_fin. diff --git a/theories/examples/factorial.v b/theories/lib/factorial.v similarity index 93% rename from theories/examples/factorial.v rename to theories/lib/factorial.v index 710062e..c85c4be 100644 --- a/theories/examples/factorial.v +++ b/theories/lib/factorial.v @@ -1,11 +1,12 @@ -From Equations Require Import Equations. From gitrees Require Import gitree program_logic. -From gitrees.input_lang Require Import lang interp. -From gitrees.examples Require Import store while. +From gitrees.examples.input_lang Require Import lang interp. +From gitrees.effects Require Import store. +From gitrees.lib Require Import while. Section fact. - Definition rs : gReifiers 2 := - gReifiers_cons reify_io (gReifiers_cons reify_store gReifiers_nil). + Context (n' : nat) (rs : gReifiers NotCtxDep n'). + Context `{!subReifier reify_store rs}. + Context `{!subReifier reify_io rs}. Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R, !SubOfe unitO R}. @@ -102,11 +103,11 @@ Section fact. simpl. rewrite get_ret_ret. iApply (wp_alloc with "Hctx"). { solve_proper. } - fold rs. iNext. iNext. + iNext. iNext. iIntros (acc) "Hacc". simpl. iApply (wp_alloc with "Hctx"). { solve_proper. } - fold rs. iNext. iNext. + iNext. iNext. iIntros (ℓ) "Hl". simpl. iApply wp_seq. { solve_proper. } @@ -141,4 +142,3 @@ Section fact. Qed. End fact. - diff --git a/theories/examples/iter.v b/theories/lib/iter.v similarity index 98% rename from theories/examples/iter.v rename to theories/lib/iter.v index 14063e7..c43e367 100644 --- a/theories/examples/iter.v +++ b/theories/lib/iter.v @@ -59,7 +59,7 @@ End iter. Section iter_wp. Context {sz : nat}. - Variable (rs : gReifiers sz). + Variable (rs : gReifiers NotCtxDep sz). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. Notation F := (gReifiers_ops rs). diff --git a/theories/examples/pairs.v b/theories/lib/pairs.v similarity index 100% rename from theories/examples/pairs.v rename to theories/lib/pairs.v diff --git a/theories/examples/while.v b/theories/lib/while.v similarity index 100% rename from theories/examples/while.v rename to theories/lib/while.v diff --git a/theories/prelude.v b/theories/prelude.v index 4ef5b7b..9592851 100644 --- a/theories/prelude.v +++ b/theories/prelude.v @@ -7,11 +7,26 @@ From iris.si_logic Require Import bi siprop. From iris.proofmode Require Import classes tactics modality_instances coq_tactics reduction. +Definition sum_map' {A B C : Set} (f : A → C) (g : B → C) : sum A B → C := + λ x, match x with | inl x' => f x' | inr x' => g x' end. + Program Definition idfun {A : ofe} : A -n> A := λne x, x. (** OFEs stuff *) Notation "F ♯ E" := (oFunctor_apply F E) (at level 20, right associativity). +Lemma ccompose_id_l {A B : ofe} (f : A -n> B) : + cid ◎ f ≡ f. +Proof. + intros x; reflexivity. +Qed. + +Lemma ccompose_id_r {A B : ofe} (f : A -n> B) : + f ◎ cid ≡ f. +Proof. + intros x; reflexivity. +Qed. + Infix "≃" := (ofe_iso) (at level 50). Definition ofe_iso_1' {A B : ofe} (p : A ≃ B) : A → B := ofe_iso_1 p. diff --git a/theories/program_logic.v b/theories/program_logic.v index 476157d..304248d 100644 --- a/theories/program_logic.v +++ b/theories/program_logic.v @@ -2,8 +2,31 @@ From gitrees Require Import gitree. Section program_logic. + Context {sz : nat} {a : is_ctx_dep}. + Variable rs : gReifiers a sz. + Notation F := (gReifiers_ops rs). + Context {R} `{!Cofe R}. + Notation IT := (IT F R). + Notation ITV := (ITV F R). + + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Lemma wp_lam (f : IT -n> IT) β s Φ `{!AsVal β} : + ▷ WP@{rs} f β @ s {{ Φ }} ⊢ WP@{rs} Fun (Next f) ⊙ β @ s{{ Φ }}. + Proof. + iIntros "H". + rewrite APP'_Fun_l. + simpl. + rewrite -Tick_eq. + by iApply wp_tick. + Qed. + +End program_logic. + +Section program_logic_ctx_indep. Context {sz : nat}. - Variable rs : gReifiers sz. + Variable rs : gReifiers NotCtxDep sz. Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Notation IT := (IT F R). @@ -32,13 +55,4 @@ Section program_logic. by rewrite LET_Val. Qed. - Lemma wp_lam (f : IT -n> IT) β s Φ `{!AsVal β} : - ▷ WP@{rs} f β @ s {{ Φ }} ⊢ WP@{rs} Fun (Next f) ⊙ β @ s{{ Φ }}. - Proof. - rewrite APP'_Fun_l. - rewrite -Tick_eq/=. iApply wp_tick. - Qed. - - -End program_logic. - +End program_logic_ctx_indep. diff --git a/theories/utils/finite_sets.v b/theories/utils/finite_sets.v new file mode 100644 index 0000000..463e388 --- /dev/null +++ b/theories/utils/finite_sets.v @@ -0,0 +1,221 @@ +From stdpp Require Export finite gmap. +Require Export Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. + +Lemma fin_to_set_sum {S1 S2 : Set} `{!EqDecision S1} `{!EqDecision S2} + `{!Finite S1} `{!Finite S2} `{HE : EqDecision (S1 + S2)} `{HF : @Finite (S1 + S2) HE} + : fin_to_set (S1 + S2) + = (set_map inl (fin_to_set S1 : gset S1)) + ∪ (set_map inr (fin_to_set S2 : gset S2)) + :> @gset (S1 + S2) HE (@finite_countable _ HE HF). +Proof. + apply set_eq. + intros [x|x]; simpl; split; intros _. + - apply elem_of_union; left. + apply elem_of_map_2. + apply elem_of_fin_to_set. + - apply elem_of_fin_to_set. + - apply elem_of_union; right. + apply elem_of_map_2. + apply elem_of_fin_to_set. + - apply elem_of_fin_to_set. +Qed. + +Lemma fin_to_set_empty `{HE : EqDecision ∅} `{HF : @Finite ∅ HE} : + fin_to_set ∅ = empty :> @gset ∅ HE (@finite_countable _ HE HF). +Proof. + apply set_eq; intros []. +Qed. + +Lemma fin_to_set_inc {S : Set} `{!EqDecision S} `{!Finite S} + `{HE : EqDecision (inc S)} `{HF : @Finite (inc S) HE} + : fin_to_set (inc S) = ({[VZ]} : gset (inc S)) ∪ (set_map VS (fin_to_set S : gset S)) + :> @gset (inc S) HE (@finite_countable _ HE HF). +Proof. + apply set_eq. + intros [| x]. + - split. + + intros _; apply elem_of_union; left. + by apply elem_of_singleton. + + intros _; apply elem_of_fin_to_set. + - split. + + intros _; apply elem_of_union; right. + apply elem_of_map_2, elem_of_fin_to_set. + + intros H. + apply elem_of_fin_to_set. +Qed. + +Section Sum. + (* Kenny Loggins starts playing in a background *) + + Lemma EqDecisionLeft {S1 S2 : Set} {H : EqDecision (S1 + S2)} : EqDecision S1. + Proof. + intros x y. + destruct (decide (inl x = inl y)) as [G | G]; + [left; by inversion G | right; intros C; by subst]. + Qed. + + Lemma EqDecisionRight {S1 S2 : Set} {H : EqDecision (S1 + S2)} : EqDecision S2. + Proof. + intros x y. + destruct (decide (inr x = inr y)) as [G | G]; + [left; by inversion G | right; intros C; by subst]. + Qed. + + Lemma FiniteLeft {S1 S2 : Set} `{EqDecision S1} + `{EqDecision (S1 + S2)} `{Finite (S1 + S2)} + : Finite S1. + Proof. + unshelve econstructor. + - apply (foldr (λ x acc, match x with + | inl x => x :: acc + | inr _ => acc + end) [] (enum (S1 + S2))). + - set (l := enum (S1 + S2)). + assert (NoDup l) as K; [apply (NoDup_enum (S1 + S2)) |]. + clearbody l. + induction l as [| a l IH]; [constructor |]. + destruct a as [a | a]; simpl. + + constructor. + * intros C. + assert (inl a ∈ l) as C'. + { + clear -C. + induction l as [| b l IH]; [inversion C |]. + destruct b as [b | b]; simpl. + - rewrite foldr_cons in C. + rewrite elem_of_cons in C. + destruct C as [-> | C]. + + apply elem_of_cons. + by left. + + right. + apply IH. + apply C. + - apply elem_of_cons. + right. + rewrite foldr_cons in C. + apply IH. + apply C. + } + by inversion K. + * apply IH. + by inversion K. + + apply IH. + by inversion K. + - intros x. + set (l := enum (S1 + S2)). + assert (inl x ∈ l) as K; [apply elem_of_enum |]. + clearbody l. + induction l as [| a l IH]; [inversion K |]. + destruct a as [a | a]; simpl. + + rewrite elem_of_cons in K. + destruct K as [K | K]. + * inversion K; subst. + apply elem_of_cons; by left. + * apply elem_of_cons; right; by apply IH. + + rewrite elem_of_cons in K. + destruct K as [K | K]; [inversion K |]. + by apply IH. + Qed. + + Lemma FiniteRight {S1 S2 : Set} `{EqDecision S2} + `{EqDecision (S1 + S2)} `{H : Finite (S1 + S2)} + : Finite S2. + Proof. + unshelve econstructor. + - apply (foldr (λ x acc, match x with + | inl _ => acc + | inr x => x :: acc + end) [] (enum (S1 + S2))). + - set (l := enum (S1 + S2)). + assert (NoDup l) as K; [apply NoDup_enum |]. + clearbody l. + induction l as [| a l IH]; [constructor |]. + destruct a as [a | a]; simpl. + + apply IH. + by inversion K. + + constructor. + * intros C. + assert (inr a ∈ l) as C'. + { + clear -C. + induction l as [| b l IH]; [inversion C |]. + destruct b as [b | b]; simpl. + - apply elem_of_cons. + right. + rewrite foldr_cons in C. + apply IH, C. + - rewrite foldr_cons in C. + rewrite elem_of_cons in C. + destruct C as [-> | C]. + + apply elem_of_cons. + by left. + + right. + apply IH, C. + } + by inversion K. + * apply IH. + by inversion K. + - intros x. + set (l := enum (S1 + S2)). + assert (inr x ∈ l) as K; [apply elem_of_enum |]. + clearbody l. + induction l as [| a l IH]; [inversion K |]. + destruct a as [a | a]; simpl. + + rewrite elem_of_cons in K. + destruct K as [K | K]; [inversion K |]. + by apply IH. + + rewrite elem_of_cons in K. + destruct K as [K | K]. + * inversion K; subst. + apply elem_of_cons; by left. + * apply elem_of_cons; right; by apply IH. + Qed. + +End Sum. + +Section Inc. + Context (S : Set). + + Global Instance EqDecisionIncN {HS : EqDecision S} (n : nat) : EqDecision (Init.Nat.iter n inc S). + Proof using S. + induction n; simpl. + - apply _. + - intros [|x] [|y]. + + by left. + + by right. + + by right. + + destruct (decide (x = y)) as [-> |]; [by left |]. + right; by inversion 1. + Qed. + + Global Instance EqDecisionInc {HS : EqDecision S} : EqDecision (inc S). + Proof using S. + assert (inc S = Init.Nat.iter 1 inc S) as ->; [done |]. + by apply EqDecisionIncN. + Qed. + + Global Instance FiniteIncN {HS : EqDecision S} (HF : Finite S) (n : nat) {HS' : EqDecision (Init.Nat.iter n inc S)} : Finite (Init.Nat.iter n inc S). + Proof using S. + induction n. + - apply (@surjective_finite S HS HF _ _ id). + apply _. + - simpl. + unshelve eapply (@surjective_finite (option (Init.Nat.iter n inc S))); simpl in *. + + intros [x |]. + * apply (VS x). + * apply VZ. + + apply _. + + intros [| x]; simpl. + * exists None; reflexivity. + * exists (Some x); reflexivity. + Qed. + + Global Instance FiniteInc {HS : EqDecision S} (HF : Finite S) (HE : EqDecision (inc S)) : Finite (inc S). + Proof using S. + assert (J : @Finite (Init.Nat.iter 1 inc S) HE). + { apply FiniteIncN, HF. } + simpl in J. + apply J. + Qed. + +End Inc. diff --git a/vendor/Binding/Auto.v b/vendor/Binding/Auto.v new file mode 100644 index 0000000..13347e3 --- /dev/null +++ b/vendor/Binding/Auto.v @@ -0,0 +1,251 @@ +Require Import Utf8. +Require Import Binding.Core. +Require Import Binding.Properties. +Require Import Binding.TermSimpl. + +Local Open Scope bind_scope. + +Ltac auto_map_id := + match goal with + | |- ?f ≡ ı → fmap ?f ?t = ?t => + let EQ := fresh "EQ" + in intros EQ; destruct t; term_simpl; + try ((progress f_equal; now eauto using @lift_id with typeclass_instances) + || (f_equal; now apply EQ)) + end. + +Ltac auto_map_comp := + match goal with + | |- ?f ∘ ?g ≡ ?h → fmap ?f (fmap ?g ?t) = fmap ?h ?t => + let EQ := fresh "EQ" + in intros EQ; destruct t; term_simpl; + try ((progress f_equal; now eauto using @lift_comp with typeclass_instances) + || (f_equal; now apply EQ)) + end. + +Ltac auto_map_bind_pure := + match goal with + | |- ?f ̂ ≡ ?g → fmap ?f ?t = bind ?g ?t => + let EQ := fresh "EQ" + in intros EQ; destruct t; term_simpl; + try ((progress f_equal; now eauto using @lift_of with typeclass_instances) + || now apply EQ) + end. + +Ltac auto_map_bind_comm := + match goal with + | |- ?g₂ ∘ ?f₂ ̂ ≡ ?f₁ ̂ ∘ ?g₁ → bind ?g₂ (fmap ?f₂ ?t) = fmap ?f₁ (bind ?g₁ ?t) => + let EQ := fresh "EQ" + in intros EQ; destruct t; term_simpl; + try ((progress f_equal; now eauto using @lift_comm with typeclass_instances) + || rewrite map_to_bind; now apply EQ) + end. + +Ltac auto_bind_id := + match goal with + | |- ?f ≡ ı → bind ?f ?t = ?t => + let EQ := fresh "EQ" + in intros EQ; destruct t; term_simpl; + try ((progress f_equal; now eauto using @lift_id with typeclass_instances) + || now apply EQ) + end. + +Ltac auto_bind_comp := + match goal with + | |- ?f ∘ ?g ≡ ?h → bind ?f (bind ?g ?t) = bind ?h ?t => + let EQ := fresh "EQ" + in intros EQ; destruct t; term_simpl; + try ((progress f_equal; now eauto using @lift_comp with typeclass_instances) + || now apply EQ) + end. + +(* + +Lemma ap_equal {A B : Type} (f g : A → B) (x y : A) : + f = g → x = y → f x = g y. +Proof. +destruct 1; destruct 1; reflexivity. +Qed. + +Local Ltac solve_equal := + reflexivity || (apply ap_equal; [ solve_equal | try reflexivity ]). + +Local Open Scope bind_scope. + +Local Ltac auto_map_id_arrow_eq Heq := + exact Heq || (apply Heq; fail) || + match goal with + | |- (?f ↑) ≡ ı => + apply lift_id; auto_map_id_arrow_eq Heq + | _ => idtac + end. + +Ltac auto_map_id := + let Heq := fresh "Heq" in + intro Heq; + match goal with + | |- ?map _ _ ?f ?t = ?t => + destruct t; term_simpl; solve_equal; try (apply Heq; fail); + match goal with + | [ IH: ∀ (A : ?Obj) f (t : ?F A), + f ≡ ı → ?map A A f t = t + |- ?map _ _ _ ?t = ?t + ] => apply IH; auto_map_id_arrow_eq Heq + | |- ?fmap _ _ _ ?map _ _ _ _ ?t = ?t => + apply map_id; auto_map_id_arrow_eq Heq + | |- ?map _ _ _ ?t = ?t => + apply map_id; auto_map_id_arrow_eq Heq + | _ => idtac + end + end. + +Local Ltac auto_map_map_comp_arrow_eq Heq := + exact Heq || (apply Heq; fail) || + match goal with + | |- ?f ↑ ∘ ?g ↑ ≡ ?h ↑ => + apply lift_comp; auto_map_map_comp_arrow_eq Heq + | _ => idtac + end. + +Ltac auto_map_map_comp := + let Heq := fresh "Heq" in + intro Heq; + match goal with + | |- ?map _ _ ?f (?map _ _ ?g ?t) = ?map _ _ ?h ?t => + destruct t; term_simpl; solve_equal; try (apply Heq; fail); + match goal with + | [ IH: ∀ (A B C : ?Obj) f g h (t : ?F A), + f ∘ g ≡ h → + ?map B C f (?map A B g t) = ?map A C h t + |- ?map _ _ _ (?map _ _ _ ?t) = ?map _ _ _ ?t + ] => apply IH; auto_map_map_comp_arrow_eq Heq + | |- fmap _ (fmap _ ?t) = fmap _ ?t => + apply map_map_comp; auto_map_map_comp_arrow_eq Heq + | |- ?map _ _ _ (?map _ _ _ ?t) = ?map _ _ _ ?t => + apply map_map_comp; auto_map_map_comp_arrow_eq Heq + | _ => idtac + end + end. + +Create HintDb auto_bind_map_comp. +(* +Local Ltac auto_bind_map_comp_subst_eq Heq := + exact Heq || (apply Heq; fail) || + match goal with + | |- subst_eq + (subst_comp (liftS ?f) (subst_of_arr (liftA ?g))) + (arrow_subst_comp (liftA ?g') (liftS ?f')) => + apply liftS_liftA_comp; auto_bind_map_comp_subst_eq Heq + | _ => idtac + end. + +Ltac auto_bind_map_comp := + let Heq := fresh "Heq" in + intro Heq; + match goal with + | |- ?bnd _ _ ?f (?map _ _ ?g ?t) = ?map _ _ ?g' (?bnd _ _ ?f' ?t) => + destruct t; + simpl; try (autorewrite with auto_bind_map_comp; simpl); + try (apply Heq; fail); + try (solve_equal; try (apply Heq; fail); + match goal with + | [ IH: ∀ (A B B' C : ?Obj) f g g' f' (t : ?F A), + subst_eq (subst_comp f (of_arrow g)) (arrow_subst_comp g' f') → + ?bnd _ _ f (?map _ _ g t) = ?map _ _ g' (?bnd _ _ f' t) + |- ?bnd _ _ _ (?map _ _ _ ?t) = ?map _ _ _ (?bnd _ _ _ ?t) + ] => apply IH; auto_bind_map_comp_subst_eq Heq + | |- bind _ (fmap _ ?t) = fmap _ (bind _ ?t) => + apply bind_map_comp; auto_bind_map_comp_subst_eq Heq + | |- ?bind _ _ _ (?fmap _ _ _ ?t) = ?fmap _ _ _ (?bind _ _ _ ?t) => + apply bind_map_comp; auto_bind_map_comp_subst_eq Heq + | _ => idtac + end) + end. +*) +Local Ltac auto_bind_pure_subst_eq Heq := + exact Heq || + match goal with + | |- _ ↑ ≡ ı => + apply lift_id; auto_bind_pure_subst_eq Heq + | _ => idtac + end. + +Local Ltac auto_bind_pure_loop Heq := + match goal with + | [ IH: ∀ (A : ?Obj) f (t : ?F A), + f ≡ ı → ?bnd A A f t = t + |- context[ ?bnd _ _ _ ?t ] + ] => + rewrite IH; [ auto_bind_pure_loop Heq | auto_bind_pure_subst_eq Heq ] + | |- context[ bind _ ?t ] => + rewrite bind_pure; + [ auto_bind_pure_loop Heq | auto_bind_pure_subst_eq Heq ] + | _ => idtac + end. + +Ltac auto_bind_pure := + let Heq := fresh "Heq" in + intro Heq; + match goal with + | |- ?bnd _ _ ?f ?t = ?t => + destruct t; term_simpl; + try (apply Heq; fail); + ((solve_equal; + match goal with + | [ IH: ∀ (A : ?Obj) f (t : ?F A), + f ≡ ı → ?bnd A A f t = t + |- ?bnd _ _ _ ?t = ?t + ] => apply IH; auto_bind_pure_subst_eq Heq + | |- bind _ ?t = ?t => + apply bind_pure; auto_bind_pure_subst_eq Heq + | |- ?bind _ _ _ ?t = ?t => + apply bind_pure; auto_bind_pure_subst_eq Heq + | _ => idtac + end) + || auto_bind_pure_loop Heq) + end. + +Create HintDb auto_bind_bind_comp. + +Local Ltac auto_bind_bind_comp_subst_eq Heq := + exact Heq || (apply Heq; fail) || + match goal with + | |- _ ↑ ∘ _ ↑ ≡ _ ↑ => + apply lift_comp; auto_bind_bind_comp_subst_eq Heq + | _ => idtac + end. + +Ltac auto_bind_bind_comp := + let Heq := fresh "Heq" in + intro Heq; + match goal with + | |- ?bnd _ _ ?f (?bnd _ _ ?g ?t) = ?bnd _ _ ?h ?t => + destruct t; + term_simpl; try (autorewrite with auto_bind_bind_comp; simpl); + try (apply Heq; fail); + try (solve_equal; try (apply Heq; fail); + match goal with + | [ IH: ∀ (A B C : ?Obj) f g h (t : ?F A), + f ∘ g ≡ h → + ?bnd B C f (?bnd A B g t) = ?bnd A C h t + |- ?bnd _ _ _ (?bnd _ _ _ ?t) = ?bnd _ _ _ ?t + ] => apply IH; auto_bind_bind_comp_subst_eq Heq + | |- bind _ (bind _ ?t) = bind _ ?t => + apply bind_bind_comp; auto_bind_bind_comp_subst_eq Heq + | |- ?bind _ _ _ (?bind _ _ _ ?t) = ?bind _ _ _ ?t => + apply bind_bind_comp; auto_bind_bind_comp_subst_eq Heq + | _ => idtac + end) + end. + +(* +Ltac auto_ASLiftable := + unfold ASLiftable; intros; simpl; + unfold bind, fmap; simpl; fold_fmap; + rewrite fmap_liftA_shift_comm; + apply f_equal; + try match goal with + | H: subst_eq ?f ?g |- _ => apply H + end. +*) +*) diff --git a/vendor/Binding/Core.v b/vendor/Binding/Core.v new file mode 100644 index 0000000..a2c966d --- /dev/null +++ b/vendor/Binding/Core.v @@ -0,0 +1,295 @@ +Require Import Utf8. +Require Import RelationClasses Morphisms. +Require Vector. + +Declare Scope bind_scope. +Delimit Scope bind_scope with bind. +Local Open Scope bind_scope. + +Section EqualityIndexedTypes. + Context {Obj : Type}. + + Class EqIndCore (T : Obj → Obj → Type) := + equal A B : T A B → T A B → Prop. + + Class EqInd (T : Obj → Obj → Type) {EIC : EqIndCore T} := + { eq_equiv A B :> Equivalence (equal A B) }. + +End EqualityIndexedTypes. + +Notation " f ≡ g " := (equal _ _ f%bind g%bind) (at level 70, no associativity) : bind_scope. + +(** * Arrows and maps *) +Section Arrows. + Context {Obj : Type}. + + (** ** Arrows *) + Class ArrowCore (Arr : Obj → Obj → Type) : Type := + { arrow_id A : Arr A A; + arrow_comp {A B C} : Arr B C → Arr A B → Arr A C + }. + + Definition arrow {Arr} {ArrEq : EqIndCore Arr} {AC : ArrowCore Arr} := Arr. + + Notation " 'ı' " := (arrow_id _) : bind_scope. + Notation " f ∘ g " := (arrow_comp f%bind g%bind) (at level 40, left associativity) : bind_scope. + + Class Arrow (Arr : Obj → Obj → Type) {ArrEq : EqIndCore Arr} {AC : ArrowCore Arr} : Prop := + { arrow_comp_id_l {A B} (f : Arr A B) : ı ∘ f ≡ f; + arrow_comp_id_r {A B} (f : Arr A B) : f ∘ ı ≡ f; + arrow_comp_assoc {A B C D} (f : Arr C D) (g : Arr B C) (h : Arr A B) : + f ∘ g ∘ h ≡ f ∘ (g ∘ h); + arrow_comp_proper + A B C :> Proper (equal B C ==> equal A B ==> equal A C) arrow_comp}. + + Context {Arr : Obj → Obj → Type} {ArrEq : EqIndCore Arr} {AC : ArrowCore Arr}. + + (** ** Maps *) + + Class FunctorCore (F : Obj → Type) := + fmap : ∀ {A B}, (Arr A B) → F A → F B. + + (*Definition fmap {F : Obj → Type} + {FunCore : FunctorCore F} {A B : Obj} + (f : Arr A B) : F A → F B := fmap_core _ _ f.*) + + Class Functor (F : Obj → Type) {FunCore : FunctorCore F} : Prop := + { map_id {A} (f : Arr A A) (t : F A) (EQ : f ≡ ı) : + fmap f t = t; + map_map_comp {A B C} (f : Arr B C) (g : Arr A B) h (t : F A) + (EQ : f ∘ g ≡ h) : + fmap f (fmap g t) = fmap h t}. + +End Arrows. + +(* Repeat notations due to section locality nonsense *) +Module ArrowNotations. + Notation " A '[→]' B " := (arrow A B) (at level 100, no associativity) : type_scope. +End ArrowNotations. + +Notation " 'ı' " := (arrow_id _) : bind_scope. +Notation " f ∘ g " := (arrow_comp f%bind g%bind) (at level 40, left associativity) : bind_scope. + +(** * Substitutions and binds *) +Section Substitutions. + Context {Obj : Type}. + + (** ** Substitutions *) + Class SubstCore (Arr : Obj → Obj → Type) (Sub : Obj → Obj → Type) : Type := + subst_of_arr : ∀ {A B}, Arr A B → Sub A B. + + Definition sub {Arr Sub} {ASC : SubstCore Arr Sub} := Sub. + Definition subarr {Arr Sub} {ASC : SubstCore Arr Sub} := Arr. + + (*Notation " 'η' " := (subst_pure _) : bind_scope. + Notation " σ • ρ " := (subst_comp σ%bind ρ%bind) (at level 40, left associativity) : bind_scope.*) + Notation " f '̂' " := (subst_of_arr f%bind) (at level 30) : bind_scope. + + Class Subst + (Arr : Obj → Obj → Type) {ArrEq : EqIndCore Arr} {AC : ArrowCore Arr} + (Sub : Obj → Obj → Type) {SubEq : EqIndCore Sub} {SC : ArrowCore Sub} + {ASC : SubstCore Arr Sub} : Prop := + { arrow_subst_id {A} : ı ̂ ≡ (ı : Sub A A); + arrow_subst_comp {A B C} (f : Arr B C) (g : Arr A B) : + (f ∘ g)̂ ≡ f ̂ ∘ g ̂; + arrow_subst_proper A B :> Proper (equal A B ==> equal A B) subst_of_arr}. + + (** ** Binding *) + + Context {Arr : Obj → Obj → Type} {EqArr : EqIndCore Arr} {AC : ArrowCore Arr}. + Context {Sub : Obj → Obj → Type} {EqSub : EqIndCore Sub} {SC : ArrowCore Sub}. + Context {ASC : SubstCore Arr Sub}. + + Class BindCore (F : Obj → Type) := + bind : ∀ {A B}, (Sub A B) → F A → F B. + + (*Definition bind {F : Obj → Type} + {BindF : BindCore F} {A B : Obj} + (f : Sub A B) : F A → F B := bind_core _ _ f.*) + + Class BindMapPure (F : Obj → Type) {MapF : FunctorCore F} {BindF : BindCore F} : Prop := + { bind_map {A B} (f : Arr A B) g t + (EQ : f ̂ ≡ g) : + fmap f t = bind g t + }. + + Class BindMapComm (F : Obj → Type) {MapF : FunctorCore F} {BindF : BindCore F} : Prop := + { bind_map_comm {A B₁ B₂ C} (f₁ : Arr B₁ C) (f₂ : Arr A B₂) (g₁ : Sub A B₁) g₂ t + (EQ : g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁) : + bind g₂ (fmap f₂ t) = fmap f₁ (bind g₁ t) + }. + + Class Bind (F : Obj → Type) {BindF : BindCore F} : Prop := + { bind_pure {A} (f : Sub A A) (t : F A) (EQ : f ≡ ı) : + bind f t = t; + bind_bind_comp {A B C} (f : Sub B C) (g : Sub A B) h (t : F A) + (EQ : f ∘ g ≡ h) : + bind f (bind g t) = bind h t + }. + +End Substitutions. + +Arguments arrow {Obj Arr ArrEq AC} /. +Arguments sub {Obj Arr Sub ASC } /. +Arguments subarr {Obj Arr Sub ASC } /. + +Module SubNotations. + Notation " A '[⇒]' B " := (sub A B) (at level 100, no associativity) : type_scope. + Notation " A '[→]' B " := (subarr A B) (at level 100, no associativity) : type_scope. +End SubNotations. +Notation " f '̂' " := (subst_of_arr f%bind) (at level 30) : bind_scope. + +(** * Lifting *) +Section Lifting. + Context {Obj : Type}. + + Class LiftableCore (Arr : Obj → Obj → Type) (G : Obj → Obj) := + lift : ∀ {A B}, Arr A B → Arr (G A) (G B). + + Notation " f ↑ " := (lift f%bind) (at level 30) : bind_scope. + + Fixpoint liftn {Arr G} {LC : LiftableCore Arr G} {A B : Obj} + n (f : Arr A B) : Arr (Nat.iter n G A) (Nat.iter n G B) := + match n with + | O => f + | S n => (liftn n f) ↑ + end. + + Class Liftable {Arr} {EqArr : EqIndCore Arr} {AC : ArrowCore Arr} + (G : Obj → Obj) {LC : LiftableCore Arr G} : Prop := + { lift_id {A} (f : Arr A A) (EQ : f ≡ ı) : f ↑ ≡ ı; + lift_comp {A B C} (f : Arr B C) (g : Arr A B) h (EQ : f ∘ g ≡ h) : + f ↑ ∘ g ↑ ≡ h ↑ ; + lift_proper A B :> Proper (equal A B ==> equal (G A) (G B)) lift + }. + + Context {Arr : Obj → Obj → Type} {EqArr : EqIndCore Arr} {AC : ArrowCore Arr}. + Context {Sub : Obj → Obj → Type} {EqSub : EqIndCore Sub} {SC : ArrowCore Sub}. + Context {ASC : SubstCore Arr Sub}. + + Class ASLiftInj (G : Obj → Obj) {ALC : LiftableCore Arr G} {SLC : LiftableCore Sub G} : Prop := + lift_of : ∀ {A B} (f : Arr A B) g (EQ : f ̂ ≡ g), f ↑ ̂ ≡ g ↑. + + Class ASLiftComm (G : Obj → Obj) + {ALC : LiftableCore Arr G} {SLC : LiftableCore Sub G} : Prop := + lift_comm : ∀ {A B₁ B₂ C} (f₁ : Arr B₁ C) (f₂ : Arr A B₂) (g₁ : Sub A B₁) (g₂ : Sub B₂ C) + (EQ : g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁), + g₂ ↑ ∘ f₂ ↑ ̂ ≡ f₁ ↑ ̂ ∘ g₁ ↑ . + +End Lifting. + +Arguments Liftable {Obj} Arr {EqArr AC} G {LC}. +Arguments ASLiftInj {Obj} Arr Sub {EqSub ASC} G {ALC SLC}. +Arguments ASLiftComm {Obj} Arr Sub {EqSub SC ASC} G {ALC SLC}. + +Notation " f ↑ " := (lift f%bind) (at level 30) : bind_scope. + +(** * Shifting *) +Section Shifting. + Context {Obj : Type}. + + Class ShiftableCore (Arr : Obj → Obj → Type) (Inc : Obj → Obj) : Type := + mk_shift : ∀ A : Obj, Arr A (Inc A). + + Global Arguments mk_shift {Arr Inc _ A}. + + Definition shift + {Arr : Obj → Obj → Type} + {F : Obj → Type} {MapF : FunctorCore F} + {Inc : Obj → Obj} {Sh : ShiftableCore Arr Inc} + {A : Obj} + (a : F A) : F (Inc A) := fmap mk_shift a. + + (*Fixpoint mk_shiftn + {Arr : Obj → Obj → Type} + {F : Obj → Type} {map} {MapF : FunctorCore (F:=F) (Arr:=Arr) map} + {Inc : Obj → Obj} {AC : ArrowCore Arr} {ALC : ALiftableCore Arr Inc} {Sh : ShiftableCore Arr Inc} + {A : Obj} n : Arr A (Nat.iter n Inc A) := + match n with + | O => ı + | S n' => (liftA (G := Inc) (mk_shiftn (Inc := Inc) n')) ∘ mk_shift + end. + + Definition shiftn {Arr : Obj → Obj → Type} + {F : Obj → Type} {map} {MapF : FunctorCore (F:=F) (Arr:=Arr) map} + {Inc : Obj → Obj} {AC : ArrowCore Arr} {ALC : ALiftableCore Arr Inc} {Sh : ShiftableCore Arr Inc} + n {A : Obj} (a : F A) := fmap (mk_shiftn n) a.*) + + Context (Arr : Obj → Obj → Type) {EqArr : EqIndCore Arr} {AC : ArrowCore Arr}. + Context (Sub : Obj → Obj → Type) {EqSub : EqIndCore Sub} {SC : ArrowCore Sub}. + Context {ASC : SubstCore Arr Sub}. + Context (Inc : Obj → Obj) {Sh : ShiftableCore Arr Inc}. + + Class LiftAShift {ALC : LiftableCore Arr Inc} : Prop := + liftA_mk_shift_comm : ∀ {A B : Obj} (f : Arr A B), + f ↑ ∘ mk_shift ≡ mk_shift ∘ f. + + Class LiftSShift {SLC : LiftableCore Sub Inc} : Prop := + liftS_mk_shift_comm : ∀ {A B : Obj} (f : Sub A B), + f ↑ ∘ mk_shift ̂ ≡ mk_shift ̂ ∘ f. + +End Shifting. + +Arguments liftA_mk_shift_comm {Obj Arr EqArr AC Inc Sh ALC _ A B} f. +Arguments liftS_mk_shift_comm {Obj Arr Sub EqSub SC ASC Inc Sh SLC _ A B} f. + +(** * Substituting *) +Section Substituting. + Context {Obj : Type}. + + Class SubstitutableCore + (Sub : Obj → Obj → Type) (F : Obj → Type) (Inc : Obj → Obj) : Type := + mk_subst : ∀ {A : Obj} (x : F A), Sub (Inc A) A. + + Definition subst + {Sub : Obj → Obj → Type} + {G : Obj → Type} {BindG : BindCore G} + {F : Obj → Type} {Inc : Obj → Obj} {Sb : SubstitutableCore Sub F Inc} + {A : Obj} + (a : G (Inc A)) (v : F A) : G A := bind (mk_subst v) a. + + (* + Fixpoint mk_substV + {Sub : Obj → Obj → Type} {Arr : Obj → Obj → Type} + {G : Obj → Type} {bnd} {BindG : BindCore (F:=G) (Sub:=Sub) bnd} + {F : Obj → Type} {Inc : Obj → Obj} {PSC : PreSubstCore Sub} {AC : ArrowCore Arr} + {SC : SubstCore Arr Sub} {SLC : SLiftableCore Sub Inc} {Sb : SubstitutableCore Sub F Inc} + {A : Obj} {n} (xs : Vector.t (F A) n) : Sub (Nat.iter n Inc A) A := + match xs with + | Vector.nil _ => η + | Vector.cons _ x _ xs => (mk_subst (Inc := Inc) x) • (mk_substV (Inc := Inc) xs) ⇑ + end. + + Definition substV + {Sub : Obj → Obj → Type} {Arr : Obj → Obj → Type} {AC : ArrowCore Arr} + {G : Obj → Type} {bnd} {BindG : BindCore (F:=G) (Sub:=Sub) bnd} + {F : Obj → Type} {Inc : Obj → Obj} {PSC : PreSubstCore Sub} {SC : SubstCore Arr Sub} + {SLC : SLiftableCore Sub Inc} {Sb : SubstitutableCore Sub F Inc} + {A : Obj} {n} (xs : Vector.t (F A) n) (a : G (Nat.iter n Inc A)) : G A := + bind (mk_substV xs) a. + *) + + Context (Arr : Obj → Obj → Type) {EqArr : EqIndCore Arr} {AC : ArrowCore Arr}. + Context (Sub : Obj → Obj → Type) {EqSub : EqIndCore Sub} {SC : ArrowCore Sub}. + Context {ASC : SubstCore Arr Sub}. + Context (F : Obj → Type) (Inc : Obj → Obj) {Sb : SubstitutableCore Sub F Inc}. + + Class SubstShift {Sh : ShiftableCore Arr Inc} : Prop := + subst_shift_pure : ∀ {A : Obj} (v : F A), + mk_subst v ∘ mk_shift ̂ ≡ ı. + + Class SubstFMap {MapF : FunctorCore F} + {ALC : LiftableCore Arr Inc} : Prop := + map_mk_subst_comm : ∀ {A B : Obj} (f : Arr A B) (v : F A), + f ̂ ∘ mk_subst v ≡ mk_subst (fmap f v) ∘ f ↑ ̂. + + Class SubstBind {BndF : BindCore F} + {SLC : LiftableCore Sub Inc} : Prop := + bind_mk_subst_comm : ∀ {A B : Obj} (f : Sub A B) (v : F A), + f ∘ mk_subst v ≡ mk_subst (bind f v) ∘ f ↑. + +End Substituting. + +Arguments subst_shift_pure {Obj Arr Sub EqSub SC ASC F Inc Sb Sh _ A} v. +Arguments map_mk_subst_comm {Obj Arr Sub EqSub SC ASC F Inc Sb MapF ALC _ A B} f v. +Arguments bind_mk_subst_comm {Obj Sub EqSub SC F Inc Sb BndF SLC _ A B} f v. diff --git a/vendor/Binding/Env.v b/vendor/Binding/Env.v new file mode 100644 index 0000000..bc5f17a --- /dev/null +++ b/vendor/Binding/Env.v @@ -0,0 +1,79 @@ +Require Import Utf8. +Require Import Binding.Lib. +Require Import SetoidClass Morphisms. + +Definition eq_ext {A B} (f g : A → B) := ∀ x, f x = g x. + +Lemma Equivalence_eq_ext {A B} : Equivalence (@eq_ext A B). +Proof. + split. + - intros Γ x; reflexivity. + - intros Γ₁ Γ₂ HEq x; symmetry; apply HEq. + - intros Γ₁ Γ₂ Γ₃ HEq₁ HEq₂ x; etransitivity; [apply HEq₁ | apply HEq₂]. +Qed. + +Global Instance Setoid_equiv {A B} : Setoid (A → B) := Build_Setoid Equivalence_eq_ext. + +Definition empty_env {A} : ∀ (x : ∅), A := λ x, match x with end. + +Definition extend {V : Set} {A} (Γ : V → A) (τ : A) : inc V → A := + λ x, match x with VZ => τ | VS x => Γ x end. + +Definition compose {A B C} (f : B → C) (g : A → B) (x : A) := f (g x). + +Notation "f • g" := (compose f g) (at level 40, left associativity). +Notation "f ▹ v" := (extend f v) (at level 40, v at next level, left associativity). +Notation "□" := empty_env. +Notation "x ≡ y" := (equiv x y) (at level 70, no associativity). + +Arguments compose {A B C} f g x /. + +Ltac destr_refl x := + match type of x with + | inc _ => destruct x as [| x]; [term_simpl; reflexivity | destr_refl x] + | _ => term_simpl + end. + +Ltac solve_simple_eq := + match goal with + | [ H: ?X ≡ ?Y |- ?X ?x = ?Y ?x ] => apply H + | [ |- ?f ?v1 = ?f ?v2 ] => f_equal; solve_simple_eq + | _ => now eauto + end. + +Ltac solve_equiv := + match goal with + | [|- ?X ≡ ?Y] => + let x := fresh "x" + in intros x; destr_refl x; solve_simple_eq + | _ => eassumption || reflexivity + end. + +Global Instance equiv_extend {A B : Set} : Proper (equiv ==> eq ==> equiv) (@extend A B). +Proof. + intros f g EQ v₁ v₂ EQv; subst; solve_equiv. +Qed. + +Global Instance equiv_compose {A B C : Set} : Proper (equiv ==> equiv ==> equiv) (@compose A B C). +Proof. + intros f₁ f₂ EQf g₁ g₂ EQg x; simpl; now rewrite EQf, EQg. +Qed. + +Require Import Binding.Set. +Import ArrowNotations. + +Lemma env_extend_equiv (V : Type) (A B : Set) (Δ₁ : A → V) Δ₂ (δ : B [→] A) (κ : V) + (HEq : Δ₂ ≡ Δ₁ • δ) : + Δ₂ ▹ κ ≡ (Δ₁ ▹ κ) • ( δ ↑ : inc B [→] inc A)%bind. +Proof. + solve_equiv. +Qed. + +Global Hint Extern 4 (_ ≡ _) => solve_equiv. + +Ltac simpl_HFInd := + subst; try discriminate; + repeat match goal with + | [ G : ?x = ?x → _ |- _ ] => specialize (G eq_refl) + | [ G : inc ?x = ?x → _ |- _ ] => clear G + end. diff --git a/vendor/Binding/Inc.v b/vendor/Binding/Inc.v new file mode 100644 index 0000000..508f545 --- /dev/null +++ b/vendor/Binding/Inc.v @@ -0,0 +1,38 @@ +Require Import Utf8. +Require Import Eqdep. +Require Import Eqdep_dec. + +Notation "∅" := Empty_set. + +Inductive inc (V : Set) : Set := +| VZ : inc V +| VS : V → inc V +. + +Arguments VZ {V}. +Arguments VS {V}. + +Definition inc_map {A B : Set} (f : A → B) (m : inc A) : inc B := + match m with + | VZ => VZ + | VS x => VS (f x) + end. + +Fixpoint nth_inc n {A : Set} : Nat.iter n inc (inc A) := + match n with + | O => VZ + | S n => VS (nth_inc n) + end. + +Notation "& n" := (nth_inc n) (at level 5). + +Module IncEqDec (T : DecidableSet) <: DecidableSet. + Definition U := inc T.U. + + Lemma eq_dec : ∀ x y:U, {x = y} + {x <> y}. + Proof. + intros [| x] [| y]; [left; reflexivity | right; inversion 1 | right; inversion 1 |]. + destruct (T.eq_dec x y) as [-> | H2]; [left; reflexivity | right]. + inversion 1; subst; contradiction. + Qed. +End IncEqDec. diff --git a/vendor/Binding/Intrinsic.v b/vendor/Binding/Intrinsic.v new file mode 100644 index 0000000..643eecd --- /dev/null +++ b/vendor/Binding/Intrinsic.v @@ -0,0 +1,232 @@ +Require Import Utf8. +Require Import Binding.Core. +Require Import Binding.Inc. +Require Import Binding.Properties. +Require Import Morphisms. + +Record Ctx {V : Type} := + {dom : Set; + arr :> dom -> V + }. +Arguments Ctx V : clear implicits. + +Definition mtC {V : Type} : Ctx V := + {| dom := Empty_set; + arr x := match x with end + |}. + +Definition extC {V : Type} (v : V) (Γ : Ctx V) : Ctx V := + {| dom := inc (dom Γ); + arr x := match x with + | VZ => v + | VS x => Γ x + end + |}. + +Notation "'ε'" := mtC. +Notation "Γ ▹ v" := (extC v Γ) (at level 40, left associativity). + +Class IntPureCore {V : Type} (F : V → Ctx V → Type) : Type := + int_pure : ∀ (Γ : Ctx V) v (x : dom Γ) (EQ : Γ x = v) , F v Γ. + +Arguments int_pure {V F _ Γ}. + +Record Arr {V : Type} {Γ Δ : Ctx V} : Type := + { apply_arr : dom Γ → dom Δ; + arr_hom : ∀ x : dom Γ, Δ (apply_arr x) = Γ x + }. +Arguments Arr {V} Γ Δ. +Notation " A '[→]' B " := (Arr A B) (at level 100, no associativity) : type_scope. +Coercion apply_arr : Arr >-> Funclass. + +Record Sub {V} {F : V → Ctx V → Type} {FP : IntPureCore F} (Γ Δ : Ctx V) : Type := + { apply_sub : ∀ v (x : dom Γ) (EQ : Γ x = v), F v Δ + }. +Notation " A '[⇒]' B " := (Sub A B) (at level 100, no associativity) : type_scope. + +Arguments apply_sub {V F FP Γ Δ}. +Coercion apply_sub : Sub >-> Funclass. + +Global Instance ArrEqC {V} : EqIndCore (Arr (V := V)) := + λ A B f g, ∀ x, f x = g x. + +Global Instance ArrEq {V} : EqInd (Arr (V := V)). +Proof. + split; intros; split; intros; congruence. +Qed. + +Global Instance SubEqC {V F} {FP : IntPureCore (V := V) F} : EqIndCore Sub := + λ A B f g, ∀ v x EQ, f v x EQ = g v x EQ. + +Global Instance SubEq {V F} {FP : IntPureCore (V := V) F} : EqInd Sub. +Proof. + split; split; intros; congruence. +Qed. + +Global Program Instance ArrowCore_Set {V} : ArrowCore (Arr (V := V)) := + { arrow_id := λ _, {| apply_arr := λ x, x |} + ; arrow_comp := λ _ _ _ f g, {| apply_arr := λ x, f (g x) |} + }. +Next Obligation. + etransitivity; apply arr_hom. +Defined. + +Class IntPure {V} (F : V → Ctx V → Type) {FP : IntPureCore (V := V) F} + {MapF : ∀ v, FunctorCore (F v)} + {BndF : ∀ v, BindCore (Sub := Sub) (F v)} : Prop := + { fmap_int_pure : ∀ (Γ Δ : Ctx V) (f : Arr Γ Δ) v (x : dom Γ) (EQ : Γ x = v), + fmap f (int_pure v x EQ) = int_pure v (f x) (eq_trans (arr_hom f x) EQ) + ; bind_set_pure : ∀ (Γ Δ : Ctx V) (f : Sub Γ Δ) v (x : dom Γ) (EQ : Γ x = v), + bind f (int_pure (IntPureCore := FP) v x EQ) = f v x EQ + }. + +Section IntInstances. + Context {V} {F : V → Ctx V → Type} {FP : IntPureCore F}. + Context {MapF : ∀ v, FunctorCore (Arr := Arr) (F v)}. + Context {BndF : ∀ v, BindCore (Sub := Sub) (F v)}. + Context {SPF : IntPure F}. + + Global Instance Arrow_Int : Arrow (Arr (V := V)). + Proof. + split; [unfold equal, ArrEqC; simpl; congruence .. |]. + intros A B C f₁ f₂ EQf g₁ g₂ EQg x; simpl; congruence. + Qed. + + Global Instance SubstArrCore_Set : ArrowCore (Sub (V := V)) := + { arrow_id A := {| apply_sub := int_pure |}; + arrow_comp A B C f g := {| apply_sub := λ v x EQ, bind f (g v x EQ) |} }. + + Global Instance SubstCore_Set : SubstCore Arr Sub := + λ Γ Δ f, {| apply_sub := λ v x EQ, int_pure v (f x) (eq_trans (arr_hom f x) EQ) |}. + + Program Definition extFun v (Γ Δ : Ctx V) (f : Arr Γ Δ) : Arr (Γ ▹ v) (Δ ▹ v) := + {| apply_arr := inc_map f |}. + Next Obligation. + destruct x as [| x]; simpl; [reflexivity | apply arr_hom]. + Defined. + + Context {MF : ∀ v, Functor (F v)} {BF : ∀ v, Bind (F v)}. + Context {BMPF : ∀ v, BindMapPure (F v)} {BMCF : ∀ v, BindMapComm (F v)}. + + Global Instance SubArrow_Set : Arrow Sub. + Proof. + split; simpl; intros. + - intros v x EQ; simpl; apply bind_pure; reflexivity. + - intros v x EQ; simpl; apply bind_set_pure. + - intros v x EQ; simpl; symmetry; apply bind_bind_comp; reflexivity. + - intros ρ₁ ρ₂ EQρ σ₁ σ₂ EQσ v x EQ; simpl; rewrite EQσ; clear EQσ. + etransitivity; [| apply bind_pure; reflexivity]. + symmetry; apply bind_bind_comp. + intros u y EQ'; rewrite EQρ; apply bind_pure; reflexivity. + Qed. + + Global Instance Subst_Set : Subst Arr Sub. + Proof. + split; intros. + - intros v x []; simpl; reflexivity. + - intros v x []; simpl; symmetry; unfold ArrowCore_Set_obligation_2. + generalize (g x) as y, (arr_hom g x). + intros y []; simpl; apply bind_set_pure. + - intros f g EQ v x EQ'; simpl. + rewrite <- !fmap_int_pure, EQ; reflexivity. + Qed. + + Global Instance ALiftableCore_ext {v : V} : LiftableCore Arr (extC v) := + { lift := extFun v }. + + Global Instance ALiftable_ext {v : V} : Liftable Arr (extC v). + Proof. + split; intros. + - intros [| x]; simpl; [reflexivity | f_equal; apply EQ]. + - intros [| x]; simpl; [reflexivity | f_equal; apply EQ]. + - intros f₁ f₂ EQf [| x]; simpl; [reflexivity | f_equal; apply EQf]. + Qed. + + Global Program Instance ShiftableCore_ext {v : V} : ShiftableCore Arr (extC v) := + λ A, {| apply_arr := VS : dom A → dom (A ▹ v) |}. + + Global Instance LiftAShift_ext {v : V} : LiftAShift Arr (extC v). + Proof. + unfold LiftAShift; intros Γ Δ f x; reflexivity. + Qed. + + Global Instance SLiftableCore_ext {v : V} : LiftableCore Sub (extC v) := + { lift Γ Δ ρ := + {| apply_sub := λ u (x : dom (Γ ▹ v)), + match x with + | VZ => λ EQ, int_pure u (VZ : dom (Δ ▹ v)) EQ + | VS y => λ EQ, shift (ρ u y EQ) + end + |} + }. + + Global Instance LiftSShift_ext {v : V} : LiftSShift Arr Sub (extC v). + Proof. + intros A B f u x []; simpl. + rewrite bind_set_pure. + apply map_to_bind. + Qed. + + Global Instance SLiftable_ext {v : V} : Liftable Sub (extC v). + Proof. + split; intros. + - intros u [| x] []; simpl; [reflexivity | unfold shift; simpl]. + rewrite EQ; simpl. + rewrite fmap_int_pure; simpl; reflexivity. + - intros u [| x] []; simpl; [now apply bind_set_pure |]. + rewrite bind_liftS_shift_comm, <- EQ; reflexivity. + - intros f₁ f₂ EQf u [| x] []; simpl; [reflexivity | now rewrite EQf]. + Qed. + + Global Instance ASLiftInj_ext {v : V} : ASLiftInj Arr Sub (extC v). + Proof. + intros A B f g EQ u [| x] []; simpl; [reflexivity |]. + rewrite <- EQ; simpl; symmetry. + generalize (f x) as y, (arr_hom f x); intros y []; simpl. + unfold shift; rewrite fmap_int_pure; reflexivity. + Qed. + + Global Instance ASLiftComm_ext {v : V} : ASLiftComm Arr Sub (extC v). + Proof. + intros A B₁ B₂ C f₁ f₂ g₁ g₂ EQ u [| x] []; simpl. + - etransitivity; [apply bind_set_pure |]. + rewrite bind_set_pure; reflexivity. + - unfold shift; erewrite <- map_to_bind, map_map_comp by apply liftA_mk_shift_comm. + rewrite <- map_map_comp'; specialize (EQ _ x eq_refl); simpl in EQ; rewrite <- map_to_bind in EQ. + rewrite <- EQ; clear EQ. + generalize (f₂ x) as y, (arr_hom f₂ x); intros y []; simpl. + rewrite !bind_set_pure; reflexivity. + Qed. + + Global Instance SubstitutableCore_ext {v : V} : SubstitutableCore Sub (F v) (extC v) := + λ A u, + {| apply_sub := λ w (x : dom (A ▹ v)), + match x with + | VZ => λ EQ, match EQ with eq_refl => u end + | VS y => int_pure w y + end + |}. + + Global Instance SubstShift_ext {v : V} : SubstShift Arr Sub (F v) (extC v). + Proof. + intros A u w x []; simpl. + apply bind_set_pure. + Qed. + + Global Instance SubstFMap_ext {v : V} : SubstFMap Arr Sub (F v) (extC v). + Proof. + intros A B f u w [ | x ] []; simpl. + - rewrite <- map_to_bind, bind_set_pure; simpl; reflexivity. + - rewrite !bind_set_pure; simpl; reflexivity. + Qed. + + Global Instance SubstBind_ext {v : V} : SubstBind Sub (F v) (extC v). + Proof. + intros A B f u w [| x] []; simpl. + - rewrite bind_set_pure; reflexivity. + - rewrite bind_set_pure; symmetry; apply subst_shift_id. + Qed. + +End IntInstances. + +Arguments int_pure {V F _ Γ v} /. diff --git a/vendor/Binding/LICENSE b/vendor/Binding/LICENSE new file mode 100644 index 0000000..ad3536c --- /dev/null +++ b/vendor/Binding/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2022,2023 Filip Sieczkowski, Piotr Polesiuk + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/vendor/Binding/Lib.v b/vendor/Binding/Lib.v new file mode 100644 index 0000000..6ed5b87 --- /dev/null +++ b/vendor/Binding/Lib.v @@ -0,0 +1,4 @@ +Require Export Binding.Core. +Require Export Binding.Inc. +Require Export Binding.Properties. +Require Export Binding.TermSimpl. diff --git a/vendor/Binding/Product.v b/vendor/Binding/Product.v new file mode 100644 index 0000000..706e45d --- /dev/null +++ b/vendor/Binding/Product.v @@ -0,0 +1,130 @@ +Require Import Utf8. +Require Import Binding.Lib. + +Record sprod (U₁ U₂ : Type) : Type := + { π₁ : U₁ + ; π₂ : U₂ + }. + +Arguments π₁ {U₁ U₂}. +Arguments π₂ {U₁ U₂}. + +Notation "U₁ × U₂" := (sprod U₁ U₂) (at level 40) : type_scope. +Notation "⟨ A , B ⟩" := {| π₁ := A ; π₂ := B |} : bind_scope. + +Section Defs. + Context {U₁ U₂ : Type} {Arr₁ : U₁ → U₁ → Type} {Arr₂ : U₂ → U₂ → Type} + {EA₁ : EqIndCore Arr₁} {EA₂ : EqIndCore Arr₂} {EqA₁ : EqInd Arr₁} {EqA₂ : EqInd Arr₂} + {AC₁ : ArrowCore Arr₁} {AC₂ : ArrowCore Arr₂} {AR₁ : Arrow Arr₁} {AR₂ : Arrow Arr₂}. + + Local Open Scope bind_scope. + Import ArrowNotations. + + Record prod_arr {X Y : U₁ × U₂} : Type := + { arr₁ : Arr₁ (π₁ X) (π₁ Y); + arr₂ : Arr₂ (π₂ X) (π₂ Y) + }. + Global Arguments prod_arr X Y : clear implicits. + + Notation " f × g " := {| arr₁ := f ; arr₂ := g |} (at level 40) : bind_scope. + + Global Instance EIC_prod : EqIndCore prod_arr := + λ A B f g, arr₁ f ≡ arr₁ g ∧ arr₂ f ≡ arr₂ g. + + Global Instance ArrowCore_vsig_arr : ArrowCore prod_arr := + {| arrow_id A := ı × ı; + arrow_comp A B C f g := (arr₁ f ∘ arr₁ g) × (arr₂ f ∘ arr₂ g) |}. + + Global Instance Eq_prod : EqInd prod_arr. + Proof. + split; split; intros. + - split; reflexivity. + - split; symmetry; apply H. + - split; etransitivity; now (apply H || apply H0). + Qed. + + Global Instance Arrow_prod_arr : Arrow prod_arr. + Proof. + split; intros. + - split; apply arrow_comp_id_l. + - split; apply arrow_comp_id_r. + - split; apply arrow_comp_assoc. + - split; eapply arrow_comp_proper; now (apply H0 || apply H). + Qed. + + Definition at₁ {A B : U₁} {C : U₂} (f : A [→] B) : ⟨A, C⟩ [→] ⟨B, C⟩ := + (f : π₁ ⟨A, C⟩ [→] π₁ ⟨B, C⟩) × ı. + Definition at₂ {A : U₁} {B C : U₂} (f : B [→] C) : ⟨A, B⟩ [→] ⟨A, C⟩ := + ı × (f : π₂ ⟨A, B⟩ [→] π₂ ⟨A, C⟩). + + Section ALift. + Context (F₁ : U₁ → U₁) (F₂ : U₂ → U₂) {ALC₁ : LiftableCore Arr₁ F₁} + {ALC₂ : LiftableCore Arr₂ F₂} {AL₁ : Liftable Arr₁ F₁} {AL₂ : Liftable Arr₂ F₂}. + + Definition on₁ (X : U₁ × U₂) := ⟨ F₁ (π₁ X), π₂ X ⟩. + Definition on₂ (X : U₁ × U₂) := ⟨ π₁ X, F₂ (π₂ X) ⟩. + + Global Instance ALC_prod_left : LiftableCore prod_arr on₁ := + { lift A B f := (arr₁ f) ↑ × (arr₂ f : π₂ (on₁ A) [→] π₂ (on₁ B))}. + + Global Instance AL_prod_left : Liftable prod_arr on₁. + Proof. + split; intros. + - split; simpl; [apply lift_id |]; apply EQ. + - split; simpl; [apply lift_comp |]; apply EQ. + - split; simpl; [apply lift_proper |]; apply H. + Qed. + + Global Instance ALC_prod_right : LiftableCore prod_arr on₂ := + { lift A B f := (arr₁ f : π₁ (on₂ A) [→] π₁ (on₂ B)) × (arr₂ f) ↑}. + + Global Instance AL_prod_right : Liftable prod_arr on₂. + Proof. + split; intros. + - split; simpl; [| apply lift_id]; apply EQ. + - split; simpl; [| apply lift_comp]; apply EQ. + - split; simpl; [| apply lift_proper]; apply H. + Qed. + + End ALift. + + Section Shift. + Context (Inc₁ : U₁ → U₁) (Inc₂ : U₂ → U₂) + {SC₁ : ShiftableCore Arr₁ Inc₁} {SC₂ : ShiftableCore Arr₂ Inc₂}. + + Global Instance SC_prod_left : ShiftableCore prod_arr (on₁ Inc₁) := + { mk_shift := λ A, mk_shift × ı }. + + Global Instance SC_prod_right : ShiftableCore prod_arr (on₂ Inc₂) := + { mk_shift := λ A, ı × mk_shift }. + + End Shift. + + Section LiftA_Shift. + Context (F₁ : U₁ → U₁) (F₂ : U₂ → U₂) + {ALC₁ : LiftableCore Arr₁ F₁} {ALC₂ : LiftableCore Arr₂ F₂} + {AL₁ : Liftable Arr₁ F₁} {AL₂ : Liftable Arr₂ F₂} + {SC₁ : ShiftableCore Arr₁ F₁} {SC₂ : ShiftableCore Arr₂ F₂} + {LAS₁ : LiftAShift Arr₁ F₁} {LAS₂ : LiftAShift Arr₂ F₂}. + + Global Instance LiftAShift_prod_left : LiftAShift prod_arr (on₁ F₁). + Proof. + intros A B f; split; simpl. + - apply LAS₁. + - etransitivity; [ apply arrow_comp_id_r | ]. + symmetry; apply arrow_comp_id_l. + Qed. + + + Global Instance LiftAShift_prod_right : LiftAShift prod_arr (on₂ F₂). + Proof. + intros A B f; split; simpl. + - etransitivity; [ apply arrow_comp_id_r | ]. + symmetry; apply arrow_comp_id_l. + - apply LAS₂. + Qed. + End LiftA_Shift. + +End Defs. + +Notation " f × g " := {| arr₁ := f ; arr₂ := g |} (at level 40) : bind_scope. diff --git a/vendor/Binding/Properties.v b/vendor/Binding/Properties.v new file mode 100644 index 0000000..7c82dc1 --- /dev/null +++ b/vendor/Binding/Properties.v @@ -0,0 +1,197 @@ +Require Import Utf8. +Require Import Binding.Core. +Require Vector. +Require Import Morphisms. + +Section Properties. + Context {Obj : Type}. + Context {Arr : Obj → Obj → Type} {EqArr : EqIndCore Arr} {AC : ArrowCore Arr}. + Context {ArrEq : EqInd Arr} {AA : Arrow Arr}. + Context {Sub : Obj → Obj → Type} {EqSub : EqIndCore Sub} {SC : ArrowCore Sub}. + Context {ASC : SubstCore Arr Sub} {SubEq : EqInd Sub} {AS : Arrow Sub} {SS : Subst Arr Sub}. + Context {F G : Obj → Type}. + Context {Inc : Obj → Obj}. + Context {Sh : ShiftableCore Arr Inc}. + Context {ALC : LiftableCore Arr Inc}. + Context {SLC : LiftableCore Sub Inc}. + Context {Sb : SubstitutableCore Sub F Inc}. + Context {LAS : LiftAShift Arr Inc}. + Context {LSS : LiftSShift Arr Sub Inc}. + Context {MapF : FunctorCore (Arr := Arr) F}. + Context {MapG : FunctorCore (Arr := Arr) G} + {MG : Functor G}. + Context {BindF : BindCore (Sub := Sub) F}. + Context {BindG : BindCore (Sub := Sub) G} + {BMPG : BindMapPure G} {BMCG : BindMapComm G} {BG : Bind G}. + Context {SbShF : SubstShift Arr Sub F Inc}. + Context {SbMapF : SubstFMap Arr Sub F Inc}. + Context {SbBndF : SubstBind Sub F Inc}. + Context {AL : Liftable Arr Inc}. + Context {SL : Liftable Sub Inc}. + Context {ASLI : ASLiftInj Arr Sub Inc} {ASLC : ASLiftComm Arr Sub Inc}. + + + Local Open Scope bind_scope. + + Lemma map_id' {A : Obj} (t : G A) : + fmap ı t = t. + Proof. + apply map_id; reflexivity. + Qed. + + Lemma map_map_comp' {A B C : Obj} (f : Arr B C) (g : Arr A B) (t : G A) : + fmap f (fmap g t) = fmap (f ∘ g) t. + Proof. + apply map_map_comp; reflexivity. + Qed. + + Global Instance fmap_proper A B : Proper (equal A B ==> eq ==> eq) fmap. + Proof. + intros f g EQ t t' EQ'; subst t'. + erewrite <- map_id', map_map_comp; [reflexivity |]. + rewrite arrow_comp_id_l, EQ; reflexivity. + Qed. + + Lemma bind_pure' {A : Obj} (t : G A) : + bind ı t = t. + Proof. + apply bind_pure; reflexivity. + Qed. + + Lemma bind_bind_comp' {A B C : Obj} (f : Sub B C) (g : Sub A B) (t : G A) : + bind f (bind g t) = bind (f ∘ g) t. + Proof. + apply bind_bind_comp; reflexivity. + Qed. + + Global Instance bind_proper A B : Proper (equal A B ==> eq ==> eq) bind. + Proof. + intros f g EQ t t' EQ'; subst t'. + erewrite <- bind_pure', bind_bind_comp; [reflexivity |]. + now rewrite EQ, arrow_comp_id_l. + Qed. + + Lemma map_to_bind {A B : Obj} (f : Arr A B) (t : G A) : + fmap f t = bind (f ̂) t. + Proof. + now apply bind_map. + Qed. + + Lemma fmap_liftA_shift_comm {A B : Obj} (f : Arr A B) (t : G A) : + fmap (f ↑) (shift t) = shift (fmap f t). + Proof. + unfold shift; now rewrite !map_map_comp', liftA_mk_shift_comm. + Qed. + + Lemma bind_liftS_shift_comm {A B : Obj} (f : Sub A B) (a : G A) : + bind (f ↑) (shift a) = shift (bind f a). + Proof. + unfold shift; apply bind_map_comm, liftS_mk_shift_comm. + Qed. + + Lemma bind_map_id {A B : Obj} (g : Sub B A) (f : Arr A B) (a : G A) + (EQ : g ∘ f ̂ ≡ ı) : + bind g (fmap f a) = a. + Proof. + rewrite bind_map_comm with (f₁ := ı) (g₁ := ı), map_id', bind_pure'; [reflexivity |]. + now rewrite EQ, arrow_comp_id_r, arrow_subst_id. + Qed. + + Lemma subst_shift_id {A : Obj} (t : G A) (v : F A): + subst (shift t) v = t. + Proof. + unfold shift, subst; apply bind_map_id, subst_shift_pure. + Qed. + + Lemma lift_of_arrow {A B : Obj} (δ : Arr A B) : + δ ↑ ̂ ≡ δ ̂ ↑. + Proof. + now apply lift_of. + Qed. + + Lemma subst_shift_id_lifted {A : Obj} (t : G (Inc A)) (v : F A) : + bind (mk_subst v ↑) (fmap (mk_shift ↑) t) = t. + Proof. + apply bind_map_id; rewrite lift_of_arrow, lift_comp by reflexivity. + apply lift_id, subst_shift_pure. + Qed. + + Lemma subst_shift_id_lifted2 {A : Obj} (t : G (Inc (Inc A))) (v : F A) : + bind ((mk_subst v) ↑ ↑) (fmap (mk_shift ↑ ↑) t) = t. + Proof. + apply bind_map_id; rewrite lift_of_arrow, lift_comp by reflexivity. + apply lift_id; rewrite lift_of_arrow, lift_comp by reflexivity. + apply lift_id, subst_shift_pure. + Qed. + + Lemma fmap_subst {A B : Obj} (f : Arr A B) (t : G (Inc A)) (v : F A) : + fmap f (subst t v) = subst (fmap (f ↑) t) (fmap f v). + Proof. + unfold subst; symmetry; erewrite bind_map_comm; [reflexivity |]. + symmetry; apply map_mk_subst_comm. + Qed. + + Lemma shift_subst {Inc' : Obj → Obj} {Sh' : ShiftableCore Arr Inc'} + {A : Obj} (t : G (Inc A)) (v : F A) : + shift (subst t v) = subst (fmap (mk_shift ↑) t) (shift v). + Proof. + apply fmap_subst. + Qed. + + Lemma bind_subst {A B : Obj} (f : Sub A B) (t : G (Inc A)) (v : F A) : + bind f (subst t v) = subst (bind (f ↑) t) (bind f v). + Proof. + unfold subst; now rewrite !bind_bind_comp', bind_mk_subst_comm. + Qed. + + (* + Lemma shiftn_map {A B : Obj} n (δ : Arr A B) : + mk_shiftn n ∘ δ ≡ₐ liftAn n δ ∘ mk_shiftn n. + Proof. + induction n; simpl; [now rewrite arrow_comp_id_l, arrow_comp_id_r |]. + rewrite arrow_comp_assoc, <- liftA_mk_shift_comm, <- arrow_comp_assoc, liftA_comp; [| apply IHn]. + erewrite <- liftA_comp, arrow_comp_assoc; reflexivity. + Qed. + + Lemma shiftn_bind {A B : Obj} n (ρ : Sub A B) : + mk_shiftn n ̂ • ρ ≡ₛ liftSn n ρ • mk_shiftn n ̂. + Proof. + induction n; simpl. + - now rewrite !arrow_subst_id, subst_comp_pure_r, subst_comp_pure_l. + - rewrite !arrow_subst_comp, subst_comp_assoc, <- liftS_mk_shift_comm, <- !subst_comp_assoc. + rewrite <- !lift_of_arrow, liftS_comp; [| eassumption]. + rewrite liftS_comp; reflexivity. + Qed. + + Lemma substV_map {A B : Obj} n (xs : Vector.t (F A) n) (δ : Arr A B) : + mk_substV (Vector.map (fmap δ) xs) • liftAn n δ ̂ ≡ₛ δ ̂ • mk_substV xs. + Proof. + induction xs; simpl; [now rewrite subst_comp_pure_l, subst_comp_pure_r |]. + rewrite subst_comp_assoc, <- lift_of_arrow, liftS_comp by apply IHxs. + erewrite <- liftS_comp by reflexivity; rewrite lift_of_arrow, <- subst_comp_assoc. + now rewrite <- map_mk_subst_comm, subst_comp_assoc. + Qed. + + Lemma substV_bind {A B : Obj} n (xs : Vector.t (F A) n) (ρ : Sub A B) : + mk_substV (Vector.map (bind ρ) xs) • liftSn n ρ ≡ₛ ρ • mk_substV xs. + Proof. + induction xs; simpl; [now rewrite subst_comp_pure_l, subst_comp_pure_r |]. + rewrite <- subst_comp_assoc, bind_mk_subst_comm, !subst_comp_assoc. + rewrite liftS_comp by apply IHxs. + now rewrite liftS_comp by reflexivity. + Qed. + + Lemma substV_shiftn_id {A : Obj} {n} (xs : Vector.t (F A) n) (t : G A) : + substV xs (shiftn n t) = t. + Proof. + unfold substV, shiftn; rewrite map_to_bind, bind_bind_comp', bind_pure; [reflexivity | clear t]. + induction xs; simpl. + - now rewrite subst_comp_pure_l, arrow_subst_id. + - rewrite arrow_subst_comp, <- lift_of_arrow, <- subst_comp_assoc. + rewrite subst_comp_assoc with (f := mk_subst h), liftS_comp by apply IHxs. + rewrite liftS_pure, subst_comp_pure_r by reflexivity. + apply subst_shift_pure. + Qed. + *) + +End Properties. diff --git a/vendor/Binding/Resolver.v b/vendor/Binding/Resolver.v new file mode 100644 index 0000000..8811e1c --- /dev/null +++ b/vendor/Binding/Resolver.v @@ -0,0 +1,37 @@ +Require Import Binding.Set Binding.Inc. +Require Import Init.Nat. + +(* only fin_S_inv is really needed *) +Require Import stdpp.fin. + +Section ResolutionDeBruijn. + Class Resolver (D : Set) (n : nat) := { resolve : fin n -> D }. + + Global Instance ResolverEmpty : Resolver Empty_set 0. + Proof. + constructor. + apply fin_0_inv. + Defined. + + Global Instance ResolverInc {D : Set} (n : nat) `{Resolver D n} : Resolver (inc D) (S n). + Proof. + constructor. + apply fin_S_inv. + - apply VZ. + - intros x; apply VS, resolve, x. + Defined. + + Global Instance ResolverIncNEmpty {n : nat} : Resolver (iter n inc Empty_set) n. + Proof. + induction n; apply _. + Defined. + +End ResolutionDeBruijn. + +Section SetPureResolver. + Context {F : Set → Type} + {SPC : SetPureCore F}. + + Definition set_pure_resolver {D} {n} `{Resolver D n} (fn : fin n) : F D := (@set_pure _ _ D (resolve fn)). + +End SetPureResolver. diff --git a/vendor/Binding/Set.v b/vendor/Binding/Set.v new file mode 100644 index 0000000..ff35dd8 --- /dev/null +++ b/vendor/Binding/Set.v @@ -0,0 +1,204 @@ +Require Import Utf8. +Require Import Binding.Core. +Require Import Binding.Inc. +Require Import Binding.Properties. +Require Import Morphisms. + +Class SetPureCore (F : Set → Type) : Type := + set_pure : ∀ A : Set, A → F A. + +Arguments set_pure {F _ A}. + +Record Arr (A B : Set) : Type := + { apply_arr : A → B + }. +Notation " A '[→]' B " := (Arr A B) (at level 100, no associativity) : type_scope. + +Arguments apply_arr {A B}. +Coercion apply_arr : Arr >-> Funclass. + +Record Sub {F : Set → Type} {FP : SetPureCore F} (A B : Set) : Type := + { apply_sub : A → F B + }. +Notation " A '[⇒]' B " := (Sub A B) (at level 100, no associativity) : type_scope. + +Arguments apply_sub {F FP A B}. +Coercion apply_sub : Sub >-> Funclass. + +Global Instance ArrEqC : EqIndCore Arr := + λ A B f g, ∀ x, f x = g x. + +Global Instance ArrEq : EqInd Arr. +Proof. + split; intros; split; intros; congruence. +Qed. + +Global Instance SubEqC {F} {FP : SetPureCore F} : EqIndCore Sub := + λ A B f g, ∀ x, f x = g x. + +Global Instance SubEq {F} {FP : SetPureCore F} : EqInd Sub. +Proof. + split; split; intros; congruence. +Qed. + +Global Instance ArrowCore_Set : ArrowCore Arr := + { arrow_id := λ _, {| apply_arr := λ x, x |} + ; arrow_comp := λ _ _ _ f g, {| apply_arr := λ x, f (g x) |} + }. + +Class SetPure (F : Set → Type) {FP : SetPureCore F} + {MapF : FunctorCore F} + {BndF : BindCore F} : Prop := + { fmap_set_pure : ∀ (A B : Set) (f : Arr A B) (x : A), + fmap f (set_pure x) = set_pure (f x) + ; bind_set_pure : ∀ (A B : Set) (f : Sub A B) (x : A), + bind f (set_pure x) = f x + }. + +Section SetInstances. + Context {F : Set → Type} {FP : SetPureCore F}. + Context {MapF : FunctorCore (Arr := Arr) F}. + Context {BndF : BindCore (Sub := Sub) F}. + Context {SPF : SetPure F}. + + Global Instance Arrow_Set : Arrow Arr. + Proof. + split; [unfold equal, ArrEqC; simpl; congruence .. |]. + intros A B C f₁ f₂ EQf g₁ g₂ EQg x; simpl; congruence. + Qed. + + Global Instance SubstArrCore_Set : ArrowCore Sub := + { arrow_id A := {| apply_sub := set_pure |}; + arrow_comp A B C f g := {| apply_sub := λ x, bind f (g x) |} }. + + Global Instance SubstCore_Set : SubstCore Arr Sub := + λ A B f, {| apply_sub := λ x, set_pure (f x) |}. + + Definition incFun (A B : Set) (f : Arr A B) : inc A → inc B := inc_map f. + + Global Instance IncMap : FunctorCore inc := incFun. + Global Instance IncFun : Functor inc. + Proof. + split; intros. + - destruct t as [| x]; unfold fmap; simpl; f_equal; apply EQ. + - destruct t as [| x]; unfold fmap; simpl; f_equal; apply EQ. + Qed. + + Context {MF : Functor F} {BF : Bind F}. + Context {BMPF : BindMapPure F} {BMCF : BindMapComm F}. + + Global Instance SubArrow_Set : Arrow Sub. + Proof. + split; simpl; intros. + - intros x; simpl; apply bind_pure; reflexivity. + - intros x; simpl; apply bind_set_pure. + - intros x; simpl; symmetry; apply bind_bind_comp; reflexivity. + - intros ρ₁ ρ₂ EQρ σ₁ σ₂ EQσ x; simpl; rewrite EQσ; clear EQσ. + etransitivity; [| apply bind_pure; reflexivity]. + symmetry; apply bind_bind_comp. + intros y; rewrite EQρ; apply bind_pure; reflexivity. + Qed. + + Global Instance Subst_Set : Subst Arr Sub. + Proof. + split; intros. + - reflexivity. + - intros x; simpl; symmetry; apply bind_set_pure. + - intros f g EQ x; simpl; congruence. + Qed. + + Global Instance ALiftableCore_inc : LiftableCore Arr inc := + { lift A B f := {| apply_arr := fmap f |} }. + + Global Instance ALiftable_inc : Liftable Arr inc. + Proof. + split; intros. + - intros x; simpl; apply map_id, EQ. + - intros x; simpl; apply map_map_comp, EQ. + - intros f₁ f₂ EQf x; simpl; now rewrite EQf. + Qed. + + Global Instance ShiftableCore_inc : ShiftableCore Arr inc := + λ A, {| apply_arr := VS |}. + + Global Instance LiftAShift_inc : LiftAShift Arr inc. + Proof. + unfold LiftAShift; reflexivity. + Qed. + + Global Instance SLiftableCore_inc : LiftableCore Sub inc := + { lift A B f := + {| apply_sub := λ x, + match x with + | VZ => set_pure VZ + | VS y => shift (f y) + end + |} + }. + + Global Instance LiftSShift_inc : LiftSShift Arr Sub inc. + Proof. + intros A B f x; simpl. + rewrite bind_set_pure; simpl. + unfold shift; simpl; rewrite map_to_bind; reflexivity. + Qed. + + Global Instance SLiftable_inc : Liftable Sub inc. + Proof. + split; intros. + - intros [| x]; simpl; [reflexivity | unfold shift; simpl]. + rewrite EQ; apply fmap_set_pure. + - intros [| x]; simpl; [now apply bind_set_pure |]. + rewrite bind_liftS_shift_comm, <- EQ; reflexivity. + - intros f₁ f₂ EQf [| x]; simpl; [reflexivity | now rewrite EQf]. + Qed. + + Global Instance ASLiftInj_inc : ASLiftInj Arr Sub inc. + Proof. + intros A B f g EQ [| x]; simpl; [reflexivity |]. + rewrite <- EQ; simpl; symmetry; apply fmap_set_pure. + Qed. + + Global Instance ASLiftComm_inc : ASLiftComm Arr Sub inc. + Proof. + intros A B₁ B₂ C f₁ f₂ g₁ g₂ EQ [| x]; simpl. + - rewrite !bind_set_pure; simpl; reflexivity. + - rewrite bind_set_pure; simpl. + unfold shift; erewrite <- map_to_bind, map_map_comp by apply liftA_mk_shift_comm. + rewrite <- map_map_comp'; f_equal. + specialize (EQ x); simpl in EQ. + now rewrite bind_set_pure, <- map_to_bind in EQ. + Qed. + + Global Instance SubstitutableCore_inc : SubstitutableCore Sub F inc := + λ A v, + {| apply_sub := λ x, + match x with + | VZ => v + | VS y => set_pure y + end + |}. + + Global Instance SubstShift_inc : SubstShift Arr Sub F inc. + Proof. + intros A v x; simpl. + rewrite bind_set_pure; reflexivity. + Qed. + + Global Instance SubstFMap_inc : SubstFMap Arr Sub F inc. + Proof. + intros A B f v [ | x ]; simpl. + - rewrite bind_set_pure; simpl; rewrite <- map_to_bind; reflexivity. + - rewrite !bind_set_pure; reflexivity. + Qed. + + Global Instance SubstBind_inc : SubstBind Sub F inc. + Proof. + intros A B f v [| x]; simpl. + - rewrite bind_set_pure; reflexivity. + - rewrite bind_set_pure; symmetry; apply subst_shift_id. + Qed. + +End SetInstances. + +Arguments set_pure {F _ A} /. diff --git a/vendor/Binding/TermSimpl.v b/vendor/Binding/TermSimpl.v new file mode 100644 index 0000000..ca1a5f8 --- /dev/null +++ b/vendor/Binding/TermSimpl.v @@ -0,0 +1,206 @@ +Require Import Utf8. +Require Import Binding.Core. +Require Import Binding.Properties. + +Create HintDb term_simpl. +Create HintDb term_simpl_raw. + +Ltac fold_fmap_goal := + repeat match goal with + | |- context[ ?map ?A ?B ?f ?t ] => + match map with + | @fmap ?Obj ?Arr ?F ?m => fail 1 + | _ => + match type of map with + | ∀ A B : ?Obj, ?Arr A B → ?F A → ?F B => + change (map A B f t) with (fmap f t) || + change (map A B f t) with (fmap (Obj := Obj) (F := F) f t) + | FunctorCore _ => + change (map A B f t) with (fmap (FunctorCore := map) f t) + end + end + end. + +Ltac fold_fmap_in H := + repeat match type of H with + | context[ ?map ?A ?B ?f ?t ] => + match map with + | @fmap ?Obj ?Arr ?F ?m => fail 1 + | _ => + match type of map with + | ∀ A B : ?Obj, ?Arr A B → ?F A → ?F B => + change (map A B f t) with (fmap f t) in H || + change (map A B f t) with (fmap (Obj := Obj) (F := F) f t) in H + | FunctorCore _ => + change (map A B f t) with (fmap (FunctorCore := map) f t) in H + end + end + end. + +Tactic Notation "fold_fmap" := fold_fmap_goal. +Tactic Notation "fold_fmap" "in" hyp(H) := fold_fmap_in H. + +Ltac fold_bind_goal := + repeat match goal with + | |- context[ ?bnd ?A ?B ?f ?t ] => + match bnd with + | @bind ?Obj ?Sub ?F ?b => fail 1 + | _ => + match type of bnd with + | ∀ A B : ?Obj, _ → ?F A → ?F B => + change (bnd A B f t) with (bind f t) || + change (bnd A B f t) with (bind (Obj := Obj) (F := F) f t) + | BindCore _ => + change (bnd A B f t) with (bind (BindCore := bnd) f t) + end + end + end. + +Ltac fold_bind_in H := + repeat match type of H with + | context[ ?bnd ?A ?B ?f ?t ] => + match bnd with + | @bind ?Obj ?Sub ?F ?b => fail 1 + | _ => + match type of bnd with + | ∀ A B : ?Obj, _ → ?F A → ?F B => + change (bnd A B f t) with (bind f t) in H || + change (bnd A B f t) with (bind (Obj := Obj) (F := F) f t) in H + | BindCore _ => + change (bnd A B f t) with (bind (BindCore := bnd) f t) in H + end + end + end. + +Tactic Notation "fold_bind" := fold_bind_goal. +Tactic Notation "fold_bind" "in" hyp(H) := fold_bind_in H. + +Ltac fold_fmap_and_bind_goal := + repeat match goal with + | |- context[ ?ff ?A ?B ?f ?t ] => + match ff with + | @fmap ?Obj ?Arr ?F ?m => fail 1 + | @bind ?Obj ?Sub ?F ?m => fail 1 + | _ => + match type of ff with + | ∀ A B : ?Obj, _ → ?F A → ?F B => + change (ff A B f t) with (fmap f t) || + change (ff A B f t) with (fmap (Obj := Obj) (F := F) f t) || + change (ff A B f t) with (bind f t) || + change (ff A B f t) with (bind (Obj := Obj) (F := F) f t) + | FunctorCore _ => + change (ff A B f t) with (fmap (FunctorCore := ff) f t) + | BindCore _ => + change (ff A B f t) with (bind (BindCore := ff) f t) + end + end + end. + +Ltac fold_fmap_and_bind_in H := + repeat match type of H with + | context[ ?ff ?A ?B ?f ?t ] => + match ff with + | @fmap ?Obj ?Arr ?F ?m => fail 1 + | @bind ?Obj ?Sub ?F ?m => fail 1 + | _ => + match type of ff with + | ∀ A B : ?Obj, _ → ?F A → ?F B => + change (ff A B f t) with (fmap f t) in H || + change (ff A B f t) with (fmap (Obj := Obj) (F := F) f t) in H || + change (ff A B f t) with (bind f t) in H || + change (ff A B f t) with (bind (Obj := Obj) (F := F) f t) in H + | FunctorCore _ => + change (ff A B f t) with (fmap (FunctorCore := ff) f t) in H + | BindCore _ => + change (ff A B f t) with (bind (BindCore := ff) f t) in H + end + end + end. + +Tactic Notation "fold_fmap_and_bind" := fold_fmap_and_bind_goal. +Tactic Notation "fold_fmap_and_bind" "in" hyp(H) := fold_fmap_and_bind_in H. + +Ltac fold_shift_goal := + repeat match goal with + | |- context[ @fmap ?Obj ?Arr ?G ?MF ?A _ + (@mk_shift ?Obj _ ?Inc ?Sh ?A) + ?t + ] => + change (@fmap Obj Arr G MF A _ (@mk_shift Obj _ Inc Sh A) t) + with (@shift Obj Arr G MF Inc Sh A t) + end. + +Ltac fold_shift_in H := + repeat match type of H with + | context[ @fmap ?Obj ?Arr ?G ?MF ?A _ + (@mk_shift ?Obj _ ?Inc ?Sh ?A) + ?t + ] => + change (@fmap Obj Arr G MF A _ (@mk_shift Obj _ Inc Sh A) t) + with (@shift Obj Arr G MF Inc Sh A t) in H + end. + +Tactic Notation "fold_shift" := fold_shift_goal. +Tactic Notation "fold_shift" "in" hyp(H) := fold_shift_in H. + +Ltac fold_subst_goal := + repeat match goal with + | |- context[ @bind ?Obj ?Sub ?G ?BF _ ?A + (@mk_subst ?Obj _ ?F ?Inc ?Sb ?A ?v) + ?t + ] => + change (@bind Obj Sub G BF _ A (@mk_subst Obj _ F Inc Sb A v) t) + with (@subst Obj Sub G BF F Inc Sb A t v) + end. + +Ltac fold_subst_in H := + repeat match type of H with + | context[ @bind ?Obj ?Sub ?G ?BF _ ?A + (@mk_subst ?Obj _ ?F ?Inc ?Sb ?A ?v) + ?t + ] => + change (@bind Obj Sub G BF _ A (@mk_subst Obj _ F Inc Sb A v) t) + with (@subst Obj Sub G BF F Inc Sb A t v) in H + end. + +Tactic Notation "fold_subst" := fold_subst_goal. +Tactic Notation "fold_subst" "in" hyp(H) := fold_subst_in H. + +Ltac term_simpl_goal := + repeat ( + unfold subst, shift, bind, fmap; simpl; + repeat (autorewrite with term_simpl_raw; simpl); + fold_fmap_and_bind; fold_shift; fold_subst; + repeat match goal with + | |- context[ fmap ?f (subst ?t ?v) ] => rewrite (fmap_subst f t v) + | |- context[ fmap (lift (G:=?Inc) ?f) (shift (Inc:=?Inc) ?t) ] => + rewrite (fmap_liftA_shift_comm f t) + | |- context[ bind ?f (subst ?t ?v) ] => rewrite (bind_subst f t v) + | |- context[ bind (lift (G:=?Inc) ?f) (shift (Inc:=?Inc) ?t) ] => + rewrite (bind_liftS_shift_comm f t) + | |- context[ subst (Inc:=?Inc) (shift (Inc:=?Inc) ?t) ?v ] => + rewrite (subst_shift_id t v) + end; + try autorewrite with term_simpl + ). + +Ltac term_simpl_in H := + repeat ( + unfold subst, shift, bind, fmap in H; simpl in H; + repeat (autorewrite with term_simpl_raw in H; simpl in H); + fold_fmap_and_bind in H; fold_shift in H; fold_subst in H; + repeat match type of H with + | context[ fmap ?f (subst ?t ?v) ] => rewrite (fmap_subst f t v) in H + | context[ fmap (lift (G:=?Inc) ?f) (shift (Inc:=?Inc) ?t) ] => + rewrite (fmap_liftA_shift_comm f t) in H + | context[ bind ?f (subst ?t ?v) ] => rewrite (bind_subst f t v) in H + | context[ bind (lift (G:=?Inc) ?f) (shift (Inc:=?Inc) ?t) ] => + rewrite (bind_liftS_shift_comm f t) in H + | context[ subst (Inc:=?Inc) (shift (Inc:=?Inc) ?t) ?v ] => + rewrite (subst_shift_id t v) in H + end; + try autorewrite with term_simpl in H + ). + +Tactic Notation "term_simpl" := term_simpl_goal. +Tactic Notation "term_simpl" "in" hyp(H) := term_simpl_in H.