Inductive Empty : Prop := .

Inductive paths {A : Type} (a : A) : A -> Type :=
  idpath : paths a a.

Notation "x = y :> A" := (@paths A x y) : type_scope.
Notation "x = y" := (x = y :>_) : type_scope.

Arguments idpath {A a} , [A] a.

Definition idmap {A : Type} : A -> A := fun x => x.

Definition path_sum {A B : Type} (z z' : A + B)
           (pq : match z, z' with
                   | inl z0, inl z'0 => z0 = z'0
                   | inr z0, inr z'0 => z0 = z'0
                   | _, _ => Empty
                 end)
: z = z'.
  destruct z, z', pq; exact idpath.
Defined.

Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
  := match p with idpath => idpath end.

Theorem ex2_8 {A B A' B' : Type} (g : A -> A') (h : B -> B') (x y : A + B)
              (* Fortunately, this unifies properly *)
              (pq : match (x, y) with (inl x', inl y') => x' = y' | (inr x', inr y') => x' = y' | _ => Empty end) :
  let f z := match z with inl z' => inl (g z') | inr z' => inr (h z') end in
  ap f (path_sum x y pq) = path_sum (f x) (f y)
     (* Coq appears to require *ALL* of the annotations *)
     ((match x as x return match (x, y) with
              (inl x', inl y') => x' = y'
            | (inr x', inr y') => x' = y'
            | _ => Empty
          end -> match (f x, f y) with
               | (inl x', inl y') => x' = y'
               | (inr x', inr y') => x' = y'
               | _ => Empty end with
           | inl x' => match y as y return match y with
                                               inl y' => x' = y'
                                             | _ => Empty
                                           end -> match f y with
                                                    | inl y' => g x' = y'
                                                    | _ => Empty end with
                         | inl y' => ap g
                         | inr y' => idmap
                       end
           | inr x' => match y as y return match y return Prop with
                                               inr y' => x' = y'
                                             | _ => Empty
                                           end -> match f y return Prop with
                                                    | inr y' => h x' = y'
                                                    | _ => Empty end with
                         | inl y' => idmap
                         | inr y' => ap h
                       end
       end) pq).
  destruct x; destruct y; destruct pq; reflexivity.
Qed.
(* Toplevel input, characters 1367-1374:
Error:
In environment
A : Type
B : Type
A' : Type
B' : Type
g : A -> A'
h : B -> B'
x : A + B
y : A + B
pq :
match x with
| inl x' => match y with
            | inl y' => x' = y'
            | inr _ => Empty
            end
| inr x' => match y with
            | inl _ => Empty
            | inr y' => x' = y'
            end
end
f :=
fun z : A + B =>
match z with
| inl z' => inl (g z')
| inr z' => inr (h z')
end : A + B -> A' + B'
x' : B
y0 : A + B
y' : B
The term "x' = y'" has type "Type" while it is expected to have type
"Prop" (Universe inconsistency). *)


(*
 * Copyright (c) 2009 Robert Dockins and Aquinas Hobor.
 *
 *)

(* Coq development: using indirection theory to model types in l-calculus *)

Require Import msl.msl_standard.

Require Import lam_ref_tcb.
Require Import lam_ref_mach_defs.
Require Import lam_ref_mach_lemmas.
Require Import lam_ref_type_prelim.
Require Import lam_ref_type_defs.
Require Import lam_ref_type_safety.

Lemma exp_to_val_to_exp : forall v H,
  exp_to_val (val_to_exp v) H = v.
Proof.
  unfold val_to_exp, exp_to_val.
  intros.
  destruct v as [v Hv]; simpl in *.
  destruct v; simpl in *;
    (replace Hv with H by (apply proof_irr); auto).
Qed.

Lemma forces2exprType: forall w v tau,
  forces w v (%tau) ->
  forall v', expr_type (val_to_exp v) tau (w,v').
Proof.
  intros.
  rewrite expr_type_eqn.
  repeat intro.
  split.
  repeat intro.
  simpl in H4.
  assert (stopped b (val_to_exp v)).
  apply values_stopped.
  unfold val_to_exp.
  destruct v; simpl; auto.
  elim H6; eauto.
  repeat intro.
  simpl in H4.
  exists (projT2 v).
  rewrite exp_to_val_to_exp.
  destruct a'.
  destruct H0.
  subst.
  rewrite <- (box_refl_trans extendM) in H; auto.
  assert (forces m v (%tau)).
  apply H.
  split; auto.
  assert (forces (fst a'1) v (%tau)).
  apply pred_nec_hereditary with (m,v).
  rewrite value_knot_necR; split; auto.
  assert (necR (m,v0) a'1).
  apply rt_trans with a'0; auto.
  destruct a'1.
  rewrite value_knot_necR in H6.
  intuition.
  auto.
  apply H6.
Qed.

Lemma exprType_value : forall w e tau m v
  (H:isValue e),
  forces w v (mtype_valid m) ->
  expr_type e tau (w,v) ->
  forces w (exp_to_val e H) (%tau).
Proof.
  intros.
  rewrite expr_type_eqn in H1.
  spec H1 (w,v).
  detach H1.
  spec H1 m.
  spec H1 (w,v) (rt_refl _ age (w,v)) H0.
  destruct H1.
  spec H2 (w,v) (rt_refl _ age (w,v)).
  detach H2.
  destruct H2.
  replace H with x by (apply proof_irr).
  auto.
  simpl; auto.
  apply values_stopped; auto.
  apply R_extends_refl.
Qed.

Lemma expr_type_search_rule : forall (G Q tau sigma:pred world) (f:expr -> expr),
  forall e a,
         closed (f e) ->
         expr_type e tau a ->
         (Q) a ->
         (|>G) a ->
  forall
  (HQ: boxy extendM Q)
  (HG: boxy extendM G)
  (Hstep : forall m m' x y, step (m,x) (m',y) -> step (m,f x) (m',f y))
  (Hredex:
     forall k v e m (H:isValue e),
         closed (f e) ->
         (|>G) (k,v) ->
         Q (k,v) ->
         mtype_valid m (k,v) ->
         (%tau) (k,exp_to_val e H) ->
         expr_type (f e) sigma (k,v))
  (Hsearch:
     forall e a,
         closed (f e) ->
         G a ->
         Q a ->
         expr_type e tau a ->
         expr_type (f e) sigma a),

  expr_type (f e) sigma a.
Proof.
  intros G Q tau sigma f e a Hcl H H0 H1; intros.
  rewrite expr_type_eqn; repeat intro.
  destruct (stopped_dec e b).
  destruct s as [[m' e'] Hst].
  split; repeat intro.
  simpl in H6.
  destruct a'2 as [k v].
  generalize (Hstep _ _ _ _ Hst); intros.
  assert (m' = b0 /\ f e' = b1).
  eapply step_deterministic; eauto.
  destruct H9; subst b0 b1.
  clear H8.
  rewrite expr_type_eqn in H.
  spec H a' H2.
  spec H b a'0 H3 H4.
  destruct H.
  spec H m' e' a'1 H5.
  detach H.
  spec H (k,v) H7.
  destruct H as [w [? ?]].
  exists w; split; auto.
  destruct H9.
  split; auto.
  apply Hsearch; auto.
  change (f e') with (snd (m',f e')).
  eapply closed_step; eauto.
  rewrite <- HG in H1.
  rewrite <- later_commute in H1.
  spec H1 a' H2.
  spec H1 (k,v).
  detach H1.
  rewrite <- HG in H1.
  apply H1; auto.
  simpl; apply Rft_Rt_trans with a'1; auto.
  apply rt_trans with a'0; auto.
  rewrite <- HQ in H0.
  spec H0 a' H2.
  eapply pred_nec_hereditary in H0.
  2: instantiate (1:=(k,v)).
  rewrite <- HQ in H0.
  apply H0; auto.
  apply rt_trans with a'0; auto.
  apply rt_trans with a'1; auto.
  apply Rt_Rft; auto.
  simpl; auto.
  simpl in H6.
  elim H6.
  exists m'; exists (f e').
  apply Hstep; auto.

  rewrite expr_type_eqn in H.
  spec H a' H2.
  spec H b a'0 H3 H4.
  destruct H.
  spec H5 a'0 (rt_refl _ age a'0).
  spec H5.
  simpl; auto.
  destruct H5.
  destruct a'0 as [k v].
  assert (expr_type (f e) sigma (k,v)).
  spec Hredex k v e b x.
  apply Hredex; auto.
  rewrite <- HG in H1.
  rewrite <- later_commute in H1.
  spec H1 a' H2.
  apply pred_nec_hereditary with a'; auto.
  rewrite <- HQ in H0.
  spec H0 a' H2.
  apply pred_nec_hereditary with a'; auto.
  rewrite expr_type_eqn in H6.
  spec H6 (k,v).
  detach H6.
  eapply H6; eauto.
  apply R_extends_refl.
Qed.

Lemma subst_env_valid_closed :  forall env G e a,
  closed' (length G) e ->
  etype_valid env G a ->
  closed (subst_env env e).
Proof.
  intros.
  unfold closed, subst_env.
  change 0 with (0 + 0).
  apply closed_subst_env.
  replace (length env + 0) with (length G); auto.
  revert H0; clear.
  revert env a; induction G; destruct env; simpl; intuition.
  rewrite IHG with env a0; auto.
Qed.

Lemma etype_valid_lookup: forall G x tau w env v,
  nth_error G x = Some tau ->
  etype_valid env G (w,v) ->
  exists v,
    nth_error env x = Some v /\ forces w v (%tau).
Proof.
  induction G; intros.
  destruct x; inversion H.
  destruct x.
  simpl in H.
  inversion H; clear H.
  subst a.
  destruct env.
  inversion H0.
  simpl in H0.
  destruct H0.
  exists v0.
  simpl.
  auto.
  destruct env.
  inversion H0.
  simpl in H0.
  destruct H0.
  simpl in H.
  apply (IHG _ _ _ _ _ H H1).
Qed.

Lemma etype_valid_val : forall G env m v v',
  etype_valid env G (m,v) ->
  etype_valid env G (m,v').
Proof.
  induction G; destruct env; simpl; intuition.
  eapply IHG; eauto.
Qed.

Lemma expr_type_val' : forall tau,
  TT |-- ALL v:value, ALL e:expr, %(expr_type e tau --> with_val v (expr_type e tau)).
Proof.
  intros; apply goedel_loeb.
  hnf; intros.
  intro v.
  destruct H; destruct a.
  clear H.
  rename H0 into H.
  repeat intro.
  destruct a'; simpl.
  destruct H0; subst.
  destruct a'0.
  rewrite value_knot_necR in H1; destruct H1; subst.
  rewrite expr_type_eqn.
  rewrite expr_type_eqn in H2.
  repeat intro.
  destruct a'.
  destruct H3; subst.
  simpl in H3.
  destruct a'0.
  rewrite value_knot_necR in H4; destruct H4; subst.
  spec H2 (m2,v0).
  detach H2.
  spec H2 b0 (m3,v0).
  detach H2.
  spec H2 H5.
  split; destruct H2.
  repeat intro.
  spec H2 b1 b2.
  destruct a'.
  rewrite value_knot_necR in H7; destruct H7; subst.
  destruct a'0.
  simpl in H9.
  rewrite value_knot_laterR in H9; destruct H9; subst.
  spec H2 (m4,v0).
  detach H2.
  detach H2.
  spec H2 (m5,v0).
  detach H2.
  destruct H2 as [w [? ?]].
  destruct w.
  destruct H2.
  subst.
  exists (m6,v).
  split.
  simpl; split; auto.
  destruct H10.
  split.
  auto.
  rewrite box_all in H.
  spec H v.
  rewrite box_all in H.
  spec H b2.
  rewrite <- (box_refl_trans extendM) in H.
  rewrite <- later_commute in H.
  spec H (m0,v1).
  detach H.
  eapply pred_nec_hereditary in H.
  2: instantiate (1:=(m1,v1)).
  rewrite <- (box_refl_trans extendM) in H.
  rewrite <- later_commute in H.
  spec H (m2,v1); detach H.
  spec H (m5,v1).
  detach H.
  spec H (m6,v1).
  detach H.
  spec H (m6,v1) (rt_refl _ age (m6,v1)).
  apply H; auto.
  split; auto.
  simpl.
  rewrite value_knot_laterR; split; auto.
  apply Rft_Rt_trans with m4; auto.
  apply rt_trans with m3; auto.
  split; auto.
  simpl; apply R_extends_refl.
  simpl; apply R_extends_trans.
  rewrite value_knot_necR; split; auto.
  split; auto.
  simpl; apply R_extends_refl.
  simpl; apply R_extends_trans.
  simpl; rewrite value_knot_laterR; split; auto.
  simpl in H8.
  simpl; auto.
  rewrite value_knot_necR; split; auto.

  repeat intro.
  destruct a'; simpl in H8.
  spec H6 (m4,v0).
  detach H6.
  detach H6.
  auto.
  simpl; auto.
  rewrite value_knot_necR; split; auto.
  rewrite value_knot_necR in H7; intuition.
  rewrite value_knot_necR; split; auto.
  split; auto.
Qed.

Lemma expr_type_val : forall e tau k v v',
  expr_type e tau (k,v) ->
  expr_type e tau (k,v').
Proof.
  intros.
  generalize (expr_type_val' tau); intro H0.
  spec H0 (k,v) I v' e.
  spec H0 (k,v) (R_extends_refl (k,v)).
  spec H0 (k,v) (rt_refl _ age (k,v)).
  apply H0; auto.
Qed.

Lemma openValue_valid_value : forall env G a e,
  openValue e ->
  closed' (length G) e ->
  etype_valid env G a ->
  isValue (subst_env env e).
Proof.
  intros env; pattern env.
  apply rev_ind; clear env; simpl; intros.
  destruct G; auto.
  split; auto.
  elim H1.
  rewrite <- (rev_involutive G) in H2.
  case_eq (rev G); intros;
    rewrite H3 in H2; simpl in H2.
  destruct l; inv H2.
  unfold subst_env.
  rewrite subst_env_split.
  simpl.
  assert (etype_valid l (rev l0) a).
  revert H2; clear.
  generalize (rev l0); clear.
  induction l; simpl; intros; auto.
  destruct l; simpl in *; auto.
  destruct H2.
  destruct l; simpl in H0; auto.
  destruct l0; simpl in H2.
  destruct H2.
  destruct l; simpl in H0; auto.
  destruct H2.
  split.
  destruct a; simpl in *.
  auto.
  apply IHl; auto.

  eapply H with (rev l0) a.
  destruct e; simpl in *; auto.
  elim H0.
  replace (length l + 0) with (length l0).
  rewrite rev_length.
  apply subst_closed'.
  replace (S (length l0)) with (length G); auto.
  rewrite <- rev_length.
  rewrite H3; simpl.
  auto.
  rewrite <- (rev_length l0).
  revert H4; generalize (rev l0); clear.
  induction l; intros.
  destruct l; simpl in H4.
  auto.
  elim H4.
  simpl.
  destruct l0; simpl in H4.
  elim H4.
  simpl; f_equal; auto.
  apply IHl; auto.
  destruct H4; auto.
  auto.
Qed.

(** Redex rules **)

Lemma typ_beta: forall v1 v2 sigma tau w,
  forces w v1 (ty_lam sigma tau) ->
  forces w v2 (%sigma) ->
  forall v', expr_type (App (val_to_exp v1) (val_to_exp v2)) tau (w,v').
Proof.
  intros.
  rewrite expr_type_eqn.
  intros z Hz.
  destruct z as [z v].
  destruct Hz as [Hz ?]; subst.
  repeat intro; split; repeat intro.
  simpl in H4; inv H4.
  elim (values_stopped (val_to_exp v1)) with b; eauto.
  apply (projT2 v1).
  elim (values_stopped (val_to_exp v2)) with b; eauto.
  apply (projT2 v2).
  exists a'1; split.
  do 5 red; apply R_extends_refl.
  rewrite exp_to_val_to_exp.
  split.
  apply pred_nec_hereditary with a'; auto.
  apply rt_trans with a'0; auto.
  apply Rt_Rft; auto.
  destruct H as [e [He [Hjst ?]]].
  simpl in Hjst; subst v1.
  inv H9.
  rewrite <- later_commute in H.
  spec H (z,v_Lam e He).
  detach H.
  spec H (fst a'1,v_Lam e He).
  detach H.
  spec H v2 (fst a'1,v_Lam e He).
  spec H (rt_refl _ age (fst a'1,v_Lam e He)).
  detach H.
  destruct a'1; auto.
  revert H.
  apply expr_type_val.
  simpl; auto.
  simpl; intros.
  destruct a'2; destruct H; subst.
  assert (forces (fst a'1) v0 (%sigma)).
  apply pred_nec_hereditary with (z,v0).
  rewrite value_knot_necR; split; auto.
  assert (necR (z,v) a'1).
  apply rt_trans with a'; auto.
  apply rt_trans with a'0; auto.
  apply Rt_Rft; auto.
  destruct a'1.
  rewrite value_knot_necR in H4.
  intuition.
  rewrite <- (box_refl_trans extendM) in H0; auto.
  apply H0.
  split; auto.
  apply H4.
  split; auto.
  simpl; rewrite value_knot_laterR; split; auto.
  assert (laterR (z,v) a'1).
  apply Rft_Rt_trans with a'; auto.
  apply Rft_Rt_trans with a'0; auto.
  destruct a'1.
  rewrite value_knot_laterR in H.
  intuition.
  split; auto.

  exfalso.
  simpl in H4.
  elim H4.
  destruct H as [e [He [? ?]]].
  simpl in H.
  subst v1.
  unfold v_Lam.
  unfold val_to_exp, v_Lam; simpl.
  exists b.
  exists (subst 0 (exp_to_val (projT1 v2) (projT2 v2)) e).
  apply st_App3.
Qed.

Lemma expr_ty_new: forall k v tau,
  forces k v (%tau) ->
  forall v', expr_type (New (val_to_exp v)) (ty_ref tau) (k,v').
Proof.
  intros.
  destruct v; unfold val_to_exp; simpl.
  rewrite expr_type_eqn.
  repeat intro.
  split; repeat intro.

  simpl in H4.
  inv H4.
  assert (stopped b x).
  apply values_stopped; auto.
  elim H4; eauto.
  unfold new in H8.
  destruct b; inv H8.
  destruct a'2.
  case_eq (unsquash m); intros.
  set (f' := fun a => if beq_nat a l then Some tau else f a).
  assert (R_extends (m,v0) (squash (n,f'),v0)).
  split; auto.
  hnf.
  rewrite H4.
  rewrite unsquash_squash.
  split; auto.
  intros.
  assert (mtype_valid (l,v) (m,v0)).
  apply pred_nec_hereditary with a'0; auto.
  apply rt_trans with a'1; auto.
  apply Rt_Rft; auto.
  case_eq (f a); intros; auto.
  right.
  unfold fmap, option_map, compose, f'.
  hnf in H7.
  rewrite H4 in H7.
  case_eq (beq_nat a l); intros.
  apply beq_nat_true in H9.
  subst a.
  spec H7 l.
  cbv beta zeta in H7.
  rewrite H8 in H7.
  destruct H7.
  simpl in H7; omegac.
  cbv beta zeta in H7.
  spec H7 a.
  rewrite H8 in H7.
  simpl.
  rewrite H8.
  generalize H8.
  rewrite (unsquash_approx H4).
  simpl.
  rewrite H8.
  rewrite H9.
  auto.
  assert
    (mtype_valid
        (S l, fun a : nat => if beq_nat a l then exp_to_val x H6 else v a)
        (squash (n,f'),v0)).
  hnf. unfold f'.
  rewrite unsquash_squash.
  intro a.
  simpl fmap. simpl ffun_fmap.
  case_eq (beq_nat a l); intros.
  simpl option_map.
  unfold fidentity_fmap.
  apply beq_nat_true in H8.
  subst a.
  simpl fst.
  split; auto.

  unfold deref; simpl snd.
  case_eq (beq_nat l l); intros.
  replace H6 with i by apply proof_irr.
  rewrite later_commute.
  fold f'.
  unfold forces.
  unfold forces in H.
  cut ((%tau) (squash (n,f'),exp_to_val x i)).
  repeat intro.
  red. rewrite approx_spec.
  split; auto.
  replace (level a'3) with (level a'2).
  apply lt_le_trans with (level (fst (squash (n,f'),exp_to_val x i))).
  simpl in H10.
  destruct a'2.
  rewrite value_knot_laterR in H10.
  simpl.
  apply laterR_level; auto.
  destruct H10; auto.
  rewrite knot_level; simpl.
  rewrite unsquash_squash; auto.
  simpl in H11.
  apply extend_level; auto.
  eapply pred_nec_hereditary in H9.
  2: apply Rt_Rft; apply H10.
  spec H9 a'3 H11.
  apply pred_nec_hereditary with a'3; auto.
  destruct a'.
  assert ((%tau) (m0,exp_to_val x i)).
  rewrite <- box_refl_trans in H; auto.
  apply H.
  split; auto.
  destruct H0; auto.
  assert ((%tau) (m,exp_to_val x i)).
  apply pred_nec_hereditary with (m0,exp_to_val x i).
  rewrite value_knot_necR; split; auto.
  assert (necR (m0,v1) (m,v0)).
  apply rt_trans with a'0; auto.
  apply rt_trans with a'1; auto.
  apply Rt_Rft; auto.
  rewrite value_knot_necR in H10.
  destruct H10; auto.
  auto.
  rewrite <- box_refl_trans in H10; auto.
  apply H10; auto.
  split; auto.
  destruct H7; auto.
  apply beq_nat_false in H8; elim H8; auto.
  case_eq (f a); intros.
  assert (mtype_valid (l,v) (m,v0)).
  apply pred_nec_hereditary with a'0; auto.
  apply rt_trans with a'1; auto.
  apply Rt_Rft; auto.
  hnf in H10.
  rewrite H4 in H10.
  cbv beta zeta in H10.
  spec H10 a.
  rewrite H9 in H10.
  destruct H10.
  simpl in H10.
  split.
  simpl; omega.
  simpl deref.
  rewrite H8.
  unfold deref in H11.
  simpl snd in H11.
  rewrite <- box_refl_trans in H11; auto.
  fold f'.
  spec H11 (squash (n,f'),v a).
  spec H11.
  split; auto.
  destruct H7; auto.
  repeat intro.
  unfold fidentity_fmap. red. rewrite approx_spec.
  split.
  apply lt_le_trans with (level a'2).
  apply laterR_level; auto.
  destruct a'2; destruct H12; subst.
  simpl.
  rewrite knot_level.
  hnf in H12.
  rewrite unsquash_squash in H12.
  case_eq (unsquash m0); intros.
  rewrite H14 in H12; auto.
  destruct H12; simpl; subst; auto.
  eapply H11; eauto.
  simpl.
  assert (mtype_valid (l,v) (m,v0)).
  apply pred_nec_hereditary with a'0; auto.
  apply rt_trans with a'1; auto.
  apply Rt_Rft; auto.
  hnf in H10.
  rewrite H4 in H10.
  spec H10 a.
  cbv beta zeta in H10.
  rewrite H9 in H10.
  simpl in H10.
  apply beq_nat_false in H8.
  omega.

  exists (squash (n,f'),v0).
  split; auto.
  split; auto.
  change (Loc l) with (val_to_exp (v_Loc l)).
  apply forces2exprType.
  rewrite ty_ref_extends.
  exists l; split.
  simpl; auto.
  simpl.
  rewrite unsquash_squash.
  unfold f'. simpl.
  case_eq (beq_nat l l); simpl; intros.
  hnf.
  unfold fidentity_fmap.
  change (approx n (approx n tau)) with ((approx n oo approx n) tau).
  rewrite <- (approx_approx1 0).
  auto.
  apply beq_nat_false in H9; elim H9; auto.

  simpl in H4.
  elim H4.
  case_eq (new b (exp_to_val x i)); intros.
  exists m; exists (Loc a).
  apply st_New2 with i; auto.
Qed.

Lemma expr_type_upd_Update: forall tau sigma w l v e3 v0,
  forces w (v_Loc l) (ty_ref tau) ->
  forces w v (%tau) ->
  expr_type e3 sigma (w,v0) ->
  expr_type (Update (Loc l) (val_to_exp v) e3) sigma (w,v0).
Proof.
  intros.
  rewrite expr_type_eqn; repeat intro.
  split; repeat intro.
  simpl in H6.
  inv H6.
  inv H9.
  assert (stopped b (val_to_exp v)).
  apply values_stopped.
  destruct v; auto.
  elim H6; eauto.
  exists a'2.
  split.
  simpl; apply R_extends_refl.
  split; auto.
  eapply pred_nec_hereditary in H4.
  2: instantiate (1:=a'2).
  2: apply rt_trans with a'1; auto.
  2: apply Rt_Rft; auto.
  destruct a'2.
  simpl in H4.
  simpl.
  case_eq (unsquash m); intros.
  rewrite H6 in H4.
  spec H4 a.
  revert H4.
  generalize (refl_equal (f a)).
  case_eq (f a); intros.
  rewrite exp_to_val_to_exp.
  unfold update.
  destruct b.
  simpl.
  simpl in H9.
  destruct H9; split; auto.
  case_eq (beq_nat l a); intro; auto.
  apply beq_nat_true in H11; subst a.
  hnf in H.
  destruct H.
  destruct H.
  simpl in H; inv H.
  cut (type_at x tau (m,v_Loc x)).
  intro.
  simpl in H.
  rewrite H6 in H.
  rewrite H4 in H.
  cut ((%tau) (m,v)); intros.
  spec H12 a'2 H13.
  eapply pred_nec_hereditary in H12.
  2: apply rt_trans with a'3; auto.
  2: apply Rt_Rft; auto.
  cut (approx n tau a'3).
  hnf in H.
  rewrite <- H.
  intros.
  red in H15. rewrite approx_spec in H15.
  destruct H15; auto.
  red. rewrite approx_spec.
  split; auto.
  apply lt_le_trans with (level a'2).
  apply laterR_level.
  apply Rt_Rft_trans with a'3; auto.
  destruct a'2.
  destruct H13; subst.
  simpl.
  rewrite knot_level.
  case_eq (unsquash m0); intros.
  hnf in H13.
  rewrite H6 in H13.
  rewrite H15 in H13.
  destruct H13; subst; simpl; auto.
  red in H0.
  assert ((%tau) (fst a',v)).
  rewrite <- box_refl_trans in H0; auto.
  spec H0 (fst a',v).
  spec H0.
  split; auto.
  destruct a'; destruct H2; auto.
  auto.
  apply pred_nec_hereditary with (fst a', v); auto.
  rewrite value_knot_necR; split; auto.
  assert (necR a' (m,v1)).
  apply rt_trans with a'0; auto.
  apply rt_trans with a'1; auto.
  apply Rt_Rft; auto.
  destruct a'.
  rewrite value_knot_necR in H13.
  simpl; destruct H13; auto.
  rewrite <- type_at_extends in H11.
  spec H11 (fst a', v_Loc x).
  spec H11.
  split; auto.
  destruct a'; destruct H2; auto.
  eapply pred_nec_hereditary.
  2: apply H11.
  rewrite value_knot_necR; split; auto.
  assert (necR a' (m,v1)).
  apply rt_trans with a'0; auto.
  apply rt_trans with a'1; auto.
  apply Rt_Rft; auto.
  destruct a'.
  rewrite value_knot_necR in H.
  destruct H; simpl; auto.
  unfold update; destruct b; simpl; auto.
  rewrite <- expr_type_extends in H1.
  spec H1 a' H2.
  eapply pred_nec_hereditary.
  2: apply H1.
  apply rt_trans with a'; auto.
  apply rt_trans with a'0; auto.
  apply rt_trans with a'1; auto.
  apply Rt_Rft; auto.
  simpl in H6.
  elim H6.
  exists (update b l v).
  exists e3.
  destruct v.
  apply st_Upd3 with i; auto.
Qed.

Lemma expr_ty_deref_loc : forall l tau a,
  expr_type (Loc l) (ty_ref tau) a ->
  expr_type (Deref (Loc l)) tau a.
Proof.
  intros.
  rewrite expr_type_eqn; repeat intro.
  split; repeat intro.
  simpl in H4.
  inv H4.
  inv H7.
  exists a'2.
  split.
  simpl; apply R_extends_refl.
  split.
  apply pred_nec_hereditary with a'0; auto.
  apply rt_trans with a'1; auto.
  apply Rt_Rft; auto.
  rewrite <- expr_type_extends in H.
  spec H a' H0.
  eapply pred_nec_hereditary in H.
  2: instantiate (1:=a'1).
  2: apply rt_trans with a'0; auto.
  assert (forces (fst a'1) (exp_to_val (Loc l) (isvLoc l)) (%(ty_ref tau))).
  destruct a'1.
  eapply exprType_value.
  2: apply H.
  unfold fst.
  red.
  apply pred_nec_hereditary with a'0; auto.
  apply H2.
  rewrite ty_ref_extends in H4.
  destruct a'1.
  destruct H4 as [l' [? ?]].
  simpl in H4; inv H4.
  simpl fst in H6.
  assert (mtype_valid b0 (m,v)).
  apply pred_nec_hereditary with a'0; auto.
  simpl in H6.
  hnf in H4.
  cbv beta zeta in H4.
  case_eq (unsquash m); intros;
    rewrite H7 in H4, H6.
  spec H4 l'.
  case_eq (f l'); intros.
  rewrite H8 in H4, H6.
  destruct H4.
  destruct a'2.
  eapply forces2exprType.
  rewrite later_commute in H9.
  spec H9 (m0,deref b0 l').
  detach H9.
  repeat intro.
  spec H9 a'1 H10.
  cut (approx n p a'1); intros.
  hnf in H6.
  rewrite H6 in H11.
  red in H11. rewrite approx_spec in H11.
  destruct H11; auto.
  red. rewrite approx_spec.
  split; auto.
  change (level a'1 < n).
  apply le_lt_trans with (level (m0,v0)).
  destruct a'1; destruct H10.
  simpl.
  hnf in H10.
  repeat rewrite knot_level.
  destruct (unsquash m0); destruct (unsquash m1).
  destruct H10; subst; auto.
  apply lt_le_trans with (level (m,v)).
  apply laterR_level; auto.
  simpl.
  rewrite knot_level.
  rewrite H7; simpl; auto.
  simpl in H5; rewrite value_knot_laterR in H5.
  destruct H5; subst.

  simpl; rewrite value_knot_laterR; split; auto.
  rewrite H8 in H6, H4.
  elim H6.
  simpl in H4.
  elim H4.
  exists b.
  exists (val_to_exp (deref b l)).
  apply st_Deref2; auto.
Qed.


Require Import Cosa.Lib.Header.
Require Import Cosa.Abstract.Valuation.
Require Import Cosa.Nominal.Set.
Require Import Cosa.Nominal.CompcertInstances.
Require Import Coq.Classes.EquivDec.
Require Cminor.

(** An abstract notion of expression. The type [expr] is a variant of
    [Cminor.expr] where the variables are taken to be at an arbitrary
    type rather than a type of identifier. They will be instantiated
    with [Graph.node]. Most of the evaluation relation is reused from
    [Cminor].*)

Section Expr.

  Context {var:Type} {nominal_var:Action var}.

  Inductive expr :=
  | Avar : var -> expr
  | Aconst : Cminor.constant -> expr
  | Aunop : Cminor.unary_operation -> expr -> expr
  | Abinop : Cminor.binary_operation -> expr -> expr -> expr
  | Aload : AST.memory_chunk -> expr -> expr
  .

  Global Program Instance action_expr : Action expr := {|
    act π := (fix act e :=
      match e return _ with
      | Avar v => Avar (π·v)
      | Aconst c => Aconst c
      | Aunop op e => Aunop op (act e)
      | Abinop op e₁ e₂ => Abinop op (act e₁) (act e₂)
      | Aload c e => Aload c (act e)
      end)
  |}.
  Next Obligation.
    autounfold.
    intros π₁ π₂ hπ e e' <-.
    induction e; (congruence||now rewrite hπ).
  Qed.
  Next Obligation.
    (* [x] should not have been introduced *)
    revert x.
    (* / *)
    intros e.
    induction e; (congruence||now rewrite act_id).
  Qed.
  Next Obligation.
    (* [x] should not have been introduced *)
    revert x.
    (* / *)
    intros e.
    induction e; (congruence||now rewrite act_comp).
  Qed.

  (** Evaluation is parametrised by an environment for the
      variables. And a read relation for loads.

      [reads chunk vaddr v] holds if reading chunk [chunk] at the
      memory address corresponding to value [vaddr] yields [v]. *)
  (* spiwack: I use a function [var->Values.val] as my environment
     because it's what is useful for abstract interpretation. However,
     we could use a relation [var->Values.val->Prop] and hence be
     more compatible with [Cminor]'s expressions. *)
  Variable (env:var -> Values.val)
           (reads:AST.memory_chunk -> Values.val -> Values.val->Prop).

  Inductive eval_expr : expr -> Values.val -> Prop :=
  | eval_Avar : forall α, eval_expr (Avar α) (env α)
  | eval_Aconst : forall cst v sp (ge:Cminor.genv),
             Cminor.eval_constant ge sp cst = Some v ->
             eval_expr (Aconst cst) v
    (** For the moment, we ignore Oaddrsymbol (which calls to the
        global environment) and Oaddrstack (which points to the top of
        the local stack-frame). *)
  | eval_Aunop : forall op a1 v1 v,
      eval_expr a1 v1 ->
      Cminor.eval_unop op v1 = Some v ->
      eval_expr (Aunop op a1) v
  | eval_Abinop: forall op a1 a2 v1 v2 v m,
      eval_expr a1 v1 ->
      eval_expr a2 v2 ->
      Cminor.eval_binop op v1 v2 m = Some v ->
      eval_expr (Abinop op a1 a2) v
    (** For the moment, we ignore unsigned comparison of pointers, which requires
        some access to memory. *)
  | eval_Aload: forall chunk addr vaddr v,
      eval_expr addr vaddr ->
      reads chunk vaddr v ->
      eval_expr (Aload chunk addr) v
  .

End Expr.

Arguments expr var : clear implicits.

Ltac apply_hyps :=
  repeat match goal with
  | H:_|-_ => eapply H
  end
.

Ltac equivariant_eval_expr_tac :=
  simpl; intros h; inversion_clear h; econstructor; apply_hyps
.

Lemma equivariant_eval_expr var `(Action var) : Equivariant (@eval_expr var).
Proof.
  apply equivariant_alt₄.
  intros π env read e v.
  assert ( forall π env read e v,  eval_expr (π · env) (π · read) (π · e) (π · v) -> eval_expr env read e v ) as h.
  { clear. intros π env read e.
    induction e; intros ?; [|equivariant_eval_expr_tac..].
    intros h; inversion h. simpl in *. simplify_act. subst.
    econstructor. }
  apply prop_extensionality.
  split.
  + apply h.
  + intros r.
    apply (h (op_p π)). simplify_act.
    exact r.
Qed.
(* Hint EResolve equivariant_eval_expr : equivariant. *)
Hint Extern 0 (Equivariant eval_expr) => eapply equivariant_eval_expr : equivariant.

Lemma eval_expr_increasing var (env:var->Values.val) :
  forall (reads₁ reads₂:_->_->_->Prop),
  (forall chunk vaddr v, reads₁ chunk vaddr v -> reads₂ chunk vaddr v) ->
  forall e v, eval_expr env reads₁ e v -> eval_expr env reads₂ e v.
Proof.
  intros * h *.
  induction 1; try (econstructor (solve[eauto])).
Qed.

(** Evaluation of pure expressions: ignores [Aload] expressions. *)
Definition eval_pure_expr {var} env e v :=
  eval_expr (var:=var) env (fun _ _ _ => True) e v
.

Lemma equivariant_eval_pure_expr var `(Action var) :
  Equivariant (@eval_pure_expr var).
Proof.
  unfold eval_pure_expr.
  combinatorize.
  narrow_equivariant.
  + easy.
Qed.
(* Hint EResolve equivariant_eval_pure_expr : equivariant. *)
Hint Extern 0 (Equivariant eval_pure_expr) => eapply equivariant_eval_pure_expr : equivariant.

(** Pure expressions as assertions. *)
Definition check_pure_expr {var} env e b :=
  eval_pure_expr (var:=var) env e (Values.Val.of_bool b)
.

Lemma equivariant_check_pure_expr var `(Action var) :
  Equivariant (@check_pure_expr var).
Proof.
  unfold check_pure_expr.
  combinatorize.
  narrow_equivariant.
  + easy.
Qed.
(* Hint EResolve equivariant_check_pure_expr : equivariant. *)
Hint Extern 0 (Equivariant check_pure_expr) => eapply equivariant_check_pure_expr : equivariant.

Definition valid_pure_expr {var} env e b :=
  check_pure_expr (var:=var) env e b /\ ~(check_pure_expr env e (negb b))
.

Lemma equivariant_valid_pure_expr var `(Action var) :
  Equivariant (@valid_pure_expr var).
Proof.
  unfold valid_pure_expr.
  combinatorize.
  Time narrow_equivariant; easy.
Qed.
(* Hint EResolve equivariant_valid_pure_expr : equivariant. *)
Hint Extern 0 (Equivariant valid_pure_expr) => eapply equivariant_valid_pure_expr : equivariant.

(** Substitution. *)
Fixpoint subs {A B} (φ:A->B) (e:expr A) : expr B :=
  match e with
  | Avar v => Avar (φ v)
  | Aconst c => Aconst c
  | Aunop op e => Aunop op (subs φ e)
  | Abinop op e₁ e₂ => Abinop op (subs φ e₁) (subs φ e₂)
  | Aload chunk e => Aload chunk (subs φ e)
  end
.

Fixpoint collect {F} (a:Applicative F) {A} (e:expr (F A)) : F (expr A) :=
  match e with
  | Avar v => a.(map) Avar v
  | Aconst c => pure a (Aconst c)
  | Aunop op e => a.(map) (Aunop op) (collect a e)
  | Abinop op e₁ e₂ => map2 a (Abinop op) (collect a e₁) (collect a e₂)
  | Aload chunk e => a.(map) (Aload chunk) (collect a e)
  end
.

(** Partial renaming. *)
Definition rename {A B} (φ:A->option B) (e:expr A) : option (expr B) :=
  collect Option (subs φ e)
.
(* arnaud: not needed?
(* arnaud: belongs_to_expr can actually be defined in term of [collect], using
   the writer applicative and a list. *)
Fixpoint belongs_to_expr {A} (e:expr A) (x:A) : Prop :=
  match e with
  | Avar v => x=v
  | Aconst _ => False
  | Aunop _ e => belongs_to_expr e x
  | Abinop _ e₁ e₂ => belongs_to_expr e₁ x \/ belongs_to_expr e₂ x
  | Aload _ e => belongs_to_expr e x
  end
.

Lemma value_not_fixed_eval_pure_expr A {_:EqDec A eq} (e:expr A) v :
  central (belongs_to_expr e)
          (fun ρ => eval_pure_expr ρ e v).
Proof.
  unfold central; revert v.
  induction e as [ x | c | op e he | op e₁ he₁ e₂ he₂ | chunk e he ]; simpl.
  - intros ** ν h.
    inversion h; subst; clear h.
    assert (ν x = swap α β ν x) as ->.
    { unfold swap.
      rewrite !if_eq_neq; congruence. }
    constructor.
  - intros ** h.
    inversion h; subst; clear h.
    econstructor; eauto.
  - intros ** h.
    inversion h; subst; clear h.
    econstructor; eauto.
    now apply he.
  - intros v α β hα hβ ** h.
    inversion h; subst; clear h.
    econstructor; eauto; [apply he₁|apply he₂]; solve[easy|clear -hα hβ; firstorder].
  - intros ** h.
    inversion h; subst; clear h.
    econstructor; eauto.
    eapply he; eauto.
Qed.

Lemma value_not_fixed_check_pure_expr A {_:EqDec A eq} (e:expr A) b :
  central (belongs_to_expr e)
          (fun ρ => check_pure_expr ρ e b).
Proof.
  apply value_not_fixed_eval_pure_expr.
Qed.

Lemma value_not_fixed_valid_pure_expr A {_:EqDec A eq} (e:expr A) b :
  central (belongs_to_expr e)
          (fun ρ => valid_pure_expr ρ e b).
Proof.
  unfold central, valid_pure_expr.
  intros ** [h₁ h₂].
  split.
  - apply value_not_fixed_check_pure_expr; eauto.
  - intros h₃; apply h₂.
    assert (ν = swap α β (swap α β ν)) as h₄.
    { extensionality x.
      now rewrite swap_idempotent. }
    rewrite h₄.
    apply value_not_fixed_check_pure_expr; eauto.
Qed. *)


(* Singly linked list *)

From iris.base_logic.lib Require Export wsat.
From iris_c.clang Require Import logic tactics notations.
From iris_c.lib Require Import gmap_solve int.

Section proof.
  Context `{clangG Σ}.

  Definition tcell (t: type): type := Tprod t (Tptr Tvoid).

  Fixpoint isList (l: val) (xs: list val) (t: type) :=
    match xs with
      | [] => (⌜ l = null ⌝)%I
      | x::xs' => (∃ p l',
                     ⌜ l = Vptr p ∧ typeof x t ∧ typeof l' (Tptr (tcell t)) ⌝ ∗
                     p ↦ Vpair x l' @ tcell t ∗ isList l' xs' t)%I
    end.

  Fixpoint isListSeg (l lt lt2: val) (x: val) (xs: list val) (t: type) :=
    match xs with
      | [] => (∃ p, ⌜ l = Vptr p ∧ l = lt ∧ typeof x t⌝ ∗ p ↦ Vpair x lt2 @ tcell t)%I
      | x'::xs' => (∃ p l',
                     ⌜ l = Vptr p ∧ typeof x t ∧ typeof l' (Tptr (tcell t)) ⌝ ∗
                     p ↦ Vpair x l' @ tcell t ∗ isListSeg l' lt lt2 x' xs' t)%I
    end.

  Lemma isList_ptr (l: val) (xs: list val) (t: type) :
    isList l xs t ⊢ ⌜ typeof l (Tptr Tvoid) ⌝.
  Proof.
    destruct xs as [|x xs'].
    - iIntros "%". iPureIntro. by subst.
    - simpl. iIntros "H".
      iDestruct "H" as (??) "(% & ? & _)".
      by destruct_ands.
  Qed.

  Lemma isList_ptr' (l: val) (xs: list val) (t: type) :
    isList l xs t ⊢ ⌜ typeof l (Tptr (tcell t)) ⌝.
  Proof.
    destruct xs as [|x xs'].
    - iIntros "%". iPureIntro. by subst.
    - simpl. iIntros "H".
      iDestruct "H" as (??) "(% & ? & _)".
      by destruct_ands.
  Qed.

  Notation "'Tlist'" := (Tptr (tcell Tint8)).

  Definition rev_list : expr :=
    while: ( (!"x"@Tlist) != null ) (
      "t" <- snd (!(!"x"@Tlist)@(tcell Tint8)) ;;
      (!"x"@Tlist) + 1 <- !"y"@Tlist ;;
      "y" <- !"x"@Tlist ;;
      "x" <- !"t"@Tlist
    ) ;;
    return: !"y"@Tlist.

  Definition traverse_list (lx: val) : expr :=
    while: (!lx@Tlist != null) ( lx <- snd (!(!lx@Tlist)@(tcell Tint8)) ).

  Lemma traverse_spec Φ lx xs: ∀ l,
    lx ↦ l @ Tlist ∗ isList l xs Tint8 ∗ (isList l xs Tint8 -∗ Φ void)
    ⊢ WP (traverse_list lx, ([], semp)) {{ v, Φ v }}.
  Proof.
    induction xs as [|x xs' IHxs'].
    - iIntros (l) "[? [% HΦ]]".
      rewrite /traverse_list. subst.
      iApply (wp_while [] []).
      repeat wp_step.
      iApply (wp_break [] []).
      simpl. iApply wp_value=>//.
      by iApply "HΦ".
    - iIntros (l) "[Hlx [Hl HΦ]]".
      simpl. iDestruct "Hl" as (p l') "[% [Hp Hl']]".
      destruct_ands.
      rewrite /traverse_list.
      iApply (wp_while [] []).
      do 10 wp_step.
      iApply (wp_continue [] []).
      iApply IHxs'. iFrame. iIntros "?".
      iApply "HΦ". iExists _, _. by iFrame.
  Qed.

  Lemma lseg_snoc' v:
    typeof v Tint8 →
    ∀ xs x p p' (p'': addr) l'',
      typeof l'' Tlist →
      isListSeg p p' p'' x xs Tint8 ∗ p'' ↦ Vpair v l'' @ tcell Tint8
       ⊢ isListSeg p p'' l'' x (xs ++ [v]) Tint8.
  Proof.
    intros ?.
    induction xs as [|x' xs' IHxs']; iIntros (x p p' p'' l'' ?) "[Hl Hv]"; simpl.
    - iDestruct "Hl" as (p''') "[% ?]". destruct_ands.
      iExists p''', p''. iSplit=>//. iFrame.
      iExists _. iFrame. done.
    - iDestruct "Hl" as (p''' l') "[% [? ?]]". destruct_ands.
      specialize (IHxs' x' l' p' p'' l'').
      iDestruct (IHxs' with "[~1 Hv]") as "?"=>//; first iFrame.
      iExists _, _. iFrame. done.
  Qed.

  Lemma lseg_snoc v xs x p p' (p'': addr) l'':
    typeof v Tint8 → typeof l'' Tlist →
    isListSeg p p' p'' x xs Tint8 ∗ p'' ↦ Vpair v l'' @ tcell Tint8
    ⊢ isListSeg p p'' l'' x (xs ++ [v]) Tint8.
  Proof. iIntros (??) "?". iApply lseg_snoc'=>//. Qed.

  Lemma lseg_unsnoc: ∀ xs p (p': addr) x,
    isListSeg p p' null x xs Tint8 ⊢
    (∃ (x': val) xs' p'', isListSeg p p'' p' x xs' Tint8 ∗
     p' ↦ Vpair x' null @ tcell Tint8 ∗ ⌜ xs = xs' ++ [x'] ⌝ ) ∨
    (⌜ p = p' ∧ xs = [] ⌝ ∗ p' ↦ Vpair x null @ tcell Tint8).
  Proof.
    induction xs as [|x' xs' IHxs'].
    - iIntros (???) "H". simpl. iDestruct "H" as (?) "[% ?]". destruct_ands.
      iRight. simplify_eq. by iFrame.
    - iIntros (???) "H". simpl. iDestruct "H" as (??) "[% [? ?]]". destruct_ands.
      iDestruct (IHxs' with "~1") as "[?|[% ?]]".
      + iLeft. iDestruct "~2" as (???) "[? [? %]]". iExists H2. iFrame.
        subst. iExists (x'::H5). iExists _.
        iSplit=>//. simpl. iExists _, _.
        iFrame. done.
      + destruct_ands. iLeft. iExists x'. iFrame.
        iExists [], H0. iSplit=>//. simpl. iExists _.
        iSplit=>//.
  Qed.

  Lemma lseg_to_list xs: ∀ p p' x,
    isListSeg p p' null x xs Tint8 ⊢ isList p (x::xs) Tint8.
  Proof.
    induction xs as [|x' xs' IHxs'].
    - iDestruct 1 as (?) "[% ?]". destruct_ands.
      iExists _, _. iFrame. iSplit=>//.
    - simpl. iDestruct 1 as (??) "[% [? ?]]". destruct_ands.
      iDestruct (IHxs' with "~") as "?".
      iExists _, _. iFrame. iSplit=>//.
  Qed.

  Definition enq_env pt pt': env :=
    (sset "lt'" (Tlist, Vptr pt')
          (sset "lt" (Tptr Tlist, Vptr pt)
                semp)).

  Lemma enq_spec' lx (p: addr) Φ x xs k: ∀ xs2 xs1 pt pt' (p': addr) l',
    typeof l' Tlist → typeof p Tlist →
    lx ↦ p @ Tlist ∗ pt ↦ p' @ Tlist ∗ pt' ↦ l' @ Tlist ∗
    isListSeg p p' l' x xs1 Tint8 ∗ isList l' xs2 Tint8 ∗ ⌜ xs = xs1 ++ xs2 ⌝ ∗
    (∀ p': addr, lx ↦ p @ Tlist -∗ pt ↦ p' @ Tlist -∗
                 isListSeg p p' null x xs Tint8 -∗
                 pt' ↦ null @ Tlist -∗
                 WP (fill_ectxs void k, ([], enq_env pt pt')) {{ Φ }})
    ⊢ WP (fill_ectxs (while: (! "lt'" @ Tlist != null) (
            "lt" <- ! "lt'" @ Tlist ;; "lt'" <- snd ! ! "lt'" @ Tlist @ (tcell Tint8)
          )) k, ([], enq_env pt pt')) {{ Φ }}.
  Proof.
    induction xs2 as [|x' xs2' IHxs'];
      iIntros (???????) "(Hlx&Hpt&Hpt'&Hxs1&Hxs2&%&HΦ)".
    - iDestruct "Hxs2" as "%". subst.
      iApply wp_while. iNext. wp_run.
      rewrite (right_id_L _ (++)).
      iApply (wp_break _ []). simpl.
      by iSpecialize ("HΦ" $! p' with "Hlx Hpt Hxs1 Hpt'").
    - simpl. iDestruct "Hxs2" as (p'' l'') "[% [? ?]]". destruct_ands.
      iApply wp_while. iNext.
      wp_run. iApply (wp_continue _ []).
      iApply (IHxs' (xs1 ++ [x'])); last iFrame; auto.
      iSplitL.
      { iApply lseg_snoc=>//. iFrame. }
      { by rewrite -assoc. }
  Qed.

  Definition enq_list (lx: val) (v: val) : expr :=
    "lt" <- !lx @ Tlist ;;
    if: ((!"lt"@Tlist) != null) then: (
      "lt'" <- snd (!(!"lt"@Tlist)@(tcell Tint8)) ;;
      while: ((!"lt'"@Tlist) != null) (
        "lt" <- !"lt'"@Tlist;;
        "lt'" <- snd (!(!"lt'"@Tlist)@(tcell Tint8))
      ) ;;
      (!"lt"@Tlist) + 1 <- Ealloc (tcell Tint8) (Vpair v null)
    ) else: (
      lx <- Ealloc (tcell Tint8) (Vpair v null)
    ).

  Lemma enq_spec Φ lx lt lt' xs v: typeof v Tint8 → ∀ l,
    lt' ↦ null @ Tlist ∗ lt ↦ null @ Tlist ∗
    lx ↦ l @ Tlist ∗ isList l xs Tint8 ∗
    (∀ l', (lx ↦ l' @ Tlist) -∗ (isList l' (xs ++ [v]) Tint8) -∗ Φ void)
    ⊢ WP (enq_list lx v, ([], enq_env lt lt')) {{ v, Φ v }}.
  Proof.
    intros ?. rewrite /enq_list. subst.
    iIntros (l) "(Ht' & Ht & Hlx & Hl & HΦ)".
    iDestruct (mapsto_typeof with "Hlx") as "%". wp_var.
    destruct xs as [|x xs'] eqn:?; subst; simpl.
    - iDestruct "Hl" as "%". subst. wp_run.
      wp_alloc x as "Hx"=>//.
      wp_assign. iApply ("HΦ" with "[-Hx]")=>//.
      iExists _, _. iFrame. iSplit=>//.
    - simpl. iDestruct "Hl" as (p l') "[% [? ?]]".
      destruct_ands. wp_run.
      wp_unfill (Ewhile _ _).
      iApply (enq_spec' lx p _ x _ _ _ [] lt lt' p l'); last iFrame; auto.
      iSplitL "~"=>//.
      { simpl. iExists _. iSplit=>//. }
      iSplit=>//. iIntros (?) "? ? ? ?". destruct a. simpl.
      wp_run. rewrite_byte. replace (Z.to_nat 1) with 1%nat=>//.
      iDestruct (lseg_unsnoc with "~2") as "[H|[% Hp]]".
      + iDestruct "H" as (???) "[Hl [Hp %]]". destruct_ands.
        iDestruct (mapstoval_split with "Hp") as "[Hp1 Hp2]". simpl.
        wp_alloc lp' as "Hlp'"=>//.
        wp_assign. iApply ("HΦ" with "~").
        iDestruct (mapsto_typeof with "Hp1") as "%".
        iDestruct (mapstoval_join with "[Hp1 Hp2]") as "Hp"; first by iSplitL "Hp1".
        iDestruct (lseg_snoc with "[Hl Hp]") as "Hl'"; try iFrame; auto.
        iDestruct (lseg_snoc with "[Hl' Hlp']") as "Hl''"; try iFrame; auto.
        iDestruct (lseg_to_list with "Hl''") as "Hl''".
        simpl. iDestruct "Hl''" as (??) "[% [? ?]]". destruct_ands.
        iExists _, _. iFrame. done.
      + destruct_ands.
        iDestruct (mapstoval_split with "Hp") as "[Hp1 Hp2]". simpl.
        wp_alloc lp' as "Hlp'"=>//. wp_assign.
        iApply ("HΦ" with "~").
        iDestruct (mapstoval_join with "[Hp1 Hp2]") as "Hp"; first by iSplitL "Hp1".
        iExists _, _. iFrame. iSplit=>//.
        iExists _, _. iFrame. iSplit=>//.
  Qed.

  Definition rev_env px py pt : env :=
    sset "x" (Tptr Tlist, Vptr px)
         (sset "y" (Tptr Tlist, Vptr py)
               (sset "t" (Tptr Tlist, Vptr pt) semp)).

  Lemma rev_spec' (f: ident) k ks Φ px py pt xs:
    ∀ lx ly ys,
      isList lx xs Tint8 ∗
      isList ly ys Tint8 ∗
      px ↦ lx @ Tlist ∗
      py ↦ ly @ Tlist ∗
      pt ↦ - @ Tlist ∗
      (∀ ly' : val, py ↦ ly' @ Tlist ∗
                    isList ly' (rev xs ++ ys) Tint8 -∗
                    WP (fill_ectxs void k, (ks, rev_env px py pt)) {{ Φ }})
      ⊢ WP (fill_ectxs (while: (! "x" @ Tlist != null) (
             "t" <- snd ! ! "x" @ Tlist @ (tcell Tint8) ;;
             ! "x" @ Tlist + (Byte.repr 1) <- ! "y" @ Tlist ;;
             "y" <- ! "x" @ Tlist ;;
             "x" <- ! "t" @ Tlist )) k, (ks, rev_env px py pt)) {{ v, Φ v }}.
  Proof.
    induction xs as [|x xs' IHxs']; intros ??? ; subst.
    - iIntros "(Hlx & Hly & Hpx & Hpy & Hpt & HΦ)".
      iDestruct "Hlx" as "%". subst.
      iApply wp_while. iNext.
      wp_run. iApply (wp_break _ []).
      iApply ("HΦ" with "[-]")=>//. iFrame.
    - iIntros "(Hlx & Hly & Hpx & Hpy & Hpt & HΦ)".
      iDestruct "Hlx" as (p l') "(% & Hp & Hl')".
      destruct H0 as [? [? ?]]. subst.
      iDestruct "Hpt" as (?) "Hpt".
      destruct p as [pb po].
      iDestruct (isList_ptr with "Hly") as "%".
      iApply wp_while. iNext. wp_run.
      rewrite_byte. replace (Z.to_nat 1) with 1%nat; last done.
      iDestruct (mapstoval_split with "Hp") as "[Hp1 Hp2]". simpl.
      wp_run. iApply (wp_continue _ []).
      iApply (IHxs' l' (Vptr (pb, po)) (x::ys)).
      iFrame. iDestruct (mapstoval_join with "[Hp1 Hp2]") as "Hp".
      { iSplitL "Hp1"; by simpl. }
      iSplitL "Hp Hly".
      { iExists (pb, po), ly. iFrame.
        iPureIntro. split; [|split]=>//. by eapply typeof_any_ptr. }
      rewrite -app_assoc. iFrame. by iExists _.
  Qed.

  Definition ps :=
    [ ("x", Tptr Tlist); ("y", Tptr Tlist); ("t", Tptr Tlist) ].

  Lemma rev_spec pt k ks Φ xs:
    ∀ lx ly ys,
      "rev" T↦ Function Tvoid ps rev_list ∗
      isList lx xs Tint8 ∗ isList ly ys Tint8 ∗
      pt ↦ - @ Tlist ∗
      (∀ ly', isList ly' (rev xs ++ ys) Tint8 -∗ WP (fill_ectxs ly' k, ks) {{ Φ }})
      ⊢ WP (fill_ectxs (Ecall Tvoid "rev"
                              (Epair (Ealloc Tlist (Evalue lx))
                                     (Epair (Ealloc Tlist (Evalue ly))
                                            (Vpair pt void))))
                              k, ks) {{ Φ }}.
   Proof.
     iIntros (???). iIntros "(Hf & Hlx & Hly & Hpt & HΦ)".
     destruct ks.
     iDestruct (wp_bind (k ++ [ EKcall Tvoid "rev"
                                ; EKpairl (Epair (Ealloc Tlist ly) (Vpair pt void))])
                        _ (Ealloc Tlist lx))
       as "H"=>//.
     assert (fill_ectxs (Ealloc Tlist lx)
                        (k ++ [ EKcall Tvoid "rev";
                                EKpairl (Epair (Ealloc Tlist ly) (Vpair pt void))]) =
             fill_ectxs (fill_ectxs (Ealloc Tlist lx)
                              [ EKcall Tvoid "rev";
                                EKpairl (Epair (Ealloc Tlist ly) (Vpair pt void))]) k).
     { symmetry. eapply fill_app. }
     rewrite H0.
     simpl. iApply "H".
     iDestruct (isList_ptr' with "Hlx") as "%".
     iDestruct (isList_ptr' with "Hly") as "%".
     wp_alloc x as "Hx". iApply wp_value=>//.
     rewrite -(fill_app x [EKcall Tvoid "rev";
                       EKpairl (Epair (Ealloc Tlist ly) (Vpair pt void))] k).
     simpl.
     rewrite (fill_app (Ealloc Tlist ly)
                       [EKcall Tvoid "rev"; EKpairr x; EKpairl (Vpair pt void) ] k).
     iApply wp_bind=>//.
     wp_alloc y as "Hy".
     iApply wp_value=>//.
     rewrite -(fill_app y [ EKcall Tvoid "rev";
                            EKpairr x;
                            EKpairl (Vpair pt void) ] k).
     simpl.
     rewrite (fill_app (Epair y (Vpair pt void))
                       [EKcall Tvoid "rev"; EKpairr x] k).
     iApply wp_bind=>//.
     iApply wp_pair.
     rewrite -(fill_app (Vpair y (Vpair pt void))
                        [EKcall Tvoid "rev"; EKpairr x] k).
     simpl.
     rewrite (fill_app (Epair x (Vpair y (Vpair pt void)))
                       [EKcall Tvoid "rev"] k).
     iApply wp_bind=>//. iApply wp_pair.
     rewrite -(fill_app (Vpair x (Vpair y (Vpair pt void)))
                        [EKcall Tvoid "rev"] k).
     simpl.
     iApply (wp_call (rev_env x y pt) e _
                     (Vpair x (Vpair y (Vpair pt Vvoid))) ps)=>//.
     iFrame. iNext.
     move: (rev_spec' "rev" [EKseq (return: ! "y" @ Tlist)]
                      (Kcall k e :: s) Φ x y pt xs lx ly ys) => Hspec.
     simpl in *.
     iDestruct (Hspec with "[-]") as "Hspec"=>//.
     { iFrame. iIntros (?).
       iIntros "[Hy Hl]".
       wp_run. by iApply "HΦ". }
   Qed.
End proof.


Require Import Coq.Lists.List
        Coq.Strings.String
        Coq.Logic.FunctionalExtensionality
        Coq.Sets.Ensembles
        Fiat.Common.ilist2
        Fiat.Common.StringBound
        Coq.Program.Program
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.Common.Ensembles.IndexedEnsembles
        Fiat.QueryStructure.Specification.Representation.Notations.

(* A tuple is a heterogeneous list indexed by a heading. *)
Definition RawTuple {heading : RawHeading} :=
  ilist2 (B := id) (AttrList heading).

Definition Tuple {heading : Heading}
  := @RawTuple heading.

(* Always parse the heading argument in Heading scope. *)
Arguments Tuple [_%Heading].

(* Notations for tuple field. *)

Record Component (Heading : Attribute) :=
  { value : attrType Heading }.

Notation "id :: value" :=
  (Build_Component {| attrName := id;
                      attrType := _ |}
                   value) : Component_scope.

Bind Scope Component_scope with Component.

(* Notation-friendly tuple definition. *)
Fixpoint BuildTuple
         {n}
         (attrs : Vector.t Attribute n)
  : ilist2 (B := Component) attrs -> @Tuple (BuildHeading attrs) :=
  match attrs return ilist2 (B := Component) attrs -> @Tuple (BuildHeading attrs) with
  | Vector.nil => fun components => inil2
  | Vector.cons attr n' attrs' =>
    fun components =>
      icons2 (B := id) (value (ilist2_hd components))
            (BuildTuple attrs' (ilist2_tl components))
  end.

(* Notation
for tuples built from [BuildTuple]. *)

Notation "< col1 , .. , coln >" :=
  (@BuildTuple _ _ (icons2 col1%Component .. (icons2 coln%Component inil2) ..))
  : Tuple_scope.

Definition GetAttributeRaw {heading}
: @RawTuple heading -> forall attr : Attributes heading, Domain heading attr := ith2.

Definition GetAttribute {heading}
  : @Tuple heading ->
    forall attr : @BoundedString _ (HeadingNames heading),
      Domain heading (ibound (indexb attr)) :=
  fun t idx => GetAttributeRaw t (ibound (indexb idx)).

Notation "t ! R" :=
  (GetAttribute t%Tuple (@Build_BoundedIndex _ _ _ R%string _))
  : Tuple_scope.

Definition SetAttributeRaw {heading}
: @RawTuple heading ->
  forall attr : Attributes heading,
    Domain heading attr -> @RawTuple heading :=
  fun tup attr dom => replace_Index2 _ tup attr dom.

Definition SetAttribute {heading}
: @Tuple heading ->
  forall attr : @BoundedString _ (HeadingNames heading),
    Domain heading (ibound (indexb attr)) -> @Tuple heading :=
  fun tup attr dom => replace_Index2 _ tup (ibound (indexb attr)) dom.

(*Notation "tup '!!' attr '<-' v " := (SetAttribute tup (@Build_BoundedIndex _ _ _ attr%string _) v) : Tuple_scope. *)

Definition AppendTupleRaw
           {heading1 heading2}
           (tup1 : @RawTuple heading1)
           (tup2 : @RawTuple heading2)
  : @RawTuple (AppendRawHeading heading1 heading2) :=
  ilist2_app tup1 tup2.

Notation "tup1 ++ tup2" := (AppendTupleRaw tup1 tup2) : Tuple_scope.

Definition UpdateAttributeRaw
           {heading}
           (attr : Attributes heading)
           (f : Domain heading attr -> Domain heading attr)
           (tup : @RawTuple heading)
  : @RawTuple heading := update_Index2 _ tup _ f.

Definition UpdateAttribute
           {heading}
           (tup : @Tuple heading)
           (attr : @BoundedString _ (HeadingNames heading))
           (f : Domain heading (ibound (indexb attr))
                -> Domain heading (ibound (indexb attr)))
  : @Tuple heading := UpdateAttributeRaw _ f tup.

Definition UpdateAttributes
           {heading}
           (tup : @Tuple heading)
           (attrs :
              list (@sigT (@BoundedString _ (HeadingNames heading))
                          (fun attr => Domain heading (ibound (indexb attr))
                                       -> Domain heading (ibound (indexb attr)))))
  : @Tuple heading := fold_left (fun (tup' : @Tuple heading)
                                     attr => UpdateAttribute tup' (projT1 attr) (projT2 attr)) attrs tup.

Class HeadingHint := { headingHint : Heading }.

Notation "tup ○ f" :=
  (let H := _ in
   let _ := {| headingHint := H |} in
   @UpdateAttributes H tup f%Update%list) : Tuple_scope.

Notation "x !! attr / f" :=
  (@existT (@BoundedString _ (HeadingNames headingHint))
           (fun attr' => Domain _ (ibound (indexb attr'))
                        -> Domain _ (ibound (indexb attr')))
           (@Build_BoundedIndex _ _ _ attr%string _)
           (fun x => f)) : Update_scope.

Notation "attr ::= v" :=
  (@existT (@BoundedString _ (HeadingNames headingHint))
           (fun attr' => Domain _ (ibound (indexb attr'))
                        -> Domain _ (ibound (indexb attr')))
           (@Build_BoundedIndex _ _ _ attr%string _)
           (fun _ => v)) : Update_scope.

(*Notation "'UpdateTuple' tup '!' attrs " :=
    (UpdateAttribute tup (@Build_BoundedIndex _ _ _ attr%string _) f)
      (tup at level 0, at level 80, attr at level 0,
       f at level 0, no associativity) : Tuple_scope.*)

Section TupleNotationExamples.
  Local Open Scope Tuple_scope.

  Definition MovieHeading : Heading := <"title" :: string, "year" :: nat>%Heading.
  Definition GwW : Tuple := <"title" :: "Gone With the Wind"%string, "year" :: 1938>.
  Definition GwW' := Eval simpl in GwW ○ ["title" ::= "Gone With the Wind Part 2"%string].
  Definition DupleMovie : RawTuple := GwW ++ GwW'.

  Definition GwW'' (tup : @Tuple MovieHeading)
    : @Tuple MovieHeading :=
    tup ○ [old !! "title" / append old "Gone With the Wind Part 3"%string;
           "year" ::= 10].

End TupleNotationExamples.
(*
Notation "a ++= b" := (@UpdateTuple _ {|attrName := a; attrType := string|}
                             (fun o => Build_Component (_::_) (append (value o) b))) (at level 80).
Notation "a :+= b" := (@UpdateTuple _ {|attrName := a; attrType := list _|}
                             (fun o => Build_Component (_::_) (cons b (value o)))) (at level 80).
Notation "[ a ; .. ; c ]" := (compose a .. (compose c id) ..) : Update_scope.

Delimit Scope Update_scope with Update.
*)

Definition IndexedRawTuple {heading} := @IndexedElement (@RawTuple heading).
Definition RawTupleIndex {heading} (I : @IndexedRawTuple heading) : nat :=
  elementIndex I.
Definition indexedRawTuple {heading} (I : @IndexedRawTuple heading)
  : @RawTuple heading := indexedElement I.

Definition IndexedTuple {heading} := @IndexedElement (@Tuple heading).
Definition TupleIndex {heading} (I : @IndexedTuple heading) : nat :=
  elementIndex I.
Definition indexedTuple {heading} (I : @IndexedTuple heading)
: @Tuple heading := indexedElement I.

Definition GetAttributeRawBnd {heading : Heading}
           (tup : @RawTuple heading)
           (idx : (BoundedIndex (HeadingNames heading)))
  : Domain heading (ibound (indexb idx)) :=
  GetAttributeRaw tup (ibound (indexb idx)).

(* Raw tuple field accessor notation *)
Notation "tup '!' idx" := (GetAttributeRaw tup ``idx) : TupleImpl_scope.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Coq - Calculus of Inductive Constructions V5.10           *)
(*****************************************************************************)
(*                                                                           *)
(*          Category Theory : Hom (Bi-)Functors (used in Adjunctions)        *)
(*                                                                           *)
(*          Amokrane Saibi May 1994                                          *)
(*                                                                           *)
(*****************************************************************************)

Require Export SET.
Require Export Dual.
Require Export PROD.
Require Export Functor.

Set Implicit Arguments.
Unset Strict Implicit.

(* C(-,G-) et D(F-,-) : D^o x C -> SET *)

(* C(F-,-) *)

Section FunSet2_r.

Variable C D : Category.

(* pour alle'ger les e'critures *)

 Section abrev.

 Definition OB_l (dxc : POb (Dual D) C) : D := Ob_l dxc.

 Variables (d1xc1 d2xc2 : POb (Dual D) C) (foxg : Pmor d1xc1 d2xc2).

 Definition HOM_l : OB_l d2xc2 --> OB_l d1xc1 := Hom_l foxg.

 Definition Build_POb1 (d : D) (c : C) := Build_POb (A:=Dual D) (B:=C) d c.

 Definition Build_Pmor1 (c c' : C) (d d' : D) (f : d' --> d)
   (g : c --> c') := Build_Pmor (u:=Build_POb1 d c) (t:=Build_POb1 d' c') f g.

 End abrev.

(* *)

Variable F : Functor D C.

Definition FunSET2_r_ob (dxc : POb (Dual D) C) := F (OB_l dxc) --> Ob_r dxc.

 Section funset2_r_map_def.

 Variable d1xc1 d2xc2 : POb (Dual D) C.

  Section funset2_r_mor_def.

  Variable foxg : Pmor d1xc1 d2xc2.

  Definition FunSET2_r_mor1 (h : FunSET2_r_ob d1xc1) :=
    (FMor F (HOM_l foxg) o h) o Hom_r foxg.

  Lemma FunSET2_r_map_law1 : Map_law FunSET2_r_mor1.
  Proof.
  unfold Map_law, FunSET2_r_mor1 in |- *; simpl in |- *.
  intros h1 h2 H.
  apply Comp_r; apply Comp_l; assumption.
  Qed.

  Canonical Structure FunSET2_r_mor :
    Map (FunSET2_r_ob d1xc1) (FunSET2_r_ob d2xc2) := FunSET2_r_map_law1.

  End funset2_r_mor_def.

 Lemma FunSET2_r_map_law : Map_law FunSET2_r_mor.
 Proof.
 unfold Map_law, FunSET2_r_mor in |- *.
 intros f1xg1 f2xg2; elim f1xg1; intros f1 g1.
 elim f2xg2; intros f2 g2; simpl in |- *.
 unfold Ext in |- *; simpl in |- *.
 unfold Equal_Pmor in |- *; simpl in |- *.
 unfold FunSET2_r_mor1 in |- *; simpl in |- *.
 unfold FunSET2_r_ob in |- *.
 intro H; elim H; intros H1 H2 h.
 apply Comp_lr.
 apply Comp_r; trivial.
 apply FPres; assumption.
 assumption.
 Qed.

 Canonical Structure FunSET2_r_map := Build_Map FunSET2_r_map_law.

 End funset2_r_map_def.

Lemma Fun2_r_comp_law : Fcomp_law FunSET2_r_map.
Proof.
unfold Fcomp_law, FunSET2_r_map in |- *; simpl in |- *.
unfold FunSET2_r_mor, Ext in |- *; simpl in |- *.
unfold FunSET2_r_mor1, FunSET2_r_ob in |- *; simpl in |- *.
intros d1xc1 d2xc2 d3xc3 f1xg1 f2xg2 h.
elim f1xg1; simpl in |- *; unfold DHom in |- *; intros f1 g1.
elim f2xg2; simpl in |- *; unfold DHom in |- *; intros f2 g2; simpl in |- *.
(* *) apply Trans with (((FMor F (f2 o f1) o h) o g1) o g2).
apply Ass.
apply Comp_r.
(* *) apply Trans with ((FMor F f2 o FMor F f1 o h) o g1).
apply Comp_r.
(* *) apply Trans with ((FMor F f2 o FMor F f1) o h).
apply Comp_r.
apply FComp.
apply Ass1.
apply Ass1.
Qed.

Lemma Fun2_r_id_law : Fid_law FunSET2_r_map.
Proof.
unfold Fid_law, FunSET2_r_map, FunSET2_r_mor in |- *; simpl in |- *.
unfold Ext, Id_SET in |- *; simpl in |- *.
unfold FunSET2_r_mor1 in |- *; simpl in |- *.
unfold FunSET2_r_ob in |- *; intros dxc f.
unfold Id_fun in |- *.
(* *) apply Trans with (FMor F (Id (OB_l dxc)) o f).
apply Idr1.
(* *) apply Trans with (Id (F (OB_l dxc)) o f).
apply Comp_r.
apply FId.
apply Idl.
Qed.

Canonical Structure FunSET2_r := Build_Functor Fun2_r_comp_law Fun2_r_id_law.

End FunSet2_r.

Section FunSet2_l.

Variables (C D : Category) (G : Functor C D).

(* D(-,G-) *)

Definition FunSET2_l_ob (dxc : POb (Dual D) C) := OB_l dxc --> G (Ob_r dxc).

 Section funset2_l_map_def.

 Variable d1xc1 d2xc2 : POb (Dual D) C.

  Section funset2_l_mor_def.

  Variable foxg : Pmor d1xc1 d2xc2.

  Definition FunSET2_l_mor1 (h : FunSET2_l_ob d1xc1) :=
    (HOM_l foxg o h) o FMor G (Hom_r foxg).

  Lemma FunSET2_l_map_law1 : Map_law FunSET2_l_mor1.
  Proof.
  unfold Map_law, FunSET2_l_mor1 in |- *; simpl in |- *.
  intros h1 h2 H.
  apply Comp_r; apply Comp_l; assumption.
  Qed.

  Canonical Structure FunSET2_l_mor :
    Map (FunSET2_l_ob d1xc1) (FunSET2_l_ob d2xc2) := FunSET2_l_map_law1.

  End funset2_l_mor_def.

 Lemma FunSET2_l_map_law : Map_law FunSET2_l_mor.
 Proof.
 unfold Map_law, FunSET2_l_mor in |- *.
 intros f1xg1 f2xg2; elim f1xg1; intros f1 g1.
 elim f2xg2; intros f2 g2; simpl in |- *.
 unfold Ext in |- *; simpl in |- *.
 unfold Equal_Pmor in |- *; simpl in |- *.
 unfold FunSET2_l_mor1 in |- *; simpl in |- *.
 unfold FunSET2_l_ob in |- *.
 intro H; elim H; intros H1 H2 h.
 apply Comp_lr.
 apply Comp_r; trivial.
 apply FPres.
 assumption.
 Qed.

 Canonical Structure FunSET2_l_map := Build_Map FunSET2_l_map_law.

 End funset2_l_map_def.

Lemma Fun2_l_comp_law : Fcomp_law FunSET2_l_map.
Proof.
unfold Fcomp_law, FunSET2_l_map in |- *; simpl in |- *.
unfold FunSET2_l_mor, Ext in |- *; simpl in |- *.
unfold FunSET2_l_mor1, FunSET2_l_ob in |- *; simpl in |- *.
intros d1xc1 d2xc2 d3xc3 f1xg1 f2xg2 h.
elim f1xg1; simpl in |- *; unfold DHom in |- *; intros f1 g1.
elim f2xg2; simpl in |- *; unfold DHom in |- *; intros f2 g2; simpl in |- *.

(* *) apply Trans with (((f2 o f1) o h) o FMor G g1 o FMor G g2).
apply Comp_l.
apply FComp.
(* *) apply Trans with ((((f2 o f1) o h) o FMor G g1) o FMor G g2).
apply Ass.
apply Comp_r.
(* *) apply Trans with ((f2 o f1 o h) o FMor G g1).
apply Comp_r.
apply Ass1.
apply Ass1.
Qed.

Lemma Fun2_l_id_law : Fid_law FunSET2_l_map.
Proof.
unfold Fid_law, FunSET2_l_map, FunSET2_l_mor in |- *; simpl in |- *.
unfold Ext, Id_SET in |- *; simpl in |- *.
unfold FunSET2_l_mor1 in |- *; simpl in |- *.
unfold FunSET2_l_ob in |- *; simpl in |- *; intros dxc f.
unfold Id_fun in |- *.
(* *) apply Trans with (Id (OB_l dxc) o f o FMor G (Id (Ob_r dxc))).
apply Ass1.
(* *) apply Trans with (f o FMor G (Id (Ob_r dxc))).
apply Idl.
(* *) apply Trans with (f o Id (G (Ob_r dxc))).
apply Comp_l; apply FId.
apply Idr1.
Qed.

Canonical Structure FunSET2_l := Build_Functor Fun2_l_comp_law Fun2_l_id_law.

End FunSet2_l.


Require Import Bool.
Require Import String.
Require Classical.
Require Import Coq.Classes.RelationClasses.
Require Coq.Setoids.Setoid.

Open Scope string_scope.

(* To solve bug 2630. *)
Ltac easy ::=
  let rec use_hyp H :=
   (match type of H with
    | _ /\ _ => exact H || destruct_hyp H
    | _ => try (solve [ inversion H ])
    end)
  with do_intro := (let H := fresh in
                    intro H; use_hyp H)
  with destruct_hyp H := (case H; clear H; do_intro; do_intro) in
  let rec use_hyps :=
   (match goal with
    | H:_ /\ _ |- _ => exact H || (destruct_hyp H; use_hyps)
    | H:_ |- _ => solve [ inversion H ]
    | _ => idtac
    end) in
  let rec do_atom :=
   ((solve [ reflexivity | symmetry; trivial ]) || (* the only modified line *)
      contradiction || (split; do_atom))
  with do_ccl := (trivial with eq_true; do_atom || (repeat do_intro; do_atom)) in
  (use_hyps; do_ccl) || fail "Cannot solve this goal".

(***************************)
(** *  Krivine's machine  **)
(***************************)

(** An abstract set of instructions, containing callcc **)
Parameter instruction : Set.
Parameter callcc : instruction.

(** A set of stack constants **)
Parameter stack_const : Set.

(** λ_c terms **)
Inductive term : Set :=
  | Cst : instruction -> term
  | Lam : string -> term -> term
  | Var : string -> term
  | App : term -> term -> term.
Coercion Cst : instruction >-> term.
Coercion Var : string >-> term.
Notation "'λ' n t" := (Lam n t) (at level 16, n at level 0, t at level 41, format "'λ' n '/  '  t").
Notation "t @ s" := (App t s) (at level 15, left associativity).

(** Closures, stacks and environments **)
Inductive Λ : Set :=
  | Closed : term -> env -> Λ
  | Cont : Π -> Λ
with Π : Set :=
  | Scst : stack_const -> Π
  | Scons : Λ -> Π -> Π
with env : Set :=
  | Enil : env
  | Econs : string -> Λ -> env -> env.
Coercion Scst : stack_const >-> Π.
Notation "t ↓ e" := (Closed t e) (at level 45, no associativity, format "t '/  ' '↓' e").
Notation "k[ π ]" := (Cont π).
Notation "t · s" := (Scons t s) (at level 47, right associativity).
Notation "e ← t ; f" := (Econs e t f) (at level 49, right associativity, format "e '←' t ';'  '/' f").
Notation "∅" := Enil.

Bind Scope Env_scope with env.
Bind Scope Stack_scope with Π.
Bind Scope Clos_scope with Λ.

Arguments Cont _%Stack_scope.
Arguments Scons _%Clos_scope _%Stack_scope.
Arguments Econs _%Clos_scope _%Env_scope.

(* Extracting a closure from an environment *)
Fixpoint get s (e : env) : Λ :=
  match e with
    | c←t;e' => if string_dec s c then t else get s e'
    | Enil => "environment too small"↓Enil (* dummy case *)
  end.

(** Checking wether a term is closed.
    Useful for eliminating typos in big λ_c-terms.  **)
Fixpoint closed_aux acc t :=
  match t with
    | Cst _ => true
    | Lam s t' => closed_aux (cons s acc) t'
    | Var n => if List.in_dec string_dec n acc then true else false
    | App t₁ t₂ => closed_aux acc t₁ && closed_aux acc t₂
  end.

Definition closed := closed_aux nil.

(** Processes **)
Inductive process := Process : Λ -> Π -> process.
Notation "c '★' s" := (Process c s) (at level 55).

(** **  Reduction rules  **)

Parameter red : process -> process -> Prop.
Notation "p₁ ≻ p₂" := (red p₁ p₂) (at level 70).
Axiom red_trans : forall p₁ p₂ p₃, p₁ ≻ p₂ -> p₂ ≻ p₃ -> p₁ ≻ p₃.

(** Reduction rules: grab, push, save, restore plus one for variables.

    The last rule is necessary for native data: we unbox it to expose it to the operators.
**)
Axiom red_Lam : forall n t c e π, (λ n t)↓e ★ c·π ≻ t↓(n←c;e) ★ π.
Axiom red_App : forall t t' e π, t @ t'↓e ★ π ≻ t↓e ★ t'↓e · π.
Axiom red_cc : forall t e π, callcc↓e ★ t·π ≻ t ★ k[π]·π.
Axiom red_k : forall t π π', k[π] ★ t·π' ≻ t ★ π.
Axiom red_Var : forall n e π, Var n↓e ★ π ≻ get n e ★ π.
Axiom red_AppVar : forall t n e π, t @ Var n↓e ★ π ≻ t↓e ★ get n e·π.

(** Tactics to perform one step of evaluation in the KAM **)
Ltac Kred tac := eapply red_trans; [now apply tac |].
Ltac Kstep := Kred red_Lam || (Kred red_Var; simpl get) || (Kred red_AppVar; simpl get) || Kred red_cc
             || Kred red_k || (Kred red_App; simpl get).

(** Printing command for λ_c terms. **)
Section Printing.
  Variable print_const : instruction -> string.
  Variable print_sconst : stack_const -> string.

  Fixpoint print_term (t : term) : string :=
    match t with
      | Cst c => print_const c
      | Lam n t => "λ" ++ n ++ " " ++ print_term t
      | Var n => n
      | App t₁ t₂ => print_term t₁ ++ " " ++ print_term t₂
    end.

  Fixpoint print_clos c :=
    match c with
      | Closed t e => (print_term t ++ "↓" ++ print_env e)%string
      | Cont s => "k[" ++ print_stack s ++ "]"
    end
  with print_stack s :=
    match s with
      | Scst α => print_sconst α
      | Scons c s' => print_clos c ++ "°" ++ print_stack s'
    end
  with print_env e :=
    match e with
      | Enil => "∅"%string
      | Econs n c Enil => n ++ " ↦ " ++ print_clos c
      | Econs n c e' => n ++ " ↦ " ++ print_clos c ++ ", " ++ print_env e'
    end.
End Printing.

(** **  Some usual terms  **)

Definition Id := λ"x" "x".
Definition nId := λ"x" ("x" @ "x"). (* or any λx. x u *)
Definition tt := λ"x" λ"y" "x".
Definition ff := λ"x" λ"y" "y".
Definition δ := λ"x" "x" @ "x".
Definition Ω := δ @ δ.
(** A universal realizer of excluded middle **)
Definition em := λ"f" λ"g" callcc @ λ"k" "g" @ λ"i" "k" @ ("f" @ "i").
(** Turing's fixpoint operator **)
Definition Y := (λ"x" λ"y" "y" @ ("x" @ "x" @ "y")) @ (λ"x" λ"y" "y" @ ("x" @ "x" @ "y")).

Example Ω_red : forall e π, δ↓e ★ δ↓e·π ≻ δ↓e ★ δ↓e·π.
Proof. unfold δ at 1. intros e π. do 2 Kstep. apply red_Var. Qed.

(** Storage operators for functions.
    We force the presence of the continuation(s) k (or u and v)
    to ensure that the reduction can only occur when it is present.
**)
Definition caron1 op := λ"Mx" "Mx" @ λ"x" op @ "x".
Definition caron2 op := λ"Mx" "Mx" @ λ"x" λ"My" "My" @ λ"y" op @ "x" @ "y".
Definition caron3 op := λ"Mx" "Mx" @ λ"x" λ"My" "My" @ λ"y" λ"Mz" "Mz" @ λ"z" op @ "x" @ "y" @ "z".
Definition caron4 op := λ"Mx" "Mx" @ λ"x" λ"My" "My" @ λ"y" λ"Mz" "Mz" @ λ"z"
  λ"Mt" "Mt" @ λ"t" op @ "x" @ "y" @ "z" @ "t".

(** Same thing for relations. **)
Definition rel_caron1 rel := λ"Mx" "Mx" @ λ"x" rel @ "x".
Definition rel_caron2 rel := λ"Mx" "Mx" @ λ"x" λ"My" "My" @ λ"y" rel @ "x" @ "y".
Definition rel_caron3 rel :=
  λ"Mx" "Mx" @ λ"x" λ"My" "My" @ λ"y" λ"Mz" "Mz" @ λ"z" rel @ "x" @ "y" @ "z".
Definition rel_caron4 rel := λ"Mx" "Mx" @ λ"x" λ"My" "My" @ λ"y" λ"Mz" "Mz" @ λ"z" λ"Mt" "Mt" @ λ"t"
  rel @ "x" @ "y" @ "z" @ "t".

(***********************)
(** *  Realizability  **)
(***********************)

Parameter pole : process -> Prop.
Notation "p ∈ ⫫" := (pole p) (at level 69, format "p  '∈'  '⫫'").
Axiom anti_evaluation : forall p p', p ≻ p' -> p' ∈ ⫫ -> p ∈ ⫫.

Definition formula := Π -> Prop.

Definition Fval (F : formula) (π : Π) := F π.
Notation "π '∈' '‖' F '‖'" := (Fval F π) (at level 70, format "'[hv' π  '∈' '/'  '‖' F '‖' ']'").

Definition realizes t F := forall π, π ∈ ‖F‖ -> t★π ∈ ⫫.
Notation "t ⊩ F" := (realizes t F) (at level 79).

Definition Impl A B := fun π => match π with Scst _ => False | t·π' => t ⊩ A /\ π' ∈ ‖B‖ end.
Notation "A '→' B" := (Impl A B) (at level 78, right associativity).

Ltac clear_realizers :=
  repeat lazymatch goal with
    | H : _ ⊩ _ |- _ => clear H
    | H : _ ∈ ‖_‖ |- _ => clear H
    | π : Π |- _ => clear π
    | t : Λ |- _ => clear t
    | e : env |- _ => clear e
  end.

(** **  Quantifications  **)

(** There is a lot of boilerplate code here because the notation mecanism of Coq is not powerful enough to handle
    relativized quantification of arbitrary arity so we have to define it for every fixed arity.
    In addition, we also take advantage of these definitions to optimize relativization predicates,
    so that relativzing to [A x ∧ B x] can be defined as [∀x, A x → B x → …].

    In a nutshell, we can use [∀ x y … z, A] or [∃ x y … z, A] for unrelativized quantifications and
    [∀₂ x, y ∈ P₁ × P₂, A] or [∃₃ x, y, z ∈ P₁ × P₂ × P₃] for relatized one, where the indices [₂] and [₃] are
    the number of variables you quantify over.  Currently, it goes from 1 to 5.
**)

(** *** Without relativization **)

Definition Forall T f : formula := fun π => exists t : T, π ∈ ‖f t‖.
Global Notation "'∀' t₁ .. t₂ ',' F" := (Forall _ (fun t₁ => .. (Forall _ (fun t₂ => F)) .. ))
  (at level 99, t₁ binder, t₂ binder, right associativity).
Global Notation "'∃' t₁ .. t₂ ',' F" :=
  (Forall formula (fun Z => (Forall _ (fun t₁ => .. (Forall _ (fun t₂ => F → Z)) ..)) → Z))
  (at level 99, t₁ binder, t₂ binder, right associativity).

(** *** With relativization **)

(** Relativization is defined as an operator of formulæ depending on an argument.
    The simplest such operator on a predicate [P] is [fun A x => P x -> A x] built by [make_Rel]
    but in some cases we may want to define optimized ones, using [now_Rel].
**)
Class Relativisation {T : Type} (P : T -> formula) := Rel : (T -> formula) -> T -> formula.
Global Instance now_Rel {T} P f : @Relativisation T P := {Rel := f}.
Global Instance make_Rel {T} P : @Relativisation T P := {Rel := fun f t => P t → f t}.
Global Hint Unfold Rel now_Rel make_Rel : Krivine.
(* Note: We cannot add the equivalence between relativized formula and the formula with the predicate
         as a precondition because the idea is precisely to modify the number of arguments
         so that terms cannot be equivalent.
         We could add the existence of terms performing the translation in both directions as a way to ensure
         correctness but this could not be used in practice. *)

(** Binding 1 variable **)
Definition ForallR {T} P `{@Relativisation T P} (f : T -> formula) : formula :=
  fun π => exists t : T, π ∈ ‖Rel f t‖.
Global Notation "'∀₁' t '∈' P ',' F" := (ForallR P (fun t => F)) (at level 99, right associativity).
Global Notation "'∃₁' t '∈' P ',' F" :=
  (Forall formula (fun Z => (ForallR P (fun t => F → Z)) → Z)) (at level 99, t at next level).

(** Binding 2 variables **)
Definition ForallR2 {T₁ T₂} P₁ P₂ `{@Relativisation T₁ P₁, @Relativisation T₂ P₂} (f : T₁ -> T₂ -> formula)
  : formula := fun π => exists t₁ : T₁, exists t₂ : T₂, π ∈ ‖Rel (fun t => Rel (f t) t₂) t₁‖.
Global Notation "'∀₂' t₁ ',' t₂ '∈' P₁ '×' P₂ ',' F" :=
  (ForallR2 P₁ P₂ (fun t₁ t₂ => F)) (at level 99, right associativity).
Global Notation "'∃₂' t₁ ',' t₂ '∈' P₁ '×' P₂ ',' F" :=
  (Forall formula (fun Z => (ForallR2 P₁ P₂ (fun t₁ t₂ => F → Z)) → Z)) (at level 99, right associativity).

(** Binding 3 variables **)
Definition ForallR3 {T₁ T₂ T₃} P₁ P₂ P₃ `{@Relativisation T₁ P₁, @Relativisation T₂ P₂, @Relativisation T₃ P₃}
                    (f : T₁ -> T₂ -> T₃ -> formula) : formula :=
  fun π => exists t₁ : T₁, exists t₂ : T₂, exists t₃ : T₃,
           π ∈ ‖Rel (fun t => Rel (fun t' => Rel (f t t') t₃) t₂) t₁‖.
Global Notation "'∀₃' t₁ ',' t₂ ',' t₃ '∈' P₁ '×' P₂ '×' P₃ ',' F" :=
  (ForallR3 P₁ P₂ P₃ (fun t₁ t₂ t₃ => F)) (at level 99,  right associativity).
Global Notation "'∃₃' t₁ ',' t₂ ',' t₃ '∈' P₁ '×' P₂ '×' P₃ ',' F" :=
  (Forall formula (fun Z => (ForallR3 P₁ P₂ P₃ (fun t₁ t₂ t₃ => F → Z)) → Z))
  (at level 99, right associativity).

(** Binding 4 variables **)
Definition ForallR4 {T₁ T₂ T₃ T₄} P₁ P₂ P₃ P₄
                    `{@Relativisation T₁ P₁, @Relativisation T₂ P₂, @Relativisation T₃ P₃, @Relativisation T₄ P₄}
                    (f : T₁ -> T₂ -> T₃ -> T₄ -> formula) : formula :=
  fun π => exists t₁ : T₁, exists t₂ : T₂, exists t₃ : T₃, exists t₄ : T₄,
           π ∈ ‖Rel (fun t => Rel (fun t' => Rel (fun t'' => Rel (f t t' t'') t₄) t₃) t₂) t₁‖.
Global Notation "'∀₄' t₁ ',' t₂ ',' t₃ ',' t₄ '∈' P₁ '×' P₂ '×' P₃ '×' P₄ ',' F" :=
  (ForallR4 P₁ P₂ P₃ P₄ (fun t₁ t₂ t₃ t₄ => F)) (at level 99,  right associativity).
Global Notation "'∃₄' t₁ ',' t₂ ',' t₃ ',' t₄ '∈' P₁ '×' P₂ '×' P₃ '×' P₄ ',' F" :=
  (Forall formula (fun Z => (ForallR4 P₁ P₂ P₃ P₄ (fun t₁ t₂ t₃ t₄ => F → Z)) → Z))
  (at level 99, right associativity).

(** Binding 5 variables **)
Definition ForallR5 {T₁ T₂ T₃ T₄ T₅} P₁ P₂ P₃ P₄ P₅
  `{@Relativisation T₁ P₁, @Relativisation T₂ P₂, @Relativisation T₃ P₃, @Relativisation T₄ P₄,
    @Relativisation T₅ P₅} (f : T₁ -> T₂ -> T₃ -> T₄ -> T₅ -> formula) : formula :=
  fun π => exists t₁ : T₁, exists t₂ : T₂, exists t₃ : T₃, exists t₄ : T₄, exists t₅ : T₅,
    π ∈ ‖Rel (fun t => Rel (fun t' => Rel (fun t'' => Rel (fun t''' => Rel (f t t' t'' t''') t₅) t₄) t₃) t₂) t₁‖.
Global Notation "'∀₅' t₁ ',' t₂ ',' t₃ ',' t₄ ',' t₅ '∈' P₁ '×' P₂ '×' P₃ '×' P₄ '×' P₅ ',' F" :=
  (ForallR5 P₁ P₂ P₃ P₄ P₅ (fun t₁ t₂ t₃ t₄ t₅ => F)) (at level 99,  right associativity).
Global Notation "'∃₅' t₁ ',' t₂ ',' t₃ ',' t₄ ',' t₅ '∈' P₁ '×' P₂ '×' P₃ '×' P₄ '×' P₅ ',' F" :=
  (Forall formula (fun Z => (ForallR5 P₁ P₂ P₃ P₄ P₅ (fun t₁ t₂ t₃ t₄ t₅ => F → Z)) → Z))
  (at level 99, right associativity).

(** ***  Function relativisation  **)

Definition fun_Pred {T T'} P P' (f : T -> T') := ∀₁x∈P, P' (f x).
Global Instance fun_Rel {T T'} P P' `{Relativisation T P} : @Relativisation (T -> T') (fun_Pred P P') :=
  now_Rel (fun_Pred P P') (fun f t => (∀₁x∈P, P'(t x)) → f t).
Notation "A '~>' B" := (fun_Pred A B) (at level 80, right associativity).

(** ** Usual connectives **)

Definition Top : formula := fun _ => False.
Notation "⊤" := Top.

Definition bot := ∀ Z, Z.
Notation "⊥" := bot.

Notation "¬ F" := (F → ⊥) (at level 25, only parsing).

Definition one := ∀ Z, (Z → Z).

(** Semantic implication **)

(** Be careful that the equivalence between c → A and c ↦ A can only be realized when c is realized
    by the identity. This means that taking c = n <> m does not provide the equivalence.
    In this case, it is better to take a boolean equality eqb since x <> y then amounts to eqb(x,y) = 0.
**)
Definition mapsto (c : Prop) F := fun π => c /\ π ∈ ‖F‖.
Notation "c '↦' F" := (mapsto c F) (at level 78, right associativity).

(** Intersection type **)
Definition inter A B := fun π => π ∈ ‖A‖ \/ π ∈ ‖B‖.
Notation "A '∩' B" := (inter A B) (at level 71, right associativity).

(** Optimized version for n-ary and **)
Definition and2 A B := ∀ Z, (A → B → Z) → Z.
Notation "A ∧ B" := (and2 A B) (at level 80, no associativity).
Definition and3 A B C := ∀ Z, (A → B → C → Z) → Z.
Notation "A ∧ B ∧ C" := (and3 A B C) (at level 80, B at next level, no associativity).
Definition and4 A B C D := ∀ Z, (A → B → C → D → Z) → Z.
Notation "A ∧ B ∧ C ∧ D" := (and4 A B C D) (at level 80, B at next level, C at next level, no associativity).
Definition and5 A B C D E := ∀ Z, (A → B → C → D → E → Z) → Z.
Notation "A ∧ B ∧ C ∧ D ∧ E" := (and5 A B C D E)
  (at level 80, B at next level, C at next level, D at next level, no associativity).
Definition and6 A B C D E F := ∀ Z, (A → B → C → D → E → F → Z) → Z.
Notation "A ∧ B ∧ C ∧ D ∧ E ∧ F" := (and6 A B C D E F)
  (at level 80, B at next level, C at next level, D at next level, E at next level, no associativity).

(** Optimized versions for n-ary or **)
Definition or2 A B := ∀ Z, (A → Z) → (B → Z) → Z.
Notation "A ∨ B" := (or2 A B) (at level 85, no associativity).
Definition or3 A B C := ∀ Z, (A → Z) → (B → Z) → (C → Z) → Z.
Notation "A ∨ B ∨ C" := (or3 A B C) (at level 85, B at next level, no associativity).
Definition or4 A B C D := ∀ Z, (A → Z) → (B → Z) → (C → Z) → (D → Z) → Z.
Notation "A ∨ B ∨ C ∨ D" := (or4 A B C D) (at level 85, B at next level, C at next level, no associativity).
Definition or5 A B C D E := ∀ Z, (A → Z) → (B → Z) → (C → Z) → (D → Z) → (E → Z) → Z.
Notation "A ∨ B ∨ C ∨ D ∨ E" := (or5 A B C D E)
  (at level 85, B at next level, C at next level, D at next level, no associativity).
Definition or6 A B C D E F := ∀ Z, (A → Z) → (B → Z) → (C → Z) → (D → Z) → (E → Z) → (F → Z) → Z.
Notation "A ∨ B ∨ C ∨ D ∨ E ∨ F" := (or6 A B C D E F)
  (at level 85, B at next level, C at next level, D at next level, E at next level, no associativity).

(** Combining existential quantifiers and conjonction

    We optimize existential qunatifiers and conjunctions [∃x, A x ∧ B x] into [∀Z, (∀x, A x → B x → Z) → Z]
    rather than [∀Z, (∀x, (∀Y, (A x → B x → Y) → Y)) → Z].

    We can also use the semantic implication to get [∀Z, (∀x, A x ↦ B x → Z) → Z]. To do so, use [&] instead of [∧].
    Such semantic conjunctions (at most 2) must be put at the begginning of the conjunct.
**)
(* Conflict with the other ∀_/∃_ notation without { } *)

(** Without ↦ **)
Global Notation "'Ex₁' t '∈' P ',' '{' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR P (fun t => F₁ → .. (F₂ → Z) .. )) → Z))
  (at level 98, t at next level, F₁ at level 79, F₂ at level 79).
Global Notation "'Ex₂' t₁ ',' t₂ '∈' P₁ '×' P₂ ',' '{' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR2 P₁ P₂ (fun t₁ t₂ => F₁ → .. (F₂ → Z) ..)) → Z))
  (at level 98, right associativity, F₁ at level 79, F₂ at level 79).
Global Notation "'Ex₃' t₁ ',' t₂ ',' t₃ '∈' P₁ '×' P₂ '×' P₃ ',' '{' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR3 P₁ P₂ P₃ (fun t₁ t₂ t₃ => F₁ → .. (F₂ → Z) ..)) → Z))
  (at level 98, right associativity, F₁ at level 79, F₂ at level 79).
Global Notation "'Ex₄' t₁ ',' t₂ ',' t₃ ',' t₄ '∈' P₁ '×' P₂ '×' P₃ '×' P₄ ',' '{' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR4 P₁ P₂ P₃ P₄ (fun t₁ t₂ t₃ t₄ => F₁ → .. (F₂ → Z) ..)) → Z))
  (at level 98, right associativity, F₁ at level 79, F₂ at level 79).
Global Notation
  "'Ex₅' t₁ ',' t₂ ',' t₃ ',' t₄ ',' t₅ '∈' P₁ '×' P₂ '×' P₃ '×' P₄ '×' P₅ ',' '{' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR5 P₁ P₂ P₃ P₄ P₅ (fun t₁ t₂ t₃ t₄ t₅ => F₁ → .. (F₂ → Z) ..)) → Z))
  (at level 98, right associativity, F₁ at level 79, F₂ at level 79).

(** With one ↦ **)
Global Notation "'Ex₁' t '∈' P ',' '{' F₀ '&' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR P (fun t => F₀ ↦ F₁ → .. (F₂ → Z) .. )) → Z))
  (at level 98, t at next level, F₀ at level 79, F₁ at level 79, F₂ at level 79).
Global Notation "'Ex₂' t₁ ',' t₂ '∈' P₁ '×' P₂ ',' '{' F₀ '&' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR2 P₁ P₂ (fun t₁ t₂ => F₀ ↦ F₁ → .. (F₂ → Z) ..)) → Z))
  (at level 98, right associativity, F₀ at level 79, F₁ at level 79, F₂ at level 79).
Global Notation "'Ex₃' t₁ ',' t₂ ',' t₃ '∈' P₁ '×' P₂ '×' P₃ ',' '{' F₀ '&' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR3 P₁ P₂ P₃ (fun t₁ t₂ t₃ => F₀ ↦ F₁ → .. (F₂ → Z) ..)) → Z))
  (at level 98, right associativity, F₀ at level 79, F₁ at level 79, F₂ at level 79).
Global Notation "'Ex₄' t₁ ',' t₂ ',' t₃ ',' t₄ '∈' P₁ '×' P₂ '×' P₃ '×' P₄ ',' '{' F₀ '&' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR4 P₁ P₂ P₃ P₄ (fun t₁ t₂ t₃ t₄ => F₀ ↦ F₁ → .. (F₂ → Z) ..)) → Z))
  (at level 98, right associativity, F₀ at level 79, F₁ at level 79, F₂ at level 79).
Global Notation
  "'Ex₅' t₁ ',' t₂ ',' t₃ ',' t₄ ',' t₅ '∈' P₁ '×' P₂ '×' P₃ '×' P₄ '×' P₅ ',' '{' F₀ '&' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR5 P₁ P₂ P₃ P₄ P₅ (fun t₁ t₂ t₃ t₄ t₅ => F₀ ↦ F₁ → .. (F₂ → Z) ..)) → Z))
  (at level 98, right associativity, F₀ at level 79, F₁ at level 79, F₂ at level 79).

(** With two ↦ **)
Global Notation "'Ex₁' t '∈' P ',' '{' F '&' F₀ '&' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR P (fun t => F ↦ F₀ ↦ F₁ → .. (F₂ → Z) .. )) → Z))
  (at level 98, t at next level, F at level 79, F₀ at level 79, F₁ at level 79, F₂ at level 79).
Global Notation "'Ex₂' t₁ ',' t₂ '∈' P₁ '×' P₂ ',' '{' F '&' F₀ '&' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR2 P₁ P₂ (fun t₁ t₂ => F ↦ F₀ ↦ F₁ → .. (F₂ → Z) ..)) → Z))
  (at level 98, right associativity, F at level 79, F₀ at level 79, F₁ at level 79, F₂ at level 79).
Global Notation "'Ex₃' t₁ ',' t₂ ',' t₃ '∈' P₁ '×' P₂ '×' P₃ ',' '{' F '&' F₀ '&' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR3 P₁ P₂ P₃ (fun t₁ t₂ t₃ => F ↦ F₀ ↦ F₁ → .. (F₂ → Z) ..)) → Z))
  (at level 98, right associativity, F at level 79, F₀ at level 79, F₁ at level 79, F₂ at level 79).
Global Notation "'Ex₄' t₁ ',' t₂ ',' t₃ ',' t₄ '∈' P₁ '×' P₂ '×' P₃ '×' P₄ ',' '{' F '&' F₀ '&' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR4 P₁ P₂ P₃ P₄ (fun t₁ t₂ t₃ t₄ => F ↦ F₀ ↦ F₁ → .. (F₂ → Z) ..)) → Z))
  (at level 98, right associativity, F at level 79, F₀ at level 79, F₁ at level 79, F₂ at level 79).
Global Notation
  "'Ex₅' t₁ ',' t₂ ',' t₃ ',' t₄ ',' t₅ '∈' P₁ '×' P₂ '×' P₃ '×' P₄ '×' P₅ ',' '{' F '&' F₀ '&' F₁ '∧' .. '∧' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR5 P₁ P₂ P₃ P₄ P₅ (fun t₁ t₂ t₃ t₄ t₅ => F ↦ F₀ ↦ F₁ → .. (F₂ → Z) ..)) → Z))
  (at level 98, right associativity, F at level 79, F₀ at level 79, F₁ at level 79, F₂ at level 79).

(** Combining existential quantifiers and disjonction **)
Global Notation "'Ex₁' t '∈' P ',' '{' F₁ '∨' .. '∨' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR P (fun t => (F₁ → Z) → .. ((F₂ → Z) → Z) .. )) → Z))
  (at level 98, t at next level, F₁ at level 79, F₂ at level 79).
Global Notation "'Ex₂' t₁ ',' t₂ '∈' P₁ '×' P₂ ',' '{' F₁ '∨' .. '∨' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR2 P₁ P₂ (fun t₁ t₂ => (F₁ → Z) → .. ((F₂ → Z) → Z) .. )) → Z))
  (at level 98, right associativity, F₁ at level 79, F₂ at level 79).
Global Notation "'Ex₃' t₁ ',' t₂ ',' t₃ '∈' P₁ '×' P₂ '×' P₃ ',' '{' F₁ '∨' .. '∨' F₂ '}'" :=
  (Forall formula (fun Z => (ForallR3 P₁ P₂ P₃ (fun t₁ t₂ t₃ => (F₁ → Z) → .. ((F₂ → Z) → Z) .. )) → Z))
  (at level 98, right associativity, F₁ at level 79, F₂ at level 79).
Global Notation "'Ex₄' t₁ ',' t₂ ',' t₃ ',' t₄ '∈' P₁ '×' P₂ '×' P₃ '×' P₄ ',' '{' F₁ '∨' .. '∨' F₂ '}'" :=
  (Forall formula
    (fun Z => (ForallR4 P₁ P₂ P₃ P₄ (fun t₁ t₂ t₃ t₄ => (F₁ → Z) → .. ((F₂ → Z) → Z) .. )) → Z))
  (at level 98, right associativity, F₁ at level 79, F₂ at level 79).
Global Notation
  "'Ex₅' t₁ ',' t₂ ',' t₃ ',' t₄ ',' t₅ '∈' P₁ '×' P₂ '×' P₃ '×' P₄ '×' P₅ ',' '{' F₁ '∨' .. '∨' F₂ '}'" :=
  (Forall formula
    (fun Z => (ForallR5 P₁ P₂ P₃ P₄ P₅ (fun t₁ t₂ t₃ t₄ t₅ => (F₁ → Z) → ..((F₂ → Z) → Z)..)) → Z))
  (at level 98, right associativity, F₁ at level 79, F₂ at level 79).


From Coq Require Import RelationClasses.
From Mon Require Import SPropBase.
Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect.
Set Warnings "notation-overridden,ambiguous-paths".
From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples.
From Crypt Require Import ChoiceAsOrd OrderEnrichedRelativeAdjunctions OrderEnrichedRelativeAdjunctionsExamples TransformingLaxMorph SubDistr Theta_dens LaxFunctorsAndTransf UniversalFreeMap FreeProbProg StateTransformingLaxMorph LaxComp.

Import SPropNotations.

(*
In this file we state transform this morphism
θdens : Frp → Sdistr
into
StT(θdens) : StT(Frp) → StT(SDistr)

We also subsequently make its domain free
θFstd : FrStP → StT(Frp) → stT(SDistr)
*)

Section GetDomainAndCodomain.
  Context {C D1 D2 : ord_category} {J1 : ord_functor C D1} {J12 : ord_functor D1 D2} {J2 : ord_functor C D2}
          {phi : natIso J2 (ord_functor_comp J1 J12)} (psi := ni_inv phi)
          {M1 : ord_relativeMonad J1} {M2: ord_relativeMonad J2}.

  Definition rlmm_domain (smTheta :  relativeLaxMonadMorphism J12 phi M1 M2)
    : ord_relativeMonad J1
    := M1.
  Definition rlmm_codomain (smTheta :  relativeLaxMonadMorphism J12 phi M1 M2)
    : ord_relativeMonad J2
    := M2.

End GetDomainAndCodomain.

Section StT_unaryThetaDens.
  Context {probE : Type -> Type}. (*an interface for probabilistic events*)
  Context {chUniverse : Type}
          {chElement : chUniverse -> choiceType}.
  Context (prob_handler : forall (T:choiceType),
    probE T -> SDistr T).

  Context {S : choiceType}.

  (*we wish to transform this monad morphism*)
  Let θdens_filled :=
  @unary_theta_dens.

  (*domain and codomain*)
  Let Frp := rlmm_domain θdens_filled.
  (* Eval hnf in rlmm_codomain θdens_filled. (*SDistr*) *)

  (*state transform the domain*)

  Program Definition unaryStateTingAdj :
  leftAdjunctionSituation choice_incl
         (ord_functor_comp (unaryTimesS1 S) choice_incl)
         (ToTheS S) :=
    mkNatIso _ _ _ _ _ _ _.
  Next Obligation.
    move=> [A X]. unshelve econstructor.
      simpl. move=> g a s. exact (g (a,s)).
      move=> g g'. simpl in g. simpl in g'.
      move=> Hg. unfold extract_ord. simpl.
      move=> a.
      unfold extract_ord in Hg. simpl in Hg.
      apply boolp.funext. move=> s.
      apply Hg.
  Defined.
  Next Obligation.
    move=> [A X]. unshelve econstructor.
      simpl. move=> g. move=> [a s]. exact (g a s).
      simpl. move => g g'.
      unfold extract_ord. simpl.
      move=> Hg. move=> [a s].
      specialize (Hg a). destruct Hg.
      reflexivity.
  Defined.
  Next Obligation.
    move=> [A X] [A' X']. move=> [fA fX]. simpl in *.
    apply sig_eq. simpl. apply boolp.funext. move=> g.
    apply boolp.funext. move=> a'. apply boolp.funext. move=> s.
    simpl.
    rewrite /OrderEnrichedRelativeAdjunctionsExamples.ToTheS_obligation_1.
    reflexivity.
  Qed.
  Next Obligation.
    move=> [A X].
    apply sig_eq. simpl. apply boolp.funext. move=> g.
    simpl. apply boolp.funext. move=> a. reflexivity.
  Qed.
  Next Obligation.
    move=> [A X].
    apply sig_eq. simpl. apply boolp.funext. move=> g.
    simpl. apply boolp.funext. move=> [a s]. reflexivity.
  Qed.

  Program Definition unaryStateBeta' :
  lnatTrans (lord_functor_comp
                      (strict2laxFunc (ToTheS S))
                      (strict2laxFunc (ord_functor_id TypeCat)))
            (lord_functor_comp
                      (strict2laxFunc (ord_functor_id TypeCat))
                      (strict2laxFunc (ToTheS S))) :=
    mkLnatTrans _ _.

  Program Definition stT_thetaDens_adj :=
  Transformed_lmla θdens_filled unaryStateTingAdj unaryStateTingAdj unaryStateBeta' _ _.
  Next Obligation.
    move=> A Y. move=> g.
    apply boolp.funext. move=> [ a s]. cbv. reflexivity.
  Qed.

  Definition stT_thetaDens :=  rlmm_from_lmla stT_thetaDens_adj.

End StT_unaryThetaDens.

Section MakeTheDomainFree.
  Context {probE : Type -> Type}. (*an interface for probabilistic events*)
  Context {chUniverse : Type}
          {chElement : chUniverse -> choiceType}.
  Context {prob_handler : forall (T:choiceType),
    probE T -> SDistr T}.

  Context {S : choiceType}.

  Let unaryIntState_filled :=
  @unaryIntState S.

  Let stT_thetaDens_filled :=
  @stT_thetaDens S.

  (*an auxiliary morphism to connect the dots*)
  Program Definition bridgg :
  relativeMonadMorphism (ord_functor_id _) (trivialChi)
     (rlmm_codomain unaryIntState_filled)
     (rlmm_domain stT_thetaDens_filled) :=
    mkRelMonMorph _ _ _ _ _ _ _.

  (*now... unaryIntState_filled ; bridgg = ppre*)
  Let ppre := rlmm_comp _ _ _ _ _ _ _ (unaryIntState_filled) bridgg.

  (*and then ppre ; stT_thetaDens_filled*)
  Definition thetaFstd := rlmm_comp _ _ _ _ _ _ _ ppre stT_thetaDens_filled.

End MakeTheDomainFree.


(******************************************************************************)
(** * Reasoning with multiple Power executions. *)
(******************************************************************************)

Require Import Classical List Relations Peano_dec Omega.
Require Import Hahn.
Require Import Basic Power_Events  Power_Model Power_Domains Power_Locations
  Power_Automation Power_Irreflexive Power_Threads Power_Helpers.

Set Implicit Arguments.
Remove Hints plus_n_O.

(* Unfold databases *)
Hint Unfold rb sync lwsync fence prop1 prop2 prop hb : derived_rels.
Hint Unfold Wf WfDEPS WfACTS WfSB WfRF WfMO WfRMW : wf_unfold.

(* Notations *)
Notation "G ⟪ r ⟫ G'" := (G.(r) ≡ G'.(r)) (at level 1).
Notation "G [ l ]  G'" := (G.(l) = G'.(l)) (at level 1).
Notation "rel |loc" := (fun G => (rel G) ∩ (same_loc G)) (at level 1).

(* Tactics *)
Ltac equiv_solver :=
  let solve_g := (fun g g' =>
    subst; (idtac + destruct g); (idtac + destruct g'); simpl; splits; auto
  ) in
  match goal with
  | |- _ ?g ≡ _ ?g' => solve_g g g'
  | |- _ ?g = _ ?g' => solve_g g g'
  end.

Tactic Notation "assert" "{" ident(name) "}" uconstr(H) :=
  assert (name: H) by equiv_solver.

Tactic Notation "unfold_all" :=
  autounfold with derived_rels type_unfold.
Tactic Notation "unfold_all" "in" hyp(H):=
  autounfold with derived_rels type_unfold in H.
Tactic Notation "unfold_all" "in" "*":=
  autounfold with derived_rels type_unfold in *.

Tactic Notation "surround" "<" constr(s) ">" constr(x) "<" constr(s') ">" "{" constr(g) "}" :=
  arewrite (x g ⊆ ⦗s g⦘ ⨾ x g ⨾ ⦗s' g⦘) by domain_solver.
Tactic Notation "surround" "<" constr(s) ">" constr(x) "{" constr(g) "}" :=
  arewrite (x g ⊆ ⦗s g⦘ ⨾ x g) by domain_solver.
Tactic Notation "surround" uconstr(x) "<" uconstr(s) ">" "{" uconstr(g) "}" :=
  arewrite (x g ⊆ x g ⨾ ⦗s g⦘) by domain_solver.

Section Power_Executions.

Variables G G' : power_execution.

(* Relational equivalence helpers *)
Lemma rb_if_rf_mo (RF: G ⟪rf⟫ G') (MO: G ⟪mo⟫ G') :
  G ⟪rb⟫ G'.
Proof. by unfold_all in *; rewrite RF, MO. Qed.

Lemma sync_if_sb (LAB: G [lab] G') (SB: G ⟪sb⟫ G') :
  G ⟪sync⟫ G'.
Proof. by unfold_all in *; rewrite SB, LAB. Qed.

Lemma lwsync_if_sb (LAB: G [lab] G') (SB: G ⟪sb⟫ G') :
  G ⟪lwsync⟫ G'.
Proof. by unfold_all in *; rewrite SB, LAB. Qed.

Lemma fence_if_sb (LAB: G [lab] G') (SB: G ⟪sb⟫ G') :
  G ⟪fence⟫ G'.
Proof.
  unfold fence.
  arewrite (G ⟪sync⟫ G') by apply sync_if_sb.
  arewrite (G ⟪lwsync⟫ G') by apply lwsync_if_sb.
Qed.

Lemma fence_if_sync_lwsync (S1: G ⟪sync⟫ G') (S2: G ⟪lwsync⟫ G') :
  G ⟪fence⟫ G'.
Proof. by unfold fence; rewrite S1, S2. Qed.

Lemma hb_if_ppo_sb_rf (LAB: G [lab] G')
  (PPO: G ⟪ppo⟫ G') (SB: G ⟪sb⟫ G') (RF: G ⟪rf⟫ G'):
  G ⟪hb⟫ G'.
Proof.
  unfold hb; rewrite PPO, RF.
  arewrite (G ⟪fence⟫ G') by apply fence_if_sb.
Qed.

Lemma hb_if_ppo_fence_rf (LAB: G [lab] G')
  (PPO: G ⟪ppo⟫ G') (FE: G ⟪fence⟫ G') (RF: G ⟪rf⟫ G'):
  G ⟪hb⟫ G'.
Proof.
  by unfold hb; rewrite PPO, RF, FE.
Qed.

Lemma prop1_if_rf_sb_ppo (LAB: G [lab] G')
  (RF: G ⟪rf⟫ G') (SB: G ⟪sb⟫ G') (PPO: G ⟪ppo⟫ G') :
  G ⟪prop1⟫ G'.
Proof.
  unfold prop1; rewrite RF.
  arewrite (G ⟪fence⟫ G') by apply fence_if_sb.
  arewrite (G ⟪hb⟫ G') by apply hb_if_ppo_sb_rf.
  by unfold_all in *; rewrite LAB.
Qed.

Lemma prop1_if_rf_fence_hb (LAB: G [lab] G')
  (RF: G ⟪rf⟫ G') (FE: G ⟪fence⟫ G') (HB: G ⟪hb⟫ G') :
  G ⟪prop1⟫ G'.
Proof.
  unfold prop1; rewrite RF, FE, HB.
  by unfold_all in *; rewrite LAB.
Qed.

Lemma prop2_if_mo_rf_sb_ppo (LAB: G [lab] G')
  (MO: G ⟪mo⟫ G') (RF: G ⟪rf⟫ G') (SB: G ⟪sb⟫ G') (PPO: G ⟪ppo⟫ G') :
  G ⟪prop2⟫ G'.
Proof.
  unfold prop2; rewrite MO, RF.
  arewrite (G ⟪rb⟫ G') by apply rb_if_rf_mo.
  arewrite (G ⟪fence⟫ G') by apply fence_if_sb.
  arewrite (G ⟪sync⟫ G') by apply sync_if_sb.
  arewrite (G ⟪hb⟫ G') by apply hb_if_ppo_sb_rf.
Qed.

Lemma prop2_if_mo_rf_fence_hb_sync (LAB: G [lab] G')
  (MO: G ⟪mo⟫ G') (RF: G ⟪rf⟫ G') (FE: G ⟪fence⟫ G') (HB: G ⟪hb⟫ G')
  (SY: G ⟪sync⟫ G'):
  G ⟪prop2⟫ G'.
Proof.
  unfold prop2; rewrite MO, RF, FE, HB, SY.
  arewrite (G ⟪rb⟫ G') by apply rb_if_rf_mo.
Qed.

Lemma prop_if_mo_rf_sb_ppo (LAB: G [lab] G')
  (MO: G ⟪mo⟫ G') (RF: G ⟪rf⟫ G') (SB: G ⟪sb⟫ G') (PPO: G ⟪ppo⟫ G') :
  G ⟪prop⟫ G'.
Proof.
  unfold prop.
  arewrite (G ⟪prop1⟫ G') by apply prop1_if_rf_sb_ppo.
  arewrite (G ⟪prop2⟫ G') by apply prop2_if_mo_rf_sb_ppo.
Qed.

Lemma prop_if_mo_rf_hb_sync_fence (LAB: G [lab] G')
  (MO: G ⟪mo⟫ G') (RF: G ⟪rf⟫ G') (HB: G ⟪hb⟫ G')
  (SY: G ⟪sync⟫ G') (FE: G ⟪fence⟫ G') :
  G ⟪prop⟫ G'.
Proof.
  unfold prop.
  arewrite (G ⟪prop1⟫ G') by apply prop1_if_rf_fence_hb.
  arewrite (G ⟪prop2⟫ G') by apply prop2_if_mo_rf_fence_hb_sync.
Qed.

Lemma prop_if_prop1_prop2 (P1: G ⟪prop1⟫ G') (P2: G ⟪prop2⟫ G'):
  G ⟪prop⟫ G'.
Proof. by unfold prop; rewrite P1, P2. Qed.

Lemma ppo_if_ii_ic (LAB: G [lab] G') (II: G ⟪ii⟫ G') (IC: G ⟪ic⟫ G') :
  G ⟪ppo⟫ G'.
Proof. by unfold ppo; rewrite II, IC; unfold_all in *; rewrite LAB. Qed.

Lemma ii_if_ii0_ci0_cc0 (HII: G ⟪ii0⟫ G') (HCI: G ⟪ci0⟫ G') (HCC: G ⟪cc0⟫ G'):
  G ⟪ii⟫ G'.
Proof.
  red; split; red; ins;
  eapply ii_rec with (P:=ii _) (P0:=ic _) (P1:=ci _) (P2:=cc _);
  auto; ins; vauto;
  try (apply HII in H0);
  try (apply HCI in H0);
  try (apply HCC in H0);
  vauto.
Qed.

Lemma ic_if_ii0_ci0_cc0 (HII: G ⟪ii0⟫ G') (HCI: G ⟪ci0⟫ G') (HCC: G ⟪cc0⟫ G'):
  G ⟪ic⟫ G'.
Proof.
  red; split; red; ins.
  - apply ic_rec with (G:=G) (P:=ii G') (P0:=ic G') (P1:=ci G') (P2:=cc G');
    auto; ins; vauto;
    try (apply HII in H0);
    try (apply HCI in H0);
    try (apply HCC in H0);
    vauto.
  - apply ic_rec with (G:=G') (P:=ii G) (P0:=ic G) (P1:=ci G) (P2:=cc G);
    auto; ins; vauto;
    try (apply HII in H0);
    try (apply HCI in H0);
    try (apply HCC in H0);
    vauto.
Qed.

(* Consistency equivalence helpers *)
Definition consistency_iso G G' :=
  G [lab] G' /\
  G ⟪sb⟫ G' /\
  G ⟪mo⟫ G' /\
  G ⟪rf⟫ G' /\
  G ⟪rmw⟫ G' /\
  G ⟪ppo⟫ G'.

Lemma consistent_alt (WF: Wf G /\ Wf G'):
   consistency_iso G G' -> (PowerConsistent G' -> PowerConsistent G).
Proof.
  unfold consistency_iso, PowerConsistent.
  ins; desf; unnw.
  assert (RB: G ⟪rb⟫ G') by (by apply rb_if_rf_mo).
  assert (PR: G ⟪prop⟫ G') by (by apply prop_if_mo_rf_sb_ppo).
  assert (HB: G ⟪hb⟫ G') by (by apply hb_if_ppo_sb_rf).
  assert (SL: G ⟪same_loc⟫ G') by (by unfold Power_Model.same_loc; rewrite H).
  by splits; auto; rewrite ?H, ?H0, ?H1, ?H2, ?H3, ?H4, ?RB, ?PR, ?HB, ?SL.
Qed.

Definition consistency_iso2 G G' :=
  G [lab] G' /\
  G ⟪mo⟫ G' /\
  G ⟪rf⟫ G' /\
  G ⟪rmw⟫ G' /\
  G ⟪ii0⟫ G' /\
  G ⟪ci0⟫ G' /\
  G ⟪cc0⟫ G' /\
  G ⟪sync⟫ G' /\
  G ⟪fence⟫ G' /\
  G ⟪sb|loc⟫ G'.

Lemma consistent_alt2 (WF: Wf G /\ Wf G'):
   consistency_iso2 G G' -> (PowerConsistent G' -> PowerConsistent G).
Proof.
  unfold consistency_iso2, PowerConsistent.
  ins; desf.
  assert (II: G ⟪ii⟫ G') by (by apply ii_if_ii0_ci0_cc0).
  assert (IC: G ⟪ic⟫ G') by (by apply ic_if_ii0_ci0_cc0).
  assert (PPO: G ⟪ppo⟫ G') by (by apply ppo_if_ii_ic).
  assert (RB: G ⟪rb⟫ G') by (by apply rb_if_rf_mo).
  assert (HB: G ⟪hb⟫ G') by (by apply hb_if_ppo_fence_rf).
  assert (PR: G ⟪prop⟫ G') by (by apply prop_if_mo_rf_hb_sync_fence).
  splits; auto; by rewrite ?H0, ?H1, ?H2, ?H3, ?H4, ?H5, ?H6, ?H7, ?H8,
                           ?RB, ?ST, ?FE, ?HB, ?PR, ?PPO.
Qed.

Definition consistency_iso3 G G' :=
  G [lab] G' /\
  G ⟪mo⟫ G' /\
  G ⟪rf⟫ G' /\
  G ⟪rmw⟫ G' /\
  G ⟪prop1⟫ G' /\
  G ⟪prop2⟫ G' /\
  G ⟪hb⟫ G' /\
  G ⟪sb|loc⟫ G'.

Lemma consistent_alt3 (WF: Wf G /\ Wf G'):
   consistency_iso3 G G' -> (PowerConsistent G' -> PowerConsistent G).
Proof.
  unfold consistency_iso3, PowerConsistent.
  ins; desf.
  assert (RB: G ⟪rb⟫ G') by (by apply rb_if_rf_mo).
  assert (PR: G ⟪prop⟫ G') by (by apply prop_if_prop1_prop2).
  splits; auto; by rewrite ?H0, ?H1, ?H2, ?H3, ?H4, ?H5, ?H6, ?RB, ?PR.
Qed.

End Power_Executions.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.
Require Import TableDataOpsRef3.Specs.table_unmap3.
Require Import TableDataOpsRef3.LowSpecs.table_unmap3.
Require Import TableDataOpsRef3.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       table_unmap_spec
       table_unmap2_spec
    .

  Lemma table_unmap3_spec_exists:
    forall habd habd'  labd g_rd map_addr level res
           (Hspec: table_unmap3_spec g_rd map_addr level habd = Some (habd', res))
            (Hrel: relate_RData habd labd),
    exists labd', table_unmap3_spec0 g_rd map_addr level labd = Some (labd', res) /\ relate_RData habd' labd'.
  Proof.
    Local Opaque peq ptr_eq.
    intros. duplicate Hrel. destruct D. clear hrepl lrepl. destruct g_rd.
    unfold table_unmap3_spec, table_unmap3_spec0 in *.
    unfold Assertion in *. rm_bind Hspec; rm_bind'. simpl in *.
    unfold Assertion; rm_bind'; grewrite.
    repeat simpl_hyp Hspec; extract_prop_dec; simpl_query_oracle; rm_bind'; grewrite.
    - rewrite_oracle_rel rel_oracle C6.
      repeat (grewrite; try simpl_htarget; simpl).
      unfold unmap_table in *. simpl in *. autounfold in *. simpl in *. grewrite.
      repeat simpl_hyp Hspec; simpl; inversion Hspec; clear H0; grewrite;
        (eexists; split; [reflexivity| constructor; destruct Hrel; simpl; try assumption; try reflexivity]).
    - rewrite_oracle_rel rel_oracle C6.
      repeat (grewrite; try simpl_htarget; simpl).
      unfold unmap_table in *. simpl in *. autounfold in *. simpl in *. grewrite.
      repeat simpl_hyp Hspec; simpl; inversion Hspec; clear H0; grewrite;
        (eexists; split; [reflexivity| constructor; destruct Hrel; simpl; try assumption; try reflexivity]).
    - rewrite_oracle_rel rel_oracle C6.
      repeat (grewrite; try simpl_htarget; simpl). inversion Hspec.
      (eexists; split; [reflexivity| constructor; destruct Hrel; simpl; try assumption; try reflexivity]).
    - rewrite_oracle_rel rel_oracle C6.
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity.
    - rewrite_oracle_rel rel_oracle C6.
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity.
  Qed.

End Refine.