(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs. <contact@nomadic-labs.com> *)

(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"), *)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)

(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)

(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)

(* Michelson comparable types: nat, int, string, timestamp, mutez, bool,
   and key hashes *)

Require Import ZArith.
Require Import Ascii.
Require String.
Require Import ListSet.
Require tez.
Require Relations_1.
Require Import syntax.
Require Import syntax_type.

Definition simple_comparable_data (a : simple_comparable_type) : Set :=
  match a with
  | int => Z
  | nat => N
  | string => str
  | bytes => str
  | timestamp => Z
  | mutez => tez.mutez
  | bool => Datatypes.bool
  | address => address_constant
  | key_hash => key_hash_constant
  end.

Fixpoint comparable_data (a : comparable_type) : Set :=
  match a with
  | Comparable_type_simple a => simple_comparable_data a
  | Cpair a b => simple_comparable_data a * comparable_data b
  end.

Definition comparison_to_int (c : comparison) :=
  match c with
  | Lt => (-1)%Z
  | Gt => 1%Z
  | Eq => 0%Z
  end.

Lemma comparison_to_int_Lt c : comparison_to_int c = (-1)%Z <-> c = Lt.
Proof.
  split.
  - destruct c; simpl.
    + discriminate.
    + reflexivity.
    + discriminate.
  - intro; subst c.
    reflexivity.
Qed.

Lemma comparison_to_int_Gt c : comparison_to_int c = 1%Z <-> c = Gt.
Proof.
  split.
  - destruct c; simpl.
    + discriminate.
    + discriminate.
    + reflexivity.
  - intro; subst c.
    reflexivity.
Qed.

Lemma comparison_to_int_Eq c : comparison_to_int c = 0%Z <-> c = Eq.
Proof.
  split.
  - destruct c; simpl.
    + reflexivity.
    + discriminate.
    + discriminate.
  - intro; subst c.
    reflexivity.
Qed.

Definition bool_compare (b1 b2 : Datatypes.bool) : comparison :=
  match b1, b2 with
  | false, false => Eq
  | false, true => Lt
  | true, false => Gt
  | true, true => Eq
  end.

Definition ascii_compare (a1 a2 : ascii) : comparison :=
  (Ascii.N_of_ascii a1 ?= Ascii.N_of_ascii a2)%N.

Fixpoint string_compare (s1 s2 : str) : comparison :=
  match s1, s2 with
  | String.EmptyString, String.EmptyString => Eq
  | String.EmptyString, _ => Lt
  | _, String.EmptyString => Gt
  | String.String a1 s1, String.String a2 s2 =>
    match ascii_compare a1 a2 with
    | Lt => Lt
    | Gt => Gt
    | Eq => string_compare s1 s2
    end
  end.

Lemma ascii_compare_Eq_correct (a1 a2 : Ascii.ascii) : ascii_compare a1 a2 = Eq <-> a1 = a2.
Proof.
  unfold ascii_compare.
  rewrite N.compare_eq_iff.
  split.
  - intro H.
    apply (f_equal Ascii.ascii_of_N) in H.
    rewrite Ascii.ascii_N_embedding in H.
    rewrite Ascii.ascii_N_embedding in H.
    assumption.
  - apply f_equal.
Qed.

Lemma ascii_compare_Lt_neq (a1 a2 : Ascii.ascii) : ascii_compare a1 a2 = Lt -> a1 <> a2.
Proof.
  intros H He.
  apply ascii_compare_Eq_correct in He.
  congruence.
Qed.

Lemma ascii_compare_Gt_neq (a1 a2 : Ascii.ascii) : ascii_compare a1 a2 = Gt -> a1 <> a2.
Proof.
  intros H He.
  apply ascii_compare_Eq_correct in He.
  congruence.
Qed.

Lemma ascii_compare_Lt_trans (a1 a2 a3 : Ascii.ascii) :
  ascii_compare a1 a2 = Lt ->
  ascii_compare a2 a3 = Lt ->
  ascii_compare a1 a3 = Lt.
Proof.
  apply N.lt_trans.
Qed.

Lemma ascii_compare_Lt_Gt (a1 a2 : Ascii.ascii) : ascii_compare a1 a2 = Gt <-> ascii_compare a2 a1 = Lt.
Proof.
  unfold ascii_compare.
  rewrite N.compare_lt_iff.
  rewrite N.compare_gt_iff.
  intuition.
Qed.

Lemma ascii_compare_Gt_trans (a1 a2 a3 : Ascii.ascii) :
  ascii_compare a1 a2 = Gt ->
  ascii_compare a2 a3 = Gt ->
  ascii_compare a1 a3 = Gt.
Proof.
  rewrite ascii_compare_Lt_Gt.
  rewrite ascii_compare_Lt_Gt.
  rewrite ascii_compare_Lt_Gt.
  intros.
  apply (ascii_compare_Lt_trans _ a2); assumption.
Qed.

Lemma string_compare_Eq_correct (s1 s2 : str) : string_compare s1 s2 = Eq <-> s1 = s2.
Proof.
  generalize s2; clear s2.
  induction s1 as [|a1 s1]; intros [|a2 s2].
  - simpl. intuition.
  - simpl. split; discriminate.
  - simpl. split; discriminate.
  - simpl.
    case_eq (ascii_compare a1 a2).
    + intro H.
      apply (ascii_compare_Eq_correct a1 a2) in H.
      destruct H.
      split.
      * intro H.
        apply IHs1 in H.
        destruct H.
        reflexivity.
      * intro H.
        injection H.
        apply IHs1.
    + intro H.
      apply ascii_compare_Lt_neq in H.
      split; congruence.
    + intro H.
      apply ascii_compare_Gt_neq in H.
      split; congruence.
Qed.

Lemma string_compare_Lt_trans (s1 s2 s3 : str) :
  string_compare s1 s2 = Lt ->
  string_compare s2 s3 = Lt ->
  string_compare s1 s3 = Lt.
Proof.
  generalize s2 s3. clear s2 s3.
  induction s1 as [|ax x] ; simpl; intros [|ay y]; intros [|az z]; simpl; try congruence.
  specialize (IHx y z).
  case_eq (ascii_compare ax ay); case_eq (ascii_compare ay az); case_eq (ascii_compare ax az); try congruence.
  + auto.
  + rewrite ascii_compare_Eq_correct.
    rewrite ascii_compare_Eq_correct.
    intros Hxz Hyz Hxy.
    assert (ax = az) as He by congruence.
    rewrite <- ascii_compare_Eq_correct in He.
    congruence.
  + rewrite ascii_compare_Eq_correct.
    rewrite ascii_compare_Eq_correct.
    intros Hxz Hyz Hxy.
    assert (ay = az) as He by congruence.
    rewrite <- ascii_compare_Eq_correct in He.
    congruence.
  + rewrite ascii_compare_Lt_Gt.
    intros Hxz Hyz Hxy.
    assert (ascii_compare ay ax = Lt) as Hlt by (apply (ascii_compare_Lt_trans _ az _); assumption).
    rewrite <- ascii_compare_Lt_Gt in Hlt.
    congruence.
  + rewrite ascii_compare_Eq_correct.
    rewrite ascii_compare_Eq_correct.
    intros Hxz Hyz Hxy.
    assert (ax = ay) as He by congruence.
    rewrite <- ascii_compare_Eq_correct in He.
    congruence.
  + rewrite ascii_compare_Lt_Gt.
    intros Hxz Hyz Hxy.
    assert (ascii_compare az ay = Lt) as Hlt by (apply (ascii_compare_Lt_trans _ ax _); assumption).
    rewrite <- ascii_compare_Lt_Gt in Hlt.
    congruence.
  + intros Hxz Hyz Hxy.
    assert (ascii_compare ax az = Lt) as Hlt by (apply (ascii_compare_Lt_trans _ ay _); assumption).
    congruence.
  + intros Hxz Hyz Hxy.
    assert (ascii_compare ax az = Lt) as Hlt by (apply (ascii_compare_Lt_trans _ ay _); assumption).
    congruence.
Qed.

Lemma string_compare_Lt_Gt (s1 s2 : str) :
  string_compare s1 s2 = Gt <->
  string_compare s2 s1 = Lt.
Proof.
  generalize s2. clear s2.
  induction s1 as [|a1 s1]; intros [|a2 s2] ; simpl.
  - split; congruence.
  - split; congruence.
  - intuition.
  - specialize (IHs1 s2).
    case_eq (ascii_compare a1 a2); case_eq (ascii_compare a2 a1);
      try (rewrite ascii_compare_Lt_Gt; congruence);
      try (rewrite <- ascii_compare_Lt_Gt; congruence);
      intuition.
Qed.

Lemma string_compare_Gt_trans (s1 s2 s3 : str) :
  string_compare s1 s2 = Gt ->
  string_compare s2 s3 = Gt ->
  string_compare s1 s3 = Gt.
Proof.
  rewrite string_compare_Lt_Gt.
  rewrite string_compare_Lt_Gt.
  rewrite string_compare_Lt_Gt.
  intros.
  apply (string_compare_Lt_trans _ s2); assumption.
Qed.

Definition address_compare (a1 a2 : address_constant) : comparison :=
  match a1, a2 with
  | Mk_address s1, Mk_address s2 => string_compare s1 s2
  end.

Definition key_hash_compare (h1 h2 : key_hash_constant) : comparison :=
  match h1, h2 with
  | Mk_key_hash s1, Mk_key_hash s2 => string_compare s1 s2
  end.

Definition comprel (A : Set) := A -> A -> comparison.

Definition simple_compare (a : syntax_type.simple_comparable_type) :
  comprel (simple_comparable_data a) :=
  match a with
  | nat => N.compare
  | int => Z.compare
  | bool => bool_compare
  | string => string_compare
  | bytes => string_compare
  | mutez => tez.compare
  | address => address_compare
  | key_hash => key_hash_compare
  | timestamp => Z.compare
  end.

Definition lexicographic_comparison {A B : Set}
           (cA : comprel A) (cB : comprel B) : comprel (A * B) :=
  fun '(x1, y1) '(x2, y2) =>
    match cA x1 x2 with
    | Eq => cB y1 y2
    | c => c
    end.

Fixpoint compare (a : comparable_type) :
  comprel (comparable_data a) :=
  match a with
  | Comparable_type_simple a => simple_compare a
  | Cpair a b => lexicographic_comparison (simple_compare a) (compare b)
  end.

Definition eq_compatible {A : Set} (cA : comprel A) : Prop :=
  forall x y : A, cA x y = Eq <-> x = y.

Lemma lexicographic_comparison_eq_iff {A B} (cA : comprel A) (cB : comprel B) :
  eq_compatible cA -> eq_compatible cB ->
  eq_compatible (lexicographic_comparison cA cB).
Proof.
  intros HA HB (xA, xB) (yA, yB).
  specialize (HA xA yA).
  specialize (HB xB yB).
  simpl.
  split.
  - destruct (cA xA yA); intuition congruence.
  - intro H; injection H.
    intros HBe HAe.
    rewrite <- HA in HAe.
    rewrite HAe.
    intuition.
Qed.

Lemma simple_compare_eq_iff a c1 c2 : simple_compare a c1 c2 = Eq <-> c1 = c2.
Proof.
  destruct a; simpl.
  - apply string_compare_Eq_correct.
  - apply N.compare_eq_iff.
  - apply Z.compare_eq_iff.
  - apply string_compare_Eq_correct.
  - destruct c1; destruct c2; split; simpl; congruence.
  - apply tez.compare_eq_iff.
  - destruct c1 as [s1]; destruct c2 as [s2]. simpl.
    rewrite string_compare_Eq_correct.
    split; congruence.
  - destruct c1 as [s1]; destruct c2 as [s2]. simpl.
    rewrite string_compare_Eq_correct.
    split; congruence.
  - apply Z.compare_eq_iff.
Qed.

Lemma compare_eq_iff a : forall c1 c2, compare a c1 c2 = Eq <-> c1 = c2.
Proof.
  induction a as [a|a b]; simpl.
  - apply simple_compare_eq_iff.
  - apply lexicographic_comparison_eq_iff.
    + exact (simple_compare_eq_iff _).
    + exact IHb.
Qed.

Definition lt_comp {A : Set} (c : comprel A) (x y : A) : Prop := c x y = Lt.

Definition lt a := lt_comp (compare a).

Lemma lexicographic_comparison_lt_trans {A B} (cA : comprel A) (cB : comprel B) :
  Relations_1.Transitive (lt_comp cA) ->
  Relations_1.Transitive (lt_comp cB) ->
  eq_compatible cA ->
  Relations_1.Transitive (lt_comp (lexicographic_comparison cA cB)).
Proof.
  intros HA HB Hcomp (xA, xB) (yA, yB) (zA, zB) Hxy Hyz.
  unfold lt_comp in *.
  simpl in *.
  case_eq (cA xA yA); intro H1; rewrite H1 in Hxy.
  - rewrite (Hcomp xA yA) in H1.
    rewrite H1.
    destruct (cA yA zA).
    + apply (HB _ yB); assumption.
    + reflexivity.
    + assumption.
  - case_eq (cA yA zA); intro H2; rewrite H2 in Hyz.
    + rewrite (Hcomp yA zA) in H2.
      rewrite <- H2.
      rewrite H1.
      reflexivity.
    + rewrite (HA xA yA zA); assumption.
    + discriminate.
  - discriminate.
Qed.

Lemma lt_trans_simple (a : simple_comparable_type) : Relations_1.Transitive (lt_comp (simple_compare a)).
Proof.
  unfold lt.
  destruct a; simpl; intros x y z.
  - apply string_compare_Lt_trans.
  - apply N.lt_trans.
  - apply Z.lt_trans.
  - apply string_compare_Lt_trans.
  - unfold lt_comp; destruct x; destruct y; destruct z; simpl; congruence.
  - apply Z.lt_trans.
  - destruct x as [x]; destruct y as [y]; destruct z as [z].
    apply string_compare_Lt_trans.
  - destruct x as [x]; destruct y as [y]; destruct z as [z].
    apply string_compare_Lt_trans.
  - apply Z.lt_trans.
Qed.

Lemma lt_trans (a : comparable_type) : Relations_1.Transitive (lt a).
Proof.
  unfold lt.
  induction a as [a | a b].
  - apply lt_trans_simple.
  - apply lexicographic_comparison_lt_trans.
    + apply lt_trans_simple.
    + exact IHb.
    + exact (simple_compare_eq_iff a).
Qed.

Definition gt_comp {A : Set} (c : comprel A) (x y : A) : Prop := c x y = Gt.
Definition gt a := gt_comp (compare a).

Lemma lexicographic_comparison_gt_trans {A B} (cA : comprel A) (cB : comprel B) :
  Relations_1.Transitive (gt_comp cA) ->
  Relations_1.Transitive (gt_comp cB) ->
  eq_compatible cA ->
  Relations_1.Transitive (gt_comp (lexicographic_comparison cA cB)).
Proof.
  intros HA HB Hcomp (xA, xB) (yA, yB) (zA, zB) Hxy Hyz.
  unfold gt_comp in *.
  simpl in *.
  case_eq (cA xA yA); intro H1; rewrite H1 in Hxy.
  - rewrite (Hcomp xA yA) in H1.
    rewrite H1.
    destruct (cA yA zA).
    + apply (HB _ yB); assumption.
    + assumption.
    + reflexivity.
  - discriminate.
  - case_eq (cA yA zA); intro H2; rewrite H2 in Hyz.
    + rewrite (Hcomp yA zA) in H2.
      rewrite <- H2.
      rewrite H1.
      reflexivity.
    + discriminate.
    + rewrite (HA xA yA zA); assumption.
Qed.

Lemma gt_trans_simple (a : simple_comparable_type) : Relations_1.Transitive (gt_comp (simple_compare a)).
Proof.
  unfold gt.
  destruct a; simpl; intros x y z.
  - apply string_compare_Gt_trans.
  - unfold gt_comp.
    rewrite N.compare_gt_iff.
    rewrite N.compare_gt_iff.
    rewrite N.compare_gt_iff.
    intros.
    transitivity y; assumption.
  - apply Zcompare_Gt_trans.
  - apply string_compare_Gt_trans.
  - unfold gt_comp.
    destruct x; destruct y; destruct z; simpl; congruence.
  - apply Zcompare_Gt_trans.
  - destruct x as [x]; destruct y as [y]; destruct z as [z].
    apply string_compare_Gt_trans.
  - destruct x as [x]; destruct y as [y]; destruct z as [z].
    apply string_compare_Gt_trans.
  - apply Zcompare_Gt_trans.
Qed.

Lemma gt_trans (a : comparable_type) : Relations_1.Transitive (gt a).
Proof.
  unfold gt.
  induction a as [a | a b].
  - apply gt_trans_simple.
  - apply lexicographic_comparison_gt_trans.
    + apply gt_trans_simple.
    + exact IHb.
    + exact (simple_compare_eq_iff a).
Qed.

Lemma compare_diff (K : comparable_type) (k1 k2 : comparable_data K) :
  compare K k1 k2 = Lt \/ compare K k1 k2 = Gt <-> k1 <> k2.
Proof.
  apply map.compare_diff.
  apply compare_eq_iff.
Qed.


(** *EqmR-related laws for the itree monad with weak bisimulation. *)
(* This file provides the instances for eqmR-related laws for the itree monad
 with weak bisimulation, [eutt]. *)

(* begin hide *)
From ExtLib Require Import
     Structures.Functor
     Structures.Monad.

From Paco Require Import paco.

From Coq Require Import Morphisms
     Program
     Classes.RelationClasses
     Relation_Definitions.

From ITree Require Import
     Basics.Basics
     Basics.CategoryOps
     Basics.HeterogeneousRelations
     Basics.Tacs Eq Eq.Eq
     Core.ITreeDefinition
     Eq.Eq Eq.UpToTaus
     EqmR.EqmRMonad
     EqmR.EqmRMonadT.

Import FunctorNotation.
Import CatNotations.
Import MonadNotation.
Import RelNotations.
Local Open Scope monad_scope.
Local Open Scope cat_scope.
Local Open Scope relationH_scope.
(* end hide *)

#[global]
Instance EqmR_ITree {E} : EqmR (itree E) := {| eqmR := (fun a b => eutt) |}.

Lemma compose_rcompose_equiv : forall {A B C} (R1 : relationH A B) (R2 : relationH B C),
  eq_rel (rcompose R1 R2) (rel_compose R2 R1) .
Proof.
  intros.
  split; unfold compose, subrelationH.
  - intros. inversion H. exists r2; split; assumption.
  - intros. edestruct H as (? & ? & ?).
    econstructor; eassumption.
Qed.

#[global]
Instance eqmR_conj_ITree {E}: RelConj (itree E).
repeat intro; eapply eutt_conj; eauto.
Defined.

#[global]
Instance itree_transport_PER_ {E}: TransportPER (itree E).
Proof.
  intros. split. unfold SymmetricH, relationH in *. intros.
  red. apply Symmetric_eqit. red. apply H.
  apply H0.
  intros. unfold TransitiveH, relationH in *. intros.
  red. eapply Transitive_eqit. red. apply H. apply H0. apply H1.
Defined.

#[global]
Instance itree_rel_comp {E} : RelComp (itree E).
Proof.
  red.
  intros until C. unfold eutt in *.
  intros R1 R2 ma mb mc HR1 HR2. intros.
  setoid_rewrite <- compose_rcompose_equiv.
  eapply eqit_trans; eassumption.
Defined.

#[global]
Instance itree_lift_transpose {E} : LiftTranspose (itree E).
Proof.
  intros A B. unfold eq_rel. split.
  + pcofix CIH. intros a b H'.
    pstep. red. punfold H'. red in H'.
    remember (observe a) as x'.
    remember (observe b) as y'.
    generalize dependent a; generalize dependent b.
    induction H'; intros.
    * constructor. intuition.
    * constructor. destruct REL. right.
      eapply CIH. intuition.
      destruct H.
    * constructor. red in REL. intros. unfold id.
      specialize (REL v).
      destruct REL. right. eapply CIH. intuition. intuition.
    * constructor. assumption. intuition.
      eapply IHH'. eassumption.
      reflexivity.
    * constructor. assumption. eapply IHH'. reflexivity.
      eassumption.
  + pcofix CIH. intros a b H'.
    pstep. red. punfold H'. red in H'.
    remember (observe a) as x'.
    remember (observe b) as y'.
    generalize dependent a; generalize dependent b.
    induction H'; intros.
    * constructor. intuition.
    * constructor. destruct REL. right.
      eapply CIH. intuition. intuition.
    * constructor. red in REL. intros. unfold id.
      specialize (REL v).
      destruct REL. right. eapply CIH. intuition.
      intuition.
    * constructor. assumption. eapply IHH'.
      reflexivity. eassumption.
    * constructor. assumption. eapply IHH'.
      eassumption.
      reflexivity.
Defined.

#[global]
Instance itree_eutt_Proper {E}:
  forall A B : Type, Proper (eq_rel (A := A) (B := B) ==> eq_rel) (eutt (E :=E)).
Proof.
  intros A B. unfold eq_rel. split.
  + pcofix CIH. intros a b H'.
    pstep. red. punfold H'. red in H'.
    remember (observe a) as x'.
    remember (observe b) as y'.
    generalize dependent a; generalize dependent b.
    induction H'; intros.
    * constructor. intuition.
    * constructor. destruct REL. right.
      eapply CIH. intuition.
      destruct H. intuition.
    * constructor. red in REL. intros. unfold id.
      specialize (REL v).
      destruct REL. right. eapply CIH. intuition. intuition.
    * constructor. assumption. intuition.
      eapply IHH'. eassumption.
      reflexivity.
    * constructor. assumption. eapply IHH'. reflexivity.
      eassumption.
  + pcofix CIH. intros a b H'.
    pstep. red. punfold H'. red in H'.
    remember (observe a) as x'.
    remember (observe b) as y'.
    generalize dependent a; generalize dependent b.
    induction H'; intros.
    * constructor. intuition.
    * constructor. destruct REL. right.
      eapply CIH. intuition. intuition.
    * constructor. red in REL. intros. unfold id.
      specialize (REL v).
      destruct REL. right. eapply CIH. intuition.
      intuition.
    * constructor. assumption. eapply IHH'. eassumption.
      reflexivity.
    * constructor. assumption. eapply IHH'.
      reflexivity.
      eassumption.
Defined.

#[global]
Instance itree_eutt_Proper_mono {E}:
  forall A B : Type, Proper (subrelationH (A:=A) (B:=B) ==> subrelationH (B:=itree E B)) eutt.
Proof.
  intros A B. do 3 red.
  intros x y. pcofix CIH. pstep. red.
  intros sub a b H.
  do 2 red in H. punfold H. red in H.
  remember (observe a) as a'.
  remember (observe b) as b'.
  generalize dependent a. generalize dependent b.
  induction H; intros; eauto.
  + constructor. red in REL. destruct REL.
    right. apply CIH. assumption. assumption.
    destruct H.
  + constructor. red in REL. intros.
    specialize (REL v). unfold id.
    destruct REL. right. apply CIH. assumption. assumption.
    destruct H.
Qed.

Inductive Returns {E} {A: Type} (a: A) : itree E A -> Prop :=
| ReturnsRet: forall t, t ≈ Ret a -> Returns a t
| ReturnsTau: forall t u, t ≈ Tau u -> Returns a u -> Returns a t
| ReturnsVis: forall {X} (e: E X) (x: X) t k, t ≈ Vis e k -> Returns a (k x) -> Returns a t
.

Global Instance Returns_eutt {E A} a: Proper (eutt eq ==> iff) (@Returns E A a).
Proof.
  repeat intro; split; intros HRet.
  - revert y H. induction HRet; intros.
    constructor; rewrite <- H, H0; reflexivity.
    apply IHHRet, eqit_inv_Tau_l; auto.
    rewrite <- H0. rewrite H. reflexivity.
    econstructor 3; [rewrite <- H0, H; reflexivity | apply IHHRet; reflexivity].
  - revert x H; induction HRet; intros ? EQ.
    constructor; rewrite EQ; eauto.
    apply IHHRet, eqit_inv_Tau_r; auto.
    rewrite EQ. rewrite <- H. reflexivity.
    econstructor 3; [rewrite EQ, H; reflexivity | apply IHHRet; reflexivity].
Defined.

Lemma Returns_Vis_sub :  forall {E} {R} X (e : E X) (k : X -> itree E R) u x, Returns u (k x) -> Returns u (Vis e k).
Proof.
  intros.
  eapply ReturnsVis. reflexivity. apply H.
Qed.

Lemma Returns_ret_inv_ : forall {E} A (a b : A) (t : itree E A), t ≈ (Ret b) -> Returns a t -> a = b.
Proof.
  intros E A a b t eq H.
  revert b eq.
  induction H; intros; subst.
  - rewrite H in eq. apply Eq.eqit_Ret in eq. auto.
  - eapply IHReturns. rewrite tau_eutt in H. rewrite <- H. assumption.
  - rewrite H in eq. symmetry in eq. apply eqit_inv in eq. inv eq.
Qed.

Lemma Returns_ret_inv :  forall {E} A (a b : A), Returns a ((ret b) : itree E A) -> a = b.
Proof.
  intros.
  eapply Returns_ret_inv_. reflexivity. cbn in H. apply H.
Qed.

Lemma eutt_Returns_ : forall {E} {R} (RR : R -> Prop) (ta : itree E R)
    (IN: forall (a : R), Returns a ta -> RR a), eutt (fun u1 u2 => u1 = u2 /\ RR u1) ta ta.
Proof.
  intros E R.
  ginit.
  gcofix CIH; intros.

  setoid_rewrite (itree_eta ta) in IN.

  gstep. red.

  destruct (observe ta).
  - econstructor.  split; auto. apply IN. econstructor. reflexivity.
  - econstructor. gfinal. left. apply CIH. intros. eapply IN. rewrite tau_eutt. assumption.
  - econstructor. intros. red.
    gfinal. left. apply CIH. intros. eapply IN. eapply Returns_Vis_sub. apply H.
Qed.

Lemma eutt_Returns2_ : forall {E} {R' R} (RR : R -> Prop) (RR' : R' -> Prop) (ta : itree E R) (ta' : itree E R') RU
    (IN1: forall (a : R'), Returns a ta' -> RR' a)
    (IN2: forall (a : R), Returns a ta -> RR a),
    eutt RU ta ta' ->
    eutt (fun u1 u2 => RU u1 u2 /\ RR u1 /\ RR' u2) ta ta'.
Proof.
  intros E R.
  ginit.
  gcofix CIH; intros.

  setoid_rewrite (itree_eta ta) in IN2.
  setoid_rewrite (itree_eta ta') in IN1.
  setoid_rewrite (itree_eta ta) in H0.
  setoid_rewrite (itree_eta ta') in H0.

  gstep. red.

  remember (observe ta); remember (observe ta').

  punfold H0. red in H0. cbn in *.
  revert ta ta' Heqi0 Heqi.
  induction H0.
  - econstructor.  split; auto. constructor;
    [apply IN2 | apply IN1]; econstructor; reflexivity.
  - econstructor. gfinal. left. apply CIH. intros.
    eapply IN1. rewrite tau_eutt. assumption.
    intros. eapply IN2. rewrite tau_eutt. assumption.
    pclearbot; eauto.
  - econstructor. intros. red.
    gfinal. left. apply CIH. intros. eapply IN1. eapply Returns_Vis_sub. apply H.
    intros. eapply IN2. eapply Returns_Vis_sub. apply H.
    pclearbot. eauto.
  - econstructor; eauto. eapply IHeqitF; eauto. intros; eapply IN2.
    eapply ReturnsTau; eauto. rewrite <- itree_eta; reflexivity.
  - econstructor; eauto. eapply IHeqitF; eauto. intros; eapply IN1.
    eapply ReturnsTau; eauto. rewrite <- itree_eta; reflexivity.
Qed.

Lemma Returns_impl_image {E A}:
  forall (ma : itree E A) (x y : A), x = y /\ Returns x ma -> image ma x y.
Proof.
  intro.
  intros. destruct H. subst. red.
  induction H0.
  - repeat intro; subst.
    rewrite H in EQR.
    apply eqit_inv_Ret in EQR. auto.
  - eapply eqit_inv_Tau_r in H. repeat intro.
    apply IHReturns. eauto.
    rewrite <- H. auto.
  - repeat intro.
    apply IHReturns. eauto. rewrite H in EQR.
    red in EQR. red in EQR.
    eapply eqit_inv_Vis in EQR. apply EQR.
Qed.

Lemma Returns_eq_rel_image :
  forall E A (ma : itree E A), eq_rel (fun (x y : A) =>  x = y /\ Returns x ma) (fun x y => image ma x y).
Proof.
  intros; split; intros.
  - intro. apply Returns_impl_image.
  - repeat intro. apply H. split. red; intros; intuition; subst; eauto.
    red. intros. destruct H0, H1. subst; split; intuition.
    apply eutt_Returns_. auto.
Qed.

Lemma Returns_mayRet :
  forall E A (ma : itree E A) (a : A),
    a ∈ ma <-> Returns a ma.
Proof.
  intros; split; intros.
  - eapply proj2. Unshelve.
    2 : exact (a = a). pose proof Returns_eq_rel_image.
    unfold eq_rel in H0. specialize (H0 E A ma). destruct H0.
    apply H1. apply H.
  - apply Returns_eq_rel_image. split; auto.
Qed.

Lemma observe_eutt {E A}:
  forall (ma : itree E A) t,
    observe ma = t -> ma ≈ go t.
Proof.
  intros. rewrite itree_eta.
  destruct (observe ma) eqn : Hma.
  all : subst; reflexivity.
Qed.

Lemma observe_eqitree {E A}:
  forall (ma : itree E A) t,
    observe ma = t -> ma ≅ go t.
Proof.
  intros. rewrite itree_eta.
  destruct (observe ma) eqn : Hma.
  all : subst; reflexivity.
Qed.

Lemma eutt_bind_inv {E} :
  forall A B (ma : itree E A) (k k' : A -> itree E B) R,
  bind ma k ≈{R} bind ma k' ->
  forall a, a ∈ ma -> exists a', a' ∈ ma /\ k a ≈{R} k' a'.
Proof.
  intros.
  exists a. split; auto.
  pose proof @eqit_Vis.
  cbn in H.
  rewrite Returns_mayRet in H0.
  induction H0.
  + rewrite <- Eq.bind_ret_l. cbn.
    setoid_rewrite <- Eq.bind_ret_l at 3.
    rewrite <- H0. apply H.
  + eapply eqit_Tau_l in H0.
    setoid_rewrite eutt_Tau in H0.
    apply IHReturns.
    rewrite <- H0. apply H.
  + assert (eutt R (ITree.bind (Vis e k0) k) (ITree.bind (Vis e k0) k')).
    rewrite <- H0. apply H.
    assert (eutt R (Vis e (fun x => ITree.bind (k0 x) k)) (Vis e (fun x => ITree.bind (k0 x) k'))).
    do 2 rewrite <- bind_vis. apply H3.
    repeat red in H4. punfold H4. red in H4. inversion H4. subst.
    dependent destruction H10. red in REL.
    specialize (REL x). destruct REL.
    * eapply IHReturns. apply H5.
    * red in H5. contradiction.
Qed.

Lemma eutt_bind_inv_homog {E} :
  forall A B (ma : itree E A) (k k': A -> itree E B) R,
  bind ma k ≈{R} bind ma k' ->
  forall a, a ∈ ma -> k a ≈{R} k' a.
Proof.
  intros.
  pose proof @eqit_Vis.
  cbn in H.
  rewrite Returns_mayRet in H0.
  induction H0.
  + rewrite <- Eq.bind_ret_l. cbn.
    rewrite <- H0. rewrite H0 in H. rewrite !Eq.bind_ret_l in H.
    rewrite H0. rewrite Eq.bind_ret_l. auto.
  + eapply eqit_Tau_l in H0.
    setoid_rewrite eutt_Tau in H0.
    apply IHReturns.
    rewrite <- H0. apply H.
  + assert (eutt R (ITree.bind (Vis e k0) k) (ITree.bind (Vis e k0) k')).
    rewrite <- H0. apply H.
    assert (eutt R (Vis e (fun x => ITree.bind (k0 x) k)) (Vis e (fun x => ITree.bind (k0 x) k'))).
    do 2 rewrite <- bind_vis. apply H3.
    repeat red in H4. punfold H4. red in H4. inversion H4. subst.
    dependent destruction H10. red in REL.
    specialize (REL x). destruct REL.
    * eapply IHReturns. apply H5.
    * red in H5. contradiction.
Qed.

Lemma mayRet_eq_Refl_ITree2:
  forall E A (ma : itree E A), ma ≈{ fun a1 a2 => a1 = a2 /\ a1 ∈ ma /\ a2 ∈ ma } ma.
Proof.
  intros. eapply itree_eutt_Proper.
  Unshelve.
  3 : exact (fun a1 a2 => a1 = a2 /\ Returns a1 ma /\ Returns a2 ma).
  red. split; repeat intro.
  crunch; eauto. rewrite Returns_mayRet in H0. auto.
  crunch; eauto. rewrite Returns_mayRet in H1. auto.
  crunch; eauto. rewrite <- Returns_mayRet in H0. auto.
  rewrite <- Returns_mayRet in H1. auto.
  apply eutt_Returns2_. all : intros; eauto. reflexivity.
Qed.

Lemma mayRet_eq_Refl_ITree:
  forall E A (ma : itree E A), ma ≈{ fun a1 a2 => a1 = a2 /\ a1 ∈ ma } ma.
Proof.
  intros. eapply itree_eutt_Proper.
  Unshelve.
  3 : exact (fun a1 a2 => a1 = a2 /\ Returns a1 ma).
  red. split; repeat intro.
  crunch; eauto. rewrite Returns_mayRet in H0. auto.
  crunch; eauto. rewrite <- Returns_mayRet in H0. auto.
  apply eutt_Returns_. intros; eauto.
Qed.

Lemma image_ma_Refl_ITree:
  forall E A (ma : itree E A), ma ≈{ image ma } ma.
Proof.
  intros. eapply itree_eutt_Proper_mono.
  Unshelve.
  3 : exact (fun a1 a2 => a1 = a2 /\ Returns a1 ma).
  2 : apply eutt_Returns_; intros; eauto.
  intros x y [-> ?].
  eapply Returns_impl_image. split; auto.
Qed.

Lemma tau_eutt_L:
  forall E A (t t': itree E A), Tau t ≈ t' <-> t ≈ t'.
Proof.
  intros. split; intros.
  - eapply eutt_Tau.
    repeat red; pstep; red.
    eapply EqTauR; auto. punfold H.
  - repeat red; pstep; red.
    eapply EqTauL; auto. punfold H.
Qed.

Lemma tau_eutt_R:
  forall E A (t t': itree E A), t ≈ Tau t' <-> t ≈ t'.
Proof.
  intros. split; intros.
  - eapply eutt_Tau.
    repeat red; pstep; red.
    eapply EqTauL; auto. punfold H.
  - repeat red; pstep; red.
    eapply EqTauR; auto. punfold H.
Qed.

Lemma ret_eutt_L:
  forall E A B (a : A) (mb : itree E B) (R: relationH A B),
    Ret a ≈{ R } mb -> exists (b : B), mb ≈ Ret b /\ R a b.
Proof.
  intros.
  repeat red in H.
  punfold H. red in H.
  remember (Ret a) as tl.
  genobs tl otl.
  genobs mb otr.
  revert Heqotr.
  rewrite Heqtl in Heqotl.
  clear Heqtl. revert Heqotl.
  clear tl. revert mb.
  induction H.
  - intros.
    exists r2. repeat red. split. pstep. red. cbn. rewrite <- Heqotr.
    constructor; auto.
    inversion Heqotl. subst. auto.
  - intros. subst. inversion Heqotl.
  - intros. subst. inversion Heqotl.
  - intros; subst; inversion Heqotl.
  - intros. apply simpobs in Heqotr.
    setoid_rewrite Heqotr.
    assert ((exists b : B, t2 ≈ Ret b /\ R a b) -> exists b: B, Tau t2 ≈ Ret b /\ R a b).
    intro. destruct H0. exists x. destruct H0. split. rewrite H0. repeat red. pstep; red.
    constructor. auto. constructor; reflexivity. auto.
    apply H0. apply IHeqitF; auto.
Qed.

Lemma ret_eutt_R:
  forall E A B (b : B) (ma : itree E A) (R: relationH A B),
    ma ≈{ R } Ret b -> exists (a : A), ma ≈ Ret a /\ R a b.
Proof.
  intros.
  repeat red in H.
  punfold H. red in H.
  remember (Ret b) as tl.
  genobs tl otl.
  genobs ma otr.
  revert Heqotr.
  rewrite Heqtl in Heqotl.
  clear Heqtl. revert Heqotl.
  clear tl. revert ma.
  induction H.
  - intros.
    exists r1. repeat red. split. pstep. red. cbn. rewrite <- Heqotr.
    constructor; auto.
    inversion Heqotl. subst. auto.
  - intros. subst. inversion Heqotl.
  - intros. subst. inversion Heqotl.
  - intros; subst. apply simpobs in Heqotr.
    setoid_rewrite Heqotr.
    setoid_rewrite tau_eutt_L.
    apply IHeqitF; auto.
  - intros; subst; inversion Heqotl.
Qed.

Lemma vis_eutt_L:
  forall E A B X (e : E X) (k : X -> itree E A) (mb : itree E B) (R: relationH A B),
    Vis e k ≈{ R } mb -> exists (k' : X -> itree E B), mb ≈ Vis e k'.
Proof.
  intros.
  repeat red in H.
  punfold H. red in H.
  remember (Vis e k) as tl.
  genobs tl otl.
  genobs mb otr.
  revert Heqotr.
  rewrite Heqtl in Heqotl.
  clear Heqtl. revert Heqotl.
  clear tl. revert mb. revert e k.
  induction H.
  - intros; subst; inversion Heqotl.
  - intros; subst; inversion Heqotl.
  - intros. red in REL. cbn in Heqotl. inversion Heqotl.
    subst. dependent destruction H2. dependent destruction H1.
    exists k2. rewrite Heqotr. rewrite <- itree_eta. reflexivity.
  - intros; subst; inversion Heqotl.
  - intros. apply simpobs in Heqotr.
    setoid_rewrite Heqotr.
    setoid_rewrite tau_eutt_L.
    eapply IHeqitF; eauto.
Qed.

Lemma vis_eutt_R:
  forall E A B X (e : E X) (k : X -> itree E B) (ma : itree E A) (R: relationH A B),
    ma ≈{ R } Vis e k -> exists (k' : X -> itree E A), ma ≈ Vis e k'.
Proof.
  intros.
  repeat red in H.
  punfold H. red in H.
  remember (Vis e k) as tl.
  genobs tl otl.
  genobs ma otr.
  revert Heqotr.
  rewrite Heqtl in Heqotl.
  clear Heqtl. revert Heqotl.
  clear tl. revert ma. revert e k.
  induction H.
  - intros; subst; inversion Heqotl.
  - intros; subst; inversion Heqotl.
  - intros. red in REL. cbn in Heqotl. inversion Heqotl.
    subst. dependent destruction H2. dependent destruction H1.
    exists k1. rewrite Heqotr. rewrite <- itree_eta. reflexivity.
  - intros. apply simpobs in Heqotr.
    setoid_rewrite Heqotr.
    setoid_rewrite tau_eutt_L.
    eapply IHeqitF; eauto.
  - intros; subst; inversion Heqotl.
Qed.

Lemma ret_mayRet : forall E A (x : A), x ∈ ret (m := itree E) x.
Proof.
  repeat intro. eapply eqit_inv_Ret in EQR; auto.
Qed.

Lemma bind_mayRet :
  forall E A (u : A) (ma : itree E A),
    u ∈ ma ->
    forall B (v : B) (k : A -> itree E B),
      v ∈ k u ->
      v ∈ (bind ma k).
Proof.
  intros.
  rewrite Returns_mayRet in H, H0.
  rewrite Returns_mayRet.
  revert k v H0.
  induction H; intros.
  - rewrite H. setoid_rewrite Eq.bind_ret_l.
    eauto.
  - rewrite tau_eutt in H. rewrite H. eapply IHReturns; eauto.
  - rewrite H. setoid_rewrite bind_vis.
    eapply ReturnsVis. reflexivity.
    eapply IHReturns. eauto.
Qed.

#[global]
Instance eqmR_mayRet_l_ITree {E}: MayRetL (itree E).
red.
  intros* EQ a1 IN.
  rewrite Returns_mayRet in IN.
  revert EQ. revert RA ma2.
  induction IN.
  - intros.
    assert (Ret a1 ≈{ RA } ma2). {
      rewrite <- H. auto.
    }
    apply ret_eutt_L in H0. destruct H0.
    exists x. destruct H0. split; auto. repeat intro. rewrite H0 in EQR. apply eqit_inv_Ret in EQR. auto.
  - intros. apply IHIN.
    rewrite tau_eutt_R in H. rewrite <- H. apply EQ.
  - intros.
    assert (Vis e k ≈{ RA } ma2). {
      rewrite <- H. auto.
    } clear EQ H. assert (EQ := H0).
    apply vis_eutt_L in H0. destruct H0.
    assert (Vis e k ≈{RA} Vis e x0).
    rewrite <- H. auto.
    eapply eqit_inv_Vis with (u := x)in H0.
    specialize (IHIN RA (x0 x) H0).
    destruct IHIN as (? & ? & ?).
    exists x1. split; auto. rewrite Returns_mayRet. rewrite H. eapply ReturnsVis.
    reflexivity. rewrite <- Returns_mayRet. eauto.
Defined.

#[global]
Instance eqmR_mayRet_r_ITree {E}: MayRetR (itree E).
Proof.
  red. intros* EQ a2 IN.
  rewrite Returns_mayRet in IN.
  revert EQ. revert RA ma1.
  induction IN.
  - intros.
    assert (ma1 ≈{ RA } Ret a2). {
      rewrite <- H. auto.
    }
    apply ret_eutt_R in H0. destruct H0.
    exists x. destruct H0. split; auto. repeat intro. rewrite H0 in EQR. apply eqit_inv_Ret in EQR.
    auto.
  - intros. apply IHIN.
    rewrite tau_eutt_R in H. rewrite <- H. apply EQ.
  - intros.
    assert (ma1 ≈{ RA } Vis e k). {
      rewrite <- H. auto.
    } clear EQ H. assert (EQ := H0).
    apply vis_eutt_R in H0. destruct H0.
    assert (Vis e x0 ≈{RA} Vis e k).
    rewrite <- H. auto.
    eapply eqit_inv_Vis with (u := x) in H0.
    specialize (IHIN RA (x0 x) H0).
    destruct IHIN as (? & ? & ?).
    exists x1. split; auto. rewrite Returns_mayRet. rewrite H. eapply ReturnsVis.
    reflexivity. rewrite <- Returns_mayRet. eauto.
Defined.

Lemma eutt_prod_rel {E}:
  forall (A B : Type)
    (RA : relationH A A) (RB : relationH B B) (ma : itree E (A * B)),
  eutt RA (fst <$> ma) (fst <$> ma) -> eutt RB (snd <$> ma) (snd <$> ma) -> eutt (prod_rel RA RB) ma ma.
Proof.
  intros until RB.
  einit. ecofix CIH.
  intros * H_fst H_snd.
  rewrite itree_eta.
  genobs ma oma.
  destruct (observe ma) eqn: EQma; subst; intros; pclearbot; simpl.
  - assert (ma ≈ Ret r). {
      repeat red. pstep. red. rewrite EQma. constructor. auto.
    }
    rewrite H in H_fst, H_snd. cbn in *. unfold ITree.map in *.
    rewrite Eq.bind_ret_l in H_fst. rewrite Eq.bind_ret_l in H_snd.
    apply eqit_inv_Ret in H_fst.
    apply eqit_inv_Ret in H_snd.
    destruct r. apply euttG_ret. split; eauto.
  - assert (ma ≈ Tau t). {
      repeat red. pstep. red. rewrite EQma. constructor.
      assert (t ≈ t) by reflexivity.
      left. apply H.
    }
    constructor. gstep. constructor. gfinal. left. eapply CIHL.
    rewrite tau_eutt in H. rewrite <- H. eauto.
    rewrite tau_eutt in H. rewrite <- H. eauto.
  - assert (ma ≈ Vis e k). {
      repeat red. pstep. red. rewrite EQma. constructor.
      intros. red. left.
      assert (k v ≈ k v) by reflexivity.
      apply H.
    }
    clear EQma.
    constructor. gstep. constructor. intros. gfinal. left.
    econstructor. reflexivity. reflexivity. right.
    eapply CIHH.
    rewrite H in H_fst, H_snd. cbn in *. unfold ITree.map in *.
    rewrite bind_vis in H_fst. rewrite bind_vis in H_snd.
    repeat red in H_fst. punfold H_fst. inv H_fst.
    dependent destruction H2.
    dependent destruction H3.
    dependent destruction H4.
    dependent destruction H5.
    red in REL. specialize (REL v). destruct REL.
    punfold H0. inv H0.

    rewrite H in H_fst, H_snd. cbn in *. unfold ITree.map in *.
    rewrite bind_vis in H_snd.
    repeat red in H_snd. punfold H_snd. inv H_snd.
    dependent destruction H2.
    dependent destruction H3.
    dependent destruction H4.
    dependent destruction H5.
    red in REL. specialize (REL v). destruct REL.
    punfold H0. inv H0.

    intros. subst. auto.
    intros. subst. auto.
Qed.

Lemma eutt_prod_rel_homo' {E}:
  forall (A B : Type)
    (RA : relationH A A) (RB : relationH B B)
    (ma ma' : itree E (A * B)),
    ma ≈ ma' ->
    eutt RA (fst <$> ma) (fst <$> ma') ->
    eutt RB (snd <$> ma) (snd <$> ma') ->
    eutt (prod_rel RA RB) ma ma'.
Proof.
  intros. rewrite H in *. apply eutt_prod_rel; auto.
Qed.

#[global]
Instance eqmR_prod_rel_ITree {E} : RelProd (itree E).
Proof.
  intros until RB.
  einit. ecofix CIH.
  intros * EQ EQ'.
  rewrite itree_eta, (itree_eta m2).
  punfold EQ; red in EQ.
  remember (fst <$> m1) eqn: P; remember (fst <$> m2) eqn: P'.
  assert (Q: fst <$> m1 ≅ i) by (subst; reflexivity).
  assert (Q': fst <$> m2 ≅ i0) by (subst; reflexivity).
  clear P P'.
  genobs i ot; genobs i0 os.
  hinduction EQ before CIHH; intros; pclearbot; simpl.
  - symmetry in Heqot; symmetry in Heqos.
    apply observe_eutt in Heqot, Heqos.
    unfold fmap in *. subst. rewrite <- Q in Heqot. rewrite <- Q' in Heqos.
    apply eqit_inv_bind_ret in Heqot, Heqos. crunch.
    rewrite H0, H in EQ'. efinal. rewrite H, H0.
    apply eqit_inv in H1, H2. cbn in *. subst. rewrite! Eq.bind_ret_l in EQ'.
    apply eqit_inv in EQ'. cbn in *. subst. destruct x, x0.
    apply eqit_Ret. constructor; eauto.
  - symmetry in Heqot, Heqos.
    apply observe_eqitree in Heqot, Heqos.
    unfold fmap in Heqot, Heqos.
    rewrite <- Q in Heqot.
    rewrite <- Q' in Heqos.
    apply eqitree_inv_bind_tau in Heqot. crunch.
    2 : { punfold H0. inv H0. inv CHECK. }
    apply eqitree_inv_bind_tau in Heqos. crunch.
    2 : { punfold H2. inv H2. inv CHECK. }
    rewrite H, H1.
    estep; ebase; right; eapply CIHL; eauto.
    rewrite H0, H2. auto.
    rewrite H, H1 in EQ'. rewrite!tau_eutt in EQ'. auto.
  - symmetry in Heqot, Heqos. apply observe_eqitree in Heqot, Heqos.
    rename Heqot into H. rename Heqos into H0.
    rewrite <- Q in H; rewrite <- Q' in H0.
    apply eqitree_inv_bind_vis in H. crunch.
    2 : { punfold H1. inv H1. }
    apply eqitree_inv_bind_vis in H0. crunch.
    2 : { punfold H2. inv H2. }
    rewrite H, H0.
    eapply euttG_vis; ebase; left; apply CIHH; auto.
    unfold fmap. setoid_rewrite H1. setoid_rewrite H2.
    apply REL.
    rewrite H, H0 in EQ'.
    unfold fmap in EQ'. setoid_rewrite bind_vis in EQ'.
    eapply eqit_inv_Vis in EQ'. cbn in *. crunch.
    eauto.
  - subst.
    destruct (observe m1) eqn : Hm1.
    + apply observe_eqitree in Hm1. rewrite Hm1 in EQ'.
      symmetry in Heqot. apply observe_eqitree in Heqot.
      unfold fmap in *. rewrite <- Q in Heqot. rewrite Hm1 in Heqot.
      setoid_rewrite Eq.bind_ret_l in Heqot.
      punfold Heqot. inv Heqot. inv CHECK0.
    + rewrite tau_euttge. rewrite itree_eta. eapply IHEQ; eauto.
      symmetry in Heqot. apply observe_eqitree in Hm1, Heqot.
      unfold fmap in Heqot. rewrite <- Q in Heqot. rewrite Hm1 in Heqot. setoid_rewrite bind_tau in Heqot.
      rewrite <- (tau_eutt t). rewrite <- Hm1. auto.
      apply observe_eqitree in Hm1. symmetry in Heqot.
      apply observe_eqitree in Heqot.
      rewrite Heqot in Q. rewrite Hm1 in Q.
      unfold fmap in Q. setoid_rewrite bind_tau in Q.
      rewrite eqitree_Tau in Q. auto.
    + apply observe_eqitree in Hm1. rewrite Hm1 in EQ'.
      symmetry in Heqot. apply observe_eqitree in Heqot.
      unfold fmap in *. rewrite <- Q in Heqot. rewrite Hm1 in Heqot. setoid_rewrite bind_vis in Heqot.
      punfold Heqot. inv Heqot. inv CHECK0.
  - subst.
    destruct (observe m2) eqn : Hm1.
    + apply observe_eqitree in Hm1. rewrite Hm1 in EQ'.
      symmetry in Heqos. apply observe_eqitree in Heqos.
      unfold fmap in *. rewrite <- Q' in Heqos. rewrite Hm1 in Heqos. setoid_rewrite Eq.bind_ret_l in Heqos.
      punfold Heqos. inv Heqos. inv CHECK0.
    + rewrite tau_euttge. rewrite (itree_eta t). eapply IHEQ; eauto.
      symmetry in Heqos. apply observe_eqitree in Hm1, Heqos.
      unfold fmap in Heqos. rewrite <- Q' in Heqos. rewrite Hm1 in Heqos. setoid_rewrite bind_tau in Heqos.
      rewrite <- (tau_eutt t). rewrite <- Hm1. auto.
      apply observe_eqitree in Hm1. symmetry in Heqos.
      apply observe_eqitree in Heqos.
      rewrite Heqos in Q'. rewrite Hm1 in Q'.
      unfold fmap in Q'. setoid_rewrite bind_tau in Q'.
      rewrite eqitree_Tau in Q'. auto.
    + apply observe_eqitree in Hm1. rewrite Hm1 in EQ'.
      symmetry in Heqos. apply observe_eqitree in Heqos.
      unfold fmap in *. rewrite <- Q' in Heqos. rewrite Hm1 in Heqos. setoid_rewrite bind_vis in Heqos.
      punfold Heqos. inv Heqos. inv CHECK0.
Defined.

#[global]
Instance eqmR_prod_fst_inv_ITree {E}: FmapFst (itree E).
Proof.
  repeat intro. unfold fmap.
  red in H. eapply eutt_clo_bind; eauto.
  intros.
  apply eqit_Ret. destruct u1, u2; inv H0; eauto.
Defined.

#[global]
Instance eqmR_prod_snd_inv_ITree {E}: FmapSnd (itree E).
Proof.
  repeat intro. unfold fmap.
  red in H. eapply eutt_clo_bind; eauto.
  intros.
  apply eqit_Ret. destruct u1, u2; inv H0; eauto.
Defined.

#[global]
Instance eqmR_sum_inl_ITree {E}: FmapInl (itree E).
Proof.
  repeat intro. unfold fmap.
  red in H. eapply eutt_clo_bind; eauto.
  intros.
  apply eqit_Ret. constructor; eauto.
Defined.

#[global]
Instance eqmR_sum_inr_ITree {E}: FmapInr (itree E).
Proof.
  repeat intro. unfold fmap.
  red in H. eapply eutt_clo_bind; eauto.
  intros.
  apply eqit_Ret. constructor; eauto.
Defined.

#[global]
Instance fmap_inv_ITree' {E}: FmapInv_mayRet (itree E).
Proof.
  intros until ma2.
  remember (fun a a' => mayRet_rel (itree E) ma1 ma2 a a' /\ R (f1 a) (f2 a')) as QQ.
  assert ((fun a a' => mayRet_rel (itree E) ma1 ma2 a a' /\ R (f1 a) (f2 a')) ⊑ QQ).
  { subst; eauto. repeat intro; eauto. }
  clear HeqQQ. rename H into HeqQQ.
  revert ma1 ma2 HeqQQ.
  einit. ecofix CIH.
  intros * ? EQ. intros.

  rewrite itree_eta, (itree_eta ma2).
  punfold EQ; red in EQ.
  remember (f1 <$> ma1) eqn: P; remember (f2 <$> ma2) eqn: P'.
  assert (Q: f1 <$> ma1 ≅ i) by (subst; reflexivity).
  assert (Q': f2 <$> ma2 ≅ i0) by (subst; reflexivity).
  clear P P'.
  genobs i ot; genobs i0 os.
  hinduction EQ before CIHH; intros; pclearbot; simpl.
  - symmetry in Heqot; symmetry in Heqos.
    apply observe_eqitree in Heqot, Heqos.
    unfold fmap in *. subst. rewrite <- Q in Heqot. rewrite <- Q' in Heqos.
    apply eqitree_inv_bind_ret in Heqot, Heqos. crunch.
    rewrite H0 in Q. rewrite H in Q'.
    rewrite H0, H.
    efinal. apply eqit_Ret. apply HeqQQ. split. red.
    rewrite!Returns_mayRet. rewrite H0, H.
    split; constructor; reflexivity.
    apply eqit_inv in H1, H2 ; cbn in *. subst; auto.
  - symmetry in Heqot, Heqos.
    apply observe_eqitree in Heqot, Heqos.
    unfold fmap in Heqot, Heqos.
    rewrite <- Q in Heqot.
    rewrite <- Q' in Heqos.
    apply eqitree_inv_bind_tau in Heqot. crunch.
    2 : { punfold H0. inv H0. inv CHECK. }
    apply eqitree_inv_bind_tau in Heqos. crunch.
    2 : { punfold H2. inv H2. inv CHECK. }
    rewrite H, H1.
    estep; ebase. right. eapply CIHL; eauto; cycle 1.
    rewrite H0, H2. auto. subst.
    unfold mayRet_rel. repeat intro.
    apply HeqQQ. crunch; eauto. red.
    rewrite!Returns_mayRet.
    rewrite H, H1. rewrite! tau_eutt.
    rewrite Returns_mayRet in H3, H5.
    auto.
  - symmetry in Heqot, Heqos. apply observe_eqitree in Heqot, Heqos.
    rename Heqot into H. rename Heqos into H0.
    rewrite <- Q in H; rewrite <- Q' in H0.
    apply eqitree_inv_bind_vis in H. crunch.
    2 : { punfold H1. inv H1. }
    apply eqitree_inv_bind_vis in H0. crunch.
    2 : { punfold H2. inv H2. }
    rewrite H, H0.
    eapply euttG_vis; ebase; left; apply CIHH; auto; cycle 1.
    unfold fmap. setoid_rewrite H1. setoid_rewrite H2.
    specialize (REL v). red. apply REL.
    repeat intro; unfold mayRet_rel in *.
    apply HeqQQ.
    crunch; auto.
    apply Returns_mayRet in H3, H5.
    crunch; apply Returns_mayRet; eapply ReturnsVis; eauto; try reflexivity. rewrite H.
    reflexivity.
    apply Returns_mayRet; eapply ReturnsVis; eauto; try reflexivity. rewrite H0.
    reflexivity. apply Returns_mayRet in H5. eauto.
  - subst.
    destruct (observe ma1) eqn : Hma1.
    + apply observe_eqitree in Hma1. rewrite Hma1 in Q.
      symmetry in Heqot. apply observe_eqitree in Heqot.
      unfold fmap in *. rewrite <- Q in Heqot. setoid_rewrite Eq.bind_ret_l in Heqot.
      punfold Heqot. inv Heqot. inv CHECK0.
    + rewrite tau_euttge. rewrite itree_eta. eapply IHEQ; eauto; cycle 1.
      symmetry in Heqot. apply observe_eqitree in Hma1, Heqot.
      unfold fmap in Heqot. rewrite <- Q in Heqot. rewrite Hma1 in Heqot. setoid_rewrite bind_tau in Heqot.
      rewrite eqitree_Tau in Heqot. eauto. repeat intro. eapply HeqQQ.
      unfold mayRet_rel in *. crunch; eauto.
      apply observe_eutt in Hma1. rewrite tau_eutt in Hma1.
      apply Returns_mayRet. rewrite Hma1. rewrite <- Returns_mayRet; auto.
    + apply observe_eqitree in Hma1.
      symmetry in Heqot. apply observe_eqitree in Heqot.
      unfold fmap in *. rewrite <- Q in Heqot. rewrite Hma1 in Heqot.
      setoid_rewrite bind_vis in Heqot.
      punfold Heqot. inv Heqot. inv CHECK0.
  - subst.
    destruct (observe ma2) eqn : Hma1.
    + apply observe_eqitree in Hma1.
      symmetry in Heqos. apply observe_eqitree in Heqos.
      unfold fmap in *. rewrite <- Q' in Heqos. rewrite Hma1 in Heqos. setoid_rewrite Eq.bind_ret_l in Heqos.
      punfold Heqos. inv Heqos. inv CHECK0.
    + rewrite tau_euttge. rewrite (itree_eta t). eapply IHEQ; eauto; cycle 1.
    symmetry in Heqos. apply observe_eqitree in Hma1, Heqos.
    unfold fmap in Heqos. rewrite <- Q' in Heqos.
    rewrite Hma1 in Heqos. setoid_rewrite bind_tau in Heqos.
      rewrite eqitree_Tau in Heqos. eauto. repeat intro. eapply HeqQQ.
      unfold mayRet_rel in *. crunch; eauto.
      apply observe_eutt in Hma1. rewrite tau_eutt in Hma1.
      apply Returns_mayRet. rewrite Hma1. rewrite <- Returns_mayRet; auto.
    + apply observe_eqitree in Hma1.
      symmetry in Heqos. apply observe_eqitree in Heqos.
      unfold fmap in *. rewrite <- Q' in Heqos. rewrite Hma1 in Heqos.
      setoid_rewrite bind_vis in Heqos.
      punfold Heqos. inv Heqos. inv CHECK0.
Defined.

#[global]
Instance eqmR_sum_rel_ITree {E}: RelSum (itree E).
Proof.
  repeat intro; split; intros; [red in H; unfold fmap|].
  - eapply eutt_clo_bind; eauto.
    intros. apply eqit_Ret. destruct u1, u2; try inv H2.
    apply H0; auto. apply H1; auto.
  - specialize (H (A1 + B1)%type (A2 + B2)%type inl inl inr inr (RA ⊕ RB)).
    assert (inl_P: ProperH (respectfulH A1 A2 (A1 + B1) (A2 + B2) RA (RA ⊕ RB)) inl inl) by
      (repeat intro; constructor; auto).
    assert (inr_P: ProperH (respectfulH B1 B2 (A1 + B1) (A2 + B2) RB (RA ⊕ RB)) inr inr) by
      (repeat intro; constructor; auto).
    specialize (H inl_P inr_P).
    apply fmap_inv_ITree' in H. eapply itree_eutt_Proper_mono; eauto.
    repeat intro; crunch; eauto.
    destruct x, y; eauto.
Defined.

#[global]
Lemma eqmR_prod_sum_rel_ITree {E}:
  forall (A B C : Type)
    (RA : relationH A A) (RB : relationH B B) (RC : relationH C C)
    (ma ma' : itree E (C + A * B)%type),
    (fst_sum <$> ma) ≈{ RC ⊕ RA } (fst_sum <$> ma') ->
    (snd_sum <$> ma) ≈{ RC ⊕ RB } (snd_sum <$> ma') -> ma ≈{ RC ⊕ RA ⊗ RB } ma'.
Proof.
  intros until RC.
  einit. ecofix CIH.
  intros * EQ EQ'.
  rewrite itree_eta, (itree_eta ma').
  punfold EQ; red in EQ.
  remember (fst_sum <$> ma) eqn: P; remember (fst_sum <$> ma') eqn: P'.
  assert (Q: fst_sum <$> ma ≅ i) by (subst; reflexivity).
  assert (Q': fst_sum <$> ma' ≅ i0) by (subst; reflexivity).
  clear P P'.
  genobs i ot; genobs i0 os.
  hinduction EQ before CIHH; intros; pclearbot; simpl.
  - symmetry in Heqot; symmetry in Heqos.
    apply observe_eutt in Heqot, Heqos.
    unfold fmap in *. subst. rewrite <- Q in Heqot. rewrite <- Q' in Heqos.
    apply eqit_inv_bind_ret in Heqot, Heqos. crunch.
    rewrite H0, H in EQ'. efinal. rewrite H, H0.
    apply eqit_inv in H1, H2. cbn in *. subst. unfold ITree.map in *. rewrite! Eq.bind_ret_l in EQ'.
    apply eqit_inv in EQ'. cbn in *. subst.
    inv REL. inv EQ'.
    all : unfold fst_sum, snd_sum in *; destruct x0 eqn: Hx0; destruct x eqn: Hx.
    all : repeat match goal with
          | [H : inl _ = _ |- _] => inv H
          | [H : inr _ = _ |- _] => inv H
          end; eauto.
    all : apply eqit_Ret; constructor; eauto.
    inv EQ'.
    destruct p, p0. constructor; eauto.
  - symmetry in Heqot, Heqos.
    apply observe_eqitree in Heqot, Heqos.
    unfold fmap in Heqot, Heqos.
    rewrite <- Q in Heqot.
    rewrite <- Q' in Heqos.
    apply eqitree_inv_bind_tau in Heqot. crunch.
    2 : { punfold H0. inv H0. inv CHECK. }
    apply eqitree_inv_bind_tau in Heqos. crunch.
    2 : { punfold H2. inv H2. inv CHECK. }
    rewrite H, H1.
    estep; ebase; right. eapply CIHL; eauto.
    rewrite H0, H2. auto.
    rewrite H, H1 in EQ'. rewrite!tau_eutt in EQ'. auto.
  - symmetry in Heqot, Heqos. apply observe_eqitree in Heqot, Heqos.
    rename Heqot into H. rename Heqos into H0.
    rewrite <- Q in H; rewrite <- Q' in H0.
    apply eqitree_inv_bind_vis in H. crunch.
    2 : { punfold H1. inv H1. }
    apply eqitree_inv_bind_vis in H0. crunch.
    2 : { punfold H2. inv H2. }
    rewrite H, H0.
    eapply euttG_vis; ebase; left; apply CIHH; auto.
    + unfold fmap. setoid_rewrite H1. setoid_rewrite H2. auto.
      rewrite H, H0 in EQ'.
      unfold fmap in EQ'. setoid_rewrite bind_vis in EQ'.
      eapply eqit_inv_Vis in EQ'. cbn in *. crunch.
      eapply REL.
    + rewrite H, H0 in EQ'. unfold fmap in EQ'. setoid_rewrite bind_vis in EQ'.
      eapply eqit_inv_Vis in EQ'. cbn in *. eauto.
  - subst.
    destruct (observe ma) eqn : Hma.
    + apply observe_eqitree in Hma. rewrite Hma in EQ'.
      symmetry in Heqot. apply observe_eqitree in Heqot.
      unfold fmap in *. rewrite <- Q in Heqot. rewrite Hma in Heqot. setoid_rewrite Eq.bind_ret_l in Heqot.
      punfold Heqot. inv Heqot. inv CHECK0.
    + rewrite tau_euttge. rewrite itree_eta. eapply IHEQ; eauto.
      symmetry in Heqot. apply observe_eqitree in Hma, Heqot.
      unfold fmap in Heqot. rewrite <- Q in Heqot. rewrite Hma in Heqot. setoid_rewrite bind_tau in Heqot.
      rewrite <- (tau_eutt t). rewrite <- Hma. auto.
      apply observe_eqitree in Hma. symmetry in Heqot.
      apply observe_eqitree in Heqot.
      rewrite Heqot in Q. rewrite Hma in Q.
      unfold fmap in Q. setoid_rewrite bind_tau in Q.
      rewrite eqitree_Tau in Q. auto.
    + apply observe_eqitree in Hma. rewrite Hma in EQ'.
      symmetry in Heqot. apply observe_eqitree in Heqot.
      unfold fmap in *. rewrite <- Q in Heqot. rewrite Hma in Heqot. setoid_rewrite bind_vis in Heqot.
      punfold Heqot. inv Heqot. inv CHECK0.
  - subst.
    destruct (observe ma') eqn : Hma.
    + apply observe_eqitree in Hma. rewrite Hma in EQ'.
      symmetry in Heqos. apply observe_eqitree in Heqos.
      unfold fmap in *. rewrite <- Q' in Heqos. rewrite Hma in Heqos. setoid_rewrite Eq.bind_ret_l in Heqos.
      punfold Heqos. inv Heqos. inv CHECK0.
    + rewrite tau_euttge. rewrite (itree_eta t). eapply IHEQ; eauto.
      symmetry in Heqos. apply observe_eqitree in Hma, Heqos.
      unfold fmap in Heqos. rewrite <- Q' in Heqos. rewrite Hma in Heqos. setoid_rewrite bind_tau in Heqos.
      rewrite <- (tau_eutt t). rewrite <- Hma. auto.
      apply observe_eqitree in Hma. symmetry in Heqos.
      apply observe_eqitree in Heqos.
      rewrite Heqos in Q'. rewrite Hma in Q'.
      unfold fmap in Q'. setoid_rewrite bind_tau in Q'.
      rewrite eqitree_Tau in Q'. auto.
    + apply observe_eqitree in Hma. rewrite Hma in EQ'.
      symmetry in Heqos. apply observe_eqitree in Heqos.
      unfold fmap in *. rewrite <- Q' in Heqos. rewrite Hma in Heqos. setoid_rewrite bind_vis in Heqos.
      punfold Heqos. inv Heqos. inv CHECK0.
      Unshelve.
      eauto.
Qed.

Global Instance eqmR_transport_Equiv_itree {E} : TransportEquiv (itree E).
Proof.
  repeat intro. typeclasses eauto.
Qed.

#[global]
Instance transport_refl {E} :TransportReflexive (itree E).
Proof.
  repeat intro. reflexivity.
Qed.
#[global]
Instance transport_symm {E} : TransportSymmetric (itree E).
Proof.
  repeat intro. symmetry; auto.
Qed.
#[global]
Instance transport_trans {E} : TransportTransitive (itree E).
Proof.
  repeat intro. etransitivity; eauto.
Qed.

Global Instance EqmR_OK_ITree {E} : EqmR_OK (itree E).
Proof.
  split; try typeclasses eauto; unfold eqmR, EqmR_ITree.
Defined.

#[global]
Instance eqmR_bind_ProperH_ITree {E}: ProperBind (itree E).
Proof.
  red.
  intros.
  pose proof (H).
  eapply eqmR_rel_comp in H. 2 : typeclasses eauto.
  Unshelve. 3 : exact (fun a1 a2 => a1 = a2 /\ a1 ∈ ma2).
  eapply eutt_clo_bind.
  apply H.
  apply mayRet_eq_Refl_ITree.
  intros. destruct H2 as (? & ? & ?). destruct H3. subst.
  apply H0. auto.
Qed.

#[global]
Instance bind_ret_l_ITree {E}: BindRetL (itree E).
Proof.
  red. intros *. red. setoid_rewrite Eq.bind_ret_l. reflexivity.
Qed.

#[global]
Instance bind_ret_r_ITree {E}: BindRetR (itree E).
Proof.
  red. intros *. red. setoid_rewrite Eq.bind_ret_r. reflexivity.
Qed.

#[global]
Instance bind_bind_ITree {E}: BindBind (itree E).
Proof.
  red. intros *. red. setoid_rewrite Eq.bind_bind. reflexivity.
Qed.

#[global]
Instance eqmR_ret_ITree {E}: RetFinal (itree E).
Proof.
  red. intros *. apply eqit_Ret.
Qed.

Global Instance EqmRMonad_ITree {E} : EqmRMonadLaws (itree E).
Proof.
  split; try typeclasses eauto.
  repeat intro. eapply image_ma_Refl_ITree.
Qed.

#[global]
Instance eqmR_ret_inv_itree {E}: RetInv (itree E).
Proof.
  red; intros; eapply eqit_inv_Ret; eauto. apply H.
Qed.

#[global]
Instance mayRet_bind_inv_itree {E}: MayRetBindInv (itree E).
Proof.
  red.
  intros.
  rewrite Returns_mayRet in H.
  remember (x <- ma;; k x).
  assert (i ≈ x <- ma ;; k x) by (subst; reflexivity). clear Heqi.
  revert ma k H0.
  induction H; intros.
  - rewrite H in H0. symmetry in H0. apply eutt_inv_bind_ret in H0.
    crunch. exists x. rewrite! Returns_mayRet.
    split; [rewrite H0|rewrite H1]; constructor; reflexivity.
  - rewrite H in H1. symmetry in H1. apply eutt_inv_bind_tau in H1; crunch.
    + edestruct IHReturns; cycle 1; eauto.
      rewrite H1.
      rewrite <- H2.
      cbn. rewrite bind_tau. rewrite tau_eutt. reflexivity.
    + edestruct IHReturns; cycle 1; eauto.
      rewrite H1.
      rewrite tau_eutt in H2.
      rewrite <- H2. setoid_rewrite Eq.bind_ret_l. reflexivity.
  - rewrite H in H1. clear H. symmetry in H1. apply eutt_inv_bind_vis in H1; crunch.
    + edestruct IHReturns.
      rewrite <- H1. eapply eutt_clo_bind; intros; subst; try reflexivity. subst. reflexivity.
      crunch; esplit; split; eauto.
      rewrite H. apply Returns_mayRet. eapply ReturnsVis. reflexivity.
      apply Returns_mayRet in H2. eauto.
    + exists x0. split. rewrite H. apply Returns_mayRet. constructor; reflexivity.
      rewrite H1. eapply ReturnsVis in H0. apply Returns_mayRet. eauto. reflexivity.
Defined.

#[global]
Instance fmap_inv_mayRet_itree {E}: FmapInvRet (itree E).
Proof.
  red. intros. unfold fmap in H. eapply eutt_bind_inv_homog in H; eauto.
Defined.

#[global]
Instance eqmR_inv_itree {E}: EqmRInv (itree E).
Proof.
  repeat intro.
  rewrite <- (Eq.bind_ret_r ma) in H.
  eapply @eutt_bind_inv_homog in H; eauto.
  eapply eqit_inv in H; eauto.
Qed.

Global Instance EqmRMonadInverses_ITree {E} : EqmRInversionProperties (itree E).
Proof.
  constructor;try typeclasses eauto.
Defined.

Global Instance EQM_ITree {E} : EQM (itree E) _.
Proof.
  econstructor;typeclasses eauto.
Defined.


(* This file is generated by Why3's Coq 8.4 driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.
Require map.MapInjection.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Inductive array
  (a:Type) {a_WT:WhyType a} :=
  | mk_array : Z -> (@map.Map.map Z _ a a_WT) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a] [a_WT]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(@array a a_WT)): (@map.Map.map
  Z _ a a_WT) := match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(@array a a_WT)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(@array a a_WT)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(@array a a_WT)) (i:Z)
  (v:a): (@array a a_WT) := (mk_array (length a1) (map.Map.set (elts a1) i
  v)).

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a} (n:Z) (v:a): (@array a a_WT) :=
  (mk_array n (map.Map.const v:(@map.Map.map Z _ a a_WT))).

(* Why3 assumption *)
Definition injective (a:(@array Z _)) (n:Z): Prop :=
  (map.MapInjection.injective (elts a) n).

(* Why3 assumption *)
Definition surjective (a:(@array Z _)) (n:Z): Prop :=
  (map.MapInjection.surjective (elts a) n).

(* Why3 assumption *)
Definition range (a:(@array Z _)) (n:Z): Prop := (map.MapInjection.range
  (elts a) n).

(* Why3 goal *)
Theorem WP_parameter_inverting : forall (a:Z) (a1:(@map.Map.map Z _ Z _))
  (b:Z) (n:Z), (((0%Z <= a)%Z /\ (0%Z <= b)%Z) /\ (((n = a) /\ (a = b)) /\
  ((map.MapInjection.injective a1 n) /\ (map.MapInjection.range a1 n)))) ->
  let o := (n - 1%Z)%Z in ((0%Z <= o)%Z -> forall (b1:(@map.Map.map Z _
  Z _)), (forall (j:Z), ((0%Z <= j)%Z /\ (j < (o + 1%Z)%Z)%Z) ->
  ((map.Map.get b1 (map.Map.get a1 j)) = j)) -> ((0%Z <= b)%Z ->
  (map.MapInjection.injective b1 n))).
(* Why3 intros a a1 b n ((h1,h2),((h3,h4),(h5,h6))) o h7 b1 h8 h9. *)
intuition.
intuition.
red; intros.
unfold get; simpl.
assert (MapInjection.surjective a1 n).
apply MapInjection.injective_surjective; assumption.
generalize (H11 i H8); unfold get; simpl; intros (i1, (Hi1,Hi2)).
generalize (H11 j H9); unfold get; simpl; intros (j1, (Hj1,Hj2)).
rewrite <- Hi2.
rewrite <- Hj2.
rewrite H6; try omega.
rewrite H6; try omega.
intro.
apply H10.
subst.
auto.
Qed.


(*** Interface part ***)

Require Import Program
               Util
               rewriting_system
               reduction_languages_facts.
Require Export Subset
               reduction_semantics
               reduction_strategy.

Module Type PRE_REF_SEM <: RED_STRATEGY_LANG.

  Include RED_STRATEGY_LANG.

  Parameter contract : forall {k}, redex k -> option term.

  Definition immediate_subterm t0 t := exists ec, t = ec:[t0].
  Definition subterm_order          := clos_trans_1n term immediate_subterm.
  Definition reduce k t1 t2 :=
      exists {k'} (c : context k k') (r : redex k') t,  dec t1 k (d_red r c) /\
          contract r = Some t /\ t2 = c[t].

  Instance lrws : LABELED_REWRITING_SYSTEM ckind term :=
  { ltransition := reduce }.
  Instance rws : REWRITING_SYSTEM term :=
  { transition := reduce init_ckind }.

  Notation "t1 <| t2"      := (subterm_order t1 t2)      (no associativity, at level 70).

  Axioms
  (redex_trivial1 :                                        forall {k} (r : redex k) ec t,
       ~dead_ckind (k+>ec) -> ec:[t] = r -> exists (v : value (k+>ec)), t = v)
  (wf_immediate_subterm : well_founded immediate_subterm)
  (wf_subterm_order     : well_founded subterm_order).

  Class SafeKRegion (k : ckind) (P : term -> Prop) :=
  {
      preservation :                                                        forall t1 t2,
          P t1  ->  k |~ t1 → t2  ->  P t2;
      progress :                                                               forall t1,
          P t1  ->  (exists (v : value k), t1 = v) \/ (exists t2, k |~ t1 → t2)
  }.

End PRE_REF_SEM.

Module Type PRE_PRECISE_REF_SEM.

  Include PRE_REF_SEM.
  Axiom dead_is_comp : CompPred _ dead_ckind.

End PRE_PRECISE_REF_SEM.

Module Type REF_STRATEGY (PR : PRE_REF_SEM) <: RED_STRATEGY PR.

  Import PR.

  Include RED_STRATEGY PR.

  Axioms
  (wf_search :                                                                forall k t,
       well_founded (search_order k t))

  (search_order_trans :                                           forall k t ec0 ec1 ec2,
       k, t |~ ec0 << ec1 -> k, t |~ ec1 << ec2 -> k,t |~ ec0 << ec2)

  (search_order_comp_if :                                             forall t ec0 ec1 k,
       immediate_ec ec0 t -> immediate_ec ec1 t ->
       ~dead_ckind (k+>ec0) -> ~dead_ckind (k+>ec1) ->
           k, t |~ ec0 << ec1  \/  k, t |~ ec1 << ec0  \/  ec0 = ec1)

  (search_order_comp_fi :                                             forall k t ec0 ec1,
       k, t |~ ec0 << ec1 ->
           immediate_ec ec0 t /\ immediate_ec ec1 t /\
           ~dead_ckind (k+>ec0) /\ ~dead_ckind (k+>ec1)).

End REF_STRATEGY.

Module Type RED_REF_SEM <: RED_SEM.

  Declare Module R  : RED_SEM.
  Declare Module ST : RED_STRATEGY_STEP R.

  Include R.
  Export ST.

  Inductive refocus_in {k1} : forall {k2}, term -> context k1 k2 -> decomp k1 -> Prop :=

  | ri_red  : forall t {k2} (c : context k1 k2) r,
                dec_term t k2 = in_red r ->
                refocus_in t c (d_red r c)
  | ri_val  : forall t {k2} (c : context k1 k2) d v,
                dec_term t k2 = in_val v ->
                refocus_out v c d ->
                refocus_in t c d
  | ri_step : forall t {k2} (c : context k1 k2) d t0 ec,
               dec_term t k2 = in_term t0 ec ->
               refocus_in t0 (ec=:c) d ->
               refocus_in t c d

  with refocus_out {k1} : forall {k2}, value k2 -> context k1 k2 -> decomp k1 -> Prop :=

  | ro_end  : forall (v : value k1),
                ~ dead_ckind k1 ->
                refocus_out v [.] (d_val v)
  | ro_red  : forall ec {k2} (c : context k1 k2) (v : value (k2+>ec)) r,
                dec_context ec k2 v = in_red r ->
                refocus_out v (ec=:c) (d_red r c)
  | ro_val  : forall ec {k2} (c  : context k1 k2) (v : value (k2+>ec)) d v0,
                dec_context ec k2 v = in_val v0 ->
                refocus_out v0 c d ->
                refocus_out v (ec=:c) d
  | ro_step : forall ec {k2} (c : context k1 k2) (v : value (k2+>ec)) d t ec0,
                dec_context ec k2 v = in_term t ec0 ->
                refocus_in t (ec0=:c) d ->
                refocus_out v (ec=:c) d.

  Scheme refocus_in_Ind  := Induction for refocus_in  Sort Prop
    with refocus_out_Ind := Induction for refocus_out Sort Prop.

  Axioms
  (refocus_in_val_eqv_refocus_out :                            forall {k2} (v : value k2)
                                                              {k1} (c : context k1 k2) d,
       refocus_in v c d <-> refocus_out v c d)

  (refocus_in_eqv_dec :                           forall t {k1 k2} (c : context k1 k2) d,
      ~dead_ckind k2 -> (refocus_in t c d <-> dec c[t] k1 d)).

End RED_REF_SEM.

Module Type PRECISE_RED_REF_SEM.

  Include RED_REF_SEM.
  Axiom dead_is_comp : CompPred _ dead_ckind.

End PRECISE_RED_REF_SEM.

Module Type RED_PE_REF_SEM <: RED_REF_SEM.

  Include RED_REF_SEM.
  Import R.

  Axioms
  (dec_context_not_val :                                 forall ec {k} (v1 : value k) v0,
       dec_context ec k v0 <> in_val v1)
  (dec_term_value :                                             forall {k} (v : value k),
       dec_term v k = in_val v).

End RED_PE_REF_SEM.

Module REF_LANG_Help.

  Ltac prove_st_wf :=
      intro t; constructor; induction t;
      (
          intros ? H;
          inversion H as [ec DECT]; subst;
          destruct ec; inversion DECT; subst;
          constructor; auto
      ).

  Context `{term : Set}.
  Context `{immediate_subterm : term -> term -> Prop}.
  Context `{wf_immediate_subterm : well_founded immediate_subterm}.

  Ltac prove_sto_wf :=
      exact (wf_clos_trans_l _ _ wf_immediate_subterm).

  Ltac prove_ec_wf :=
      intros k t ec; destruct k, t, ec; repeat
      (
          constructor;
          intros ec H;
          destruct ec; inversion H; dep_subst; clear H
      ).

End REF_LANG_Help.

(*** Implementation part ***)

Module RedRefSem (PR : PRE_REF_SEM) (ST : REF_STRATEGY PR) <: RED_REF_SEM.

  Module RLF := RED_LANG_Facts PR.
  Import PR RLF.

  Module ST := ST.
  Export ST.

  Module R <: RED_SEM.

    Include PR.

    Lemma decompose :                                                forall (t : term) k,
        ~dead_ckind k -> exists (d : decomp k), dec t k d.

    Proof with unfold dec; eauto using dec_context_next_alive, dec_term_next_alive.
      induction t using (well_founded_ind wf_subterm_order); intros.

      remember (dec_term t k); assert (hh := dec_term_correct t k);
      symmetry in Heqi;
      destruct i; rewrite Heqi in hh.

      - exists (d_red r [.])...

      - destruct (H t0) with (k := k+>e) as [[k2 r c | v] [? Hd]];
            unfold dec in *.
            repeat econstructor...
            eapply dec_term_next_alive...

        + exists (d_red r (c~+(e=:[.]))).
          subst t0; simpl; rewrite plug_compose...

        + { subst t0.
          assert (~dead_ckind (k+>e))...
          clear Heqi; generalize dependent v.
          induction e using (well_founded_ind (wf_search k t)); intros.

          remember (dec_context e _ v); assert (ht := dec_context_correct e _ v);
          destruct i; rewrite <- Heqi in ht; try
          ( compute in hh; rewrite <- hh in ht).

          - exists (d_red r [.])...

          - destruct (H t0) with (k := k+>e0) as [[k2 r c | v0] [? Hd]].
                repeat econstructor...
                eapply dec_context_next_alive...

            + exists (d_red r (c~+e0=:[.])).
              subst t0; simpl; rewrite plug_compose...

            + symmetry in Heqi.
              destruct (dec_context_term_next _ _ _ Heqi) as (H5, _).

              subst t0.
              rewrite <- hh in H5...

          - eexists (d_val v0)...

          - intuition.
          }

      - eexists (d_val v)...

      - intuition.
    Qed.

  End R.

  Include R.

  Inductive refocus_in {k1} : forall {k2}, term -> context k1 k2 -> decomp k1 -> Prop :=

  | ri_red  : forall t {k2} (c : context k1 k2) r,
                dec_term t k2 = in_red r ->
                refocus_in t c (d_red r c)
  | ri_val  : forall t {k2} (c : context k1 k2) d v,
                dec_term t k2 = in_val v ->
                refocus_out v c d ->
                refocus_in t c d
  | ri_step : forall t {k2} (c : context k1 k2) d t0 ec,
               dec_term t k2 = in_term t0 ec ->
               refocus_in t0 (ec=:c) d ->
               refocus_in t c d

  with refocus_out {k1} : forall {k2}, value k2 -> context k1 k2 -> decomp k1 -> Prop :=

  | ro_end  : forall (v : value k1),
                ~ dead_ckind k1 ->
                refocus_out v [.] (d_val v)
  | ro_red  : forall ec {k2} (c : context k1 k2) (v : value (k2+>ec)) r,
                dec_context ec k2 v = in_red r ->
                refocus_out v (ec=:c) (d_red r c)
  | ro_val  : forall ec {k2} (c  : context k1 k2) (v : value (k2+>ec)) d v0,
                dec_context ec k2 v = in_val v0 ->
                refocus_out v0 c d ->
                refocus_out v (ec=:c) d
  | ro_step : forall ec {k2} (c : context k1 k2) (v : value (k2+>ec)) d t ec0,
                dec_context ec k2 v = in_term t ec0 ->
                refocus_in t (ec0=:c) d ->
                refocus_out v (ec=:c) d.

  Scheme refocus_in_Ind  := Induction for refocus_in  Sort Prop
    with refocus_out_Ind := Induction for refocus_out Sort Prop.

  Lemma refocus_in_not_dead :                  forall {t k1 k2} {c : context k1 k2} {d},
      refocus_in t c d -> ~dead_ckind k2.

  Proof.
    intros; intro.
    assert (hh := dec_term_from_dead t k2 H0).
    destruct H;
    solve
    [ rewrite H in hh;
      discriminate hh ].
  Qed.

  Lemma refocus_out_not_dead :                    forall {k1 k2} (c : context k1 k2) v d,
      refocus_out v c d -> ~dead_ckind k2.

  Proof with auto.
    intros; intro.
    destruct H;
    solve
    [ intuition
    | assert (hh := dec_context_from_dead ec k2 v H0);
      rewrite H in hh;
      discriminate hh ].
  Qed.

  Lemma refocus_in_correct :                      forall t {k1 k2} (c : context k1 k2) d,
      refocus_in t c d -> c[t] = d.

  Proof.
    intros t k1 k2 c d.
    induction 1 using refocus_in_Ind with
    (P := fun _ t c d (_ : refocus_in  t c d)     => c[t] = d)
    (P0:= fun _ v c d (_ : refocus_out v c d)  => c[v] = d);

    simpl; auto;
    match goal with
    | _ : dec_term ?t ?k2 = _      |- _ => assert (hh := dec_term_correct t k2)
    | _ : dec_context ?ec _ ?v = _ |- _ => assert (hh := dec_context_correct ec _ v)
    end;
    rewrite e in hh; simpl in *;
    rewrite hh;
    solve [auto].
  Qed.

  Lemma refocus_in_to_out :        forall {k2} (v : value k2) {k1} (c : context k1 k2) d,
      refocus_in v c d -> refocus_out v c d.

  Proof with eauto.
    intros k2 v k1; remember (value_to_term v) as t; revert k2 v Heqt.
    induction t using (well_founded_ind wf_subterm_order); intros; subst.

    dependent destruction H0;
        assert (hh := dec_term_correct (v:term) k2); rewrite H in hh.

    - contradiction (value_redex _ _ hh).

    - rewrite (value_to_term_injective _ _ hh)...

    - destruct (value_trivial v (ec=:[.]) t0); auto;
          try solve [eapply dec_term_next_alive; eassumption];
          subst t0;
          capture_all value @value_to_term.

      clear H; revert x H0 hh.
      induction ec using (well_founded_ind (wf_search k2 (v:term))); intros.

      assert (refocus_out x (ec=:c) d).
      { apply (H1 x)... do 2 econstructor... }

      dependent destruction H2;
          assert (G1 := ccons_inj _ _ _ _ x1 x);
          subst; rec_subst G1;

          assert (gg := dec_context_correct ec k2 x0); rewrite H2 in gg.

      + contradiction (value_redex v r); congruence.

      + assert (v1 = v).
        { apply (value_to_term_injective v1 v); congruence. }
        subst...

      + assert (~ dead_ckind (k2+>ec1)).
        {
            destruct search_order_comp_fi with k2 (v:term) ec1 ec as (?, (?, (?, ?)))...
            - rewrite hh; eapply dec_context_term_next...
        }

        destruct (value_trivial v (ec1=:[.]) t); auto;
            try solve [ simpl; congruence ];
            subst t.
        eapply (H ec1); eauto.
        * rewrite hh; eapply dec_context_term_next; eauto.
        * congruence.
  Qed.

  Lemma refocus_out_to_in :      forall {k2} {v : value k2} {k1} {c : context k1 k2} {d},
      refocus_out v c d -> refocus_in v c d.

  Proof with eauto.
    intros k2 v k1; remember (value_to_term v); revert k2 v Heqt.
    induction t using (well_founded_ind wf_subterm_order); intros; subst.

    remember (dec_term v k2) as i;
    assert (hh := dec_term_correct v k2);
    destruct i; rewrite <- Heqi in hh; symmetry in Heqi.

    - contradict (value_redex _ _ hh).

    - apply (ri_step _ _ _ _ _ Heqi).

      assert (~ dead_ckind (k2+>e)) as Hndk.
      { eapply dec_term_next_alive... }
      destruct (value_trivial v (e=:[.]) t);
          try solve [auto];
          subst t;
          capture_all value @value_to_term.

      clear Heqi; revert e x hh Hndk.
      induction e using (well_founded_ind (wf_search k2 v)); intros.

      apply (H x) with (v := x)...
      { do 2 econstructor... }
      remember (dec_context e _ x) as i.
      assert (gg := dec_context_correct e _ x);
      destruct i; rewrite <- Heqi in gg; subst;
      symmetry in Heqi.

      + contradiction (value_redex v r); congruence.

      + assert (~ dead_ckind (k2+>e0)).
        {
            destruct search_order_comp_fi with k2 v e0 e as (?, (?, (?, ?)))...
            - rewrite hh; eapply dec_context_term_next...
        }

        destruct (value_trivial v (e0=:[.]) t);
            try solve [simpl; congruence];
            subst t.

        apply ro_step with (x0:R.term) e0...
        apply (H1 e0)...
        * rewrite hh; eapply dec_context_term_next...
        * compute; congruence.

      + eapply ro_val...
        assert (v0 = v).
        * apply (value_to_term_injective v0 v); congruence.
        * subst...

      + intuition.

    - assert (H1 := value_to_term_injective _ _ hh); subst;
      econstructor...

    - contradiction (refocus_out_not_dead _ _ _ H0).
  Qed.

  Lemma refocus_in_redex_self_e :                               forall {k} (r : redex k),
      refocus_in r [.] (d_red r [.]).

  Proof with eauto.
    intros;
    remember (dec_term r k).
    assert (~ dead_ckind k).
    { eapply proper_death2... apply [.]. }

    destruct i;
        assert (hh := dec_term_correct r k);
        rewrite <- Heqi in hh;
        simpl in hh; try symmetry in hh.

    - apply redex_to_term_injective in hh; subst; constructor...

    - symmetry in Heqi; assert (H0 := dec_term_term_top _ _ Heqi).
      assert (~ dead_ckind (k+>e)) as Hndk.
      { eapply dec_term_next_alive... }
      econstructor 3...
      destruct (redex_trivial1 r e t Hndk hh) as (v, H1)...

      subst t.
      clear H0 Heqi;
      generalize dependent v; generalize dependent e.
      induction e using (well_founded_ind (wf_search k r)); intros.

      apply refocus_out_to_in.
      remember (dec_context e _ v); assert (ht := dec_context_correct e _ v);
      rewrite <- Heqi in ht; symmetry in Heqi.

      destruct i; simpl in ht.

      + rewrite hh in ht.
        apply redex_to_term_injective in ht; subst.
        constructor...

      + econstructor 4...
        rewrite ht in hh.
        assert (~ dead_ckind (k+>e0)).
        { eapply dec_context_next_alive... }
        destruct (redex_trivial1 r e0 t H1 hh) as (v1, H4)...
        subst t.
        destruct (dec_context_term_next _ _ _ Heqi).
        apply H0...
        * congruence.

      + rewrite ht in hh; contradiction (value_redex _ _ hh).

      + intuition.

    - contradict hh; apply value_redex.

    - intuition.
  Qed.

  Lemma refocus_in_redex_self :      forall {k2} (r : redex k2) {k1} (c : context k1 k2),
      refocus_in r c (d_red r c).

  Proof with eauto.
      intros;
      assert (H := refocus_in_redex_self_e r);
      generalize c.

      (* induction on H *)
      apply refocus_in_Ind with

      (P  := fun k2' t c0 d (_ : refocus_in t c0 d) =>
                 match d with
                 | d_val v      => True
                 | d_red r' c1 => forall (c : context k1 k2),
                                      refocus_in t (c0~+c) (d_red r' (c1~+c))
                 end)
      (P0 := fun k2' v c0 d (_ : refocus_out v c0 d) =>
                 match d with
                 | d_val v      => True
                 | d_red r' c1 => forall (c : context k1 k2),
                                      refocus_out v (c0~+c) (d_red r' (c1~+c))
                 end)
      (r := H);

      intros;
      try destruct d;
      unfold dec in *;
      solve
      [ auto
      | econstructor;   eauto
      | econstructor 3; eauto
      | econstructor 4; eauto ].
  Qed.

  Lemma refocus_in_under_redex :   forall ec t {k} (r : redex k) {k0} (c : context k0 k),
       ec:[t] = r -> ~dead_ckind (k+>ec) -> refocus_in t (ec=:c) (d_red r c).

  Proof.
    intros ec t k r k0 c H H0.
    assert (exists (v : value (k+>ec)), t = v) as [v H1];
              eauto using redex_trivial1.
    subst.
    apply refocus_out_to_in.
    induction ec using (well_founded_ind (wf_search k r)).
    remember (dec_context ec _ v) as D eqn:HeqD; destruct D;
    assert (H2 := dec_context_correct ec _ v);
    rewrite <- HeqD in H2.
    - constructor 2.
      assert (r = r0).
      { apply redex_to_term_injective; congruence. }
      congruence.
    - econstructor 4.
      symmetry; apply HeqD.
      assert (exists (v' : value (k+>e)), t = v') as [v' H3].
      { rewrite H2 in H; eauto using redex_trivial1, dec_context_next_alive. }
      subst.
      apply refocus_out_to_in.
      apply H1.
      + symmetry in HeqD; destruct (dec_context_term_next _ _ _ HeqD) as [H3 _].
        congruence.
      + eauto using dec_context_next_alive.
      + congruence.
    - assert ((v0 : term) = r).
      { compute; congruence. }
      exfalso; eauto using (value_redex v0 r).
    - autof.
  Qed.

  Lemma refocus_in_under_value : forall ec t {k} (v : value k) {k0} (c : context k0 k) d,
      ec:[t] = v -> ~dead_ckind (k+>ec) -> refocus_out v c d -> refocus_in t (ec=:c) d.

  Proof.
    intros ec t k v k0 c d H H0 H1.
    assert (exists (v : value (k+>ec)), t = v) as [v0 H2];
              eauto using value_trivial1.
    subst.
    apply refocus_out_to_in.
    induction ec using (well_founded_ind (wf_search k v)).
    remember (dec_context ec _ v0) as D eqn:HeqD; destruct D;
    assert (H3 := dec_context_correct ec _ v0);
    rewrite <- HeqD in H3.
    - assert ((v : term) = r).
      { compute; congruence. }
      exfalso; eauto using (value_redex v r).
    - econstructor 4.
      + symmetry; apply HeqD.
      + assert (exists (v' : value (k+>e)), t = v') as [v' H4].
        { rewrite H3 in H; eauto using value_trivial1, dec_context_next_alive. }
        subst.
        apply refocus_out_to_in.
        apply H2.
        * symmetry in HeqD; destruct (dec_context_term_next _ _ _ HeqD) as [H4 _].
          congruence.
        * eauto using dec_context_next_alive.
        * congruence.
    - assert (v = v1).
      { apply value_to_term_injective; congruence. }
      subst.
      econstructor 3; eauto.
    - autof.
  Qed.

  Lemma refocus_in_plug :                         forall {k1 k2} (c : context k1 k2) {k3}
                                                              {c0 : context k3 k1} {t d},
      ~dead_ckind k2 -> refocus_in c[t] c0 d -> refocus_in t (c~+c0) d.

  Proof with eauto.
      induction c; intros; simpl.
      - trivial.

      - apply IHc in H0; clear IHc;
        [ | apply (death_propagation2 _ _ H) ].
        inversion H0; dep_subst;
            match goal with H : dec_term ec:[t] k2 = _ |- _ =>
            assert (hh := dec_term_correct (ec:[t]) k2);
            rewrite H in hh
            end.

        + auto using refocus_in_under_redex.

        + eauto using refocus_in_under_value.

        + destruct search_order_comp_if with ec:[t] ec0 ec k2 as [H3 | [H3 | H3]].
              compute...
              compute...
              eapply dec_term_next_alive...
              apply H.

          * contradiction (dec_term_term_top _ _ H2 ec).
          * destruct (elem_context_det _ _ hh _ _ H3) as (v, H4)...
            subst t1.
            {
                clear H2; generalize dependent v; generalize dependent ec0.
                induction ec0 using (well_founded_ind (wf_search k2 ec:[t])); intros.

                assert (H4 := refocus_in_to_out _ _ _ H5).
                dependent destruction H4;
                inversion_ccons x.
                - rewrite hh in H3;
                  contradiction (dec_context_red_bot _ _ _ H2 _ H3).
                - rewrite hh in H3;
                  contradiction (dec_context_val_bot _ _ _ H2 _ H3).
                - assert (ht := dec_context_correct ec0 _ v).
                  rewrite H2 in ht.
                  rewrite <- hh in ht.
                  destruct (dec_context_term_next _ _ _ H2) as (H4', H6).
                  destruct search_order_comp_if with ec:[t] ec2 ec k2 as [H7|[H7|H7]].
                      compute...
                      compute...
                      assert (H7 := search_order_comp_fi _ _ _ _ H4'); intuition.
                      assert (H7 := search_order_comp_fi _ _ _ _ H3); intuition.

                  + contradiction (H6 ec); rewrite <- hh...
                  + destruct (elem_context_det _ _ ht _ _ H7) as (v1, h4)...
                    subst t0.
                    apply H1 with ec2 v1...
                      { congruence. }
                  + subst; assert (H8 := elem_plug_injective1 _ _ _ ht).
                    subst...
            }

          * subst; assert (H8 := elem_plug_injective1 _ _ _ hh).
            subst...
  Qed.

  Lemma refocus_in_plug_rev :                     forall {k1 k2} (c : context k1 k2) {k3}
                                                                (c0 : context k3 k1) t d,
          refocus_in t (c~+c0) d -> refocus_in c[t] c0 d.

  Proof with eauto.
      induction c; intros; simpl.

      - trivial.

      - apply IHc; clear IHc;
            eauto using death_propagation2.

        remember (dec_term ec:[t] k2) as D;
        symmetry in HeqD;
        destruct D;
        assert (DTC2 := dec_term_correct ec:[t] k2);
        rewrite HeqD in DTC2;
        subst.
        + cut (d = d_red r (c~+c0)).
          { intro; subst; constructor; auto. }

          destruct (redex_trivial1 _ _ _ (refocus_in_not_dead H) DTC2) as [v ?]; subst t.
          eapply refocus_in_to_out in H.

          clear HeqD.
          induction ec using (well_founded_ind (wf_search k2 r)).

          dependent destruction H; dep_subst;
          simpl in x; inversion_ccons x;
          assert (DCC := dec_context_correct ec k2 v);
          rewrite H in DCC.
          * assert (r = r0).
            { apply redex_to_term_injective; congruence. }
            subst.
            constructor...
          * assert ((v1 : term) = r).
            { compute; congruence. }
            exfalso; eauto using (value_redex v1 r).
          * assert (H3 := dec_context_next_alive _ _ _ _ _ H).
            destruct (redex_trivial1 r ec1 t) as [v' ?];
                try solve [auto | congruence].
            subst t.
            eapply (H0 ec1);
            try solve
            [ rewrite <- DTC2; destruct (dec_context_term_next _ _ _ H); auto
            | eauto using refocus_in_to_out
            | compute; congruence ].

        + destruct search_order_comp_if with ec:[t] e ec k2 as [H1 | [H1 | H1]].
              compute...
              compute...
              eapply dec_term_next_alive...
              eauto using refocus_in_not_dead.

          * contradict (dec_term_term_top _ _ HeqD _ H1).

          * destruct (elem_context_det _ _ DTC2 _ _ H1) as (v, H2)...
            subst t0.
            econstructor 3; eauto.
            {
              clear HeqD; generalize dependent v; generalize dependent e.
              induction e using (well_founded_ind (wf_search k2 ec:[t])); intros.

              apply refocus_out_to_in.
              remember (dec_context e _ v) as D.
              destruct D;
                  symmetry in HeqD;
                  assert (ht := dec_context_correct e _ v);
                  rewrite HeqD in ht.

              - rewrite DTC2 in H1;
                contradiction (dec_context_red_bot _ _ _ HeqD _ H1).

              - destruct (dec_context_term_next _ _ _ HeqD) as (H3, H4).
                econstructor 4...
                rewrite <- DTC2 in ht.
                destruct search_order_comp_if with ec:[t] e0 ec k2 as [H5 | [H5 | H5]].
                    compute...
                    compute...
                    apply (search_order_comp_fi _ _ _ _ H3).
                    apply (search_order_comp_fi _ _ _ _ H1).

                + rewrite DTC2 in H1;
                  contradiction (H4 ec H1).
                  congruence.
                + destruct (elem_context_det _ _ ht _ _ H5) as (v0, H6)...
                  subst t0.
                  apply H0...
                  { congruence. }
                + subst.
                  assert (H5 := elem_plug_injective1 _ _ _ ht).
                  subst...

              - rewrite DTC2 in H1;
                contradiction (dec_context_val_bot _ _ _ HeqD _ H1).

              - contradict ht.
                eapply search_order_comp_fi...
            }

          * subst.
            assert (H5 := elem_plug_injective1 _ _ _ DTC2).
            subst.
            econstructor 3...

        + cut (refocus_out v (c~+c0) d).
          { intro; econstructor; eauto. }

          destruct (value_trivial1 _ _ _ (refocus_in_not_dead H) DTC2) as [v' ?].
          subst t.
          capture_all value @value_to_term.
          eapply refocus_in_to_out in H.

          clear HeqD.
          induction ec using (well_founded_ind (wf_search k2 v)).

          assert (DCC := dec_context_correct ec k2 v').
          dependent destruction H; simpl in x; inversion_ccons x;
          rewrite H in DCC.
          * exfalso.
            assert ((v : term) = r).
            { congruence. }
            eauto using (value_redex v r).
          * replace v1 with v in * by (apply value_to_term_injective; congruence).
            eauto.
          * destruct (@value_trivial1 _ ec1 t v) as [v'' ?];
                try solve [eauto using dec_context_next_alive | congruence].
            capture_all value @value_to_term.
            subst t.
            apply (H0 ec1) with (v':=v'');
            solve
            [ destruct (dec_context_term_next ec k2 v' H); rewrite <- DTC2; eauto
            | eauto using dec_context_next_alive, refocus_in_to_out
            | congruence ].

        + exfalso;
          eapply refocus_in_not_dead;
          eauto using death_propagation.
  Qed.

  Lemma refocus_in_value_self :                                 forall {k} (v : value k),
      ~ dead_ckind k -> refocus_in v [.] (d_val v).

  Proof with auto.
    intros.
    apply refocus_out_to_in.
    constructor...
  Qed.

  Theorem refocus_in_val_eqv_refocus_out :                forall {k2} (v : value k2) {k1}
                                                                   (c : context k1 k2) d,
       refocus_in v c d <-> refocus_out v c d.

  Proof.
    split; [apply refocus_in_to_out | apply refocus_out_to_in].
  Qed.

  Module DPT := RedDecProcEqvDec R.

  Theorem refocus_in_eqv_dec :                    forall t {k1 k2} (c : context k1 k2) d,
      ~dead_ckind k2 -> (refocus_in t c d <-> dec c[t] k1 d).

  Proof. eauto 6 using DPT.dec_proc_eqv_dec, refocus_in_correct,
                       refocus_in_plug, refocus_in_plug_rev,
                       refocus_in_redex_self, refocus_in_value_self. Qed.

End RedRefSem.

Module PreciseRedRefSem (PR : PRE_PRECISE_REF_SEM) (ST : REF_STRATEGY PR)
                                                                  <: PRECISE_RED_REF_SEM.

  Include RedRefSem PR ST.

  Definition dead_is_comp := PR.dead_is_comp.

End PreciseRedRefSem.


Require Import propInv1.
Require Import verif_cond_5.
Require Import extra5.
Local Open Scope Z.

Theorem t1_5: (startnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1) /\ cond5 ->
 (inv hands1 dryer1 ctrlState2 ctrlTimer2 timer1).

Proof.
intros.
split.
unfold propInv1.
inversion_clear H.
inversion_clear H1.
inversion_clear H2.
inversion_clear H3.
inversion_clear H4.
inversion_clear H5.
intros.
(*analysis of cases i<timer1 and i=timer1*)
elim Zle_lt_or_eq with i timer1.
intros.
apply startnewloop_to_propInv.
assumption.
split.
apply H5.
split.
inversion_clear H0.
auto with zarith.
apply H5.
(*analysis of case i=timer1*)
intros.
rewrite H7 in H5.
(*split startnewloop*)
inversion_clear H0.
inversion_clear H9.
inversion_clear H10.
inversion_clear H11.
inversion_clear H12.
rewrite H10 in H1.
rewrite get_set_same in H1.
inversion_clear H8.
(*split extraInv*)
inversion_clear H14.
inversion_clear H15.
inversion_clear H16.
inversion_clear H17.
inversion_clear H18.
inversion_clear H19.
inversion_clear H20.
inversion_clear H21.
inversion_clear H22.
replace (timer1-1) with timer0 in H1.
apply H23 in H1.
inversion_clear H5.
inversion_clear H24.
inversion_clear H25.
replace dryer1.[of_Z (timer1-1)] with dryer0.[of_Z (timer1-1)] in H24.
elimtype False.
inversion_clear H1.
inversion_clear H27.
inversion_clear H28.
replace (timer1-1) with timer0 in H24.
apply Zcase_sign with ctrlTimer0.
intros.
rewrite H28 in H27.
rewrite Z.sub_0_r in H27.
rewrite H24 in H27.
contradict H27.
discriminate.
intros.
elim H29 with timer0.
intros.
rewrite H31 in H24.
contradict H24.
discriminate.
auto with zarith.
intros.
auto with zarith.
auto with zarith.
apply arr_same_before_upd with dryer0.[of_Z (timer1-1)] timer1.
split.
auto with zarith.
assumption.
auto with zarith.
apply ctrlState_inf.
inversion_clear H5.
inversion_clear H8.
assumption.
apply extra5.
split.
inversion_clear H.
inversion_clear H0.
split.
apply H.
assumption.
apply H.
Qed.


Require Import List.
Require Import ZArith.
Require Import Lia.
Require Import Utils.
Require Import Lattices.
Require Import Instr.
Require Import Semantics.
Require Import AbstractCommon.
Require Import Rules.

Require Coq.Vectors.Vector.

(** Quasi-Abstract Machine.
   Like the abstract machine, but IFC decisions are factored out into
   a separate rule evaluator. *)

Set Implicit Arguments.

Definition run_tmr_type (labelCount : OpCode -> nat) (T : Type) :=
  forall (opcode : OpCode)
         (pclab : T)
         (labs : Vector.t T (labelCount opcode)),
    option (T * T).

(** Count how many argument labels come with this OpCode ? *)
Definition labelCount (c:OpCode) : nat :=
match c with
| OpNoop => 0
| OpAdd  => 2
| OpSub  => 2
| OpPush => 0
| OpPop => 0
| OpLoad => 2
| OpStore => 3
| OpJump => 1
| OpBranchNZ => 1
| OpCall => 1
| OpRet => 1
| OpVRet => 2
| OpOutput => 1
end.

Local Open Scope Z_scope.

(** * Rules of the abstract machine  *)

Section QAMachine.
Context {T: Type}.

(** The [run_tmr opcode pclab labs] should say if an instruction is
allowed to execute on a given combination of PC label ([pclab]) and
argument labels ([labs]). It should return [Some (rpcl, rl)] if
execution is allowed, where [rpcl] is the new PC label and [rl] is a
label for a possible result; otherwise, it should return [None] *)

Variable run_tmr : run_tmr_type labelCount T.

(** Step relation *)
Inductive step_rules : @AS T -> (@Event T)+τ -> @AS T -> Prop :=
| step_nop : forall m i s pcv pcl rpcl rl,
    index_list_Z pcv i = Some Noop ->
    run_tmr OpNoop pcl <||> = Some (rpcl,rl) ->
    step_rules (AState m i s (pcv,pcl)) τ (AState m i s (pcv+1,rpcl))

| step_add: forall m i s pcv pcl rpcl rl x1v x1l x2v x2l,
    index_list_Z pcv i = Some Add ->
    run_tmr OpAdd pcl <|x1l;x2l|> = Some (rpcl,rl) ->
    step_rules (AState m i ((AData (x1v,x1l)::(AData (x2v,x2l))::s)) (pcv,pcl))
               τ
               (AState m i ((AData (x1v+x2v,rl))::s) (pcv+1,rpcl))

| step_sub: forall m i s pcv pcl rpcl rl x1v x1l x2v x2l,
    index_list_Z pcv i = Some Sub ->
    run_tmr OpSub pcl <|x1l;x2l|> = Some (rpcl,rl) ->
    step_rules (AState m i ((AData (x1v,x1l)::(AData (x2v,x2l))::s)) (pcv,pcl))
               τ
               (AState m i ((AData (x1v-x2v,rl))::s) (pcv+1,rpcl))

| step_push: forall m i s pcv pcl rpcl rl cv,
    index_list_Z pcv i = Some (Push cv) ->
    run_tmr OpPush pcl <||> = Some (rpcl,rl) ->
    step_rules (AState m i s (pcv,pcl))
               τ
               (AState m i ((AData (cv,rl))::s) (pcv+1,rpcl))

| step_pop: forall m i s pcv pcl rpcl rl a,
    index_list_Z pcv i = Some Pop ->
    run_tmr OpPop pcl <||> = Some (rpcl,rl) ->
    step_rules (AState m i (AData a :: s) (pcv,pcl))
               τ
               (AState m i s (pcv+1,rpcl))

| step_load: forall m i s pcv pcl addrv addrl xv xl rl rpcl,
    index_list_Z pcv i = Some Load ->
    index_list_Z addrv m = Some (xv,xl) ->
    run_tmr OpLoad pcl <|addrl;xl|> = Some (rpcl,rl) ->
    step_rules (AState m i ((AData (addrv,addrl))::s) (pcv,pcl))
               τ
               (AState m i ((AData (xv, rl))::s) (pcv+1,rpcl))

| step_store: forall m i s pcv pcl addrv addrl xv xl mv ml rl rpcl m',
    index_list_Z pcv i = Some Store ->
    index_list_Z addrv m = Some (mv,ml) ->
    update_list_Z addrv (xv, rl) m = Some m' ->
    run_tmr OpStore pcl <|addrl;xl;ml|> = Some (rpcl,rl) ->
    step_rules (AState m i ((AData (addrv,addrl))::(AData (xv,xl))::s) (pcv,pcl))
               τ
               (AState m' i s (pcv+1,rpcl))

| step_jump: forall m i s pcv pcl pcv' pcl' rl rpcl,
    index_list_Z pcv i = Some Jump ->
    run_tmr OpJump pcl <|pcl'|> = Some (rpcl,rl) ->
    step_rules (AState m i ((AData (pcv',pcl'))::s) (pcv,pcl))
               τ
               (AState m i s (pcv',rpcl))

| step_branchnz_true: forall m i s pcv pcl offv al rl rpcl,
    index_list_Z pcv i = Some (BranchNZ offv) -> (* relative target *)
    run_tmr OpBranchNZ pcl <|al|> = Some (rpcl,rl) ->
    step_rules (AState m i ((AData (0,al))::s) (pcv,pcl))
               τ
               (AState m i s (pcv+1,rpcl))

| step_branchnz_false: forall m i s pcv pcl offv av al rl rpcl,
    index_list_Z pcv i = Some (BranchNZ offv) -> (* relative target *)
    run_tmr OpBranchNZ pcl <|al|> = Some (rpcl,rl) ->
    av <> 0 ->
    step_rules (AState m i ((AData (av,al))::s) (pcv,pcl))
               τ
               (AState m i s (pcv+offv,rpcl))

| step_call: forall m i s pcv pcl pcv' pcl' rl rpcl args a r,
    index_list_Z pcv i = Some (Call a r) ->
    run_tmr OpCall pcl <|pcl'|> = Some (rpcl,rl) ->
    length args = a ->
    (forall a, In a args -> exists d, a = AData d) ->
    step_rules (AState m i ((AData (pcv',pcl'))::args++s) (pcv,pcl))
               τ
               (AState m i (args++(ARet (pcv+1,rl) r)::s) (pcv',rpcl))

| step_ret: forall m i s pcv pcl pcv' pcl' rl rpcl s' ,
    index_list_Z pcv i = Some Ret ->
    pop_to_return s ((ARet (pcv',pcl') false)::s') ->
    run_tmr OpRet pcl <|pcl'|> = Some (rpcl,rl) ->
    step_rules (AState m i s  (pcv,pcl)) τ (AState m i s' (pcv',rpcl))

| step_vret: forall m i s pcv pcl pcv' pcl' rl rpcl resv resl s' ,
    index_list_Z pcv i = Some VRet ->
    pop_to_return s ((ARet (pcv',pcl') true)::s') ->
    run_tmr OpVRet pcl <|resl;pcl'|> = Some (rpcl,rl) ->
    step_rules (AState m i (AData (resv,resl)::s) (pcv,pcl))
               τ (AState m i (AData (resv, rl)::s') (pcv',rpcl))

| step_output: forall m i s pcv pcl rl rpcl xv xl,
    index_list_Z pcv i = Some Output ->
    run_tmr OpOutput pcl <|xl|> = Some (rpcl,rl) ->
    step_rules (AState m i (AData (xv,xl)::s) (pcv,pcl))
               (E (EInt (xv,rl))) (AState m i s (pcv+1,rpcl)).

Definition quasi_abstract_machine :=
  {| state := AS ;
    event := Event ;
    step := step_rules ;
    init_data := list Instr * list (@Atom T) * nat * T;
    init_state := fun id =>
                    let '(p,d,n,def) := id in
                    {| amem := replicate (0%Z, def) n ;
                       aimem := p ;
                       astk := map (fun a => AData a) d;
                       apc := (0%Z, def) |}
  |}.

Lemma step_rules_instr : forall m i s pcv pcl s' e,
  step_rules (AState m i s (pcv,pcl)) e s' ->
  exists instr,
    index_list_Z pcv i = Some instr.
Proof.
  intros.
  inv H ; eauto.
Qed.

End QAMachine.

(** A version of the previous machine specialized for rules given as
symbolic lattice expressions, as defined in [Rules.v] *)

Section IFCQuasiAbstractMachine.

Context {T : Type}
        {Latt : JoinSemiLattice T}.

(** Get the "rule" for a given operation. *)
Variable fetch_rule : forall opcode : OpCode, AllowModify (labelCount opcode).

Definition ifc_run_tmr (opcode: OpCode) (pclab: T) (vlabs:Vector.t T (labelCount opcode)) :  option (T * T) :=
  let r := (fetch_rule opcode) in
  apply_rule r pclab vlabs.

Definition ifc_quasi_abstract_machine :=
  quasi_abstract_machine ifc_run_tmr.

End IFCQuasiAbstractMachine.

(** An instantiation of the Quasi-abstract machine with a particular
    symbolic rule table corresponding to the Abstract machine. *)

Section TINIQuasiAbstractMachine.

Context {T: Type}
        {Latt: JoinSemiLattice T}.

Definition fetch_rule (opcode:OpCode) : (AllowModify (labelCount opcode)) :=
  match opcode with
    | OpNoop => ≪ TRUE , LabPC , __ ≫
    | OpAdd => ≪ TRUE,  LabPC , JOIN Lab1 Lab2 ≫
    | OpSub => ≪ TRUE, LabPC, JOIN Lab1 Lab2 ≫
    | OpPush => ≪ TRUE, LabPC , BOT ≫
    | OpPop => ≪ TRUE, LabPC , BOT ≫
    | OpLoad => ≪ TRUE, LabPC, JOIN Lab1 Lab2 ≫
    | OpStore => ≪ LE (JOIN Lab1 LabPC) Lab3,  (* addr, new value, old value *)
                   LabPC ,
                  JOIN Lab1 (JOIN Lab2 LabPC) ≫
    | OpJump => ≪ TRUE, JOIN Lab1 LabPC , __ ≫
    | OpBranchNZ => ≪ TRUE, JOIN Lab1 LabPC , __ ≫
    | OpCall => ≪ TRUE , JOIN Lab1 LabPC , LabPC ≫
    | OpRet => ≪ TRUE, Lab1 , __ ≫
    | OpVRet => ≪ TRUE, Lab2 , JOIN Lab1 LabPC ≫ (* value, return addr *)
    | OpOutput => ≪ TRUE, LabPC , JOIN Lab1 LabPC ≫ (* output value *)
    end.

Definition tini_quasi_abstract_machine := ifc_quasi_abstract_machine fetch_rule.

Ltac step_tmr :=
  match goal with
    | [ H: ifc_run_tmr _ _ _ _ = _  |- _ ] => inv H
  end.

Lemma step_rules_non_ret_label_pc: forall m i stk pc l s instr e,
  step tini_quasi_abstract_machine (AState m i stk (pc, l)) e s ->
  index_list_Z pc i = Some instr ->
  instr <> Ret ->
  instr <> VRet ->
  exists (l' : T) (pc' : Z), apc s = (pc', l') /\ l <: l' = true.
Proof.
  intros. simpl in H.
  inv H; try step_tmr ; simpl in *; eauto.

  unfold ifc_run_tmr, apply_rule  in H3. simpl in H3.
  unfold Vector.nth_order in H3. simpl in H3.
  set (assert1 := addrl \_/ l <: ml) in *.
  case_eq assert1; intros;
  (unfold assert1 in * );
  (rewrite H in *; simpl in * ) ; allinv.
  eauto.

  congruence.
  congruence.
Qed.

End TINIQuasiAbstractMachine.