From AIM Require Export Coqlib.
From AIM Require Export Map.
Require Import Arith.
From AIM Require Export Machine.
From AIM Require Export Assertions.
Require Import Lia.
From AIM Require Export Mem_Lemmas.
From AIM Require Export Assertion_Lemmas.

Set Implicit Arguments.
Unset Strict Implicit.

(* ************************************************)
(* portage                                        *)

Definition mjudge (h : Mem) (A : MPred) := A h.

Notation "M ||- A" := (mjudge M A) (at level 80).

Notation " A ** B " := (mstar A B) (at level 67, right associativity).

Notation "A ==> B" :=
  (forall M, M ||- A -> M ||- B) (at level 13).

Notation "A <==> B" :=
  (forall M, M ||- A <-> M ||- B) (at level 13).

Implicit Types A B C D : MPred.

Implicit Types M h : Mem.

Notation sconj := mstar (only parsing).

Notation join := MemMod.disjUnion (only parsing).

Notation emp := MemMod.emp (only parsing).

Notation meq := mEq (only parsing).

Notation unit := Aemp (only parsing).

Lemma join_comm : forall M1 M2 M,
  join M1 M2 M -> join M2 M1 M.
Proof.
  intros M1 M2 M.
  auto with PMap.
Qed.

Definition bang (A:Prop) : MPred :=
  fun h => unit h /\ A.

Require Import List.
Fixpoint itr (tdata : Set) (p : tdata -> MPred) (lst : list tdata) {struct lst} : MPred :=
  match lst with
    | nil => unit
    | cons data lst' => (p data) ** (itr p lst')
  end.

Notation "! A" := (bang A) (at level 55).

Notation set := MemMod.put.

Notation top := mTrue.

(* Parameter sig : forall (l : Label) (v : nat), Mem. *)

(* ************************************************)
(* mjudge                                         *)

Lemma mjudge_intro : forall M A,
  A M -> M ||- A.
Proof.
  unfold mjudge; trivial.
Qed.

Lemma mjudge_elim : forall M A,
  M ||- A -> A M.
Proof.
  unfold mjudge; trivial.
Qed.

(* ************************************************)
(* sconj                                          *)

Lemma sconj_intro : forall ha hb h A B,
  ha ||- A -> hb ||- B -> join ha hb h ->
    h ||- A ** B.
Proof.
  intros.
  exists ha; exists hb; auto.
Qed.
Arguments sconj_intro [ha hb h A B].

Lemma sconj_elim : forall M A B,
  M ||- A ** B
    -> exists ha, exists hb, join ha hb M
      /\ (ha ||- A) /\ (hb ||- B).
Proof.
  unfold sconj; trivial.
Qed.

Lemma sconj_sym : forall h A B,
  h ||- A ** B -> h ||- B ** A.
Admitted.

Lemma sconj_mono_left : forall h A B,
  h ||- (A ** B) ->
    forall A', (A ==> A') ->
      h ||- (A' ** B).
Proof.
  destruct 1 as [ha [hb [J [HA HB]]]].
  exists ha; exists hb.
  intuition.
  apply H.
  apply HA.
Qed.

Lemma sconj_mono_right : forall h A B,
  h ||- (A ** B) ->
    forall B', (B ==> B') ->
      h ||- (A ** B').
Proof.
  destruct 1 as [ha [hb [J [HA HB]]]].
  exists ha; exists hb.
  intuition.
  apply H.
  apply HB.
Qed.

Lemma sconj_mono : forall h A A' B B',
  h ||- A ** B ->
    (A ==> A') -> (B ==> B') ->
    h ||- A' ** B'.
Proof.
  intros.
  assert (h ||- (A' ** B)).
  eapply sconj_mono_left; [eauto | assumption].
  eapply sconj_mono_right; [eauto | assumption].
Qed.

Lemma sconj_eqv_left : forall M A B,
  M ||- A ** B -> forall A',
    (A <==> A')
  -> M ||- A' ** B.
Admitted.
Arguments sconj_eqv_left [M A B].

Lemma sconj_assoc_left : forall A B C h,
  h ||- (A ** B) ** C -> h ||- A ** (B ** C).
Admitted.

Lemma sconj_assoc_right : forall A B C h,
  h ||- A ** (B ** C) -> h ||- (A ** B) ** C.
Admitted.

(* ************************************************)
(* unit                                           *)

Lemma unit_intro : emp ||- unit.
Proof.
  unfold mjudge, unit, Aemp.
  trivial.
Qed.

Lemma unit_intro_left : forall h A,
  h ||- A -> h ||- unit ** A.
Admitted.
Arguments unit_intro_left [h A].

Lemma unit_intro_right : forall h A,
  h ||- A -> h ||- A ** unit.
Admitted.

Lemma unit_elim : forall h,
  h ||- unit -> h = emp.
Admitted.

Lemma join_emp_l : forall m1 m : Mem, join emp m1 m -> m1 = m.
Proof.
 intros.
 auto with PMap.
Qed.

Lemma unit_elim_left : forall h A,
  h ||- unit ** A -> h ||- A.
Admitted.
Arguments unit_elim_left [h A].

Lemma unit_elim_right : forall h A,
  h ||- A ** unit -> h ||- A.
Proof.
  intros.
  apply (unit_elim_left (sconj_sym H)).
Qed.
Arguments unit_elim_right [h A].

(* ************************************************)
(* top                                            *)

Lemma top_intro : forall h, h ||- top.
Proof.
  unfold mjudge, top, top.
  tauto.
Qed.

Lemma top_intro_left : forall h A,
  h ||- A -> h ||- top ** A.
Proof.
  intros.
  assert (join emp h h).
  unfold join,emp; auto with PMap.
  apply (sconj_intro (top_intro emp) H H0).
Qed.
Arguments top_intro_left [h A].

Lemma top_intro_left1 : forall M A B,
  M ||- B ** A -> M ||- top ** A.
Proof.
  intros.
  destruct (sconj_elim H) as [M1 [M2 [HJM [HM1 HM2]]]].
  apply sconj_intro with M1 M2; auto.
  apply top_intro; auto.
Qed.
Arguments top_intro_left1 [M A B].

Lemma top_intro_right : forall M A,
  M ||- A -> M ||- A ** top.
Proof.
  intros M A H.
  substH H with (top_intro_left H).
  apply sconj_sym; trivial.
Qed.
Arguments top_intro_right [M A].

Lemma top_intro_right1 : forall M A B,
  M ||- A ** B -> M ||- A ** top.
Proof.
  intros M A B H.
  destruct (sconj_elim H) as [M1 [M2 [HJM [HM1 HM2]]]].
  apply sconj_intro with M1 M2; auto.
  apply top_intro; auto.
Qed.
Arguments top_intro_right1 [M A B].

(* *********************************************** *)
(* bang                                            *)

Lemma bang_intro : forall h (A:Prop),
  h ||- unit -> A ->
    h ||- ! A.
Proof.
  unfold bang.
  intros h A Hp Aok.
  constructor; assumption.
Qed.

Lemma bang_elim1 : forall h P,
  h ||- ! P -> P.
Proof.
  unfold mjudge, bang.
  intuition.
Qed.

Lemma bang_elim2 : forall h P,
    h ||- ! P -> h ||- unit.
Proof.
  unfold mjudge, bang.
  intuition.
Qed.

Lemma bang_elim : forall h P,
  h ||- ! P ->
    h ||- unit /\ P.
Proof.
  intros h P Hp.
  constructor.
  exact (bang_elim2 Hp).
  exact (bang_elim1 Hp).
Qed.

Lemma bang_elim_left : forall h P B,
    h ||- ! P ** B ->
      P /\ h ||- B.
Proof.
  intros h A B H.
  assert (A /\ h ||- unit ** B).
  destruct H as [ha [hb [J [HA HB]]]].
  constructor.
  apply (bang_elim1 HA).
  assert (HA' := bang_elim2 HA).
  eapply sconj_intro; eauto.
  intuition.
  intuition.
  apply unit_elim_left; trivial.
Qed.

Lemma bang_elim_left1 : forall h P B,
  h ||- ! P ** B ->
    P.
Proof.
  intros h A B H.
  destruct (bang_elim_left H).
  assumption.
Qed.

Lemma bang_elim_left2 : forall h P B,
  h ||- ! P ** B ->
    h ||- B.
Proof.
  intros h A B H.
  destruct (bang_elim_left H).
  assumption.
Qed.

Lemma bang_elim_right : forall h P B,
    h ||- B ** ! P ->
      P /\ h ||- B.
Proof.
  intros h A B H.
  substH H with (sconj_sym H).
  apply bang_elim_left; auto.
Qed.

Lemma bang_intro_left : forall h (P:Prop) B,
  P -> h ||- B ->
    h ||- ! P ** B.
Proof.
  intros h A B HA HB.
  unfold bang.
  assert (Q := unit_intro_left HB).
  eapply sconj_mono; eauto.
  intros M H.
  unfold mjudge in * .
  auto.
Qed.

Lemma bang_intro_right : forall h (P:Prop) B,
  P -> h ||- B ->
    h ||- B ** ! P.
Proof.
  intros.
  apply sconj_sym.
  apply bang_intro_left; auto.
Qed.

(* *********************************************** *)
(* pto                                             *)

Lemma pto_intro : forall M l w,
  (forall l', (l' = l -> M l' = Some w)
    /\ (l' <> l -> M l' = None))
  -> M ||- l |-> w.
Admitted.

Lemma pto_elim : forall M l w,
  (M ||- l |-> w)
  -> (forall l', (l' = l -> M l' = Some w)
    /\ (l' <> l -> M l' = None)).
Admitted.

Lemma pto_get_eq : forall M l w,
  M ||- l |-> w ->
    M l = Some w.
Admitted.

Lemma pto_get_eq1 : forall M l w A,
  M ||- l |-> w ** A ->
    M l = Some w.
Admitted.

Lemma pto_update : forall M l v1 v2,
  M ||- l |-> v1 ->
    set M l v2 ||- l |-> v2.
Admitted.

Lemma pto_update1 : forall M l v1 A,
  M ||- (l |-> v1 ** A) -> forall v2,
    set M l v2 ||- (l |-> v2 ** A).
Admitted.

Lemma pto_pto_eq : forall h x v1 v2,
  h ||- x |-> v1 ->
  h ||- x |-> v2 ->
   v1 = v2.
Admitted.

Lemma pto_pto_eq1 : forall h x v1 v2 A B,
  h ||- x |-> v1 ** A ->
    h ||- x |-> v2 ** B ->
      v1 = v2.
Admitted.

(* *********************************************** *)
(* ptox                                             *)

Lemma pto_ptox : forall M l v,
  M ||- l |-> v
  -> M ||- l |->_.
Admitted.

Lemma pto_ptox1 : forall M l v A,
  M ||- l |-> v ** A
  -> M ||- l |->_ ** A.
Admitted.

Lemma ptox_pto : forall M l,
  (M ||- l |->_)
  -> exists v, M ||- l |-> v.
Proof.
  intros M l H.
  unfold ptox in H.
  unfold mjudge in H.
  apply H.
Qed.

Lemma ptox_pto1 : forall M l A,
  (M ||- l |->_ ** A)
  -> exists v, M ||- l |-> v ** A.
Admitted.

Lemma ptox_elim1 : forall M l A,
  (M ||- l |->_ *^* A)
  -> exists w, M ||- l |-> w *^* A.
Proof.
  apply ptox_pto1.
Qed.

Lemma ptox_update : forall M l v,
  M ||- l |->_
  -> set M l v ||- l |-> v.
Admitted.

Lemma ptox_update1 : forall M l A,
  M ||- l |->_ ** A
  -> forall v, set M l v ||- l |-> v ** A.
Admitted.

(* ********************************************** *)
(* leadsTo                                        *)

Lemma leadsTo_pto : forall M l v,
  M ||- l |~> v
  -> M ||- l |-> v ** top.
Admitted.
Hint Resolve leadsTo_pto : splogic.

Lemma leadsTo_pto1 : forall M l v A,
  M ||- l |~> v ** A
  -> M ||- l |-> v ** top ** A.
Admitted.

Lemma pto_leadsTo : forall M l v,
  M ||- l |-> v
  -> M ||- l |~> v.
Admitted.
Hint Resolve pto_leadsTo : splogic.

Lemma pto_leadsTo1 : forall M l v A,
  M ||- l |-> v ** A
  -> M ||- l |~> v.
Admitted.

Lemma leadsTo_mono : forall M l v A,
  M ||- l |~> v ** A
  -> M ||- l |~> v.
Admitted.
Hint Resolve leadsTo_mono : splogic.

Lemma leadsTo_get_eq : forall M l v,
  M ||- l |~> v
  -> M l = Some v.
Admitted.

Lemma leadsTo_update : forall M l v1 v2,
  M ||- l |~> v1 ->
    set M l v2 ||- l |~> v2.
Admitted.

(* ********************************************** *)
(* leadsTox                                       *)

Lemma leadsTox_leadsTo : forall M l,
  M ||- l |~>_
  -> exists v, M ||- l |~> v.
Admitted.

Lemma leadsTo_leadsTox : forall M l v,
  M ||- l |~> v
  -> M ||- l |~>_.
Admitted.

(* under construction *)

(* ************************************************)
(* WORD-wise                                      *)

(* ************************************************)
(* setW                                           *)

Notation junk := 0.

Notation setW := (MemUpdW) (only parsing).

(* ************************************************)
(* ptoW                                          *)

Lemma ptoW_pto : forall M l v,
  (M ||- l |->w v)
  -> M ||- l |-> v ** l+1 |->_ .
Admitted.
Hint Resolve ptoW_pto : splogic.

Lemma ptoW_pto1 : forall M l v A,
  (M ||- l |->w v ** A)
  -> M ||- (l |-> v ** l+1 |->_ ) ** A .
Admitted.

Lemma pto_ptoW : forall M l v,
  M ||- l |-> v ** l+1 |->_
  -> (M ||- l |->w v).
Admitted.
Hint Resolve pto_ptoW : splogic.

Lemma pto_ptoW1 : forall M l v A,
  M ||- (l |-> v ** l+1 |->_ ) ** A
  -> (M ||- l |->w v ** A).
Admitted.

Lemma ptoW_get_eq : forall M l v,
  M ||- l |->w v ->
    M l = Some v.
Admitted.

Lemma ptoW_get_eq1 : forall M l v A,
  M ||- l |->w v ** A ->
    M l = Some v.
Admitted.

Lemma ptoW_ptoW_eq : forall M l v1 v2,
  M ||- l |->w v1 ->
  M ||- l |->w v2 ->
    v1 = v2.
Admitted.

Lemma ptoW_ptoW_eq1 : forall M l v1 v2 A B,
  M ||- l |->w v1 ** A ->
  M ||- l |->w v2 ** B ->
      v1 = v2.
Admitted.

(* temporary *)
Lemma ptoW_pto_eq : forall M l v1 v2,
  M ||- l |->w v1 ->
  M ||- l |-> v2 ->
    v1 = v2.
Admitted.

(* temporary *)
Lemma ptoW_pto_eq1 : forall M l v1 v2 A B,
  M ||- l |->w v1 ** A ->
  M ||- l |-> v2 ** B ->
      v1 = v2.
Admitted.

Lemma ptoW_update : forall M l v1,
  M ||- l |->w v1 -> forall v2 v',
    setW M l v2 v' ||- l |->w v2.
Admitted.

Lemma ptoW_update1 : forall M l v1 A,
  M ||- l |->w v1 *^* A -> forall v2 v',
    setW M l v2 v' ||- l |->w v2 *^* A.
Admitted.

Lemma ptoW_elim  : forall M l v,
  (M ||- l |->w v)
  -> exists x, M ||- l |-> v ** l+1 |-> x.
Admitted.

Lemma ptoW_elim1 : forall M l v m,
  (M ||- l |->w v *^* m)
  -> exists x, M ||- l |-> v ** l+1 |-> x *^* m.
Admitted.

Lemma ptoW_intro : forall M l v x,
  M ||- l |-> v ** l+1 |-> x
  -> (M ||- l |->w v).
Admitted.

Lemma ptoW_intro1 : forall M l v x m,
  M ||- l |-> v ** l+1 |-> x *^* m
  -> M ||- l |->w v *^* m.
Admitted.

(**********************************************)
(* ptoxW                                      *)

Lemma ptoxW_ptoW : forall M l,
  M ||- l |->w_ -> exists x, M ||- l |->w x.
Admitted.

Lemma ptoxW_ptoW1 : forall M l A,
  M ||- l |->w_ ** A -> exists x, M ||- l |->w x ** A.
Admitted.

Lemma ptoW_ptoxW : forall M l x,
  M ||- l |->w x -> M ||- l |->w_ .
Admitted.

Lemma ptoW_ptoxW1 : forall M l x A,
  M ||- l |->w x ** A -> M ||- l |->w_ ** A.
Admitted.

Lemma ptoxW_update : forall M l,
  M ||- l |->w_ -> forall v2 v',
    MemUpdW M l v2 v' ||- l |->w v2.
Admitted.

Lemma ptoxW_update1 : forall M l A,
  M ||- l |->w_ *^* A
  -> forall v2 v',
  setW M l v2 v' ||- l |->w v2 *^* A.
Admitted.

(*********************************)
(* leadsToW                      *)

Lemma ptoW_leadsToW : forall M l v,
     M ||- l |->w v
  -> M ||- l |~>w v.
Admitted.
Arguments ptoW_leadsToW [M l v].
Hint Resolve ptoW_leadsToW : splogic.

Lemma leadsToW_ptoW : forall M l v,
     M ||- l |~>w v
  -> M ||- l |->w v ** top.
Admitted.
Arguments leadsToW_ptoW [M l v].
Hint Resolve leadsToW_ptoW : splogic.

Lemma ptoW_leadsToW1 : forall M l v A,
     M ||- l |->w v ** A
  -> M ||- l |~>w v.
Admitted.
Arguments ptoW_leadsToW1 [M l v A].
Hint Resolve ptoW_leadsToW1 : splogic.

Lemma leadsToW_leadsTo : forall M l v,
  M ||- l |~>w v
    -> M ||- l |~> v
      /\ M ||- (l + 1) |~>_.
Admitted.
Arguments leadsToW_leadsTo [M l v].
Hint Resolve leadsToW_leadsTo : splogic.

Lemma ptoW_leadsToW_eq1 : forall M l v v' A,
     M ||- l |->w v ** A
  -> M ||- l |~>w v'
  -> v = v'.
Admitted.
Arguments ptoW_leadsToW_eq1 [M l v v' A].

(* temporary *)
Lemma pto_leadsToW_eq1 : forall M l v v' A,
     M ||- l |-> v ** A
  -> M ||- l |~>w v'
  -> v = v'.
Admitted.
Arguments ptoW_leadsToW_eq1 [M l v v' A].

Lemma leadsToW_get_eq : forall M l v,
     M ||- l |~>w v
  -> M l = Some v.
Admitted.
Arguments leadsToW_get_eq [M l v].

Lemma leadsToW_leadsToW_eq : forall M l v v',
  M ||- l |~>w v
  -> M ||- l |~>w v'
  -> v = v'.
Admitted.
Arguments leadsToW_leadsToW_eq [M l v v'].

Lemma leadsToW_update : forall M l v1,
  M ||- l |~>w v1 -> forall v2 v',
    setW M l v2 v' ||- l |~>w v2.
Proof.
  intros M l v1 H v2 v'.
  substH H with (leadsToW_ptoW H).
  apply ptoW_leadsToW1 with top; trivial.
  apply ptoW_update1 with v1; trivial.
Qed.

(**********************************)
(* leadsToxW                      *)

Lemma leadsToW_leadsToxW : forall M l v,
  M ||- l |~>w v
  -> M ||- l|~>w_.
Proof.
  unfold leadsToxW.
  intros M l v H.
  substH H with (leadsToW_ptoW H).
  unfold imprecM.
  apply ptoW_ptoxW1 with v; trivial.
Qed.
Arguments leadsToW_leadsToxW [M l v].

Lemma leadsToxW_leadsToW : forall M l,
  M ||- l |~>w_
  -> exists v, M ||- l|~>w v.
Admitted.
Arguments leadsToxW_leadsToW [M l].

Lemma ptoW_leadsToxW1 : forall M l v A,
     M ||- l |->w v *^* A
  -> M ||- l |~>w_ .
Admitted.
Arguments ptoW_leadsToxW1 [M l v A].

Lemma ptoxW_leadsToxW1 : forall M l A,
     M ||- l |->w_ *^* A
  -> M ||- l |~>w_ .
Admitted.
Arguments ptoxW_leadsToxW1 [M l A].

Lemma leadsToxW_update : forall M l,
  M ||- l |~>w_ -> forall v2 v',
    setW M l v2 v' ||- l |~>w v2.
Admitted.
Arguments leadsToxW_update [M l].

(* ************************************************)
(* meq                                            *)

Lemma meq_intro : forall M,
  M ||- meq M.
Proof.
  unfold mjudge, meq; auto.
Qed.
Hint Resolve meq_intro : splogic.

Lemma meq_elim : forall M M',
  M ||- meq M' -> M = M'.
Proof.
  unfold mjudge, meq; auto.
Qed.

Lemma meq_update : forall M l v x,
  setW M l v x ||- meq (setW M l v x).
Proof.
  intros; apply meq_intro; trivial.
Qed.

Lemma meq_update1 : forall M1 M l v x A,
  (M ||- meq M1 ** A)
  -> (M1 ||- l |~>w_)
  -> setW M l v x ||- meq (setW M1 l v x) ** A.
Admitted.

(*********************************)
(* ptoxBlk                       *)

Lemma imp_ptoxBlk_unit : forall l,
  (ptoxBlk l 0) ==> (unit).
Proof.
  unfold ptoxBlk; intros l; trivial.
Qed.

Lemma imp_unit_ptoxBlk : forall l,
  (unit) ==> (ptoxBlk l 0).
Proof.
  unfold ptoxBlk; intros l; trivial.
Qed.

Hint Resolve imp_ptoxBlk_unit imp_unit_ptoxBlk : splogic.

Lemma imp_ptoxBlk_ptox : forall l,
  (ptoxBlk l 1) ==> (ptox l).
Proof.
  unfold ptoxBlk; intro l; intros.
  apply unit_elim_right; trivial.
Qed.

Lemma imp_ptox_ptoxBlk : forall l,
  (ptox l) ==> (ptoxBlk l 1).
Proof.
  unfold ptoxBlk; intro l; intros.
  apply unit_intro_right; trivial.
Qed.

Hint Resolve imp_ptoxBlk_ptox imp_ptox_ptoxBlk : splogic.

Lemma imp_ptoxBlk_ptoxW : forall l,
  (ptoxBlk l 2) ==> (ptoxW l).
Proof.
  unfold ptoxBlk, ptoxW; intro l; intros.
  apply unit_elim_right; trivial.
  apply sconj_assoc_right; trivial.
Qed.

Lemma imp_ptoxW_ptoxBlk : forall l,
  (ptoxW l) ==> (ptoxBlk l 2).
Proof.
  unfold ptoxBlk, ptoxW; intro l; intros.
  apply sconj_assoc_left; trivial.
  apply unit_intro_right; trivial.
Qed.

Hint Resolve imp_ptoxBlk_ptoxW imp_ptoxW_ptoxBlk : splogic.

Lemma ptoxBlk_split : forall s1 s2 M l,
  M ||- ptoxBlk l (s1 + s2)
  -> M||- (ptoxBlk l s1) ** (ptoxBlk (l+s1) s2).
Admitted.

Lemma ptoxBlk_merge : forall s1 s2 M l,
  M||- (ptoxBlk l s1) ** (ptoxBlk (l+s1) s2)
  -> M ||- ptoxBlk l (s1 + s2).
Admitted.
Lemma imp_ptoxBlk_split : forall l s1 s2,
  (ptoxBlk l (s1 + s2)) ==> ((ptoxBlk l s1) ** (ptoxBlk (l+s1) s2)).
Proof.
  intros l s1 s2 M.
  intro H.
  apply ptoxBlk_split; trivial.
Qed.

Lemma imp_ptoxBlk_merge : forall l s1 s2,
  ((ptoxBlk l s1) ** (ptoxBlk (l+s1) s2)) ==> (ptoxBlk l (s1 + s2)).
Proof.
  intros l s1 s2 M.
  intro H.
  apply ptoxBlk_merge; trivial.
Qed.

Hint Resolve imp_ptoxBlk_split imp_ptoxBlk_merge : splogic.

(* ******************************************************)
(* Basic tactics                                        *)
(* ******************************************************)

Ltac hyprep H y :=
  let H' := fresh in
    (assert (H' := y); try (clear H; rename H' into H)).

Ltac sep_mjudge :=
  apply mjudge_elim.

Ltac sep_mjudgeH H :=
  hyprep H (mjudge_intro H).

Ltac sep_turnon :=
  match goal with
    | H : unit ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : top ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (sconj ?A ?B) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (ptox ?l) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (pto ?l ?x) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (leadsTo ?l ?x) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (leadsTox ?l) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (ptoxW ?l) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (ptoW ?l ?x) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (leadsToW ?l ?x) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (leadsToxW ?l) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (stkSpacePrec ?sp ?size) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (stkSpace ?sp ?size) ?M |- _ => sep_mjudgeH H; sep_turnon
    | _ => (try sep_mjudge); idtac
  end.

Ltac sep_turnoff := unfold mjudge in * .

Tactic Notation "sep" "on" := sep_turnon.

Tactic Notation "sep" "off" := sep_turnoff.

Ltac assocl H :=
  match type of H with
    | _ ||- sconj (ptoxW ?l) _ => idtac
    | _ ||- sconj (ptoW ?l ?x) _ => idtac
    | _ ||- sconj (sconj _ _) _ => hyprep H (sconj_assoc_left H); assocl H
    | _ => idtac
  end.

(* Ltac assocl H := *)
(*   repeat (hyprep H (sconj_assoc_left H)). *)

Ltac assocr :=
  match goal with
    | |- _ ||- sconj (ptoxW ?l) _ => idtac
    | |- _ ||- sconj (ptoW ?l ?w) _ => idtac
    | |- _ ||- sconj (sconj _ _) _ => apply sconj_assoc_right; assocr
    | _ => idtac
  end.

(* Ltac assocr := *)
(*   repeat (apply sconj_assoc_right). *)

Ltac sep_inj :=
  match goal with

    | H : ?M ||- (pto ?l ?v),
      H0 : ?M ||- (pto ?l ?v2) |- _
        => generalize (pto_pto_eq H H0)

    | H : ?M ||- sconj (pto ?l ?v) _,
      H0 : ?M ||- sconj (pto ?l ?v2) _ |- _
        => generalize (pto_pto_eq1 H H0)

    | H : ?M ||- (ptoW ?l ?v),
      H0 : ?M ||- (ptoW ?l ?v2) |- _
        => generalize (ptoW_ptoW_eq H H0)

    | H : ?M ||- sconj (ptoW ?l ?v) _,
      H0 : ?M ||- sconj (ptoW ?l ?v2) _ |- _
        => generalize (ptoW_ptoW_eq1 H H0)

(* temporary *)
    | H : ?M ||- (ptoW ?l ?v),
      H0 : ?M ||- (pto ?l ?v2) |- _
        => generalize (ptoW_pto_eq H H0)
(* temporary *)
    | H : ?M ||- sconj (ptoW ?l ?v) _,
      H0 : ?M ||- sconj (pto ?l ?v2) _ |- _
        => generalize (ptoW_pto_eq1 H H0)

    | H : ?M ||- sconj (ptoW ?l ?v) _,
      H0 : ?M ||- leadsToW ?l ?v2 |- _
        => generalize (ptoW_leadsToW_eq1 H H0)
(* temporary *)
    | H : ?M ||- sconj (pto ?l ?v) _,
      H0 : ?M ||- leadsToW ?l ?v2 |- _
        => generalize (pto_leadsToW_eq1 H H0)

    | H : ?M ||- leadsToW ?l ?v,
      H0 : ?M ||- leadsToW ?l ?v2 |- _
        => generalize (leadsToW_leadsToW_eq H H0)
  end.

Tactic Notation "sep" "inj" := sep_inj.

Ltac sep_update :=
  match goal with
    | |- MemUpdW ?M ?l ?v ?junk ||- ptoW ?l ?v
      => apply ptoxW_update

    | |- MemUpdW ?M ?l ?v ?junk ||- ptoxW ?l
      => apply ptoW_ptoxW with v; apply ptoxW_update

    | |- MemUpdW ?M ?l ?v ?junk ||- sconj (ptoW ?l ?v) ?B =>
      apply ptoxW_update1

    | |- MemUpdW ?M ?l ?v ?junk ||- sconj (ptoxW ?l) ?B =>
      apply ptoW_ptoxW1 with v; apply ptoxW_update1

    | |- MemUpdW ?M ?l ?v ?junk ||- (leadsToW ?l ?v)
      => apply leadsToxW_update

    | |- MemUpdW ?M ?l ?v ?junk ||- (leadsToxW ?l)
      => apply leadsToW_leadsToxW with v; apply leadsToxW_update

    | |- MemUpdW ?M ?l ?v ?junk ||- sconj (meq (MemUpdW ?M1 ?l ?v ?junk)) ?B
      => apply meq_update1; auto

    | _ => fail 1 "Error: format"
  end.

Tactic Notation "sep" "upd" := sep_update.

(**************************************************************)
(* memory shift                                               *)
(**************************************************************)

Ltac sep_lift n :=
  match eval compute in n with
    | O => assocr
    | _ => assocr; apply sconj_sym; sep_lift (pred n)
  end.

Ltac sep_liftH H n :=
  match eval compute in n with
    | O => assocl H
    | _ => assocl H; hyprep H (sconj_sym H); sep_liftH H (pred n)
  end.

Ltac sep_shift_l n :=
  match eval compute in n with
    | 0 => apply sconj_sym
    | _ => sep_lift (pred n); apply sconj_sym
  end.

Tactic Notation "sep" "lift" constr (n) :=
  sep_lift n.

Tactic Notation "sep" "lift" constr (n) "in" hyp (H):=
  sep_liftH H n.

Tactic Notation "sep" "lift" constr (n) "in" hyp (H) "as" hyp (Hx):=
  generalize H; intro Hx; sep_liftH Hx n.

Ltac sep_searchH H C n :=
  match eval compute in n with
    | O => assocl H;
      match type of H with
        | _ ||- C ** ?B => idtac
        | _ ||- ?A ** ?B => fail 1 "Error: Not found"
        | _ => fail 1 "Error:"
      end
    | _ => assocl H;
      match type of H with
        | _ ||- C ** ?B => idtac
        | _ ||- ?A ** ?B => hyprep H (sconj_sym H); sep_searchH H C (pred n)
        | _ => fail 1 "Error:"
      end
  end.

Ltac sep_search C n :=
  match eval compute in n with
    | O => assocr;
      match goal with
        | |- _ ||- sconj C ?B => idtac
        | |- _ ||- sconj ?A ?B => fail 1 "Error: Not found"
        | _ => fail 1 "Error:"
      end
    | _ => assocr;
      match goal with
        | |- _ ||- sconj C ?B => idtac
        | |- _ ||- sconj ?A ?B => apply sconj_sym; sep_search C (pred n)
        | _ => fail 1 "Error:"
      end
  end.

Tactic Notation "sep" "search" constr (C) "in" hyp (H) "with" constr (n) :=
  sep_searchH H C n.

Tactic Notation "sep" "search" constr (C) "in" hyp (H) :=
  sep_searchH H C 10.

Tactic Notation "sep" "search" constr (C) "with" constr (n) :=
  sep_search C n.

Tactic Notation "sep" "search" constr (C) :=
  sep_search C 30.

(**************************************************************)
(* stack operation                                            *)
(**************************************************************)

Lemma stkSpacePrec_stkSpace : forall M sp size,
  M ||- (stkSpacePrec sp size)
  -> M ||- stkSpace sp size.
Admitted.
Arguments stkSpacePrec_stkSpace [M sp size].

Lemma stkSpacePrec_stkSpace1 : forall M sp size A,
  M ||- (stkSpacePrec sp size *^* A)
  -> M ||- stkSpace sp size.
Admitted.
Arguments stkSpacePrec_stkSpace1 [M sp size A].

Lemma stkSpacePrec_ptoxW :forall M sp,
  M ||- stkSpacePrec sp 2
  -> M ||- ptoxW (sp - 2).
Admitted.

Lemma ptoxW_stkSpacePrec :forall M l,
  M ||- ptoxW l
  -> M ||- stkSpacePrec (l+2) 2.
Admitted.

Lemma stkSpacePrec_unit : forall M sp,
  M ||- stkSpacePrec sp 0
  -> M ||- unit.
Admitted.

Lemma stkSpacePrec_unit1 : forall M sp A,
  M ||- (stkSpacePrec sp 0 ** A)
  -> M ||- A.
Admitted.

Lemma unit_stkSpacePrec : forall M sp,
  M ||- unit
  -> M ||- stkSpacePrec sp 0.
Admitted.

Lemma unit_stkSpacePrec_unit : forall M sp A,
  M ||- A
  -> M ||- sconj (stkSpacePrec sp 0) A.
Admitted.

(*************************)
(* ** stack split     ** *)

Lemma stkSpacePrec_splitW : forall M sp size,
  M ||- stkSpacePrec (sp+2) (size+2)
    -> M ||- stkSpacePrec sp size *^*
      (sp |->w_ ).
Admitted.
Arguments stkSpacePrec_splitW [M sp size].

Lemma stkSpacePrec_splitWh : forall M sp size,
  M ||- stkSpacePrec sp size
    -> size >= 2
    -> M ||- stkSpacePrec (sp - 2) (size - 2) *^*
      (sp - 2 |->w_ ).
Admitted.
Arguments stkSpacePrec_splitWh [M sp size].

Lemma stkSpacePrec_splitWh1 : forall M sp size A,
  M ||- stkSpacePrec sp size *^* A
    -> size >= 2
    -> M ||- stkSpacePrec (sp - 2) (size - 2) *^*
      (sp -2 |->w_ *^* A).
Admitted.
Arguments stkSpacePrec_splitWh1 [M sp size A].

Lemma stkSpacePrec_splitW1 : forall M sp size A,
  M ||- stkSpacePrec (sp + 2) (size + 2) *^* A
    -> M ||- stkSpacePrec sp size *^*
      (sp |->w_ *^* A).
Admitted.
Arguments stkSpacePrec_splitW1 [M sp size A].

Lemma stkSpacePrec_mergeW : forall M sp size,
  M ||- stkSpacePrec (sp - 2) (size - 2) *^* sp - 2 |->w_
    -> sp >= 2
    -> size >= 2
    ->  M ||- stkSpacePrec sp size.
Admitted.
Arguments stkSpacePrec_mergeW [M sp size].

Lemma stkSpacePrec_mergeW1 : forall M sp size A,
  M ||- stkSpacePrec (sp - 2) (size - 2) *^*
    (sp - 2 |->w_ *^* A)
    -> sp >= 2
    -> size >= 2
    ->  M ||- stkSpacePrec sp size *^* A.
Admitted.
Arguments stkSpacePrec_mergeW1 [M sp size A].

Lemma stkSpacePrec_mergeWh : forall M sp size,
  M ||- stkSpacePrec sp size *^* sp |->w_
    ->  M ||- stkSpacePrec (sp + 2) (size + 2).
Admitted.
Arguments stkSpacePrec_mergeWh [M sp size].

Lemma stkSpacePrec_mergeWh1 : forall M sp size A,
  M ||- stkSpacePrec sp size *^*
    (sp |->w_ *^* A)
    ->  M ||- stkSpacePrec (sp + 2) (size + 2) *^* A.
Admitted.
Arguments stkSpacePrec_mergeWh1 [M sp size A].

Ltac stk_splitw :=
  match goal with
    | |- _ ||- stkSpacePrec (?sp + 2) (?size + 2) => apply stkSpacePrec_mergeWh
    | |- _ ||- sconj (stkSpacePrec (?sp + 2) (?size +2)) _ => apply stkSpacePrec_mergeWh1
    | |- _ ||- stkSpacePrec ?sp ?size =>
      apply stkSpacePrec_mergeW;
        [ idtac
          | simpl; auto with arith; lia || fail 1 "Error: top address of stake should be >= 2"
          | simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= 2"
        ]
    | |- _ ||- sconj (stkSpacePrec ?sp ?size) _ =>
      apply stkSpacePrec_mergeW1;
        [ idtac
          | simpl; auto with arith; lia || fail 1 "Error: top address of stake should be >= 2"
          | simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= 2"
        ]
    | _ => fail 1 "Error: cannot split the current goal"
  end.

Ltac stk_splitwH H :=
  match type of H with
    | _ ||- stkSpacePrec (?sp + 2) (?size + 2)
      => hyprep H (stkSpacePrec_splitW H)
    | _ ||- sconj (stkSpacePrec (?sp + 2) (?size +2)) _
      => hyprep H (stkSpacePrec_splitW1 H)
    | _ ||- stkSpacePrec ?sp ?size
      => let Hx := fresh "H" in
        (assert (Hx : size >= 2);
          [ simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= 2" | idtac];
          hyprep H (stkSpacePrec_splitWh H Hx); clear Hx)
    | _ ||- sconj (stkSpacePrec ?sp ?size) _
      => let Hx := fresh "H" in
        (assert (Hx : size >= 2);
          [ simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= 2" | idtac];
            hyprep H (stkSpacePrec_splitWh1 H Hx); clear Hx)
    | _ => fail 1 "Error: cannot split the current hypothesis"
  end.

Lemma stkSpacePrec_split : forall M sp size k,
  M ||- stkSpacePrec (sp+k) (size+k)
    -> M ||- stkSpacePrec (sp+k) k *^* stkSpacePrec sp size.
Admitted.
Arguments stkSpacePrec_split [M sp size k].

Lemma stkSpacePrec_splith : forall M sp size k,
  M ||- stkSpacePrec sp size
    -> k <= size
    -> M ||- stkSpacePrec (sp - k) (size - k) *^* stkSpacePrec sp k.
Admitted.
Arguments stkSpacePrec_splith [M sp size k].

Lemma stkSpacePrec_splith1 : forall M sp size k A,
  M ||- stkSpacePrec sp size *^* A
    -> k <= size
    -> M ||- stkSpacePrec sp k *^* stkSpacePrec (sp - k) (size - k) *^* A.
Admitted.
Arguments stkSpacePrec_splith1 [M sp size k A].

Lemma stkSpacePrec_split1 : forall M sp size k A,
  M ||- stkSpacePrec (sp + k) (size + k) *^* A
    -> M ||- stkSpacePrec (sp+k) k *^* stkSpacePrec sp size *^* A.
Admitted.
Arguments stkSpacePrec_split1 [M sp size k A].

Lemma stkSpacePrec_merge : forall M sp size k,
  M ||- stkSpacePrec (sp - k) (size - k) *^* stkSpacePrec sp k
    -> sp >= k
    -> size >= k
    ->  M ||- stkSpacePrec sp size.
Admitted.
Arguments stkSpacePrec_merge [M sp size k].

Lemma stkSpacePrec_merge1 : forall M sp size k A,
  M ||- stkSpacePrec (sp - k) (size - k) *^* stkSpacePrec sp k *^* A
    -> sp >= k
    -> size >= k
    ->  M ||- stkSpacePrec sp size *^* A.
Admitted.
Arguments stkSpacePrec_merge1 [M sp size k A].

Lemma stkSpacePrec_mergeh : forall M sp size k,
  M ||- stkSpacePrec sp size *^* stkSpacePrec (sp+k) k
    ->  M ||- stkSpacePrec (sp + k) (size + k).
Admitted.
Arguments stkSpacePrec_mergeh [M sp size k].

Lemma stkSpacePrec_mergeh1 : forall M sp size k A,
  M ||- stkSpacePrec sp size *^* stkSpacePrec (sp+k) k *^* A
    ->  M ||- stkSpacePrec (sp + k) (size + k) *^* A.
Admitted.
Arguments stkSpacePrec_mergeh1 [M sp size k A].

Ltac stk_split k :=
  match goal with
    | |- _ ||- stkSpacePrec (?sp + k) (?size + k) => apply stkSpacePrec_mergeh
    | |- _ ||- sconj (stkSpacePrec (?sp + k) (?size +k)) _ => apply stkSpacePrec_mergeh1
    | |- _ ||- stkSpacePrec ?sp ?size
      => apply stkSpacePrec_merge with k;
        [ idtac
          | simpl; auto with arith; lia || fail 1 "Error: top address of stake should be >= k"
          | simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= k"
        ]
    | |- _ ||- sconj (stkSpacePrec ?sp ?size) _
      => apply stkSpacePrec_merge1 with k;
        [ idtac
          | simpl; auto with arith; lia || fail 1 "Error: top address of stake should be >= k"
          | simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= k"
        ]
    | _ => fail 1 "Error: cannot split the current goal"
  end.

Ltac stk_splitH H k :=
  match type of H with
    | _ ||- stkSpacePrec (?sp + k) (?size + k)
      => hyprep H (stkSpacePrec_split H)
    | _ ||- sconj (stkSpacePrec (?sp + k) (?size + k)) _
      => hyprep H (stkSpacePrec_split1 H)
    | _ ||- stkSpacePrec ?sp ?size
      => let Hx := fresh "H" in
        (assert (Hx : size >= k);
          [ simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= k" | hyprep H (stkSpacePrec_splith H Hx); clear Hx])
    | _ ||- sconj (stkSpacePrec ?sp ?size) _
      => let Hx := fresh "H" in
        (assert (Hx : size >= k);
          [ simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= k" | hyprep H (stkSpacePrec_splith1 H Hx); clear Hx])
    | _ => fail 1 "Error: cannot split the current hypothesis"
  end.

Tactic Notation "sep" "stksplit" := stk_splitw.

Tactic Notation "sep" "stksplit" "in" hyp (H) := stk_splitwH H.

Tactic Notation "sep" "stksplit" constr (k) := stk_split k.

Tactic Notation "sep" "stksplit" constr (k) "in" hyp (H) := stk_splitH H k.

(**************************************************************)
(* memory re-order macth                                      *)
(**************************************************************)

Ltac matchhp ig ih sg sh Hp :=
  match goal with
    | |- _ ||- top => apply top_intro (* true *)
    | |- ?h ||- ?A =>
      match type of Hp with
        | h ||- A => exact Hp (* assumption *)
      end

    | |- _ ||- unit => try (apply unit_intro)
    | |- _ ||- bang _ => apply bang_intro; auto

    | |- ?h ||- ptoxW ?l => (* match: ptoW |- ptoxW *)
      match type of Hp with
        | h ||- ptoW l ?v =>
          apply (ptoW_ptoxW Hp); trivial; fail 1 "Error : unknown"
      end

    | |- _ ||- sconj _ unit => apply unit_intro_right;
      matchhp (pred ig) sh (pred sg) sh Hp
    | |- _ ||- sconj unit _ => apply unit_intro_left;
      matchhp (pred ig) sh (pred sg) sh Hp

    | |- _ ||- sconj (bang _) _ => apply bang_intro_left;
      [auto | matchhp (pred ig) sh (pred sg) sh Hp]
    | |- _ ||- sconj _ (bang _) => apply bang_intro_right;
      [auto | matchhp (pred ig) sh (pred sg) sh Hp]

(*     | [NI : ~ set_in ?x ?s |- *)
(*       ?h ||- fas ?P (set_add ?x ?s)] => apply fas_intro1;  *)
(*     [assocr; matchhp (S ig) sh (S sg) sh | assumption] *)

(*     | [NI : ~ set_in ?x ?s |- *)
(*       ?h ||- sconj (fas ?P (set_add ?x ?s)) _] => apply fas_intro;  *)
(*      [assocr; matchhp (S ig) sh (S sg) sh | assumption] *)

    | |- _ ||- sconj _ (bang _) => apply bang_intro_right;
      [auto | matchhp (pred ig) sh (pred sg) sh Hp]

    | |- ?h ||- sconj ?A ?C => (* match left *)
      match type of Hp with
        | h ||- sconj A ?B =>
          let h1 := fresh "h" in
            (apply (sconj_mono_right Hp);
              (clear h Hp; intros h Hp) || (clear Hp; intros h1 Hp);
                assocl Hp; assocr;
                matchhp (pred ig) (pred sh) (pred sg) (pred sh) Hp)
      end

    | |- ?h ||- sconj (ptoxW ?l) ?C => (* match left: ptoW |- ptoxW *)
      match type of Hp with
        | h ||- sconj (ptoW l ?v) ?B =>
          let h1 := fresh "h" in
            (apply (sconj_mono (A':=ptoxW l)(B':=C) Hp);
              (clear h Hp; intros h Hp) || (clear Hp; intros h1 Hp);
                [ apply (ptoW_ptoxW Hp); fail 1 "Error : unknown"
                  |
                  assocl Hp; assocr;
                  matchhp (pred ig) (pred sh) (pred sg) (pred sh) Hp ])
      end

    | |- ?h ||- sconj ?C ?B => (* match right *)
      match type of Hp with
        | h ||- sconj ?A B =>
          let h' := fresh "h" in
            (apply (sconj_mono_left Hp);
              (clear h Hp; intros h Hp) || (clear Hp; intros h' Hp);
                assocl Hp; assocr;
                matchhp (pred ig) (pred sh) (pred sg) (pred sh) Hp)
      end

    | |- ?h ||- sconj ?C ?D => (* shift *)
      match type of Hp with
        | h ||- sconj ?A ?B =>
          match eval compute in ig with
            | O => (* no more shift on goal *)
              match eval compute in ih with
            | O => idtac (* finished *)
                | _ => (* shift hyp, continue with matching *)
                  hyprep Hp (sconj_sym Hp); assocl Hp;
                  matchhp sg (pred ih) sg sh Hp
              end
            | _ => (* shift goal *)
              apply sconj_sym; assocr;  matchhp (pred ig) ih sg sh Hp
          end
      end
    | _ => match type of Hp with
             | _ ||- sconj _ unit => hyprep Hp (unit_elim_right Hp);
               matchhp ig (pred sh) sg (pred sh) Hp
             | _ ||- sconj unit _ => hyprep Hp (unit_elim_left Hp);
               matchhp ig (pred sh) sg (pred sh) Hp
             | _ => idtac
           end
(*     | _ => idtac *)
  end.

Ltac simplsep sizeg sizeh Hp :=
  match type of Hp with
    | ?h ||- _ =>
      match goal with
        | |- h ||- _ =>
          assocl Hp; assocr; matchhp sizeg sizeh sizeg sizeh Hp
      end
 end.

Tactic Notation "sep" "matchH" hyp (H) "with" constr (size) :=
  simplsep size size H.

(**************************************************************)
(* memory macth                                               *)
(**************************************************************)

Ltac sep_trivial :=
  match goal with

    | |- emp ||- unit =>
      apply unit_intro; trivial

    | |- ?M ||- top =>
      apply top_intro; trivial

    | H: ?M ||- pto ?l ?v
      |- ?M ||- ptox ?l => apply pto_ptox with v; trivial

    | H : ?M ||- stkSpacePrec ?sp 2
       |- ?M ||- ptoxW (?sp-2) =>
        apply (stkSpacePrec_ptoxW H); trivial

    | H : ?M ||- ptoxW ?l
       |- ?M ||- stkSpacePrec (?l+2) 2 =>
        apply (ptoxW_stkSpacePrec H); trivial

    | H : ?M ||- (stkSpacePrec ?sp ?size)
       |- ?M ||- stkSpace ?sp ?size =>
        apply (stkSpacePrec_stkSpace H); trivial

    | H : ?M ||- sconj (stkSpacePrec ?sp ?size) _
       |- ?M ||- stkSpace ?sp ?size =>
        apply (stkSpacePrec_stkSpace1 H); trivial

    | H : ?M ||- sconj (ptoW ?l ?v) _
       |- ?M ||- leadsToW ?l ?v => (* match: ptoW |- leadsToW *)
          apply (ptoW_leadsToW1 H); trivial

    | H : ?M ||- sconj (ptoW ?l ?v) _
       |- ?M ||- leadsToxW ?l => (* match: ptoW, ptoxW |- leadsToxW *)
          apply (ptoW_leadsToxW1 H); trivial

    | H : ?M ||- sconj (ptoxW ?l) _
       |- ?M ||- leadsToxW ?l => (* match: ptoW, ptoxW |- leadsToxW *)
          apply (ptoxW_leadsToxW1 H); trivial

    | H: ?M ||- ptoW ?l ?v
      |- ?M ||- ptoxW ?l => apply ptoW_ptoxW with v; trivial

    | H: ?M ||- leadsToW ?l ?v
      |- ?M ||- leadsToxW ?l => apply leadsToW_leadsToxW with v; trivial

    | H: ?M ||- ?A
      |- ?M ||- ?B => auto with splogic; fail

    | |- ?A ==> ?B => intros; auto with splogic; fail

    | _ => trivial
  end.

Tactic Notation "sep" "trivial" := sep_trivial.

Ltac sep_simpl :=
  match goal with

(* unit *)
    | H : ?M ||- unit ** ?A
       |- _  =>
        hyprep H (unit_elim_left H)

    |  |- ?M ||- unit ** ?A =>
        apply unit_intro_left

    | H : ?M ||- ?A ** unit
       |- _  =>
        hyprep H (unit_elim_right H)

    |  |- ?M ||- ?A ** unit =>
        apply unit_intro_right

(* stkSpacePrec empty *)
    | H : ?M ||- (stkSpacePrec ?sp 0) ** ?A
       |- _  =>
        hyprep H (stkSpacePrec_unit1 H)

    | H : ?M ||- stkSpacePrec ?sp 0
       |- _  =>
        hyprep H (stkSpacePrec_unit H)

    | |- ?M ||- sconj (stkSpacePrec ?sp 0) _ =>
      apply stkSpacePrec_unit1

    | |- ?M ||- stkSpacePrec ?sp 0 =>
      apply stkSpacePrec_unit

    | _ => trivial
  end.

Tactic Notation "sep" "simpl" := sep_simpl.

(* obselete *)
Ltac sep_elim_left H :=
  match type of H with

    | ?M ||- unit =>
      hyprep H (unit_elim H); subst M

    | ?M ||- (ptoxW ?l) =>
      let v:= fresh "v" in
      (hyprep H (ptoxW_ptoW H); destruct H as [v H])

    | ?M ||- sconj (ptoxW ?l) ?A =>
      let v:= fresh "v" in
      (hyprep H (ptoxW_ptoW1 H); destruct H as [v H])

    | _ => fail 1 "Format Error : M |- l |-> _ * _ "
  end.

Tactic Notation "sep" "elim_left" hyp (H) := sep_elim_left H.

(* new *)

Ltac sep_match_left H :=
  match goal with
    | |- ?M ||- sconj ?A' ?B' =>
      match type of H with
        | M ||- sconj ?A ?B =>
          let M1 := fresh "M" in
            (apply (sconj_mono (A':=A') (B':=B') H);
              (clear M H; intros M H; sep_trivial)
              || (clear H; intros M1 H; sep_trivial))
      end
  end.

Tactic Notation "sep" "match_left" hyp (H) := sep_match_left H.

Ltac sep_subst_left A :=
  match goal with
    | |- ?M ||- ?A' ** ?B' =>
      apply sconj_mono_left with A; [ idtac | sep_trivial ]
  end.

Ltac sep_subst_leftH H A' :=
  match type of H with
    | ?M ||- ?A ** ?B =>
      let Hx := fresh "Hx" in
        (assert (Hx : A ==> A');
          [sep_trivial
            | hyprep H (sconj_mono_left H (A':=A') Hx); clear Hx])
  end.

Tactic Notation "sep" "subst_left" "with" constr (A) "in" hyp (H) := sep_subst_leftH H A.

Tactic Notation "sep" "subst_left" "with" constr (A) := sep_subst_left A.

(* new *)
Ltac sep_elim H :=
  match type of H with

    | ?M ||- unit =>
      hyprep H (unit_elim H); subst M

    | ?M ||- unit ** ?A =>
      hyprep H (unit_elim_left H)

    | ?M ||- (ptoW ?l ?v) =>
      hyprep H (ptoW_pto H)

    | ?M ||- (ptoW ?l ?v) ** ?A =>
      hyprep H (ptoW_pto1 H)

    | ?M ||- (ptoxW ?l) =>
      let v:= fresh "v" in
      (hyprep H (ptoxW_ptoW H); destruct H as [v H])

    | ?M ||- sconj (ptoxW ?l) ?A =>
      let v:= fresh "v" in
      (hyprep H (ptoxW_ptoW1 H); destruct H as [v H])

    | ?M ||- (leadsToxW ?l) =>
      let v:= fresh "v" in
      (hyprep H (leadsToxW_leadsToW H); destruct H as [v H])

    | _ => fail 1 "Format Error : M |- l |-> _ * _ "
  end.

Tactic Notation "sep" "elim" hyp (H) := sep_elim H.

Tactic Notation "sep" "destruct" hyp (H) := sep_elim H.

Ltac sep_exists_left v :=
  match goal with

    | |- ?M ||- sconj (ptoxW ?l) ?A =>
      apply ptoW_ptoxW1 with v

    | |- ?M ||- ptoxW ?l =>
      apply ptoW_ptoxW with v

    | |- ?M ||- leadsToxW ?l =>
      apply leadsToW_leadsToxW with v
    | _ => fail 1 "Format Error : M |- l |-> _ * _ "
  end.

Tactic Notation "sep" "exists_left" constr (v) := sep_exists_left v.

Tactic Notation "sep" "exists" constr (v) := sep_exists_left v.

(* some tactics added by Xinyu *)
Ltac sep_leqv_subst m :=
  match goal with
    | |- ?M ||- ?A *^* ?B =>
      let Hx := fresh in
        (assert (Hx : leqvM m A);
          [(auto || idtac) | (apply (leqvM_app_subst (H := M) (mstar_eqv_subst_left B Hx)); auto; clear Hx) || fail 1 "failed" ])
    | _ => idtac
  end.

Tactic Notation "sep" "leqv_subst" "with" constr (m) := sep_leqv_subst m.

Ltac sep_leqv_substH H m :=
  match type of H with
    | ?M ||- ?A *^* ?B =>
      let Hx := fresh in
        (assert (Hx : leqvM A m);
        [(auto || idtac) | hypreplace H (leqvM_app_subst (mstar_eqv_subst_left B Hx) H)])
    | _ => idtac
  end.

Tactic Notation "sep" "leqv_subst" "in" hyp (H) "with" constr (m) := sep_leqv_substH H m.

Ltac sep_weaker_subst H m :=
  match type of H with
    | ?M ||- ?A *^* ?B =>
      let Hx := fresh in
        (assert (Hx : forall H, A H -> m H);
          [(auto || idtac) | hypreplace H (mstar_subst_weaker_left H Hx)])
    | _ => idtac
  end.

Tactic Notation "sep" "weaker_subst" "in" hyp (H) "with" constr (m) := sep_weaker_subst H m.

Lemma stkSpace_sp_ge_sz:
forall M sp sz,
  M ||- stkSpace sp sz -> sp >= sz.
Proof.
  intros.
  sep off. unfold stkSpace in H.
  inversion H; auto.
Qed.

Lemma stkSpace_sp_ge_sz1:
forall M sp sz B,
  M ||- stkSpace sp sz *^* B -> sp >= sz.
Admitted.

Lemma stkSpacePrec_sp_ge_sz:
forall M sp sz,
  M ||- stkSpacePrec sp sz -> sp >= sz.
Admitted.

Lemma stkSpacePrec_sp_ge_sz1:
forall M sp sz B,
  M ||- stkSpacePrec sp sz *^* B -> sp >= sz.
Proof.
  intros. sep off.
  unfold mstar in H.
  InvertAll.
  apply stkSpacePrec_sp_ge_sz with x; auto.
Qed.

Ltac sep_update2 :=
  match goal with
    | |- MemUpdW ?M ?l ?v ?junk ||- ptoW ?l ?v
      => apply ptoxW_update
    | |- MemUpdW ?M ?l ?v ?junk ||- ptoxW ?l
      => apply ptoW_ptoxW with v; apply ptoxW_update
    | |- MemUpdW ?M ?l ?v ?junk ||- (ptoW ?l ?v) *^* ?B =>
      apply ptoxW_update1
    | |- MemUpdW ?M ?l ?v ?junk ||- (ptoxW ?l) *^* ?B =>
      apply ptoW_ptoxW1 with v; apply ptoxW_update1
    | |- MemUpdW ?M ?l ?v ?junk ||- (leadsToW ?l ?v)
      => apply leadsToxW_update
    | |- MemUpdW ?M ?l ?v ?junk ||- (leadsToxW ?l)
      => apply leadsToW_leadsToxW with v; apply leadsToxW_update
    | |- MemMod.put ?M ?l ?v ||- (pto ?l ?v) *^* ?B
      => apply ptox_update1
    | _ => fail 1 "Error: format"
  end.

Tactic Notation "sep" "upd2" := sep_update2.

Lemma ptoW_precise:
forall l v, precise (l |->w v).
Admitted.

Lemma ptoW_indom1:
forall M l v A,
  (l |->w v *^* A) M -> MemMod.in_dom l M /\ MemMod.in_dom (l+1) M.
Admitted.

Lemma ptoxW_indom1:
forall M l A,
  (l |->w_ *^* A) M -> MemMod.in_dom l M /\ MemMod.in_dom (l+1) M.
Admitted.


(******************************************************************************)
(*       Copyright (C) 2014 Florent Hivert <florent.hivert@lri.fr>            *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code 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.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
Add Rec LoadPath "ALEA/src" as ALEA.
Add Rec LoadPath "../Combi/LRrule".

Set Implicit Arguments.
Unset Strict Implicit.

Require Import ssreflect ssrfun ssrbool eqtype choice ssrnat seq
        ssrint div rat fintype bigop path ssralg ssrnum.
(* Import bigop before ssralg/ssrnum to get correct printing of \sum \prod*)

Require Import tools combclass ordtype subseq partition tableau Schensted std stdtab.
Require Import hook.

Section Identity.

Definition is_stdtab_pair_of_shape sh p :=
  (is_stdtab_of_shape sh p.1) && (is_stdtab_of_shape sh p.2).
Definition is_stdtab_pair_of_n n p :=
  [&& (is_stdtab_of_n n p.1), (is_stdtab_of_n n p.2) & (shape p.1 == shape p.2)].

Variable n : nat.

Section Shape.

Variable sh : intpartn n.

Definition stpsh : predArgType := ((stdtabsh sh) * (stdtabsh sh))%type.
Definition seq_of_stpsh (p : stpsh) := let: (p1, p2) := p in (val p1, val p2).
Definition stpsh_of_seq p : is_stdtab_pair_of_shape sh p -> stpsh.
Proof. move=> /andP [] /(@StdtabSh sh) p1 /(@StdtabSh sh) p2; exact: (p1, p2). Defined.

Lemma stpshP (p : stpsh) : is_stdtab_pair_of_shape sh (seq_of_stpsh p).
Proof.
  rewrite /is_stdtab_pair_of_shape.
  case: p => [p1 p2] /=.
  by rewrite !stdtabshP !stdtabsh_shape !eq_refl.
Qed.

Lemma seq_of_stpshK p : (stpsh_of_seq (stpshP p)) = p.
Proof.
  apply/eqP; rewrite /stpsh_of_seq /eq_op /=.
  apply/andP; split; case: p => [[p1 H1] [p2 H2]] /=; apply /eqP => /=.
  - case: (elimTF _ _) => /= H _; by apply val_inj.
  - case: (elimTF _ _) => /= _ H; by apply val_inj.
Qed.

Lemma stpsh_of_seqK p (Hp : is_stdtab_pair_of_shape sh p) :
  seq_of_stpsh (@stpsh_of_seq p Hp) = p.
Proof.
  rewrite /stpsh_of_seq /=.
  case: (elimTF _ _) => /= _ _.
  by case: p {Hp}.
Qed.

Lemma stpsh_val_rect :
  forall F : stpsh -> Type,
    (forall p Px, F (@stpsh_of_seq p Px)) ->
    forall u : stpsh, F u.
Proof. move=> F H p; rewrite -(seq_of_stpshK p); exact: H. Qed.

Canonical stpsh_subType := SubType _ seq_of_stpsh stpsh_of_seq stpsh_val_rect stpsh_of_seqK.
Definition stpsh_eqMixin := Eval hnf in [eqMixin of stpsh by <:].
Definition stpsh_subCountType := Eval hnf in [subCountType of stpsh_subType].

Lemma enum_stpshP : Finite.axiom (T:=stpsh_subCountType) (enum stpsh).
Proof.
  rewrite /Finite.axiom => [[p1 p2]].
  rewrite enumT /= -(@enumP _ (p1, p2)).
  by apply eq_count => [[x1 x2]] /=.
Qed.

Definition stpsh_finMixin := Eval hnf in FinMixin enum_stpshP.
Definition stpsh_finType := Eval hnf in FinType stpsh_subCountType stpsh_finMixin.
Definition stpsh_subFinType := Eval hnf in [subFinType of stpsh_finType].

Lemma card_stpsh : #|stpsh_finType| = #|stdtabsh_finType sh|^2.
Proof.
  rewrite -mulnn -card_prod.
  by rewrite !cardE enumT unlock /=.
Qed.

End Shape.

Lemma stpn_PredEq (ev : intpartn_subFinType n) :
  predI (is_stdtab_pair_of_n n) (pred1 (val ev) \o shape \o (fun x => x.1)) =1
  is_stdtab_pair_of_shape ev.
Proof.
  move=> [p1 p2] /=; rewrite /is_stdtab_pair_of_n /is_stdtab_pair_of_shape /=.
  case: (altP (shape p1 =P ev)) => [Hsh1|]; last by rewrite !andbF /=.
  rewrite [shape p1 == _]eq_sym Hsh1 !andbT.
  case: (altP (shape p2 =P ev)) => [Hsh2|]; last by rewrite ?andbF /=.
  by rewrite !andbT /size_tab Hsh1 Hsh2 intpartn_sumn eq_refl !andbT.
Qed.

Lemma stpn_partition_shape tabp :
  is_stdtab_pair_of_n n tabp -> is_part_of_n n ((shape \o (fun x => x.1)) tabp).
Proof.
  rewrite /is_stdtab_pair_of_n; move: tabp => [p1 p2] /= /andP [].
  rewrite /size_tab => /andP [] /andP [] H _ -> _ /=.
  exact: is_part_sht.
Qed.

Structure stpn : predArgType :=
  STPN {stpnval :> seq (seq nat) * seq (seq nat); _ : is_stdtab_pair_of_n n stpnval }.
Canonical stpn_subType := Eval hnf in [subType for stpnval].
Definition stpn_eqMixin := Eval hnf in [eqMixin of stpn by <:].
Canonical stpn_eqType := Eval hnf in EqType stpn stpn_eqMixin.
Definition stpn_choiceMixin := Eval hnf in [choiceMixin of stpn by <:].
Canonical stpn_choiceType := Eval hnf in ChoiceType stpn stpn_choiceMixin.
Definition stpn_countMixin := Eval hnf in [countMixin of stpn by <:].
Canonical stpn_countType := Eval hnf in CountType stpn stpn_countMixin.
Canonical stpn_subCountType := Eval hnf in [subCountType of stpn].

Definition type :=
  union_finType
    (Pi := fun sh : seq nat => is_stdtab_pair_of_shape sh)
    (fun p : intpartn_subFinType n => (stpsh_subFinType p))
    stpn_PredEq stpn_partition_shape stpn_subCountType.
Canonical stpn_finType := Eval hnf in [finType of stpn for type].
Canonical stpn_subFinType := Eval hnf in [subFinType of stpn].

Lemma card_stpn : #|stpn_finType| = \sum_(p : intpartn n) (n`! %/ (F_deno p))^2.
Proof.
  rewrite card_unionE.
  rewrite (eq_bigr (fun sh : intpartn_subFinType n => #|stdtabsh_finType sh|^2)); first last.
  move=> i _; by rewrite card_stpsh.
  apply eq_bigr => sh _.
  by rewrite HookLengthFormula intpartn_sumn.
Qed.

Lemma RSstdmapP (s : stdwordn n) : is_stdtab_pair_of_n n (RStabmap s).
Proof.
  have := RStabmap_spec s.
  have := RStabmapE s.
  rewrite /is_stdtab_pair_of_n /is_RStabpair /=.
  move H : (RStabmap s) => [p q] /= HRS /and3P [] Hp Hq /eqP Hsh.
  rewrite /size_tab -Hsh Hq eq_refl /= !andbT.
  rewrite HRS RSstdE stdwordnP /=.
  by rewrite -/(size_tab _) size_RS size_sdtn eq_refl !andbT.
Qed.
Definition RSstd (s : stdwordn n) : stpn := STPN (RSstdmapP s).

Lemma rspair_stpnP (p : stpn) : is_RStabpair (val p).
Proof.
  rewrite /is_RStabpair; case: p => [[p q]] /=.
  by rewrite /is_stdtab_pair_of_n /= => /and3P [] /andP [] /andP [] -> _ _ /andP [] -> _ ->.
Qed.
Definition rspair_stpn (p : stpn) : (rstabpair nat_ordType) := RSTabPair (rspair_stpnP p).
Lemma RSstdmap_invP (p : stpn) : is_std_of_n n (RStabinv (rspair_stpn p)).
Proof.
  have /= := RStabinvK (rspair_stpn p).
  rewrite /RStab /= => Hcan.
  have := erefl (val (rspair_stpn p)).
  rewrite -{1}Hcan {Hcan} /= => Hp.
  rewrite /is_std_of_n /=; apply/andP; split.
  - rewrite -RSstdE -RStabmapE Hp {Hp}.
    case: p => [[p q]]; by rewrite /is_stdtab_pair_of_n /= => /andP [] /andP [].
  - rewrite -size_RS -RStabmapE Hp {Hp}.
    case: p => [[p q]]; by rewrite /is_stdtab_pair_of_n /= => /andP [] /andP [].
Qed.
Definition RSstdinv (p : stpn) : stdwordn n := StdWordN (RSstdmap_invP p).

Lemma RSstdinvK : cancel RSstdinv RSstd.
Proof.
  move=> pq; have := RStabinvK (rspair_stpn pq).
  rewrite /RStab /= => Hcan.
  have := erefl (val (rspair_stpn pq)).
  rewrite -{1}Hcan {Hcan} /= => Hpq.
  move: pq Hpq => [[p q]] Hpq; rewrite /RSstd /RSstdinv /= => H.
  by apply val_inj => /=.
Qed.
Lemma RSstdK : cancel RSstd RSstdinv.
Proof.
  move=> s /=; apply val_inj; rewrite /= -(RStabK s).
  congr (RStabinv _); by apply val_inj => /=.
Qed.
Lemma bijRSstd : bijective RSstd.
Proof. split with (g := RSstdinv). exact: RSstdK. exact: RSstdinvK. Qed.

Theorem Ident : n`! = \sum_(p : intpartn n) (n`! %/ (F_deno p))^2.
Proof. rewrite -{1}card_stdwordn -card_stpn; exact: bij_card bijRSstd. Qed.

Open Scope ring_scope.

Import GRing.Theory.
Import Num.Theory.

Theorem IdentBis : 1 / (n`!)%:Q = \sum_(p : intpartn n) 1 / (F_deno p)%:Q ^+ 2.
Proof.
  rewrite -[RHS]mulr1.
  have Hfn0 : n`!%:Q != 0 by rewrite intr_eq0 eqz_nat -lt0n fact_gt0.
  rewrite -{5}(@divff _ ((n`!%:Q) ^+ 2)); last by rewrite sqrf_eq0.
  rewrite mulrA mulr_suml.
  rewrite (eq_bigr (fun p : intpartn n => ((n`! %/ (F_deno p)) ^ 2)%N%:Q)); first last.
    move=> p _; rewrite PoszM intrM.
    have -> : (n`! %/ F_deno p)%:Q = (n`!)%:Q / (F_deno p)%:Q.
      rewrite -[LHS]mulr1 -{2}(@divff _ (F_deno p)%:Q); first last.
        rewrite intr_eq0 eqz_nat /=; exact: (F_deno_non0 p).
      rewrite !mulrA -intrM -PoszM.
      have := divF_deno p.
      by rewrite intpartn_sumn dvdn_eq => /eqP ->.
    by rewrite -expr2 expr_div_n mulrC mul1r.
  rewrite -!(big_morph intr (@intrD _) (id2 := 0)) //=.
  rewrite -!(big_morph Posz PoszD (id2 := 0%N)) //=.
  rewrite -Ident expr2.
  by rewrite invfM mulrA divff.
Qed.

End Identity.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall B O P T R Tprime : Universe, ((wd_ O P /\ (wd_ R B /\ (wd_ T R /\ (wd_ T Tprime /\ (wd_ B O /\ (wd_ R O /\ (wd_ R Tprime /\ (col_ R B R /\ (col_ R B T /\ col_ R T Tprime))))))))) -> col_ R B Tprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O L Lprime : Universe, ((wd_ B O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ A O /\ (wd_ A Bprime /\ (wd_ A Aprime /\ (wd_ O Aprime /\ (wd_ O Lprime /\ (wd_ C Bprime /\ (wd_ O L /\ (wd_ B Cprime /\ (col_ O A B /\ (col_ O B C /\ (col_ O Aprime Bprime /\ (col_ O Bprime Cprime /\ (col_ O A C /\ (col_ O Aprime Cprime /\ (col_ B Cprime L /\ (col_ C Bprime Lprime /\ (col_ O L Lprime /\ col_ O C Aprime))))))))))))))))))))) -> col_ O A Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Hammer Require Import Hammer.

Set Implicit Arguments.

Definition ifdec (A B:Prop) (C:Type) (H:{A} + {B}) (x y:C) : C :=
if H then x else y.

Theorem ifdec_left :
forall (A B:Prop) (C:Set) (H:{A} + {B}),
~ B -> forall x y:C, ifdec H x y = x.
Proof. hammer_hook "DecBool" "DecBool.ifdec_left".
intros; case H; auto.
intro; absurd B; trivial.
Qed.

Theorem ifdec_right :
forall (A B:Prop) (C:Set) (H:{A} + {B}),
~ A -> forall x y:C, ifdec H x y = y.
Proof. hammer_hook "DecBool" "DecBool.ifdec_right".
intros; case H; auto.
intro; absurd A; trivial.
Qed.

Unset Implicit Arguments.


(*
    Copyright (C) 2012  G. Gonthier, B. Ziliani, A. Nanevski, D. Dreyer

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    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 General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*)

From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype.
From LemmaOverloading
Require Import heaps.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Class Indom (x : ptr) (h : heap) :=
   { indom : def h -> x \in dom h }.

Obligation Tactic := idtac.

Program Instance found : forall A x (v : A), Indom x (x:->v).
Next Obligation.
move=> A x v; rewrite defPt => xnull.
by rewrite domPt !inE eq_refl xnull.
Qed.

Program Instance found_left :
  forall x h1 h2 (xh1 : Indom x h1), Indom x (h1:+h2).
Next Obligation.
move=> x h1 h2 xh1 defh12; rewrite domUn !inE defh12.
case: xh1 => xh1; by rewrite (xh1 (defUnl defh12)).
Qed.

Program Instance found_right :
  forall x h1 h2 (xh2 : Indom x h2), Indom x (h1:+h2).
Next Obligation.
move=> x h1 h2 xh2 defh12; rewrite domUn !inE defh12.
by case: xh2 => xh2; rewrite (xh2 (defUnr defh12)) orbT.
Qed.

(* simple example *)
Example ex1 A (x1 x2 : ptr) (v1 v2 : A) (h1 h2 : heap) :
          def (h1 :+ x1 :-> 1 :+ (x2 :-> 3 :+ empty)) ->
          if x2 \in dom (h1 :+ x1 :-> 1 :+ (x2 :-> 3 :+ empty))
            then 1 == 1
            else 1 == 0.
Proof.
move=>D.
by rewrite indom.
Qed.

(* same example, automatically unfolding a definition *)
Example ex2 A (x1 x2 : ptr) (v1 v2 : A) (h1 h2 : heap) :
          def (h1 :+ x1 :-> 1 :+ (x2 :-> 3 :+ empty)) ->
          if x2 \in dom (h1 :+ x1 :-> 1 :+ (x2 :-> 3 :+ empty))
            then 1 == 1
            else 1 == 0.
Proof.
set H := _ :+ _ :+ (_ :+ _).
move=>D.
by rewrite indom.
Qed.


(** * A refinement of Mathcomp's rationals [rat] with [bigQ] from Coq standard library. *)

Require Import ZArith QArith Lia.
From Bignums Require Import BigQ.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat order.
From mathcomp Require Import ssralg ssrnum ssrint rat div intdiv.
From CoqEAL.refinements Require Import hrel refinements param binint.
Import Refinements.Op.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope ring_scope.
Local Open Scope Z_scope.
Delimit Scope Z_scope with coqZ.

Import GRing.Theory Order.Theory Num.Theory.

Section classes.

Class max_of C := max_op : C -> C -> C.
Class min_of C := min_op : C -> C -> C.

End classes.

(** ** Link between [Z] (Coq standard lib) and [int] (Mathcomp) *)
Section Zint.

(** *** Various lemmas about [nat_of_pos] *)

Lemma nat_of_pos_inj x y : nat_of_pos x = nat_of_pos y -> x = y.
Proof. rewrite -!binnat.to_natE; apply Pos2Nat.inj. Qed.

Lemma nat_of_pos_gt0 p : (0 < nat_of_pos p)%N.
Proof. by elim: p =>//= p IHp; rewrite NatTrec.doubleE double_gt0. Qed.

Lemma nat_of_pos_gtr0 p : (0 < Posz (nat_of_pos p))%R.
Proof. by rewrite -[0%R]/(Posz 0) ltz_nat nat_of_pos_gt0. Qed.

Lemma Posz_nat_of_pos_neq0 p : Posz (nat_of_pos p) == 0%R = false.
Proof.
rewrite -binnat.to_natE.
case E: (Pos.to_nat _)=>//; exfalso; move: E.
by move: (binnat.to_nat_gt0 p); case (Pos.to_nat _).
Qed.

(** *** Conversion from [Z] to [int] *)
Definition Z2int (z : BinNums.Z) :=
  match z with
  | Z0 => 0%:Z
  | Z.pos p => (nat_of_pos p)%:Z
  | Z.neg n => (- (nat_of_pos n)%:Z)%R
  end.

(** *** Conversion from [int] to [Z] *)
Definition int2Z (n : int) : BinNums.Z :=
  match n with
  | Posz O => Z0
  | Posz n => Z.pos (Pos.of_nat n)
  | Negz n => Z.neg (Pos.of_nat n.+1)
  end.

Lemma Z2int_inj x y : Z2int x = Z2int y -> x = y.
Proof.
rewrite /Z2int.
case x, y=>//.
{ move=>[] H.
  by rewrite -[Z0]/(Z.of_nat 0%N) H -binnat.to_natE positive_nat_Z. }
{ rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz /=.
  case E: (Pos.to_nat _)=>//=.
  by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. }
{ rewrite -binnat.to_natE; case E: (Pos.to_nat _)=>//=.
  by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. }
{ by move=>[] /nat_of_pos_inj ->. }
{ rewrite -!binnat.to_natE /GRing.opp /= /intZmod.oppz /=.
  case (Pos.to_nat p0)=>//=.
  by move=>[] H; move: (binnat.to_nat_gt0 p); rewrite H ltnn. }
{ rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz /=.
  case E: (Pos.to_nat _)=>//=.
  by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. }
{ rewrite -!binnat.to_natE /GRing.opp /= /intZmod.oppz /=.
  case E: (Pos.to_nat p)=>//=.
  by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. }
rewrite -!binnat.to_natE /GRing.opp /= /intZmod.oppz /=.
case E: (Pos.to_nat p)=>//=.
{ by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. }
case E': (Pos.to_nat p0)=>//= [] [] H.
by move: E'; rewrite -H -E=>/Pos2Nat.inj ->.
Qed.

Lemma int2ZK : cancel int2Z Z2int.
Proof.
case => [n|n]; case: n => [|n] //=.
case: n => [//|n].
{ by rewrite -binnat.to_natE -Nat2Pos.inj_succ // Nat2Pos.id. }
case: n => [//|n].
{ by rewrite -binnat.to_natE -!Nat2Pos.inj_succ // Nat2Pos.id. }
Qed.

Lemma Z2intK : cancel Z2int int2Z.
Proof.
case => [|p|p] //=.
{ have Pp := nat_of_pos_gt0 p.
  by rewrite /= -(prednK Pp) (prednK Pp) -binnat.to_natE Pos2Nat.id. }
rewrite /int2Z.
have Pp := nat_of_pos_gt0 p.
rewrite -(prednK Pp) {Pp} /= -!binnat.to_natE.
rewrite -[in RHS](Pos2Nat.id p).
set n := Pos.to_nat p.
by case: n.
Qed.

(** *** [Z2int] is a morphism for arithmetic operations *)

Lemma Z2int_opp n : Z2int (- n) = (- (Z2int n))%R.
Proof. by case n=>// p /=; rewrite GRing.opprK. Qed.

Lemma Z2int_abs x : Z2int (Z.abs x) = `|Z2int x|%nat.
Proof. by case: x => // p /=; rewrite abszN. Qed.

Lemma Z2int_add x y : Z2int (x + y) = (Z2int x + Z2int y)%R.
Proof.
rewrite /Z2int /GRing.add /= /intZmod.addz /Z.add; case x, y=>//.
{ rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz.
  by case (Pos.to_nat p)=>// n; rewrite subn0. }
{ by rewrite addn0. }
{ (try by rewrite nat_of_add_pos) || by rewrite nat_of_addn_gt0. }
{ rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz.
  move: (Z.pos_sub_discr p p0); case (Z.pos_sub _ _).
  { move<-; rewrite -binnat.to_natE; case (Pos.to_nat _)=>// n.
    by rewrite ltnSn subnn. }
  { move=> p' ->; rewrite -!binnat.to_natE Pos2Nat.inj_add.
    case (Pos.to_nat p0); [by rewrite Nat.add_0_l addn0|move=> n].
    rewrite ifT; [by rewrite plusE addKn|].
    by rewrite plusE; apply ltn_addr; rewrite ltnSn. }
  move=> p' ->; rewrite -!binnat.to_natE Pos2Nat.inj_add.
  case (Pos.to_nat p').
  { rewrite Nat.add_0_r; case (Pos.to_nat p)=>// n.
    by rewrite ltnSn subnn. }
  move=> n.
  case E: (Pos.to_nat p)=>/=; [by rewrite subn0|].
  rewrite ifF.
  { by rewrite plusE addnS -addSn addKn. }
  by rewrite plusE addnS -addSn -ltn_subRL subnn ltn0. }
{ rewrite /GRing.opp /= /intZmod.oppz -binnat.to_natE.
  by case (Pos.to_nat p); [rewrite addn0|move=>n; rewrite subn0]. }
{ rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz.
  move: (Z.pos_sub_discr p p0); case E': (Z.pos_sub _ _).
  { move<-; rewrite -binnat.to_natE Z.pos_sub_diag; case (Pos.to_nat _)=>// n.
    by rewrite ltnSn subnn. }
  { move=> ->.
    rewrite -!binnat.to_natE Pos2Nat.inj_add Z.pos_sub_lt; last first.
    { by apply Pos.lt_add_diag_r. }
    rewrite -binnat.to_natE Pos2Nat.inj_sub ?Pos2Nat.inj_add; last first.
    { by apply Pos.lt_add_diag_r. }
    rewrite plusE minusE addKn; case (Pos.to_nat _).
    { by rewrite addn0; case (Pos.to_nat p0)=>// n; rewrite ltnSn subnn. }
    move=> n.
    case E: (Pos.to_nat p0 + n.+1)%N.
    { by exfalso; move: E; rewrite addnS. }
    rewrite -E ifF.
    { f_equal.
      have H: (Pos.to_nat p0 + n.+1 - n.+1 = Pos.to_nat p0 + n.+1 - n.+1)%N.
      { done. }
      move: H; rewrite {2}E addnK=>->.
      by rewrite subnS subSn /= ?subKn //; move: E;
        rewrite addnS=>[] [] <-; rewrite leq_addl. }
    by rewrite addnS -ltn_subRL subnn ltn0. }
  move=> ->; rewrite Z.pos_sub_gt; [|by apply Pos.lt_add_diag_r].
  rewrite -!binnat.to_natE !Pos2Nat.inj_sub; [|by apply Pos.lt_add_diag_r].
  rewrite Pos2Nat.inj_add; case (Pos.to_nat p).
  { by rewrite plusE minusE !add0n subn0. }
  by move=> n; rewrite plusE minusE addKn ifT // leq_addr. }
rewrite -!binnat.to_natE Pos2Nat.inj_add /GRing.opp /= /intZmod.oppz plusE.
case (Pos.to_nat p).
{ by rewrite add0n; case (Pos.to_nat p0)=>// n; rewrite ltn0 subn0. }
move=> n; case (Pos.to_nat p0); [by rewrite addn0 ltn0 subn0|].
by move=> n'; rewrite addSn -addnS.
Qed.

Lemma Z2int_mul_nat_of_pos (x : BinNums.Z) (y : positive) :
  (Z2int x * nat_of_pos y)%R = Z2int (Z.mul x (BinNums.Zpos y)).
Proof.
rewrite /Z2int; case Ex: x.
{ by rewrite mul0r Z.mul_0_l. }
{ by rewrite /= -!binnat.to_natE Pos2Nat.inj_mul. }
by rewrite /= mulNr  -!binnat.to_natE Pos2Nat.inj_mul.
Qed.

Lemma Z2int_mul x y : Z2int (x * y) = (Z2int x * Z2int y)%R.
Proof.
case y=>/=.
{ by rewrite GRing.mulr0 Z.mul_0_r. }
{ by move=> p; rewrite Z2int_mul_nat_of_pos. }
move=> p.
by rewrite GRing.mulrN Z2int_mul_nat_of_pos -Z2int_opp Zopp_mult_distr_r.
Qed.

Lemma divE x y : Nat.div x y = divn x y.
Proof.
case: y => [//|y].
rewrite /Nat.div.
move: (Nat.divmod_spec x y 0 y).
case: Nat.divmod => q r /(_ (le_n _)) [].
rewrite Nat.mul_0_r Nat.sub_diag !Nat.add_0_r Nat.mul_comm => + Hr /=.
rewrite multE minusE plusE => /(f_equal (fun x => divn x y.+1)) ->.
rewrite divnMDl // divn_small ?addn0 //.
rewrite ltn_subLR; [|exact/ssrnat.leP].
  by rewrite -addSnnS addnC addnS ltnS leq_addr.
Qed.

(* Mathcomp's divz and Z.div don't match for negative values. *)
Lemma Z2int_div x y : Z.le 0 x -> Z.le 0 y ->
  Z2int (Z.div x y) = (Z2int x %/ Z2int y)%Z.
Proof.
case: x => [|x|//] _; [by rewrite intdiv.div0z|].
case: y => [|y|//] _; [by rewrite intdiv.divz0|].
rewrite -!positive_nat_Z -div_Zdiv; last first.
{ rewrite Nat.neq_0_lt_0; exact: Pos2Nat.is_pos. }
rewrite !positive_nat_Z /= /divz gtr0_sgz ?mul1r; last first.
{ exact: nat_of_pos_gt0. }
rewrite divE !binnat.to_natE absz_nat /Z2int.
move: (Zle_0_nat (nat_of_pos x %/ nat_of_pos y)).
rewrite -[X in _ = Posz X]Nat2Z.id.
  by case: Z.of_nat => //= p _; rewrite binnat.to_natE.
Qed.

Lemma Z2int_le x y : (Z2int x <= Z2int y)%R <-> Z.le x y.
Proof.
rewrite /Z2int; case Ex: x; case Ey: y=> //.
{ rewrite oppr_ge0; split; move=> H; exfalso; move: H; [|by rewrite /Z.le].
  apply/negP; rewrite -ltNge; apply nat_of_pos_gt0. }
{ split; move=> H; exfalso; move: H; [|by rewrite /Z.le].
  apply/negP; rewrite -ltNge; apply nat_of_pos_gt0. }
{ rewrite -!binnat.to_natE /Num.Def.ler /=.
  by rewrite -!positive_nat_Z -Nat2Z.inj_le; split => /ssrnat.leP. }
{ split; move=> H; exfalso; move: H; [|by rewrite /Z.le].
  apply /negP; rewrite -ltNge.
  by apply: (@lt_trans _ _ 0%R); rewrite ?oppr_lt0; apply nat_of_pos_gt0. }
{ rewrite oppr_le0; split; by rewrite /Z.le. }
{ split=>_; [by rewrite /Z.le|].
  by apply: (@le_trans _ _ 0%R); [apply oppr_le0|apply ltW, nat_of_pos_gt0]. }
rewrite ler_opp2; split.
{ rewrite /Z.le /Z.compare -!binnat.to_natE /Num.Def.ler /= => /ssrnat.leP.
  by rewrite -Pos.compare_antisym -Pos2Nat.inj_le -Pos.compare_le_iff. }
rewrite /Z.le /Z.compare -!binnat.to_natE /Num.Def.ler /=.
rewrite -Pos.compare_antisym => H; apply/ssrnat.leP.
by rewrite -Pos2Nat.inj_le -Pos.compare_le_iff.
Qed.

Lemma Z2int_lt x y : (Z2int x < Z2int y)%R <-> Z.lt x y.
Proof.
rewrite -lez_addr1 -[1%R]/(Z2int 1) -Z2int_add Z2int_le; lia.
Qed.

Lemma nat_of_pos_Z_to_pos x : nat_of_pos x = `|Z2int (Z.pos x)|%N.
Proof. by rewrite /absz /Z2int. Qed.

Lemma Zabs_natE n : Z.abs_nat n = `|Z2int n|%N.
Proof.
case: n => //= p; first by rewrite binnat.to_natE.
by rewrite abszN absz_nat binnat.to_natE.
Qed.

Lemma Z2int_Z_of_nat n : Z2int (Z.of_nat n) = n.
Proof.
by case: n => //= n; rewrite Pos.of_nat_succ -binnat.to_natE Nat2Pos.id.
Qed.

(** *** Various lemmas about gcd *)

Lemma dvdnP m n : reflect (Z.divide (Z.of_nat m) (Z.of_nat n)) (m %| n).
Proof.
apply: (iffP idP) => H.
{ rewrite dvdn_eq in H; rewrite -(eqP H) /Z.divide; exists (Z.of_nat (n %/ m)).
  by rewrite Nat2Z.inj_mul. }
{ have [q Hq] := H; apply/dvdnP; exists `|Z2int q|%N; apply/Nat2Z.inj.
  have [Zq|NZq] := Z_zerop q.
  { by rewrite Zq /= in Hq *. }
  case: m Hq H => [|m] Hq H.
  { by rewrite Zmult_comm /= in Hq; rewrite mulnC /=. }
  rewrite Nat2Z.inj_mul -Zabs_natE Zabs2Nat.id_abs Z.abs_eq //.
  have H0 : (0 <= q * Z.of_nat m.+1) by rewrite -Hq; apply Zle_0_nat.
  by apply: Zmult_le_0_reg_r H0. }
Qed.

Lemma ZgcdE n d : Z.gcd n (Z.pos d) = Z.of_nat (div.gcdn `|Z2int n| (nat_of_pos d)).
Proof.
apply: Z.gcd_unique.
{ exact: Zle_0_nat. }
{ apply/Z.divide_abs_r; rewrite -Zabs2Nat.id_abs; apply/dvdnP.
  by rewrite Zabs_natE dvdn_gcdl. }
{ apply/Z.divide_abs_r; rewrite -Zabs2Nat.id_abs; apply/dvdnP.
  by rewrite Zabs_natE /= dvdn_gcdr. }
move=> q Hn Hd; apply/Z.divide_abs_l; rewrite -Zabs2Nat.id_abs; apply/dvdnP.
rewrite Zabs_natE dvdn_gcd.
apply/andP; split; apply/dvdnP; rewrite -!Zabs_natE !Zabs2Nat.id_abs.
{ by apply/Z.divide_abs_l/Z.divide_abs_r. }
{ by apply/Z.divide_abs_l; rewrite -binnat.to_natE positive_nat_Z. }
Qed.

Lemma ZgcdE' n m : Z.gcd n m = Z.of_nat (gcdn `|Z2int n| `|Z2int m|).
Proof.
case m.
{ rewrite Z.gcd_0_r {2}/absz {2}/Z2int /= gcdn0 -Zabs2Nat.id_abs; f_equal.
  rewrite /Z.abs_nat /absz /Z2int.
  case n=>// p; rewrite -!binnat.to_natE //.
  case (Pos.to_nat _); [by rewrite GRing.oppr0|move=> n'].
  by rewrite /GRing.opp /=. }
{ by move=> p; rewrite ZgcdE nat_of_pos_Z_to_pos. }
by move=> p; rewrite -Z.gcd_opp_r /= ZgcdE abszN /absz.
Qed.

Lemma Z_ggcd_1_r n : Z.ggcd n 1 = (1, (n, 1))%coqZ.
Proof.
move: (Z.ggcd_gcd n 1) (Z.ggcd_correct_divisors n 1); rewrite Z.gcd_1_r.
case (Z.ggcd _ _)=> g ab /= ->; case ab=> a b [].
by rewrite !Z.mul_1_l => <- <-.
Qed.

Lemma Z_ggcd_coprime a b :
  let '(g, (a', b')) := Z.ggcd a b in
  g <> 0%coqZ -> coprime `|Z2int a'| `|Z2int b'|.
Proof.
move: (Z.ggcd_gcd a b) (Z.ggcd_correct_divisors a b).
case (Z.ggcd _ _)=> g ab; case ab=> a' b' /= Hg [] Ha Hb Pg.
rewrite /coprime; apply/eqP /Nat2Z.inj; rewrite -ZgcdE' /=.
suff ->: a' = (a / g)%coqZ.
{ suff ->: b' = (b / g)%coqZ; [by apply Z.gcd_div_gcd|].
  by rewrite Hb Z.mul_comm Z_div_mult_full. }
by rewrite Ha Z.mul_comm Z_div_mult_full.
Qed.

Lemma Z2int_lcm x y : Z.le 0 x -> Z.le 0 y ->
  Z2int (Z.lcm x y) = lcmn `|Z2int x| `|Z2int y|.
Proof.
case: x => [|x|//] _; [by rewrite /= lcm0n|].
case: y => [|y|//] _; [by rewrite /= lcmn0|].
rewrite /Z.lcm Z2int_abs Z2int_mul Z2int_div //.
rewrite ZgcdE' abszM; apply: f_equal; apply/eqP.
rewrite -(@eqn_pmul2r (gcdn `|Z2int (Z.pos x)| `|Z2int (Z.pos y)|)); last first.
{ rewrite gcdn_gt0; apply/orP; left; rewrite absz_gt0 /= eqz_nat.
  apply: lt0n_neq0; exact: nat_of_pos_gt0. }
rewrite muln_lcm_gcd.
rewrite -(absz_nat (gcdn _ _)) -mulnA -abszM.
rewrite Z2int_Z_of_nat /=.
  by rewrite intdiv.divzK // /mem /in_mem /intdiv.dvdz /= dvdn_gcdr.
Qed.

End Zint.

(** ** Link between [bigQ] (Coq standard lib) and [rat] (Mathcomp) *)
Section binrat_theory.

Arguments refines A%type B%type R%rel _ _. (* Fix a scope issue with refines *)

(** *** Conversion from [bigQ] to [rat] *)
Program Definition bigQ2rat_def (bq : bigQ) :=
  let q := Qred (BigQ.to_Q bq) in
  ((Z2int (Qnum q))%:Q / (Z2int (Z.pos (Qden q)))%:Q)%R.
Fact bigQ2rat_key : unit. Proof. by []. Qed.
Program Definition bigQ2rat :=
  locked_with bigQ2rat_key bigQ2rat_def.
Canonical bigQ2rat_unlockable := [unlockable fun bigQ2rat].

(** *** Conversion from [rat] to [bigQ] *)
Definition rat2bigQ (q : rat) : bigQ :=
  let n := BigZ.of_Z (int2Z (numq q)) in
  let d := BigN.N_of_Z (int2Z (denq q)) in
  (n # d)%bigQ.

(** *** Refinement relation *)
Definition r_ratBigQ := fun_hrel bigQ2rat.

(** *** Main instances *)

#[export] Instance zero_bigQ : zero_of bigQ := 0%bigQ.
#[export] Instance one_bigQ : one_of bigQ := 1%bigQ.
#[export] Instance opp_bigQ : opp_of bigQ := BigQ.opp.
#[export] Instance add_bigQ : add_of bigQ := BigQ.add_norm.
#[export] Instance sub_bigQ : sub_of bigQ := BigQ.sub_norm.
#[export] Instance mul_bigQ : mul_of bigQ := BigQ.mul_norm.
#[export] Instance inv_bigQ : inv_of bigQ := BigQ.inv_norm.
#[export] Instance div_bigQ : div_of bigQ := BigQ.div_norm.
#[export] Instance eq_bigQ : eq_of bigQ := BigQ.eq_bool.
#[export] Instance lt_bigQ : lt_of bigQ := fun p q => if BigQ.compare p q is Lt then true else false.
#[export] Instance le_bigQ : leq_of bigQ := fun p q => if BigQ.compare q p is Lt then false else true.
#[export] Instance max_bigQ : max_of bigQ := BigQ.max.
#[export] Instance min_bigQ : min_of bigQ := BigQ.min.
#[export] Instance cast_of_nat_bigQ : cast_of nat bigQ := BigQ.of_Z \o Z.of_nat.
#[export] Instance spec_bigQ : spec_of bigQ rat := bigQ2rat.

(** *** Proofs of refinement *)

#[export] Instance refine_ratBigQ_zero : refines r_ratBigQ 0%R 0%C.
Proof. rewrite refinesE /r_ratBigQ unlock; red; exact: val_inj. Qed.

#[export] Instance refine_ratBigQ_one : refines r_ratBigQ 1%R 1%C.
Proof. rewrite refinesE /r_ratBigQ unlock; red; exact: val_inj. Qed.

#[export] Instance refine_ratBigQ_opp : refines (r_ratBigQ ==> r_ratBigQ) -%R -%C.
Proof.
rewrite refinesE => _ a <-; rewrite /r_ratBigQ unlock /fun_hrel /=.
rewrite BigQ.strong_spec_opp Qred_opp [in LHS]/Qnum /=.
by rewrite Z2int_opp mulrNz mulNr.
Qed.

Lemma Z2int_Qred n d :
  ((Z2int (Qnum (Qred (n # d))))%:Q / (nat_of_pos (Qden (Qred (n # d))))%:Q
   = (Z2int n)%:Q / (Z2int (Z.pos d))%:Q)%R.
Proof.
rewrite -(fracqE (Z2int n, Z2int (Z.pos d))) -[RHS]divq_num_den.
rewrite /Qred.
move: (Z.ggcd_gcd n (Z.pos d)) (Z.ggcd_correct_divisors n (Z.pos d)).
move: (Z_ggcd_coprime n (Z.pos d)).
case: Z.ggcd => g [n' d'] /=.
case: g => [|g|g].
{ by move=> _ _ [_]; rewrite Z.mul_0_l. }
{ move=> coprime_n'_d' => _ [->].
  rewrite (nat_of_pos_Z_to_pos d) => /[dup] posd' ->.
  have d'n0 : `|Z2int d'| != 0%R.
  { rewrite normr_eq0.
    case: d' posd' {coprime_n'_d'} => // d' _.
    by rewrite Posz_nat_of_pos_neq0. }
  rewrite !Z2int_mul abszM PoszM gez0_abs; [|by rewrite -[0%R]int2ZK Z2int_le].
  rewrite fracqMM ?Posz_nat_of_pos_neq0 // abszE.
  move: (@valq_frac (Z2int n', `|Z2int d'|) d'n0).
  rewrite scalqE // mul1r => [[neq deq]].
  have -> : nat_of_pos (Z.to_pos d') = `|Z2int d'| :> int.
  { rewrite nat_of_pos_Z_to_pos Z2Pos.id ?abszE //.
    by case: d' posd' {coprime_n'_d' d'n0 neq deq}. }
  rewrite [X in (X%:~R / _)%R]neq [X in (_ / X%:~R)%R]deq.
  rewrite (_ : gcdn _ _ = 1%nat) ?mul1r //; exact/eqP/coprime_n'_d'. }
by move: (Z.gcd_nonneg n (Z.pos d)) => + _ => /[swap] <-.
Qed.

Lemma BigQ_red_den_nonzero q :
  match BigQ.red q with BigQ.Qz _ => True | BigQ.Qq _ d => (BigN.to_Z d) <> Z0 end.
Proof.
case: q => [//|n d] /=.
rewrite /BigQ.norm.
rewrite BigN.spec_compare.
case: Z.compare_spec => [| |//] Hgcd.
{ rewrite /BigQ.check_int BigN.spec_compare.
  case Z.compare_spec => [//| |//] Hd.
  apply: BigNumPrelude.Zlt0_not_eq.
  move: Hd; exact: Z.lt_trans. }
rewrite /BigQ.check_int BigN.spec_compare.
case Z.compare_spec => [//| |//] Hd.
apply: BigNumPrelude.Zlt0_not_eq.
move: Hd; exact: Z.lt_trans.
Qed.

Lemma r_ratBigQ_red x y : r_ratBigQ x y ->
  match BigQ.red y with
  | BigQ.Qz n => numq x = Z2int (BigZ.to_Z n) /\ denq x = 1%R
  | BigQ.Qq n d => numq x = Z2int (BigZ.to_Z n) /\ denq x = Z2int (BigN.to_Z d)
  end.
Proof.
case: (ratP x) => nx dx nx_dx_coprime {x}.
rewrite /r_ratBigQ /fun_hrel unlock -BigQ.strong_spec_red.
have ry_red : Qred (BigQ.to_Q (BigQ.red y)) = BigQ.to_Q (BigQ.red y).
{ by rewrite BigQ.strong_spec_red Qcanon.Qred_involutive. }
have ry_dneq0 := BigQ_red_den_nonzero y.
case: (BigQ.red y) ry_dneq0 ry_red => [ny _ _|ny dy dy_neq0].
{ rewrite /BigQ.to_Q /Qnum /Qden mulr1.
  move=> /(f_equal ( *%R^~ dx.+1%:~R)%R).
  rewrite mulfVK ?mulrz_neq0 // -intrM => /intr_inj nx_eq.
  have dx_1 : (dx.+1 = 1)%nat.
  { by move: nx_dx_coprime => /eqP <-; rewrite -nx_eq abszM /= gcdnC gcdnMl. }
    by rewrite -nx_eq dx_1 mulr1. }
rewrite /BigQ.to_Q ifF ?BigN.spec_eqb ?Z.eqb_neq //.
rewrite Qcanon.Qred_iff ZgcdE -[1%coqZ]/(Z.of_nat 1%nat) => /Nat2Z.inj.
rewrite /Qnum /Qden nat_of_pos_Z_to_pos => /eqP ny_dy_coprime.
move=> /eqP; rewrite rat_eqE !coprimeq_num // !coprimeq_den //=.
rewrite !gtr0_sg ?nat_of_pos_gtr0 // !mul1r => /andP[/eqP <-].
rewrite ifF; [|exact/eqP/eqP/lt0r_neq0/nat_of_pos_gtr0].
rewrite -!abszE !absz_nat => /eqP[<-]; split=> [//|].
rewrite -[LHS]/(Z2int (Z.pos (Z.to_pos (BigN.to_Z dy)))) Z2Pos.id //.
exact: BigQ.N_to_Z_pos.
Qed.

#[export] Instance refine_ratBigQ_add :
  refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ) +%R +%C.
Proof.
rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=.
rewrite (Qred_complete _ _ (BigQ.spec_add_norm _ _)).
case: (BigQ.to_Q a) => na da {a}.
case: (BigQ.to_Q b) => nb db {b}.
rewrite /Qplus !Z2int_Qred.
rewrite Z2int_add !Z2int_mul /= nat_of_mul_pos.
rewrite intrD PoszM !intrM.
by rewrite [RHS]addf_div // intq_eq0 Posz_nat_of_pos_neq0.
Qed.

#[export] Instance refine_ratBigQ_sub :
  refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ) (fun x y => x - y)%R sub_op.
Proof.
apply refines_abstr2=> a b rab c d rcd.
rewrite /sub_op /sub_bigQ /BigQ.sub_norm; eapply refines_apply; tc.
Qed.

#[export] Instance refine_ratBigQ_mul :
  refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ) *%R *%C.
Proof.
rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=.
rewrite (Qred_complete _ _ (BigQ.spec_mul_norm _ _)).
case: (BigQ.to_Q a) => na da {a}.
case: (BigQ.to_Q b) => nb db {b}.
rewrite /Qmult !Z2int_Qred /=.
rewrite Z2int_mul nat_of_mul_pos.
rewrite PoszM !intrM.
by rewrite [RHS]mulf_div.
Qed.

#[export] Instance refine_ratBigQ_inv :
  refines (r_ratBigQ ==> r_ratBigQ)%rel GRing.inv inv_op.
Proof.
rewrite refinesE => _ a <-; rewrite /r_ratBigQ unlock /fun_hrel /=.
rewrite (Qred_complete _ _ (BigQ.spec_inv_norm _)).
case: (BigQ.to_Q a) => na da {a}.
rewrite /Qinv [Qnum (na # da)]/=.
case: na => [|na|na].
{ by rewrite /= !mul0r invr0. }
{ by rewrite [Qden (_ # da)]/= !Z2int_Qred invf_div. }
rewrite [Qden (_ #da)]/= !Z2int_Qred invf_div.
by rewrite -!Pos2Z.opp_pos !Z2int_opp !mulrNz mulNr invrN mulrN.
Qed.

#[export] Instance refine_ratBigQ_div :
  refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ)%rel (fun x y => x / y)%R div_op.
Proof.
apply: refines_abstr2 => x1 x2 rx y1 y2 ry.
rewrite /div_op /div_bigQ /BigQ.div_norm.
exact: refines_apply.
Qed.

#[export] Instance refine_ratBigQ_eq :
  refines (r_ratBigQ ==> r_ratBigQ ==> eq) eqtype.eq_op eq_op.
Proof.
rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=.
rewrite /eq_op /eq_bigQ BigQ.spec_eq_bool.
case: (BigQ.to_Q a) => na da {a}.
case: (BigQ.to_Q b) => nb db {b}.
rewrite /Qeq_bool !Z2int_Qred /= /Zeq_bool -Z.eqb_compare.
rewrite GRing.eqr_div ?intq_eq0 ?Posz_nat_of_pos_neq0 //.
rewrite !nat_of_pos_Z_to_pos.
rewrite !gez0_abs; [|by rewrite -[0%R]int2ZK Z2int_le..].
rewrite -!intrM -!Z2int_mul eqr_int.
by case: Z.eqb_spec => [->|eq]; apply/eqP => // eq'; apply/eq/Z2int_inj.
Qed.

#[export] Instance refine_ratBigQ_eq' :
  refines (r_ratBigQ ==> r_ratBigQ ==> bool_R)%rel eqtype.eq_op eq_op.
Proof.
rewrite refinesE => x1 x2 rx y1 y2 ry.
move: refine_ratBigQ_eq; rewrite refinesE => /(_ _ _ rx _ _ ry) <-.
case: (_ == _); constructor.
Qed.

#[export] Instance refine_ratBigQ_lt :
  refines (r_ratBigQ ==> r_ratBigQ ==> bool_R) Num.lt lt_op.
Proof.
rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=.
rewrite /lt_op /lt_bigQ BigQ.spec_compare.
case: (BigQ.to_Q a) => na da {a}.
case: (BigQ.to_Q b) => nb db {b}.
rewrite !Z2int_Qred /= /Qcompare /= -Z.ltb_compare.
rewrite ltr_pdivr_mulr ?ltr0z ?nat_of_pos_gtr0 //.
rewrite mulrAC ltr_pdivl_mulr ?ltr0z ?nat_of_pos_gtr0 //.
rewrite !nat_of_pos_Z_to_pos.
rewrite !gez0_abs; [|by rewrite -[0%R]int2ZK Z2int_le..].
rewrite -!intrM -!Z2int_mul ltr_int.
case: ltP.
{ by move=> /(proj1 (Z2int_lt _ _)) /(proj2 (Z.ltb_lt _ _)) => ->. }
by move=> /(proj1 (Z2int_le _ _)) /(proj2 (Z.ltb_ge _ _)) => ->.
Qed.

#[export] Instance refine_ratBigQ_le :
  refines (r_ratBigQ ==> r_ratBigQ ==> bool_R) Num.le leq_op.
Proof.
rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=.
rewrite /leq_op /le_bigQ BigQ.spec_compare.
case: (BigQ.to_Q a) => na da {a}.
case: (BigQ.to_Q b) => nb db {b}.
rewrite !Z2int_Qred /= /Qcompare /=.
rewrite ler_pdivr_mulr ?ltr0z ?nat_of_pos_gtr0 //.
rewrite mulrAC ler_pdivl_mulr ?ltr0z ?nat_of_pos_gtr0 //.
rewrite !nat_of_pos_Z_to_pos.
rewrite !gez0_abs; [|by rewrite -[0%R]int2ZK Z2int_le..].
rewrite -!intrM -!Z2int_mul ler_int.
case: leP.
{ move=> /(proj1 (Z2int_le _ _)) /Zle_compare.
  by rewrite Z.compare_antisym; case: Z.compare. }
by move=> /(proj1 (Z2int_lt _ _)) /Zlt_compare; case: Z.compare.
Qed.

#[export] Instance refine_ratBigQ_max :
  refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ)%rel Num.max max_op.
Proof.
apply: refines_abstr2 => x1 x2 rx y1 y2 ry.
have H := refines_apply (refines_apply refine_ratBigQ_lt rx) ry.
move: H => /refines_bool_eq; rewrite maxElt refinesE => ->.
rewrite /lt_op /lt_bigQ /max_op /max_bigQ /BigQ.max.
by case: (_ ?= _)%bigQ.
Qed.

#[export] Instance refine_ratBigQ_min :
  refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ)%rel Num.min min_op.
Proof.
apply: refines_abstr2 => x1 x2 rx y1 y2 ry.
have H := refines_apply (refines_apply refine_ratBigQ_lt ry) rx.
move: H => /refines_bool_eq; rewrite minEle leNgt refinesE => ->.
rewrite /lt_op /lt_bigQ /min_op /min_bigQ /BigQ.min.
rewrite !BigQ.spec_compare -QArith_base.Qcompare_antisym.
by case: QArith_base.Qcompare.
Qed.

#[export] Instance refine_ratBigQ_of_nat :
  refines (nat_R ==> r_ratBigQ)%rel (fun n => n%:~R%R) cast_op.
Proof.
rewrite refinesE => n _ /nat_R_eq <-; rewrite /r_ratBigQ unlock /fun_hrel.
rewrite /= Z_ggcd_1_r /= BigZ.spec_of_Z mulr1.
by apply/eqP; rewrite eqr_int Z2int_Z_of_nat.
Qed.

#[export] Instance refine_ratBigQ_spec :
  refines (eq ==> r_ratBigQ)%rel spec spec_id.
Proof. by rewrite refinesE => x _ <-. Qed.

#[export] Instance refine_ratBigQ_bigQ2rat a : refines r_ratBigQ (bigQ2rat a) a.
Proof. by rewrite refinesE. Qed.

End binrat_theory.


From Hammer Require Import Hammer.

Require Export BinInt Zcompare Zorder.

Local Open Scope Z_scope.

Notation Zmax_case := Z.max_case (compat "8.3").
Notation Zmax_case_strong := Z.max_case_strong (compat "8.3").
Notation Zmax_right := Z.max_r (compat "8.3").
Notation Zle_max_l := Z.le_max_l (compat "8.3").
Notation Zle_max_r := Z.le_max_r (compat "8.3").
Notation Zmax_lub := Z.max_lub (compat "8.3").
Notation Zmax_lub_lt := Z.max_lub_lt (compat "8.3").
Notation Zle_max_compat_r := Z.max_le_compat_r (compat "8.3").
Notation Zle_max_compat_l := Z.max_le_compat_l (compat "8.3").
Notation Zmax_idempotent := Z.max_id (compat "8.3").
Notation Zmax_n_n := Z.max_id (compat "8.3").
Notation Zmax_comm := Z.max_comm (compat "8.3").
Notation Zmax_assoc := Z.max_assoc (compat "8.3").
Notation Zmax_irreducible_dec := Z.max_dec (compat "8.3").
Notation Zmax_le_prime := Z.max_le (compat "8.3").
Notation Zsucc_max_distr := Z.succ_max_distr (compat "8.3").
Notation Zmax_SS := Z.succ_max_distr (compat "8.3").
Notation Zplus_max_distr_l := Z.add_max_distr_l (compat "8.3").
Notation Zplus_max_distr_r := Z.add_max_distr_r (compat "8.3").
Notation Zmax_plus := Z.add_max_distr_r (compat "8.3").
Notation Zmax1 := Z.le_max_l (compat "8.3").
Notation Zmax2 := Z.le_max_r (compat "8.3").
Notation Zmax_irreducible_inf := Z.max_dec (compat "8.3").
Notation Zmax_le_prime_inf := Z.max_le (compat "8.3").
Notation Zpos_max := Pos2Z.inj_max (compat "8.3").
Notation Zpos_minus := Pos2Z.inj_sub_max (compat "8.3").

Lemma Zmax_spec x y :
x >= y /\ Z.max x y = x  \/ x < y /\ Z.max x y = y.
Proof. hammer_hook "Zmax" "Zmax.Zmax_spec".
Z.swap_greater. destruct (Z.max_spec x y); auto.
Qed.

Lemma Zmax_left n m : n>=m -> Z.max n m = n.
Proof. hammer_hook "Zmax" "Zmax.Zmax_left".   Z.swap_greater. apply Z.max_l. Qed.

Lemma Zpos_max_1 p : Z.max 1 (Z.pos p) = Z.pos p.
Proof. hammer_hook "Zmax" "Zmax.Zpos_max_1".
now destruct p.
Qed.


Require Import Autosubst.Autosubst.
Require Import Relations.
From Metatheories Require Import ARS Term.

Inductive red : relation term :=
  | red_appabs t11 t2 : red (tapp (tabs t11) t2) (t11.[t2/])
  | red_appl t1 t1' t2 :
      red t1 t1' ->
      red (tapp t1 t2) (tapp t1' t2)
  | red_appr t1 t2 t2' :
      red t2 t2' ->
      red (tapp t1 t2) (tapp t1 t2')
  | red_abs t t' :
      red t t' ->
      red (tabs t) (tabs t').
Hint Constructors red.
Local Hint Constructors clos_refl_trans clos_refl_sym_trans.

Lemma ered_appabs t11 t2 t :
  t = t11.[t2/] ->
  red (tapp (tabs t11) t2) t.
Proof. intros. subst. econstructor. Qed.

Lemma ered_appr t1 t2 t2' t' :
  red t2 t2' ->
  t' = tapp t1 t2' ->
  red (tapp t1 t2) t'.
Proof. intros. subst. eauto. Qed.

Lemma red_abs_multi t t' :
  clos_refl_trans _ red t t' ->
  clos_refl_trans _ red (tabs t) (tabs t').
Proof. induction 1; eauto. Qed.

Lemma red_appl_multi t1 t1' t2 :
  clos_refl_trans _ red t1 t1' ->
  clos_refl_trans _ red (tapp t1 t2) (tapp t1' t2).
Proof. induction 1; eauto. Qed.

Lemma red_appr_multi t1 t2 t2' :
  clos_refl_trans _ red t2 t2' ->
  clos_refl_trans _ red (tapp t1 t2) (tapp t1 t2').
Proof. induction 1; eauto. Qed.

Lemma red_app_equiv t1 t1' t2 t2' :
  clos_refl_sym_trans _ red t1 t1' ->
  clos_refl_sym_trans _ red t2 t2' ->
  clos_refl_sym_trans _ red (tapp t1 t2) (tapp t1' t2').
Proof.
  intros Hrstc Hrstc'.
  apply rst_trans with (y := tapp t1' t2).
  - induction Hrstc; eauto.
  - induction Hrstc'; eauto.
Qed.

Hint Resolve red_abs_multi red_appl_multi red_appr_multi red_app_equiv.

Lemma red_var_multi_inv x t :
  clos_refl_trans _ red (tvar x) t ->
  t = tvar x.
Proof.
  intros Hrt.
  apply clos_rt_rt1n in Hrt.
  inversion Hrt; subst; eauto.
  - inversion H.
Qed.

Lemma red_abs_multi_inv t t' :
  clos_refl_trans _ red t t' ->
  forall t1, t = tabs t1 ->
  exists t1', t' = tabs t1' /\ clos_refl_trans _ red t1 t1'.
Proof.
  intros Hrt.
  apply clos_rt_rt1n in Hrt.
  induction Hrt; intros ? ?; subst; eauto.
  - inversion H; subst.
    destruct (IHHrt _ eq_refl) as [? []]; eauto.
Qed.

Lemma red_rename t t' :
  red t t' ->
  forall r,
  red (rename r t) (rename r t').
Proof.
  induction 1; simpl; intros ?; eauto.
  - apply ered_appabs.
    autosubst.
Qed.

Lemma red_rename_multi r t t' :
  clos_refl_trans _ red t t' ->
  clos_refl_trans _ red (rename r t) (rename r t').
Proof.
  Local Hint Resolve red_rename.
  induction 1; simpl; eauto.
Qed.

Lemma red_subst t t' :
  red t t' ->
  forall s,
  red t.[s] t'.[s].
Proof.
  induction 1; simpl; intros ?; eauto.
  - apply ered_appabs.
    autosubst.
Qed.

Lemma neutral_red t t' :
  neutral t' ->
  red t t' ->
  neutral t.
Proof. induction 2; simpl; eauto. Qed.

Lemma neutral_red_multi t t' :
  neutral t' ->
  clos_refl_trans _ red t t' ->
  neutral t.
Proof.
  induction 2; eauto.
  eapply neutral_red; eauto.
Qed.

Lemma red_subst_multi_aux t : forall s s',
  (forall x, clos_refl_trans _ red (s x) (s' x)) ->
  clos_refl_trans _ red t.[s] t.[s'].
Proof.
  induction t; simpl; eauto 6.
  - intros.
    apply red_abs_multi.
    apply IHt.
    intros [| ?].
    + apply rt_refl.
    + apply red_rename_multi. eauto.
Qed.

Lemma red_subst_multi t t' s s' :
  clos_refl_trans _ red t t' ->
  (forall x, clos_refl_trans _ red (s x) (s' x)) ->
  clos_refl_trans _ red t.[s] t'.[s'].
Proof.
  Local Hint Resolve red_subst.
  intros Hrt ?.
  eapply rt_trans.
  - apply red_subst_multi_aux. eauto.
  - apply clos_rt_rt1n in Hrt.
    induction Hrt; eauto.
Qed.

Section Confluence.
  Inductive pr : relation term :=
    | pr_appabs t11 t11' t2 t2' :
        pr t11 t11' ->
        pr t2 t2' ->
        pr (tapp (tabs t11) t2) (t11'.[t2'/])
    | pr_var x : pr (tvar x) (tvar x)
    | pr_app t1 t1' t2 t2' :
        pr t1 t1' ->
        pr t2 t2' ->
        pr (tapp t1 t2) (tapp t1' t2')
    | pr_abs t t' :
        pr t t' ->
        pr (tabs t) (tabs t').
  Local Hint Constructors pr.

  Lemma epr_appabs t11 t11' t2 t2' t' :
    pr t11 t11' ->
    pr t2 t2' ->
    t' = t11'.[t2'/] ->
    pr (tapp (tabs t11) t2) t'.
  Proof. intros. subst. eauto. Qed.

  Lemma pr_refl t : pr t t.
  Proof. induction t; eauto. Qed.
  Local Hint Resolve pr_refl.

  Lemma red_pr t t' : red t t' -> pr t t'.
  Proof. induction 1; eauto. Qed.
  Local Hint Resolve red_pr.

  Lemma pr_red_multi t t' : pr t t' -> clos_refl_trans _ red t t'.
  Proof. induction 1; eauto 7. Qed.
  Local Hint Resolve pr_red_multi.

  Lemma pr_multi_red_multi t t' : clos_refl_trans _ pr t t' -> clos_refl_trans _ red t t'.
  Proof.
    intros ?.
    apply clos_rt_idempotent.
    eapply clos_rt_impl.
    - apply pr_red_multi.
    - eauto.
  Qed.

  Lemma red_multi_pr_multi t t' : clos_refl_trans _ red t t' -> clos_refl_trans _ pr t t'.
  Proof. induction 1; eauto. Qed.

  Lemma pr_rename t t' :
    pr t t' ->
    forall r,
    pr (rename r t) (rename r t').
  Proof.
    induction 1; simpl; intros ?; eauto.
    - eapply epr_appabs; eauto.
      autosubst.
  Qed.

  Lemma pr_subst t t' :
    pr t t' ->
    forall s s',
    (forall x, pr (s x) (s' x)) ->
    pr t.[s] t'.[s'].
  Proof.
    induction 1; simpl; intros ? ? Hsub; eauto 6.
    - apply epr_appabs with (t11' := t11'.[up s']) (t2' := t2'.[s']); eauto.
      + apply IHpr1.
        intros [| ?].
        * apply pr_refl.
        * apply pr_rename. eauto.
      + autosubst.
    - constructor.
      apply IHpr.
      intros [| ?].
      + apply pr_refl.
      + apply pr_rename. eauto.
  Qed.

  Fixpoint development t :=
    match t with
    | tvar x => tvar x
    | tabs t1 => tabs (development t1)
    | tapp (tabs t11) t2 => (development t11).[development t2/]
    | tapp t1 t2 => tapp (development t1) (development t2)
    end.

  Lemma finite_development t t' :
    pr t t' ->
    pr t' (development t).
  Proof.
    induction 1; simpl; eauto.
    - apply pr_subst; eauto.
      intros [| ?].
      + apply IHpr2.
      + apply pr_refl.
    - destruct t1; simpl in *; eauto.
      inversion H; subst.
      inversion IHpr1; subst.
      eauto.
  Qed.

  Corollary pr_diamond : diamond_property _ pr.
  Proof.
    intros H H'.
    repeat eexists; apply finite_development; eauto.
  Qed.

  Definition pr_confluent := diamond_property_impl_confluent _ _ pr_diamond.

  Theorem red_confluent : confluent _ red.
  Proof.
    eapply confluent_same_relation.
    - apply pr_confluent.
    - intros.
      split.
      + apply pr_multi_red_multi.
      + apply red_multi_pr_multi.
  Qed.
End Confluence.


From Fiat.Narcissus Require Import Examples.TutorialPrelude.

Record msg := { data : word 8; tag : word 8 }.
Definition format := format_word ◦ data.
Definition invariant (_ : msg) := True.

Definition dec : CorrectAlignedDecoderFor invariant format.
Proof.
  synthesize_aligned_decoder.
Defined.


From iris.proofmode Require Import base.
From iris.algebra Require Export base.
Set Default Proof Using "Type".

Inductive env (A : Type) : Type :=
  | Enil : env A
  | Esnoc : env A → ident → A → env A.
Arguments Enil {_}.
Arguments Esnoc {_} _ _ _.
Instance: Params (@Enil) 1.
Instance: Params (@Esnoc) 1.

Fixpoint env_lookup {A} (i : ident) (Γ : env A) : option A :=
  match Γ with
  | Enil => None
  | Esnoc Γ j x => if ident_beq i j then Some x else env_lookup i Γ
  end.

Module env_notations.
  Notation "y ≫= f" := (option_bind f y).
  Notation "x ← y ; z" := (y ≫= λ x, z).
  Notation "' x1 .. xn ← y ; z" := (y ≫= (λ x1, .. (λ xn, z) .. )).
  Notation "Γ !! j" := (env_lookup j Γ).
End env_notations.
Import env_notations.

Inductive env_wf {A} : env A → Prop :=
  | Enil_wf : env_wf Enil
  | Esnoc_wf Γ i x : Γ !! i = None → env_wf Γ → env_wf (Esnoc Γ i x).

Fixpoint env_to_list {A} (E : env A) : list A :=
  match E with Enil => [] | Esnoc Γ _ x => x :: env_to_list Γ end.
Coercion env_to_list : env >-> list.
Instance: Params (@env_to_list) 1.

Fixpoint env_dom {A} (Γ : env A) : list ident :=
  match Γ with Enil => [] | Esnoc Γ i _ => i :: env_dom Γ end.

Fixpoint env_app {A} (Γapp : env A) (Γ : env A) : option (env A) :=
  match Γapp with
  | Enil => Some Γ
  | Esnoc Γapp i x =>
     Γ' ← env_app Γapp Γ;
     match Γ' !! i with None => Some (Esnoc Γ' i x) | Some _ => None end
  end.

Fixpoint env_replace {A} (i: ident) (Γi: env A) (Γ: env A) : option (env A) :=
  match Γ with
  | Enil => None
  | Esnoc Γ j x =>
     if ident_beq i j then env_app Γi Γ else
     match Γi !! j with
     | None => Γ' ← env_replace i Γi Γ; Some (Esnoc Γ' j x)
     | Some _ => None
     end
  end.

Fixpoint env_delete {A} (i : ident) (Γ : env A) : env A :=
  match Γ with
  | Enil => Enil
  | Esnoc Γ j x => if ident_beq i j then Γ else Esnoc (env_delete i Γ) j x
  end.

Fixpoint env_lookup_delete {A} (i : ident) (Γ : env A) : option (A * env A) :=
  match Γ with
  | Enil => None
  | Esnoc Γ j x =>
     if ident_beq i j then Some (x,Γ)
     else ''(y,Γ') ← env_lookup_delete i Γ; Some (y, Esnoc Γ' j x)
  end.

Inductive env_Forall2 {A B} (P : A → B → Prop) : env A → env B → Prop :=
  | env_Forall2_nil : env_Forall2 P Enil Enil
  | env_Forall2_snoc Γ1 Γ2 i x y :
     env_Forall2 P Γ1 Γ2 → P x y → env_Forall2 P (Esnoc Γ1 i x) (Esnoc Γ2 i y).

Inductive env_subenv {A} : relation (env A) :=
  | env_subenv_nil : env_subenv Enil Enil
  | env_subenv_snoc Γ1 Γ2 i x :
     env_subenv Γ1 Γ2 → env_subenv (Esnoc Γ1 i x) (Esnoc Γ2 i x)
  | env_subenv_skip Γ1 Γ2 i y :
     env_subenv Γ1 Γ2 → env_subenv Γ1 (Esnoc Γ2 i y).

Section env.
Context {A : Type}.
Implicit Types Γ : env A.
Implicit Types i : ident.
Implicit Types x : A.
Hint Resolve Esnoc_wf Enil_wf.

Ltac simplify :=
  repeat match goal with
  | _ => progress simplify_eq/=
  | H : context [ident_beq ?s1 ?s2] |- _ => destruct (ident_beq_reflect s1 s2)
  | |- context [ident_beq ?s1 ?s2] => destruct (ident_beq_reflect s1 s2)
  | H : context [option_bind _ ?x] |- _ => destruct x eqn:?
  | |- context [option_bind _ ?x] => destruct x eqn:?
  | _ => case_match
  end.

Lemma env_lookup_perm Γ i x : Γ !! i = Some x → Γ ≡ₚ x :: env_delete i Γ.
Proof.
  induction Γ; intros; simplify; rewrite 1?Permutation_swap; f_equiv; eauto.
Qed.

Lemma env_lookup_snoc Γ i P : env_lookup i (Esnoc Γ i P) = Some P.
Proof. induction Γ; simplify; auto. Qed.
Lemma env_lookup_snoc_ne Γ i j P :
  i ≠ j → env_lookup i (Esnoc Γ j P) = env_lookup i Γ.
Proof. induction Γ=> ?; simplify; auto. Qed.

Lemma env_app_perm Γ Γapp Γ' :
  env_app Γapp Γ = Some Γ' → env_to_list Γ' ≡ₚ Γapp ++ Γ.
Proof. revert Γ'; induction Γapp; intros; simplify; f_equal; auto. Qed.
Lemma env_app_fresh Γ Γapp Γ' i :
  env_app Γapp Γ = Some Γ' → Γapp !! i = None → Γ !! i = None → Γ' !! i = None.
Proof. revert Γ'. induction Γapp; intros; simplify; eauto. Qed.
Lemma env_app_fresh_1 Γ Γapp Γ' i x :
  env_app Γapp Γ = Some Γ' → Γ' !! i = None → Γ !! i = None.
Proof. revert Γ'. induction Γapp; intros; simplify; eauto. Qed.
Lemma env_app_disjoint Γ Γapp Γ' i :
  env_app Γapp Γ = Some Γ' → Γapp !! i = None ∨ Γ !! i = None.
Proof.
  revert Γ'.
  induction Γapp; intros; simplify; naive_solver eauto using env_app_fresh_1.
Qed.
Lemma env_app_wf Γ Γapp Γ' : env_app Γapp Γ = Some Γ' → env_wf Γ → env_wf Γ'.
Proof. revert Γ'. induction Γapp; intros; simplify; eauto. Qed.

Lemma env_replace_fresh Γ Γj Γ' i j :
  env_replace j Γj Γ = Some Γ' →
  Γj !! i = None → env_delete j Γ !! i = None → Γ' !! i = None.
Proof. revert Γ'. induction Γ; intros; simplify; eauto using env_app_fresh. Qed.
Lemma env_replace_wf Γ Γi Γ' i :
  env_replace i Γi Γ = Some Γ' → env_wf (env_delete i Γ) → env_wf Γ'.
Proof.
  revert Γ'. induction Γ; intros ??; simplify; [|inversion_clear 1];
    eauto using env_app_wf, env_replace_fresh.
Qed.
Lemma env_replace_lookup Γ Γi Γ' i :
  env_replace i Γi Γ = Some Γ' → is_Some (Γ !! i).
Proof. revert Γ'. induction Γ; intros; simplify; eauto. Qed.
Lemma env_replace_perm Γ Γi Γ' i :
  env_replace i Γi Γ = Some Γ' → Γ' ≡ₚ Γi ++ env_delete i Γ.
Proof.
  revert Γ'. induction Γ as [|Γ IH j y]=>Γ' ?; simplify; auto using env_app_perm.
  rewrite -Permutation_middle -IH //.
Qed.

Lemma env_lookup_delete_correct Γ i :
  env_lookup_delete i Γ = (x ← Γ !! i; Some (x,env_delete i Γ)).
Proof. induction Γ; intros; simplify; eauto. Qed.
Lemma env_lookup_delete_Some Γ Γ' i x :
  env_lookup_delete i Γ = Some (x,Γ') ↔ Γ !! i = Some x ∧ Γ' = env_delete i Γ.
Proof. rewrite env_lookup_delete_correct; simplify; naive_solver. Qed.

Lemma env_lookup_env_delete Γ j : env_wf Γ → env_delete j Γ !! j = None.
Proof. induction 1; intros; simplify; eauto. Qed.
Lemma env_lookup_env_delete_ne Γ i j : i ≠ j → env_delete j Γ !! i = Γ !! i.
Proof. induction Γ; intros; simplify; eauto. Qed.
Lemma env_delete_fresh Γ i j : Γ !! i = None → env_delete j Γ !! i = None.
Proof. induction Γ; intros; simplify; eauto. Qed.

Lemma env_delete_wf Γ j : env_wf Γ → env_wf (env_delete j Γ).
Proof. induction 1; simplify; eauto using env_delete_fresh. Qed.

Global Instance env_Forall2_refl (P : relation A) :
  Reflexive P → Reflexive (env_Forall2 P).
Proof. intros ? Γ. induction Γ; constructor; auto. Qed.
Global Instance env_Forall2_sym (P : relation A) :
  Symmetric P → Symmetric (env_Forall2 P).
Proof. induction 2; constructor; auto. Qed.
Global Instance env_Forall2_trans (P : relation A) :
  Transitive P → Transitive (env_Forall2 P).
Proof.
  intros ? Γ1 Γ2 Γ3 HΓ; revert Γ3.
  induction HΓ; inversion_clear 1; constructor; eauto.
Qed.
Global Instance env_Forall2_antisymm (P Q : relation A) :
  AntiSymm P Q → AntiSymm (env_Forall2 P) (env_Forall2 Q).
Proof. induction 2; inversion_clear 1; constructor; auto. Qed.
Lemma env_Forall2_impl {B} (P Q : A → B → Prop) Γ Σ :
  env_Forall2 P Γ Σ → (∀ x y, P x y → Q x y) → env_Forall2 Q Γ Σ.
Proof. induction 1; constructor; eauto. Qed.

Global Instance Esnoc_proper (P : relation A) :
  Proper (env_Forall2 P ==> (=) ==> P ==> env_Forall2 P) Esnoc.
Proof. intros Γ1 Γ2 HΓ i ? <-; by constructor. Qed.
Global Instance env_to_list_proper (P : relation A) :
  Proper (env_Forall2 P ==> Forall2 P) env_to_list.
Proof. induction 1; constructor; auto. Qed.

Lemma env_Forall2_fresh {B} (P : A → B → Prop) Γ Σ i :
  env_Forall2 P Γ Σ → Γ !! i = None → Σ !! i = None.
Proof. by induction 1; simplify. Qed.
Lemma env_Forall2_wf {B} (P : A → B → Prop) Γ Σ :
  env_Forall2 P Γ Σ → env_wf Γ → env_wf Σ.
Proof. induction 1; inversion_clear 1; eauto using env_Forall2_fresh. Qed.

Lemma env_subenv_fresh Γ Σ i : env_subenv Γ Σ → Σ !! i = None → Γ !! i = None.
Proof. by induction 1; simplify. Qed.
Lemma env_subenv_wf Γ Σ : env_subenv Γ Σ → env_wf Σ → env_wf Γ.
Proof. induction 1; inversion_clear 1; eauto using env_subenv_fresh. Qed.
Global Instance env_to_list_subenv_proper :
  Proper (env_subenv ==> sublist) (@env_to_list A).
Proof. induction 1; simpl; constructor; auto. Qed.
End env.