diff --git a/.gitignore b/.gitignore index d6f3606a..9f1b379c 100644 --- a/.gitignore +++ b/.gitignore @@ -34,5 +34,6 @@ tests/extraction/*.ml tests/extraction/*.mli examples/io.ml examples/io.mli +examples/extracted/ *.native diff --git a/Makefile b/Makefile index efe41bd1..dc98653f 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,4 @@ -.PHONY: clean all coq test tests examples install uninstall depgraph \ - example-imp example-lc example-io example-nimp +.PHONY: clean all coq test tests examples install uninstall depgraph COQPATHFILE=$(wildcard _CoqPath) @@ -17,41 +16,20 @@ uninstall: Makefile.coq test: examples tests tests: - make -C tests + $(MAKE) -C tests -examples: example-imp example-lc example-io example-nimp example-threads - -example-imp: examples/Imp.v - coqc -Q theories/ ITree examples/Imp.v - -example-lc: examples/stlc.v - coqc -Q theories/ ITree examples/stlc.v - -example-lc: examples/stlc.v - coqc -Q theories/ ITree examples/Nimp.v - -example-io: examples/IO.v - cd examples && \ - coqc -Q ../theories/ ITree IO.v && \ - ocamlbuild io.native && ./io.native - -THREADSV=examples/MultiThreadedPrinting.v examples/ExtractThreadsExample.v -THREADSML=examples/runthread.ml -example-threads: $(THREADSV) $(THREADSML) - coqc -Q theories/ ITree -Q examples/ Examples $(THREADSV) && \ - cd examples && \ - ocamlbuild -I extracted runthread.native && \ - ./runthread.native +examples: + $(MAKE) -C examples Makefile.coq: _CoqProject coq_makefile -f $< -o $@ clean: Makefile.coq $(MAKE) -f Makefile.coq clean - $(RM) {*,*/*}/*.{vo,glob} {*,*/*}/.*.aux + $(MAKE) -C tests clean + $(MAKE) -C examples clean + $(RM) theories/{*,*/*}/*.{vo,glob} theories/{*,*/*}/.*.aux $(RM) _CoqProject Makefile.coq* - $(RM) examples/extracted/*.* - cd examples && ocamlbuild -clean _CoqProject: $(COQPATHFILE) _CoqConfig Makefile @ echo "# Generating _CoqProject" diff --git a/_CoqConfig b/_CoqConfig index 7f760de9..76004698 100644 --- a/_CoqConfig +++ b/_CoqConfig @@ -1,10 +1,15 @@ -Q theories ITree theories/Basics.v +theories/Basics_Functions.v theories/Core.v +theories/Eq/Shallow.v theories/Eq/Eq.v theories/Eq/UpToTaus.v +theories/Eq/UpToTausExplicit.v +theories/Eq/Untaus.v +theories/Eq/SimUpToTaus.v theories/Effect/Sum.v theories/Effect/Std.v @@ -16,9 +21,13 @@ theories/OpenSum.v theories/Fix.v theories/FixFacts.v +theories/Translate.v +theories/TranslateFacts.v theories/Morphisms.v theories/MorphismsFacts.v +theories/KTree.v + theories/UpTo.v theories/Trace.v theories/MFixITree.v diff --git a/examples/Asm.v b/examples/Asm.v index f284f0b5..87c6a62c 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -1,129 +1,158 @@ -Require Import Coq.Strings.String. +From Coq Require Import + Strings.String + Program.Basics + ZArith.ZArith. +From ITree Require Import Basics_Functions. +From ExtLib Require Structures.Monad. +Require Import Imp. + +Typeclasses eauto := 5. + +Section Syntax. + + Definition var : Set := string. + Definition value : Set := nat. + + (** ** Syntax *) + + Variant operand : Set := + | Oimm (_ : value) + | Ovar (_ : var). + + Variant instr : Set := + | Imov (dest : var) (src : operand) + | Iadd (dest : var) (src : var) (o : operand) + | Iload (dest : var) (addr : operand) + | Istore (addr : var) (val : operand). + + Variant branch {label : Type} : Type := + | Bjmp (_ : label) (* jump to label *) + | Bbrz (_ : var) (yes no : label) (* conditional jump *) + | Bhalt + . + Global Arguments branch _ : clear implicits. + + (** A block is a sequence of straightline instructions followed + by a branch. *) + Inductive block {label : Type} : Type := + | bbi (_ : instr) (_ : block) + | bbb (_ : branch label). + Global Arguments block _ : clear implicits. + + (** Collection of blocks labeled by [A], with branches in [B]. *) + Definition bks A B := A -> block B. + + (** Blocks with visible unlinked labels [A] and [B] and internal + linked labels, allowing blocks to explicitly jump to each other. + - [A]: entry points + - [B]: exit points + - [internal]: linked and hidden labels + *) + Record asm A B : Type := + { + internal : Type; + code : bks (internal + A) (internal + B) + }. + + Global Arguments internal {A B}. + Global Arguments code {A B}. + +End Syntax. + +Arguments internal {A B}. +Arguments code {A B}. -Definition var : Set := string. -Definition value : Set := nat. (* this should change *) - -(* start with the syntax *) - -Variant operand : Set := -| Oimm (_ : value) -| Ovar (_ : var). +From ITree Require Import + ITree OpenSum KTree. -Variant instr : Set := -| Imov (dest : var) (src : operand) -| Iadd (dest : var) (src : var) (o : operand) -| Iload (dest : var) (addr : operand) -| Istore (addr : var) (val : operand). +Section Semantics. -Variant branch {label : Type} : Type := -| Bjmp (_ : label) (* jump to label *) -| Bbrz (_ : var) (yes no : label) (* conditional jump *) -| Bhalt -. -Arguments branch _ : clear implicits. + (* Denotation in terms of itrees *) -Inductive block {label : Type} : Type := -| bbi (_ : instr) (_ : block) -| bbb (_ : branch label). -Arguments block _ : clear implicits. + Import ExtLib.Structures.Monad. + Import MonadNotation. + Local Open Scope monad_scope. -Record program : Type := -{ label : Type -; blocks : label -> block label -; main : label -}. + Import Imp. + Inductive Memory : Type -> Type := + | Load (addr : value) : Memory value + | Store (addr val : value) : Memory unit. -(* now define a semantics *) + Inductive Exit : Type -> Type := + | Done : Exit Empty_set. -From ITree Require Import - ITree OpenSum Fix. - -Require Import ExtLib.Structures.Monad. -Import MonadNotation. -Local Open Scope monad_scope. - -(* the "effect" to track local variables *) -Inductive Locals : Type -> Type := -| GetVar (x : var) : Locals value -| SetVar (x : var) (v : value) : Locals unit. - -Inductive Memory : Type -> Type := -| Load (addr : value) : Memory value -| Store (addr val : value) : Memory unit. - -Section with_effect. - Variable e : Type -> Type. - Context {HasLocals : Locals -< e}. - Context {HasMemory : Memory -< e}. - - Definition denote_operand (o : operand) : itree e value := - match o with - | Oimm v => Ret v - | Ovar v => lift (GetVar v) - end. + Definition done {E A} `{Exit -< E} : itree E A := + Vis (subeffect _ Done) (fun v => match v : Empty_set with end). - Definition denote_instr (i : instr) : itree e unit := - match i with - | Imov d s => - v <- denote_operand s ;; - lift (SetVar d v) - | Iadd d l r => - lv <- lift (GetVar l) ;; - rv <- denote_operand r ;; - lift (SetVar d (lv + rv)) - | Iload d a => - addr <- denote_operand a ;; - val <- lift (Load addr) ;; - lift (SetVar d val) - | Istore a v => - addr <- lift (GetVar a) ;; - val <- denote_operand v ;; - lift (Store addr val) - end. + (* Denotation of blocks *) + Section with_effect. + Context {E : Type -> Type}. + Context {HasLocals : Locals -< E}. + Context {HasMemory : Memory -< E}. + Context {HasExit : Exit -< E}. - Section with_labels. - Context {label : Type}. - - Definition denote_branch (b : branch label) - : itree e (option label) := - match b with - | Bjmp l => ret (Some l) - | Bbrz v y n => - val <- lift (GetVar v) ;; - if val : value then ret (Some y) else ret (Some n) - | Bhalt => ret None + Definition denote_operand (o : operand) : itree E value := + match o with + | Oimm v => Ret v + | Ovar v => lift (GetVar v) end. - Fixpoint denote_block (b : block label) - : itree e (option label) := - match b with - | bbi i b => - denote_instr i ;; - denote_block b - | bbb b => - denote_branch b + Definition denote_instr (i : instr) : itree E unit := + match i with + | Imov d s => + v <- denote_operand s ;; + lift (SetVar d v) + | Iadd d l r => + lv <- lift (GetVar l) ;; + rv <- denote_operand r ;; + lift (SetVar d (lv + rv)) + | Iload d a => + addr <- denote_operand a ;; + val <- lift (Load addr) ;; + lift (SetVar d val) + | Istore a v => + addr <- lift (GetVar a) ;; + val <- denote_operand v ;; + lift (Store addr val) end. - End with_labels. -End with_effect. -Definition denote_program {e} `{Locals -< e} `{Memory -< e} - (p : program) : itree e unit := - rec (fun lbl : p.(label) => - next <- denote_block (_ +' e) (p.(blocks) lbl) ;; - match next with - | None => ret tt - | Some next => lift (Call next) - end) - p.(main). + Section with_labels. + Context {A B : Type}. -(* SAZ: Everything from here down can probably be polished. + Definition denote_branch (b : branch B) : itree E B := + match b with + | Bjmp l => ret l + | Bbrz v y n => + val <- lift (GetVar v) ;; + if val : value then ret y else ret n + | Bhalt => done + end. - In particular, I'm still not completely happy with how all the different parts - fit together in run. + Fixpoint denote_block (b : block B) : itree E B := + match b with + | bbi i b => + denote_instr i ;; denote_block b + | bbb b => + denote_branch b + end. - *) + Definition denote_b : bks A B -> ktree E A B := + fun bs a => denote_block (bs a). + End with_labels. + + (* A denotation of an asm program can be viewed as a circuit/diagram + where wires correspond to jumps/program links. + + It is therefore denoted as a [den] term *) + + (* Denotation of [asm] *) + Definition denote_asm {A B} : asm A B -> ktree E A B := + fun s => loop (denote_b (code s)). + + End with_effect. +End Semantics. (* Interpretation ----------------------------------------------------------- *) @@ -163,13 +192,3 @@ Instance RelDec_string : RelDec (@eq string) := Instance RelDec_value : RelDec (@eq value) := { rel_dec := Nat.eqb }. -(* SAZ: Is this the nicest way to present this? *) -Definition run (p: program) : itree emptyE _ := - let p1 := interp1 interpret_Memory _ (denote_program p) in - let p2 := interp1 interpret_Locals _ p1 in - let p3 := run_env _ p2 empty in - let p4 := run_env _ p3 empty in - p4. - -(* SAZ: Note: we should be able to prove that run produces trees that are equivalent - to run' where run' interprets memory and locals in a different order *) diff --git a/examples/AsmCombinators.v b/examples/AsmCombinators.v new file mode 100644 index 00000000..c4626502 --- /dev/null +++ b/examples/AsmCombinators.v @@ -0,0 +1,413 @@ +(** * Composition of [asm] programs *) + +Require Import Asm. + +From Coq Require Import + List + Strings.String + Program.Basics. +Import ListNotations. +From ITree Require Import Basics_Functions. +Require Import ZArith. + +Typeclasses eauto := 5. + +(** ** Internal structures *) + +Definition fmap_branch {A B : Type} (f: A -> B): branch A -> branch B := + fun b => + match b with + | Bjmp a => Bjmp (f a) + | Bbrz c a a' => Bbrz c (f a) (f a') + | Bhalt => Bhalt + end. + +Definition fmap_block {A B: Type} (f: A -> B): block A -> block B := + fix fmap b := + match b with + | bbb a => bbb (fmap_branch f a) + | bbi i b => bbi i (fmap b) + end. + +Definition relabel_bks {A B C D : Type} (f : A -> B) (g : C -> D) + (b : bks B C) : bks A D := + fun a => fmap_block g (b (f a)). + +Section after. +Context {A : Type}. +Fixpoint after (is : list instr) (bch : branch A) : block A := + match is with + | nil => bbb bch + | i :: is => bbi i (after is bch) + end. +End after. + +(** ** Low-level interface with [asm] *) + +(** Any collection of blocks forms an [asm] program with + no hidden blocks. *) +Definition raw_asm {A B} (b : bks A B) : asm A B := + {| internal := Empty_set; + code := fun a' => + match a' with + | inl v => match v : Empty_set with end + | inr a => fmap_block inr (b a) + end; + |}. + +(** Wrap a single block as [asm]. *) +Definition raw_asm_block {A} (b : block A) : asm unit A := + raw_asm (fun _ => b). + +(** ** [asm] combinators *) + +(** An [asm] program made only of external jumps. This is + useful to connect programs with [app_asm]. *) +Definition pure_asm {A B} (f : A -> B) : asm A B := + raw_asm (fun a => bbb (Bjmp (f a))). + +Definition id_asm {A} : asm A A := pure_asm id. + +(* Internal relabeling functions for [app_asm] *) +Definition _app_B {I J B D} : + block (I + B) -> block ((I + J) + (B + D)) := + fmap_block (fun l => + match l with + | inl i => inl (inl i) + | inr b => inr (inl b) + end). + +Definition _app_D {I J B D} : + block (J + D) -> block ((I + J) + (B + D)) := + fmap_block (fun l => + match l with + | inl j => inl (inr j) + | inr d => inr (inr d) + end). + +(** Append two asm programs, preserving their internal links. *) +Definition app_asm {A B C D} (ab : asm A B) (cd : asm C D) : + asm (A + C) (B + D) := + {| internal := ab.(internal) + cd.(internal); + code := fun l => + match l with + | inl (inl ia) => _app_B (ab.(code) (inl ia)) + | inl (inr ic) => _app_D (cd.(code) (inl ic)) + | inr (inl a) => _app_B (ab.(code) (inr a)) + | inr (inr c) => _app_D (cd.(code) (inr c)) + end; + |}. + +(** Rename visible program labels. *) +Definition relabel_asm {A B C D} (f : A -> B) (g : C -> D) + (bc : asm B C) : asm A D := + {| code := relabel_bks (sum_bimap id f) (sum_bimap id g) bc.(code); + |}. + +(** Link labels from two programs together. *) +Definition link_asm {I A B} (ab : asm (I + A) (I + B)) : asm A B := + {| internal := ab.(internal) + I; + code := relabel_bks sum_assoc_r sum_assoc_l ab.(code); + |}. + +(** ** Correctness *) +(** The combinators above map to their denotational counterparts. *) + +From ExtLib Require Import + Structures.Monad. +Import MonadNotation. +From ITree Require Import + ITree KTree. +Require Import Imp. + +Section Correctness. + +Context {E : Type -> Type}. +Context {HasLocals : Locals -< E}. +Context {HasMemory : Memory -< E}. +Context {HasExit : Exit -< E}. + +(** *** Internal structures *) + +Lemma fmap_block_map: + forall {L L'} b (f: L -> L'), + denote_block (fmap_block f b) ≅ ITree.map f (denote_block b). +Proof. + induction b as [i b | br]; intros f. + - simpl. + unfold ITree.map; rewrite bind_bind. + eapply eq_itree_eq_bind; [reflexivity | intros []; apply IHb]. + - simpl. + destruct br; simpl. + + unfold ITree.map; rewrite ret_bind; reflexivity. + + unfold ITree.map; rewrite bind_bind. + eapply eq_itree_eq_bind; [reflexivity | intros []; rewrite ret_bind; reflexivity]. + + rewrite (itree_eta (ITree.map _ _)). + cbn. apply eq_itree_vis. intros []. +Qed. + +Definition traverse_ {A: Type} {M: Type -> Type} `{Monad M} (f: A -> M unit): list A -> M unit := + fix traverse__ l: M unit := + match l with + | [] => ret tt + | a::l => (f a;; traverse__ l)%monad + end. + +Definition denote_list: list instr -> itree E unit := + traverse_ denote_instr. + +Lemma after_correct : + forall {label: Type} instrs (b: branch label), + denote_block (after instrs b) ≅ (denote_list instrs ;; denote_branch b). +Proof. + induction instrs as [| i instrs IH]; intros b. + - simpl; rewrite ret_bind; reflexivity. + - simpl; rewrite bind_bind. + eapply eq_itree_eq_bind; [reflexivity | intros []; apply IH]. +Qed. + +Lemma denote_list_app: + forall is1 is2, + @denote_list (is1 ++ is2) ≅ + (@denote_list is1;; denote_list is2). +Proof. + intros is1 is2; induction is1 as [| i is1 IH]; simpl; intros; [rewrite ret_bind; reflexivity |]. + rewrite bind_bind; setoid_rewrite IH; reflexivity. +Qed. + +(* TO MOVE *) +Lemma map_ret {X Y: Type}: + forall (f: X -> Y) x, + @ITree.map E _ _ f (Ret x) ≅ Ret (f x). +Proof. + intros. + unfold ITree.map. + rewrite ret_bind; reflexivity. +Qed. + +Lemma raw_asm_block_correct_lifted {A} (b : block A) : + denote_asm (raw_asm_block b) ⩯ + (fun _ => denote_block b). +Proof. + unfold denote_asm. + rewrite vanishing_ktree. + rewrite elim_l_ktree', elim_l_ktree. + unfold denote_b; simpl. + intros []. + rewrite fmap_block_map, map_map. + unfold ITree.map. + rewrite <- (bind_ret (denote_block b)) at 2. + reflexivity. +Qed. + +Lemma raw_asm_block_correct {A} (b : block A) : + eutt eq (denote_asm (raw_asm_block b) tt) + (denote_block b). +Proof. + apply raw_asm_block_correct_lifted. +Qed. + +(** *** [asm] combinators *) + +Theorem pure_asm_correct {A B} (f : A -> B) : + denote_asm (pure_asm f) + ⩯ @lift_ktree E _ _ f. +Proof. + unfold denote_asm . + rewrite vanishing_ktree. + rewrite elim_l_ktree', elim_l_ktree. + unfold denote_b; simpl. + intros ?. + rewrite map_ret. + reflexivity. +Qed. + +Definition id_asm_correct {A} : + denote_asm (pure_asm id) + ⩯ @id_ktree E A. +Proof. + rewrite pure_asm_correct; reflexivity. +Defined. + +Lemma tensor_ktree_slide_right {A B C D}: + forall (ac: ktree E A C) (bd: ktree E B D), + ac ⊗ bd ⩯ id_ktree ⊗ bd >=> ac ⊗ id_ktree. +Proof. + intros. + unfold tensor_ktree. + repeat rewrite id_ktree_left. + rewrite sum_elim_compose. + rewrite compose_ktree_assoc. + rewrite inl_sum_elim, inr_sum_elim. + reflexivity. +Qed. + +Lemma local_rewrite1 {A B C: Type}: + id_ktree ⊗ sym_ktree >=> assoc_ktree_l >=> sym_ktree ⩯ + @assoc_ktree_l E A B C >=> sym_ktree ⊗ id_ktree >=> assoc_ktree_r. +Proof. + unfold id_ktree, tensor_ktree,sym_ktree, assoc_ktree_l, ITree.cat, assoc_ktree_r, lift_ktree. + intros [| []]; simpl; + repeat (rewrite bind_bind; simpl) || (rewrite ret_bind_; simpl); reflexivity. +Qed. + +Lemma local_rewrite2 {A B C: Type}: + sym_ktree >=> assoc_ktree_r >=> id_ktree ⊗ sym_ktree ⩯ + @assoc_ktree_l E A B C >=> sym_ktree ⊗ id_ktree >=> assoc_ktree_r. +Proof. + unfold id_ktree, tensor_ktree,sym_ktree, assoc_ktree_l, ITree.cat, assoc_ktree_r, lift_ktree. + intros [| []]; simpl; + repeat (rewrite bind_bind; simpl) || (rewrite ret_bind_; simpl); reflexivity. +Qed. + +Lemma loop_tensor_ktree {I A B C D} + (ab : ktree E A B) (cd : ktree E (I + C) (I + D)) : + ab ⊗ loop cd ⩯ + loop (assoc_ktree_l >=> sym_ktree ⊗ id_ktree >=> assoc_ktree_r + >=> ab ⊗ cd + >=> assoc_ktree_l >=> sym_ktree ⊗ id_ktree >=> assoc_ktree_r). +Proof. + rewrite tensor_swap, tensor_ktree_loop. + rewrite <- compose_loop. + rewrite <- loop_compose. + rewrite (tensor_swap cd ab). + repeat rewrite <- compose_ktree_assoc. + rewrite local_rewrite1. + do 2 rewrite compose_ktree_assoc. + rewrite <- (compose_ktree_assoc sym_ktree assoc_ktree_r _). + rewrite local_rewrite2. + repeat rewrite <- compose_ktree_assoc. + reflexivity. +Qed. + +Lemma foo {A B C: Type}: + forall (f: bks A C) (g: bks B C), + denote_b (fun a => match a with + | inl x => f x + | inr x => g x + end) ⩯ + fun a => match a with + | inl x => denote_block (f x) + | inr x => denote_block (g x) + end. +Proof. + intros. + unfold denote_b; intros []; reflexivity. +Qed. + +Lemma bar {A B C: Type}: + forall (f: bks A C) (g: bks B C) a, + denote_block match a with + | inl x => f x + | inr x => g x + end ≈ + match a with + | inl x => denote_block (f x) + | inr x => denote_block (g x) + end. +Proof. + intros. + destruct a; reflexivity. +Qed. + +Lemma foo_assoc_l {A B C D D'} (f : ktree E _ D') : + @id_ktree E A ⊗ @assoc_ktree_l E B C D >=> (assoc_ktree_l >=> f) + ⩯ assoc_ktree_l >=> (assoc_ktree_l >=> (assoc_ktree_r ⊗ id_ktree >=> f)). +Proof. + rewrite <- !compose_ktree_assoc. + rewrite <- assoc_coherent_l. + rewrite (compose_ktree_assoc _ _ (_ ⊗ id_ktree)). + rewrite cat_tensor, id_ktree_left, assoc_lr, tensor_id. + rewrite id_ktree_right. + reflexivity. +Qed. + +Lemma foo_assoc_r {A' A B C D} (f : ktree E A' _) : + f >=> assoc_ktree_r >=> @id_ktree E A ⊗ @assoc_ktree_r E B C D + ⩯ f >=> assoc_ktree_l ⊗ id_ktree >=> assoc_ktree_r >=> assoc_ktree_r. +Proof. + rewrite (compose_ktree_assoc _ _ assoc_ktree_r). + rewrite <- assoc_coherent_r. + rewrite (compose_ktree_assoc (tensor_ktree _ _)). + rewrite (compose_ktree_assoc _ (tensor_ktree _ _)). + rewrite <- (compose_ktree_assoc (tensor_ktree _ _)). + rewrite cat_tensor, id_ktree_left, assoc_lr, tensor_id. + rewrite id_ktree_left. + rewrite compose_ktree_assoc. + reflexivity. +Qed. + +Definition app_asm_correct {A B C D} (ab : asm A B) (cd : asm C D) : + @eq_ktree E _ _ + (denote_asm (app_asm ab cd)) + (tensor_ktree (denote_asm ab) (denote_asm cd)). +Proof. + unfold denote_asm. + + match goal with | |- ?x ⩯ _ => set (lhs := x) end. + rewrite tensor_ktree_loop. + rewrite loop_tensor_ktree. + rewrite <- compose_loop. + rewrite <- loop_compose. + rewrite loop_loop. + subst lhs. + rewrite <- (loop_rename_internal' sym_ktree sym_ktree) + by apply sym_nilpotent. + apply eq_ktree_loop. + rewrite ! compose_ktree_assoc. + unfold tensor_ktree, sym_ktree, ITree.cat, assoc_ktree_l, assoc_ktree_r, id_ktree, lift_ktree. + intros [[|]|[|]]; cbn. + (* ... *) + all: repeat (rewrite ret_bind; simpl). + all: rewrite bind_bind. + all: unfold _app_B, _app_D. + all: rewrite fmap_block_map. + all: unfold ITree.map. + all: apply eutt_bind; try reflexivity. + all: intros []; rewrite (itree_eta (ITree.bind _ _)); cbn; reflexivity. +Qed. + +Definition relabel_bks_correct {A B C D} (f : A -> B) (g : C -> D) + (bc : bks B C) : + @eq_ktree E _ _ + (denote_b (relabel_bks f g bc)) + (lift_ktree f >=> denote_b bc >=> lift_ktree g). +Proof. + rewrite lift_compose_ktree. + rewrite compose_ktree_lift. + intro a. + unfold denote_b, relabel_bks. + rewrite fmap_block_map. + reflexivity. +Qed. + +Definition relabel_asm_correct {A B C D} (f : A -> B) (g : C -> D) + (bc : asm B C) : + @eq_ktree E _ _ + (denote_asm (relabel_asm f g bc)) + (lift_ktree f >=> denote_asm bc >=> lift_ktree g). +Proof. + unfold denote_asm. + simpl. + rewrite relabel_bks_correct. + rewrite <- compose_loop. + rewrite <- loop_compose. + apply eq_ktree_loop. + rewrite !tensor_id_lift. + reflexivity. +Qed. + +Definition link_asm_correct {I A B} (ab : asm (I + A) (I + B)) : + @eq_ktree E _ _ + (denote_asm (link_asm ab)) + (loop (denote_asm ab)). +Proof. + unfold denote_asm. + rewrite loop_loop. + apply eq_ktree_loop. + simpl. + rewrite relabel_bks_correct. + reflexivity. +Qed. + +End Correctness. diff --git a/examples/ExtractThreadsExample.v b/examples/ExtractThreadsExample.v index e414f129..cfc9427f 100644 --- a/examples/ExtractThreadsExample.v +++ b/examples/ExtractThreadsExample.v @@ -7,9 +7,9 @@ Extraction Blacklist String List Char Core Z. Set Extraction AccessOpaque. (* NOTE: assumes that this file is compiled from / *) -Cd "examples/extracted". +Cd "extracted". Recursive Extraction Library MultiThreadedPrinting. (* This is needed for the makefile to succeed for some reason. *) -Cd "../..". +Cd "..". diff --git a/examples/Factorial.v b/examples/Factorial.v new file mode 100644 index 00000000..26b21c43 --- /dev/null +++ b/examples/Factorial.v @@ -0,0 +1,66 @@ +Set Implicit Arguments. +Set Contextual Implicit. + +From Coq Require Import + Nat + Setoid + RelationClasses + Program + Morphisms. + +From ITree Require Import + ITree + Fix + FixFacts + Eq.Eq + Eq.UpToTaus + MorphismsFacts. + +(* Define the recursive factorial function via events. + Here we use the generic "rec" interface of the library, instantiating callE + with the type of factorial : nat -> nat. +*) +Definition factC {E} n : itree (callE nat nat +' E) nat := ITree.liftE (inl1 (Call n)). + +(* We write the body of the function monadically, using events rather than recursive calls. *) +Definition fact_body {E} (rec : nat -> itree (callE nat nat +' E) nat) : nat -> itree (callE nat nat +' E) nat := + (fun x => match x with + | 0 => Ret 1 + | S m => y <- rec m ;; Ret (x * y) + end). + +Definition factorial {E} (n:nat) : itree E nat := + rec (fact_body factC) n. + + +(* This is the Coq specification -- the usual mathematical definition. *) +Fixpoint factspec (n:nat) : nat := + match n with + | 0 => 1 + | S m => n * factspec m + end. + +(* The proof is by induction on n and uses only rewriting, no coinduction. *) +(* SAZ: The rewriting in this proof is a bit annoying. + - We have to use itree_eta in order to rewrite with ret_bind. + - the use of cbn to drive the interp forward also unfolds the fact_body too + much, which means we have to use fold_bind so that interp_bind can see + the bind. +*) +Lemma factorial_correct : forall {E} n, (factorial n : itree E nat) ≈ Ret (factspec n). +Proof. + intros E. + intros n. + induction n; intros; subst. + - rewrite itree_eta. cbn. reflexivity. + - unfold factorial. + rewrite rec_unfold. + rewrite itree_eta. + cbn. + rewrite tau_eutt. + rewrite IHn. + rewrite ret_bind_. + fold_bind. rewrite interp_bind. + rewrite interp_ret. rewrite ret_bind_. + rewrite interp_ret. reflexivity. +Qed. \ No newline at end of file diff --git a/examples/Imp.v b/examples/Imp.v index e47f6269..9a63768f 100644 --- a/examples/Imp.v +++ b/examples/Imp.v @@ -3,6 +3,7 @@ *) Require Import Coq.Lists.List. Require Import Coq.Strings.String. +Require Import ExtLib.Data.String. Require Import ExtLib.Structures.Monad. Require Import ExtLib.Structures.Traversable. Require Import ExtLib.Data.List. @@ -39,212 +40,120 @@ Inductive stmt : Set := | If (i : expr) (t e : stmt) (* if (i) then { t } else { e } *) | While (t : expr) (b : stmt) (* while (t) { b } *) | Skip (* ; *) -(* For Calls ******** -| Call (ls : list var) (f : string) (args : list expr) -*) . -(* the "effect" to track local variables *) -Inductive Locals : Type -> Type := -| GetVar (x : var) : Locals value -| SetVar (x : var) (v : value) : Locals unit. +Module ImpNotations. -(* the "effect" to track errors *) -Inductive Error : Type -> Type := -| RuntimeError (_ : string) : Error Empty_set. + Notation "x '←' e" := + (Assign x e) (at level 60, e at level 50). -Definition error {eff} `{Error -< eff} (msg : string) {a} : itree eff a := - x <- lift (RuntimeError msg) ;; - match x : Empty_set with end. + Notation "a ;;; b" := + (Seq a b) + (at level 80, right associativity, + format + "'[v ' a ';;;' '/' '[' b ']' ']'" + ). + Notation "'IF' i 'THEN' t 'ELSE' e" := + (If i t e) + (at level 200, + right associativity, + format + "'[v ' 'IF' i '/' '[' 'THEN' t ']' '/' '[' 'ELSE' e ']' ']'"). -Definition ImpEff : Type -> Type := Locals +' Error. + Notation "'WHILE' t 'DO' b" := + (While t b) + (at level 200, + right associativity, + format + "'[v ' 'WHILE' t '/' '[' 'DO' b ']' ']'"). -(* For Calls ********* -Inductive External : Type -> Type := -| CallExternal (name : string) (ls : list value) : External (list value). + Coercion Lit: nat >-> expr. + Definition Var_coerce: string -> expr := Var. + Coercion Var_coerce: string >-> expr. -Definition ImpEff : Type -> Type := Locals +' (External +' Error). -*) +End ImpNotations. -Section assignMany. - Context {eff : Type -> Type}. - Context {HasLocals : Locals -< eff}. - Context {HasError : Error -< eff}. - - Fixpoint assignMany (ls : list var) (vs : list value) : itree eff unit := - match ls , vs with - | nil , nil => ret tt - | x :: xs , v :: vs => lift (SetVar x v) ;; assignMany xs vs - | nil , _ :: _ => lift (RuntimeError "insufficient binders") ;; ret tt - | _ :: _ , nil => lift (RuntimeError "too many binders") ;; ret tt - end. -End assignMany. - -(* The meaning of an expression *) -Fixpoint denoteExpr (e : expr) : itree ImpEff value := - match e with - | Var v => lift (GetVar v) - | Lit n => ret n - | Plus a b => l <- denoteExpr a ;; r <- denoteExpr b ;; ret (l + r) - end. - -Definition while {eff} (t : itree eff bool) : itree eff unit := - rec (fun _ : unit => - continue <- translate (fun _ x => inr1 x) _ t ;; - if continue : bool then lift (Call tt) else Monad.ret tt) tt. - -(* the meaning of a statement *) -Fixpoint denoteStmt (s : stmt) : itree ImpEff unit := - match s with - | Assign x e => - v <- denoteExpr e ;; - lift (SetVar x v) - | Seq a b => - denoteStmt a ;; denoteStmt b - | If i t e => - v <- denoteExpr i ;; - if is_true v then denoteStmt t else denoteStmt e - | While t b => - while (v <- denoteExpr t ;; - if is_true v - then denoteStmt b ;; ret true - else ret false) - | Skip => ret tt -(* For Calls ******** - | Call xs f args => - vals <- mapT denoteExpr args ;; - results <- lift (CallExternal f vals) ;; - assignMany xs results -*) - end. +Import ImpNotations. -(* some simple examples *) -Eval simpl in - denoteStmt (Seq (Assign "x" (Lit 1)) - (Assign "y" (Var "x"))). - -Eval simpl in - denoteStmt (Seq (Assign "x" (Lit 1)) - (While (Var "x") (Assign "x" (Var "x")))). +(* the "effect" to track local variables *) +Inductive Locals : Type -> Type := +| GetVar (x : var) : Locals value +| SetVar (x : var) (v : value) : Locals unit. -(* Two interpretations of local variable environments - *) -Module ImplicitInit. - Import ITree.Basics.Monads. +Section Denote. - (* Interpretation of the `Locals` effects using total maps, i.e. - * variables are implicitly initialized to some default value. - * This mirrors the semantics of Imp. - *) - Definition evalLocals {eff} : Locals ~> stateT (var -> value) (itree eff) := - fun _ e st => - match e with - | GetVar x => - ret (st, st x) - | SetVar x v => - ret (fun x' => if string_dec x x' then v else st x', tt) - end. + Context {eff : Type -> Type}. + Context {HasLocals : Locals -< eff}. - Definition init : var -> value := - fun _ => 0. + (* The meaning of an expression *) + Fixpoint denoteExpr (e : expr) : itree eff value := + match e with + | Var v => lift (GetVar v) + | Lit n => ret n + | Plus a b => l <- denoteExpr a ;; r <- denoteExpr b ;; ret (l + r) + end. -End ImplicitInit. + Definition while {eff} (t : itree eff bool) : itree eff unit := + loop + (fun l : unit + unit => + match l with + | inr _ => ret (inl tt) + | inl _ => continue <- t ;; + if continue : bool then ret (inl tt) else ret (inr tt) + end) tt. + + (* the meaning of a statement *) + Fixpoint denoteStmt (s : stmt) : itree eff unit := + match s with + | Assign x e => + v <- denoteExpr e ;; + lift (SetVar x v) + | Seq a b => + denoteStmt a ;; denoteStmt b + | If i t e => + v <- denoteExpr i ;; + if is_true v then denoteStmt t else denoteStmt e + | While t b => + while (v <- denoteExpr t ;; + if is_true v + then denoteStmt b ;; ret true + else ret false) + | Skip => ret tt + end. +End Denote. -Module ExplicitInit. - Import ITree.Basics.Monads. +From ITree Require Import + Effect.Env. - Definition env := list (var * value). +From ExtLib Require Import + Core.RelDec + Structures.Maps + Data.Map.FMapAList. - Fixpoint lookup (e : env) (v : string) : option value := +Definition evalLocals {E: Type -> Type} `{envE var value -< E}: Locals ~> itree E := + fun _ e => match e with - | nil => None - | (var,val) :: es => - if string_dec var v then Some val else lookup es v + | GetVar x => env_lookupDefault x 0 + | SetVar x v => env_add x v end. - Fixpoint set (v : string) (val : value) (e : env) : env := - match e with - | nil => (v, val) :: nil - | (var,val') :: es => - if string_dec var v then (var, val) :: es else (var, val') :: set v val es - end. +Definition env := alist var value. + +(* Enable typeclass instances for Maps keyed by strings and values *) +Instance RelDec_string : RelDec (@eq string) := + { rel_dec := fun s1 s2 => if string_dec s1 s2 then true else false}. + +Instance RelDec_string_Correct: RelDec_Correct RelDec_string. +Proof. + constructor; intros x y. + split. + - unfold rel_dec; simpl. + destruct (string_dec x y) eqn:EQ; [intros _; apply string_dec_sound; assumption | intros abs; inversion abs]. + - intros EQ; apply string_dec_sound in EQ; unfold rel_dec; simpl; rewrite EQ; reflexivity. +Qed. - (* Interpretation of the `Locals` effects using partial maps, i.e. - * variables must be explicitly initialized. - * This mirrors the semantics of C. - *) - Definition evalLocals {eff} `{Error -< eff}: Locals ~> stateT env (itree eff) := - fun _ e st => - match e with - | GetVar x => - match lookup st x with - | None => - error ("variable `" ++ x ++ "` not defined") - | Some v => ret (st, v) - end - | SetVar x v => - ret (set x v st, tt) - end. - - Definition init : env := nil. - -End ExplicitInit. - -Definition evalLocals stmt := - interp_state (into_state ExplicitInit.evalLocals) _ (denoteStmt stmt) ExplicitInit.init. - -(* For Calls ************ -Definition evalLocals stmt := - run_state ExplicitInit.evalLocals (denoteStmt stmt) ExplicitInit.init. -*) - -(* some simple examples *) -Eval simpl in - let stmt := Seq (Assign "x" (Lit 1)) - (Assign "y" (Var "x")) in - evalLocals stmt. - -Eval simpl in - let stmt := Seq (Assign "x" (Lit 1)) - (While (Var "x") (Assign "x" (Var "x"))) in - evalLocals stmt. - -(* For Calls ************ -Eval simpl in - let stmt := Seq (Call ("x" :: nil) "print" (Lit 1 :: nil)) - (Assign "y" (Var "x")) in - simplify 1 (evalLocals stmt). - -Module ToTrace. - - Definition Event : Type := (string * list value * list value)%type. - - Section with_oracle. - (* we could add state without much difficulty *) - Variable oracle : string -> list value -> list value. - - Definition evalExternals {eff} - : eff_hom_s (list Event) External eff := - fun _ e st => - match e with - | CallExternal f ls => - let res := oracle f ls in - ret (st ++ (f, ls, res) :: nil, res)%list - end. - End with_oracle. - -End ToTrace. - -Definition evalTrace {eff} {t} (oracle : _) - (it : ITree.itree (External +' eff) t) -: ITree.itree eff (list ToTrace.Event * t) := - run_state (ToTrace.evalExternals oracle) it nil. - -Eval simpl in - let stmt := Seq (Call ("x" :: nil) "print" (Lit 1 :: nil)) - (Assign "y" (Var "x")) in - fun oracle => - simplify 2 (evalTrace oracle (evalLocals stmt)). -*) +Definition ImpEval (s: stmt): itree emptyE (env * unit) := + let p := interp evalLocals _ (denoteStmt s) in + run_env _ p empty. diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v new file mode 100644 index 00000000..14c3496d --- /dev/null +++ b/examples/Imp2Asm.v @@ -0,0 +1,124 @@ +Require Import Imp Asm AsmCombinators. + +Require Import Psatz. + +From Coq Require Import + Strings.String + Morphisms + Setoid + Decimal + Numbers.DecimalString + RelationClasses. + +From ITree Require Import + Basics_Functions + Effect.Env + ITree. + +From ExtLib Require Import + Core.RelDec + Structures.Monad + Structures.Maps + Programming.Show + Data.Map.FMapAList. + +Import ListNotations. +Open Scope string_scope. + +Section compile_assign. + + Fixpoint nat_to_string (n: nat): string := + match n with + | O => "" + | S n => String (ascii_of_nat 49) (nat_to_string n) + end. + + Definition gen_tmp (n: nat): string := + "temp_" ++ nat_to_string n. + + Definition varOf (s : var) : var := "local_" ++ s. + + Fixpoint compile_expr (l: nat) (e: expr): list instr := + match e with + | Var x => [Imov (gen_tmp l) (Ovar (varOf x))] + | Lit n => [Imov (gen_tmp l) (Oimm n)] + | Plus e1 e2 => + let instrs1 := compile_expr l e1 in + let instrs2 := compile_expr (S l) e2 in + instrs1 ++ instrs2 ++ [Iadd (gen_tmp l) (gen_tmp l) (Ovar (gen_tmp (S l)))] + end. + + Definition compile_assign (x: Imp.var) (e: expr): list instr := + let instrs := compile_expr 0 e in + instrs ++ [Imov (varOf x) (Ovar (gen_tmp 0))]. + +End compile_assign. + +(** Sequencing of blocks: the program [seq_asm ab bc] links the + exit points of [ab] with the entry points of [bc]. + +[[ + B + A---ab-----bc---C +]] + + ... can be implemented using just [app_asm] and [link_asm]. + +[[ + +------+ + | | + A------ab--+B + | + B+--bc------C +]] +*) +Definition seq_asm {A B C} (ab : asm A B) (bc : asm B C): asm A C := + link_asm (relabel_asm sum_comm id (app_asm ab bc)). + +(* Location of temporary for [if]. *) +Definition tmp_if := gen_tmp 0. + +(* Conditional *) +Definition cond_asm (e : list instr) : asm unit (unit + unit) := + raw_asm_block (after e (Bbrz tmp_if (inr tt) (inl tt))). + +(** [if_asm e tp fp] +[[ + true + ee-------tp---C + 1---ee-------fp---C + false +]] + *) +Definition if_asm {A} + (e : list instr) (tp : asm unit A) (fp : asm unit A) : + asm unit A := + seq_asm (cond_asm e) + (relabel_asm id sum_merge (app_asm tp fp)). + +(* [while_asm e p] +[[ + +-------------+ + | | + | true | + | e-------p--+ + 1---+--e--------------1 + false +]] +*) +Definition while_asm (e : list instr) (p : asm unit unit) : + asm unit unit := + link_asm (relabel_asm id sum_merge + (app_asm (if_asm e + (relabel_asm id inl p) + (pure_asm inr)) + (pure_asm inl))). + +Fixpoint compile (s : stmt) {struct s} : asm unit unit := + match s with + | Skip => id_asm + | Assign x e => raw_asm_block (after (compile_assign x e) (Bjmp tt)) + | Seq l r => seq_asm (compile l) (compile r) + | If e l r => if_asm (compile_expr 0 e) (compile l) (compile r) + | While e b => while_asm (compile_expr 0 e) (compile b) + end. diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v new file mode 100644 index 00000000..05a5d361 --- /dev/null +++ b/examples/Imp2AsmCorrectness.v @@ -0,0 +1,729 @@ +Require Import Imp Asm AsmCombinators Imp2Asm. + +Require Import Psatz. + +From Coq Require Import + Strings.String + Morphisms + Setoid + RelationClasses. + +From ITree Require Import + Basics_Functions + ITree + Effect.Env + MorphismsFacts + FixFacts + KTree. + +From ExtLib Require Import + Core.RelDec + Structures.Monad + Structures.Maps + Programming.Show + Data.Map.FMapAList. + +Import ListNotations. +Open Scope string_scope. + +Section EUTT. + + Context {E: Type -> Type}. + + Instance eq_itree_run_env {E R} {K V map} {Mmap: Maps.Map K V map}: + Proper (@eutt (envE K V +' E) R R eq ==> eq ==> @eutt E (prod map R) (prod map R) eq) + (run_env R). + Proof. + eapply MorphismsFacts.eutt_interp_state. + Qed. + +End EUTT. + +Section GEN_TMP. + + Lemma nat_to_string_inj: + forall (n m: nat), n <> m -> nat_to_string n <> nat_to_string m. + Proof. + induction n as [| n IH]; simpl; intros m ineq. + - destruct m as [| m]; [lia | intros abs; inversion abs]. + - destruct m as [| m]; [intros abs; inversion abs |]. + simpl; intros abs; inversion abs; subst; clear abs. + apply (IH m); auto. + Qed. + + Lemma gen_tmp_inj: forall n m, m <> n -> gen_tmp m <> gen_tmp n. + Proof. + intros n m ineq; intros abs; apply ineq. + apply nat_to_string_inj in ineq; inversion abs; easy. + Qed. + + Lemma varOf_inj: forall n m, m <> n -> varOf m <> varOf n. + Proof. + intros n m ineq abs; inv abs; easy. + Qed. + +End GEN_TMP. + +Opaque gen_tmp. +Opaque varOf. + +Ltac flatten_goal := + match goal with + | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq + end. + +Ltac flatten_hyp h := + match type of h with + | context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq + end. + +Ltac flatten_all := + match goal with + | h: context[match ?x with | _ => _ end] |- _ => let Heq := fresh "Heq" in destruct x eqn:Heq + | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq + end. + +Ltac inv h := inversion h; subst; clear h. + +Section alistFacts. + + + (* Generic facts about alists. To eventually move to ExtLib. *) + + Arguments alist_find {_ _ _ _}. + + Definition alist_In {K R RD V} k m v := @alist_find K R RD V k m = Some v. + + Arguments alist_add {_ _ _ _}. + Arguments alist_find {_ _ _ _}. + Arguments alist_remove {_ _ _ _}. + + Context {K V: Type}. + Context {RR : @RelDec K (@eq K)}. + Context {RRC : @RelDec_Correct K (@eq K) RR}. + + Lemma In_add_eq: + forall k v (m: alist K V), + alist_In k (alist_add k v m) v. + Proof. + intros; unfold alist_add, alist_In; simpl; flatten_goal; [reflexivity | rewrite <- neg_rel_dec_correct in Heq; tauto]. + Qed. + + (* A removed key is not contained in the resulting map *) + Lemma not_In_remove: + forall (m : alist K V) (k : K) (v: V), + ~ alist_In k (alist_remove k m) v. + Proof. + induction m as [| [k1 v1] m IH]; intros. + - simpl; intros abs; inv abs. + - simpl; flatten_goal. + + unfold alist_In; simpl. + rewrite Bool.negb_true_iff in Heq; rewrite Heq. + intros abs; eapply IH; eassumption. + + rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. + intros abs; eapply IH; eauto. + Qed. + + (* Removing a key does not alter other keys *) + Lemma In_In_remove_ineq: + forall (m : alist K V) (k : K) (v : V) (k' : K), + k <> k' -> + alist_In k m v -> + alist_In k (alist_remove k' m) v. + Proof. + induction m as [| [? ?] m IH]; intros ?k ?v ?k' ineq IN; [inversion IN |]. + simpl. + flatten_goal. + - unfold alist_In in *; simpl in *. + rewrite Bool.negb_true_iff, <- neg_rel_dec_correct in Heq. + flatten_goal; auto. + - unfold alist_In in *; simpl in *. + rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. + flatten_hyp IN; [rewrite rel_dec_correct in Heq; subst; tauto | eapply IH; eauto]. + Qed. + + Lemma In_remove_In_ineq: + forall (m : alist K V) (k : K) (v : V) (k' : K), + alist_In k (alist_remove k' m) v -> + alist_In k m v. + Proof. + induction m as [| [? ?] m IH]; intros ?k ?v ?k' IN; [inversion IN |]. + simpl in IN; flatten_hyp IN. + - unfold alist_In in *; simpl in *. + flatten_all; auto. + eapply IH; eauto. + -rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. + unfold alist_In; simpl. + flatten_goal; [rewrite rel_dec_correct in Heq; subst |]. + exfalso; eapply not_In_remove; eauto. + eapply IH; eauto. + Qed. + + Lemma In_remove_In_ineq_iff: + forall (m : alist K V) (k : K) (v : V) (k' : K), + k <> k' -> + alist_In k (alist_remove k' m) v <-> + alist_In k m v. + Proof. + intros; split; eauto using In_In_remove_ineq, In_remove_In_ineq. + Qed. + + (* Adding a value to a key does not alter other keys *) + Lemma In_In_add_ineq: + forall k v k' v' (m: alist K V), + k <> k' -> + alist_In k m v -> + alist_In k (alist_add k' v' m) v. + Proof. + intros. + unfold alist_In; simpl; flatten_goal; [rewrite rel_dec_correct in Heq; subst; tauto |]. + apply In_In_remove_ineq; auto. + Qed. + + Lemma In_add_In_ineq: + forall k v k' v' (m: alist K V), + k <> k' -> + alist_In k (alist_add k' v' m) v -> + alist_In k m v. + Proof. + intros k v k' v' m ineq IN. + unfold alist_In in IN; simpl in IN; flatten_hyp IN; [rewrite rel_dec_correct in Heq; subst; tauto |]. + eapply In_remove_In_ineq; eauto. + Qed. + + Lemma In_add_ineq_iff: + forall m (v v' : V) (k k' : K), + k <> k' -> + alist_In k m v <-> alist_In k (alist_add k' v' m) v. + Proof. + intros; split; eauto using In_In_add_ineq, In_add_In_ineq. + Qed. + + (* alist_find fails iff no value is associated to the key in the map *) + Lemma alist_find_None: + forall k (m: alist K V), + (forall v, ~ In (k,v) m) <-> alist_find k m = None. + Proof. + induction m as [| [k1 v1] m IH]; [simpl; easy |]. + simpl; split; intros H. + - flatten_goal; [rewrite rel_dec_correct in Heq; subst; exfalso | rewrite <- neg_rel_dec_correct in Heq]. + apply (H v1); left; reflexivity. + apply IH; intros v abs; apply (H v); right; assumption. + - intros v; flatten_hyp H; [inv H | rewrite <- IH in H]. + intros [EQ | abs]; [inv EQ; rewrite <- neg_rel_dec_correct in Heq; tauto | apply (H v); assumption]. + Qed. + +End alistFacts. +Arguments alist_find {_ _ _ _}. +Arguments alist_add {_ _ _ _}. +Arguments alist_find {_ _ _ _}. +Arguments alist_remove {_ _ _ _}. + +Section Simulation_Relation. + + Variable E: Type -> Type. + Context {HasLocals: Locals -< E} {HasMemory: Memory -< E}. + + Variant Rvar : var -> var -> Prop := + | Rvar_var v : Rvar (varOf v) v. + + Definition Renv (g_asm g_imp : alist var value) : Prop := + forall k_asm k_imp, Rvar k_asm k_imp -> + forall v, alist_In k_imp g_imp v <-> alist_In k_asm g_asm v. + + Definition sim_rel g_asm n: alist var value * unit -> alist var value * value -> Prop := + fun '(g_asm', _) '(g_imp',v) => + Renv g_asm' g_imp' /\ (* we don't corrupt any of the imp variables *) + alist_In (gen_tmp n) g_asm' v /\ (* we get the right value *) + (forall m, m < n -> forall v, (* we don't mess with anything on the "stack" *) + alist_In (gen_tmp m) g_asm v <-> alist_In (gen_tmp m) g_asm' v). + + Lemma Renv_add: forall g_asm g_imp n v, + Renv g_asm g_imp -> Renv (alist_add (gen_tmp n) v g_asm) g_imp. + Proof. + repeat intro. + destruct (k_asm ?[ eq ] (gen_tmp n)) eqn:EQ. + rewrite rel_dec_correct in EQ; subst; inv H0. + rewrite <- neg_rel_dec_correct in EQ. + rewrite (H _ _ H0). + apply In_add_ineq_iff; auto. + Qed. + + Lemma Renv_find: + forall g_asm g_imp x, + Renv g_asm g_imp -> + alist_find x g_imp = alist_find (varOf x) g_asm. + Proof. + intros. + destruct (alist_find x g_imp) eqn:LUL, (alist_find (varOf x) g_asm) eqn:LUR; auto. + - eapply H in LUL; [| constructor]. + rewrite LUL in LUR; auto. + - eapply H in LUL; [| constructor]. + rewrite LUL in LUR; auto. + - erewrite <- (H (varOf x) x (Rvar_var x) v) in LUR. + rewrite LUR in LUL; inv LUL. + Qed. + + Lemma sim_rel_add: forall g_asm g_imp n v, + Renv g_asm g_imp -> + sim_rel g_asm n (alist_add (gen_tmp n) v g_asm, tt) (g_imp, v). + Proof. + intros. + split; [| split]. + - apply Renv_add; assumption. + - apply In_add_eq. + - intros m LT v'. + apply In_add_ineq_iff, gen_tmp_inj; lia. + Qed. + + Lemma sim_rel_Renv: forall g_asm n s1 v1 s2 v2, + sim_rel g_asm n (s1,v1) (s2,v2) -> Renv s1 s2. + Proof. + intros ? ? ? ? ? ? H; apply H. + Qed. + + Lemma sim_rel_find_tmp_n: + forall g_asm n g_asm' g_imp' v, + sim_rel g_asm n (g_asm', tt) (g_imp',v) -> + alist_In (gen_tmp n) g_asm' v. + Proof. + intros ? ? ? ? ? [_ [H _]]; exact H. + Qed. + + Lemma sim_rel_find_tmp_lt_n: + forall g_asm n m g_asm' g_imp' v, + m < n -> + sim_rel g_asm n (g_asm', tt) (g_imp',v) -> + alist_find (gen_tmp m) g_asm = alist_find (gen_tmp m) g_asm'. + Proof. + intros ? ? ? ? ? ? ineq [_ [_ H]]. + match goal with + | |- _ = ?x => destruct x eqn:EQ + end. + setoid_rewrite (H _ ineq); auto. + match goal with + | |- ?x = _ => destruct x eqn:EQ' + end; [| reflexivity]. + setoid_rewrite (H _ ineq) in EQ'. + rewrite EQ' in EQ; easy. + Qed. + + Lemma Renv_write_local: + forall (x : Imp.var) (a a0 : alist var value) (v : Imp.value), + Renv a a0 -> Renv (alist_add (varOf x) v a) (alist_add x v a0). + Proof. + intros k m m' v. + repeat intro. + red in H. + specialize (H k_asm k_imp H0 v0). + inv H0. + unfold alist_add, alist_In; simpl. + do 2 flatten_goal; + repeat match goal with + | h: _ = true |- _ => rewrite rel_dec_correct in h + | h: _ = false |- _ => rewrite <- neg_rel_dec_correct in h + end; try subst. + - tauto. + - tauto. + - apply varOf_inj in Heq; easy. + - setoid_rewrite In_remove_In_ineq_iff; eauto using RelDec_string_Correct. + Qed. + +End Simulation_Relation. + +Section Correctness. + + Context {E': Type -> Type}. + Context {HasMemory: Memory -< E'}. + Context {HasExit: Exit -< E'}. + Notation E := (Locals +' E'). + + Definition interp_locals {R: Type} (t: itree E R) (s: alist var value) + : itree E' (alist var value * R) := + run_env _ (interp1 evalLocals _ t) s. + + Instance eutt_interp_locals {R}: + Proper (@eutt E R R eq ==> eq ==> @eutt E' (prod (alist var value) R) (prod _ R) eq) + interp_locals. + Proof. + repeat intro. + unfold interp_locals. + unfold run_env. + rewrite H0. eapply eutt_interp_state; auto. rewrite H. + reflexivity. + Qed. + + Lemma interp_locals_bind: forall {R S} (t: itree E R) (k: R -> itree _ S) (s: alist var value), + @eutt E' _ _ eq + (interp_locals (ITree.bind t k) s) + (ITree.bind (interp_locals t s) (fun s' => interp_locals (k (snd s')) (fst s'))). + Proof. + intros. + unfold interp_locals. + unfold run_env. + rewrite interp1_bind. + rewrite interp_state_bind. + reflexivity. + Qed. + + Definition eq_locals {R1 R2} (RR : R1 -> R2 -> Prop) + (Renv_ : _ -> _ -> Prop) + t1 t2 := + forall g1 g2, + Renv_ g1 g2 -> + eutt (fun a (b : alist var value * R2) => Renv_ (fst a) (fst b) /\ RR (snd a) (snd b)) + (interp_locals t1 g1) + (interp_locals t2 g2). + + Instance eutt_eq_locals (Renv_ : _ -> _ -> Prop) {R} RR : + Proper (eutt eq ==> eutt eq ==> iff) (@eq_locals R R RR Renv_). + Proof. + repeat intro. + split; repeat intro. + - rewrite <- H, <- H0; auto. + - rewrite H, H0; auto. + Qed. + + Definition eq_locals_bind_gen (Renv_ : _ -> _ -> Prop) + {R1 R2 S1 S2} (RR : R1 -> R2 -> Prop) + (RS : S1 -> S2 -> Prop) : + forall t1 t2, + eq_locals RR Renv_ t1 t2 -> + forall k1 k2, + (forall r1 r2, RR r1 r2 -> eq_locals RS Renv_ (k1 r1) (k2 r2)) -> + eq_locals RS Renv_ (t1 >>= k1) (t2 >>= k2). + Proof. + repeat intro. + rewrite 2 interp_locals_bind. + eapply eutt_bind_gen. + { eapply H; auto. } + intros. eapply H0; destruct H2; auto. + Qed. + + Lemma eq_locals_loop {A B C} x (t1 t2 : C + A -> itree E (C + B)) : + (forall l, eq_locals eq Renv (t1 l) (t2 l)) -> + eq_locals eq Renv (loop t1 x) (loop t2 x). + Proof. + unfold eq_locals, interp_locals, run_env. + intros. unfold loop. + rewrite 2 interp1_loop. + eapply interp_state_loop; auto. + Qed. + + Ltac force_left := + match goal with + | |- eutt _ ?x _ => rewrite (itree_eta x); cbn + end. + + Ltac force_right := + match goal with + | |- eutt _ _ ?x => rewrite (itree_eta x); cbn + end. + + Ltac untau_left := force_left; rewrite tau_eutt. + Ltac untau_right := force_right; rewrite tau_eutt. + + + Notation "(% x )" := (gen_tmp x) (at level 1). + + Lemma compile_expr_correct : forall e g_imp g_asm n, + Renv g_asm g_imp -> + eutt (sim_rel g_asm n) + (interp_locals (denote_list (compile_expr n e)) g_asm) + (interp_locals (denoteExpr e) g_imp). + Proof. + induction e; simpl; intros. + - repeat untau_left. + repeat untau_right. + force_left; force_right. + apply eutt_ret. + erewrite <- Renv_find; [| eassumption]. + apply sim_rel_add; assumption. + - repeat untau_left. + force_left. + force_right. + apply eutt_ret. + apply sim_rel_add; assumption. + - do 2 setoid_rewrite denote_list_app. + do 2 setoid_rewrite interp_locals_bind. + eapply eutt_bind_gen. + + eapply IHe1; assumption. + + intros [g_asm' []] [g_imp' v] HSIM. + eapply eutt_bind_gen. + eapply IHe2. + eapply sim_rel_Renv; eassumption. + intros [g_asm'' []] [g_imp'' v'] HSIM'. + repeat untau_left. + force_left; force_right. + simpl fst in *. + apply eutt_ret. + { + generalize HSIM; intros LU; apply sim_rel_find_tmp_n in LU. + unfold alist_In in LU; erewrite sim_rel_find_tmp_lt_n in LU; eauto; fold (alist_In (%n) g_asm'' v) in LU. + generalize HSIM'; intros LU'; apply sim_rel_find_tmp_n in LU'. + rewrite LU,LU'. + split; [| split]. + { + eapply Renv_add, sim_rel_Renv; eassumption. + } + { + apply In_add_eq. + } + { + intros m LT v''. + rewrite <- In_add_ineq_iff; [| apply gen_tmp_inj; lia]. + destruct HSIM as [_ [_ HSIM]]. + destruct HSIM' as [_ [_ HSIM']]. + rewrite HSIM; [| auto with arith]. + rewrite HSIM'; [| auto with arith]. + reflexivity. + } + } + Qed. + + Lemma compile_assign_correct : forall e x, + eq_locals eq Renv + (denote_list (compile_assign x e)) + (v <- denoteExpr e ;; lift (SetVar x v)). + Proof. + red; intros. + unfold compile_assign. + rewrite denote_list_app. + do 2 rewrite interp_locals_bind. + eapply eutt_bind_gen. + eapply compile_expr_correct; eauto. + intros. + repeat untau_left. + force_left. + repeat untau_right; force_right. + eapply eutt_ret; simpl. + destruct r1, r2. + erewrite sim_rel_find_tmp_n; eauto; simpl. + destruct H0. + split; auto. + eapply Renv_write_local; eauto. + Qed. + + Lemma seq_asm_correct {A B C} (ab : asm A B) (bc : asm B C) : + eq_ktree (denote_asm (seq_asm ab bc)) + (denote_asm ab >=> denote_asm bc). + Proof. + unfold seq_asm. + rewrite link_asm_correct, relabel_asm_correct, app_asm_correct. + rewrite id_ktree_right. + rewrite sym_ktree_unfold. + apply cat_from_loop. + Qed. + + Lemma if_asm_correct {A} (e : list instr) (tp fp : asm unit A) : + eq_ktree + (denote_asm (if_asm e tp fp)) + (fun _ => + denote_list e ;; + v <- lift (GetVar tmp_if) ;; + if v : value then denote_asm fp tt else denote_asm tp tt). + Proof. + unfold if_asm. + rewrite seq_asm_correct. + unfold cond_asm. + rewrite raw_asm_block_correct_lifted. + intros []; unfold ITree.cat at 1; simpl. + rewrite after_correct. + simpl. + repeat setoid_rewrite bind_bind. + apply eutt_bind; [reflexivity | intros ?]. + apply eutt_bind; [reflexivity | intros []]. + - rewrite ret_bind_. + rewrite (relabel_asm_correct _ _ _ (inr tt)). + unfold ITree.cat; simpl. + rewrite bind_bind. + unfold lift_ktree; rewrite ret_bind_. + setoid_rewrite (app_asm_correct tp fp (inr tt)). + setoid_rewrite bind_bind. + rewrite <- (bind_ret (denote_asm fp tt)) at 2. + eapply eutt_bind; [ reflexivity | intros ? ]. + unfold lift_ktree; rewrite ret_bind_; reflexivity. + - rewrite ret_bind_. + rewrite (relabel_asm_correct _ _ _ (inl tt)). + unfold ITree.cat; simpl. + rewrite bind_bind. + unfold lift_ktree; rewrite ret_bind_. + setoid_rewrite (app_asm_correct tp fp (inl tt)). + setoid_rewrite bind_bind. + rewrite <- (bind_ret (denote_asm tp tt)) at 2. + eapply eutt_bind; [reflexivity | intros ?]. + unfold lift_ktree; rewrite ret_bind_; reflexivity. + Qed. + + Lemma while_asm_correct (e : list instr) (p : asm unit unit) : + eq_ktree + (denote_asm (while_asm e p)) + (loop (fun l => + match l with + | inl tt => + denote_list e ;; + v <- lift (GetVar tmp_if) ;; + if v : value then + Ret (inr tt) + else + denote_asm p tt;; Ret (inl tt) + | inr tt => Ret (inl tt) + end)). + Proof. + unfold while_asm. + rewrite link_asm_correct. + apply eq_ktree_loop. + rewrite relabel_asm_correct, id_ktree_left. + rewrite app_asm_correct. + rewrite if_asm_correct. + intros [[] |[]]. + - unfold ITree.cat. + simpl; setoid_rewrite bind_bind. + rewrite bind_bind. + apply eutt_bind; [reflexivity | intros []]. + rewrite bind_bind. + apply eutt_bind; [reflexivity | intros []]. + + rewrite (pure_asm_correct _ tt). + unfold lift_ktree. + repeat rewrite ret_bind_. + reflexivity. + + rewrite (relabel_asm_correct _ _ _ tt). + unfold ITree.cat. + simpl; repeat setoid_rewrite bind_bind. + unfold lift_ktree; rewrite ret_bind_. + apply eutt_bind; [reflexivity | intros []]. + repeat rewrite ret_bind_; reflexivity. + - rewrite itree_eta; cbn; reflexivity. + Qed. + + Lemma while_is_loop {E} (body : itree E bool) : + while body + ≈ loop (fun l : unit + unit => + match l with + | inl _ => ITree.map (fun b => if b : bool then inl tt else inr tt) + body + | inr _ => Ret (inl tt) (* Enter loop *) + end) tt. + Proof. + unfold while. + apply eutt_loop; [intros [[]|[]]; simpl | reflexivity]. + 2: reflexivity. + unfold ITree.map. + apply eutt_bind; [reflexivity | intros []; reflexivity]. + Qed. + + Definition env_lookupDefault_is_lift {K V : Type} {E: Type -> Type} `{envE K V -< E} (x: K) (v: V): + env_lookupDefault x v = lift (lookupDefaultE x v). + Proof. + reflexivity. + Qed. + + Lemma sim_rel_get_tmp0: + forall g_asm0 g_asm g_imp v, + sim_rel g_asm0 0 (g_asm,tt) (g_imp,v) -> + interp_locals (lift (GetVar (%0))) g_asm ≈ Ret (g_asm,v). + Proof. + intros. + destruct H as [_ [eq _]]. + unfold interp_locals. + rewrite interp1_liftE. + cbn. + unfold run_env. + rewrite env_lookupDefault_is_lift. + unfold lift; rewrite interp_state_liftE. + cbn. + rewrite eq. + apply tau_eutt. + Qed. + + Lemma compile_correct (s : stmt) : + eq_locals eq Renv + (denote_asm (compile s) tt) + (denoteStmt s). + Proof. + induction s. + + - (* Assign *) + simpl. + rewrite raw_asm_block_correct. + rewrite after_correct. + rewrite <- (bind_ret (ITree.bind (denoteExpr e) _)). + eapply eq_locals_bind_gen. + { eapply compile_assign_correct; auto. } + intros [] [] []. simpl. + repeat intro. + rewrite itree_eta, (itree_eta (_ _ g2)); cbn. + apply eutt_ret; auto. + + - (* Seq *) + rewrite fold_to_itree; simpl. + rewrite seq_asm_correct. unfold to_itree. + unfold ITree.cat. + eapply eq_locals_bind_gen. + { eauto. } + intros [] [] []; auto. + + - (* If *) + repeat intro. + rewrite fold_to_itree. simpl. + rewrite if_asm_correct. + unfold to_itree. + rewrite 2 interp_locals_bind. + eapply eutt_bind_gen. + { apply compile_expr_correct; auto. } + intros. + destruct r2 as [g_imp' v]; simpl. + rewrite interp_locals_bind. + destruct r1 as [g_asm' []]. + generalize H0; intros EQ. apply sim_rel_get_tmp0 in EQ. + setoid_rewrite EQ; clear EQ. + rewrite ret_bind_. + simpl. + apply sim_rel_Renv in H0. + destruct v; simpl; auto. + + - (* While *) + simpl; rewrite fold_to_itree. + rewrite while_asm_correct. + rewrite while_is_loop. + unfold to_itree. + apply eq_locals_loop. + intros [[]|[]]. + 2:{ repeat intro. + rewrite itree_eta, (itree_eta (_ _ g2)); cbn. + apply eutt_ret; auto. } + unfold ITree.map. rewrite bind_bind. + + repeat intro. + rewrite 2 interp_locals_bind. + eapply eutt_bind_gen. + { apply compile_expr_correct; auto. } + intros. + destruct r2 as [g_imp' v]; simpl. + rewrite interp_locals_bind. + destruct r1 as [g_asm' []]. + generalize H0; intros EQ. apply sim_rel_get_tmp0 in EQ. + rewrite interp_locals_bind. + setoid_rewrite EQ; clear EQ. + rewrite ret_bind_. + simpl. + apply sim_rel_Renv in H0. + destruct v; simpl; auto. + + rewrite itree_eta, (itree_eta (_ >>= _)); cbn. + apply eutt_ret. auto. + + rewrite 2 interp_locals_bind, bind_bind. + eapply eutt_bind_gen. + { eapply IHs; auto. } + intros. + rewrite itree_eta, (itree_eta (_ >>= _)); cbn. + apply eutt_ret. destruct H1; auto. + + - (* Skip *) + repeat intro. + rewrite (itree_eta (_ (denote_asm _ _) _)), + (itree_eta (_ (denoteStmt _) _)); + cbn. + apply eutt_ret; auto. + Qed. + +End Correctness. diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 index 00000000..90493969 --- /dev/null +++ b/examples/Makefile @@ -0,0 +1,37 @@ +.PHONY: example-imp example-lc example-io example-nimp example-asm example-threads + +examples: Makefile.coq + mkdir -p extracted + $(MAKE) -f Makefile.coq + +Makefile.coq: _CoqProject + coq_makefile -f $< -o $@ + +example-imp: + $(MAKE) -f Makefile.coq Imp.vo + +example-asm: + $(MAKE) -f Makefile.coq Asm.vo + +example-lc: + $(MAKE) -f Makefile.coq stlc.vo + +example-io: + $(MAKE) -f Makefile.coq IO.vo + +example-nimp: + $(MAKE) -f Makefile.coq Nimp.vo + +THREADSV=MultiThreadedPrinting.vo ExtractThreadsExample.vo +THREADSML=runthread.ml + +example-threads: Makefile.coq $(THREADSML) + $(MAKE) -f Makefile.coq $(THREADSV) + coqc -Q theories/ ITree -Q examples/ Examples $(THREADSV) + ocamlbuild -I extracted runthread.native + ./runthread.native + +clean: _CoqProject + $(MAKE) -f Makefile.coq clean + ocamlbuild -clean + $(RM) -rf extracted diff --git a/examples/Nimp.v b/examples/Nimp.v index c2d4aa2d..15a3286d 100644 --- a/examples/Nimp.v +++ b/examples/Nimp.v @@ -145,7 +145,7 @@ Definition one_loop_tree : itree nd unit := Import Coq.Classes.Morphisms. (* SAZ: the [~] notation for eutt wasn't working here. *) -Lemma eval_one_loop : eutt (eval one_loop) (one_loop_tree). +Lemma eval_one_loop : eutt eq (eval one_loop) (one_loop_tree). Proof. (* pupto2_init. diff --git a/examples/_CoqProject b/examples/_CoqProject new file mode 100644 index 00000000..1e4b83c0 --- /dev/null +++ b/examples/_CoqProject @@ -0,0 +1,15 @@ +-Q ../theories ITree +-R . Examples + +IO.v +MultiThreadedPrinting.v +ExtractThreadsExample.v + +Imp.v +Asm.v +AsmCombinators.v +Imp2Asm.v +Imp2AsmCorrectness.v + +Nimp.v +stlc.v diff --git a/examples/stlc.v b/examples/stlc.v index 545e1964..685e71b0 100644 --- a/examples/stlc.v +++ b/examples/stlc.v @@ -59,17 +59,16 @@ Fixpoint subst (n : nat) (s t : term) := (* big-step call-by-value *) Definition big_step : term -> itree emptyE value := - mfix (fun _ => value) - (fun _ lift big_step t => + rec (fun t => match t with | Var n => ret (VHead (VVar n)) | App t1 t2 => - t2' <- big_step t2;; - t1' <- big_step t1;; + t2' <- lift (Call t2);; + t1' <- lift (Call t1);; match t1' with | VHead hv => ret (VHead (VApp hv t2')) | VLam t1'' => - big_step (subst O (to_term t2') t1'') + lift (Call (subst O (to_term t2') t1'')) end | Lam t => ret (VLam t) end). diff --git a/tests/Makefile b/tests/Makefile index 77071558..ebe4c01f 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1,4 +1,4 @@ -.PHONY: all extraction +.PHONY: all extraction clean all: extraction @@ -7,10 +7,15 @@ all: extraction # ITree library # - Extract.v contains the extraction command for # MetaModule (and recursively its dependencies) +COQC=coqc -Q ../../theories ITree -Q . TestExtraction + extraction: cd extraction; \ - coqc -Q ../../theories ITree \ - -Q . TestExtraction \ - ./MetaModule.v \ - ./Extract.v + $(COQC) ./MetaModule.v; \ + $(COQC) ./Extract.v ocamlbuild extraction/MetaModule.native -no-links + +clean: + $(RM) {*,*/*}/*.{vo,glob} {*,*/*}/.*.aux + $(RM) -rf _build/ + $(RM) extraction/*.ml{i,} diff --git a/theories/Basics.v b/theories/Basics.v index e2aaa86d..fd5227d1 100644 --- a/theories/Basics.v +++ b/theories/Basics.v @@ -14,7 +14,7 @@ Set Universe Polymorphism. - Monad morphisms *) Notation "E ~> F" := (forall T, E T -> F T) - (at level 99, right associativity) : type_scope. + (at level 99, right associativity, only parsing) : type_scope. (** Identity morphism. *) Definition idM {E : Type -> Type} : E ~> E := fun _ e => e. diff --git a/theories/Basics_Functions.v b/theories/Basics_Functions.v new file mode 100644 index 00000000..7b33dc1a --- /dev/null +++ b/theories/Basics_Functions.v @@ -0,0 +1,195 @@ +(** * The Category of Functions + + Definitions to reason about Coq functions [A -> B] categorically. + + *) + +(* begin hide *) +From Coq Require Import + Morphisms + Program.Basics + Program.Combinators. + +Set Universe Polymorphism. +(* end hide *) + +(* From [Program.Basics] and [Program.Combinators]: + + id : A -> A (* This one is from [Init.Datatypes] *) + compose : (B -> C) -> (A -> B) -> (A -> C) + Infix "∘" = compose + + compose_id_right : f ∘ id = f + compose_id_left : id ∘ f = f + compose_assoc : (f ∘ g) ∘ h = f ∘ (g ∘ h) + *) + +(** Extensional function equality *) +Definition eeq {A B} : (A -> B) -> (A -> B) -> Prop := + fun f g => forall a : A, f a = g a. + +Instance subrelation_eeq_eqeq {A B} : + @subrelation (A -> B) eeq (@eq A ==> @eq B)%signature := {}. +Proof. congruence. Qed. + +Instance Equivalence_eeq {A B} : Equivalence (@eeq A B). +Proof. constructor; congruence. Qed. + +Instance eq_compose {A B C} : + Proper (eeq ==> eeq ==> eeq) (@compose A B C). +Proof. cbv; congruence. Qed. + +(** * [Empty_set] as an initial object. *) + +Notation from_Empty_set := + (fun v : Empty_set => match v with end) + (only parsing). + +(** * [sum] as a tensor product. *) + +Definition sum_elim {A B C} (f : A -> C) (g : B -> C) : A + B -> C := + fun x => + match x with + | inl a => f a + | inr b => g b + end. + +Definition sum_bimap {A B C D} (f : A -> B) (g : C -> D) : + A + C -> B + D := + sum_elim (inl ∘ f) (inr ∘ g). + +Definition sum_map_l {A B C} (f : A -> B) : A + C -> B + C := + sum_bimap f id. + +Definition sum_map_r {A B C} (f : A -> B) : C + A -> C + B := + sum_bimap id f. + +Definition sum_assoc_r {A B C} (abc : (A + B) + C) : A + (B + C) := + match abc with + | inl (inl a) => inl a + | inl (inr b) => inr (inl b) + | inr c => inr (inr c) + end. + +Definition sum_assoc_l {A B C} (abc : A + (B + C)) : (A + B) + C := + match abc with + | inl a => inl (inl a) + | inr (inl b) => inl (inr b) + | inr (inr c) => inr c + end. + +Definition sum_comm {A B} : A + B -> B + A := + sum_elim inr inl. + +Definition sum_empty_l {A} : Empty_set + A -> A := + sum_elim from_Empty_set id. + +Definition sum_empty_r {A} : A + Empty_set -> A := + sum_elim id from_Empty_set. + +Definition sum_merge {A} : A + A -> A := sum_elim id id. + +(** ** Equational theory *) + +Lemma compose_sum_elim {A B C D} (ac : A -> C) (bc : B -> C) (cd : C -> D) : + eeq (cd ∘ sum_elim ac bc) + (sum_elim (cd ∘ ac) (cd ∘ bc)). +Proof. intros []; auto. Qed. + +Lemma sum_elim_inl {A B C} (f : A -> C) (g : B -> C) : + sum_elim f g ∘ inl = f. +Proof. reflexivity. Qed. + +Lemma sum_elim_inr {A B C} (f : A -> C) (g : B -> C) : + sum_elim f g ∘ inr = g. +Proof. reflexivity. Qed. + +Lemma sum_elim_inl' {A B C D} (f : A -> C) (g : B -> C) (h : D -> A) : + sum_elim f g ∘ (inl ∘ h) = f ∘ h. +Proof. reflexivity. Qed. + +Lemma sum_elim_inr' {A B C D} (f : A -> C) (g : B -> C) (h : D -> B) : + sum_elim f g ∘ (inr ∘ h) = g ∘ h. +Proof. reflexivity. Qed. + +Lemma unfold_sum_assoc_r {A B C} : + @sum_assoc_r A B C = sum_elim (sum_elim inl (inr ∘ inl)) (inr ∘ inr). +Proof. cbv; auto. Qed. + +Instance eeq_sum_elim {A B C} : + Proper (eeq ==> eeq ==> eeq) (@sum_elim A B C). +Proof. cbv; intros; subst; destruct _; auto. Qed. + +Hint Rewrite @sum_elim_inl : sum_elim. +Hint Rewrite @sum_elim_inr : sum_elim. +Hint Rewrite @sum_elim_inl' : sum_elim. +Hint Rewrite @sum_elim_inr' : sum_elim. + +(** ** Automatic solver of reassociating sums *) + +Class ReSum (A B : Type) := + resum : A -> B. + +Instance ReSum_id A : ReSum A A := id. +Instance ReSum_sum A B C `{ReSum A C} `{ReSum B C} : ReSum (A + B) C := + sum_elim resum resum. +Instance ReSum_inl A B C `{ReSum A B} : ReSum A (B + C) := + inl ∘ resum. +Instance ReSum_inr A B C `{ReSum A B} : ReSum A (C + B) := + inr ∘ resum. + +(* Usage template: + +[[ +Opaque compose. +Opaque id. +Opaque sum_elim. + +Definition f {X Y Z} : complex_sum -> another_complex_sum := + Eval compute in resum. + +Transparent compose. +Transparent id. +Transparent sum_elim. +]] +*) + +(** * Bijections *) + +Class Iso {A B} (f : A -> B) (f' : B -> A) : Type := + { iso_ff' : forall a, f' (f a) = a; + iso_f'f : forall b, f (f' b) = b; + }. + +Instance Iso_id {A} : Iso (@id A) id := {}. +Proof. all: auto. Qed. + +Instance Iso_sum_assoc_l {A B C} : Iso (@sum_assoc_l A B C) sum_assoc_r := {}. +Proof. + - intros. destruct a as [| []]; auto. + - intros. destruct b as [[] |]; auto. +Qed. + +Instance Iso_sum_assoc_r {A B C} : Iso (@sum_assoc_r A B C) sum_assoc_l := {}. +Proof. + - intros. destruct a as [[] |]; auto. + - intros. destruct b as [| []]; auto. +Qed. + +Instance Iso_compose {A B C} (f : A -> B) (g : B -> C) + {f' : B -> A} `{Iso _ _ f f'} + {g' : C -> B} `{Iso _ _ g g'} : Iso (compose g f) (compose f' g') := {}. +Proof. + all: intro a; cbv; rewrite ?iso_ff', ?iso_f'f; auto. +Qed. + +Instance Iso_sum_comm {A B} : @Iso (A + B) _ sum_comm sum_comm := {}. +Proof. all: intros []; auto. Qed. + +Instance Iso_sum_bimap {A B C D} (f : A -> B) (g : C -> D) + {f' : B -> A} `{Iso _ _ f f'} + {g' : D -> C} `{Iso _ _ g g'} : + Iso (sum_bimap f g) (sum_bimap f' g') := {}. +Proof. + all: intros []; cbv; rewrite ?iso_ff', ?iso_f'f; auto. +Qed. diff --git a/theories/Core.v b/theories/Core.v index 029077b2..f8fd2dab 100644 --- a/theories/Core.v +++ b/theories/Core.v @@ -65,13 +65,15 @@ End itree. Arguments itree _ _ : clear implicits. Arguments itreeF _ _ : clear implicits. +Notation itree' E R := (itreeF E R (itree E R)). + Definition observe {E R} := @_observe E R. Ltac fold_observe := change @_observe with @observe in *. Ltac unfold_observe := unfold observe in *. -Ltac genobs x ox := remember (observe x) as ox; simpl observe. - +Ltac genobs x ox := remember (observe x) as ox. +Ltac genobs_clear x ox := genobs x ox; match goal with [H: ox = observe x |- _] => clear H x end. Ltac simpobs := fold_observe; repeat match goal with [H: _ = observe _ |- _] => rewrite_everywhere_except (@eq_sym _ _ _ H) H @@ -121,6 +123,11 @@ Definition bind {E T U} : itree E U := bind' k c. +Definition cat {E T U V} + (k : T -> itree E U) (h : U -> itree E V) : + T -> itree E V := + fun t => bind (k t) h. + (* note(gmm): There needs to be generic automation for monads to simplify * using the monad laws up to a setoid. * this would be *really* useful to a lot of projects. @@ -145,7 +152,7 @@ CoFixpoint spin {E R} : itree E R := Tau spin. (** Repeat a computation infinitely. *) Definition forever {E R S} (t : itree E R) : itree E S := - cofix forever_t := bind t (fun _ => Tau forever_t). + cofix forever_t := bind t (fun _ => Tau (forever_t)). (* this definition exists in ExtLib (or should because it is * generic to Monads) @@ -174,6 +181,7 @@ Notation "t1 ;; t2" := (ITree.bind t1 (fun _ => t2)) Notation "' p <- t1 ;; t2" := (ITree.bind t1 (fun x_ => match x_ with p => t2 end)) (at level 100, t1 at next level, p pattern, right associativity) : itree_scope. +Infix ">=>" := ITree.cat (at level 50, left associativity) : itree_scope. Instance Functor_itree {E} : Functor (itree E) := { fmap := @ITree.map E }. diff --git a/theories/Effect/Sum.v b/theories/Effect/Sum.v index 3be1b0cd..8d7a737f 100644 --- a/theories/Effect/Sum.v +++ b/theories/Effect/Sum.v @@ -15,6 +15,9 @@ From ITree Require Import Variant sum1 (E1 E2 : Type -> Type) (X : Type) : Type := | inl1 (_ : E1 X) | inr1 (_ : E2 X). +Arguments inr1 {_ _} [_] _. +Arguments inl1 {_ _} [_] _. + Notation "E1 +' E2" := (sum1 E1 E2) (at level 60, right associativity) : type_scope. @@ -29,6 +32,16 @@ Module Sum1. (* Just for this section, [A B C D : Type -> Type] are more effect types. *) +Definition elim_emptyE {A} : emptyE ~> A := + fun X (e : emptyE X) => match e with end. + +Definition idE {A : Type -> Type} : A ~> A := + fun X (e : A X) => e. + +Definition cmpE {A B C : Type -> Type} : (B ~> C) -> (A ~> B) -> (A ~> C) := + fun g f X a => g X (f X a). + + (** [Sum1.swap] *) Definition swap {A B : Type -> Type} : A +' B ~> B +' A := fun _ ab => @@ -39,7 +52,7 @@ Definition swap {A B : Type -> Type} : A +' B ~> B +' A := (** [Sum1.bimap] *) Definition bimap {A B C D : Type -> Type} - (f : A ~> B) (g : B ~> D) : A +' B ~> B +' D := + (f : A ~> B) (g : C ~> D) : A +' C ~> B +' D := fun _ ab => match ab with | inl1 a => inl1 (f _ a) @@ -54,4 +67,19 @@ Definition elim {A B C : Type -> Type} | inr1 b => g _ b end. +(** [Sum1.assoc] *) +Definition assoc {A B C : Type -> Type} : A +' (B +' C) ~> (A +' B) +' C := + fun _ abc => + match abc with + | inl1 a => inl1 (inl1 a) + | inr1 (inl1 b) => inl1 (inr1 b) + | inr1 (inr1 c) => inr1 c + end. + +Definition emptyE_left {A : Type -> Type} : emptyE +' A ~> A := + elim elim_emptyE idE. + +Definition emptyE_right {A : Type -> Type} : A +' emptyE ~> A := + elim idE elim_emptyE. + End Sum1. diff --git a/theories/Eq/Eq.v b/theories/Eq/Eq.v index e179b6bb..dd9a278a 100644 --- a/theories/Eq/Eq.v +++ b/theories/Eq/Eq.v @@ -8,284 +8,446 @@ From Coq Require Import Program Setoid Morphisms - RelationClasses - ProofIrrelevance. + RelationClasses. From Paco Require Import paco. From ITree Require Import Core. -Ltac auto_inj_pair2 := - repeat (match goal with - | [ H : _ |- _ ] => apply inj_pair2 in H - end). +From ITree Require Export + Eq.Shallow. -Lemma pointwise_relation_fold {A B} {r: relation B} f g: (forall v:A, r (f v) (g v)) -> pointwise_relation _ r f g. - Proof. red. eauto. Qed. +(* Taken from paco-v2.0.3: BEGIN *) -Section eq_itree. - Context {E : Type -> Type} {R : Type}. +Lemma paco2_mon_bot {T0 T1} (gf gf': rel2 T0 T1 -> rel2 T0 T1) r' x0 x1 + (REL: paco2 gf bot2 x0 x1) + (LEgf: gf <3= gf'): + paco2 gf' r' x0 x1. +Proof. + eapply paco2_mon_gen; [apply REL | apply LEgf | intros; contradiction PR]. +Qed. - Inductive eq_itreeF' (sim : relation (itree E R)) : relation (itreeF E R (itree E R)) := - | EqRet : forall x, eq_itreeF' sim (RetF x) (RetF x) - | EqTau : forall m1 m2 - (REL: sim m1 m2), eq_itreeF' sim (TauF m1) (TauF m2) - | EqVis : forall {u} (e : E u) k1 k2 - (REL: forall v, sim (k1 v) (k2 v)), - eq_itreeF' sim (VisF e k1) (VisF e k2) - . - Hint Constructors eq_itreeF'. +Lemma upaco2_mon_bot {T0 T1} (gf gf': rel2 T0 T1 -> rel2 T0 T1) r' x0 x1 + (REL: upaco2 gf bot2 x0 x1) + (LEgf: gf <3= gf'): + upaco2 gf' r' x0 x1. +Proof. + eapply upaco2_mon_gen; [apply REL | apply LEgf | intros; contradiction PR]. +Qed. - Global Instance Reflexive_eq_itreeF' sim - : Reflexive sim -> Reflexive (eq_itreeF' sim). - Proof. - red. destruct x; eauto. - Qed. +Lemma rclo2_mon_gen {T0 T1} gf gf' (clo clo': rel2 T0 T1 -> rel2 T0 T1) r r' e0 e1 + (REL: rclo2 gf clo r e0 e1) + (LEgf: gf <3= gf') + (LEclo: clo <3= clo') + (LEr: r <2= r') : + rclo2 gf' clo' r' e0 e1. +Proof. + induction REL. + - econstructor 1. apply LEr, R. + - econstructor 2; [intros; eapply H, PR| apply LEclo, CLOR']. + - econstructor 3; [intros; eapply H, PR| apply LEgf, CLOR']. +Qed. - Global Instance Symmetric_eq_itreeF' sim - : Symmetric sim -> Symmetric (eq_itreeF' sim). - Proof. - red. inversion 2; eauto. - Qed. +Arguments paco2_fold {T0 T1} gf. +Arguments paco2_unfold {T0 T1} gf. - Global Instance Transitive_eq_itreeF' sim - : Transitive sim -> Transitive (eq_itreeF' sim). - Proof. - red. inversion 2; inversion 1; eauto. - subst. dependent destruction H6. dependent destruction H7. eauto. - Qed. +Ltac pfold_reverse := + match goal with + | [|- ?gf (upaco2 _ _) _ _] => eapply (paco2_unfold gf) + | [|- ?gf (?gres (upaco2 _ _)) _ _] => eapply (paco2_unfold (compose gf gres)) + end; eauto with paco. - Definition eq_itreeF (sim: relation (itree E R)) : relation (itree E R) := - fun t1 t2 => eq_itreeF' sim (observe t1) (observe t2). - Hint Unfold eq_itreeF. +Ltac punfold_reverse H := + let PP := type of H in + match PP with + | ?gf (upaco2 _ _) _ _ => eapply (paco2_fold gf) in H + | ?gf (?gres (upaco2 _ _)) _ _ => eapply (paco2_fold (compose gf gres)) in H + end; eauto with paco. - Lemma eq_itreeF'_mono : forall x0 x1 r r' - (IN: eq_itreeF' r x0 x1) (LE: forall x2 x3, (r x2 x3 : Prop) -> r' x2 x3 : Prop), eq_itreeF' r' x0 x1. - Proof. pmonauto. Qed. +(* Taken from paco-v2.0.3: END*) - Lemma eq_itreeF_mono : monotone2 eq_itreeF. - Proof. do 2 red. pmonauto. Qed. - Definition eq_itree : relation (itree E R) := paco2 eq_itreeF bot2. - Global Instance Reflexive_eq_itreeF sim - : Reflexive sim -> Reflexive (eq_itreeF sim). - Proof. red; red; reflexivity. Qed. +(* TODO: Send to paco *) +Global Instance Symmetric_bot2 (A : Type) : @Symmetric A bot2. +Proof. auto. Qed. - Global Instance Symmetric_eq_itreeF sim - : Symmetric sim -> Symmetric (eq_itreeF sim). - Proof. red; red; symmetry; auto. Qed. +Global Instance Transitive_bot2 (A : Type) : @Transitive A bot2. +Proof. auto. Qed. - Global Instance Transitive_eq_itreeF sim - : Transitive sim -> Transitive (eq_itreeF sim). - Proof. red; red; etransitivity; eauto. Qed. +Section eq_itree. + Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + + Inductive eq_itreeF {I J} (sim : I -> J -> Prop) : + itreeF E R1 I -> itreeF E R2 J -> Prop := + | EqRet : forall r1 r2, RR r1 r2 -> eq_itreeF sim (RetF r1) (RetF r2) + | EqTau : forall m1 m2 + (REL: sim m1 m2), eq_itreeF sim (TauF m1) (TauF m2) + | EqVis : forall {u} (e : E u) k1 k2 + (REL: forall v, sim (k1 v) (k2 v)), + eq_itreeF sim (VisF e k1) (VisF e k2) + . + Hint Constructors eq_itreeF. + + Definition eq_itree_ (sim: itree E R1 -> itree E R2 -> Prop) : + itree E R1 -> itree E R2 -> Prop := + fun t1 t2 => eq_itreeF sim (observe t1) (observe t2). + Hint Unfold eq_itree_. + + Lemma eq_itreeF_mono I J x0 x1 (r r' : I -> J -> Prop) : + forall + (IN: eq_itreeF r x0 x1) + (LE: forall x2 x3, r x2 x3 -> r' x2 x3 : Prop), + eq_itreeF r' x0 x1. + Proof. pmonauto. Qed. + + Lemma eq_itree__mono : monotone2 eq_itree_. + Proof. do 2 red. pmonauto. Qed. + + Definition eq_itree : itree E R1 -> itree E R2 -> Prop := + paco2 eq_itree_ bot2. End eq_itree. -Hint Constructors eq_itreeF'. -Hint Unfold eq_itreeF. -Hint Resolve eq_itreeF_mono : paco. +Hint Constructors eq_itreeF. +Hint Unfold eq_itree_. +Hint Resolve eq_itree__mono : paco. Hint Unfold eq_itree. -Definition go_sim {E R} (r: relation (itree E R)) : relation (itreeF E R (itree E R)) := - fun ot1 ot2 => r (go ot1) (go ot2). - Ltac unfold_eq_itree := - (try match goal with [|- eq_itreeF _ _ _ ] => red end); - (repeat match goal with [H: eq_itreeF _ _ _ |- _ ] => red in H end). + (try match goal with [|- eq_itree_ _ _ _ _ ] => red end); + (repeat match goal with [H: eq_itree_ _ _ _ _ |- _ ] => red in H end). + +Lemma flip_eq_itree {E R1 R2} (RR : R1 -> R2 -> Prop) : + forall (u : itree E R1) (v : itree E R2), + eq_itree RR u v -> eq_itree (flip RR) v u. +Proof. + pcofix self. + intros u v euv. pfold. punfold euv. unfold_eq_itree. + destruct euv; pclearbot; auto 10. +Qed. Delimit Scope eq_itree_scope with eq_itree. (* note(gmm): overriding `=` seems like a bad idea *) -Notation "t1 ≅ t2" := (eq_itree t1%itree t2%itree) (at level 70). +Notation "t1 ≅ t2" := (eq_itree eq t1%itree t2%itree) (at level 70). (* you can write ≅ using \cong in tex-mode *) +Section eq_itree_h. -(* Some simple congruences -------------------------------------------------- *) +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). -Lemma itree_eq_tau : forall {E R} (t1 t2 : itree E R), - t1 ≅ t2 -> Tau t1 ≅ Tau t2. +Lemma itree_eq_tau (t1 : itree E R1) (t2 : itree E R2) : + eq_itree RR t1 t2 -> eq_itree RR (Tau t1) (Tau t2). Proof. - intros E R t1 t2 H. - pfold. econstructor. left. assumption. + intro; pfold. econstructor. left. assumption. Qed. -Lemma itree_eq_vis : forall {E R S} (e : E R) (k1 k2 : R -> itree E S) - (h : forall (r:R), (k1 r) ≅ (k2 r)), Vis e k1 ≅ Vis e k2. +Lemma itree_eq_vis {U} (e : E U) + (k1 : U -> itree E R1) (k2 : U -> itree E R2) : + (forall u, eq_itree RR (k1 u) (k2 u)) -> + eq_itree RR (Vis e k1) (Vis e k2). Proof. - intros E R S e k1 k2 h. - pfold. econstructor. intros v. left. apply h. -Qed. + intro H; pfold. econstructor. intros v. left. eapply H. +Qed. +Inductive eq_itree_trans_clo (r : itree E R1 -> itree E R2 -> Prop) : + itree E R1 -> itree E R2 -> Prop := +| eq_itree_trans_clo_intro t1 t2 t3 t4 + (EQVl: eq_itree eq t1 t2) + (EQVr: eq_itree eq t4 t3) + (RELATED: r t2 t3) + : eq_itree_trans_clo r t1 t4 +. +Hint Constructors eq_itree_trans_clo. -Lemma eq_itree_refl {E R} r x : paco2 (@eq_itreeF E R) r x x. +Lemma eq_itree_clo_trans : weak_respectful2 (eq_itree_ RR) eq_itree_trans_clo. Proof. - revert x. pcofix CIH; intros. - pfold. unfold_eq_itree. destruct (observe x); eauto. + econstructor; [pmonauto|]. + intros. dependent destruction PR. + apply GF in RELATED. + punfold EQVl. punfold EQVr. red in RELATED. red. unfold_eq_itree. + inversion EQVl; clear EQVl; + inversion EQVr; clear EQVr; + inversion RELATED; clear RELATED; + subst; simpobs; try discriminate. + + - inversion H0; inversion H3; auto. + - inversion H; inversion H3; subst; pclearbot; eauto using rclo2. + + - inversion H; inversion H3; subst; auto_inj_pair2; subst. + pclearbot. + econstructor. intros. specialize (REL v). specialize (REL0 v). pclearbot. eauto using rclo2. Qed. -Hint Resolve eq_itree_refl : refl. -Global Instance Reflexive_eq_itree {E R} : Reflexive (@eq_itree E R). +Inductive eq_itree_bind_clo (r : itree E R1 -> itree E R2 -> Prop) : + itree E R1 -> itree E R2 -> Prop := +| pbc_intro_h U1 U2 (RU : U1 -> U2 -> Prop) t1 t2 k1 k2 + (EQV: eq_itree RU t1 t2) + (REL: forall u1 u2, RU u1 u2 -> r (k1 u1) (k2 u2)) + : eq_itree_bind_clo r (ITree.bind t1 k1) (ITree.bind t2 k2) +. +Hint Constructors eq_itree_bind_clo. + +Lemma eq_itree_clo_bind : + weak_respectful2 (eq_itree_ RR) eq_itree_bind_clo. Proof. - eauto with refl. + econstructor; try pmonauto. + intros. dependent destruction PR. + punfold EQV. unfold_eq_itree. + rewrite !unfold_bind; inv EQV; simpobs. + - eapply eq_itreeF_mono; [eapply GF |]; eauto using rclo2. + - simpl. fold_bind. pclearbot. eauto 7 using rclo2. + - econstructor. + intros x. specialize (REL0 x). fold_bind. pclearbot. eauto 7 using rclo2. Qed. -Global Instance Symmetric_eq_itree {E R} : Symmetric (@eq_itree E R). +End eq_itree_h. + +Arguments eq_itree_clo_trans : clear implicits. +Arguments eq_itree_clo_bind : clear implicits. + +Hint Constructors eq_itree_trans_clo. +Hint Constructors eq_itree_bind_clo. + +Section eq_itree_eq. + Context {E : Type -> Type} {R : Type}. + + Let eq_itreeF {I J} := @eq_itreeF E R _ eq I J. + Let eq_itree_ := @eq_itree_ E R _ eq. + Let eq_itree := @eq_itree E R _ eq. + + Global Instance Reflexive_eq_itreeF I (sim : I -> I -> Prop) + : Reflexive sim -> Reflexive (eq_itreeF sim). + Proof. + red. destruct x; constructor; eauto. + Qed. + + Global Instance Symmetric_eq_itreeF I (sim : I -> I -> Prop) + : Symmetric sim -> Symmetric (eq_itreeF sim). + Proof. + red. inversion 2; constructor; eauto. + Qed. + + Global Instance Transitive_eq_itreeF I (sim : I -> I -> Prop) + : Transitive sim -> Transitive (eq_itreeF sim). + Proof. + red. inversion 2; inversion 1; subst; repeat auto_inj_pair2; subst; constructor; eauto. + Qed. + + Global Instance Reflexive_eq_itree_ sim + : Reflexive sim -> Reflexive (eq_itree_ sim). + Proof. repeat red. reflexivity. Qed. + + Global Instance Symmetric_eq_itree_ sim + : Symmetric sim -> Symmetric (eq_itree_ sim). + Proof. repeat red; symmetry; auto. Qed. + + Global Instance Transitive_eq_itree_ sim + : Transitive sim -> Transitive (eq_itree_ sim). + Proof. repeat red; etransitivity; eauto. Qed. + +Global Instance Reflexive_eq_itree r : Reflexive (paco2 eq_itree_ r). +Proof. + pcofix CIH; intros. + pfold. do 2 red. destruct (observe x); eauto. +Qed. + +Global Instance Symmetric_eq_itree r (SYMr : Symmetric r) : + Symmetric (paco2 eq_itree_ r). Proof. pcofix CIH; intros. - pfold. unfold_eq_itree. punfold H0. inv H0; eauto. - - pclearbot. eauto. - - econstructor. intros. specialize (REL v). pclearbot. eauto. + pfold. do 2 red. punfold H0. inv H0; eauto. + - constructor; destruct REL; eauto. + - constructor. intros. destruct (REL v); eauto. Qed. -Global Instance Transitive_eq_itree {E R} : Transitive (@eq_itree E R). +Global Instance Transitive_eq_itree : Transitive eq_itree. Proof. pcofix CIH. intros. - pfold. punfold H0. punfold H1. unfold_eq_itree. - genobs x ox; genobs y oy; genobs z oz. - remember oy as oy' in H1. - destruct H0, H1; inversion Heqoy'; subst; auto. + pfold. red. + punfold H0; red in H0. + punfold H1; red in H1. + destruct H0; inversion H1; subst; eauto. - pclearbot; eauto. - - apply inj_pair2 in H1. - apply inj_pair2 in H2. + - auto_inj_pair2; subst. subst; econstructor. intros. specialize (REL v). specialize (REL0 v). pclearbot. eauto. Qed. -Global Instance Equivalence_eq_itree {E R} : - Equivalence (@eq_itree E R). +Global Instance Equivalence_eq_itree : Equivalence eq_itree. Proof. constructor; typeclasses eauto. Qed. -Global Instance Equivalence_go_eq_itree {E R} : - Equivalence (go_sim (@eq_itree E R)). +Global Instance eq_itree_observe : + Proper (eq_itree ==> going eq_itree) (@observe E R). Proof. - constructor; repeat intro; red; eauto with refl. - - symmetry; eauto. - - etransitivity; eauto. + constructor; punfold H. pfold. eapply eq_itreeF_mono; eauto. Qed. -Instance eq_itree_go {E R} : - Proper (go_sim (@eq_itree E R) ==> @eq_itree E R) (@go E R). +Global Instance eq_itree_tauF : + Proper (eq_itree ==> going eq_itree) (@TauF E R _). Proof. - repeat intro. eauto. + constructor; pfold. econstructor. eauto. Qed. -Instance eq_itree_observe {E R} : - Proper (@eq_itree E R ==> go_sim (@eq_itree E R)) (@observe E R). +Global Instance eq_itree_VisF {u} (e: E u) : + Proper (pointwise_relation _ eq_itree ==> going eq_itree) (VisF e). Proof. - repeat intro. punfold H. pfold. eapply eq_itreeF_mono; eauto. + constructor; red in H. pfold; econstructor. left. apply H. Qed. -Instance eq_itree_tauF {E R} : - Proper (@eq_itree E R ==> go_sim (@eq_itree E R)) (@TauF E R _). + Global Instance observing_eq_itree_eq_ r `{Reflexive _ r} : + subrelation (observing eq) (eq_itree_ r). + Proof. + repeat red; intros x _ [[]]; destruct observe; auto. + Qed. + + Global Instance observing_eq_itree_eq : + subrelation (observing eq) eq_itree. + Proof. + repeat red; intros; pfold. apply observing_eq_itree_eq_; auto. + left; apply reflexivity. + Qed. + +Lemma itree_eta (t : itree E R) : t ≅ go (observe t). +Proof. apply observing_eq_itree_eq. econstructor. reflexivity. Qed. + +Lemma itree_eta' (ot : itree' E R) : ot = observe (go ot). +Proof. reflexivity. Qed. + +End eq_itree_eq. + + +Lemma eq_itree_tau {E R1 R2} (RR : R1 -> R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : + eq_itree RR t1 t2 -> eq_itree RR (Tau t1) (Tau t2). Proof. - repeat intro. pfold. econstructor. eauto. + intros; pfold; constructor; auto. Qed. -Instance eq_itree_VisF {E R u} (e: E u) : - Proper (pointwise_relation _ eq_itree ==> go_sim (@eq_itree E R)) (VisF e). +Lemma eq_itree_vis {E R1 R2} (RR : R1 -> R2 -> Prop) + {U} (e : E U) (k1 : U -> itree E R1) (k2 : U -> itree E R2) : + (forall u, eq_itree RR (k1 u) (k2 u)) -> + eq_itree RR (Vis e k1) (Vis e k2). Proof. - repeat intro. red in H. pfold. econstructor. left. apply H. + intros; pfold; constructor; left. apply H. Qed. -Lemma itree_eta {E R} (t: itree E R): t ≅ go (observe t). +Lemma eq_itree_ret {E R1 R2} (RR : R1 -> R2 -> Prop) r1 r2 : + RR r1 r2 -> @eq_itree E _ _ RR (Ret r1) (Ret r2). Proof. - pfold. red. cbn. eapply Reflexive_eq_itreeF'; eauto with refl. + intros; pfold; eauto; constructor; auto. Qed. -Lemma bind_unfold {E R S} - (t : itree E R) (k : R -> itree E S) : - observe (ITree.bind t k) = observe (ITree.bind_match k (ITree.bind' k) (observe t)). -Proof. eauto with refl. Qed. - -Lemma unfold_bind {E R S} - (t : itree E R) (k : R -> itree E S) : - ITree.bind t k ≅ ITree.bind_match k (ITree.bind' k) (observe t). -Proof. rewrite itree_eta, bind_unfold, <-itree_eta. eauto with refl. Qed. - -Lemma ret_bind {E R S} (r : R) : - forall k : R -> itree E S, - ITree.bind (Ret r) k ≅ (k r). +Lemma eq_itree_tau_inv {E R1 R2} (RR : R1 -> R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : + eq_itree RR (Tau t1) (Tau t2) -> eq_itree RR t1 t2. Proof. - intros. rewrite unfold_bind. eauto with refl. + intros H; punfold H; inversion H; pclearbot; auto. Qed. -Lemma tau_bind {E R} U t (k: U -> itree E R) : - ITree.bind (Tau t) k ≅ Tau (ITree.bind t k). +Lemma eq_itree_vis_inv {E R1 R2} (RR : R1 -> R2 -> Prop) + {U} (e : E U) (k1 : U -> itree E R1) (k2 : U -> itree E R2) : + eq_itree RR (Vis e k1) (Vis e k2) -> + (forall u, eq_itree RR (k1 u) (k2 u)). Proof. - setoid_rewrite unfold_bind at 1. eauto with refl. + intros H; punfold H; inversion H; pclearbot; auto_inj_pair2; subst; auto. Qed. -Lemma vis_bind {E R} U V (e: E V) (ek: V -> itree E U) (k: U -> itree E R) : - ITree.bind (Vis e ek) k ≅ Vis e (fun x => ITree.bind (ek x) k). +Lemma eq_itree_ret_inv {E R1 R2} (RR : R1 -> R2 -> Prop) r1 r2 : + @eq_itree E _ _ RR (Ret r1) (Ret r2) -> RR r1 r2. Proof. - setoid_rewrite unfold_bind at 1. eauto with refl. + intros H; punfold H; inversion H; pclearbot; auto_inj_pair2; subst; auto. Qed. -Inductive eq_itree_trans_clo {E R} (r: relation (itree E R)) : relation (itree E R) := -| eq_itree_trans_clo_intro (t1 t2 t3 t4: itree E R) - (EQVl: t1 ≅ t2) - (EQVr: t4 ≅ t3) - (RELATED: r t2 t3) - : eq_itree_trans_clo r t1 t4 -. -Hint Constructors eq_itree_trans_clo. +(* One-sided inversion *) -Lemma eq_itree_clo_trans E R: weak_respectful2 eq_itreeF (@eq_itree_trans_clo E R). +Lemma eq_itree_ret_inv1 {E R} (t : itree E R) r : + t ≅ Ret r -> observe t = RetF r. Proof. - econstructor; [pmonauto|]. - intros. dependent destruction PR. - apply GF in RELATED. - punfold EQVl. punfold EQVr. unfold_eq_itree. - genobs t1 ot1; genobs t2 ot2; genobs t3 ot3; genobs t4 ot4. - destruct EQVl; - inversion EQVr; clear EQVr; - inversion RELATED; clear RELATED; - subst; simpobs; try discriminate. + intros; punfold H; inversion H; subst; auto. +Qed. - - inversion H0; auto. - - inversion H0; subst; pclearbot; eauto using rclo2. +Lemma eq_itree_vis_inv1 {E R U} (t : itree E R) (e : E U) (k : U -> _) : + t ≅ Vis e k -> exists k', observe t = VisF e k' /\ forall u, k' u ≅ k u. +Proof. + intros; punfold H; inversion H; subst; auto_inj_pair2; subst; pclearbot; eauto. +Qed. - - inversion H0; subst; auto_inj_pair2; subst. - pclearbot. - econstructor. intros. specialize (REL v). specialize (REL0 v). pclearbot. eauto using rclo2. +Lemma eq_itree_tau_inv1 {E R} (t t' : itree E R) : + t ≅ Tau t' -> exists t0, observe t = TauF t0 /\ t0 ≅ t'. +Proof. + intros; punfold H; inversion H; pclearbot; eauto. Qed. +(**) -Inductive eq_itree_bind_clo {E R} (r: relation (itree E R)) : relation (itree E R) := -| pbc_intro U t1 t2 (k1 k2: U -> _) - (EQV: t1 ≅ t2) - (REL: forall v, r (k1 v) (k2 v)) - : eq_itree_bind_clo r (ITree.bind t1 k1) (ITree.bind t2 k2) -. -Hint Constructors eq_itree_bind_clo. +(* TODO (LATER): I keep these [...bind_] lemmas around temporarily + in case I run some issues with slow typeclass resolution. *) -Lemma eq_itree_clo_bind E R: weak_respectful2 eq_itreeF (@eq_itree_bind_clo E R). -Proof. - econstructor; try pmonauto. - intros. dependent destruction PR. - punfold EQV. unfold_eq_itree. - rewrite !bind_unfold; inv EQV; simpobs. - - eapply eq_itreeF_mono; eauto using rclo2. - - simpl. fold_bind. pclearbot. eauto 7 using rclo2. - - econstructor. - intros x. specialize (REL0 x). fold_bind. pclearbot. eauto 7 using rclo2. -Qed. +Lemma unfold_bind_ {E R S} + (t : itree E R) (k : R -> itree E S) : + ITree.bind t k ≅ ITree.bind_match k (fun t => ITree.bind t k) (observe t). +Proof. rewrite unfold_bind. reflexivity. Qed. -Instance eq_itree_bind {E R S} : - Proper (@eq_itree E R ==> - pointwise_relation _ eq_itree ==> - @eq_itree E S) ITree.bind. +Lemma ret_bind_ {E R S} (r : R) (k : R -> itree E S) : + ITree.bind (Ret r) k ≅ (k r). +Proof. rewrite ret_bind. reflexivity. Qed. + +Lemma tau_bind_ {E R} U t (k: U -> itree E R) : + ITree.bind (Tau t) k ≅ Tau (ITree.bind t k). +Proof. rewrite tau_bind. reflexivity. Qed. + +Lemma vis_bind_ {E R} U V (e: E V) (ek: V -> itree E U) (k: U -> itree E R) : + ITree.bind (Vis e ek) k ≅ Vis e (fun x => ITree.bind (ek x) k). +Proof. rewrite vis_bind. reflexivity. Qed. + +Lemma eq_itree_bind {E R1 R2 S1 S2} (RR : R1 -> R2 -> Prop) + (RS : S1 -> S2 -> Prop) + t1 t2 k1 k2 : + eq_itree RR t1 t2 -> + (forall r1 r2, RR r1 r2 -> eq_itree RS (k1 r1) (k2 r2)) -> + @eq_itree E _ _ RS (ITree.bind t1 k1) (ITree.bind t2 k2). Proof. repeat intro. pupto2_init. pupto2 eq_itree_clo_bind. econstructor; eauto. - intros. pupto2_final. apply H0. + intros. pupto2_final; apply H0; auto. +Qed. + +Instance eq_itree_eq_bind {E R S} : + Proper (eq_itree eq ==> + pointwise_relation _ (eq_itree eq) ==> + eq_itree eq) (@ITree.bind E R S). +Proof. + repeat intro; eapply eq_itree_bind; eauto. + intros; subst; auto. +Qed. + +Lemma eq_itree_map {E R1 R2 S1 S2} (RR : R1 -> R2 -> Prop) + (RS : S1 -> S2 -> Prop) + f1 f2 t1 t2 : + (forall r1 r2, RR r1 r2 -> RS (f1 r1) (f2 r2)) -> + @eq_itree E _ _ RR t1 t2 -> + eq_itree RS (ITree.map f1 t1) (ITree.map f2 t2). +Proof. + unfold ITree.map; intros. + eapply eq_itree_bind; eauto. + intros; pfold; constructor; auto. +Qed. + +Instance eq_itree_eq_map {E R S} : + Proper (pointwise_relation _ eq ==> + eq_itree eq ==> + eq_itree eq) (@ITree.map E R S). +Proof. + repeat intro; eapply eq_itree_map; eauto. + intros; subst; auto. Qed. Instance eq_itree_paco {E R} r: - Proper (@eq_itree E R ==> @eq_itree E R ==> flip impl) - (paco2 (eq_itreeF ∘ gres2 eq_itreeF) r). + Proper (eq_itree eq ==> eq_itree eq ==> flip impl) + (paco2 (@eq_itree_ E R _ eq ∘ gres2 (eq_itree_ eq)) r). Proof. repeat intro. pupto2 eq_itree_clo_trans. eauto. Qed. @@ -295,7 +457,7 @@ Lemma bind_ret {E R} : ITree.bind s (fun x => Ret x) ≅ s. Proof. pcofix CIH. intros. - pfold. unfold_eq_itree. rewrite !bind_unfold. simpl. + pfold. unfold_eq_itree. rewrite !unfold_bind. simpl. genobs s os. destruct os; simpl; eauto. Qed. @@ -303,20 +465,42 @@ Lemma bind_bind {E R S T} : forall (s : itree E R) (k : R -> itree E S) (h : S -> itree E T), ITree.bind (ITree.bind s k) h ≅ ITree.bind s (fun r => ITree.bind (k r) h). Proof. - revert R S. pcofix CIH. intros. - pfold. unfold_eq_itree. rewrite !bind_unfold. - genobs s os; destruct os; unfold_bind; simpl; eauto. - eapply Reflexive_eq_itreeF'. eauto with refl. + pcofix CIH. intros. + pfold. unfold_eq_itree. + rewrite !unfold_bind. (* TODO: this is a bit slow (0.5s). *) + genobs s os; destruct os; unfold_bind; simpl; auto. + apply Reflexive_eq_itreeF. auto using reflexivity. Qed. Lemma map_map {E R S T}: forall (f : R -> S) (g : S -> T) (t : itree E R), ITree.map g (ITree.map f t) ≅ ITree.map (fun x => g (f x)) t. Proof. unfold ITree.map. intros. - pupto2_init. rewrite bind_bind. - pupto2 eq_itree_clo_bind. econstructor; eauto with refl. - intros. rewrite ret_bind. - pupto2_final. eauto with refl. + rewrite bind_bind. setoid_rewrite ret_bind. reflexivity. +Qed. + +Lemma map_bind {E R S T}: forall (f : R -> S) (k: S -> itree E T) (t : itree E R), + ITree.bind (ITree.map f t) k ≅ ITree.bind t (fun x => k (f x)). +Proof. + unfold ITree.map. intros. + rewrite bind_bind. setoid_rewrite ret_bind. reflexivity. +Qed. + +Lemma bind_map {E X Y Z} (t: itree E X) (k: X -> itree E Y) (f: Y -> Z) : + (ITree.map f (x <- t;; k x)) ≅ (x <- t;; ITree.map f (k x)). +Proof. + intros. + unfold ITree.map. + rewrite bind_bind. + reflexivity. +Qed. + +(* Used in KTree *) +Lemma map_is_cat {E} {R S: Type} (f: R -> S) (t: itree E R) : + ITree.map f t + ≅ ITree.cat (fun _:unit => t) (fun x => Ret (f x)) tt. +Proof. + intros; reflexivity. Qed. (* @@ -399,7 +583,9 @@ Proof. Qed. *) -Hint Rewrite @ret_bind : itree. -Hint Rewrite @tau_bind : itree. -Hint Rewrite @vis_bind : itree. +Hint Rewrite @ret_bind_ : itree. +Hint Rewrite @tau_bind_ : itree. +Hint Rewrite @vis_bind_ : itree. +Hint Rewrite @map_bind : itree. Hint Rewrite @bind_ret : itree. +Hint Rewrite @bind_bind : itree. diff --git a/theories/Eq/Shallow.v b/theories/Eq/Shallow.v new file mode 100644 index 00000000..f2aff5fa --- /dev/null +++ b/theories/Eq/Shallow.v @@ -0,0 +1,139 @@ +(** * Shallow equivalence *) + +(** Equality under [observe]: + +[[ + observing eq t1 t2 <-> t1.(observe) = t2.(observe) +]] + + We actually define a more general relation transformer + [observing] to lift arbitrary relations through [observe]. *) + +From ITree Require Import Core. + +From Coq Require Import + Classes.RelationClasses + Classes.Morphisms + Setoids.Setoid + Relations.Relations + ProofIrrelevance. + +(** ** Misc *) + +(** Rewrite all heterogeneous equalities with the axiom + [inj_pair2 : existT _ T a = existT _ T b -> a = b]. *) +Ltac auto_inj_pair2 := + repeat (match goal with + | [ H : _ |- _ ] => apply inj_pair2 in H + end). + +Lemma pointwise_relation_fold {A B} {r: relation B} f g : + (forall v:A, r (f v) (g v)) -> pointwise_relation _ r f g. +Proof. red. eauto. Qed. + +(**) + +(** ** [observing]: Lift relations through [observe]. *) +Inductive observing {E R1 R2} + (eq_ : itree' E R1 -> itree' E R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : Prop := +| observing_intros : + eq_ t1.(observe) t2.(observe) -> observing eq_ t1 t2. +Hint Constructors observing. + +Section observing_relations. + +Context {E : Type -> Type} {R : Type}. +Variable (eq_ : itree' E R -> itree' E R -> Prop). + +Global Instance observing_observe : + Proper (observing eq_ ==> eq_) (@observe E R). +Proof. intros ? ? []; cbv; auto. Qed. + +Global Instance observing_go : Proper (eq_ ==> observing eq_) (@go E R). +Proof. cbv; auto. Qed. + +Global Instance monotonic_observing eq_' : + subrelation eq_ eq_' -> + subrelation (observing eq_) (observing eq_'). +Proof. intros ? ? ? []; cbv; eauto. Qed. + +Global Instance Equivalence_observing : + Equivalence eq_ -> Equivalence (observing eq_). +Proof. + intros []; split; cbv; auto. + - intros ? ? []; auto. + - intros ? ? ? [] []; eauto. +Qed. + +End observing_relations. + +Lemma unfold_bind {E R S} + (t : itree E R) (k : R -> itree E S) : + observing eq + (ITree.bind t k) + (ITree.bind_match k (fun t => ITree.bind t k) (observe t)). +Proof. eauto. Qed. + +Instance observing_bind {E R S} : + Proper (observing eq ==> eq ==> observing eq) (@ITree.bind E R S). +Proof. + repeat intro; subst. + do 2 rewrite unfold_bind; rewrite H. + reflexivity. +Qed. + +Lemma ret_bind {E R S} (r : R) (k : R -> itree E S) : + observing eq (ITree.bind (Ret r) k) (k r). +Proof. apply unfold_bind. Qed. + +Lemma tau_bind {E R} U t (k: U -> itree E R) : + observing eq (ITree.bind (Tau t) k) (Tau (ITree.bind t k)). +Proof. apply @unfold_bind. Qed. + +Lemma vis_bind {E R U V} (e: E V) (ek: V -> itree E U) (k: U -> itree E R) : + observing eq + (ITree.bind (Vis e ek) k) + (Vis e (fun x => ITree.bind (ek x) k)). +Proof. apply @unfold_bind. Qed. + +Lemma unfold_forever {E R S} (t: itree E R): + observing eq (@ITree.forever E R S t) (ITree.bind t (fun _ => Tau (ITree.forever t))). +Proof. econstructor. reflexivity. Qed. + +(** ** [going]: Lift relations through [go]. *) + +Inductive going {E R1 R2} (r : itree E R1 -> itree E R2 -> Prop) + (ot1 : itree' E R1) (ot2 : itree' E R2) : Prop := +| going_intros : r (go ot1) (go ot2) -> going r ot1 ot2. +Hint Constructors going. + +Lemma observing_going {E R1 R2} (eq_ : itree' E R1 -> itree' E R2 -> Prop) ot1 ot2 : + going (observing eq_) ot1 ot2 <-> eq_ ot1 ot2. +Proof. + split; auto. + intros [[]]; auto. +Qed. + +Section going_relations. + +Context {E : Type -> Type} {R : Type}. +Variable (eq_ : itree E R -> itree E R -> Prop). + +Global Instance going_go : Proper (going eq_ ==> eq_) (@go E R). +Proof. intros ? ? []; auto. Qed. + +Global Instance monotonic_going eq_' : + subrelation eq_ eq_' -> + subrelation (going eq_) (going eq_'). +Proof. intros ? ? ? []; eauto. Qed. + +Global Instance Equivalence_going : + Equivalence eq_ -> Equivalence (going eq_). +Proof. + intros []; constructor; cbv; eauto. + - intros ? ? []; auto. + - intros ? ? ? [] []; eauto. +Qed. + +End going_relations. diff --git a/theories/Eq/SimUpToTaus.v b/theories/Eq/SimUpToTaus.v new file mode 100644 index 00000000..edc230e3 --- /dev/null +++ b/theories/Eq/SimUpToTaus.v @@ -0,0 +1,418 @@ +(** * Simulation Up To Tau *) + +(** A preorder [sutt t1 t2], where every visible step + ([RetF] or [VisF]) on the left must be matched with a corresponding + step on the right, ignoring [TauF]. + + In particular, [spin := Tau spin] is less than everything. + + The induced equivalence relation is [eutt]. + + Various [Proper] lemmas about [eutt] are more easily proved as + [Proper] lemmas about [sutt] first, and then symmetrizing using + [eutt_sutt] and [sutt_eutt]. + *) + +Require Import Paco.paco. + +From Coq Require Import + Classes.RelationClasses + Classes.Morphisms + Setoids.Setoid + Program + Relations.Relations. + +From ITree Require Import + Core. + +From ITree Require Import + Eq.UpToTausExplicit + Eq.UpToTaus. + +Section SUTT. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +Variant suttF (eutt : itree E R1 -> itree E R2 -> Prop) + (ot1 : itreeF E R1 (itree E R1)) + (ot2 : itreeF E R2 (itree E R2)) : Prop := +| suttF_ (FIN: finite_tausF ot1 -> finite_tausF ot2) + (EQV: forall ot1' ot2' + (UNTAUS1: unalltausF ot1 ot1') + (UNTAUS2: unalltausF ot2 ot2'), + eq_notauF RR eutt ot1' ot2') +. +Hint Constructors suttF. + +Lemma suttF_unpack eutt ot1 ot2 : + suttF eutt ot1 ot2 <-> + forall ot1', unalltausF ot1 ot1' -> + exists ot2', unalltausF ot2 ot2' /\ eq_notauF RR eutt ot1' ot2'. +Proof. + split. + - intros [] ot1' H1. + edestruct FIN; eauto. + - intros. constructor. + + intros []; auto. edestruct H as [? []]; eauto. + + intros; edestruct H as [y []]; eauto. + replace ot2' with y; auto. + eapply unalltaus_injective; eauto. +Qed. + +Variant suttF0 (eutt : itree E R1 -> itree E R2 -> Prop) + (ot1 : itreeF E R1 (itree E R1)) + (ot2 : itreeF E R2 (itree E R2)) : Prop := +| suttF0_notau ot2' : + notauF ot1 -> + unalltausF ot2 ot2' -> + eq_notauF RR eutt ot1 ot2' -> + suttF0 eutt ot1 ot2 +| suttF0_tau t1 : + ot1 = TauF t1 -> + suttF eutt (observe t1) ot2 -> + suttF0 eutt ot1 ot2 +. +Hint Constructors suttF0. + +Lemma sutt_inv eutt ot1 ot2 : + suttF eutt ot1 ot2 <-> + suttF0 eutt ot1 ot2. +Proof. + split; intros SUTT. + - destruct SUTT. destruct ot1. + + assert (Iuat1 : @unalltausF E _ (RetF r) (RetF r)). + { repeat constructor. } + edestruct FIN as [ot2' [Iuntaus Inotau]]. + { eauto. } + eapply suttF0_notau; eauto. + + eapply suttF0_tau; auto. + constructor. + * rewrite finite_taus_tau in FIN; auto. + * intros. apply EQV; auto. + eapply unalltaus_tau'; auto. + + assert (Iuat1 : @unalltausF E _ (VisF e k) (VisF e k)). + { repeat constructor. } + edestruct FIN as [ot2' [Iuntaus Inotau]]. + { eauto. } + eapply suttF0_notau; eauto. + - destruct SUTT. + + constructor; eauto. + intros; auto_untaus. + + subst; destruct H0; constructor. + * rewrite finite_taus_tau; auto. + * intros; auto_untaus. + eapply unalltaus_tau in UNTAUS1; auto. + apply EQV; auto. +Qed. + +Definition sutt_ (eutt : itree E R1 -> itree E R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : Prop := + suttF eutt (observe t1) (observe t2). +Hint Unfold sutt_. + +(* [sutt_] is monotone. *) +Lemma monotone_sutt_ : monotone2 sutt_. +Proof. pmonauto. Qed. +Hint Resolve monotone_sutt_ : paco. + +(* We now take the greatest fixpoint of [eutt_]. *) + +(* Equivalence Up To Taus. + + [eutt t1 t2]: [t1] is equivalent to [t2] up to taus. *) +Definition sutt : itree E R1 -> itree E R2 -> Prop := paco2 sutt_ bot2. + +Global Arguments sutt t1%itree t2%itree. + +End SUTT. + +Hint Constructors suttF. +Hint Unfold sutt_. +Hint Resolve monotone_sutt_ : paco. + +Hint Constructors suttF0. + +Lemma monotone_eq_notauF_RR {E R1 R2} (RR1 RR2 : R1 -> R2 -> Prop) + {I J} (r : I -> J -> Prop) : + (forall r1 r2, RR1 r1 r2 -> RR2 r1 r2) -> + forall t1 t2, eq_notauF RR1 r t1 t2 -> @eq_notauF E _ _ RR2 _ _ r t1 t2. +Proof. intros ? ? ? []; auto. Qed. + +Lemma monotone_sutt_RR {E R1 R2} (RR1 RR2 : R1 -> R2 -> Prop) r : + (forall r1 r2, RR1 r1 r2 -> RR2 r1 r2) -> + forall t1 t2, sutt_ RR1 r t1 t2 -> @sutt_ E _ _ RR2 r t1 t2. +Proof. + intros. induction H0. + constructor; auto. + intros. + edestruct EQV; eauto; + eapply monotone_eq_notauF_RR; eauto. +Qed. + +Theorem sutt_eutt {E R1 R2} (RR : R1 -> R2 -> Prop) : + forall (t1 : itree E R1) (t2 : itree E R2), + sutt RR t1 t2 -> sutt (flip RR) t2 t1 -> eutt RR t1 t2. +Proof. + intros. apply euttE_impl_eutt. revert_until RR. + pcofix self; intros t1 t2 H1 H2. + punfold H1. punfold H2. + destruct H1 as [FIN1 EQV1], H2 as [FIN2 EQV2]. + pfold; constructor. + - split; auto. + - intros. + eapply eq_notauF_and. + + intros ? ? I1 I2; right. + apply self; [ apply I1 | apply I2 ]. + + eapply monotone_eq_notauF; auto using EQV1. + intros; pclearbot; auto. + + apply eq_notauF_flip. + eapply monotone_eq_notauF; auto using EQV2. + intros; pclearbot; auto. +Qed. + +Theorem eutt_sutt {E R1 R2} (RR : R1 -> R2 -> Prop) r : + forall (t1 : itree E R1) (t2 : itree E R2), + paco2 (eutt_ RR) r t1 t2 -> paco2 (sutt_ RR) r t1 t2. +Proof. + intros. apply eutt_impl_euttE in H. revert_until r. + pcofix self; intros t1 t2 H1. + punfold H1. + destruct H1 as [FIN1 EQV1]. + pfold; constructor. + - apply FIN1. + - intros. + eapply monotone_eq_notauF; eauto. + intros ? ? []; auto. +Qed. + +Hint Resolve eutt_sutt. + +Section SUTT1. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +Inductive suttF1 (sutt: itree' E R1 -> itree' E R2 -> Prop) : + itree' E R1 -> itree' E R2 -> Prop := +| suttF1_ret r1 r2 : RR r1 r2 -> suttF1 sutt (RetF r1) (RetF r2) +| suttF1_vis u (e : E u) k1 k2 + (SUTTK: forall x, sutt (observe (k1 x)) (observe (k2 x))): + suttF1 sutt (VisF e k1) (VisF e k2) +| suttF1_tau_right ot1 t2 + (EQTAUS: suttF1 sutt ot1 (observe t2)): + suttF1 sutt ot1 (TauF t2) +| suttF1_tau_left t1 ot2 + (EQTAUS: sutt (observe t1) ot2): + suttF1 sutt (TauF t1) ot2 +. +Hint Constructors suttF1. + +Definition sutt1 (t1 : itree E R1) (t2 : itree E R2) := + paco2 suttF1 bot2 (observe t1) (observe t2). +Hint Unfold sutt1. + +End SUTT1. + +Hint Constructors suttF1. +Hint Unfold sutt1. + +Section SUTT1_rel. + +Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). + +Lemma reflexive_suttF1 `{Reflexive _ RR} sutt (r1:Reflexive sutt) : Reflexive (@suttF1 E _ _ RR sutt). +Proof. + unfold Reflexive. intros x. + destruct x; eauto. +Qed. + +End SUTT1_rel. + +Section SUTT1_facts. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +Lemma monotone_suttF1 : monotone2 (@suttF1 E _ _ RR). +Proof. repeat red; intros. induction IN; eauto. Qed. +Hint Resolve monotone_suttF1 : paco. + +Lemma sutt_to_sutt1 (r : _ -> _ -> Prop) (r' : _ -> _ -> Prop) + (IMPL_rr' : forall t1 t2, r t1 t2 -> observing r' t1 t2) : + forall (t1 : itree E R1) (t2 : itree E R2), + paco2 (sutt_ RR) r t1 t2 -> paco2 (suttF1 RR) r' (observe t1) (observe t2). +Proof. + pcofix self; intros t1 t2 SUTT. + punfold SUTT. pfold. + apply sutt_inv in SUTT. + destruct SUTT. + - destruct H0 as [Huntaus Hnotau]. + induction Huntaus. + + destruct H1; subst; auto. + constructor. intros x; edestruct (H0 x). + * right; auto. + * right; auto. apply self0. apply IMPL_rr'; auto. + + subst; auto. + - rewrite H; constructor. right; apply self. pfold; auto. +Qed. + +Lemma sutt1_to_sutt : forall (t1 : itree E R1) (t2 : itree E R2), + sutt1 RR t1 t2 -> sutt RR t1 t2. +Proof. + pcofix self; intros t1 t2 SUTT. + punfold SUTT. pfold. red. + induction SUTT. + - apply sutt_inv; eauto 7. + - pclearbot. apply sutt_inv; eapply suttF0_notau; eauto. + constructor; auto. + - destruct IHSUTT. constructor. + + rewrite finite_taus_tau; auto. + + intros. eapply unalltaus_tau in UNTAUS2; eauto. + - pclearbot. apply suttF_unpack. + intros. eapply unalltaus_tau in H; eauto. + destruct H as [Huntaus Hnotau]. + revert ot2 EQTAUS; induction Huntaus; intros. + + punfold EQTAUS. induction EQTAUS. + * eauto 9. + * eexists; split. + { repeat constructor. } + { pclearbot; constructor; auto. } + * destruct IHEQTAUS as [? []]; auto. + eauto using unalltaus_tau'. + * contradiction. + + punfold EQTAUS. induction EQTAUS; try discriminate. + * destruct IHEQTAUS as [? []]; auto. + eauto using unalltaus_tau'. + * pclearbot; inv OBS. eauto. +Qed. + +Lemma sutt_is_sutt1 (t1 : itree E R1) (t2 : itree E R2) : + sutt RR t1 t2 <-> sutt1 RR t1 t2. +Proof. + split. + - intros; eapply sutt_to_sutt1; try eassumption; auto. + - apply sutt1_to_sutt. +Qed. + +End SUTT1_facts. + +Hint Resolve @monotone_suttF1 : paco. + +(** Generalized heterogeneous version of [eutt_bind] *) +Lemma sutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: + forall t1 t2, + sutt RR t1 t2 -> + forall s1 s2, (forall r1 r2, RR r1 r2 -> sutt SS (s1 r1) (s2 r2)) -> + @sutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). +Proof. + intros; apply sutt_is_sutt1. + apply sutt_is_sutt1 in H. + revert t1 t2 H; pcofix self; intros. + punfold H1. + genobs t1 ot1. genobs t2 ot2. + revert t1 t2 Heqot1 Heqot2. + induction H1; intros. + - rewrite 2 unfold_bind, <- Heqot1, <- Heqot2; simpl. + eapply sutt_to_sutt1; [ | eapply H0; eauto]. intros ? ? []. + - rewrite 2 unfold_bind, <- Heqot1, <- Heqot2; simpl. + pclearbot. pfold; constructor. auto. + - rewrite (unfold_bind t0), <- Heqot2; simpl. + pfold; constructor. + apply paco2_unfold; [auto with paco |]. + eapply IHsuttF1; auto. + - rewrite (unfold_bind t0), <- Heqot1; simpl. + pfold; constructor. + pclearbot; subst; auto. +Qed. + +Require Import ITree.MorphismsFacts ITree.Morphisms. + +Require Import Coq.Relations.Relations. + +Lemma eq_itree_vis_l {E R1 R2} {RR : R1 -> R2 -> Prop} {C1 C2 RC T} + (e : E T) (k : _ -> _) + (it : itreeF E _ _) + (H : @eq_itreeF E R1 R2 RR C1 C2 RC (VisF e k) it) + : + exists k', it = VisF e k' /\ + (forall x, RC (k x) (k' x)). +Proof. + refine + match H in eq_itreeF _ _ x y + return + match x return Prop with + | @VisF _ _ _ u e k => + exists k' : _ -> C2, y = VisF e k' /\ (forall x : u, RC (k x) (k' x)) + | _ => True + end + with + | EqVis _ _ _ _ _ Ek => ltac:(eexists; split; [ reflexivity | eassumption ]) + | _ => I + end. +Qed. + +(* todo: this could be made stronger with eutt rather than eq_itree + *) +Instance Proper_sutt {E : Type -> Type} {R1 R2 : Type} +: Proper (pointwise_relation _ (pointwise_relation _ Basics.impl) ==> + eq_itree eq ==> eq_itree eq ==> Basics.impl) + (@sutt E R1 R2). +Proof. + red. red. + unfold pointwise_relation. + intros x y Hxy. + unfold impl. + red. red. + do 5 intro. do 2 rewrite sutt_is_sutt1. + revert x0 y0 H x1 y1. + pcofix CIH. + intros. + punfold H0. + punfold H1. + red in H0. red in H1. + pfold. + punfold H2. + revert H0 H1. + generalize dependent (observe y0). + generalize dependent (observe y1). + generalize dependent (observe x2). + generalize dependent (observe x3). + induction 1; eauto. + { inversion 1; subst. + inversion 1; subst. + constructor. eapply Hxy. + assumption. } + { intros. + eapply eq_itree_vis_l in H0. + eapply eq_itree_vis_l in H1. + destruct H0 as [ ? [ ? ? ] ]. + destruct H1 as [ ? [ ? ? ] ]. + rewrite H. rewrite H1. + constructor. + intros. + right. + specialize (H0 x4). + specialize (H2 x4). + pclearbot. + eapply CIH; eauto. } + { intros. + inversion H1; clear H1; subst. + constructor. + eapply IHsuttF1; eauto. + pclearbot. + punfold REL. } + { intros. + inversion H0; clear H0; subst. + constructor. + right. + change i with (observe {| _observe := i |}). + pclearbot. + eapply CIH. + - eassumption. + - instantiate (1:={| _observe := ot2 |}). + pfold. red. eapply H1. + - eapply EQTAUS. } +Qed. + +(* Instance sutt_interp (E F : Type -> Type) (R : Type) : *) +(* Proper (Rhom (fun _ => sutt eq) ==> sutt eq ==> sutt eq) *) +(* (fun f => @interp E F f R). *) + diff --git a/theories/Eq/Untaus.v b/theories/Eq/Untaus.v new file mode 100644 index 00000000..19826083 --- /dev/null +++ b/theories/Eq/Untaus.v @@ -0,0 +1,498 @@ +Require Import Paco.paco. + +From Coq Require Import + Program + Lia + Classes.RelationClasses + Classes.Morphisms + Setoids.Setoid + Relations.Relations. + +From ITree Require Import + Core. + +From ITree Require Export + Eq.Eq. + +Local Open Scope itree. + +Section FiniteTaus. + +Context {E : Type -> Type} {R : Type}. + +(* [notau t] holds when [t] does not start with a [Tau]. *) +Definition notauF {I} (t : itreeF E R I) : Prop := + match t with + | TauF _ => False + | _ => True + end. + +Notation notau t := (notauF (observe t)). + +(* [untaus t t'] holds when [t = Tau (... Tau t' ...)]: + [t] steps to [t'] by "peeling off" a finite number of [Tau]. + "Peel off" means to remove only taus at the root of the tree, + not any behind a [Vis] step). *) +Inductive untausF : + itreeF E R (itree E R) -> itreeF E R (itree E R) -> Prop := +| NoTau ot0 : untausF ot0 ot0 +| OneTau ot t' ot0 (OBS: TauF t' = ot) (TAUS: untausF (observe t') ot0): untausF ot ot0 +. +Hint Constructors untausF. + +Definition unalltausF ot ot0 := untausF ot ot0 /\ notauF ot0. +Hint Unfold unalltausF. + +Lemma unalltausF_untausF ot ot0 : unalltausF ot ot0 -> untausF ot ot0. +Proof. intros []; auto. Qed. +Hint Resolve unalltausF_untausF. + +Lemma unalltausF_notauF ot ot0 : unalltausF ot ot0 -> notauF ot0. +Proof. intros []; auto. Qed. +Hint Resolve unalltausF_notauF. + +(* [finite_taus t] holds when [t] has a finite number of taus + to peel. *) +Definition finite_tausF ot : Prop := exists ot', unalltausF ot ot'. +Hint Unfold finite_tausF. + +(** ** Lemmas *) + +Lemma untaus_all ot ot' : + untausF ot ot' -> notauF ot' -> unalltausF ot ot'. +Proof. induction 1; eauto. Qed. + +Lemma unalltaus_notau ot ot' : unalltausF ot ot' -> notauF ot'. +Proof. intros. induction H; eauto. Qed. + +Lemma notau_tau I (ot : itreeF E R I) (t0 : I) + (NOTAU : notauF ot) + (OBS: TauF t0 = ot): False. +Proof. subst. auto. Qed. +Hint Resolve notau_tau. + +Lemma notau_ret I (ot: itreeF E R I) r (OBS: RetF r = ot) : notauF ot. +Proof. subst. red. eauto. Qed. +Hint Resolve notau_ret. + +Lemma notau_vis I (ot : itreeF E R I) u (e: E u) k (OBS: VisF e k = ot) : notauF ot. +Proof. intros. subst. red. eauto. Qed. +Hint Resolve notau_vis. + +(* If [t] does not start with [Tau], removing all [Tau] does + nothing. Can be thought of as [notau_unalltaus] composed with + [unalltaus_injective] (below). *) +Lemma unalltaus_notau_id ot ot' : + unalltausF ot ot' -> notauF ot -> ot = ot'. +Proof. + intros [[ | ]] ?; eauto. exfalso; eauto. +Qed. + +(* There is only one way to peel off all taus. *) +Lemma unalltaus_injective ot ot1 ot2 : + unalltausF ot ot1 -> unalltausF ot ot2 -> ot1 = ot2. +Proof. + intros [Huntaus Hnotau]. revert ot2 Hnotau. + induction Huntaus; intros; eauto using unalltaus_notau_id. + eapply IHHuntaus; eauto. + destruct H as [Huntaus' Hnotau']. + destruct Huntaus'. + + exfalso; eauto. + + subst. inversion OBS0; subst; eauto. +Qed. + +(* Adding a [Tau] to [t1] then peeling them all off produces + the same result as peeling them all off from [t1]. *) +Lemma unalltaus_tau t ot1 ot2 + (OBS: TauF t = ot1) + (TAUS: unalltausF ot1 ot2): + unalltausF (observe t) ot2. +Proof. + destruct TAUS as [Huntaus Hnotau]. + destruct Huntaus. + - exfalso; eauto. + - subst; inversion OBS0; subst; eauto. +Qed. + +Lemma unalltaus_tau' t ot1 ot2 + (OBS: TauF t = ot1) + (TAUS: unalltausF (observe t) ot2): + unalltausF ot1 ot2. +Proof. + destruct TAUS as [Huntaus Hnotau]. + subst. eauto. +Qed. + +Lemma notauF_untausF ot1 ot2 + (NOTAU : notauF ot1) + (UNTAUS : untausF ot1 ot2) : ot1 = ot2. +Proof. + destruct UNTAUS; eauto. + exfalso; eauto. +Qed. + +Definition untausF_shift (t1 t2 : itree E R) : + untausF (TauF t1) (TauF t2) -> untausF (observe t1) (observe t2). +Proof. + intros H. + inversion H; subst. + { constructor. } + clear H. + inversion OBS; subst; clear OBS. + remember (observe t1) as ot1. + remember (TauF t2) as tt2. + generalize dependent t1. + generalize dependent t2. + induction TAUS; intros; subst; econstructor; eauto. +Qed. + +Definition untausF_trans (t1 t2 t3 : itreeF E R _) : + untausF t1 t2 -> untausF t2 t3 -> untausF t1 t3. +Proof. + induction 1; auto. + subst; econstructor; auto. +Qed. + +Definition untausF_strong_ind + (P : itreeF E R _ -> Prop) + (ot1 ot2 : itreeF E R _) + (Huntaus : untausF ot1 ot2) + (Hnotau : notauF ot2) + (STEP : forall ot1 + (Huntaus : untausF ot1 ot2) + (IH: forall t1' oti + (NEXT: ot1 = TauF t1') + (UNTAUS: untausF (observe t1') oti), + P oti), + P ot1) + : P ot1. +Proof. + enough (H : forall oti, + untausF ot1 oti -> + untausF oti ot2 -> + P oti + ). + { apply H; eauto. } + revert STEP. + induction Huntaus; intros; subst. + - eapply STEP; eauto. + intros; subst. dependent destruction H; inv Hnotau. + - destruct H0; auto. + subst. apply STEP; eauto. + intros. inv NEXT. + apply IHHuntaus; eauto. + + clear -H UNTAUS. + remember (TauF t') as ott'. remember (TauF t1') as ott1'. + move H at top. revert_until H. induction H; intros; subst. + * inv Heqott1'. eauto. + * inv Heqott'. dependent destruction H; eauto. + + genobs t1' ot1'. revert UNTAUS. clear -Hnotau H0. induction H0; intros. + * dependent destruction UNTAUS; eauto. + subst. simpobs. inv Hnotau. + * subst. dependent destruction UNTAUS; eauto. +Qed. + +(* If [t] does not start with [Tau], then it starts with finitely + many [Tau]. *) +Lemma notau_finite_taus ot : notauF ot -> finite_tausF ot. +Proof. eauto. Qed. + +(* [Vis] and [Ret] start with no taus, of course. *) +Lemma finite_taus_ret ot (r : R) (OBS: RetF r = ot) : finite_tausF ot. +Proof. eauto 10. Qed. + +Lemma finite_taus_vis {u} ot (e : E u) (k : u -> itree E R) (OBS: VisF e k = ot): + finite_tausF ot. +Proof. eauto 10. Qed. + +(* [finite_taus] is preserved by removing or adding one [Tau]. *) +Lemma finite_taus_tau t': + finite_tausF (TauF t') <-> finite_tausF (observe t'). +Proof. + split; intros [? [Huntaus Hnotau]]; eauto 10. + inv Huntaus. + - contradiction. + - inv OBS; eauto. +Qed. + +(* (* [finite_taus] is preserved by removing or adding any finite *) +(* number of [Tau]. *) *) +Lemma untaus_finite_taus ot ot': + untausF ot ot' -> (finite_tausF ot <-> finite_tausF ot'). +Proof. + induction 1; intros; subst. + - reflexivity. + - erewrite finite_taus_tau; eauto. +Qed. + +Lemma untaus_untaus : forall (ot1 ot2 ot3: itreeF E R _), + untausF ot1 ot2 -> untausF ot2 ot3 -> untausF ot1 ot3. +Proof. + intros t1 t2 t3. induction 1; simpl; eauto. +Qed. + +Lemma untaus_unalltaus_rev (ot1 ot2 ot3: itreeF E R _) : + untausF ot1 ot2 -> unalltausF ot1 ot3 -> unalltausF ot2 ot3. +Proof. + intros H. revert ot3. + induction H; intros. + - eauto with arith. + - destruct H0 as [Huntaus Hnotau]. + destruct Huntaus. + + exfalso; eauto. + + inv OBS0. inversion H0; subst; eauto. +Qed. + +Lemma unalltausF_ret : forall x (t: itree' E R), + unalltausF (RetF x) t -> t = RetF x. +Proof. + intros x t [UNT NOT]; inversion UNT; subst; clear UNT; [reflexivity | easy]. +Qed. + +Lemma unalltausF_vis {S}: forall e (k: S -> itree E R) (t: itree' E R), + unalltausF (VisF e k) t -> t = VisF e k. +Proof. + intros e k t [UNT NOT]; inversion UNT; subst; clear UNT; [reflexivity | easy]. +Qed. + +End FiniteTaus. + +Arguments untaus_unalltaus_rev : clear implicits. + +Hint Resolve unalltausF_notauF. +Hint Resolve unalltausF_untausF. + +Hint Constructors untausF. +Hint Unfold unalltausF. +Hint Unfold finite_tausF. +Hint Resolve notau_ret. +Hint Resolve notau_vis. +Hint Resolve notau_tau. + +Notation finite_taus t := (finite_tausF (observe t)). +Notation untaus t t' := (untausF (observe t) (observe t')). +Notation unalltaus t t' := (unalltausF (observe t) (observe t')). + +Ltac auto_untaus := + repeat match goal with + | [ H1 : notauF ?X, H2 : unalltausF ?X ?Y |- _ ] => + assert_fails (unify X Y); + replace Y with X in * by apply (unalltaus_notau_id _ _ H2 H1) + | [ H1 : unalltausF ?X ?Y, H2 : unalltausF ?X ?Z |- _ ] => + assert_fails (unify Y Z); + replace Z with Y in * by apply (unalltaus_injective _ _ _ H1 H2) + end; auto. + +Section NOTAU. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + + +(* Equivalence between visible steps of computation (i.e., [Vis] or + [Ret], parameterized by a relation [euttE] between continuations + in the [Vis] case. *) +Variant eq_notauF {I J} (euttE : I -> J -> Prop) +: itreeF E R1 I -> itreeF E R2 J -> Prop := +| Eutt_ret : forall r1 r2, + RR r1 r2 -> + eq_notauF euttE (RetF r1) (RetF r2) +| Eutt_vis : forall u (e : E u) k1 k2, + (forall x, euttE (k1 x) (k2 x)) -> + eq_notauF euttE (VisF e k1) (VisF e k2). +Hint Constructors eq_notauF. + +(* Paco takes the greatest fixpoints of monotone relations. *) + +Lemma monotone_eq_notauF : forall I J (r r' : I -> J -> Prop) x1 x2 + (IN: eq_notauF r x1 x2) + (LE: r <2= r'), + eq_notauF r' x1 x2. +Proof. pmonauto. Qed. +Hint Resolve monotone_eq_notauF. + +Lemma eq_notauF_vis_inv1 {I J} {euttE : I -> J -> Prop} {U} + ot (e : E U) k : + eq_notauF euttE ot (VisF e k) -> + exists k', + ot = VisF e k' /\ (forall x, euttE (k' x) (k x)). +Proof. + intros. remember (VisF e k) as t. + inversion H; subst; try discriminate. + inversion H2; subst; auto_inj_pair2; subst; eauto. +Qed. + + +Lemma eq_unalltaus (t1 : itree E R1) (t2 : itree E R2) ot1' + (FT: unalltausF (observe t1) ot1') + (EQV: eq_itree RR t1 t2) : + exists ot2', unalltausF (observe t2) ot2'. +Proof. + genobs t1 ot1. revert t1 Heqot1 t2 EQV. + destruct FT as [Huntaus Hnotau]. + induction Huntaus; intros; punfold EQV; unfold_eq_itree; subst. + - eexists. constructor; eauto. inv EQV; simpl; eauto. + - inv EQV; simpobs; try inv Heqot1. + pclearbot. edestruct IHHuntaus as [? []]; eauto. +Qed. + +Lemma eq_unalltaus_eqF (t : itree E R1) (s : itree E R2) ot' + (UNTAUS : unalltausF (observe t) ot') + (EQV: eq_itree RR t s) : + exists os', unalltausF (observe s) os' /\ eq_itreeF RR (eq_itree RR) ot' os'. +Proof. + destruct UNTAUS as [Huntaus Hnotau]. + remember (observe t) as ot. revert s t Heqot EQV. + induction Huntaus; intros; punfold EQV; unfold_eq_itree. + - eexists (observe s). split. + inv EQV; simpobs; eauto. + subst; eauto. + eapply eq_itreeF_mono; eauto. + intros ? ? [| []]; eauto. + - inv EQV; simpobs; inversion Heqot; subst. + destruct REL as [| []]. + edestruct IHHuntaus as [? [[]]]; eauto 10. +Qed. + +Lemma eq_unalltaus_eq (t : itree E R1) (s : itree E R2) t' + (UNTAUS : unalltausF (observe t) (observe t')) + (EQV: eq_itree RR t s) : + exists s', unalltausF (observe s) (observe s') /\ eq_itree RR t' s'. +Proof. + eapply eq_unalltaus_eqF in UNTAUS; try eassumption. + destruct UNTAUS as [os' []]. eexists (go os'); split; eauto. + pfold. eapply eq_itreeF_mono; eauto. +Qed. + +End NOTAU. + +Hint Resolve monotone_eq_notauF. +Hint Constructors eq_notauF. + +(** *** [eq_notauF] lemmas *) + +Lemma eq_notauF_and {E R1 R2} (RR : R1 -> R2 -> Prop) {I J} + (euttE1 euttE2 euttE : I -> J -> Prop) : + (forall t1 t2, euttE1 t1 t2 -> euttE2 t1 t2 -> euttE t1 t2) -> + forall (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J), + eq_notauF RR euttE1 ot1 ot2 -> eq_notauF RR euttE2 ot1 ot2 -> + eq_notauF RR euttE ot1 ot2. +Proof. + intros ? ? ? [] Hen2; inversion Hen2; auto. + auto_inj_pair2; subst; auto. +Qed. + +Lemma eq_notauF_flip {E R1 R2} (RR : R1 -> R2 -> Prop) {I J} + (euttE : I -> J -> Prop) : + forall (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J), + eq_notauF (flip RR) (flip euttE) ot2 ot1 -> + eq_notauF RR euttE ot1 ot2. +Proof. + intros ? ? []; auto. +Qed. + +Delimit Scope euttE_scope with euttE. + +(** ** Generalized symmetry and transitivity *) + +Lemma Symmetric_eq_notauF_ {E R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + {I J} (r1 : I -> J -> Prop) (r2 : J -> I -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) + (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J) : + eq_notauF RR1 r1 ot1 ot2 -> + eq_notauF RR2 r2 ot2 ot1. +Proof. intros []; auto. Qed. + +Lemma Transitive_eq_notauF_ {E R1 R2 R3} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop) + (RR3 : R1 -> R3 -> Prop) + {I J K} (r1 : I -> J -> Prop) (r2 : J -> K -> Prop) + (r3 : I -> K -> Prop) + (TRANS_RR : forall r1 r2 r3, RR1 r1 r2 -> RR2 r2 r3 -> RR3 r1 r3) + (TRANS_r : forall i j k, r1 i j -> r2 j k -> r3 i k) + (ot1 : itreeF E R1 I) ot2 ot3 : + eq_notauF RR1 r1 ot1 ot2 -> + eq_notauF RR2 r2 ot2 ot3 -> + eq_notauF RR3 r3 ot1 ot3. +Proof. + intros [] I2; inversion I2; eauto. + auto_inj_pair2; subst; eauto. +Qed. + +Section NOTAU_rel. + +Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). + +(* Reflexivity of [eq_notauF], modulo a few assumptions. *) +Lemma Reflexive_eq_notauF `{Reflexive _ RR} I (eq_ : I -> I -> Prop) : + Reflexive eq_ -> + forall (ot : itreeF E R I), notauF ot -> eq_notauF RR eq_ ot ot. +Proof. + intros. destruct ot; try contradiction; econstructor; intros; subst; eauto. +Qed. + +Global Instance Symmetric_eq_notauF `{Symmetric _ RR} I (eq_ : I -> I -> Prop) : + Symmetric eq_ -> Symmetric (@eq_notauF E _ _ RR _ _ eq_). +Proof. + repeat intro. eapply Symmetric_eq_notauF_; eauto. +Qed. + +Global Instance Transitive_eq_notauF `{Transitive _ RR} I (eq_ : I -> I -> Prop) : + Transitive eq_ -> Transitive (@eq_notauF E _ _ RR _ _ eq_). +Proof. + repeat intro. eapply Transitive_eq_notauF_; eauto. +Qed. + +End NOTAU_rel. + +Global Instance eq_itree_notauF {E R} : + Proper (going (@eq_itree E R _ eq) ==> flip impl) notauF. +Proof. + intros ? ? [] ?; punfold H. inv H; simpl in *; subst; eauto. +Qed. + +Lemma untaus_bind {E S R} : forall t t' (k: S -> itree E R) + (UNTAUS: untausF (observe t) (observe t')), + untausF (observe (ITree.bind t k)) (observe (ITree.bind t' k)). +Proof. + intros. genobs t ot; genobs t' ot'. revert t Heqot t' Heqot'. + induction UNTAUS; intros; subst. + - rewrite !unfold_bind; simpobs; eauto. + - rewrite unfold_bind. simpobs. cbn. eauto. +Qed. + +Lemma untaus_bindF {E S R} : forall t t' (k: S -> itree E R) + (UNTAUS: untausF (observe t) t'), + untausF (observe (ITree.bind t k)) (observe (ITree.bind (go t') k)). +Proof. + intros; eapply untaus_bind; eauto. +Qed. + +Lemma finite_taus_bind_fst {E R S} + (t : itree E R) (f : R -> itree E S) : + finite_taus (ITree.bind t f) -> finite_taus t. +Proof. + intros [tf' [TAUS PROP]]. + genobs (ITree.bind t f) obtf. move TAUS at top. revert_until TAUS. + induction TAUS; intros; subst. + - rewrite unfold_bind in PROP. + genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. + - genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. + rewrite unfold_bind in Heqobtf. simpobs. inv Heqobtf. unfold_bind. + eapply finite_taus_tau; eauto. +Qed. + +Lemma finite_taus_bind {E R S} + (t : itree E R) (f : R -> itree E S) + (FINt: finite_tausF (observe t)) + (FINk: forall v, finite_tausF (observe (f v))): + finite_tausF (observe (ITree.bind t f)). +Proof. + rewrite unfold_bind. + genobs t ot. clear Heqot t. + destruct FINt as [ot' [UNT NOTAU]]. + induction UNT; subst. + - destruct ot0; inv NOTAU; simpl; eauto 7. + - apply finite_taus_tau. eauto. +Qed. diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index c9f4a7db..02e7d742 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -11,9 +11,9 @@ *) (* TODO: - - relate to Eq.Eq.eq_itree - - prove monad laws (see [eutt_bind_bind_fail]) - - make [eutt] easier to work with ([eutt_bind] is already a mess) + - Generalize Reflexivity, Symmetry, Transitivity to heterogeneous + eutt. + - Make eutt a notation instead of a definition? *) Require Import Paco.paco. @@ -26,88 +26,60 @@ From Coq Require Import Setoids.Setoid Relations.Relations. -From ITree Require Import Core Eq.Eq. +From ITree Require Import + Core. -Local Open Scope itree. +From ITree Require Export + Eq.Eq. -(* [notau t] holds when [t] does not start with a [Tau]. *) -Definition notauF {E R I} (t : itreeF E R I) : Prop := - match t with - | TauF _ => False - | _ => True - end. -Arguments notauF [E R I] t. +Local Open Scope itree. -Notation notau t := (notauF (observe t)). Section EUTT. -Context {E : Type -> Type} {R : Type}. - -(* Equivalence between visible steps of computation (i.e., [Vis] or - [Ret], parameterized by a relation [eutt] between continuations - in the [Vis] case. *) -Variant eq_notauF {I} (eutt : relation I) -: relation (itreeF E R I) := -| Eutt_ret : forall r, eq_notauF eutt (RetF r) (RetF r) -| Eutt_vis : forall u (e : E u) k1 k2, - (forall x, eutt (k1 x) (k2 x)) -> - eq_notauF eutt (VisF e k1) (VisF e k2). -Hint Constructors eq_notauF. - - -(* [untaus t' t] holds when [t = Tau (... Tau t' ...)]: - [t] steps to [t'] by "peeling off" a finite number of [Tau]. - "Peel off" means to remove only taus at the root of the tree, - not any behind a [Vis] step). *) -Inductive untausF : relation (itreeF E R _) := -| NoTau ot0 : untausF ot0 ot0 -| OneTau ot t' ot0 (OBS: TauF t' = ot) (TAUS: untausF (observe t') ot0): untausF ot ot0 -. -Hint Constructors untausF. - -Definition unalltausF ot ot0 := untausF ot ot0 /\ notauF ot0. -Hint Unfold unalltausF. - - -(* [finite_taus t] holds when [t] has a finite number of taus - to peel. *) -Definition finite_tausF ot : Prop := exists ot', unalltausF ot ot'. -Hint Unfold finite_tausF. - -(* [eutt_ eutt t1 t2] means that, if [t1] or [t2] ever takes a - visible step ([Vis] or [Ret]), then the other takes the same - step, and the subsequent continuations (in the [Vis] case) are - related by [eutt]. In particular, [(t1 = spin)%eq_itree] if - and only if [(t2 = spin)%eq_itree]. Note also that in that - case, the parameter [eutt] is irrelevant. - - This is the relation we will take a fixpoint of. *) -Inductive euttF (eutt : relation (itree E R)) (ot1 ot2: itreeF E R (itree E R)) : Prop := -| euttF_ (FIN: finite_tausF ot1 <-> finite_tausF ot2) - (EQV: forall ot1' ot2' - (UNTAUS1: unalltausF ot1 ot1') - (UNTAUS2: unalltausF ot2 ot2'), - eq_notauF eutt ot1' ot2') +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +Inductive euttF + (eutt: itree E R1 -> itree E R2 -> Prop) + (eutt_taus: itreeF E R1 _ -> itreeF E R2 _ -> Prop) + : itreeF E R1 _ -> itreeF E R2 _ -> Prop := +| euttF_ret r1 r2 + (RBASE: RR r1 r2): + euttF eutt eutt_taus (RetF r1) (RetF r2) +| euttF_vis u (e : E u) k1 k2 + (EUTTK: forall x, eutt (k1 x) (k2 x) \/ eutt_taus (observe (k1 x)) (observe (k2 x))): + euttF eutt eutt_taus (VisF e k1) (VisF e k2) +| euttF_tau_tau t1 t2 + (EQTAUS: eutt_taus (observe t1) (observe t2)): + euttF eutt eutt_taus (TauF t1) (TauF t2) +| euttF_tau_left t1 ot2 + (EQTAUS: euttF eutt eutt_taus (observe t1) ot2): + euttF eutt eutt_taus (TauF t1) ot2 +| euttF_tau_right ot1 t2 + (EQTAUS: euttF eutt eutt_taus ot1 (observe t2)): + euttF eutt eutt_taus ot1 (TauF t2) . Hint Constructors euttF. -Definition eutt_ (eutt : relation (itree E R)) (t1 t2 : itree E R) : Prop := - euttF eutt (observe t1) (observe t2). +Definition eutt_ eutt t1 t2 := paco2 (euttF eutt) bot2 (observe t1) (observe t2). Hint Unfold eutt_. -(* Paco takes the greatest fixpoints of monotone relations. *) +Lemma euttF_mon r r' s s' x y + (EUTT: euttF r s x y) + (LEr: r <2= r') + (LEs: s <2= s'): + euttF r' s' x y. +Proof. + induction EUTT; eauto. + econstructor; intros. edestruct EUTTK; eauto. +Qed. -Lemma monotone_eq_notauF : forall I (r r' : relation I) x1 x2 - (IN: eq_notauF r x1 x2) - (LE: r <2= r'), - eq_notauF r' x1 x2. -Proof. pmonauto. Qed. -Hint Resolve monotone_eq_notauF. +Lemma monotone_euttF eutt : monotone2 (euttF eutt). +Proof. repeat intro. eauto using euttF_mon. Qed. +Hint Resolve monotone_euttF : paco. -(* [eutt_] is monotone. *) Lemma monotone_eutt_ : monotone2 eutt_. -Proof. pmonauto. Qed. +Proof. red. eauto using euttF_mon, paco2_mon_gen. Qed. Hint Resolve monotone_eutt_ : paco. (* We now take the greatest fixpoint of [eutt_]. *) @@ -115,902 +87,551 @@ Hint Resolve monotone_eutt_ : paco. (* Equivalence Up To Taus. [eutt t1 t2]: [t1] is equivalent to [t2] up to taus. *) -Definition eutt : relation (itree E R) := paco2 eutt_ bot2. +Definition eutt : itree E R1 -> itree E R2 -> Prop := paco2 eutt_ bot2. +Hint Unfold eutt. Global Arguments eutt t1%itree t2%itree. -Infix "≈" := eutt (at level 70) : itree_scope. - -(* Lemmas about the auxiliary relations. *) - -(* Many have a name [X_Y] to represent an implication - [X _ -> Y _] (possibly with more arguments on either side). *) - -Lemma untaus_all ot ot' : - untausF ot ot' -> notauF ot' -> unalltausF ot ot'. -Proof. induction 1; eauto. Qed. - -Lemma unalltaus_notau ot ot' : unalltausF ot ot' -> notauF ot'. -Proof. intros. induction H; eauto. Qed. +End EUTT. -Lemma notau_tau I (ot : itreeF E R I) (t0 : I) - (NOTAU : notauF ot) - (OBS: TauF t0 = ot): False. -Proof. subst. auto. Qed. -Hint Resolve notau_tau. +Hint Constructors euttF. +Hint Unfold eutt_. +Hint Resolve monotone_euttF : paco. +Hint Resolve monotone_eutt_ : paco. +Hint Unfold eutt. -Lemma notau_ret I (ot: itreeF E R I) r (OBS: RetF r = ot) : notauF ot. -Proof. subst. red. eauto. Qed. -Hint Resolve notau_ret. +Infix "≈" := (eutt eq) (at level 70) : itree_scope. -Lemma notau_vis I (ot : itreeF E R I) u (e: E u) k (OBS: VisF e k = ot) : @notauF E R I ot. -Proof. intros. subst. red. eauto. Qed. -Hint Resolve notau_vis. - -(* If [t] does not start with [Tau], removing all [Tau] does - nothing. Can be thought of as [notau_unalltaus] composed with - [unalltaus_injective] (below). *) -Lemma unalltaus_notau_id ot ot' : - unalltausF ot ot' -> notauF ot -> ot = ot'. -Proof. - intros [[ | ]] ?; eauto. exfalso; eauto. -Qed. - -(* There is only one way to peel off all taus. *) -Lemma unalltaus_injective ot ot1 ot2 : - unalltausF ot ot1 -> unalltausF ot ot2 -> ot1 = ot2. -Proof. - intros [Huntaus Hnotau]. revert ot2 Hnotau. - induction Huntaus; intros; eauto using unalltaus_notau_id. - eapply IHHuntaus; eauto. - destruct H as [Huntaus' Hnotau']. - destruct Huntaus'. - + exfalso; eauto. - + subst. inversion OBS0; subst; eauto. -Qed. - -(* Adding a [Tau] to [t1] then peeling them all off produces - the same result as peeling them all off from [t1]. *) -Lemma unalltaus_tau t ot1 ot2 - (OBS: TauF t = ot1) - (TAUS: unalltausF ot1 ot2): - unalltausF (observe t) ot2. -Proof. - destruct TAUS as [Huntaus Hnotau]. - destruct Huntaus. - - exfalso; eauto. - - subst; inversion OBS0; subst; eauto. -Qed. - -Lemma unalltaus_tau' t ot1 ot2 - (OBS: TauF t = ot1) - (TAUS: unalltausF (observe t) ot2): - unalltausF ot1 ot2. -Proof. - destruct TAUS as [Huntaus Hnotau]. - subst. eauto. -Qed. - -Lemma notauF_untausF ot1 ot2 - (NOTAU : notauF ot1) - (UNTAUS : untausF ot1 ot2) : ot1 = ot2. -Proof. - destruct UNTAUS; eauto. - exfalso; eauto. -Qed. - -Definition untausF_shift (t1 t2 : itree E R) : - untausF (TauF t1) (TauF t2) -> untausF (observe t1) (observe t2). -Proof. - intros H. - inversion H; subst. - { constructor. } - clear H. - inversion OBS; subst; clear OBS. - remember (observe t1) as ot1. - remember (TauF t2) as tt2. - generalize dependent t1. - generalize dependent t2. - induction TAUS; intros; subst; econstructor; eauto. -Qed. - -Definition untausF_trans (t1 t2 t3 : itreeF E R _) : - untausF t1 t2 -> untausF t2 t3 -> untausF t1 t3. -Proof. - induction 1; auto. - subst; econstructor; auto. -Qed. - -Definition untausF_strong_ind - (P : itreeF E R _ -> Prop) - (ot1 ot2 : itreeF E R _) - (Huntaus : untausF ot1 ot2) - (Hnotau : notauF ot2) - (STEP : forall ot1 - (Huntaus : untausF ot1 ot2) - (IH: forall t1' oti - (NEXT: ot1 = TauF t1') - (UNTAUS: untausF (observe t1') oti), - P oti), - P ot1) - : P ot1. -Proof. - enough (H : forall oti, - untausF ot1 oti -> - untausF oti ot2 -> - P oti - ). - { apply H; eauto. } - revert STEP. - induction Huntaus; intros; subst. - - eapply STEP; eauto. - intros; subst. dependent destruction H; inv Hnotau. - - destruct H0; auto. - subst. apply STEP; eauto. - intros. inv NEXT. - apply IHHuntaus; eauto. - + clear -H UNTAUS. - remember (TauF t') as ott'. remember (TauF t1') as ott1'. - move H at top. revert_until H. induction H; intros; subst. - * inv Heqott1'. eauto. - * inv Heqott'. dependent destruction H; eauto. - + genobs t1' ot1'. revert UNTAUS. clear -Hnotau H0. induction H0; intros. - * dependent destruction UNTAUS; eauto. - subst. simpobs. inv Hnotau. - * subst. dependent destruction UNTAUS; eauto. -Qed. - -(* If [t] does not start with [Tau], then it starts with finitely - many [Tau]. *) -Lemma notau_finite_taus ot : notauF ot -> finite_tausF ot. -Proof. eauto. Qed. - -(* [Vis] and [Ret] start with no taus, of course. *) -Lemma finite_taus_ret ot (r : R) (OBS: RetF r = ot) : finite_tausF ot. -Proof. eauto 10. Qed. - -Lemma finite_taus_vis {u} ot (e : E u) (k : u -> itree E R) (OBS: VisF e k = ot): - finite_tausF ot. -Proof. eauto 10. Qed. - -(* [finite_taus] is preserved by removing or adding one [Tau]. *) -Lemma finite_taus_tau t': - finite_tausF (TauF t') <-> finite_tausF (observe t'). -Proof. - split; intros [? [Huntaus Hnotau]]; eauto 10. - inv Huntaus. - - contradiction. - - inv OBS; eauto. -Qed. - -(* (* [finite_taus] is preserved by removing or adding any finite *) -(* number of [Tau]. *) *) -Lemma untaus_finite_taus ot ot': - untausF ot ot' -> (finite_tausF ot <-> finite_tausF ot'). -Proof. - induction 1; intros; subst. - - reflexivity. - - erewrite finite_taus_tau; eauto. -Qed. +Section EUTT_homo. -(**) +Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). -Lemma eq_unalltaus (t1 t2 : itree E R) ot1' - (FT: unalltausF (observe t1) ot1') - (EQV: t1 ≅ t2) : - exists ot2', unalltausF (observe t2) ot2'. +Global Instance subrelation_eq_eutt : + @subrelation (itree E R) (eq_itree RR) (eutt RR). Proof. - genobs t1 ot1. revert t1 Heqot1 t2 EQV. - destruct FT as [Huntaus Hnotau]. - induction Huntaus; intros; punfold EQV; unfold_eq_itree; subst. - - eexists. constructor; eauto. inv EQV; simpl; eauto. - - inv EQV; simpobs; try inv Heqot1. - pclearbot. edestruct IHHuntaus as [? []]; eauto. + pcofix CIH. intros. pfold. revert_until CIH. pcofix CIH'. intros. + punfold H0. pfold. inv H0; pclearbot; eauto 7. Qed. -Lemma eq_unalltaus_eqF (t s : itree E R) ot' - (UNTAUS : unalltausF (observe t) ot') - (EQV: t ≅ s) : - exists os', unalltausF (observe s) os' /\ eq_itreeF' eq_itree ot' os'. +Global Instance Reflexive_eutt_gen `{Reflexive _ RR} + (r : itree E R -> itree E R -> Prop) : + Reflexive (paco2 (eutt_ RR) r). Proof. - destruct UNTAUS as [Huntaus Hnotau]. - remember (observe t) as ot. revert s t Heqot EQV. - induction Huntaus; intros; punfold EQV; unfold_eq_itree. - - eexists (observe s). split. - inv EQV; simpobs; eauto. - subst; eauto. - eapply eq_itreeF'_mono; eauto. - intros ? ? [| []]; eauto. - - inv EQV; rewrite <- H0 in Heqot; inversion Heqot; subst. - destruct REL as [| []]. - edestruct IHHuntaus as [? [[]]]; eauto 10. + pcofix CIH. intros. pfold. revert x. pcofix CIH'. intros. + genobs_clear x ox. destruct ox; eauto 7. Qed. -Lemma eq_unalltaus_eq (t s : itree E R) t' - (UNTAUS : unalltausF (observe t) (observe t')) - (EQV: t ≅ s) : - exists s', unalltausF (observe s) (observe s') /\ t' ≅ s'. +Global Instance Reflexive_euttF_gen `{Reflexive _ RR} + (r : relation (itree E R)) (r' : relation (itree' E R)) : + Reflexive (euttF RR (upaco2 (eutt_ RR) r) (upaco2 (euttF RR (upaco2 (eutt_ RR) r)) r')). Proof. - eapply eq_unalltaus_eqF in UNTAUS; try eassumption. - destruct UNTAUS as [os' []]. eexists (go os'); split; eauto. - pfold. eapply eq_itreeF'_mono; eauto. + repeat intro. assert (X := Reflexive_eutt_gen r (go x)). do 2 punfold X. + eauto using euttF_mon, upaco2_mon_bot. Qed. -(* Reflexivity of [eutt_0], modulo a few assumptions. *) -Lemma reflexive_euttF0 I (eutt : relation I) ot : - Reflexive eutt -> notauF ot -> eq_notauF eutt ot ot. +Global Instance Symmetric_eutt_gen `{Symmetric _ RR} + (r : itree E R -> itree E R -> Prop) + (Sr : Symmetric r) : + Symmetric (paco2 (eutt_ RR) r). Proof. - intros. destruct ot; try contradiction; econstructor; intros; subst; eauto. + pcofix CIH. intros. pfold. revert_until CIH. pcofix CIH'. intros. + punfold H1. punfold H1. pfold. + genobs_clear x ox. genobs_clear y oy. + induction H1; pclearbot; eauto. + - econstructor. intros. + edestruct EUTTK as [TMP | TMP]; destruct TMP; eauto 7; contradiction. + - punfold EQTAUS. eauto 8. Qed. -Lemma euttF_tau r t1 t2 t1' t2' - (OBS1: TauF t1' = observe t1) - (OBS2: TauF t2' = observe t2) - (REL: eutt_ r t1' t2'): - eutt_ r t1 t2. +End EUTT_homo. + +Section EUTT_hetero. + +Context {E : Type -> Type}. + +Lemma Symmetric_euttF_hetero {R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) (r'1 : _ -> _ -> Prop) (r'2 : _ -> _ -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) + (SYM_r' : forall i j, r'1 i j -> r'2 j i) : + forall (ot1 : itree' E R1) (ot2 : itree' E R2), + euttF RR1 r1 r'1 ot1 ot2 -> euttF RR2 r2 r'2 ot2 ot1. Proof. - intros. destruct REL. econstructor. - - simpobs. rewrite !finite_taus_tau. eauto. - - intros. eapply EQV; eapply unalltaus_tau; eauto. + intros. induction H; eauto 7. + econstructor; intros. edestruct EUTTK; eauto 7. Qed. -Lemma euttF_tau_left r t1 t2 t1' - (OBS: TauF t1 = observe t1') - (REL: eutt_ r t1' t2): - eutt_ r t1 t2. +Lemma Symmetric_eutt__hetero {R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) (r'1 : _ -> _ -> Prop) (r'2 : _ -> _ -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) + (SYM_r' : forall i j, r'1 i j -> r'2 j i) : + forall (ot1 : itree' E R1) (ot2 : itree' E R2), + paco2 (euttF RR1 r1) r'1 ot1 ot2 -> + paco2 (euttF RR2 r2) r'2 ot2 ot1. Proof. - intros. destruct REL. econstructor. - - rewrite <- FIN. symmetry. rewrite <- OBS. rewrite <- finite_taus_tau; eauto. reflexivity. - - intros. eapply EQV; eauto. rewrite <- OBS. inversion UNTAUS1. constructor; auto. - econstructor; eauto. + pcofix CIH. intros. + pfold. punfold H0. + induction H0; pclearbot; eauto 7. + - econstructor. intros. + edestruct EUTTK; eauto. + destruct H; eauto. + - destruct EQTAUS; eauto. +Qed. + +Lemma Symmetric_eutt_hetero {R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) : + forall (t1 : itree E R1) (t2 : itree E R2), + paco2 (eutt_ RR1) r1 t1 t2 -> paco2 (eutt_ RR2) r2 t2 t1. +Proof. + pcofix CIH. intros. + pfold. revert_until CIH. pcofix CIH'. intros. + pfold. do 2 punfold H0. + genobs_clear t1 ot1. genobs_clear t2 ot2. + induction H0; pclearbot; eauto 7. + econstructor; intros. + edestruct EUTTK as [TMP | TMP]; destruct TMP; eauto 7; contradiction. Qed. -Lemma euttF_tau_right r t1 t2 t2' - (OBS: TauF t2 = observe t2') - (REL: eutt_ r t1 t2'): - eutt_ r t1 t2. +Lemma euttF_elim_tau_left {R1 R2} (RR: R1 -> R2 -> Prop) r (t1: itree E R1) (ot2: itree' E R2) + (REL : euttF RR r (upaco2 (euttF RR r) bot2) (TauF t1) ot2) : + euttF RR r (upaco2 (euttF RR r) bot2) (observe t1) ot2. Proof. - intros. destruct REL. econstructor. - - rewrite FIN. rewrite <- OBS. rewrite <- finite_taus_tau; eauto. reflexivity. - - intros. eapply EQV; eauto. rewrite <- OBS. inversion UNTAUS2. constructor; auto. - econstructor; eauto. + remember (TauF t1) as ott1. + move REL before r. revert_until REL. + induction REL; intros; subst; try dependent destruction Heqott1; eauto. + pclearbot. punfold EQTAUS. Qed. -Lemma euttF_vis {u} (r : relation (itree E R)) t1 t2 (e : _ u) k1 k2 - (OBS1: VisF e k1 = observe t1) - (OBS2: VisF e k2 = observe t2) - (REL: forall x, r (k1 x) (k2 x)): - eutt_ r t1 t2. +Lemma euttF_elim_tau_right {R1 R2} (RR: R1 -> R2 -> Prop) r (ot1: itree' E R1) (t2: itree E R2) + (REL : euttF RR r (upaco2 (euttF RR r) bot2) ot1 (TauF t2)) : + euttF RR r (upaco2 (euttF RR r) bot2) ot1 (observe t2). Proof. - intros. econstructor. - - split; intros; eapply notau_finite_taus; eauto. - - intros. - apply unalltaus_notau_id in UNTAUS1; eauto. - apply unalltaus_notau_id in UNTAUS2; eauto. - simpobs. subst. eauto. + eapply (Symmetric_euttF_hetero _ (flip RR) _ (flip r)) in REL; eauto. + - eapply euttF_elim_tau_left in REL. + eapply Symmetric_euttF_hetero in REL; eauto. + intros. pclearbot. left. + eapply Symmetric_eutt__hetero; eauto; unfold flip; eauto. + - intros. pclearbot. left. + eapply Symmetric_eutt__hetero; eauto; unfold flip; eauto. Qed. -(**) +Definition isb_tau {E R} (ot: itree' E R) : bool := + match ot with | TauF _ => true | _ => false end. -Lemma Reflexive_euttF (r : relation (itree E R)) : - Reflexive r -> Reflexive (euttF r). +Lemma eutt_Ret {R1 R2} (RR: R1 -> R2 -> Prop) x y : + RR x y -> @eutt E R1 R2 RR (Ret x) (Ret y). Proof. - split. - - reflexivity. - - intros. - erewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). - apply reflexive_euttF0; eauto using unalltaus_notau. + intros; pfold. pfold. econstructor. eauto. Qed. -Lemma eutt_refl r x : paco2 eutt_ r x x. +Lemma eutt_Vis {R1 R2 U} RR (e: E U) k k' : + (forall x: U, @eutt E R1 R2 RR (k x) (k' x)) -> + eutt RR (Vis e k) (Vis e k'). Proof. - revert x. pcofix CIH. - intros. pfold. apply Reflexive_euttF. eauto. + intros. pfold. pfold. econstructor. + intros. left. left. apply H. Qed. -(* [eutt] is an equivalence relation. *) -Global Instance Reflexive_eutt: (Reflexive eutt). -Proof. - repeat intro. apply eutt_refl. -Qed. +End EUTT_hetero. -Global Instance Symmetric_eutt -: Symmetric eutt. -Proof. - pcofix Symmetric_eutt. - intros t1 t2 H12. - punfold H12. - pfold. - destruct H12 as [I12 H12]. - split. - - symmetry; assumption. - - intros. hexploit H12; eauto. intros. - inv H; eauto. - econstructor. intros. specialize (H0 x). pclearbot. eauto. -Qed. +Section EUTT_upto. -Global Instance Transitive_eutt : Transitive eutt. +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +Inductive eutt_trans_left_clo (r: itree E R1 -> itree E R2 -> Prop) : + itree E R1 -> itree E R2 -> Prop := +| eutt_trans_left_clo_intro t1 t2 t3 + (EQV: t1 ≈ t2) + (REL: r t2 t3) + : eutt_trans_left_clo r t1 t3 +. +Hint Constructors eutt_trans_left_clo. + +Lemma eutt_clo_trans_left : + weak_respectful2 (@eutt_ E R1 R2 RR) eutt_trans_left_clo. Proof. - pcofix Transitive_eutt. - intros t1 t2 t3 H12 H23. - punfold H12. - punfold H23. - pfold. - destruct H12 as [I12 H12]. - destruct H23 as [I23 H23]. - split. - - etransitivity; eauto. - - intros t1' t3' H1 H3. - destruct I12 as [I1 I2]. - destruct I1 as [n2' [t2' TAUS2]]; eauto. - hexploit H12; eauto. intros REL1. - hexploit H23; eauto. intros REL2. - destruct REL1; inversion REL2; clear REL2; eauto. - auto_inj_pair2; subst. + econstructor; [pmonauto|]. + intros. destruct PR. + eapply GF in REL. clear l LE GF. + revert_until r. pcofix CIH. intros. + pfold. punfold REL. do 2 punfold EQV. + genobs_clear t1 ot1. genobs_clear t2 ot2. genobs_clear t3 ot3. + move EQV before CIH. revert_until EQV. + induction EQV; intros; subst; pclearbot; eauto 7 using euttF_mon, upaco2_mon_bot, rclo2. + - remember (VisF e k2) as o. + move REL before CIH. revert_until REL. + induction REL; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. econstructor. intros. - specialize (H x); specialize (H6 x). pclearbot. eauto. -Qed. + edestruct EUTTK, EUTTK0; pclearbot; eauto 7 using rclo2. + - destruct (isb_tau ot3) eqn: ISTAU. + + destruct ot3; inv ISTAU. + econstructor. right. eapply CIH. eauto. + pfold. + eapply euttF_elim_tau_left in REL. + eapply euttF_elim_tau_right in REL. eauto. + + dependent destruction REL; simpobs; inv ISTAU. + econstructor. genobs_clear t2 ot. + move REL before CIH. revert_until REL. + induction REL; intros; inv H0. + * punfold EQTAUS. + genobs_clear t1 ot1. remember (RetF r1) as o. + move EQTAUS before CIH. revert_until EQTAUS. + induction EQTAUS; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + * punfold EQTAUS. + genobs_clear t1 ot1. remember (VisF e k1) as o. + move EQTAUS before CIH. revert_until EQTAUS. + induction EQTAUS; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + econstructor. intros. + edestruct EUTTK, EUTTK0; pclearbot; eauto 7 using rclo2. + * eapply IHREL; eauto. + punfold EQTAUS. pfold. + eapply euttF_elim_tau_right in EQTAUS. eauto. + - remember (TauF t2) as o. + move REL before CIH. revert_until REL. + induction REL; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + punfold EQTAUS. +Qed. + +Inductive eutt_trans_right_clo (r: itree E R1 -> itree E R2 -> Prop) : + itree E R1 -> itree E R2 -> Prop := +| eutt_trans_right_clo_intro t1 t2 t3 + (EQV: t3 ≈ t2) + (REL: r t1 t2) + : eutt_trans_right_clo r t1 t3 +. +Hint Constructors eutt_trans_right_clo. -(**) +Lemma eutt_clo_trans_right : + weak_respectful2 (@eutt_ E R1 R2 RR) eutt_trans_right_clo. +Proof. + econstructor; [pmonauto|]. + intros. destruct PR. + eapply GF in REL. clear l LE GF. + revert_until r. pcofix CIH. intros. + pfold. punfold REL. do 2 punfold EQV. + genobs_clear t1 ot1. genobs_clear t2 ot2. genobs_clear t3 ot3. + move EQV before CIH. revert_until EQV. + induction EQV; intros; subst; pclearbot; eauto 7 using euttF_mon, upaco2_mon_bot, rclo2. + - remember (VisF e k2) as o. + move REL before CIH. revert_until REL. + induction REL; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + econstructor. intros. + edestruct EUTTK, EUTTK0; pclearbot; eauto 7 using rclo2. + - destruct (isb_tau ot1) eqn: ISTAU. + + destruct ot1; inv ISTAU. + econstructor. right. eapply CIH. eauto. + pfold. + eapply euttF_elim_tau_left in REL. + eapply euttF_elim_tau_right in REL. eauto. + + dependent destruction REL; simpobs; inv ISTAU. + econstructor. genobs_clear t2 ot. + move REL before CIH. revert_until REL. + induction REL; intros; inv H0. + * punfold EQTAUS. + remember (RetF r2) as o. + move EQTAUS before CIH. revert_until EQTAUS. + induction EQTAUS; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + * punfold EQTAUS. + remember (VisF e k2) as o. + move EQTAUS before CIH. revert_until EQTAUS. + induction EQTAUS; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + econstructor. intros. + edestruct EUTTK, EUTTK0; pclearbot; eauto 7 using rclo2. + * eapply IHREL; eauto. + punfold EQTAUS. pfold. + eapply euttF_elim_tau_right in EQTAUS. eauto. + - remember (TauF t2) as o. + move REL before CIH. revert_until REL. + induction REL; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + punfold EQTAUS. +Qed. + +Inductive eutt_bind_clo {E R1 R2} (r: itree E R1 -> itree E R2 -> Prop) : itree E R1 -> itree E R2 -> Prop := +| eutt_bind_clo_intro U1 U2 RU t1 t2 k1 k2 + (EQV: @eutt E U1 U2 RU t1 t2) + (REL: forall v1 v2 (RELv: RU v1 v2), r (k1 v1) (k2 v2)) + : @eutt_bind_clo E R1 R2 r (ITree.bind t1 k1) (ITree.bind t2 k2) + (* TODO: 8.8 doesn't like the implicit arguments *) +. +Hint Constructors eutt_bind_clo. -(* [eutt] is preserved by removing one [Tau]. *) -Lemma tauF_eutt (t t': itree E R) (OBS: TauF t' = observe t): t ≈ t'. +Lemma eutt_clo_bind : weak_respectful2 (@eutt_ E R1 R2 RR) eutt_bind_clo. +Proof. + econstructor; [pmonauto|]. + intros. destruct PR. + assert (RELk: forall v1 v2, RU v1 v2 -> eutt_ RR r (k1 v1) (k2 v2)) by eauto. + clear l LE GF REL. + revert_until r. pcofix CIH. intros. + pfold. do 2 punfold EQV. + rewrite !unfold_bind. + genobs_clear t1 ot1. genobs_clear t2 ot2. + move EQV before CIH. revert_until EQV. + induction EQV; intros; subst; pclearbot. + - specialize (RELk _ _ RBASE). punfold RELk. + eauto 7 using euttF_mon, upaco2_mon_bot, rclo2. + - econstructor. intros. + edestruct EUTTK; pclearbot; eauto 7 using rclo2. + - simpl. eauto 7. + - econstructor. rewrite unfold_bind. eauto. + - econstructor. rewrite unfold_bind. eauto. +Qed. + +Global Instance eutt_cong_eutt r : + Proper (eutt eq ==> eutt eq ==> flip impl) + (paco2 (@eutt_ E R1 R2 RR ∘ gres2 (eutt_ RR)) r). Proof. - pfold. split. - - simpobs. rewrite finite_taus_tau. reflexivity. - - intros t1' t2' H1 H2. - eapply unalltaus_tau in H1; eauto. - assert (X := unalltaus_injective _ _ _ H1 H2). - subst; apply reflexive_euttF0; eauto using unalltaus_notau. - left. apply Reflexive_eutt. + repeat intro. + pupto2 eutt_clo_trans_left. econstructor; eauto. + pupto2 eutt_clo_trans_right. econstructor; eauto. Qed. -Lemma tau_eutt (t: itree E R) : Tau t ≈ t. +Global Instance eutt_cong_gres_eutt_ r : + Proper (eutt eq ==> eutt eq ==> flip impl) + (gres2 (@eutt_ E R1 R2 RR) r). Proof. - eapply tauF_eutt. eauto. + repeat intro. + pupto2 eutt_clo_trans_left. econstructor; eauto. + pupto2 eutt_clo_trans_right. econstructor; eauto. Qed. -(* [eutt] is preserved by removing all [Tau]. *) -Lemma untaus_eutt (t t' : itree E R) : untausF (observe t) (observe t') -> t ≈ t'. +Global Instance eutt_eq_under_rr_impl : + Proper (@eutt E _ _ eq ==> @eutt _ _ _ eq ==> flip impl) (eutt RR). Proof. - intros H. - pfold. split. - - eapply untaus_finite_taus; eauto. - - induction H; intros. - + rewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). - apply reflexive_euttF0; eauto using unalltaus_notau. - left; apply Reflexive_eutt. - + eapply unalltaus_tau in UNTAUS1; eauto. + repeat red. intros. pupto2_init. rewrite H, H0. pupto2_final. eauto. Qed. -End EUTT. +End EUTT_upto. -Hint Constructors eq_notauF. -Hint Constructors untausF. -Hint Unfold unalltausF. -Hint Unfold finite_tausF. -Hint Constructors euttF. -Hint Resolve monotone_eutt_ : paco. -Hint Resolve notau_ret. -Hint Resolve notau_vis. -Hint Resolve notau_tau. +Arguments eutt_clo_trans_left : clear implicits. +Hint Constructors eutt_trans_left_clo. -Delimit Scope eutt_scope with eutt. +Arguments eutt_clo_trans_right : clear implicits. +Hint Constructors eutt_trans_right_clo. -Infix "≈" := eutt (at level 70). +Arguments eutt_clo_bind : clear implicits. +Hint Constructors eutt_bind_clo. -Notation finite_taus t := (finite_tausF (observe t)). -Notation untaus t t' := (untausF (observe t) (observe t')). -Notation unalltaus t t' := (unalltausF (observe t) (observe t')). +Global Instance eutt_bind {E U R} : + Proper (eutt eq ==> + pointwise_relation _ (eutt eq) ==> + eutt eq) (@ITree.bind E U R). +Proof. + repeat intro. + pupto2_init. pupto2 eutt_clo_bind. econstructor; eauto. + intros. subst. pupto2_final. apply H0. +Qed. -(* We can now rewrite with [eutt] equalities. *) -Instance Equivalence_eutt E R : @Equivalence (itree E R) eutt. -Proof. constructor; typeclasses eauto. Qed. +Section EUTT_nested. -Instance subrelation_eq_eutt {E R} : subrelation (@eq_itree E R) eutt. -Proof. - pcofix CIH. intros. - pfold. econstructor. - { split; [|symmetry in H0]; intros; destruct H as [n [? ?]]; eauto using eq_unalltaus. } +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). - intros. eapply eq_unalltaus_eqF in H0; eauto. destruct H0 as [s' [UNTAUS' EQV']]. - hexploit @unalltaus_injective; [apply UNTAUS' | apply UNTAUS2 | intro X]; subst. - inv EQV'; simpobs; eauto. - eapply unalltaus_notau in UNTAUS1. simpobs. contradiction. -Qed. +Inductive eutt_nested_trans_clo (r: itree' E R1 -> itree' E R2 -> Prop) : + itree' E R1 -> itree' E R2 -> Prop := +| eutt_nested_trans_clo_intro ot1 ot2 ot3 ot4 + (EQVl: go ot1 ≅ go ot2) + (EQVr: go ot4 ≅ go ot3) + (REL: r ot2 ot3) + : eutt_nested_trans_clo r ot1 ot4 +. +Hint Constructors eutt_nested_trans_clo. -Instance subrelation_go_sim_eq_eutt {E R} : subrelation (go_sim (@eq_itree E R)) (go_sim (@eutt E R)). +Lemma eutt_nested_clo_trans r : + weak_respectful2 (euttF RR (gres2 (eutt_ RR) (upaco2 (eutt_ RR ∘ gres2 (eutt_ RR)) r))) + eutt_nested_trans_clo. Proof. - repeat intro. red. red in H. rewrite H. reflexivity. -Qed. + econstructor; [pmonauto|]. + intros. destruct PR. + apply GF in REL. clear l LE GF. + punfold EQVl; red in EQVl. punfold EQVr; red in EQVr. simpl in *. + move REL before r0. revert_until REL. + induction REL; intros; subst; + try (dependent destruction EQVl; dependent destruction EQVr; [ idtac ]; pclearbot). + - eauto. + - econstructor. intros. + edestruct EUTTK. + + left. rewrite REL, REL0. eauto. + + right. eapply rclo2_step. + econstructor. + * instantiate (1:= observe(k1 x)). rewrite <- !itree_eta. eauto. + * instantiate (1:= observe(k2 x)). rewrite <- !itree_eta. eauto. + * eauto using rclo2. + - econstructor. eapply rclo2_step. econstructor. + + rewrite REL. reflexivity. + + rewrite REL0. reflexivity. + + eauto using rclo2. + - dependent destruction EQVl; pclearbot. punfold REL0. + - dependent destruction EQVr; pclearbot. punfold REL0. +Qed. + +Global Instance eq_cong_nested_euttF r r0 : + Proper (going (eq_itree eq) ==> going (eq_itree eq) ==> flip impl) + (paco2 (@euttF E R1 R2 RR (gres2 (eutt_ RR) (upaco2 (eutt_ RR ∘ gres2 (eutt_ RR)) r)) + ∘ gres2 (euttF RR (gres2 (eutt_ RR) (upaco2 (eutt_ RR ∘ gres2 (eutt_ RR)) r)))) r0). +Proof. + repeat intro. destruct H, H0. + pupto2 eutt_nested_clo_trans. econstructor; eauto. +Qed. + +Inductive eutt_nested_bind_clo (r: itree' E R1 -> itree' E R2 -> Prop) : itree' E R1 -> itree' E R2 -> Prop := +| eutt_nested_bind_clo_intro U1 U2 RU t1 t2 k1 k2 + (EQV: @eutt E U1 U2 RU t1 t2) + (REL: forall v1 v2 (RELv: RU v1 v2), r (observe (k1 v1)) (observe (k2 v2))) + : eutt_nested_bind_clo r (observe (ITree.bind t1 k1)) (observe (ITree.bind t2 k2)) +. +Hint Constructors eutt_nested_bind_clo. -Instance eutt_go {E R} : - Proper (go_sim (@eutt E R) ==> @eutt E R) (@go E R). +Lemma eutt_nested_clo_bind r : + weak_respectful2 (euttF RR (gres2 (eutt_ RR) (upaco2 (eutt_ RR ∘ gres2 (eutt_ RR)) r))) + eutt_nested_bind_clo. Proof. - repeat intro. eauto. + econstructor; [pmonauto|]. + intros. destruct PR. + assert (RELk: forall v1 v2, RU v1 v2 -> euttF RR (gres2 (eutt_ RR) (upaco2 (eutt_ RR ∘ gres2 (eutt_ RR)) r)) r0 (observe (k1 v1)) (observe (k2 v2))) by eauto. + clear l LE GF REL. + do 2 punfold EQV. + rewrite !unfold_bind. + genobs_clear t1 ot1. genobs_clear t2 ot2. + move EQV before RU. revert_until EQV. + induction EQV; intros; subst; pclearbot. + - specialize (RELk _ _ RBASE). + eauto 7 using euttF_mon, upaco2_mon_bot, rclo2. + - econstructor. intros. + edestruct EUTTK; pclearbot; eauto 8 using rclo2. + - simpl. eauto 9 using rclo2. + - econstructor. rewrite unfold_bind. eauto. + - econstructor. rewrite unfold_bind. eauto. Qed. -Instance eutt_observe {E R} : - Proper (@eutt E R ==> go_sim (@eutt E R)) (@observe E R). -Proof. - repeat intro. punfold H. pfold. destruct H. econstructor; eauto. -Qed. +End EUTT_nested. -Instance eutt_tauF {E R} : - Proper (@eutt E R ==> go_sim (@eutt E R)) (@TauF E R _). -Proof. - repeat intro. pfold. punfold H. - destruct H. econstructor. - - split; intros; simpl. - + rewrite finite_taus_tau, <-FIN, <-finite_taus_tau; eauto. - + rewrite finite_taus_tau, FIN, <-finite_taus_tau; eauto. - - intros. eapply EQV; eapply unalltaus_tau; eauto. -Qed. +Arguments eutt_nested_clo_trans : clear implicits. +Hint Constructors eutt_nested_trans_clo. -Instance eutt_VisF {E R u} (e: E u) : - Proper (pointwise_relation _ eutt ==> go_sim (@eutt E R)) (VisF e). -Proof. - repeat intro. red in H. pfold. econstructor. - - repeat econstructor. - - intros. - destruct UNTAUS1 as [UNTAUS1 Hnotau1]. - destruct UNTAUS2 as [UNTAUS2 Hnotau2]. - dependent destruction UNTAUS1. - dependent destruction UNTAUS2. simpobs. - econstructor; intros; left; apply H. -Qed. +Arguments eutt_nested_clo_bind : clear implicits. +Hint Constructors eutt_nested_bind_clo. -Instance eq_itree_notauF {E R} : - Proper (go_sim (@eq_itree E R) ==> flip impl) (@notauF E R _). -Proof. - repeat intro. punfold H. inv H; simpl in *; subst; eauto. -Qed. +Section EUTT_eq. -(* If [t1] and [t2] are equivalent, then either both start with - finitely many taus, or both [spin]. *) -Instance eutt_finite_taus {E R} : - Proper (go_sim (@eutt E R) ==> flip impl) (@finite_tausF E R). -Proof. - repeat intro. punfold H. eapply H. eauto. -Qed. +Context {E : Type -> Type} {R : Type}. -(* Lemmas about [bind]. *) +Let eutt : itree E R -> itree E R -> Prop := eutt eq. -Lemma untaus_bind {E S R} : forall t t' (k: S -> itree E R) - (UNTAUS: untausF (observe t) (observe t')), - untausF (observe (ITree.bind t k)) (observe (ITree.bind t' k)). +Global Instance subrelation_observing_eutt: + @subrelation (itree E R) (observing eq) eutt. Proof. - intros. genobs t ot; genobs t' ot'. revert t Heqot t' Heqot'. - induction UNTAUS; intros; subst. - - rewrite !bind_unfold; simpobs; eauto. - - rewrite bind_unfold. simpobs. cbn. eauto. + repeat intro. eapply subrelation_eq_eutt, observing_eq_itree_eq. eauto. Qed. -Lemma untaus_bindF {E S R} : forall t t' (k: S -> itree E R) - (UNTAUS: untausF (observe t) t'), - untausF (observe (ITree.bind t k)) (observe (ITree.bind (go t') k)). -Proof. - intros; eapply untaus_bind; eauto. -Qed. +Global Instance Reflexive_eutt: Reflexive eutt. +Proof. apply Reflexive_eutt_gen; eauto. Qed. -Lemma finite_taus_bind_fst {E R S} - (t : itree E R) (f : R -> itree E S) : - finite_taus (ITree.bind t f) -> finite_taus t. -Proof. - intros [tf' [TAUS PROP]]. - genobs (ITree.bind t f) obtf. move TAUS at top. revert_until TAUS. - induction TAUS; intros; subst. - - rewrite bind_unfold in PROP. - genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. - - genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. - rewrite bind_unfold in Heqobtf. simpobs. inv Heqobtf. unfold_bind. - eapply finite_taus_tau; eauto. -Qed. +Global Instance Symmetric_eutt: Symmetric eutt. +Proof. apply Symmetric_eutt_gen; eauto. Qed. -Lemma finite_taus_bind {E R S} - (t : itree E R) (f : R -> itree E S) - (FINt: finite_tausF (observe t)) - (FINk: forall v, finite_tausF (observe (f v))): - finite_tausF (observe (ITree.bind t f)). +Global Instance Transitive_eutt : Transitive eutt. Proof. - rewrite bind_unfold. - genobs t ot. clear Heqot t. - destruct FINt as [ot' [UNT NOTAU]]. - induction UNT; subst. - - destruct ot0; inv NOTAU; simpl; eauto 7. - - apply finite_taus_tau. eauto. + unfold eutt. repeat intro. pupto2_init. + rewrite H, H0. pupto2_final. apply Reflexive_eutt. Qed. -Lemma untaus_eq_idx E R: forall (ot1 ot2: itreeF E R _), - untausF ot1 ot2 -> untausF ot1 ot2. -Proof. intros; subst; eauto. Qed. +(* We can now rewrite with [eutt] equalities. *) +Global Instance Equivalence_eutt : @Equivalence (itree E R) eutt. +Proof. constructor; typeclasses eauto. Qed. + +Global Instance eutt_cong_go : Proper (going eutt ==> eutt) go. +Proof. intros ? ? []; eauto. Qed. -Lemma untaus_untaus E R: forall (ot1 ot2 ot3: itreeF E R _), - untausF ot1 ot2 -> untausF ot2 ot3 -> untausF ot1 ot3. +Global Instance eutt_cong_observe : Proper (eutt ==> going eutt) observe. Proof. - intros t1 t2 t3. induction 1; simpl; eauto. + constructor. punfold H. pfold. destruct H. econstructor; eauto. Qed. -Lemma untaus_unalltus_rev E R (ot1 ot2 ot3: itreeF E R _) : - untausF ot1 ot2 -> unalltausF ot1 ot3 -> unalltausF ot2 ot3. +Global Instance eutt_cong_tauF : Proper (eutt ==> going eutt) (@TauF _ _ _). Proof. - intros H. revert ot3. - induction H; intros. - - eauto using untaus_eq_idx with arith. - - destruct H0 as [Huntaus Hnotau]. - destruct Huntaus. - + exfalso; eauto. - + inv OBS0. inversion H0; subst; eauto. + constructor. pfold. pfold. econstructor. punfold H. Qed. -Lemma eutt_strengthen {E R}: - forall r (t1 t2: itree E R) - (FIN: finite_taus t1 <-> finite_taus t2) - (EQV: forall t1' t2' - (UNT1: unalltaus t1 t1') - (UNT2: unalltaus t2 t2'), - paco2 (eutt_ ∘ gres2 eutt_) r t1' t2'), - paco2 (eutt_ ∘ gres2 eutt_) r t1 t2. -Proof. - intros. pfold. econstructor; eauto. - intros. - hexploit (EQV (go ot1') (go ot2')); eauto. - intros EQV'. punfold EQV'. destruct EQV'. - eapply EQV0; - repeat constructor; eauto. eapply UNTAUS1. eapply UNTAUS2. +Global Instance eutt_cong_VisF {u} (e: E u) : + Proper (pointwise_relation _ eutt ==> going eutt) (VisF e). +Proof. + constructor. pfold. pfold. econstructor. + intros. specialize (H x0). punfold H. Qed. -Inductive eutt_trans_clo {E R} (r: relation (itree E R)) : relation (itree E R) := -| eutt_pre_clo_intro (t1 t2 t3 t4: itree E R) - (EQVl: t1 ≈ t2) - (EQVr: t4 ≈ t3) - (REL: r t2 t3) - : eutt_trans_clo r t1 t4 -. -Hint Constructors eutt_trans_clo. +End EUTT_eq. -Lemma eutt_clo_trans E R: weak_respectful2 (@eutt_ E R) eutt_trans_clo. -Proof. - econstructor; [pmonauto|]. - intros. inv PR. - punfold EQVl. punfold EQVr. destruct EQVl, EQVr. split. - { rewrite FIN, FIN0. apply GF in REL. destruct REL. eauto. } - - intros. apply proj1 in FIN. edestruct FIN as [n'' [t2'' TAUS'']]; [eexists; eauto|]. - hexploit EQV; eauto. intros EUTT1. - apply proj1 in FIN0. edestruct FIN0 as [n''' [t2''' TAUS''']]; [eexists; eauto|]. - hexploit EQV0; eauto. intros EUTT2. - apply GF in REL. destruct REL. - hexploit EQV1; eauto. intros EUTT3. - destruct EUTT1; destruct EUTT2; - try (solve [inversion EUTT3; auto]). - remember (VisF _ _) as o2 in EUTT3. - remember (VisF _ _) as o3 in EUTT3. - inversion EUTT3; subst; try discriminate. - inversion H2; clear H2; inversion H3; clear H3. - subst; auto_inj_pair2; subst. - econstructor. intros. - specialize (H x); specialize (H0 x); specialize (H1 x). - pclearbot. eauto using rclo2. -Qed. - -Inductive eutt_tau_clo {E R} (r: relation (itree E R)) : relation (itree E R) := -| eutt_tau_clo_intro (t1 t2: itree E R) - (REL: r t1 t2) : eutt_tau_clo r (Tau t1) (Tau t2). -Hint Constructors eutt_tau_clo. - -Lemma eutt_clo_tau E R: weak_respectful2 (@eutt_ E R) eutt_tau_clo. -Proof. - econstructor; [pmonauto|]. - intros l r LE GF x0 x1 PR. - inv PR. - hexploit LE; eauto; intros H. - hexploit GF; eauto; intros EUTT. - dependent destruction EUTT. - econstructor. - - rewrite <- finite_taus_tau in FIN. - rewrite <- finite_taus_tau in FIN. - assumption. - - intros. - apply unalltaus_tau with (t:=t1) in UNTAUS1; auto. - apply unalltaus_tau with (t:=t2) in UNTAUS2; auto. - eapply EQV in UNTAUS1; eauto. - eapply monotone_eq_notauF. apply UNTAUS1. - intros. apply rclo2_incl. assumption. -Qed. - -Inductive eutt_bind_clo {E R} (r: relation (itree E R)) : relation (itree E R) := -| eutt_bind_clo_intro U (t1 t2: itree E U) k1 k2 - (EQV: t1 ≈ t2) - (REL: forall v, r (k1 v) (k2 v)) - : eutt_bind_clo r (ITree.bind t1 k1) (ITree.bind t2 k2) -. -Hint Constructors eutt_bind_clo. +(**) -Lemma bind_clo_finite_taus E U R (t1 t2: itree E U) (k1 k2: U -> itree E R) - (FT: finite_taus (ITree.bind t1 k1)) - (FTk: forall v, finite_taus (k1 v) -> finite_taus (k2 v)) - (EQV: t1 ≈ t2): - finite_taus (ITree.bind t2 k2). +Lemma eutt_tau {E R1 R2} (RR : R1 -> R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : + eutt RR t1 t2 -> eutt RR (Tau t1) (Tau t2). Proof. - punfold EQV. destruct EQV as [[FTt _] EQV]. - assert (FT1 := FT). apply finite_taus_bind_fst in FT1. - assert (FT2 := FT1). apply FTt in FT2. - destruct FT1 as [a [FT1 NT1]], FT2 as [b [FT2 NT2]]. - rewrite @untaus_finite_taus in FT; [|eapply untaus_bindF, FT1]. - rewrite bind_unfold. genobs t2 ot2. clear Heqot2 t2. - induction FT2. - - destruct ot0; inv NT2; simpl; eauto 7. - hexploit EQV; eauto. intros EQV'. inv EQV'. - rewrite bind_unfold in FT. eauto. - - subst. eapply finite_taus_tau; eauto. - eapply IHFT2; eauto using unalltaus_tau'. + intros. pfold. pfold. econstructor. punfold H. Qed. -Lemma eutt_clo_bind E R: weak_respectful2 (@eutt_ E R) eutt_bind_clo. +Lemma eutt_vis {E R1 R2} (RR : R1 -> R2 -> Prop) + {U} (e : E U) (k1 : U -> itree E R1) (k2 : U -> itree E R2) : + (forall u, eutt RR (k1 u) (k2 u)) -> + eutt RR (Vis e k1) (Vis e k2). Proof. - econstructor; [pmonauto|]. - intros. destruct PR. split. - - assert (EQV':=EQV). symmetry in EQV'. - split; intros; eapply bind_clo_finite_taus; eauto; intros. - + edestruct GF; eauto. apply FIN. eauto. - + edestruct GF; eauto. apply FIN. eauto. - - punfold EQV. destruct EQV. - intros. - hexploit (@finite_taus_bind_fst E); [do 2 eexists; apply UNTAUS1|]. intros [a FT1]. - hexploit (@finite_taus_bind_fst E); [do 2 eexists; apply UNTAUS2|]. intros [b FT2]. - specialize (EQV _ _ FT1 FT2). - destruct FT1 as [FT1 Hnotau1]. destruct FT2 as [FT2 Hnotau2]. - hexploit @untaus_bindF; [ eapply FT1 | ]. intros UT1. - hexploit @untaus_bindF; [ eapply FT2 | ]. intros UT2. - hexploit untaus_unalltus_rev; [apply UT1| |]. eauto. intros UAT1. - hexploit untaus_unalltus_rev; [apply UT2| |]; eauto. intros UAT2. - inv EQV. - + rewrite bind_unfold in UAT1, UAT2. simpobs. cbn in *. - eapply GF in REL. destruct REL. - eapply monotone_eq_notauF; eauto using rclo2. - + rewrite bind_unfold in UAT1, UAT2. simpobs. cbn in *. - destruct UAT1 as [UAT1 _]. destruct UAT2 as [UAT2 _]. - dependent destruction UAT1. dependent destruction UAT2. simpobs. - econstructor. intros. specialize (H x). pclearbot. fold_bind. eauto using rclo2. + intros. pfold. pfold. econstructor. intros. specialize (H x). punfold H. Qed. -(* [eutt] is a congruence wrt. [bind] *) - -Instance eutt_bind {E R S} : - Proper (@eutt E R ==> - pointwise_relation _ eutt ==> - @eutt E S) ITree.bind. +Lemma eutt_ret {E R1 R2} (RR : R1 -> R2 -> Prop) r1 r2 : + RR r1 r2 -> @eutt E R1 R2 RR (Ret r1) (Ret r2). Proof. - repeat intro. pupto2_init. - pupto2 eutt_clo_bind. econstructor; eauto. - intros. pupto2_final. apply H0. + intros. pfold. pfold. econstructor. eauto. Qed. -Instance eutt_paco {E R} r: - Proper (@eutt E R ==> @eutt E R ==> flip impl) - (paco2 (eutt_ ∘ gres2 eutt_) r). +Global Instance eutt_map {E R S} : + Proper (pointwise_relation _ eq ==> eutt eq ==> eutt eq) (@ITree.map E R S). Proof. - repeat intro. pupto2 eutt_clo_trans. eauto. + unfold ITree.map. do 3 red. intros. + rewrite H0. setoid_rewrite H. reflexivity. Qed. -Instance eutt_gres {E R} r: - Proper (@eutt E R ==> @eutt E R ==> flip impl) - (gres2 eutt_ r). +Global Instance eutt_forever {E R S} : + Proper (eutt eq ==> eutt eq) (@ITree.forever E R S). Proof. - repeat intro. pupto2 eutt_clo_trans. eauto. + repeat intro. pupto2_init. revert_until S. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + rewrite (unfold_forever x), (unfold_forever y). + pupto2 eutt_nested_clo_bind. econstructor; eauto. + intros. subst. pupto2_final. pfold. simpl. eauto. Qed. -Instance eutt_map {E R S} : - Proper (pointwise_relation _ eq ==> @eutt E R ==> @eutt E S) ITree.map. -Proof. -Admitted. - -Instance eutt_forever {E R S} : - Proper (@eutt E R ==> @eutt E S) ITree.forever. +Global Instance eutt_when {E} (b : bool) : + Proper (eutt eq ==> eutt eq) (@ITree.when E b). Proof. -Admitted. -Instance eutt_when {E} (b : bool) : - Proper (@eutt E unit ==> @eutt E unit) (ITree.when b). -Proof. -Admitted. + repeat intro. destruct b; simpl; eauto. reflexivity. +Qed. Lemma eutt_map_map {E R S T} (f : R -> S) (g : S -> T) (t : itree E R) : - eutt (ITree.map g (ITree.map f t)) - (ITree.map (fun x => g (f x)) t). -Proof. - rewrite map_map. reflexivity. -Qed. - -Notation itree' E R := (itreeF E R (itree E R)). - -Definition observing {E R} - (f : itree' E R -> itree' E R -> Prop) - (x y : itree E R) := - f x.(observe) y.(observe). - -Inductive euttF1' {E R} (r : itree E R -> itree E R -> Prop) : - itree' E R -> itree' E R -> Prop := -| euttF1_Tau_L : forall t1 t2, - euttF1' r t1.(observe) t2 -> - euttF1' r (TauF t1) t2 -| euttF1_Tau_R : forall t1 t2, - euttF1' r t1 t2.(observe) -> - euttF1' r t1 (TauF t2) -| euttF1_euttF0 : forall t1 t2, - eq_notauF r t1 t2 -> - euttF1' r t1 t2 -. - -Definition euttF1 {E R} (r : relation (itree E R)) : - relation (itree E R) := observing (euttF1' r). - -Lemma euttF1_euttF {E R} (r : relation (itree E R)) : - forall t1 t2, - euttF1 r t1 t2 -> eutt_ r t1 t2. -Proof. -Admitted. - -Inductive euttF' {E R} (eutt: relation (itree E R)) (eqtaus: relation (itreeF E R _)) - : relation (itreeF E R _) := -| euttF'_ret r : euttF' eutt eqtaus (RetF r) (RetF r) -| euttF'_vis u (e : E u) k1 k2 - (EUTTK: forall x, eutt (k1 x) (k2 x)): - euttF' eutt eqtaus (VisF e k1) (VisF e k2) -| euttF'_tau_tau t1 t2 - (EQTAUS: eqtaus (observe t1) (observe t2)): - euttF' eutt eqtaus (TauF t1) (TauF t2) -| euttF'_tau_left t1 ot2 - (EQTAUS: euttF' eutt eqtaus (observe t1) ot2): - euttF' eutt eqtaus (TauF t1) ot2 -| euttF'_right ot1 t2 - (EQTAUS: euttF' eutt eqtaus ot1 (observe t2)): - euttF' eutt eqtaus ot1 (TauF t2) -. -Hint Constructors euttF'. - -Definition eutt'_ {E R} eutt t1 t2 := paco2 (@euttF' E R eutt) bot2 (* (fun x y => eutt (go x) (go y)) *) (observe t1) (observe t2). -Hint Unfold eutt'_. - -Definition eutt' {E R} := paco2 (@eutt'_ E R) bot2. -Hint Unfold eutt'. - -Lemma euttF'_mon {E R} r r' s s' x y - (EUTT: @euttF' E R r s x y) - (LEr: r <2= r') - (LEs: s <2= s'): - euttF' r' s' x y. + eutt eq (ITree.map g (ITree.map f t)) + (ITree.map (fun x => g (f x)) t). Proof. - induction EUTT; eauto. + apply subrelation_eq_eutt, map_map. Qed. -Lemma reflexive_euttF' {E R} eutt eqtaus (r1:Reflexive eutt) (r:Reflexive eqtaus) : Reflexive (@euttF' E R eutt eqtaus). -Proof. - unfold Reflexive. intros x. - destruct x; eauto. -Qed. - -Lemma monotone_euttF' {E R} eutt : monotone2 (@euttF' E R eutt). -Proof. repeat intro. eauto using euttF'_mon. Qed. -Hint Resolve monotone_euttF' : paco. - -Lemma monotone_eutt'_ {E R} : monotone2 (@eutt'_ E R). -Proof. red. eauto using euttF'_mon, paco2_mon_gen. Qed. -Hint Resolve monotone_eutt'_ : paco. - -Lemma eutt__is_eutt'_ {E R} r (t1 t2: itree E R) : - eutt_ r t1 t2 <-> eutt'_ r t1 t2. -Proof. - split; intros. - { revert t1 t2 H. pcofix CIH'. intros. destruct H0. - genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - assert (EM: notauF ot1 \/ notauF ot2 \/ ~(notauF ot1 \/ notauF ot2)) - by (destruct ot1, ot2; simpl; tauto). - destruct EM as [EM|[EM|EM]]. - - destruct FIN as [FIN _]. - hexploit FIN; eauto 7. clear FIN; intro FIN. - destruct FIN as [ot' [UNTAUS NOTAU]]. - hexploit EQV; eauto. intros EQNT. - induction UNTAUS; subst. - { pfold. inv EQNT; eauto. } - hexploit IHUNTAUS; eauto. - { intros. destruct UNTAUS1. - dependent destruction H; [|subst; contradiction]. - hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. - } - intros EUTT. punfold EUTT. - - destruct FIN as [_ FIN]. - hexploit FIN; eauto 7. clear FIN; intro FIN. - destruct FIN as [ot' [UNTAUS NOTAU]]. - hexploit EQV; eauto. intros EQNT. - induction UNTAUS; subst. - { pfold. inv EQNT; eauto. } - hexploit IHUNTAUS; eauto. - { intros. destruct UNTAUS2. - dependent destruction H; [|subst; contradiction]. - hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. - } - intros EUTT. punfold EUTT. - - destruct ot1, ot2; simpl in *; try tauto. - pfold. econstructor. right. apply CIH'. - econstructor. - + rewrite !finite_taus_tau in FIN. eauto. - + eauto using unalltaus_tau'. - } - { punfold H. econstructor; intros. - - split; intros. - + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - destruct H0 as [ot' [UNTAUS NOTAU]]. - move UNTAUS before r. revert_until UNTAUS. - induction UNTAUS; intros. - * induction H; eauto; try contradiction. - rewrite finite_taus_tau. eauto. - * induction H; eauto 7; try inv OBS; pclearbot - ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. - punfold EQTAUS. - + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - destruct H0 as [ot' [UNTAUS NOTAU]]. - move UNTAUS before r. revert_until UNTAUS. - induction UNTAUS; intros. - * induction H; eauto; try contradiction. - rewrite finite_taus_tau. eauto. - * induction H; eauto 7; try inv OBS; pclearbot - ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. - punfold EQTAUS. - - genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - destruct UNTAUS1 as [UNTAUS1 NT1]. destruct UNTAUS2 as [UNTAUS2 NT2]. - move UNTAUS2 before r. move UNTAUS1 before r. revert_until UNTAUS1. - induction UNTAUS1. - + induction 1; intros. - * inv H; try contradiction; eauto. - * subst. inv H; try contradiction. eauto. - + induction 1; intros; subst. - * inv H; try contradiction; eauto. - * inv H; try contradiction; eauto. - pclearbot. eapply IHUNTAUS1; eauto. - punfold EQTAUS. - } -Qed. - -Lemma eutt_is_eutt' {E R} r (t1 t2: itree E R) : - paco2 eutt_ r t1 t2 <-> paco2 eutt'_ r t1 t2. -Proof. - split; intros; eapply paco2_mon_gen; eauto; intros; apply eutt__is_eutt'_; eauto. -Qed. - -Lemma eutt_is_eutt'_gres {E R} r (t1 t2: itree E R) : - paco2 (eutt_ ∘ gres2 eutt_) r t1 t2 <-> paco2 (eutt'_ ∘ gres2 eutt'_) r t1 t2. -Proof. - split; intros. - - eapply paco2_mon_gen; eauto. intros. - red in PR|-*. rewrite <-eutt__is_eutt'_. - eapply monotone_eutt_; eauto. intros. - eapply grespectful2_impl; eauto. intros. - rewrite eutt__is_eutt'_. reflexivity. - - eapply paco2_mon_gen; eauto. intros. - red in PR|-*. rewrite eutt__is_eutt'_. - eapply monotone_eutt'_; eauto. intros. - eapply grespectful2_impl; eauto. intros. - rewrite eutt__is_eutt'_. reflexivity. -Qed. - -Instance eutt'_paco {E R} r: - Proper (@eutt E R ==> @eutt E R ==> flip impl) - (paco2 (eutt'_ ∘ gres2 eutt'_) r). +Lemma tau_eutt {E R} (t: itree E R) : Tau t ≈ t. Proof. - repeat intro. - rewrite <-eutt_is_eutt'_gres. - rewrite <-eutt_is_eutt'_gres in H1. - rewrite H, H0. eauto. + pfold. pfold. econstructor. reflexivity. Qed. -Instance eutt'_gres {E R} r: - Proper (@eutt E R ==> @eutt E R ==> flip impl) - (gres2 eutt'_ r). +(** Generalized heterogeneous version of [eutt_bind] *) +Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: + forall t1 t2, + eutt RR t1 t2 -> + forall s1 s2, (forall r1 r2, RR r1 r2 -> eutt SS (s1 r1) (s2 r2)) -> + @eutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). Proof. - repeat intro. - rewrite grespectful2_iff; [|intros; erewrite eutt__is_eutt'_; reflexivity]. - rewrite grespectful2_iff in H1; [|intros; erewrite eutt__is_eutt'_; reflexivity]. - rewrite H, H0. eauto. + intros. red in H0. pupto2_init. pupto2 eutt_clo_bind. econstructor; eauto. + intros. pupto2_final. eauto. Qed. diff --git a/theories/Eq/UpToTausExplicit.v b/theories/Eq/UpToTausExplicit.v new file mode 100644 index 00000000..bdb24439 --- /dev/null +++ b/theories/Eq/UpToTausExplicit.v @@ -0,0 +1,609 @@ +(* Equivalence up to taus *) +(* We consider tau as an "internal step", that should not be + visible to the outside world, so adding or removing [Tau] + constructors from an itree should produce an equivalent itree. + + We must be careful because there may be infinite sequences of + taus (i.e., [spin]). Here we shall only allow inserting finitely + many taus between any two visible steps ([Ret] or [Vis]), so that + [spin] is only related to itself. The main consequence of this + choice is that equivalence up to taus is an equivalence relation. + *) + +(* TODO: + - Generalize Reflexivity, Symmetry, Transitivity to heterogeneous + eutt. + - Make eutt a notation instead of a definition? + *) + +Require Import Paco.paco. + +From Coq Require Import + Program + Lia + Classes.RelationClasses + Classes.Morphisms + Setoids.Setoid + Relations.Relations. + +From ITree Require Import + Core. + +From ITree Require Export + Eq.Eq + Eq.Untaus + Eq.UpToTaus. + +Local Open Scope itree. + +Section EUTT. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +(* [euttE_ euttE t1 t2] means that, if [t1] or [t2] ever takes a + visible step ([Vis] or [Ret]), then the other takes the same + step, and the subsequent continuations (in the [Vis] case) are + related by [euttE]. In particular, [(t1 = spin)%eq_itree] if + and only if [(t2 = spin)%eq_itree]. Note also that in that + case, the parameter [euttE] is irrelevant. + + This is the relation we will take a fixpoint of. *) +Inductive euttEF (euttE : itree E R1 -> itree E R2 -> Prop) + (ot1 : itreeF E R1 (itree E R1)) + (ot2 : itreeF E R2 (itree E R2)) : Prop := +| euttEF_ (FIN: finite_tausF ot1 <-> finite_tausF ot2) + (EQV: forall ot1' ot2' + (UNTAUS1: unalltausF ot1 ot1') + (UNTAUS2: unalltausF ot2 ot2'), + eq_notauF RR euttE ot1' ot2') +. +Hint Constructors euttEF. + +Definition euttE_ (euttE : itree E R1 -> itree E R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : Prop := + euttEF euttE (observe t1) (observe t2). +Hint Unfold euttE_. + +(* [euttE_] is monotone. *) +Lemma monotone_euttE_ : monotone2 euttE_. +Proof. pmonauto. Qed. +Hint Resolve monotone_euttE_ : paco. + +(* We now take the greatest fixpoint of [euttE_]. *) + +(* Equivalence Up To Taus. + + [euttE t1 t2]: [t1] is equivalent to [t2] up to taus. *) +Definition euttE : itree E R1 -> itree E R2 -> Prop := paco2 euttE_ bot2. +Hint Unfold euttE. + +Global Arguments euttE t1%itree t2%itree. + +(* Lemmas about the auxiliary relations. *) + +(* Many have a name [X_Y] to represent an implication + [X _ -> Y _] (possibly with more arguments on either side). *) + +(**) + +Lemma euttEF_tau r t1 t2 t1' t2' + (OBS1: TauF t1' = observe t1) + (OBS2: TauF t2' = observe t2) + (REL: euttE_ r t1' t2'): + euttE_ r t1 t2. +Proof. + intros. destruct REL. econstructor. + - simpobs. rewrite !finite_taus_tau. eauto. + - intros. eapply EQV; eapply unalltaus_tau; eauto. +Qed. + +Lemma euttEF_tau_left r t1 t2 t1' + (OBS: TauF t1 = observe t1') + (REL: euttE_ r t1' t2): + euttE_ r t1 t2. +Proof. + intros. destruct REL. econstructor. + - rewrite <- FIN. symmetry. rewrite <- OBS. rewrite <- finite_taus_tau; eauto. reflexivity. + - intros. eapply EQV; eauto. rewrite <- OBS. inversion UNTAUS1. constructor; auto. + econstructor; eauto. +Qed. + +Lemma euttEF_tau_right r t1 t2 t2' + (OBS: TauF t2 = observe t2') + (REL: euttE_ r t1 t2'): + euttE_ r t1 t2. +Proof. + intros. destruct REL. econstructor. + - rewrite FIN. rewrite <- OBS. rewrite <- finite_taus_tau; eauto. reflexivity. + - intros. eapply EQV; eauto. rewrite <- OBS. inversion UNTAUS2. constructor; auto. + econstructor; eauto. +Qed. + +Lemma euttEF_vis {u} (r : _ -> _ -> Prop) t1 t2 (e : _ u) k1 k2 + (OBS1: VisF e k1 = observe t1) + (OBS2: VisF e k2 = observe t2) + (REL: forall x, r (k1 x) (k2 x)): + euttE_ r t1 t2. +Proof. + intros. econstructor. + - split; intros; eapply notau_finite_taus; eauto. + - intros. + apply unalltaus_notau_id in UNTAUS1; eauto. + apply unalltaus_notau_id in UNTAUS2; eauto. + simpobs. subst. eauto. +Qed. + +(**) + +Lemma euttE_strengthen : + forall r (t1 : itree E R1) (t2 : itree E R2) + (FIN: finite_taus t1 <-> finite_taus t2) + (EQV: forall t1' t2' + (UNT1: unalltaus t1 t1') + (UNT2: unalltaus t2 t2'), + paco2 (euttE_ ∘ gres2 euttE_) r t1' t2'), + paco2 (euttE_ ∘ gres2 euttE_) r t1 t2. +Proof. + intros. pfold. econstructor; eauto. + intros. + hexploit (EQV (go ot1') (go ot2')); eauto. + intros EQV'. punfold EQV'. destruct EQV'. + eapply EQV0; + repeat constructor; eauto. +Qed. + +(**) + +Lemma euttE_Ret x y : + RR x y -> euttE (Ret x) (Ret y). +Proof. + intros; pfold. + constructor. + split; intros; eapply finite_taus_ret; reflexivity. + intros. + apply unalltausF_ret in UNTAUS1. + apply unalltausF_ret in UNTAUS2. + subst; constructor; assumption. +Qed. + +Lemma euttE_Vis {U} (e: E U) k k' : + (forall x, euttE (k x) (k' x)) -> + euttE (Vis e k) (Vis e k'). +Proof. + intros. + pfold; constructor. + split; intros; eapply finite_taus_vis; reflexivity. + intros. + cbn in *. + apply unalltausF_vis in UNTAUS1. + apply unalltausF_vis in UNTAUS2. + subst; constructor. + intros x; specialize (H x). + punfold H. +Qed. + +End EUTT. + +Hint Unfold euttE_. +Hint Unfold euttE. +Hint Constructors euttEF. +Hint Resolve monotone_euttE_ : paco. + +Lemma Symmetric_euttEF_ {E R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) + (ot1 : itree' E R1) (ot2 : itree' E R2) : + euttEF RR1 r1 ot1 ot2 -> + euttEF RR2 r2 ot2 ot1. +Proof. + intros []; split. + - split; apply FIN. + - intros. specialize (EQV _ _ UNTAUS2 UNTAUS1). + eapply Symmetric_eq_notauF_; eauto. +Qed. + +Lemma Transitive_euttEF_ {E R1 R2 R3} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop) + (RR3 : R1 -> R3 -> Prop) + (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) + (r3 : _ -> _ -> Prop) + (TRANS_RR : forall r1 r2 r3, RR1 r1 r2 -> RR2 r2 r3 -> RR3 r1 r3) + (TRANS_r : forall i j k, r1 i j -> r2 j k -> r3 i k) + (ot1 : itree' E R1) ot2 ot3 : + euttEF RR1 r1 ot1 ot2 -> + euttEF RR2 r2 ot2 ot3 -> + euttEF RR3 r3 ot1 ot3. +Proof. + intros [] []. + constructor. + - etransitivity; eauto. + - intros t1' t3' H1 H3. + assert (FIN2 : finite_tausF ot2). + { apply FIN; eauto. } + destruct FIN2 as [t2' []]. + eapply Transitive_eq_notauF_; eauto. +Qed. + +Lemma Symmetric_euttE_ {E R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) : + forall (t1 : itree E R1) (t2 : itree E R2), + paco2 (euttE_ RR1) r1 t1 t2 -> paco2 (euttE_ RR2) r2 t2 t1. +Proof. + pcofix self. + intros t1 t2 H12. + punfold H12. + pfold. + eapply Symmetric_euttEF_; try eassumption. + intros ? ? []; auto. +Qed. + +Lemma Transitive_euttE_ {E R1 R2 R3} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop) + (RR3 : R1 -> R3 -> Prop) + (TRANS_RR : forall r1 r2 r3, RR1 r1 r2 -> RR2 r2 r3 -> RR3 r1 r3) : + forall (t1 : itree E R1) t2 t3, + euttE RR1 t1 t2 -> euttE RR2 t2 t3 -> euttE RR3 t1 t3. +Proof. + pcofix self. + intros t1 t2 t3 H12 H23. + punfold H12; punfold H23; pfold. + eapply Transitive_euttEF_; try eassumption. + intros; pclearbot; eauto. +Qed. + +Section EUTT_rel. + +Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). + +Global Instance subrelation_eq_euttE : + @subrelation (itree E R) (eq_itree RR) (euttE RR). +Proof. + pcofix CIH. intros. + pfold. econstructor. + { split; [|apply flip_eq_itree in H0]; intros; destruct H as [n [? ?]]; eauto using eq_unalltaus. } + + intros. eapply eq_unalltaus_eqF in H0; eauto. destruct H0 as [s' [UNTAUS' EQV']]. + hexploit @unalltaus_injective; [apply UNTAUS' | apply UNTAUS2 | intro X]; subst. + inv EQV'; simpobs; eauto. + eapply unalltaus_notau in UNTAUS1. contradiction. +Qed. + +Global Instance Reflexive_euttEF `{Reflexive _ RR} + (r : itree E R -> itree E R -> Prop) : + Reflexive r -> Reflexive (euttEF RR r). +Proof. + split. + - reflexivity. + - intros. + erewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). + apply Reflexive_eq_notauF; eauto. +Qed. + +Global Instance Symmetric_euttEF `{Symmetric _ RR} + (r : itree E R -> itree E R -> Prop) : + Symmetric r -> Symmetric (euttEF RR r). +Proof. + intros SYM x y. apply Symmetric_euttEF_; auto. +Qed. + +Global Instance Transitive_euttEF `{Transitive _ RR} + (r : itree E R -> itree E R -> Prop) : + Transitive r -> Transitive (euttEF RR r). +Proof. + intros TRANS x y z. apply Transitive_euttEF_; auto. +Qed. + +Global Instance Symmetric_euttE `{Symmetric _ RR} + (r : itree E R -> itree E R -> Prop) + (Sr : Symmetric r) : + Symmetric (paco2 (euttE_ RR) r). +Proof. red; eapply Symmetric_euttE_; eauto. Qed. + +Global Instance Reflexive_euttE `{Reflexive _ RR} + (r : itree E R -> itree E R -> Prop) : + Reflexive (paco2 (euttE_ RR) r). +Proof. + pcofix CIH. + intros. pfold. red. apply Reflexive_euttEF; eauto. +Qed. + +End EUTT_rel. + +Section EUTT_eq. + +Context {E : Type -> Type} {R : Type}. + +Let euttE : itree E R -> itree E R -> Prop := euttE eq. + +Global Instance Transitive_euttE : Transitive euttE. +Proof. + red; eapply Transitive_euttE_; eauto. + intros; subst; eauto. +Qed. + +(**) + +(* [euttE] is preserved by removing one [Tau]. *) +Lemma tauF_euttE (t t': itree E R) (OBS: TauF t' = observe t): euttE t t'. +Proof. + pfold. split. + - simpobs. rewrite finite_taus_tau. reflexivity. + - intros t1' t2' H1 H2. + eapply unalltaus_tau in H1; eauto. + pose proof (unalltaus_injective _ _ _ H1 H2). + subst; apply Reflexive_eq_notauF; eauto. + left. apply reflexivity. +Qed. + +Lemma tau_euttE (t: itree E R) : euttE (Tau t) t. +Proof. + eapply tauF_euttE. eauto. +Qed. + +(* [euttE] is preserved by removing all [Tau]. *) +Lemma untaus_euttE (t t' : itree E R) : untausF (observe t) (observe t') -> euttE t t'. +Proof. + intros H. + pfold. split. + - eapply untaus_finite_taus; eauto. + - induction H; intros. + + rewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). + apply Reflexive_eq_notauF; eauto. + left; apply reflexivity. + + eapply unalltaus_tau in UNTAUS1; eauto. +Qed. + +(* We can now rewrite with [euttE] equalities. *) +Global Instance Equivalence_euttE : @Equivalence (itree E R) euttE. +Proof. constructor; typeclasses eauto. Qed. + +(**) + +Global Instance euttE_go : Proper (going euttE ==> euttE) go. +Proof. intros ? ? []; eauto. Qed. + +Global Instance euttE_observe : Proper (euttE ==> going euttE) observe. +Proof. + constructor. punfold H. pfold. destruct H. econstructor; eauto. +Qed. + +Global Instance euttE_tauF : Proper (euttE ==> going euttE) (fun t => TauF t). +Proof. + constructor; pfold. punfold H. + destruct H. econstructor. + - split; intros; simpl. + + rewrite finite_taus_tau, <-FIN, <-finite_taus_tau; eauto. + + rewrite finite_taus_tau, FIN, <-finite_taus_tau; eauto. + - intros. eapply EQV; eapply unalltaus_tau; eauto. +Qed. + +Global Instance euttE_VisF {u} (e: E u) : + Proper (pointwise_relation _ euttE ==> going euttE) (VisF e). +Proof. + constructor; pfold. red in H. econstructor. + - repeat econstructor. + - intros. + destruct UNTAUS1 as [UNTAUS1 Hnotau1]. + destruct UNTAUS2 as [UNTAUS2 Hnotau2]. + dependent destruction UNTAUS1. + dependent destruction UNTAUS2. simpobs. + econstructor; intros; left; apply H. +Qed. + +(* If [t1] and [t2] are equivalent, then either both start with + finitely many taus, or both [spin]. *) +Global Instance euttE_finite_taus : + Proper (going euttE ==> flip impl) finite_tausF. +Proof. + intros ? ? [] ?; punfold H. eapply H. eauto. +Qed. + +End EUTT_eq. + +(**) + +Lemma euttE_tau {E R1 R2} (RR : R1 -> R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : + euttE RR t1 t2 -> euttE RR (Tau t1) (Tau t2). +Proof. + intros H. + pfold. eapply euttEF_tau. reflexivity. reflexivity. punfold H. +Qed. + +(* Lemmas about [bind]. *) + +Inductive euttE_bind_clo {E R1 R2} (r: itree E R1 -> itree E R2 -> Prop) : itree E R1 -> itree E R2 -> Prop := +| euttE_bind_clo_intro U1 U2 RU t1 t2 k1 k2 + (EQV: @euttE E U1 U2 RU t1 t2) + (REL: forall v1 v2 (RELv: RU v1 v2), r (k1 v1) (k2 v2)) + : euttE_bind_clo r (ITree.bind t1 k1) (ITree.bind t2 k2) +. +Hint Constructors euttE_bind_clo. + +Lemma bind_clo_finite_taus {E U1 U2 RU R1 R2} t1 t2 k1 k2 + (FT: finite_taus (@ITree.bind E U1 R1 t1 k1)) + (FTk: forall v1 v2 (RELv: RU v1 v2 : Prop), finite_taus (k1 v1) -> finite_taus (k2 v2)) + (EQV: euttE RU t1 t2): + finite_taus (@ITree.bind E U2 R2 t2 k2). +Proof. + punfold EQV. destruct EQV as [[FTt _] EQV]. + assert (FT1 := FT). apply finite_taus_bind_fst in FT1. + assert (FT2 := FT1). apply FTt in FT2. + destruct FT1 as [a [FT1 NT1]], FT2 as [b [FT2 NT2]]. + rewrite @untaus_finite_taus in FT; [|eapply untaus_bindF, FT1]. + rewrite unfold_bind. genobs t2 ot2. clear Heqot2 t2. + induction FT2. + - destruct ot0; inv NT2; simpl; eauto 7. + hexploit EQV; eauto. intros EQV'. inv EQV'. + rewrite unfold_bind in FT. eauto. + - subst. eapply finite_taus_tau; eauto. + eapply IHFT2; eauto using unalltaus_tau'. +Qed. + +Lemma euttE_clo_bind {E R1 R2} RR : weak_respectful2 (@euttE_ E R1 R2 RR) euttE_bind_clo. +Proof. + econstructor; [pmonauto|]. + intros. destruct PR. split. + - assert (EQV':=EQV). + eapply (Symmetric_euttE_ RU (flip RU) bot2 bot2) in EQV'; eauto. + split; intros; eapply bind_clo_finite_taus; eauto; intros. + + edestruct GF; eauto. apply FIN. eauto. + + edestruct GF; eauto. apply FIN. eauto. + - punfold EQV. destruct EQV. + intros. + hexploit (@finite_taus_bind_fst E); [do 2 eexists; apply UNTAUS1|]. intros [a FT1]. + hexploit (@finite_taus_bind_fst E); [do 2 eexists; apply UNTAUS2|]. intros [b FT2]. + specialize (EQV _ _ FT1 FT2). + destruct FT1 as [FT1 Hnotau1]. destruct FT2 as [FT2 Hnotau2]. + hexploit @untaus_bindF; [ eapply FT1 | ]. intros UT1. + hexploit @untaus_bindF; [ eapply FT2 | ]. intros UT2. + hexploit @untaus_unalltaus_rev; [apply UT1| |]. eauto. intros UAT1. + hexploit @untaus_unalltaus_rev; [apply UT2| |]; eauto. intros UAT2. + inv EQV. + + rewrite unfold_bind in UAT1. rewrite unfold_bind in UAT2. cbn in *. + eapply GF in REL; eauto. destruct REL. + eapply monotone_eq_notauF; eauto using rclo2. + + rewrite unfold_bind in UAT1. rewrite unfold_bind in UAT2. cbn in *. + destruct UAT1 as [UAT1 _]. destruct UAT2 as [UAT2 _]. + dependent destruction UAT1. dependent destruction UAT2. simpobs. + econstructor. intros. specialize (H x). pclearbot. fold_bind. eauto using rclo2. +Qed. + +Inductive euttE_trans_clo {E R1 R2} (r: itree E R1 -> itree E R2 -> Prop) : + itree E R1 -> itree E R2 -> Prop := +| euttE_pre_clo_intro t1 t2 t3 t4 + (EQVl: euttE eq t1 t2) + (EQVr: euttE eq t4 t3) + (REL: r t2 t3) + : euttE_trans_clo r t1 t4 +. +Hint Constructors euttE_trans_clo. + +Lemma euttE_clo_trans {E R1 R2} RR : + weak_respectful2 (@euttE_ E R1 R2 RR) euttE_trans_clo. +Proof. + econstructor; [pmonauto|]. + intros. inv PR. + punfold EQVl. punfold EQVr. destruct EQVl, EQVr. split. + { rewrite FIN, FIN0. apply GF in REL. destruct REL. eauto. } + + intros. apply proj1 in FIN. edestruct FIN as [n'' [t2'' TAUS'']]; [eexists; eauto|]. + hexploit EQV; eauto. intros EUTT1. + apply proj1 in FIN0. edestruct FIN0 as [n''' [t2''' TAUS''']]; [eexists; eauto|]. + hexploit EQV0; eauto. intros EUTT2. + apply GF in REL. destruct REL. + hexploit EQV1; eauto. intros EUTT3. + destruct EUTT1; destruct EUTT2; + try (solve [subst; inversion EUTT3; auto]). + remember (VisF _ _) as o2 in EUTT3. + remember (VisF _ _) as o3 in EUTT3. + inversion EUTT3; subst; try discriminate. + inversion H2; clear H2; inversion H3; clear H3. + subst; auto_inj_pair2; subst. + econstructor. intros. + specialize (H x); specialize (H0 x); specialize (H1 x). + pclearbot. eauto using rclo2. +Qed. + +Arguments euttE_clo_trans : clear implicits. + + +Section EUTT_eq_EUTTE. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +Lemma euttE__impl_eutt_ r t1 t2 : + @euttE_ E R1 R2 RR r t1 t2 -> eutt_ RR r t1 t2. +Proof. + revert t1 t2. pcofix CIH'. intros. destruct H0. + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. + assert (EM: notauF ot1 \/ notauF ot2 \/ ~(notauF ot1 \/ notauF ot2)) + by (destruct ot1, ot2; simpl; tauto). + destruct EM as [EM|[EM|EM]]. + - destruct FIN as [FIN _]. + hexploit FIN; eauto 7. clear FIN; intro FIN. + destruct FIN as [ot' [UNTAUS NOTAU]]. + hexploit EQV; eauto. intros EQNT. + induction UNTAUS; subst. + { pfold. inv EQNT; eauto. } + hexploit IHUNTAUS; eauto. + { intros. destruct UNTAUS1. + dependent destruction H; [|subst; contradiction]. + hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. + } + intros EUTT. punfold EUTT. + - destruct FIN as [_ FIN]. + hexploit FIN; eauto 7. clear FIN; intro FIN. + destruct FIN as [ot' [UNTAUS NOTAU]]. + hexploit EQV; eauto. intros EQNT. + induction UNTAUS; subst. + { pfold. inv EQNT; eauto. } + hexploit IHUNTAUS; eauto. + { intros. destruct UNTAUS2. + dependent destruction H; [|subst; contradiction]. + hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. + } + intros EUTT. punfold EUTT. + - destruct ot1, ot2; simpl in *; try tauto. + pfold. econstructor. right. apply CIH'. + econstructor. + + rewrite !finite_taus_tau in FIN. eauto. + + eauto using unalltaus_tau'. +Qed. + +Lemma euttE_impl_eutt r t1 t2 : + paco2 (@euttE_ E R1 R2 RR) r t1 t2 -> paco2 (eutt_ RR) r t1 t2. +Proof. + split; intros; eapply paco2_mon_gen; eauto; intros; apply euttE__impl_eutt_; eauto. +Qed. + +Lemma eutt_impl_euttE r t1 t2 : + paco2 (@eutt_ E R1 R2 RR) r t1 t2 -> paco2 (euttE_ RR) r t1 t2. +Proof. + revert_until RR. pcofix CIH. intros. + rename H0 into H. do 2 punfold H. pfold. econstructor; intros. + - split; intros. + + genobs_clear t1 ot1. genobs_clear t2 ot2. + destruct H0 as [ot' [UNTAUS NOTAU]]. + move UNTAUS before r. revert_until UNTAUS. + induction UNTAUS; intros. + * induction H; eauto; try contradiction. + rewrite finite_taus_tau. eauto. + * induction H; eauto 7; try inv OBS; pclearbot + ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. + punfold EQTAUS. + + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. + destruct H0 as [ot' [UNTAUS NOTAU]]. + move UNTAUS before r. revert_until UNTAUS. + induction UNTAUS; intros. + * induction H; eauto; try contradiction. + rewrite finite_taus_tau. eauto. + * induction H; eauto 7; try inv OBS; pclearbot + ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. + punfold EQTAUS. + - genobs_clear t1 ot1. genobs_clear t2 ot2. + destruct UNTAUS1 as [UNTAUS1 NT1]. destruct UNTAUS2 as [UNTAUS2 NT2]. + move UNTAUS2 before r. move UNTAUS1 before r. revert_until UNTAUS1. + induction UNTAUS1. + + induction 1; intros. + * inv H; try contradiction; eauto. + econstructor. intros. + edestruct EUTTK as [TMP | TMP]; destruct TMP; eauto 7; contradiction. + * subst. inv H; try contradiction. eauto. + + induction 1; intros; subst. + * inv H; try contradiction; eauto. + * inv H; try contradiction; eauto. + pclearbot. eapply IHUNTAUS1; eauto. + punfold EQTAUS. +Qed. + +Lemma eutt_is_euttE r t1 t2 : + paco2 (@eutt_ E R1 R2 RR) r t1 t2 <-> paco2 (euttE_ RR) r t1 t2. +Proof. split; eauto using euttE_impl_eutt, eutt_impl_euttE. Qed. + +End EUTT_eq_EUTTE. diff --git a/theories/Fix.v b/theories/Fix.v index 9e5641bc..76be8254 100644 --- a/theories/Fix.v +++ b/theories/Fix.v @@ -85,11 +85,73 @@ Inductive callE (A B : Type) : Type -> Type := Arguments Call {A B}. +(** Get the [A] contained in a [callE A B]. *) +Definition unCall {A B T} (e : callE A B T) : A := + match e with + | Call a => a + end. + +(** Lift a function on [A] to a morphism on [callE]. *) +Definition calling {A B} {F : Type -> Type} + (f : A -> F B) : callE A B ~> F := + fun _ e => + match e with + | Call a => f a + end. + +(* This is identical to [callWith] but [rec] finds a universe + inconsistency with [callWith], and not with [callWith']. *) +Definition calling' {A B} {F : Type -> Type} + (f : A -> itree F B) : callE A B ~> itree F := + fun _ e => + match e with + | Call a => f a + end. + (* Interpret a single recursive definition. *) Definition rec {E : Type -> Type} {A B : Type} (body : A -> itree (callE A B +' E) B) : A -> itree E B := - fun a => mrec (fun _ call => - match call in callE _ _ T return itree (_ +' E) T with - | Call a => body a - end) _ (Call a). + fun a => mrec (calling' body) _ (Call a). + +Definition loop_once {E : Type -> Type} {A B C : Type} + (body : C + A -> itree E (C + B)) + (loop_ : C + A -> itree E B) : C + A -> itree E B := + fun ca => + cb <- body ca ;; + match cb with + | inl c => loop_ (inl c) + | inr b => Ret b + end. + +Definition loop_ {E : Type -> Type} {A B C : Type} + (body : C + A -> itree E (C + B)) : + C + A -> itree E B := + cofix loop__ := loop_once body (fun cb => Tau (loop__ cb)). + +(** Iterate a function updating an accumulator [C], + until it produces an output [B]. An encoding of tail recursive + functions. + + The Kleisli category for the [itree] monad is a traced + monoidal category, with [loop] as its trace. + *) +(* We use explicit recursion instead of relying on [rec] to + make the definition properly tail recursive. *) +Definition loop {E : Type -> Type} {A B C : Type} + (body : (C + A) -> itree E (C + B)) : + A -> itree E B := + fun a => loop_ body (inr a). + +(* Iterate a function updating an accumulator [A], until it produces + an output [B]. It's an Asymmetric variant of [loop], and it looks + similar to an Anamorphism, hence the name [aloop]. *) +Definition aloop {E : Type -> Type} {A B : Type} + (body : A -> itree E (A + B)) : + A -> itree E B := + cofix aloop_ a := + ab <- body a ;; + match ab with + | inl a => Tau (aloop_ a) + | inr b => Ret b + end. diff --git a/theories/FixFacts.v b/theories/FixFacts.v index 8b6aec1d..5b505bc3 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -11,52 +11,56 @@ From Coq Require Import From ITree Require Import Basics + Basics_Functions + OpenSum Core Morphisms MorphismsFacts Fix Effect.Sum - Eq.Eq Eq.UpToTaus. + Eq.Eq Eq.UpToTaus Eq.SimUpToTaus. Section Facts. Context {D E : Type -> Type} (ctx : D ~> itree (D +' E)). (** Unfolding of [interp_mrec]. *) + Definition interp_mrecF R : itreeF (D +' E) R _ -> itree E R := handleF1 (interp_mrec ctx R) (fun _ d k => Tau (interp_mrec ctx _ (ctx _ d >>= k))). -Lemma unfold_interp_mrecF R (t : itree (D +' E) R) : +Lemma observe_interp_mrecF R (t : itree (D +' E) R) : observe (interp_mrec ctx _ t) = observe (interp_mrecF _ (observe t)). Proof. reflexivity. Qed. -Lemma unfold_interp_mrec R (t : itree (D +' E) R) : - eq_itree (interp_mrec ctx _ t) +Lemma observe_interp_mrec R (t : itree (D +' E) R) : + eq_itree eq + (interp_mrec ctx _ t) (interp_mrecF _ (observe t)). Proof. - rewrite itree_eta, unfold_interp_mrecF, <-itree_eta. + rewrite itree_eta, observe_interp_mrecF, <-itree_eta. reflexivity. Qed. Lemma ret_mrec {T} (x: T) : interp_mrec ctx _ (Ret x) ≅ Ret x. -Proof. rewrite unfold_interp_mrec; reflexivity. Qed. +Proof. rewrite observe_interp_mrec; reflexivity. Qed. Lemma tau_mrec {T} (t: itree _ T) : interp_mrec ctx _ (Tau t) ≅ Tau (interp_mrec ctx _ t). -Proof. rewrite unfold_interp_mrec. reflexivity. Qed. +Proof. rewrite observe_interp_mrec. reflexivity. Qed. Lemma vis_mrec_right {T U} (e : E U) (k : U -> itree (D +' E) T) : interp_mrec ctx _ (Vis (inr1 e) k) ≅ Vis e (fun x => interp_mrec ctx _ (k x)). -Proof. rewrite unfold_interp_mrec. reflexivity. Qed. +Proof. rewrite observe_interp_mrec. reflexivity. Qed. Lemma vis_mrec_left {T U} (d : D U) (k : U -> itree (D +' E) T) : interp_mrec ctx _ (Vis (inl1 d) k) ≅ Tau (interp_mrec ctx _ (ITree.bind (ctx _ d) k)). -Proof. rewrite unfold_interp_mrec. reflexivity. Qed. +Proof. rewrite observe_interp_mrec. reflexivity. Qed. Hint Rewrite @ret_mrec : itree. Hint Rewrite @vis_mrec_left : itree. @@ -64,14 +68,14 @@ Hint Rewrite @vis_mrec_right : itree. Hint Rewrite @tau_mrec : itree. Instance eq_itree_mrec {R} : - Proper (@eq_itree _ R ==> @eq_itree _ R) (interp_mrec ctx R). + Proper (eq_itree eq ==> eq_itree eq) (interp_mrec ctx R). Proof. repeat intro. pupto2_init. revert_until R. pcofix CIH. intros. - rewrite !unfold_interp_mrec. + rewrite !observe_interp_mrec. pupto2_final. punfold H0. inv H0; pclearbot; [| |destruct e]. - - eapply eq_itree_refl. + - apply reflexivity. - pfold. econstructor. eauto. - pfold. econstructor. apply pointwise_relation_fold in REL. right. eapply CIH. rewrite REL. reflexivity. @@ -90,90 +94,554 @@ Proof. autorewrite with itree; try rewrite <- bind_bind; pupto2_final. - 1: { apply eq_itree_refl. } + 1: { apply reflexivity. } all: try (pfold; econstructor; eauto). Qed. -Let h_mrec : D ~> itree E := mrec ctx. +Theorem unfold_interp_mrec {T} (c : itree _ T) : + interp_mrec ctx _ c ≈ interp (Sum1.elim (C:=itree E) (mrec ctx) ITree.liftE) _ c. +Proof. + repeat intro. pupto2_init. revert_until T. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + rewrite observe_interp_mrecF, unfold_interp. + destruct (observe c); [| |destruct e]; simpl; eauto 7. + - rewrite interp_mrec_bind. + pfold. econstructor. + pupto2 eutt_nested_clo_bind. + econstructor; [reflexivity|]. + intros; subst. eauto. + - unfold ITree.liftE. rewrite vis_bind_. + pfold. econstructor. econstructor. intros. left. + rewrite ret_bind. + pupto2_final. eauto. +Qed. + +Theorem unfold_mrec {T} (d : D T) : + mrec ctx _ d ≈ interp (Sum1.elim (C:=itree E) (mrec ctx) ITree.liftE) _ (ctx _ d). +Proof. + apply unfold_interp_mrec. +Qed. + +End Facts. + +Lemma rec_unfold {E A B} (f : A -> itree (callE A B +' E) B) (x : A) : + rec f x ≈ interp (Sum1.elim (C:=itree E) (calling' (rec f)) ITree.liftE) _ (f x). +Proof. + unfold rec. unfold mrec. + rewrite unfold_interp_mrec. + eapply eutt_interp. + - red. intro. red. destruct a; try reflexivity. + destruct c. + reflexivity. + - reflexivity. +Qed. + +Notation loop_once_ f loop_ := + (loop_once f (fun cb => Tau (loop_ f%function cb))). + +Lemma unfold_loop'' {E A B C} (f : C + A -> itree E (C + B)) (x : C + A) : + observe (loop_ f x) + = observe (loop_once f (fun cb => Tau (loop_ f cb)) x). +Proof. reflexivity. Qed. + +Lemma unfold_loop' {E A B C} (f : C + A -> itree E (C + B)) (x : C + A) : + loop_ f x + ≅ loop_once f (fun cb => Tau (loop_ f cb)) x. +Proof. + rewrite itree_eta, (itree_eta (loop_once _ _ _)). + reflexivity. +Qed. + +Lemma unfold_loop {E A B C} (f : C + A -> itree E (C + B)) (x : C + A) : + loop_ f x + ≈ loop_once f (loop_ f) x. +Proof. + rewrite unfold_loop'. + apply eutt_bind; try reflexivity. + intros []; try reflexivity. + rewrite tau_eutt; reflexivity. +Qed. + +Lemma unfold_aloop' {E A B} (f : A -> itree E (A + B)) (x : A) : + aloop f x + ≅ (ab <- f x ;; + match ab with + | inl a => Tau (aloop f a) + | inr b => Ret b + end). +Proof. + rewrite (itree_eta (aloop _ _)), (itree_eta (ITree.bind _ _)). + reflexivity. +Qed. + +Lemma unfold_aloop {E A B} (f : A -> itree E (A + B)) (x : A) : + aloop f x + ≈ (ab <- f x ;; + match ab with + | inl a => aloop f a + | inr b => Ret b + end). +Proof. + rewrite unfold_aloop'. + apply eutt_bind; try reflexivity. + intros []; try reflexivity. + apply tau_eutt. +Qed. + +(* Equations for a traced monoidal category *) + +Lemma loop_natural_l {E A A' B C} (f : A -> itree E A') + (body : C + A' -> itree E (C + B)) (a : A) : + ITree.bind (f a) (loop body) + ≅ loop (fun ca => + match ca with + | inl c => Ret (inl c) + | inr a => ITree.map inr (f a) + end >>= body) a. +Proof. + unfold loop. + rewrite unfold_loop'; unfold loop_once. + unfold ITree.map. autorewrite with itree. + eapply eq_itree_bind; try reflexivity. + intros a' _ []. autorewrite with itree. + remember (inr a') as ca eqn:EQ; clear EQ a'. + pupto2_init. revert ca; clear; pcofix self; intro ca. + rewrite unfold_loop'; unfold loop_once. + pupto2 @eq_itree_clo_bind; econstructor; try reflexivity. + intros [c | b]; intros; subst. + - match goal with + | [ |- _ _ (Tau (loop_ ?f _)) ] => rewrite (unfold_loop' f) + end. + unfold loop_once_. + rewrite ret_bind_. (* TODO: [ret_bind] doesn't work. *) + pfold; constructor; auto. + - pfold; constructor; auto. +Qed. + +Lemma loop_natural_r {E A B B' C} (f : B -> itree E B') + (body : C + A -> itree E (C + B)) (a : A) : + loop body a >>= f + ≅ loop (fun ca => body ca >>= fun cb => + match cb with + | inl c => Ret (inl c) + | inr b => ITree.map inr (f b) + end) a. +Proof. + unfold loop. + remember (inr a) as ca eqn:EQ; clear EQ a. + pupto2_init. revert ca; clear; pcofix self; intro ca. + rewrite !unfold_loop'; unfold loop_once. + rewrite !bind_bind. + pupto2 @eq_itree_clo_bind; econstructor; try reflexivity. + intros [c | b]; intros; subst. + - rewrite ret_bind_, tau_bind_. + pfold; constructor; auto. + - autorewrite with itree. + pupto2_final; apply reflexivity. +Qed. -Inductive mrec_invariant {U} : relation (itree _ U) := -| mrec_main (d1 d2 : _ U) (Ed : eq_itree d1 d2) : - mrec_invariant (interp_mrec ctx _ d1) - (interp1 (mrec ctx) _ d2) -| mrec_bind T (d : _ T) (k1 k2 : T -> itree _ U) - (Ek : forall x, eq_itree (k1 x) (k2 x)) : - mrec_invariant (interp_mrec ctx _ (d >>= k1)) - (interp_mrec ctx _ d >>= fun x => - interp1 h_mrec _ (k2 x)) +Lemma loop_dinatural {E A B C C'} (f : C -> itree E C') + (body : C' + A -> itree E (C + B)) (a : A) : + loop (fun c'a => body c'a >>= fun cb => + match cb with + | inl c => Tau (ITree.map inl (f c)) + | inr b => Ret (inr b) + end) a + ≅ loop (fun ca => + match ca with + | inl c => f c >>= fun c' => Tau (Ret (inl c')) + | inr a => Ret (inr a) + end >>= body) a. +Proof. + unfold loop. + do 2 rewrite unfold_loop'; unfold loop_once. + autorewrite with itree. + eapply eq_itree_bind; try reflexivity. + clear a; intros cb _ []. + pupto2_init. revert cb; pcofix self; intros. + destruct cb as [c | b]. + - rewrite tau_bind. + pfold; constructor; pupto2_final; left. + rewrite map_bind. + rewrite (unfold_loop' _ (inl c)); unfold loop_once. + autorewrite with itree. + pupto2 eq_itree_clo_bind; econstructor; try reflexivity. + intros c'; intros; subst. + rewrite tau_bind. + rewrite ret_bind_. + rewrite unfold_loop'; unfold loop_once. + rewrite bind_bind. + pfold; constructor. + pupto2 eq_itree_clo_bind; econstructor; try reflexivity. + intros; subst. eauto. + - rewrite ret_bind. + pupto2_final; apply reflexivity. +Qed. + +Lemma vanishing1 {E A B} (f : Empty_set + A -> itree E (Empty_set + B)) + (a : A) : + loop f a ≅ ITree.map sum_empty_l (f (inr a)). +Proof. + unfold loop. + rewrite unfold_loop'; unfold loop_once, ITree.map. + eapply eq_itree_bind; try reflexivity. + intros [[]| b] _ []; reflexivity. +Qed. + +Lemma vanishing2 {E A B C D} (f : D + (C + A) -> itree E (D + (C + B))) + (a : A) : + loop (loop f) a + ≅ loop (fun dca => ITree.map sum_assoc_l (f (sum_assoc_r dca))) a. +Proof. + unfold loop; rewrite 2 unfold_loop'; unfold loop_once. + rewrite map_bind. + rewrite unfold_loop'; unfold loop_once. + rewrite bind_bind. + eapply eq_itree_bind; try reflexivity. + clear a; intros dcb _ []. + pupto2_init. revert dcb; pcofix self; intros. + destruct dcb as [d | [c | b]]; simpl. + - (* d *) + rewrite tau_bind. + rewrite 2 unfold_loop'; unfold loop_once. + autorewrite with itree. + pfold; constructor. + pupto2 eq_itree_clo_bind; econstructor; try reflexivity. + intros; subst. auto. + - (* c *) + rewrite ret_bind. + rewrite 2 unfold_loop'; unfold loop_once. + rewrite unfold_loop'; unfold loop_once. + autorewrite with itree. + pfold; constructor. + pupto2 eq_itree_clo_bind; econstructor; try reflexivity. + intros; subst. auto. + - (* b *) + rewrite ret_bind. + pupto2_final; apply reflexivity. +Qed. + +Lemma superposing1 {E A B C D D'} (f : C + A -> itree E (C + B)) + (g : D -> itree E D') (a : A) : + ITree.map inl (loop f a) + ≅ loop (fun cad => + match cad with + | inl c => ITree.map (sum_bimap id inl) (f (inl c)) + | inr (inl a) => ITree.map (sum_bimap id inl) (f (inr a)) + | inr (inr d) => ITree.map (inr ∘ inr) (g d) + end) (inl a). +Proof. + unfold loop. + remember (inr a) as inra eqn:Hr. + remember (inr (inl a)) as inla eqn:Hl. + assert (Hlr : match inra with + | inl c => inl c + | inr a => inr (inl a) + end = inla). + { subst; auto. } + clear a Hl Hr. + unfold ITree.map. + pupto2_init. revert inla inra Hlr; pcofix self; intros. + rewrite 2 unfold_loop'; unfold loop_once. + rewrite bind_bind. + destruct inra as [c | a]; subst. + - rewrite bind_bind; setoid_rewrite ret_bind_. + pupto2 eq_itree_clo_bind; econstructor; try reflexivity. + intros [c' | b]; simpl; intros; subst. + + rewrite tau_bind. pfold; constructor. + pupto2_final. auto. + + rewrite ret_bind. pupto2_final; apply reflexivity. + - rewrite bind_bind; setoid_rewrite ret_bind_. + pupto2 eq_itree_clo_bind; econstructor; try reflexivity. + intros [c' | b]; simpl; intros; subst. + + rewrite tau_bind. pfold; constructor. + pupto2_final. auto. + + rewrite ret_bind_. pupto2_final; apply reflexivity. +Qed. + +Lemma superposing2 {E A B C D D'} (f : C + A -> itree E (C + B)) + (g : D -> itree E D') (d : D) : + ITree.map inr (g d) + ≅ loop (fun cad => + match cad with + | inl c => ITree.map (sum_bimap id inl) (f (inl c)) + | inr (inl a) => ITree.map (sum_bimap id inl) (f (inr a)) + | inr (inr d) => ITree.map (inr ∘ inr) (g d) + end) (inr d). +Proof. + unfold loop; rewrite unfold_loop'; unfold loop_once. + rewrite map_bind; unfold ITree.map. + eapply eq_itree_bind; try reflexivity. + intros d' _ []. reflexivity. +Qed. + +Lemma yanking {E A} (a : A) : + @loop E _ _ _ (fun aa => Ret (sum_comm aa)) a ≅ Tau (Ret a). +Proof. + rewrite itree_eta; cbn; apply eq_itree_tau. + rewrite itree_eta; reflexivity. +Qed. + +Definition sum_map1 {A B C} (f : A -> B) (ac : A + C) : B + C := + match ac with + | inl a => inl (f a) + | inr c => inr c + end. + +Lemma bind_aloop {E A B C} (f : A -> itree E (A + B)) (g : B -> itree E (B + C)) (x : A) : + (aloop f x >>= aloop g) + ≈ aloop (fun ab => + match ab with + | inl a => ITree.map inl (f a) + | inr b => ITree.map (sum_map1 inr) (g b) + end) (inl x). +Proof. + pupto2_init. revert_until g. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + + rewrite !unfold_aloop', bind_bind, map_bind. + pupto2 eutt_nested_clo_bind. econstructor; [reflexivity|]. + intros; subst. destruct v2; simpl. + - rewrite tau_bind_. + pfold. econstructor. eauto. + - rewrite ret_bind_. pfold. econstructor. pfold_reverse. + revert_until x. pcofix CIH''. intros. + rewrite !unfold_aloop', map_bind. + pupto2 eutt_nested_clo_bind. econstructor; [reflexivity|]. + intros. subst. destruct v2; simpl; eauto 7. +Qed. + +Instance eq_itree_loop {E A B C} : + Proper ((eq ==> eq_itree eq) ==> eq ==> eq_itree eq) (@loop E A B C). +Proof. + repeat intro; subst. + unfold loop. + remember (inr _) as ca eqn:EQ; clear EQ y0. + pupto2_init. revert ca; pcofix self; intros. + rewrite 2 unfold_loop'; unfold loop_once. + pupto2 eq_itree_clo_bind; econstructor; try auto. + intros [c | b]; intros; subst; pfold; constructor; auto. +Qed. + +Section eutt_loop. + +Context {E : Type -> Type} {A B C : Type}. +Variables f1 f2 : C + A -> itree E (C + B). +Hypothesis eutt_f : forall ca, sutt eq (f1 ca) (f2 ca). + +Inductive loop_preinv (t1 t2 : itree E B) : Prop := +| loop_inv_main ca : + t1 ≅ loop_ f1 ca -> + t2 ≅ loop_ f2 ca -> + loop_preinv t1 t2 +| loop_inv_bind u1 u2 : + sutt eq u1 u2 -> + t1 ≅ (cb <- u1;; + match cb with + | inl c => Tau (loop_ f1 (inl c)) + | inr b => Ret b + end) -> + t2 ≅ (cb <- u2;; + match cb with + | inl c => Tau (loop_ f2 (inl c)) + | inr b => Ret b + end) -> + loop_preinv t1 t2 . +Hint Constructors loop_preinv. + +Lemma eutt_loop_inv_main_step (ca : C + A) t1 t2 : + t1 ≅ loop_ f1 ca -> + t2 ≅ loop_ f2 ca -> + suttF1 eq (going loop_preinv) (observe t1) (observe t2). +Proof. + intros H1 H2. + rewrite unfold_loop' in H1. + rewrite unfold_loop' in H2. + unfold loop_once. + specialize (eutt_f ca). + apply sutt_is_sutt1 in eutt_f. + punfold eutt_f. + unfold loop_once in H1. + unfold loop_once in H2. + rewrite unfold_bind in H1. + rewrite unfold_bind in H2. + + revert t1 t2 H1 H2. + induction eutt_f; intros z1 z2 H1 H2. + + - subst; destruct r2. + + apply eq_itree_tau_inv1 in H1. + destruct H1 as [t1' [Ht1 Ht1']]. + apply eq_itree_tau_inv1 in H2. + destruct H2 as [t2' [Ht2 Ht2']]. + rewrite Ht1, Ht2. + repeat constructor. + econstructor; try rewrite <- itree_eta; eassumption. + + apply eq_itree_ret_inv1 in H1. + apply eq_itree_ret_inv1 in H2. + rewrite H1, H2. + auto. + + - pclearbot. apply eq_itree_vis_inv1 in H1. + apply eq_itree_vis_inv1 in H2. + destruct H1 as [k01 [Hk1 Hk1']]. + destruct H2 as [k02 [Hk2 Hk2']]. + rewrite Hk1, Hk2. + constructor; intros. + repeat constructor. + eapply loop_inv_bind. + + apply sutt_is_sutt1, SUTTK. + + rewrite <- itree_eta; auto. + + rewrite <- itree_eta; auto. + + - apply eq_itree_tau_inv1 in H2. + destruct H2 as [t2' [Ht2 Ht2']]. + rewrite Ht2. + constructor. + apply IHs; auto. rewrite <- unfold_bind; auto. -Notation mi_holds r := - (forall c1 c2 d1 d2, - mrec_invariant d1 d2 -> - eq_itree c1 d1 -> eq_itree c2 d2 -> r c1 c2). - -Lemma mrec_invariant_init {U} (r : relation (itree _ U)) - (INV : mi_holds r) - (c1 c2 : itree _ U) - (Ec : eq_itree c1 c2) : - paco2 (compose eq_itreeF (gres2 eq_itreeF)) r - (interp_mrec ctx _ c1) - (interp1 h_mrec _ c2). -Proof. - rewrite unfold_interp_mrec, unfold_interp1. - punfold Ec. - inversion Ec; cbn; pclearbot; pupto2_final. - + eapply eq_itree_refl. (* This should be reflexivity. *) - + pfold; constructor. right; eapply INV. - 1: apply mrec_main; eassumption. - all: reflexivity. - + destruct e. - { pfold; constructor; cbn; right. eapply INV. - 1: apply mrec_bind; eassumption. - all: cbn; reflexivity. - } - { pfold; econstructor. - intros; right. eapply INV. - 1: apply mrec_main; eapply REL. - all: reflexivity. - } -Qed. - -Lemma mrec_invariant_eq {U} : mi_holds (@eq_itree _ U). -Proof. - intros d1 d2 c1 c2 Ec1 Ec2 H. - pupto2_init; revert d1 d2 c1 c2 Ec1 Ec2 H; pcofix self. - intros _d1 _d2 c1 c2 [d1 d2 Ed | T d k1 k2 Ek] Ec1 Ec2. - - rewrite Ec1, Ec2. - apply mrec_invariant_init; auto 10. - - rewrite Ec1, Ec2. cbn. - rewrite unfold_interp_mrec. - rewrite (unfold_bind (interp_mrec _ _ d)). - unfold observe, _observe; cbn. - destruct (observe d); fold_observe; cbn. - + rewrite <- unfold_interp_mrec. - apply mrec_invariant_init; auto. - + pupto2_final; pfold; constructor; right. - eapply self. - 1: apply mrec_bind; eassumption. - all: cbn; fold_bind; reflexivity. - + destruct e; cbn. - * fold_bind. rewrite <-bind_bind. - pupto2_final. pfold. econstructor. right. - eapply self. - 1: apply mrec_bind; eassumption. - all: cbn; reflexivity. - * pupto2_final; pfold; constructor; right. - eapply self. - 1: apply mrec_bind; eassumption. - all: cbn; fold_bind; reflexivity. -Qed. - -Theorem interp_mrec_is_interp : forall {T} (c : itree _ T), - eq_itree (interp_mrec ctx _ c) (interp1 h_mrec _ c). -Proof. - intros; eapply mrec_invariant_eq; - try eapply mrec_main; reflexivity. + - pclearbot. + replace ot2 with (observe (go ot2)) in *. + rewrite <- unfold_bind in H2. + apply eq_itree_tau_inv1 in H1. + destruct H1 as [t1' [Ht1 Ht1']]. + rewrite Ht1. + repeat constructor. + eapply loop_inv_bind. + + apply sutt_is_sutt1. eauto. + + rewrite <- itree_eta; auto. + + rewrite <- itree_eta; auto. + + auto. Qed. -End Facts. +Lemma eutt_loop_inv ot1 ot2 : + loop_preinv (go ot1) (go ot2) -> paco2 (suttF1 eq) bot2 ot1 ot2. +Proof. + intros HH. + revert ot1 ot2 HH; pcofix self; intros. pfold. + destruct HH as [ca H1 H2 | u1 u2 Hu H1 H2]. + - eapply monotone_suttF1. + + eapply (eutt_loop_inv_main_step ca (go ot1) (go ot2)); eauto. + + intros ? ? []. right. eapply self; eauto. + - apply sutt_is_sutt1 in Hu. + punfold Hu. + rewrite unfold_bind in H1. + rewrite unfold_bind in H2. + revert ot1 ot2 H1 H2; induction Hu; intros. + + + subst; destruct r2. + * apply eq_itree_tau_inv1 in H1. + apply eq_itree_tau_inv1 in H2. + simpl in H1, H2. + destruct H1 as [? []], H2 as [? []]. + subst. + do 2 constructor. right. + apply self. + eapply loop_inv_main; rewrite <- itree_eta; eauto. + * apply eq_itree_ret_inv1 in H1. + apply eq_itree_ret_inv1 in H2. + simpl in H1, H2. subst; auto. + + + pclearbot. + apply eq_itree_vis_inv1 in H1. + apply eq_itree_vis_inv1 in H2. + simpl in H1, H2. + destruct H1 as [? []], H2 as [? []]. + subst; constructor. + right. apply self. + eapply loop_inv_bind. + * apply sutt_is_sutt1. eapply SUTTK. + * rewrite <- itree_eta; auto. + * rewrite <- itree_eta; auto. + + + apply eq_itree_tau_inv1 in H2. + simpl in H2. + destruct H2 as [t2' [Ht2 Ht2']]. + rewrite Ht2. + constructor. + apply IHHu; auto. + rewrite <- itree_eta, <- unfold_bind; auto. + + + pclearbot. + replace ot2 with (observe (go ot2)) in *. + rewrite <- unfold_bind in H2. + apply eq_itree_tau_inv1 in H1. + simpl in H1. + destruct H1 as [t1' [Ht1 Ht1']]. + rewrite Ht1. + constructor. + right; apply self. + eapply loop_inv_bind. + * apply sutt_is_sutt1. + eapply EQTAUS. + * rewrite <- itree_eta; auto. + * auto. + * auto. +Qed. + +End eutt_loop. + +Instance sutt_loop {E A B C} : + Proper (pointwise_relation _ (sutt eq) ==> eq ==> sutt eq) (@loop E A B C). +Proof. + repeat intro; subst. apply sutt_is_sutt1. + + eapply eutt_loop_inv. + - eauto. + - unfold loop; econstructor; rewrite <- itree_eta; reflexivity. +Qed. + +Instance eutt_loop {E A B C} : + Proper (pointwise_relation _ (eutt eq) ==> eq ==> eutt eq) (@loop E A B C). +Proof. + repeat intro; subst. + repeat red in H. + eapply sutt_eutt. + - eapply sutt_loop; auto. + repeat intro; subst. + apply eutt_sutt; auto. + - eapply paco2_mon_gen. + + eapply sutt_loop; auto. + repeat intro. + apply eutt_sutt. apply symmetry; auto. + + intros. eapply monotone_sutt_RR; try eassumption. + red; auto. + + auto. +Qed. + +Lemma interp_state_loop {E F S A B C} (RS : S -> S -> Prop) + (h : E ~> Monads.stateT S (itree F)) + (t1 t2 : C + A -> itree E (C + B)) : + (forall ca s1 s2, RS s1 s2 -> + eutt (fun a b => RS (fst a) (fst b) /\ snd a = snd b) + (interp_state h (C+B) (t1 ca) s1) + (interp_state h (C+B) (t2 ca) s2)) -> + (forall ca s1 s2, RS s1 s2 -> + eutt (fun a b => RS (fst a) (fst b) /\ snd a = snd b) + (interp_state h B (loop_ t1 ca) s1) + (interp_state h B (loop_ t2 ca) s2)). +Proof. + repeat intro. pupto2_init. revert_until H. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + + rewrite (itree_eta (loop_ t1 ca)), (itree_eta (loop_ t2 ca)), !unfold_loop''. + unfold loop_once. rewrite <- !itree_eta, !interp_state_bind. + pupto2 eutt_nested_clo_bind. econstructor; eauto. + intros. destruct RELv. rewrite H2. destruct (snd v2). + - rewrite !interp_state_tau. + pfold. econstructor. pupto2_final. eauto. + - rewrite !interp_state_ret. simpl. eauto 7. +Qed. + +Lemma interp1_loop {E F G} `{F -< G} (f : E ~> itree G) {A B C} + (t : C + A -> itree (E +' F) (C + B)) ca : + interp1 f _ (loop_ t ca) ≅ loop_ (fun ca => interp1 f _ (t ca)) ca. +Proof. + pupto2_init. revert ca. pcofix CIH. intros. + unfold loop. rewrite !unfold_loop'. unfold loop_once. + rewrite interp1_bind. + pupto2 eq_itree_clo_bind. econstructor; [reflexivity|]. + intros. subst. rewrite unfold_interp1. pupto2_final. pfold. red. + destruct u2; simpl; eauto. +Qed. diff --git a/theories/ITree.v b/theories/ITree.v index e5483705..2aeddc44 100644 --- a/theories/ITree.v +++ b/theories/ITree.v @@ -3,8 +3,10 @@ From ITree Require Export Core Eq.Eq Eq.UpToTaus + Eq.SimUpToTaus Effect.Sum OpenSum + Translate Morphisms Fix . diff --git a/theories/KTree.v b/theories/KTree.v new file mode 100644 index 00000000..3ec0f0d7 --- /dev/null +++ b/theories/KTree.v @@ -0,0 +1,756 @@ +(** * The Category of Continuation Trees *) + +(** The Kleisli category of ITrees. *) + +(* begin hide *) +From ITree Require Import + ITree + OpenSum + Fix + FixFacts + Basics_Functions. + +From Coq Require Import + Program + Morphisms. +(* end hide *) + +Definition ktree (E: Type -> Type) (A B : Type) : Type + := A -> itree E B. +(* ktree can represent both blocks (A -> block B) and asm (asm A B). *) + +Bind Scope ktree_scope with ktree. + +(* (@ktree E) forms a traced monoidal category, i.e. a symmetric monoidal one with a loop operator *) +(* Obj ≅ Type *) +(* Arrow: A -> B ≅ terms of type (ktree A B) *) + +(** ** KTree equivalence *) +Section Equivalence. + +Context {E : Type -> Type}. + +(* We work up to pointwise eutt *) +Definition eq_ktree {A B} (d1 d2 : ktree E A B) := + (forall a, eutt eq (d1 a) (d2 a)). + +Global Instance Equivalence_eq_ktree {A B} : Equivalence (@eq_ktree A B). +Proof. + split. + - intros ab a; reflexivity. + - intros ab ab' eqAB a; symmetry; auto. + - intros ab ab' ab'' eqAB eqAB' a; etransitivity; eauto. +Qed. + +Global Instance eq_ktree_elim {A B C} : + Proper (eq_ktree ==> eq_ktree ==> eq_ktree) (@sum_elim A B (itree E C)). +Proof. + repeat intro. destruct a; unfold sum_elim; auto. +Qed. + +End Equivalence. + +Infix "⩯" := eq_ktree (at level 70). + +(** *** Conversion to [itree] *) +(** A trick to allow rewriting with eq_ktree in pointful contexts. *) + +Definition to_itree {E} (f : @ktree E unit unit) : itree E unit := f tt. + +Global Instance Proper_to_itree {E} : + Proper (eq_ktree ==> eutt eq) (@to_itree E). +Proof. + repeat intro. + apply H. +Qed. + +Lemma fold_to_itree {E} (f : @ktree E unit unit) : f tt = to_itree f. +Proof. reflexivity. Qed. + + +(** ** Categorical operations *) + +Section Operations. + +Context {E : Type -> Type}. + +(* Utility function to lift a pure computation into ktree *) +Definition lift_ktree {A B} (f : A -> B) : ktree E A B := fun a => Ret (f a). + +(** *** Category *) + +(** Identity morphism *) +Definition id_ktree {A} : ktree E A A := fun a => Ret a. + +(** Composition is [ITree.cat], denoted as [>=>]. *) + +(** *** Symmetric monoidal category *) + +(** Monoidal unit *) +Definition I: Type := Empty_set. + +(** Tensor product *) +(* Tensoring on objects is given by the coproduct *) +Definition tensor_ktree {A B C D} + (ab : ktree E A B) (cd : ktree E C D) + : ktree E (A + C) (B + D) + := sum_elim (ab >=> lift_ktree inl) (cd >=> lift_ktree inr). + +(* Left and right unitors *) +Definition λ_ktree {A: Type}: ktree E (I + A) A := lift_ktree sum_empty_l. +Definition λ_ktree' {A: Type}: ktree E A (I + A) := lift_ktree inr. +Definition ρ_ktree {A: Type}: ktree E (A + I) A := lift_ktree sum_empty_r. +Definition ρ_ktree' {A: Type}: ktree E A (A + I) := lift_ktree inl. + +(* Associators *) +Definition assoc_ktree_l {A B C: Type}: ktree E (A + (B + C)) ((A + B) + C) := lift_ktree sum_assoc_l. +Definition assoc_ktree_r {A B C: Type}: ktree E ((A + B) + C) (A + (B + C)) := lift_ktree sum_assoc_r. + +(* Symmetry *) +Definition sym_ktree {A B: Type}: ktree E (A + B) (B + A) := lift_ktree sum_comm. + +(** Traced monoidal category *) + +(* The trace is [Fix.loop]. + + A [box : ktree (I + A) (I + B)] is a circuit, drawn below as ###, + with two input wires labeled by I and A, and two output wires + labeled by I and B. + + The [loop_ktree : ktree (I + A) (I + B) -> ktree A B] combinator closes + the circuit, linking the box with itself by plugging the I output + back into the input. + + +-----+ + | ### | + +-###-+I + A----###----B + ### + + *) + +End Operations. + +Infix "⊗" := (tensor_ktree) (at level 30). + +(** ** Equations *) + +Section CategoryLaws. + +Context {E : Type -> Type}. + +(** *** [compose_ktree] respect eq_ktree *) +Global Instance eq_ktree_compose {A B C} : + Proper (eq_ktree ==> eq_ktree ==> eq_ktree) (@ITree.cat E A B C). +Proof. + intros ab ab' eqAB bc bc' eqBC. + intro a. + unfold ITree.cat. + rewrite (eqAB a). + apply eutt_bind; try reflexivity. + intro b; rewrite (eqBC b); reflexivity. +Qed. + +(** *** [compose_ktree] is associative *) +Lemma compose_ktree_assoc {A B C D} + (ab : ktree E A B) (bc : ktree E B C) (cd : ktree E C D) : + ((ab >=> bc) >=> cd) ⩯ (ab >=> (bc >=> cd)). +Proof. + intros a. + unfold ITree.cat. + rewrite bind_bind. + apply eutt_bind; try reflexivity. +Qed. + +(** *** [id_ktree] respect identity laws *) +Lemma id_ktree_left {A B}: forall (f: ktree E A B), + id_ktree >=> f ⩯ f. +Proof. + intros f a; unfold ITree.cat, id_ktree. + rewrite itree_eta; rewrite ret_bind. rewrite <- itree_eta; reflexivity. +Qed. + +Lemma id_ktree_right {A B}: forall (f: ktree E A B), + f >=> id_ktree ⩯ f. +Proof. + intros f a; unfold ITree.cat, id_ktree. + rewrite <- (bind_ret (f a)) at 2. + reflexivity. +Qed. + +End CategoryLaws. + +(** *** [lift] properties *) + +Section LiftLaws. + +Context {E : Type -> Type}. + +(** *** [lift_ktree] is well-behaved *) + +Global Instance eq_lift_ktree {A B} : + Proper (eeq ==> eq_ktree) (@lift_ktree E A B). +Proof. + repeat intro. + unfold lift_ktree. + erewrite (H a); reflexivity. +Qed. + +Lemma lift_ktree_id {A: Type}: @id_ktree E A ⩯ lift_ktree id. +Proof. + unfold id_ktree, lift_ktree; reflexivity. +Qed. + +Fact compose_lift_ktree {A B C} (ab : A -> B) (bc : B -> C) : + (@lift_ktree E _ _ ab >=> lift_ktree bc) ⩯ (lift_ktree (bc ∘ ab)). +Proof. + intros a. + unfold lift_ktree, ITree.cat. + rewrite ret_bind_. + reflexivity. +Qed. + +Fact compose_lift_ktree_l {A B C D} (f: A -> B) (g: B -> C) (k: ktree E C D) : + (lift_ktree f >=> (lift_ktree g >=> k)) ⩯ (lift_ktree (g ∘ f) >=> k). +Proof. + rewrite <- compose_ktree_assoc. + rewrite compose_lift_ktree. + reflexivity. +Qed. + +Fact compose_lift_ktree_r {A B C D} (f: B -> C) (g: C -> D) (k: ktree E A B) : + ((k >=> lift_ktree f) >=> lift_ktree g) ⩯ (k >=> lift_ktree (g ∘ f)). +Proof. + rewrite compose_ktree_assoc. + rewrite compose_lift_ktree. + reflexivity. +Qed. + +Fact lift_compose_ktree {A B C}: forall (f:A -> B) (bc: ktree E B C), + lift_ktree f >=> bc ⩯ fun a => bc (f a). +Proof. + intros; intro a. + unfold lift_ktree, ITree.cat. + rewrite ret_bind_. reflexivity. +Qed. + +Fact compose_ktree_lift {A B C}: forall (ab: ktree E A B) (g:B -> C), + eq_ktree (ab >=> lift_ktree g) + (fun a => ITree.map g (ab a)). +Proof. + intros; intro a. + unfold ITree.map. + apply eutt_bind. + reflexivity. + intro; reflexivity. +Qed. + +Lemma sym_ktree_unfold {A B}: + lift_ktree sum_comm ⩯ @sym_ktree E A B. +Proof. + reflexivity. +Qed. + +End LiftLaws. + +Section MonoidalCategoryLaws. + +Context {E : Type -> Type}. + +(** *** [associators] *) +Lemma assoc_lr {A B C} : + @assoc_ktree_l E A B C >=> assoc_ktree_r ⩯ id_ktree. +Proof. + unfold assoc_ktree_l, assoc_ktree_r. + rewrite compose_lift_ktree. + intros [| []]; reflexivity. +Qed. + +Lemma assoc_rl {A B C} : + @assoc_ktree_r E A B C >=> assoc_ktree_l ⩯ id_ktree. +Proof. + unfold assoc_ktree_l, assoc_ktree_r. + rewrite compose_lift_ktree. + intros [[]|]; reflexivity. +Qed. + +(** *** [sum_elim] lemmas *) + +Fact compose_sum_elim {A B C D} (ac : ktree E A C) (bc : ktree E B C) (cd : ktree E C D) : + sum_elim ac bc >=> cd ⩯ sum_elim (ac >=> cd) (bc >=> cd). +Proof. + intros; intros []; + (unfold ITree.map; simpl; apply eutt_bind; reflexivity). +Qed. + +Fact lift_sum_elim {A B C} (ac : A -> C) (bc : B -> C) : + sum_elim (@lift_ktree E _ _ ac) (lift_ktree bc) + ⩯ lift_ktree (sum_elim ac bc). +Proof. + intros []; reflexivity. +Qed. + +(** *** [Unitors] lemmas *) + +(* TODO: replacing l by λ breaks PG (retracts like crazy, or if you go too far it can't retract at all from the second lemma) (ρ is fine, interestingly) *) +Lemma elim_l_ktree {A B: Type} (ab: @ktree E A (I + B)) : + ab >=> λ_ktree ⩯ (fun a: A => ITree.map sum_empty_l (ab a)). +Proof. + intros; apply compose_ktree_lift. +Qed. + +Lemma elim_l_ktree' {A B: Type} (f: @ktree E (I + A) (I + B)) : + λ_ktree' >=> f ⩯ fun a => f (inr a). +Proof. + repeat intro. + unfold λ_ktree', ITree.cat, lift_ktree. + rewrite ret_bind_; reflexivity. +Qed. + +Lemma elim_ρ_ktree' {A B: Type} (f: @ktree E (A + I) (B + I)) : + ρ_ktree' >=> f ⩯ fun a => f (inl a). +Proof. + repeat intro. + unfold ρ_ktree', ITree.cat, lift_ktree. + rewrite ret_bind_; reflexivity. +Qed. + +Lemma elim_ρ_ktree {A B: Type} (ab: @ktree E A (B + I)) : + ab >=> ρ_ktree ⩯ (fun a: A => ITree.map sum_empty_r (ab a)). +Proof. + intros; apply compose_ktree_lift. +Qed. + +(** *** [tensor] lemmas *) + +Global Instance eq_ktree_tensor {A B C D}: + Proper (eq_ktree ==> eq_ktree ==> eq_ktree) (@tensor_ktree E A B C D). +Proof. + intros ac ac' eqac bd bd' eqbd. + unfold tensor_ktree. + rewrite eqac, eqbd; reflexivity. +Qed. + +Fact tensor_id_lift {A B C} (f : B -> C) : + (@id_ktree E A) ⊗ (lift_ktree f) ⩯ lift_ktree (sum_bimap id f). +Proof. + unfold tensor_ktree. + rewrite compose_lift_ktree, id_ktree_left. + rewrite lift_sum_elim. + reflexivity. +Qed. + +Fact tensor_lift_id {A B C} (f : A -> B) : + (lift_ktree f) ⊗ (@id_ktree E C) ⩯ lift_ktree (sum_bimap f id). +Proof. + unfold tensor_ktree. + rewrite compose_lift_ktree, id_ktree_left. + rewrite lift_sum_elim. + reflexivity. +Qed. + +Lemma tensor_id {A B} : + id_ktree ⊗ id_ktree ⩯ @id_ktree E (A + B). +Proof. + unfold tensor_ktree, ITree.cat, id_ktree. + intros []; cbn; rewrite ret_bind_; reflexivity. +Qed. + +Lemma assoc_I {A B}: + @assoc_ktree_r E A I B >=> id_ktree ⊗ λ_ktree ⩯ ρ_ktree ⊗ id_ktree. +Proof. + unfold ρ_ktree,λ_ktree. + rewrite tensor_lift_id, tensor_id_lift. + unfold assoc_ktree_r. + rewrite compose_lift_ktree. + apply eq_lift_ktree. + intros [[|]|]; compute; try reflexivity. + destruct i. +Qed. + +Lemma cat_tensor {A1 A2 A3 B1 B2 B3} + (f1 : ktree E A1 A2) (f2 : ktree E A2 A3) + (g1 : ktree E B1 B2) (g2 : ktree E B2 B3) : + (f1 ⊗ g1) >=> (f2 ⊗ g2) ⩯ (f1 >=> f2) ⊗ (g1 >=> g2). +Proof. + unfold tensor_ktree, ITree.cat, lift_ktree; simpl. + intros []; simpl; + rewrite !bind_bind; setoid_rewrite ret_bind_; reflexivity. +Qed. + +Lemma sum_elim_compose {A B C D F} + (ac: ktree E A (C + D)) (bc: ktree E B (C + D)) + (cf: ktree E C F) (df: ktree E D F) : + sum_elim ac bc >=> sum_elim cf df + ⩯ sum_elim (ac >=> (sum_elim cf df)) (bc >=> (sum_elim cf df)). +Proof. + intros. + unfold ITree.map. + intros []; reflexivity. +Qed. + +Lemma inl_sum_elim {A B C} (ac: ktree E A C) (bc: ktree E B C) : + lift_ktree inl >=> sum_elim ac bc ⩯ ac. +Proof. + intros. + unfold ITree.cat, lift_ktree. + intros ?. + rewrite ret_bind_. + reflexivity. +Qed. + +Lemma inr_sum_elim {A B C} (ac: ktree E A C) (bc: ktree E B C) : + lift_ktree inr >=> sum_elim ac bc ⩯ bc. +Proof. + intros. + unfold ITree.cat, lift_ktree. + intros ?. + rewrite ret_bind_. + reflexivity. +Qed. + +Lemma tensor_ktree_slide {A B C D} (ac: ktree E A C) (bd: ktree E B D) : + ac ⊗ bd ⩯ ac ⊗ id_ktree >=> id_ktree ⊗ bd. +Proof. + intros. + unfold tensor_ktree. + repeat rewrite id_ktree_left. + rewrite sum_elim_compose. + rewrite compose_ktree_assoc. + rewrite inl_sum_elim, inr_sum_elim. + reflexivity. +Qed. + +Lemma assoc_coherent_r {A B C D}: + @assoc_ktree_r E A B C ⊗ @id_ktree E D + >=> assoc_ktree_r + >=> id_ktree ⊗ assoc_ktree_r + ⩯ assoc_ktree_r >=> assoc_ktree_r. +Proof. + unfold tensor_ktree, assoc_ktree_r. + repeat rewrite id_ktree_left. + repeat rewrite compose_sum_elim. + repeat rewrite compose_lift_ktree. + rewrite lift_sum_elim. + repeat rewrite compose_lift_ktree. + rewrite lift_sum_elim. + apply eq_lift_ktree. + intros [[[|]|]|]; reflexivity. +Qed. + +Lemma assoc_coherent_l {A B C D}: + @id_ktree E A ⊗ @assoc_ktree_l E B C D + >=> assoc_ktree_l + >=> assoc_ktree_l ⊗ id_ktree + ⩯ assoc_ktree_l >=> assoc_ktree_l. +Proof. + unfold tensor_ktree, assoc_ktree_l. + repeat rewrite id_ktree_left. + repeat rewrite compose_sum_elim. + repeat rewrite compose_lift_ktree. + rewrite lift_sum_elim. + repeat rewrite compose_lift_ktree. + rewrite lift_sum_elim. + apply eq_lift_ktree. + intros [|[|[|]]]; reflexivity. +Qed. + +(** *** [sym] lemmas *) + +Lemma sym_unit_ktree {A} : + sym_ktree >=> λ_ktree ⩯ @ρ_ktree E A. +Proof. + unfold sym_ktree, ρ_ktree, λ_ktree. + rewrite lift_compose_ktree. + intros []; simpl; reflexivity. +Qed. + +Lemma sym_assoc_ktree {A B C}: + @assoc_ktree_r E A B C >=> sym_ktree >=> assoc_ktree_r + ⩯ (sym_ktree ⊗ id_ktree) >=> assoc_ktree_r >=> (id_ktree ⊗ sym_ktree). +Proof. + unfold assoc_ktree_r, sym_ktree. + rewrite tensor_lift_id, tensor_id_lift. + repeat rewrite compose_lift_ktree. + apply eq_lift_ktree. + intros [[|]|]; compute; reflexivity. +Qed. + +Lemma sym_nilpotent {A B: Type}: + sym_ktree >=> sym_ktree ⩯ @id_ktree E (A + B). +Proof. + unfold sym_ktree, id_ktree. + rewrite compose_lift_ktree. + unfold compose. + unfold lift_ktree; intros a. + setoid_rewrite iso_ff'; reflexivity. +Qed. + +Lemma tensor_swap {A B C D} (ab : ktree E A B) (cd : ktree E C D) : + ab ⊗ cd ⩯ (sym_ktree >=> cd ⊗ ab >=> sym_ktree). +Proof. + unfold tensor_ktree. + unfold sym_ktree. + rewrite !(compose_ktree_lift cd), !(compose_ktree_lift ab), !lift_compose_ktree, !compose_ktree_lift. + intros []; cbn; rewrite map_map; cbn; + apply eutt_map; try intros []; reflexivity. +Qed. + +End MonoidalCategoryLaws. + +(** *** Traced monoidal categories *) + +Section TraceLaws. + +Context {E : Type -> Type}. + +(** *** [loop] lemmas *) + +Global Instance eq_ktree_loop {I A B} : + Proper (eq_ktree ==> eq_ktree) (@loop E I A B). +Proof. + repeat intro; apply eutt_loop; auto. +Qed. + +(* Naturality of (loop_ktree I A B) in A *) +(* Or more diagrammatically: +[[ + +-----+ + | ### | + +-###-+I +A----B----###----C + ### + +is equivalent to: + + +----------+ + | ### | + +------###-+I +A----B----###----C + ### + +]] + *) + +Lemma compose_loop {I A B C} + (bc_: ktree E (I + B) (I + C)) (ab: ktree E A B) : + loop ((id_ktree ⊗ ab) >=> bc_) + ⩯ ab >=> loop bc_. +Proof. + intros a. + rewrite (loop_natural_l ab bc_ a). + apply eutt_loop; [intros [] | reflexivity]. + all: unfold tensor_ktree, sym_ktree, ITree.cat, assoc_ktree_l, assoc_ktree_r, id_ktree, lift_ktree; simpl. + - rewrite bind_bind, ret_bind_; reflexivity. + - rewrite bind_bind, map_bind. + setoid_rewrite ret_bind_; reflexivity. +Qed. + +(* Naturality of (loop I A B) in B *) +(* Or more diagrammatically: +[[ + +-----+ + | ### | + +-###-+I +A----###----B----C + ### + +is equivalent to: + + +----------+ + | ### | + +-###------+I +A----###----B----C + ### + +]] + *) + +Lemma loop_compose {I A B B'} + (ab_: ktree E (I + A) (I + B)) (bc: ktree E B B') : + loop (ab_ >=> (id_ktree ⊗ bc)) + ⩯ loop ab_ >=> bc. +Proof. + intros a. + rewrite (loop_natural_r bc ab_ a). + apply eutt_loop; [intros [] | reflexivity]. + all: unfold tensor_ktree, sym_ktree, ITree.cat, assoc_ktree_l, assoc_ktree_r, id_ktree, lift_ktree; simpl. + - apply eutt_bind; [reflexivity | intros []; simpl]. + rewrite ret_bind_; reflexivity. + reflexivity. + - apply eutt_bind; [reflexivity | intros []; simpl]. + rewrite ret_bind_; reflexivity. + reflexivity. +Qed. + +(* Dinaturality of (loop I A B) in I *) + +Lemma loop_rename_internal {I J A B} + (ab_: ktree E (I + A) (J + B)) (ji: ktree E J I) : + loop (ab_ >=> (ji ⊗ id_ktree)) + ⩯ loop ((ji ⊗ id_ktree) >=> ab_). +Proof. + unfold tensor_ktree, ITree.cat, lift_ktree, sum_elim. + + assert (EQ:forall (x: J + B), + match x with + | inl a => a0 <- ji a;; Ret (inl a0) + | inr b => a <- id_ktree b;; Ret (inr a) + end ≈ + match x with + | inl a => Tau (ITree.map (@inl I B) (ji a)) + | inr b => Ret (inr b) + end). + { + intros []. + symmetry; apply tau_eutt. + unfold id_ktree. + rewrite ret_bind_; reflexivity. + } + intros ?. + setoid_rewrite EQ. + rewrite loop_dinatural. + apply eutt_loop; [intros [] | reflexivity]. + all: unfold id_ktree. + all: repeat rewrite bind_bind. + 2: repeat rewrite ret_bind_; reflexivity. + apply eutt_bind; [reflexivity | intros ?]. + apply eutt_bind; [| intros ?; reflexivity]. + apply tau_eutt. +Qed. + +(* Loop over the empty set can be erased *) +Lemma vanishing_ktree {A B: Type} (f: ktree E (I + A) (I + B)) : + loop f ⩯ λ_ktree' >=> f >=> λ_ktree. +Proof. + intros a. + rewrite vanishing1. + unfold λ_ktree,λ_ktree'. + unfold ITree.cat, ITree.map, lift_ktree. + rewrite bind_bind. + rewrite ret_bind_. + reflexivity. +Qed. + +(* [loop_loop]: + +These two loops: + +[[ + +----------+ + | +-----+ | + | | ### | | + | +-###-+I | + +---###----+J + A-----###-------B + ### +]] + +... can be rewired as a single one: + + +[[ + +-------+ + | ### | + +--###--+(I+J) + +--###--+ + A-----###-----B + ### +]] + + *) + +Lemma loop_loop {I J A B} (ab__: ktree E (I + (J + A)) (I + (J + B))) : + loop (loop ab__) + ⩯ loop (assoc_ktree_r >=> ab__ >=> assoc_ktree_l). +Proof. + intros a. + rewrite vanishing2. + apply eutt_loop; [intros [[]|] | reflexivity]. + all: unfold ITree.map, ITree.cat, assoc_ktree_r, assoc_ktree_l, lift_ktree; cbn. + all: rewrite bind_bind. + all: rewrite ret_bind_. + all: reflexivity. +Qed. + +Lemma fold_map {R S}: + forall (f: R -> S) (t: itree E R), + (x <- t;; Ret (f x)) ≅ (ITree.map f t). +Proof. + intros; reflexivity. +Qed. + +Lemma tensor_ktree_loop {I A B C D} + (ab : ktree E (I + A) (I + B)) (cd : ktree E C D) : + (loop ab) ⊗ cd + ⩯ loop (assoc_ktree_l >=> (ab ⊗ cd) >=> assoc_ktree_r). +Proof. + unfold tensor_ktree, ITree.cat, assoc_ktree_l, assoc_ktree_r, lift_ktree, sum_elim. + intros []; simpl. + all:setoid_rewrite bind_bind. + all:setoid_rewrite ret_bind_. + all:rewrite fold_map. + 1:rewrite (@superposing1 E A B I C D). + 2:rewrite (@superposing2 E A B I C D). + all:unfold sum_bimap, ITree.map, sum_assoc_r,sum_elim; cbn. + all:apply eutt_loop; [intros [| []]; cbn | reflexivity]. + all: setoid_rewrite bind_bind. + all:setoid_rewrite ret_bind_. + all:reflexivity. +Qed. + +Lemma yanking_ktree {A: Type}: + loop sym_ktree ⩯ @id_ktree E A. +Proof. + unfold sym_ktree, lift_ktree. + intros ?; rewrite yanking. + apply tau_eutt. +Qed. + +Lemma loop_rename_internal' {I J A B} (ij : ktree E I J) (ji: ktree E J I) + (ab_: @ktree E (I + A) (I + B)) : + (ij >=> ji) ⩯ id_ktree -> + loop ((ji ⊗ id_ktree) >=> ab_ >=> (ij ⊗ id_ktree)) + ⩯ loop ab_. +Proof. + intros Hij. + rewrite loop_rename_internal. + rewrite <- compose_ktree_assoc. + rewrite cat_tensor. + rewrite Hij. + rewrite id_ktree_left. + rewrite tensor_id. + rewrite id_ktree_left. + reflexivity. +Qed. + +End TraceLaws. + +Hint Rewrite @compose_ktree_assoc : lift_ktree. +Hint Rewrite @tensor_id_lift : lift_ktree. +Hint Rewrite @tensor_lift_id : lift_ktree. +Hint Rewrite @lift_sum_elim : lift_ktree. + +(* Here we show that we can implement [ITree.cat] using + [tensor_ktree], [loop], and composition with the monoidal + natural isomorphisms. *) +Section CatFromLoop. + +Variable E : Type -> Type. + +Theorem cat_from_loop {A B C} (ab : ktree E A B) (bc : ktree E B C) : + loop (sym_ktree >=> ab ⊗ bc) ⩯ ab >=> bc. +Proof. + rewrite tensor_ktree_slide. + rewrite <- compose_ktree_assoc. + rewrite loop_compose. + rewrite tensor_swap. + repeat rewrite <- compose_ktree_assoc. + rewrite sym_nilpotent, id_ktree_left. + rewrite compose_loop. + erewrite yanking_ktree. + rewrite id_ktree_right. + reflexivity. +Qed. + +End CatFromLoop. diff --git a/theories/Morphisms.v b/theories/Morphisms.v index e6c552a7..0159c039 100644 --- a/theories/Morphisms.v +++ b/theories/Morphisms.v @@ -35,10 +35,64 @@ From ITree Require Import Basics Core Effect.Sum + Translate OpenSum. Open Scope itree_scope. +(* + +(* ------------------------------------------------------------------------- *) + +A Monad Transformer MT is given by: + MT : (type -> type) -> (type -> type) + lift : `{Monad m} {a}, m a -> MT m a + +such that: + Monad (MT m) + + lift o return = return + lift o (bind t1 k) = + +EXAMPLE: + stateT S m a := S -> m (S * a) + lift : m `{Monad m} {a}, fun (c: m a) (s:S) => y <- c ;; ret (s, y) + +operations + get : m `{Monad m} stateT S m S := fun s => ret_m (s, s) + put : m `{Monad m}, S -> stateT S m unit := fun s' => fun s => ret_m (s', tt) + +(* category *) +id : A ~> MT (itree A) +compose : (B ~> MT2 (itree C)) ~> (A ~> MT1 (itree B)) -> (A ~> (MT2 o MT1) (itree C)) + +(* co-cartesian *) +par : (A ~> MT1 (itree B)) -> (C ~> MT2 (itree D)) -> (A + C ~> (MT1 ** MT2) (itree (B + D))) +both : (A ~> MT (itree B)) -> (C ~> (MT itree B)) -> (A + C ~> MT (itree B)) + +swap : (A ~> MT1 (itree B)) -> (C ~> MT2 (itree D)) -> (A + C ~> (MT2 ** MT1) (itree (D + B))) + + +left : A ~> MT (itree (A + B)) +right : B ~> MT (itree (A + B)) + +left : (A ~> MT (itree B)) -> (A ~> MT (itree (B + C))) +right : (C ~> MT (itree D)) -> (C ~> MT (itree (A + D))) + + + +(* ------------------------------------------------------------------------- *) +Algebraic effects handlers + +Definition sig (E:Type -> Type) m `{Monad m} := forall X, E X -> m x + + + + + +*) + + (** [itreeF] eliminator, where the codomain is in the [itree] monad, a building block for itree monad morphisms. *) Definition handleF {E F : Type -> Type} {I R : Type} @@ -68,6 +122,7 @@ Definition handleF1 {E F G : Type -> Type} {I R : Type} end end. Hint Unfold handleF1. +(* note(gmm): i'd propose to remove handleF1 *) (** Shallow effect handling: pass the first [Vis] node to the given handler [h]. *) @@ -83,6 +138,7 @@ Definition handle1 {E F G : Type -> Type} {R : Type} itree (E +' F) R -> itree G R := cofix handle1_ t := handleF1 handle1_ h (observe t). Hint Unfold handle1. +(* note(gmm): i'd propose to remove handle1 *) (** An itree effect handler [E ~> itree F] defines an itree morphism [itree E ~> itree F]. *) @@ -93,6 +149,7 @@ Definition interp {E F : Type -> Type} (h : E ~> itree F) : (fun _ e k => Tau (ITree.bind (h _ e) (fun x => interp_ (k x)))) (observe t). + (* N.B.: the guardedness of this definition relies on implementation details of [bind]. *) @@ -103,6 +160,7 @@ Definition interp {E F : Type -> Type} (h : E ~> itree F) : allows a few equations to be bisimularities ([eq_itree]) instead of up-to-tau equivalences ([eutt]). *) + Definition interp1 {E F G : Type -> Type} `{F -< G} (h : E ~> itree G) : itree (E +' F) ~> itree G := fun R => cofix interp1_ t := @@ -115,30 +173,60 @@ Definition interp1 {E F G : Type -> Type} `{F -< G} (h : E ~> itree G) : end) (observe t). -(** A plain effect morphism [E ~> F] defines an itree morphism - [itree E ~> itree F]. *) -Definition translate {E F : Type -> Type} (h : E ~> F) : - itree E ~> itree F := fun R => - cofix translate_ t := - handleF translate_ - (fun _ e k => Vis (h _ e) (fun x => translate_ (k x))) - (observe t). - (** Effects [E, F : Type -> Type] and itree [E ~> itree F] form a category. *) -(* TODO: check that [itree] is a monad, so that category is its - Kleisli category. *) -(* todo(gmm): it would be good to have notation for this. - * - if there was a "category" class like in Haskell, then we could - * get composition from something like that. - *) -Definition eh_compose {A B C} (g : B ~> itree C) (f : A ~> itree B) : +(* Morphism Category -------------------------------------------------------- *) + +Definition eh_cmp {A B C} (g : B ~> itree C) (f : A ~> itree B) : A ~> itree C := fun _ e => interp g _ (f _ e). Definition eh_id {A} : A ~> itree A := @ITree.liftE A. +Definition eh_par {A B C D} (f : A ~> itree B) (g : C ~> itree D) +: (A +' C) ~> itree (B +' D) := + fun _ e => + match e with + | inl1 e1 => translate (@inl1 _ _) (f _ e1) + | inr1 e2 => translate (@inr1 _ _) (g _ e2) + end. + +Definition eh_both {A B C} (f : A ~> itree B) (g : C ~> itree B) +: (A +' C) ~> itree B := + fun _ e => + match e with + | inl1 e1 => f _ e1 + | inr1 e2 => g _ e2 + end. + +Definition eh_lift {A B} (m : A ~> B) : A ~> itree B := + fun _ e => ITree.liftE (m _ e). + +Definition eh_inl {A B} : A ~> itree (A +' B) := + eh_lift (fun _ e => inl1 e). + +Definition eh_inr {A B} : B ~> itree (A +' B) := + eh_lift (fun _ e => inr1 e). + +Definition eh_swap {A B} : A +' B ~> itree (B +' A) := + eh_lift Sum1.swap. + +Definition eh_elim_empty {A} : emptyE ~> itree A := + eh_lift Sum1.elim_emptyE. + +Definition eh_empty_left {B} : emptyE +' B ~> itree B := + eh_lift Sum1.emptyE_left. + +Definition eh_empty_right {A} : A +' emptyE ~> itree A := + eh_lift Sum1.emptyE_right. + +(* SAZ: do we need the assoc2 too -- add to Sum.v ? *) +Definition eh_assoc {A B C} : (A +' (B +' C)) ~> itree ((A +' B) +' C) := + eh_lift Sum1.assoc. + + + (** Standard interpreters *) Import ITree.Basics.Monads. @@ -152,11 +240,11 @@ Import ITree.Basics.Monads. Definition interp_state_match {E F S R} (h : E ~> stateT S (itree F)) (rec : itree E R -> stateT S (itree F) R) - (t:itree E R) : stateT S (itree F) R := + (ot:itree' E R) : stateT S (itree F) R := fun s => - match t.(observe) with + match ot with | RetF r => Ret (s, r) - | VisF e k => + | VisF e k => Tau (ITree.bind (h _ e s) (fun sx => rec (k (snd sx)) (fst sx))) | TauF t => Tau (rec t s) @@ -164,14 +252,14 @@ Definition interp_state_match {E F S R} (h : E ~> stateT S (itree F)) CoFixpoint interp_state {E F S} (h : E ~> stateT S (itree F)) : itree E ~> stateT S (itree F) := - fun R => interp_state_match h (interp_state h R). + fun R t => interp_state_match h (interp_state h R) (observe t). Definition interp1_state_match {E F S R} (h : E ~> stateT S (itree F)) (rec : itree (E +' F) R -> stateT S (itree F) R) - (t : itree (E +' F) R) : stateT S (itree F) R := + (ot : itree' (E +' F) R) : stateT S (itree F) R := fun s => - match t.(observe) with + match ot with | RetF r => Ret (s, r) | VisF ef k => match ef with @@ -186,8 +274,7 @@ Definition interp1_state_match {E F S R} (h : E ~> stateT S (itree F)) CoFixpoint interp1_state {E F S} (h : E ~> stateT S (itree F)) : itree (E +' F) ~> stateT S (itree F) := - fun R => interp1_state_match h (interp1_state h R). - + fun R t => interp1_state_match h (interp1_state h R) (observe t). Definition translate1_state {E F S} (h : E ~> state S) : itree (E +' F) ~> stateT S (itree F) := @@ -212,13 +299,9 @@ Definition interp_reader {E F R} (h : R -> E ~> itree F) : R -> itree E ~> itree F := fun r => interp (h r). -Definition interp1_reader {E F R} (h : R -> E ~> itree F) : - R -> itree (E +' F) ~> itree F := - fun r => interp1 (h r). - -Definition translate1_reader {E F R} (h : R -> E ~> identity) : - R -> itree (E +' F) ~> itree F := - fun r => interp1 (fun _ e => Ret (h r _ e)). +Definition translate_reader {E F R} (h : R -> E ~> identity) : + R -> itree E ~> itree F := + fun r => interp (fun _ e => Ret (h r _ e)). Import ExtLib.Structures.Monoid. diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index ef23ed3e..1eb3ace9 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -11,9 +11,29 @@ From ITree Require Import Core Effect.Sum OpenSum + Translate Morphisms Eq.Eq - Eq.UpToTaus. + Eq.UpToTaus + TranslateFacts. + +(** * Morphism equivalence *) +Definition Rhom {A B : Type -> Type} (R : forall t, B t -> B t -> Prop) + (f g : A ~> B) : Prop := + forall X, pointwise_relation (A X) (R X) (f X) (g X). + +Definition eh_eq {A B : Type -> Type} +: (A ~> itree B) -> (A ~> itree B) -> Prop := + Rhom (fun t => @eq_itree B _ t eq). + +Definition eh_eutt {A B : Type -> Type} +: (A ~> itree B) -> (A ~> itree B) -> Prop := + Rhom (fun t => @eutt B _ t eq). + +Notation "f ≡ g" := (eh_eutt f g) (at level 70). + + +(** * [interp] *) (* Proof of [interp f (t >>= k) ~ (interp f t >>= fun r => interp f (k r))] @@ -41,84 +61,78 @@ Definition interp_u {E F} (f : E ~> itree F) R : (fun _ e k => Tau (ITree.bind (f _ e) (fun x => interp f _ (k x)))). -Lemma interp_unfold {E F R} {f : E ~> itree F} (t : itree E R) : - observe (interp f _ t) = observe (interp_u f _ (observe t)). -Proof. eauto. Qed. - Lemma unfold_interp {E F R} {f : E ~> itree F} (t : itree E R) : - interp f _ t ≅ interp_u f _ (observe t). -Proof. rewrite itree_eta, interp_unfold, <-itree_eta. reflexivity. Qed. - -(* SAZ: If we need to introduce these auxilliar definitions to prove - properties about functions like interp1, I think that we shoul - _define_ interp1 in terms of its unfolding. I have experimented - with porting interp_state and interp1_state to this form. -*) -(* Unfolding of [interp1]. *) -Definition interp1_u {E F G} `{F -< G} (h : E ~> itree G) R : - itreeF (E +' F) R _ -> itree G R := - handleF (interp1 h _) - (fun _ ef k => - match ef with - | inl1 e => Tau (ITree.bind (h _ e) - (fun x => interp1 h _ (k x))) - | inr1 f => Vis (subeffect _ f) (fun x => interp1 h _ (k x)) - end). + observing eq (interp f _ t) (interp_u f _ (observe t)). +Proof. econstructor. reflexivity. Qed. -Lemma interp1_unfold {E F R} {f : E ~> itree F} (t : itree (E +' F) R) : - observe (interp1 f _ t) = observe (interp1_u f _ (observe t)). -Proof. eauto. Qed. - -Lemma unfold_interp1 {E F R} {f : E ~> itree F} (t : itree (E +' F) R) : - interp1 f _ t ≅ interp1_u f _ (observe t). -Proof. rewrite itree_eta, interp1_unfold, <-itree_eta. reflexivity. Qed. +(** ** [interp] and constructors *) Lemma ret_interp {E F R} {f : E ~> itree F} (x: R): - interp f _ (Ret x) ≅ Ret x. + observing eq (interp f _ (Ret x)) (Ret x). Proof. rewrite unfold_interp. reflexivity. Qed. Lemma tau_interp {E F R} {f : E ~> itree F} (t: itree E R): - interp f _ (Tau t) ≅ Tau (interp f _ t). + observing eq (interp f _ (Tau t)) (Tau (interp f _ t)). Proof. rewrite unfold_interp. reflexivity. Qed. Lemma vis_interp {E F R} {f : E ~> itree F} U (e: E U) (k: U -> itree E R) : - interp f _ (Vis e k) ≅ Tau (ITree.bind (f _ e) (fun x => interp f _ (k x))). + observing eq (interp f _ (Vis e k)) (Tau (ITree.bind (f _ e) (fun x => interp f _ (k x)))). Proof. rewrite unfold_interp. reflexivity. Qed. -Instance eq_itree_interp {E F R} f : - Proper (@eq_itree E R ==> - @eq_itree F R) (interp f _). +(** ** [interp] properness *) +Instance eq_itree_interp {E F R}: + Proper (Rhom (fun _ => eq_itree eq) ==> eq_itree eq ==> eq_itree eq) + (fun f => @interp E F f R). Proof. - repeat intro. pupto2_init. revert_until R. - pcofix CIH. intros. - rewrite itree_eta, (itree_eta (interp f _ y)), !interp_unfold. - punfold H0; red in H0. - destruct H0; pclearbot. + intros f g Hfg. + intros l r Hlr. + pupto2_init. + revert l r Hlr. + pcofix CIH. + rename r into rr. + intros l r Hlr. + rewrite itree_eta, (itree_eta (interp g _ r)), !unfold_interp. + punfold Hlr; red in Hlr. + destruct Hlr; pclearbot. - pupto2_final. pfold. red. cbn. eauto. - pupto2_final. pfold. red. cbn. eauto. - - pfold. econstructor. pupto2 (eq_itree_clo_bind F R). - constructor. - + reflexivity. - + eauto. intros; pupto2_final; right; eauto. + - pfold. econstructor. pupto2 eq_itree_clo_bind. + econstructor. + + eapply Hfg. + + intros; subst; pupto2_final; right; eauto. Qed. -Instance eq_itree_interp1 {E F R} f : - Proper (@eq_itree (E +' F) R ==> - @eq_itree F R) (interp1 f _). +Global Instance Proper_interp_eq_itree {E F R f} +: Proper (eq_itree eq ==> eq_itree eq) (@interp E F f R). Proof. - repeat intro. pupto2_init. revert_until R. - pcofix CIH. intros. - rewrite itree_eta, (itree_eta (interp1 f _ y)), !interp1_unfold. - punfold H0; red in H0. - destruct H0; pclearbot. - - pupto2_final. pfold. red. cbn. eauto. - - pupto2_final. pfold. red. cbn. eauto. - - pfold. destruct e; cbn; econstructor. - + pupto2 (eq_itree_clo_bind F R). - constructor. - * reflexivity. - * intros; pupto2_final; eauto. - + intros. pupto2_final. eauto. + eapply eq_itree_interp. + red. reflexivity. +Qed. + +(* Note that this allows rewriting of handlers. *) +Instance eutt_interp (E F : Type -> Type) (R : Type) : + Proper (Rhom (fun _ => eutt eq) ==> eutt eq ==> eutt eq) + (fun f => @interp E F f R). +Proof. + repeat intro. pupto2_init. revert_until H. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + + rewrite !unfold_interp. do 2 punfold H1. pfold. + induction H1; intros; subst; pclearbot; simpl; eauto. + - econstructor. pupto2 eutt_nested_clo_bind. + econstructor; [apply H|]. + intros; subst. pupto2_final. + right. eapply CIH'. edestruct EUTTK; pclearbot; eauto. + - econstructor. pupto2_final. eauto 7. +Qed. + +Lemma interp_ret : forall {E F R} x + (f : E ~> itree F), + (interp f R (Ret x)) ≅ Ret x. +Proof. + intros. rewrite (itree_eta (Ret x)). + rewrite unfold_interp. unfold interp_u. unfold handleF. + cbn. reflexivity. Qed. Lemma interp_bind {E F R S} @@ -129,81 +143,97 @@ Proof. revert R t k. pcofix CIH. intros. rewrite (itree_eta t). destruct (observe t). - - rewrite ret_interp, !ret_bind. pupto2_final. apply eq_itree_refl. + (* TODO: [ret_bind] (0.8s) is much slower than [ret_bind_] (0.02s) *) + - rewrite ret_interp. rewrite !ret_bind. pupto2_final. apply reflexivity. - rewrite tau_interp, !tau_bind, tau_interp. pupto2_final. pfold. econstructor. eauto. - - rewrite vis_interp, tau_bind, bind_bind. + - rewrite vis_interp, tau_bind. rewrite bind_bind. pfold. do 2 red; cbn. constructor. pupto2 (eq_itree_clo_bind F S). econstructor. + reflexivity. - + intros; specialize (CIH _ (k0 v) k); auto. + + intros; subst. specialize (CIH _ (k0 u2) k); auto. +Qed. + +Lemma interp_liftE {E F : Type -> Type} {R : Type} + (f : E ~> (itree F)) + (e : E R) : + interp f _ (ITree.liftE e) ≅ Tau (f _ e). +Proof. + unfold ITree.liftE. rewrite vis_interp. + apply itree_eq_tau. + assert (pointwise_relation _ (@eq_itree _ _ _ (@eq R)) (fun x : R => interp f R (Ret x)) (fun x => Ret x)). + {red. intros. rewrite ret_interp. reflexivity. } + rewrite H. rewrite bind_ret. + reflexivity. Qed. -Definition interp_match {E F} (f: E ~> itree F) : (E +' F) ~> itree F := - fun _ ef => match ef with inl1 e => f _ e | inr1 e => Vis e (fun r => Ret r) end. -Inductive interp_inv {E F R} (f: E ~> itree F) : relation (itree' F R) := -| _interp_inv_main t: - interp_inv f - (observe (interp (interp_match f) _ t)) (observe (interp1 f _ t)) -| _interp_inv_bind u t (k: u -> _): - interp_inv f - (observe (ITree.bind t (fun x => interp (interp_match f) _ (k x)))) - (observe (ITree.bind t (fun x => interp1 f _ (k x)))) -. -Hint Constructors interp_inv. +(** ** Composition of [interp] *) -Lemma interp_inv_main_step E F R (f: E ~> itree F) (t: itree _ R) : - euttF' (fun x y => interp_inv f (observe x) (observe y)) (interp_inv f) - (observe (interp (interp_match f) _ t)) (observe (interp1 f _ t)). +Lemma interp_id_liftE {E R} (t : itree E R) : + interp (fun _ e => ITree.liftE e) _ t ≈ t. Proof. - rewrite interp_unfold, interp1_unfold. - genobs t ot. clear Heqot t. - destruct ot; simpl; eauto. - destruct e; simpl; eauto. - econstructor. rewrite bind_unfold. - econstructor. intros. - fold_bind. rewrite bind_unfold. simpl. eauto. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite unfold_interp. unfold interp_u. unfold handleF. + pfold. revert t. pcofix CIH'. + intros t. + destruct (observe t); cbn; eauto. + - pfold. econstructor. + right. rewrite unfold_interp. unfold interp_u. unfold handleF. + apply CIH'. + - pfold. econstructor. cbn. econstructor. intros. + assert (ITree.bind' (fun x0 : u => interp (fun (T : Type) (e0 : E T) => ITree.liftE e0) R (k x0)) (Ret x) = (x0 <- Ret x ;; interp (fun (T : Type) (e0 : E T) => ITree.liftE e0) R (k x0))). + { intros; reflexivity. } + left. rewrite H, ret_bind. + pupto2_final. eauto. Qed. -Lemma interp_is_interp1 E F R (f: E ~> itree F) (t: itree _ R) : - interp (interp_match f) _ t ≈ interp1 f _ t. + +Theorem interp_interp {E F G R} (f : E ~> itree F) (g : F ~> itree G) : + forall t : itree E R, + interp g _ (interp f _ t) + ≅ interp (fun _ e => interp g _ (f _ e)) _ t. Proof. + intros t. + pupto2_init. revert t. - cut (forall (t1 t2: itree _ R) (REL: interp_inv f (observe t1) (observe t2)), t1 ≈ t2). - { eauto. } - - intros. apply eutt_is_eutt'. - revert t1 t2 REL. pcofix CIH. intros. pfold. - revert t1 t2 REL. pcofix CIH'. intros. - destruct REL. - - pfold. eapply euttF'_mon; eauto using interp_inv_main_step; intros. - eapply upaco2_mon; eauto. intros. - eapply (CIH' (go x2) (go x3)); eauto. - - rewrite !bind_unfold. fold_bind. - genobs t ot. clear Heqot t. - destruct ot; simpl; eauto 10. - pfold. eapply euttF'_mon; eauto using interp_inv_main_step; intros. - eapply upaco2_mon; eauto. intros. - eapply (CIH' (go x2) (go x3)); eauto. + pcofix CIH. + intros t. + rewrite itree_eta. + rewrite (itree_eta t). + rewrite (itree_eta (interp (fun (T : Type) (e : E T) => interp g T (f T e)) R {| _observe := observe t|})). + rewrite unfold_interp. + destruct (observe t); cbn. + - pupto2_final. pfold. econstructor. reflexivity. + - pupto2_final. pfold. econstructor. right. apply CIH. + - rewrite interp_bind. + pfold. econstructor. + pupto2 eq_itree_clo_bind. + apply pbc_intro_h with (RU := eq). + + reflexivity. + + intros. + pupto2_final. right. subst. apply CIH. Qed. +(** * [interp_state] *) Lemma unfold_interp_state : forall {E F S R} (h : E ~> Monads.stateT S (itree F)) t s, observe (interp_state h _ t s) = - observe (interp_state_match h (interp_state h R) t s). + observe (interp_state_match h (interp_state h R) (observe t) s). Proof. intros E F S R h t s. econstructor. -Qed. - +Qed. Instance eq_itree_interp_state {E F S R} (h : E ~> Monads.stateT S (itree F)) : - Proper (@eq_itree E R ==> @eq S ==> - @eq_itree F (S * R)) (interp_state h _). + Proper (eq_itree eq ==> eq ==> eq_itree eq) + (interp_state h R). Proof. repeat intro. pupto2_init. revert_until R. - pcofix CIH. intros h x y H0 x2 y0 H1. + pcofix CIH. intros h x y H0 x2 y0 H1. rewrite itree_eta, (itree_eta (interp_state h _ y y0)), !unfold_interp_state. unfold interp_state_match. punfold H0; red in H0. @@ -211,43 +241,42 @@ Proof. - pupto2_final. pfold. red. cbn. subst. eauto. - pupto2_final. pfold. red. cbn. subst. eauto. - pfold. econstructor. pupto2 (eq_itree_clo_bind F (S * R)). - constructor. + econstructor. + subst. reflexivity. - + intros; pupto2_final; right; eauto. + + intros; subst. pupto2_final; right; eauto. Qed. Lemma unfold_interp1_state : forall {E F S R} (h : E ~> Monads.stateT S (itree F)) t s, observe (interp1_state h _ t s) = - observe (interp1_state_match h (interp1_state h R) t s). + observe (interp1_state_match h (interp1_state h R) (observe t) s). Proof. - intros E F S R h t s. + intros E F S R h t s. econstructor. -Qed. +Qed. Instance eq_itree_interp1_state {E F S R} (h : E ~> Monads.stateT S (itree F)) : - Proper (@eq_itree (E +' F) R ==> @eq S ==> - @eq_itree F (S * R)) (interp1_state h _). + Proper (eq_itree eq ==> eq ==> eq_itree eq) (interp1_state h R). Proof. repeat intro. pupto2_init. revert_until R. - pcofix CIH. intros h x y H0 x2 y0 H1. + pcofix CIH. intros h x y H0 x2 y0 H1. rewrite itree_eta, (itree_eta (interp1_state h _ y y0)), !unfold_interp1_state. unfold interp1_state_match. punfold H0; red in H0. - genobs x ox; destruct ox; simpobs; dependent destruction H0; simpobs; pclearbot. + genobs x ox; destruct ox; simpobs; dependent destruction H0; simpobs; pclearbot. - pupto2_final. pfold. red. cbn. subst. eauto. - pupto2_final. pfold. red. cbn. subst. eauto. - pfold. destruct e. * econstructor. pupto2 (eq_itree_clo_bind F (S * R)). - constructor. + econstructor. + subst. reflexivity. - + intros. pupto2_final. right. eauto. + + intros; subst. pupto2_final. right. eauto. * econstructor. intros. pupto2_final. right. eauto. Qed. - + Lemma interp_state_ret {E F : Type -> Type} {R S : Type} (f : forall T, E T -> S -> itree F (S * T)%type) @@ -298,7 +327,7 @@ Lemma interp_state_tau : forall {E F:Type -> Type} S {T : Type} (t:itree E T) (s (h : E ~> Monads.stateT S (itree F)), interp_state h _ (Tau t) s ≅ Tau (interp_state h _ t s). Proof. - intros E F S T t s h. + intros E F S T t s h. rewrite itree_eta. reflexivity. Qed. @@ -306,7 +335,7 @@ Lemma interp1_state_tau : forall {E F:Type -> Type} S {T : Type} (t:itree (E +' (h : E ~> Monads.stateT S (itree F)), interp1_state h _ (Tau t) s ≅ Tau (interp1_state h _ t s). Proof. - intros E F S T t s h. + intros E F S T t s h. rewrite itree_eta. reflexivity. Qed. @@ -315,8 +344,8 @@ Lemma interp_state_liftE {E F : Type -> Type} {R S : Type} (s : S) (e : E R) : (interp_state f _ (ITree.liftE e) s) ≅ Tau (f _ e s). Proof. - unfold ITree.liftE. rewrite interp_state_vis. - assert (pointwise_relation _ eq_itree (fun sx : S * R => interp_state f R (Ret (snd sx)) (fst sx)) (fun sx => Ret sx)). + unfold ITree.liftE. rewrite interp_state_vis. + assert (pointwise_relation _ (eq_itree eq) (fun sx : S * R => interp_state f R (Ret (snd sx)) (fst sx)) (fun sx => Ret sx)). { intros sx. destruct sx. simpl. rewrite itree_eta. cbn. reflexivity. } rewrite H. @@ -329,8 +358,8 @@ Lemma interp1_state_liftE1 {E F : Type -> Type} {R S : Type} (s : S) (e : E R) : (interp1_state f _ (ITree.liftE (inl1 e)) s) ≅ Tau (f _ e s). Proof. - unfold ITree.liftE. rewrite interp1_state_vis1. - assert (pointwise_relation _ eq_itree (fun sx : S * R => interp1_state f R (Ret (snd sx)) (fst sx)) (fun sx => Ret sx)). + unfold ITree.liftE. rewrite interp1_state_vis1. + assert (pointwise_relation _ (eq_itree eq) (fun sx : S * R => interp1_state f R (Ret (snd sx)) (fst sx)) (fun sx => Ret sx)). { intros sx. destruct sx. simpl. rewrite itree_eta. cbn. reflexivity. } rewrite H. @@ -363,16 +392,17 @@ Proof. intros A t k s. rewrite (itree_eta t). destruct (observe t). + (* TODO: performance issues with [ret|tau|vis_bind] here too. *) - cbn. rewrite interp_state_ret. rewrite !ret_bind. simpl. - pupto2_final. apply eq_itree_refl. + pupto2_final. apply reflexivity. - cbn. rewrite interp_state_tau, !tau_bind, interp_state_tau. pupto2_final. pfold. econstructor. right. apply CIH. - cbn. rewrite interp_state_vis, tau_bind, vis_bind, bind_bind, interp_state_vis. pfold. red. constructor. pupto2 (eq_itree_clo_bind F (S * B)). econstructor. + reflexivity. - + intros. specialize (CIH _ (k0 (snd v)) k (fst v)). auto. -Qed. + + intros. subst. specialize (CIH _ (k0 (snd u2)) k (fst u2)). auto. +Qed. Lemma interp1_state_bind {E F : Type -> Type} {A B S : Type} (f : forall T, E T -> S -> itree F (S * T)%type) @@ -389,7 +419,7 @@ Proof. rewrite (itree_eta t). destruct (observe t). - cbn. rewrite interp1_state_ret. rewrite !ret_bind. simpl. - pupto2_final. apply eq_itree_refl. + pupto2_final. apply reflexivity. - cbn. rewrite interp1_state_tau, !tau_bind, interp1_state_tau. pupto2_final. pfold. econstructor. right. apply CIH. - cbn. destruct e. @@ -397,9 +427,325 @@ Proof. pfold. red. constructor. pupto2 (eq_itree_clo_bind F (S * B)). econstructor. + reflexivity. - + intros. specialize (CIH _ (k0 (snd v)) k (fst v)). auto. + + intros. subst. specialize (CIH _ (k0 (snd u2)) k (fst u2)). auto. * rewrite interp1_state_vis2, !vis_bind. rewrite itree_eta. rewrite unfold_interp1_state. cbn. pfold. constructor. intros. specialize (CIH _ (k0 v) k s). auto. -Qed. +Qed. + +Instance eutt_interp_state {E F: Type -> Type} {S : Type} + (h : E ~> Monads.stateT S (itree F)) R : + Proper (eutt eq ==> eq ==> eutt eq) (@interp_state E F S h R). +Proof. + repeat intro. subst. pupto2_init. revert_until R. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + + rewrite !unfold_interp_state. do 2 punfold H0. pfold. + induction H0; intros; subst; simpl; pclearbot; eauto. + - econstructor. pupto2 eutt_nested_clo_bind. + econstructor; [reflexivity|]. + intros; subst. pupto2_final. + right. eapply CIH'. edestruct EUTTK; pclearbot; eauto. + - econstructor. pupto2_final. eauto 7. +Qed. + +(* Commuting interpreters --------------------------------------------------- *) + +Lemma interp_translate {E F G} (f : E ~> F) (g : F ~> itree G) {R} (t : itree E R) : + interp g _ (translate f t) ≅ interp (fun _ e => g _ (f _ e)) _ t. +Proof. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite (itree_eta). + rewrite (itree_eta (interp (fun (T : Type) (e : E T) => g T (f T e)) R t)). + rewrite !unfold_interp. unfold interp_u. + unfold handleF. rewrite unfold_translate. unfold translateF. + destruct (observe t); cbn. + - pupto2_final. apply Reflexive_eq_itree. (* SAZ: typeclass resolution failure? *) + - pfold. constructor. pupto2_final. right. apply CIH. + - pfold. constructor. + pupto2 eq_itree_clo_bind. + econstructor. + + reflexivity. + + intros. subst. pupto2_final. right. apply CIH. +Qed. + +Lemma translate_to_interp {E F R} (f : E ~> F) (t : itree E R) : + translate f t ≈ interp (fun _ e => ITree.liftE (f _ e)) _ t. +Proof. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite itree_eta. + rewrite (itree_eta (interp (fun (T : Type) (e : E T) => ITree.liftE (f T e)) R t)). + rewrite unfold_translate. + rewrite unfold_interp. + unfold translateF, interp_u, handleF. + pfold. revert t. pcofix CIH'. + intros t. + destruct (observe t); cbn; simpl in *; eauto. + - pfold. econstructor. + right. rewrite unfold_translate. unfold translateF. + rewrite unfold_interp. unfold interp_u. apply CIH'. + - pfold. econstructor. unfold ITree.liftE. rewrite vis_bind. + econstructor. intros. + left. + rewrite (itree_eta (x0 <- Ret x;; interp (fun (T : Type) (e0 : E T) => Vis (f T e0) (fun x1 : T => Ret x1)) R (k x0))). + assert ((observe (x0 <- Ret x;; interp (fun (T : Type) (e0 : E T) => Vis (f T e0) (fun x1 : T => Ret x1)) R (k x0))) + = observe (interp (fun (T : Type) (e0 : E T) => Vis (f T e0) (fun x1 : T => Ret x1)) R (k x))). + { reflexivity. } + rewrite H. + unfold ITree.liftE in CIH. + rewrite <- itree_eta. + pupto2_final. right. + apply CIH. +Qed. + +(* Morphism Category -------------------------------------------------------- *) + + +Lemma eh_cmp_id_left_strong : + forall A R (t : itree A R), interp eh_id R t ≈ t. +Proof. + intros A R. + intros t. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite unfold_interp. unfold interp_u. unfold handleF. + pfold. revert t. pcofix CIH'. + intros t. + destruct (observe t); cbn; eauto. + - pfold. econstructor. + right. rewrite unfold_interp. unfold interp_u. unfold handleF. + apply CIH'. + - pfold. econstructor. cbn. econstructor. intros. + assert (ITree.bind' (fun x0 : u => interp eh_id R (k x0)) (Ret x) = (x0 <- Ret x ;; interp eh_id R (k x0))). + { intros; reflexivity. } + left. + rewrite H. rewrite ret_bind. (* TODO: [ret_bind] doesn't work *) + pupto2_final. right. apply CIH. +Qed. + + +Lemma eh_cmp_id_left : + forall A B (f : A ~> itree B), eh_cmp eh_id f ≡ f. +Proof. + intros A B f X e. + unfold eh_cmp. apply eh_cmp_id_left_strong. +Qed. + + +Lemma eh_cmp_id_right : + forall A B (f : A ~> itree B), eh_cmp f eh_id ≡ f. +Proof. + intros B A f X e. + unfold eh_cmp. + unfold eh_id. unfold ITree.liftE. + rewrite unfold_interp. unfold interp_u. + unfold handleF. + cbn. eapply transitivity. apply tau_eutt. + assert (pointwise_relation _ (eq_itree eq) (fun x : X => interp f X (Ret x)) (fun x => Ret x)). + { red. intros. apply interp_ret. } + rewrite H. rewrite bind_ret. + reflexivity. +Qed. + +Lemma eh_both_left_right_id : forall A B X e, eh_both eh_inl eh_inr X e = (@eh_id (A +' B)) X e. +Proof. + intros A B X e. + unfold eh_both. + unfold eh_id. unfold ITree.liftE. + destruct e. + - unfold eh_inl. reflexivity. + - unfold eh_inr. reflexivity. +Qed. + +Lemma eh_cmp_assoc : forall A B C D (h : C ~> itree D) (g : B ~> itree C) (f : A ~> itree B), + eh_cmp h (eh_cmp g f) ≡ (eh_cmp (eh_cmp h g) f). +Proof. + intros A B C D h g f X e. + unfold eh_cmp. rewrite interp_interp. reflexivity. +Qed. + +Lemma eh_par_id : forall A B, eh_par eh_id eh_id ≡ (@eh_id (A +' B)). +Proof. + intros A B X e. + unfold eh_par. + unfold eh_id. + destruct e. + - unfold ITree.liftE. + rewrite translate_vis. + assert (pointwise_relation X (@eq_itree (A +' B) _ _ eq) (fun x : X => translate (inl1 (E2:=B)) (Ret x)) (fun x : X => Ret x)). + { intros x. rewrite translate_ret. reflexivity. } + rewrite H. reflexivity. + - unfold ITree.liftE. + rewrite translate_vis. + assert (pointwise_relation X (@eq_itree (A +' B) _ _ eq) (fun x : X => translate (inr1 (E2:=B)) (Ret x)) (fun x : X => Ret x)). + { intros x. rewrite translate_ret. reflexivity. } + rewrite H. reflexivity. +Qed. + + +Lemma eh_swap_swap_id : forall A B, eh_cmp eh_swap eh_swap ≡ (eh_id : (A +' B) ~> itree (A +' B)). +Proof. + intros A B X e. + unfold eh_cmp. unfold eh_swap. unfold eh_lift. + rewrite interp_liftE. rewrite tau_eutt. destruct e; simpl; reflexivity. +Qed. + +Lemma eh_empty_unit_l : forall A, eh_cmp eh_empty_right eh_inl ≡ (eh_id : A ~> itree A). +Proof. + intros A X e. + unfold eh_cmp. + unfold eh_empty_right. + unfold eh_inl. + unfold eh_lift. + rewrite interp_liftE. + rewrite tau_eutt. + simpl. unfold Sum1.idE. reflexivity. +Qed. + +Lemma eh_empty_unit_r : forall A, eh_cmp eh_empty_left eh_inr ≡ (eh_id : A ~> itree A). +Proof. + intros A X e. + unfold eh_cmp. + unfold eh_empty_left. + unfold eh_inr. + unfold eh_lift. + rewrite interp_liftE. + rewrite tau_eutt. + simpl. unfold Sum1.idE. reflexivity. +Qed. + +(*** + lemmas about [interp1]. + We can remove [interp1] but keep it just in case it is useful. + ***) + +Definition interp1_u {E F G} `{F -< G} (h : E ~> itree G) R : + itreeF (E +' F) R _ -> itree G R := + handleF (interp1 h _) + (fun _ ef k => + match ef with + | inl1 e => Tau (ITree.bind (h _ e) + (fun x => interp1 h _ (k x))) + | inr1 f => Vis (subeffect _ f) (fun x => interp1 h _ (k x)) + end). + +Lemma unfold_interp1 {E F G : Type -> Type} `{F -< G} (h : E ~> itree G) R (t : itree (E +' F) R) : + observing eq (interp1 h _ t) (interp1_u h _ (observe t)). +Proof. econstructor. auto. Qed. + +Lemma unfold_interp1_ {E F G : Type -> Type} `{F -< G} (h : E ~> itree G) R (t : itree (E +' F) R) : + interp1 h _ t ≅ interp1_u h _ (observe t). +Proof. rewrite itree_eta, unfold_interp1, <-itree_eta. reflexivity. Qed. + +(** ** [interp1] is equivalent to [interp] *) + +Section interp1_is_interp. + +Context {E F G : Type -> Type} `{F -< G} (f : E ~> itree G). + +Definition interp_match : (E +' F) ~> itree G := + fun _ ef => match ef with inl1 e => f _ e | inr1 e => Vis (subeffect _ e) (fun r => Ret r) end. + +Lemma interp_is_interp1 R (t: itree _ R) : + interp interp_match _ t ≈ interp1 f _ t. +Proof. + pupto2_init. revert_until R. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + + rewrite unfold_interp, unfold_interp1. unfold interp_u, interp1_u. + destruct (observe t); [| |destruct e]; simpl; eauto. + - pfold; econstructor. pupto2_final. eauto. + - pfold; econstructor. pupto2 eutt_nested_clo_bind. + econstructor; [reflexivity|]. + intros. subst. eauto. + - rewrite vis_bind_. pfold. econstructor. econstructor. + left. rewrite ret_bind_. pupto2_final. eauto. +Qed. + +End interp1_is_interp. + +Instance eq_itree_interp1 {E F G R} `{F -< G} (h : E ~> itree G) : + Proper (@eq_itree (E +' F) _ _ eq ==> eq_itree eq) (interp1 h R). +Proof. + repeat intro. pupto2_init. revert_until R. + pcofix CIH. intros. + rewrite !unfold_interp1_. + punfold H1; red in H1. + destruct H1; pclearbot. + - pupto2_final. pfold. red. cbn. eauto. + - pupto2_final. pfold. red. cbn. eauto. + - pfold. destruct e; cbn; econstructor. + + pupto2 eq_itree_clo_bind. + econstructor. + * reflexivity. + * intros; subst. pupto2_final; eauto. + + intros. pupto2_final. eauto. +Qed. + +Instance eutt_interp1 {E F G R} `{F -< G} (h: E ~> itree G): + Proper (eutt eq ==> eutt eq) (@interp1 E F G _ h R). +Proof. + repeat intro. pupto2_init. revert_until H. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + + rewrite !unfold_interp1. do 2 punfold H1. pfold. + induction H1; intros; subst; pclearbot; simpl; eauto. + - destruct e. + + econstructor. pupto2 eutt_nested_clo_bind. + econstructor; [reflexivity|]. + intros; subst. pupto2_final. + right. eapply CIH'. edestruct EUTTK; pclearbot; eauto. + + econstructor. left. pupto2_final. + right. eapply CIH. edestruct EUTTK; pclearbot; eauto. + - econstructor. pupto2_final. eauto 7. +Qed. + +Lemma interp1_bind {E F G} `{F -< G} {R S} (h : E ~> itree G) (t : _ R) (k : _ -> itree (E +' F) S) : + interp1 h _ (t >>= k) ≅ interp1 h _ t >>= fun x => interp1 h _ (k x). +Proof. + pupto2_init. + revert t; pcofix self; intros. + rewrite !unfold_interp1_, unfold_bind, unfold_bind_. + destruct (observe t); cbn. + - rewrite unfold_interp1_. + pupto2_final. apply reflexivity. + - pfold; constructor; auto. + - destruct e; cbn. + + rewrite bind_bind. pfold; constructor. + pupto2 eq_itree_clo_bind. econstructor. + * reflexivity. + * intros; subst. eauto. + + pfold; constructor; auto. +Qed. + +Lemma translate_interp1 {E F R} (h : F ~> itree E) : + forall (t : itree E R), + interp1 h _ (translate (fun _ e => inr1 e) t) ≅ t. +Proof. + pcofix self; intros. + pfold; red. + rewrite unfold_interp1. + rewrite TranslateFacts.unfold_translate. + destruct (observe t); cbn; auto. +Qed. + +Lemma interp1_liftE {E F G: Type -> Type} `{F -< G}: + forall (h: forall T: Type, E T -> itree G T) T (e : E T), + @interp1 E F G _ h T (lift e) ≈ h T e. +Proof. + intros. unfold lift. + rewrite unfold_interp1_; cbn. + rewrite tau_eutt. + setoid_rewrite unfold_interp1_; cbn. + rewrite bind_ret. + reflexivity. +Qed. diff --git a/theories/Trace.v b/theories/Trace.v index 99289e01..54360f24 100644 --- a/theories/Trace.v +++ b/theories/Trace.v @@ -6,7 +6,11 @@ Import ListNotations. From ITree Require Import Core - Eq.UpToTaus. + Eq.Untaus + Eq.UpToTaus + Eq.SimUpToTaus. + +Local Open Scope itree. From Paco Require Import paco. @@ -98,8 +102,42 @@ Lemma is_trace_unalltaus_add: forall {E R} (t1 t2 : itree E R) tr, is_trace t1 tr. Proof. intros. eapply is_traceF_unalltaus_add; eauto. Qed. -Lemma eutt_trace_incl : forall {E R} (t1 t2 : itree E R), - t1 ≈ t2 -> trace_incl t1 t2. +Lemma is_trace_tau : forall {E R} (t : itree E R) tr, + is_trace t tr <-> + is_trace (Tau t) tr. +Proof. + intros. split; intros. + - constructor. unfold is_trace in *. remember (observe t). + generalize dependent t. + induction H; intros; subst; constructor; eapply IHis_traceF; auto. + - inversion H; subst; try constructor; auto. +Qed. + +Lemma tauF_sutt_eq : forall {E R} (t1 t2 t : itree E R), + sutt eq t1 t2 -> + TauF t = observe t1 -> + sutt eq t t2. +Proof. + intros. pinversion H. pfold. constructor; simpobs. + - intros. apply FIN. rewrite finite_taus_tau. assumption. + - intros t1' t2' H1 H2. + apply EQV; auto. + eapply unalltaus_tau'; auto. +Qed. + +Lemma suttF_tau_right {E R} r (t1 t2 t2' : itree E R) + (OBS: TauF t2 = observe t2') + (REL: sutt_ eq r t1 t2'): + sutt_ eq r t1 t2. +Proof. + intros. destruct REL. constructor. + - intros. apply FIN in H. simpobs. rewrite <- finite_taus_tau. auto. + - intros. eapply EQV; eauto. rewrite <- OBS. inversion UNTAUS2. constructor; auto. + econstructor; eauto. +Qed. + +Lemma sutt_trace_incl : forall {E R} (t1 t2 : itree E R), + sutt eq t1 t2 -> trace_incl t1 t2. Proof. red. intros. red in H0. remember (observe t1). generalize dependent t1. generalize dependent t2. @@ -110,35 +148,35 @@ Proof. rewrite Heqi. constructor; auto. red. rewrite <- Heqi. auto. } assert (FIN2: finite_tausF (observe t1)) by (eexists; apply Hunall). - rewrite FIN in FIN2. inv FIN2. + apply FIN in FIN2. inv FIN2. specialize (EQV _ _ Hunall H0). inv EQV. red. eapply is_trace_unalltaus_add. + simpobs. auto. + red. rewrite <- Heqi. constructor. - apply IHis_traceF with (t1:=t); auto. - rewrite <- H. symmetry. apply tauF_eutt. assumption. + eapply tauF_sutt_eq; eauto. - pinversion H. assert (Hunall: unalltausF (observe t1) (VisF e k)). { rewrite Heqi. constructor; auto. red. rewrite <- Heqi. auto. } assert (FIN2: finite_tausF (observe t1)) by (eexists; apply Hunall). - rewrite FIN in FIN2. inv FIN2. + apply FIN in FIN2. inv FIN2. specialize (EQV _ _ Hunall H0). inv EQV. invert_existTs. inv H0. red. remember (VisF _ _) in H1. remember (observe t2). generalize dependent t2. induction H1; intros; subst; constructor. eapply IHuntausF; auto. - + rewrite FIN. apply finite_taus_tau; auto. - + eapply euttF_tau_right; eauto. + + rewrite finite_taus_tau in FIN; auto. + + eapply suttF_tau_right; eauto. - pinversion H. assert (Hunall: unalltausF (observe t1) (VisF e k)). { rewrite Heqi. constructor; auto. red. rewrite <- Heqi. auto. } assert (FIN2: finite_tausF (observe t1)) by (eexists; apply Hunall). - rewrite FIN in FIN2. inv FIN2. + apply FIN in FIN2. inv FIN2. specialize (EQV _ _ Hunall H1). inv EQV. invert_existTs. inv H1. specialize (H6 x). red. remember (VisF _ _) in H2. remember (observe t2). @@ -148,27 +186,16 @@ Proof. pfold. inversion H6. pinversion H1. inversion H1. + eapply IHuntausF; auto. - * rewrite FIN. apply finite_taus_tau; auto. - * eapply euttF_tau_right; eauto. + * rewrite finite_taus_tau in FIN; auto. + * eapply suttF_tau_right; eauto. Qed. Lemma eutt_trace_eq : forall {E R} (t1 t2 : itree E R), t1 ≈ t2 -> trace_eq t1 t2. Proof. split. - - apply eutt_trace_incl; auto. - - symmetry in H. apply eutt_trace_incl; auto. -Qed. - -Lemma is_trace_tau : forall {E R} (t : itree E R) tr, - is_trace t tr <-> - is_trace (Tau t) tr. -Proof. - intros. split; intros. - - constructor. unfold is_trace in *. remember (observe t). - generalize dependent t. - induction H; intros; subst; constructor; eapply IHis_traceF; auto. - - inversion H; subst; try constructor; auto. + - apply sutt_trace_incl; apply eutt_sutt; auto. + - symmetry in H. apply sutt_trace_incl; apply eutt_sutt; auto. Qed. Lemma trace_incl_finite_taus : forall {E R} (t1 t2 : itree E R), @@ -197,37 +224,53 @@ Proof. intros. apply H. red. rewrite <- Heqi. apply is_trace_tau; auto. Qed. -Lemma trace_eq_eutt : forall {E R} (t1 t2 : itree E R), - trace_eq t1 t2 -> t1 ≈ t2. +Lemma trace_incl_sutt : forall {E R} (t1 t2 : itree E R), + trace_incl t1 t2 -> sutt eq t1 t2. Proof. - intros E R. pcofix CIH. intros t1 t2 Heq. pfold. constructor. - - destruct Heq. split; intros; eapply trace_incl_finite_taus; eauto. - - intros. destruct Heq as [H12 H21]. unfold trace_incl in *. unfold is_trace in *. - assert (Heq' : forall tr, is_traceF ot1' tr <-> is_traceF ot2' tr). - { - intros. split; intros. + intros E R. pcofix CIH. intros t1 t2 Hincl. pfold. constructor. + - apply trace_incl_finite_taus; auto. + - intros. unfold trace_incl in *. unfold is_trace in *. + assert (Heq' : forall tr, is_traceF ot1' tr -> is_traceF ot2' tr). + { intros. - pose proof (is_traceF_unalltaus_add _ _ _ UNTAUS1 H). eapply is_traceF_unalltaus_remove; eauto. - - pose proof (is_traceF_unalltaus_add _ _ _ UNTAUS2 H). - eapply is_traceF_unalltaus_remove; eauto. } destruct ot1', ot2'; try solve [inv UNTAUS1; inv H0]; try solve [inv UNTAUS2; inv H0]. + assert (is_traceF (RetF r0 : itreeF E R (itree E R)) (TRet r0)) by constructor. - rewrite Heq' in H. inv H. constructor. + apply Heq' in H. inv H; auto. + assert (is_traceF (RetF r0 : itreeF E R (itree E R)) (TRet r0)) by constructor. - rewrite Heq' in H. inv H. + apply Heq' in H. inv H. + assert (is_traceF (VisF e k) (TEventEnd e)) by constructor. - rewrite Heq' in H. inv H. + apply Heq' in H. inv H. + assert (is_traceF (VisF e k) (TEventEnd e)) by constructor. - rewrite Heq' in H. inv H. invert_existTs. + apply Heq' in H. inv H. invert_existTs. constructor. intros. right. apply CIH. - red. split; red; intros. - * assert (is_traceF (VisF e k) (TEventResponse e x tr)) by (constructor; auto). - rewrite Heq' in H0. inv H0. invert_existTs. auto. - * assert (is_traceF (VisF e k0) (TEventResponse e x tr)) by (constructor; auto). - rewrite <- Heq' in H0. inv H0. invert_existTs. auto. + intros. + assert (is_traceF (VisF e k) (TEventResponse e x tr)) by (constructor; auto). + apply Heq' in H0. inv H0. invert_existTs. auto. +Qed. + +Theorem trace_incl_iff_sutt : forall {E R} (t1 t2 : itree E R), + sutt eq t1 t2 <-> trace_incl t1 t2. +Proof. + split. + - apply sutt_trace_incl. + - apply trace_incl_sutt. +Qed. + +Lemma trace_eq_eutt : forall {E R} (t1 t2 : itree E R), + trace_eq t1 t2 -> t1 ≈ t2. +Proof. + intros E R t1 t2 [? ?]. apply sutt_eutt. + - apply trace_incl_sutt; auto. + - apply trace_incl_sutt in H0. clear H. + generalize dependent t1. generalize dependent t2. pcofix CIH; intros. + pinversion H0. pfold. constructor; auto. intros. + specialize (EQV _ _ UNTAUS1 UNTAUS2). destruct EQV; constructor; auto. + + rewrite H. reflexivity. + + intros. right. apply CIH. pclearbot. apply H. Qed. Theorem trace_eq_iff_eutt : forall {E R} (t1 t2 : itree E R), diff --git a/theories/Translate.v b/theories/Translate.v new file mode 100644 index 00000000..9fc1cf08 --- /dev/null +++ b/theories/Translate.v @@ -0,0 +1,34 @@ +(** An event morphism [E ~> F] lifts to an itree morphism [itree E ~> itree F] + by mapping the event morphism across each visible event. We call this + process _event translation_. + + + Translate is defined separately from the itree Morphisms because it is + conceptually at a different level: translation always yields strong + bisimulations. We can relate translation and interpretation via the law: + + translate h t ≈ interp (liftE ∘ h) t +*) + +From ExtLib Require + Structures.Monoid. + +From ITree Require Import + Basics + Core + Effect.Sum. + +Open Scope itree_scope. + +(** A plain effect morphism [E ~> F] defines an itree morphism + [itree E ~> itree F]. *) +Definition translateF {E F R} (h : E ~> F) (rec: itree E R -> itree F R) (t : itreeF E R _) : itree F R := + match t with + | RetF x => Ret x + | TauF t => Tau (rec t) + | VisF e k => Vis (h _ e) (fun x => rec (k x)) + end. + +CoFixpoint translate {E F R} (h : E ~> F) (t : itree E R) : itree F R + := translateF h (translate h) (observe t). + diff --git a/theories/TranslateFacts.v b/theories/TranslateFacts.v new file mode 100644 index 00000000..5d2828c5 --- /dev/null +++ b/theories/TranslateFacts.v @@ -0,0 +1,154 @@ +(* translate facts ---------------------------------------------------------- *) + +From ExtLib Require + Structures.Monoid. + +From ITree Require Import + Basics + Core + Effect.Sum + Translate + Eq + UpToTaus. + +From Paco Require Import paco. + +From Coq Require Import + Program + Setoid + Morphisms + RelationClasses. + +Section TranslateFacts. + Context {E F : Type -> Type}. + Context {R : Type}. + Context (h : E ~> F). + +Lemma unfold_translate : forall (t : itree E R), + observing eq (translate h t) (translateF h (translate h) (observe t)). +Proof. + intros t. econstructor. reflexivity. +Qed. + +Lemma translate_ret : forall (r:R), translate h (Ret r) ≅ Ret r. +Proof. + intros r. + rewrite itree_eta. + rewrite unfold_translate. cbn. reflexivity. +Qed. + +Lemma translate_tau : forall (t : itree E R), translate h (Tau t) ≅ Tau (translate h t). +Proof. + intros t. + rewrite itree_eta. + rewrite unfold_translate. cbn. reflexivity. +Qed. + +Lemma translate_vis : forall X (e:E X) (k : X -> itree E R), + translate h (Vis e k) ≅ Vis (h _ e) (fun x => translate h (k x)). +Proof. + intros X e k. + rewrite itree_eta. + rewrite unfold_translate. cbn. reflexivity. +Qed. + +Global Instance translate_Proper : + Proper (eq_itree (@eq R) ==> eq_itree eq) (translate h). +Proof. + repeat red. + intros x y H. + pupto2_init. + revert x y H. + pcofix CIH. + intros x y H. + rewrite itree_eta. + rewrite (itree_eta (translate h y)). + repeat rewrite unfold_translate. unfold translateF. + rewrite (itree_eta x) in H. + rewrite (itree_eta y) in H. + destruct (observe x); destruct (observe y); pinversion H; subst; cbn. + - pupto2_final. apply Reflexive_eq_itree. (* SAZ: typeclass resolution not working *) + - pupto2_final. pfold. constructor. right. apply CIH. eauto. + - pupto2_final. pfold. + repeat (match goal with + | [ H : _ |- _ ] => apply inj_pair2 in H + end). subst. + constructor. + inversion H. + repeat (match goal with + | [ H : _ |- _ ] => apply inj_pair2 in H + end). subst. + right. apply CIH. + eapply transitivity. pclearbot. apply REL0. reflexivity. +Qed. + +Global Instance translateF_Proper : + Proper (going (eq_itree eq) ==> eq_itree (@eq R)) (translateF h (translate h)). +Proof. + repeat red. intros. + replace x with (observe (go x)) by auto. + replace y with (observe (go y)) by auto. + rewrite <- !unfold_translate. + rewrite H. apply reflexivity. +Qed. + +End TranslateFacts. + +Lemma translate_bind : forall {E F R S} (h : E ~> F) (t : itree E S) (k : S -> itree E R), + translate h (x <- t ;; k x) ≅ (x <- (translate h t) ;; translate h (k x)). +Proof. + intros E F R S h t k. + pupto2_init. + revert S t k. + pcofix CIH. + intros s t k. + rewrite !unfold_translate, !unfold_bind. + genobs_clear t ot. destruct ot; cbn. + - rewrite unfold_translate. + pupto2_final. apply Reflexive_eq_itree. + - pfold. econstructor. pupto2_final. right. apply CIH. + - pfold. econstructor. intros. pupto2_final. right. apply CIH. +Qed. + +(* categorical properties --------------------------------------------------- *) + +Import Sum1. + +Lemma translate_id : forall E R (t : itree E R), translate idE t ≅ t. +Proof. + intros E R t. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite itree_eta. + rewrite (itree_eta t). + rewrite unfold_translate. + unfold translateF. + destruct (observe t); cbn. + - pupto2_final. apply Reflexive_eq_itree. + - pfold. econstructor. pupto2_final. right. apply CIH. + - pfold. econstructor. intros. pupto2_final. right. apply CIH. +Qed. + +Lemma translate_cmpE : forall E F G R (g : F ~> G) (f : E ~> F) (t : itree E R), + translate (cmpE g f) t ≅ translate g (translate f t). +Proof. + intros E F G R g f t. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite !unfold_translate. + genobs_clear t ot. destruct ot; cbn. + - pupto2_final. apply reflexivity. + - pfold. econstructor. pupto2_final. right. apply CIH. + - pfold. econstructor. intros. pupto2_final. right. apply CIH. +Qed. + +(* SAZ: TODO - it would be good to allow for rewriting of event morphisms under translate: + + E ~~ F -> translate E t ≅ translate F t + + Where E ~~ F is extensional equality. +*) \ No newline at end of file