Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Functor.Diagonal.
Require Import Category.Structure.Cone.
Require Import Category.Construction.Comma.
Require Import Category.Instance.Cones.
Require Import Category.Instance.Fun.
Require Import Category.Instance.Cat.

Generalizable All Variables.

Theorem Cones_to_Comma `(F : [J, C]) : Cones F ⟶ (Δ ↓ =(F)).
Proof.
  functor; simpl; intros.
  - exists (vertex_obj[X], ttt).
    transform; simpl; intros.
    + apply @vertex_map. exact (@coneFrom _ _ _ X).
    + abstract (rewrite id_right; apply cone_coherence).
    + abstract (rewrite id_right; symmetry; apply cone_coherence).
  - exists (`1 f, ttt); abstract (simpl; intros; cat).
  - abstract proper.
  - abstract cat.
  - abstract cat.
Defined.

Theorem Cones_from_Comma `(F : [J, C]) : (Δ ↓ =(F)) ⟶ Cones F.
Proof.
  functor; simpl; intros.
  - construct; simpl; intros.
    + exact (fst ``X).
    + exists (transform[`2 X]). abstract (intros; rewrite (naturality[`2 X]); cat).
  - destruct f; simpl in *.
    exists (fst x0); abstract (intros; rewrite e; cat).
  - abstract proper.
  - abstract cat.
  - abstract cat.
Defined.

(* Wikipedia: "We can define the category of cones to F as the comma category
  (Δ ↓ F). Morphisms of cones are then just morphisms in this category. This
  equivalence is rooted in the observation that a natural map between constant
  functors Δ(N), Δ(M) corresponds to a morphism between N and M. In this
  sense, the diagonal functor acts trivially on arrows. In similar vein,
  writing down the definition of a natural map from a constant functor Δ(N) to
  F yields the same diagram as the above. As one might expect, a morphism from
  a cone (N, ψ) to a cone (L, φ) is just a morphism N → L such that all the
  "obvious" diagrams commute." *)

Theorem Cones_Comma `(F : [J, C]) : Cones F ≅[Cat] (Δ ↓ =(F)).
Proof.
  isomorphism; simpl; intros.
  - apply Cones_to_Comma.
  - apply Cones_from_Comma.
  - constructive.
    + exists (id, ttt); abstract cat.
    + exists (id, ttt); abstract cat.
    + abstract (simpl; cat).
    + abstract (simpl; cat).
    + abstract (simpl; cat).
  - constructive.
    + exists id; abstract (intros; cat).
    + exists id; abstract (intros; cat).
    + abstract (simpl; cat).
    + abstract (simpl; cat).
    + abstract (simpl; cat).
Qed.


Require Import UsefulTypes.
Require Import list.
Require Import Coq.Lists.List.
Require Import tactics.
Require Import Omega.
Require Import universe.
Require Import bin_rels.
Require Import eq_rel.
Require Import universe.
Require Import LibTactics.
Require Import tactics.
Require Import Coq.Bool.Bool.
Require Import Coq.Program.Tactics.
Require Import Omega.
Require Import Coq.Program.Basics.
Require Import Coq.Lists.List.
Require Import Coq.Init.Notations.
Require Import UsefulTypes.
Require Import Coq.Classes.DecidableClass.
Require Import Coq.Classes.Morphisms.
Require Import varInterface.

Hint Rewrite diff_nil : fast.
Set Implicit Arguments.
Section AssociationList.
Variables Key Value : Type.
Definition AssocList : Type := list (Key * Value).
Definition ALDom : AssocList -> list Key := map (fun x => fst x).
Definition ALRange : AssocList -> list Value := map (fun x => snd x).

Theorem ALDomCombine :
  forall lv lnt,
    length lv = length lnt
    -> ALDom (combine lv lnt) = lv.
Proof.
  induction lv; sp; simpl; destruct lnt; allsimpl; sp; try omega.
  f_equal; auto.
Qed.

Theorem ALRangeCombine :
  forall lv lnt,
    length lv = length lnt
    -> ALRange (combine lv lnt) = lnt.
Proof.
  induction lv; sp; simpl; destruct lnt; allsimpl; sp; try omega.
  f_equal; auto.
Qed.

Lemma ALInEta : forall sub v t,
  LIn (v,t) sub -> (LIn v (ALDom sub)) # (LIn t (ALRange sub)).
Proof.
  induction sub as [| ? Hind]; introv Hin; auto.
  allsimpl. dorn Hin; subst; auto;[].
  apply IHHind in Hin. repnd.
  split; right; auto.
Qed.

Definition ALMap {TK TV : Type}
  (fk : Key -> TK)
  (fv : Value -> TV) (al : AssocList):=
map (fun p => (fk (fst p), fv (snd p))) al.

Definition ALMapRange {T : Type} (f : Value -> T) (al : AssocList):=
ALMap (fun x=>x) f al.

Definition ALMapDom {T : Type} (f : Key -> T) (al : AssocList):=
ALMap f (fun x=>x)  al.

Context {deqKey : (Deq Key)}.
(** All definitions/lemmas below need decidable equality on Key.
    If not, they should placed before the line above *)
Fixpoint ALFind
    (al : AssocList) (key : Key): option Value :=
match al with
| nil => None
| (k, v) :: xs => if (beq_var k key)
                  then Some v
                  else ALFind xs key
end.

Definition ALFindDef
    (al : AssocList) (key : Key) (def: Value):  Value :=
match (ALFind al key) with
| Some v => v
| None => def
end.

(** Same as [AlFind] above, but the output contains proofs of
    correctness. *)
Lemma ALFind2 :
  forall  (sub: AssocList) (a : Key) ,
    { b: Value & LIn (a,b) sub}
    + !(LIn a (ALDom sub)).
Proof.
   induction sub as [| (a', b') sub Hind]; intro a.
   - right.  sp.
   - simpl. destruct (decideP (a=a')) as [Hc|Hc]; subst.
      + left. exists b'. left; refl.
      + destruct (Hind a) as [Hl | Hr]; exrepnd ;[left | right].
          * exists b. right; auto.
          * intro Hf. apply Hr. simpl in Hf. destruct (split sub).
              dorn Hf; sp.
Defined.

Definition ALFindDef2
    (al : AssocList) (key : Key) (def: Value):  Value :=
match (ALFind2 al key) with
| inl (existT _ v _ ) => v
| inr _ => def
end.

(** In proofs, it is often convenient to replace
  [ALFindDef] with [ALFindDef2] so that we get some
  correctness hypotheses for free on destruction*)
Lemma ALFindDef2Same : forall
  (key : Key) (def: Value) (al : AssocList),
  ALFindDef al key def=ALFindDef2 al key def.
Proof.
  induction al as [|h th Hind]; auto;[]. destruct h as [k v].
  allunfold ALFindDef. allunfold ALFindDef2.
  simpl. setoid_rewrite decide_decideP.
  cases_ifd Hd; auto.
  - rw Hdt; auto. subst. rewrite deqP_refl. simpl. refl.
  - unfold ALFindDef2 in Hind.
    rw  Hind.  destruct_head_match; simpl; auto.
    destruct s; auto.
Abort.

Fixpoint ALFilter (sub : AssocList) (keys : list Key) : AssocList :=
  match sub with
  | nil => nil
  | (k, v) :: xs =>
      if (memvar k keys)
      then ALFilter xs keys
      else (k, v) :: ALFilter xs keys
  end.

Lemma ALFilter_nil_r :
  forall sub, ALFilter sub [] = sub.
Proof.
  induction sub; simpl; sp.
  rewrite IHsub; auto.
Qed.

Notation DeqKey := (fun (x y: Key) => decideP (x=y)).

Ltac dec :=
unfold beq_var in *;
unfold memvar in *;
(repeat rewrite decide_decideP);
(repeat rewrite memberb_din);
repeat match goal with
[H:context[decide _] |- _] => rewrite decide_decideP in H
|[H:context[memberb _ _ _] |- _] => rewrite memberb_din in H
end.

Lemma ALDomFilterCommute :
  forall l sub,
    diff l (ALDom sub) = ALDom (ALFilter sub l).
Proof.
  induction sub; simpl; sp; allsimpl.
  - apply diff_nil.
  - rewrite diff_cons_r. dec.
    cases_if; simpl; f_equal; auto.
Qed.

(* for some tactics like cpx *)

Ltac dest t :=
let tf := eval cbv beta in t in
destruct tf.

Lemma ALFindSome :
  forall sub : AssocList,
  forall v : Key,
  forall u : Value,
    ALFind sub v = Some u
    -> LIn (v, u) sub.
Proof.
  induction sub; simpl; sp.
  setoid_rewrite decide_decideP in H.
  dest (DeqKey a0 v); subst; cpx.
  inverts H. cpx.
Qed.

Lemma ALFindNone :
  forall sub v,
    ALFind sub v = None
    -> ! LIn v (ALDom sub).
Proof.
  induction sub; simpl; sp;
  inversion H;
  setoid_rewrite decide_decideP in H;
  setoid_rewrite decide_decideP in H2;
  dest (DeqKey a0 v); cpx.
  apply IHsub in H0;  cpx.
Qed.

Lemma ALFind2Same : forall (sub: AssocList) v, ALFind sub v =
        proj_as_option (ALFind2 sub v).
Proof using.
  induction sub as [| a]; intros; auto; simpl.
  destruct a. dec. dec.
  destruct (decideP (k = v));
  subst; autorewrite with SquiggleEq; simpl in *; auto.
  rewrite IHsub. destruct ((ALFind2 sub v)); simpl;
  try(destruct s; simpl); auto;
  destruct (decideP (v = k)); cpx.
Qed.

Lemma ALFindFilterSome :
  forall l v t sub,
    (ALFind (ALFilter sub l) v = Some t)
    <=> (ALFind sub v = Some t # ! LIn v l).
Proof.
  induction sub; simpl; sp; split; introv H; sp; allsimpl; dec.
  -  destruct (in_deq Key _ a0 l); allsimpl.
    + rw IHsub in H; sp;case_if as Hd; subst;auto; try contradiction.
    + dec.
       case_if as Hd; subst; auto; try contradiction.
      rw IHsub in H; exrepnd; auto.

  - destruct (in_deq Key _ a0 l); allsimpl.
    + apply IHsub in H; exrepnd; auto.
    + dec. dest (DeqKey a0 v); allsimpl; subst; sp;[].
      rw IHsub in H; exrepnd; auto.

  - destruct (in_deq Key _ a0 l); allsimpl.
    + apply IHsub; split; auto. dec.
      dest (DeqKey a0 v); allsimpl; subst; sp.

    + dec. dest (DeqKey a0 v); allsimpl; subst; sp.
       apply IHsub; split; auto.
Qed.

Lemma ALFindFilterNone :
  forall l v sub,
    (ALFind (ALFilter sub l) v = None)
    <=> (ALFind sub v = None [+] LIn v l).
  induction sub; simpl; sp; split; introv H; sp; allsimpl; dec.
  - destruct (in_deq Key _ a0 l); allsimpl; dec;
    dest (DeqKey a0 v); allsimpl;
    subst;
    try(rw IHsub in H);
    exrepnd; auto;cpx.
  - destruct (in_deq Key _ a0 l); allsimpl;dec;
    dest (DeqKey a0 v); allsimpl;
    subst;cpx;apply IHsub; cpx.
  - dec. dest (in_deq Key _ a0 l); allsimpl; dec;
    dest (DeqKey a0 v); allsimpl;
    subst;cpx;apply IHsub; cpx.
Qed.

Lemma ALFilterSwap :
  forall l1 l2 sub,
    ALFilter (ALFilter sub l1) l2
    = ALFilter (ALFilter sub l2) l1.
Proof.
  induction sub; simpl; sp.
  allsimpl; cases_if as H1d; cases_if as H2d;
  allsimpl; try (rw H1d); try (rw H2d);
  cpx; try (rw IHsub); cpx.
Qed.

Lemma ALFilterAppR :
  forall sub vs1 vs2,
    ALFilter sub (vs1 ++ vs2)
    = ALFilter (ALFilter sub vs1) vs2.
Proof.
  induction sub; simpl; sp; dec.
  rw <- memberb_din.
  rw <- memberb_din.
  rw memberb_app.
  destructr (memberb _ a0 vs1) as [m1 | m1]; simpl.
  apply IHsub. unfold memvar.
  allsimpl. destruct (memberb _ a0 vs2) as [m2 | m2];
  simpl; subst;
  try(rw IHsub); auto.
Qed.

Lemma ALFilterAppAsDiff :
  forall sub l1 l2,
    ALFilter sub (l1 ++ l2)
    = ALFilter sub (l1 ++ diff l1 l2).
Proof.
  induction sub; simpl; sp; allsimpl;[].
  dec.
  cases_ifd  Hd; cases_ifd  Hdd; cpx;
  allrw in_app_iff;
  allrw in_diff.
  - provefalse. apply Hddf.
    dorn Hdt; cpx.
  - provefalse. apply Hdf.
    dorn Hddt; exrepnd; cpx.
  - f_equal. auto.
Qed.

(** [lv] is needs to make the induction
    hypothesis strong enough *)
Lemma ALFilterDom : forall  sub lv,
  ALFilter sub (lv++ALDom sub) =[].
Proof.
  induction sub as [|(v,u) sub Hind] ; introv ; auto;[].
  allsimpl; dec.
  cases_ifd Hd; cpx; allsimpl; allrw in_app_iff;
  cpx; dec.
  - rw cons_as_app. rw app_assoc. rw Hind; auto.
  - provefalse. apply Hdf. right. cpx.
Qed.

Fixpoint ALKeepFirst (sub : AssocList) (vars : list Key) : AssocList :=
match sub with
| nil => nil
| (v, t) :: xs =>
    if in_deq _ _ v vars
    then (v, t) :: ALKeepFirst
                   xs
                   (diff [v] vars)
    else ALKeepFirst xs vars
end.

Lemma ALKeepFirstNil :
  forall sub,
    ALKeepFirst sub [] = [].
Proof.
  induction sub; simpl; sp.
Qed.

Lemma ALFindSomeKeepFirstSingleton:
  forall sub v t,
    ALFind sub v = Some t
    -> ALKeepFirst sub [v] = [(v,t)].
Proof.
  induction sub as [|(v,t) sub Hind];
  introv Heq; allsimpl; cpx. dec.
  dest (DeqKey v v0);
  subst;allsimpl; cpx.
  rewrite deqP_refl.
  rw ALKeepFirstNil; auto.
  inversion Heq.
  cpx.
  cases_if; cpx.
Qed.

Lemma ALFindNoneKeepFirstSingleton:
  forall sub v,
    ALFind sub v = None
    -> ALKeepFirst sub [v] = [].
Proof.
  induction sub as [|(v,t) sub Hind];
  introv Heq; allsimpl; cpx.
  dec.
  dest (DeqKey v v0);
  subst;allsimpl; cpx.
  cases_if; cpx.
Qed.
Hint Rewrite ALKeepFirstNil ALFilterDom ALFilter_nil_r : fast.

Ltac cpx :=
  repeat match goal with
           (* false hypothesis *)
           | [ H : [] = snoc _ _ |- _ ] =>
             complete (apply nil_snoc_false in H; sp)
           | [ H : snoc _ _ = [] |- _ ] =>
             complete (symmetry in H; apply nil_snoc_false in H; sp)

           (* simplifications *)
           | [ H : _ :: _ = _ :: _ |- _ ] => inversion H; subst; GC

           | [ H : Some _ = Some _ |- _ ] => inversion H; subst; GC
           | [ H : Some _ = None |- _ ] => inversion H; GC
           | [ H : None = Some _ |- _ ] => inversion H; GC

           | [ H : 0 = length _ |- _ ] =>
             symmetry in H; trw_h length0 H; subst
           | [ H : length _ = 0 |- _ ] =>
             trw_h length0 H; subst

           | [ H : 1 = length _ |- _ ] =>
             symmetry in H; trw_h length1 H; exrepd; subst
           | [ H : length _ = 1 |- _ ] =>
             trw_h length1 H; exrepd; subst

           | [ H : [_] = snoc _ _ |- _ ] =>
             symmetry in H; trw_h snoc1 H; repd; subst
           | [ H : snoc _ _ = [_] |- _ ] =>
             trw_h snoc1 H; repd; subst

           | [ H : context[length (snoc _ _)] |- _ ] =>
             rewrite length_snoc in H
         end;
  inj;
  try (complete (allsimpl; sp)).

Lemma ALKeepFirstLin:
  forall sub v vs t,
    LIn (v,t) (ALKeepFirst sub vs)
    <=> (ALFind sub v = Some t # LIn v vs).
Proof.
  induction sub; simpl; sp;[split;sp|]. dec.
  dest (DeqKey a0 v);
  destruct (in_deq Key _ a0 vs);
  subst; cpx; split; introns Hyp; allsimpl; exrepnd; cpx.
  - dec. dorn Hyp; cpx; cpx. apply IHsub in Hyp.
    exrepnd.
    apply in_remove in Hyp; cpx.
  - dec. cpx.
     apply IHsub in Hyp; exrepnd; cpx.
  - dorn Hyp; cpx. apply IHsub in Hyp.
    exrepnd.
    apply in_remove in Hyp; cpx.
  - right. apply IHsub; dands; cpx.
    apply in_remove; dands; cpx.
Qed.

Lemma ALKeepFirstLinApp:
  forall sub v vs vss t,
    LIn (v,t) (ALKeepFirst sub (vs))
    -> LIn (v,t) (ALKeepFirst sub (vs++ vss)).
Proof.
  introv X.
  apply ALKeepFirstLin in X.
  apply ALKeepFirstLin.
  exrepnd; dands; auto.
  apply in_app_iff.
  cpx.
Qed.

Lemma ALFilterLIn :
  forall v t sub vars,
    LIn (v, t) (ALFilter sub vars)
    <=>
    (
      LIn (v, t) sub
      #
      ! LIn v vars
    ).
Proof.
  induction sub; simpl; sp; dec.
  split; sp. cases_if;
  simpl; allrw; split; sp; cpx.
Qed.

Lemma ALFilterSubset :
  forall sub vars,
    subset (ALFilter sub vars) sub.
Proof.
  introv Hin.
  destruct x;
  rw ALFilterLIn in Hin; cpx.
Qed.

Lemma ALKeepFirstSubst :
  forall sub vars,
    subset (ALKeepFirst sub vars) sub.
Proof.
  introv Hin.
  destruct x;
  rw ALKeepFirstLin in Hin; exrepnd;
  cpx.
  apply ALFindSome; cpx.
Qed.

Hint Resolve ALFilterSubset ALKeepFirstSubst :
  SetReasoning.

Lemma ALKeepFirstAppLin:
  forall lv1 lv2 sub v u,
  LIn (v,u) (ALKeepFirst sub (lv1++lv2))
  -> LIn (v,u) (ALKeepFirst sub lv1) [+]
     LIn (v,u) (ALKeepFirst sub lv2).
Proof. introv Hin.
  apply ALKeepFirstLin in Hin.
  repnd.
  apply in_app_iff in Hin. dorn Hin;[left|right];
  apply ALKeepFirstLin;sp.
Qed.

Lemma ALKeepFirstFilterDiff:
forall sub lvk lvf,
  (ALKeepFirst  sub (diff lvf lvk))
  =
  (ALKeepFirst (ALFilter sub lvf) lvk).
Proof.
  induction sub; allsimpl;
  autorewrite with fast; cpx; dec;[].
  intros. allsimpl.
  destruct a. dec.
  cases_ifd H1d; cases_ifd H2d;
   allrw in_diff; exrepnd; allsimpl; cpx.
  - cases_ifd H3d; cpx. f_equal.
    rw <- diff_remove. apply IHsub.
  - cases_ifd H3d; cpx. provefalse.
    apply H1df. dands;cpx.
Qed.

Lemma ALFilterAppSub :
  forall sub1 sub2 l,
  ALFilter (sub1++sub2) l
  = (ALFilter sub1 l)++(ALFilter sub2 l).
Proof.
  induction sub1; simpl; sp;[].
  rw IHsub1.
  cases_ifd Hd; cpx.
Qed.

Lemma ALFindApp :
  forall v sub1 sub2,
    ALFind (sub1 ++ sub2) v
    = match ALFind sub1 v with
        | Some t => Some t
        | None => ALFind sub2 v
      end.
Proof.
  induction sub1; simpl; sp.
  cases_if; auto.
Qed.

Lemma ALFindRangeMapSome :
  forall v t sub f,
    ALFind sub v = Some t
    -> ALFind (ALMapRange f sub) v
        = Some (f t).
Proof.
  induction sub; simpl; sp; allsimpl;[].
  cases_ifd Hd; cpx.
Qed.

Lemma ALFindRangeMapNone :
  forall v sub f,
    ALFind sub v = None
    -> ALFind (ALMapRange f sub) v = None.
Proof.
  induction sub; simpl; sp; allsimpl.
  cases_ifd Hd; cpx.
Qed.

Fixpoint ALRangeRel  (R : Value -> Value-> [univ])
    (subl subr : AssocList) : [univ] :=
match (subl, subr) with
| ([],[]) => True
| ((vl,tl) :: sl , (vr,tr) :: sr) => (vl=vr # R tl tr # ALRangeRel R sl sr)
| ( _ , _) => False
end.

Lemma ALRangeRelApp : forall R subl1 subl2 subr1 subr2,
  (ALRangeRel  R subl1 subl2 # ALRangeRel R subr1 subr2)
  ->   ALRangeRel R (subl1 ++ subr1)  (subl2 ++ subr2).
Proof.
  induction subl1 as [|(v1,t1) subl1 Hind]; introv Hsr;
  destruct subl2 as [|(v2,t2) subl2]; inverts Hsr; allsimpl;sp.
Qed.

Lemma ALRangeRelRefl : forall R,
  refl_rel R -> refl_rel (ALRangeRel R).
Proof.
  introv Hr. unfold refl_rel in Hr. unfold refl_rel.
  induction x as [|(v1,t1) subl1 Hind];  allsimpl;sp.
Qed.

Lemma ALRangeRelSameDom : forall R
  (subl subr : AssocList),
  ALRangeRel R subl subr
  -> ALDom subl = ALDom subr.
Proof.
  induction subl as [| (kl,vl) subl Hind]; introv Hal;
  destruct subr as [| (kr,vr) subr]; allsimpl; repnd; dands; cpx.
  f_equal; cpx.
Qed.

Lemma ALRangeRelFind : forall R
  (subl subr : AssocList) k t,
  ALRangeRel R subl subr
  -> ALFind subl k = Some t
  -> { tr : Value & ALFind subr k = Some tr # R t tr}.
Proof.
  induction subl as [| (kl,vl) subl Hind]; cpx; introv HAl Hf.
  allsimpl. destruct subr as [| (kr,vr) subr]; cpx;[].
  allsimpl. repnd. subst.
  cases_ifd Hd; cpx.
  eexists; eauto.
Qed.

Lemma ALRangeRelFilter : forall R
  (subl subr : AssocList) l,
  ALRangeRel R subl subr
  ->  ALRangeRel R
        (ALFilter  subl l)
        (ALFilter  subr l).
Proof.
  induction subl as [| (kl,vl) subl Hind]; introv Hal;
  destruct subr as [| (kr,vr) subr]; allsimpl; repnd; dands; subst; cpx.
  cases_if; cpx.
Qed.

(* hints should be placed (again) after this line.
  the ones in the section get deactivated
 *)
End AssociationList.
Hint Rewrite ALKeepFirstNil ALFilterDom ALFilter_nil_r
  ALRangeCombine ALDomCombine: fast.

Hint Resolve ALFilterSubset ALKeepFirstSubst :
  SetReasoning.

Definition ALSwitch {K V} (sub : AssocList K V)  : AssocList V K :=
  map (fun x => (snd x, fst x)) sub.

Lemma ALSwitchCombine : forall {K V} (lv: list V) (lk : list K) ,
  combine lv lk = ALSwitch (combine lk lv).
Proof.
  induction lv; allsimpl.
  - destruct lk; cpx.
  - destruct lk; cpx.
    allsimpl. f_equal. cpx.
Qed.

Lemma ALMapRangeFilterCommute :
  forall K V l T (deq : Deq K) (f: V -> T) (sub : AssocList K V),
  (ALFilter (ALMapRange f sub) l)  = ALMapRange f (ALFilter sub l).
Proof.
  induction sub; simpl; sp; allsimpl.
  cases_if; simpl; auto; f_equal; auto.
Qed.

Ltac dec :=
unfold beq_var in *;
(repeat rewrite decide_decideP);
(repeat rewrite memberb_din);
repeat match goal with
[H:context[decide _] |- _] => rewrite decide_decideP in H
|[H:context[memberb _ _ _] |- _] => rewrite memberb_din in H
end.

Lemma ALFindMapSome :
  forall {KA KB VA VB : Type}
    (DKA : Deq KA)
    (DKB : Deq KB)
    (fk : KA -> KB)
    (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA)
      v t, ALFind sub v = Some t
  -> ALFind  (ALMap fk fv sub) (fk v)
        = Some (fv t).
Proof.
  introv Hik.
  induction sub;simpl; introv Heq; sp; allsimpl;[].
  dec.
  cases_ifd Hd; cpx.
  + f_equal. apply Hik in Hdt.
    destruct Hdt. rewrite deqP_refl in Heq.
    invertsn Heq. refl.
  + apply IHsub. revert Heq. cases_ifd Hdd;
    subst; cpx.
Qed.

Lemma ALFindMapNone :
  forall {KA KB VA VB : Type}
    (DKA : Deq KA)
    (DKB : Deq KB)
    (fk : KA -> KB)
    (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA)
      v, ALFind  sub v = None
  -> ALFind (ALMap fk fv sub) (fk v)
        = None.
Proof.
  introv Hik.
  induction sub;simpl; introv Heq; sp; allsimpl;[].
  dec.
  cases_ifd Hd; cpx.
  + f_equal. apply Hik in Hdt.
    destruct Hdt. rewrite deqP_refl in Heq.
    invertsn Heq.
  + apply IHsub. revert Heq. cases_ifd Hdd;
    subst; cpx.
Qed.

Lemma ALFindEndoMapSome :
  forall {KA VA VB: Type}
    (DKA : Deq KA)
    (fk : KA -> KA)
    (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA)
      v, ALFind sub v = None
  -> ALFind (ALMap fk fv sub) (fk v)
        = None.
Proof.
  intros. eapply ALFindMapNone; eauto.
Qed.

Lemma ALMapFilterCommute :
  forall {KA KB VA VB : Type}
  (DKA : Deq KA)
  (DKB : Deq KB)
  (fk : KA -> KB)
  (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA) l,
      (ALFilter  (ALMap fk fv sub) (map fk l))
          = ALMap fk fv (ALFilter  sub l).
Proof.
  introv Hin.
  induction sub; simpl; sp; allsimpl;
  dec. dec.
  cases_ifd Hd; cases_ifd Hc;
    simpl; auto; f_equal; auto.
  - dec. apply in_map_iff in Hdt. exrepnd. apply Hin in Hdt1.
    subst. cpx.
  - rw in_map_iff in Hdf. provefalse.
    apply Hdf. eexists; eauto.
Qed.

(** endo maps avoid the need to provide another
    decider for keys *)
Lemma ALEndoMapFilterCommute :
  forall {KA VA VB : Type}
  (DKA : Deq KA)
  (fk : KA -> KA)
  (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA) l,
      (ALFilter  (ALMap fk fv sub) (map fk l))
          = ALMap fk fv (ALFilter  sub l).
Proof.
  intros. apply ALMapFilterCommute; auto.
Qed.

Lemma ALMapRangeFindCommute :
  forall K V T (v: K) (deq : Deq K) (f: V -> T) (sub : AssocList K V),
  (ALFind  (ALMapRange f sub) v)  = option_map f (ALFind  sub v).
Proof.
  induction sub; simpl; sp; allsimpl.
  cases_if; simpl; auto; f_equal; auto.
Qed.

(* Move *)
Ltac dALFind sn :=
  match goal with
    | [  |- context[ALFind ?s ?v] ] =>
      let sns := fresh sn "s" in
      remember (ALFind s v) as sn;
        destruct sn as [sns |]
    | [ H: context[ALFind ?s ?v] |- _ ] =>
      let sns := fresh sn "s" in
      remember (ALFind s v) as sn;
        destruct sn as [sns |]
  end.

Lemma ALMapCombine :
  forall {KA KB VA VB : Type}
    (fk : KA -> KB)
    (fv : VA -> VB) ka va,
  ALMap fk fv (combine ka va)
  = (combine (map fk ka) (map fv va)).
Proof using.
  induction ka; intros ?; eauto.
  simpl.
  destruct va; auto.
  unfold ALMap. simpl.
  f_equal. eauto.
Qed.

Lemma ALFindMap2 :
  forall {KA KB VA VB : Type}
    {DKA : Deq KA}
    {DKB : Deq KB}
    (fk : KA -> KB)
    (fv : VA -> VB),
  forall (sub : AssocList KA VA) k,
  (forall s, In s sub -> fk (fst s) = fk k -> fst s = k)
  -> ALFind  (ALMap fk fv sub) (fk k) = option_map fv (ALFind  sub k).
Proof using.
  clear.
  introv Hik.
  induction sub;simpl; sp; allsimpl;[].
  dec.
  cases_ifd Hd; cpx.
  + specialize (Hik _ (or_introl eq_refl)). symmetry in Hdt.
    simpl in Hik. symmetry in Hdt.
    apply Hik in Hdt. subst.
    rewrite deqP_refl. refl.
  + rewrite IHsub.
    * clear IHsub. dec. cases_if as Hd;
      subst; cpx.
    * intros ? ?. apply Hik. cpx.
Qed.

Lemma ALFindMap :
  forall {KA KB VA VB : Type}
    {DKA : Deq KA}
    {DKB : Deq KB}
    (fk : KA -> KB)
    (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA) k,
  ALFind  (ALMap fk fv sub) (fk k) = option_map fv (ALFind  sub k).
Proof using.
  introv Hik. intros. apply ALFindMap2.
  intros ? ?. apply Hik.
Qed.

Lemma ALFindNoneIf {KA VA : Type}
    {DKA : Deq KA} :
  forall k (sub: AssocList KA VA),
  (not (In k (ALDom sub))) -> ALFind  sub k = None.
Proof using.
  intros ? ? ?.
  dALFind ss;[| refl].
  provefalse.
  symmetry in Heqss.
  apply ALFindSome in Heqss.
  apply ALInEta in Heqss. tauto.
Qed.

Notation lmap := AssocList.

(*this is slightly different from ALFind2*)
Lemma lmap_find :
  forall {A B: Type}
         (eqdec: Deq A) (sub: lmap A B) (a : A) ,
    { b: B & LIn (a,b) sub}
    + !(LIn a (fst (split sub))).
Proof.
   induction sub as [| (a', b') sub Hind]; intro a.
   - right.  sp.
   - destruct (decideP (a'= a)) as [Hc|Hc]; subst.
      + left. exists b'. left; refl.
      + destruct (Hind a) as [Hl | Hr]; exrepnd ;[left | right].
          * exists b. right; auto.
          * intro Hf. apply Hr. simpl in Hf. destruct (split sub).
              dorn Hf; sp.
Defined.

Notation dom_lmap := ALDom.

(**same as above, but the impelemtation is guaranteed to return the first match*)
Lemma lmap_find_first: forall {A B: Type}
  (eqdec: Deq A) (sub: lmap A B) (a : A) ,
    { b: B & {n:nat & n < length sub
            # nth n sub (a,b) = (a,b)
            # (forall m, m<n ->  (nth m (dom_lmap sub) a) <> a) } }
       + !LIn a (dom_lmap sub).
Proof.
   induction sub as [| (a', b') sub Hind]; intro a.
   - right.  sp.
   - destruct (decideP (a'=a)) as [Hc|Hc]; subst.
      + left. exists b'. exists 0. split; simpl; auto. apply  lt_0_Sn.
        split; auto. introv Hm; inverts Hm.
      + destruct (Hind a) as [Hl | Hr]; exrepnd ;[left | right].
          * exists b. exists (S n). repeat(split); auto; simpl. apply lt_n_S. auto.
            introv Hlt. destruct m; auto. apply Hl1. apply lt_S_n; auto.
          * introv Hf. apply Hr. simpl in Hf.
              dorn Hf; sp.
Defined.

Lemma ALFindMap3:
forall {KA KB VA VB : Type} {DKA : Deq KA} {DKB : Deq KB}
         (fv : VA -> VB) (sub : lmap KA VA) (k : KA),
       ALFind (ALMap id fv sub) k = option_map fv (ALFind sub k).
Proof using.
  intros.
  apply (ALFindMap2 id fv).
  intros; destruct s; simpl in *; assumption.
Qed.

(* Move :there must be something similar in stdlib or, Extlib, or UsefulTypes.v *)
Definition eqfun {A B:Type} (f g : A -> B) :=
  forall a, f a = g a.

Definition ALFindEndo {Key:Type} {d:Deq Key} (sub: AssocList Key Key)  (k:Key) : Key :=
  ALFindDef sub k k.

Lemma ALFindEndoId {Key:Type} {d:Deq Key} (sub: AssocList Key Key) v :
  disjoint [v] (ALDom sub)
  -> ALFindEndo sub v = v.
Proof using.
  intros.
  unfold ALFindEndo, ALFindDef.
  rewrite ALFindNoneIf;[refl|].
  firstorder.
Qed.

Lemma ALFindEndoId2 {Key:Type} {d:Deq Key} lv v:
  ALFindEndo (map (fun x=> (x,x)) lv) v = v.
Proof using.
  unfold ALFindEndo, ALFindDef.
  dALFind sd; [| refl].
  symmetry in Heqsd.
  apply ALFindSome in Heqsd. apply in_map_iff in Heqsd.
  exrepnd. inverts Heqsd1. refl.
Qed.

Lemma ALFindMapEndoId {Key:Type} {d:Deq Key} (sub: AssocList Key Key) lv:
  disjoint lv (ALDom sub)
  -> map (ALFindEndo sub) lv = lv.
Proof using.
  intros Hd.
  rewrite <- (map_id lv) at 2.
  apply eq_maps.
  intros ? Hin.
  apply ALFindEndoId.
  eapply subset_disjoint;[| apply Hd].
  apply singleton_subset. assumption.
Qed.

Lemma vmap_app_nest {NVar:Type} {deq : Deq NVar} (sub1 sub2: AssocList NVar NVar):
  disjoint (ALRange sub1) (ALDom sub2)
  -> eqfun (ALFindEndo (sub1++sub2)) ((ALFindEndo sub2) ∘ (ALFindEndo sub1)).
Proof using.
  intros Hd.
  intros v. unfold compose, ALFindEndo, ALFindDef.
  rewrite ALFindApp. dALFind s1v; auto.
  rewrite ALFindNoneIf;[refl|].
  apply Hd. symmetry in Heqs1v.
  apply ALFindSome in Heqs1v. apply in_map_iff.
  eexists; dands ; eauto. auto.
Qed.

Lemma vmap_decompose {NVar:Type} {deq : Deq NVar}  (lv : list NVar) (sub: AssocList NVar NVar):
  let subOuter := map (fun v => (v,  (ALFindEndo sub) v)) lv in
  let subInner := ALFilter sub lv in
  disjoint (ALRange sub) lv
  -> eqfun (ALFindEndo sub) ((ALFindEndo subOuter) ∘ (ALFindEndo subInner)).
Proof using.
  simpl. intros Hd a.
  rewrite  <- vmap_app_nest;
    [| setoid_rewrite map_map; unfold compose; simpl; rewrite map_id;
       eapply subset_disjoint; try apply Hd; apply map_monotone, ALFilterSubset].
  unfold ALFindEndo, ALFindDef.
  setoid_rewrite ALFindApp. symmetry.
  dALFind sfa; simpl; symmetry in Heqsfa;
    [apply ALFindFilterSome in Heqsfa | apply ALFindFilterNone in Heqsfa]; repnd;
      try rewrite  Heqsfa0;[refl|].
  dALFind sm; symmetry in Heqsm.
  - apply ALFindSome in Heqsm. apply in_map_iff in Heqsm. exrepnd. inverts Heqsm1. refl.
  - apply ALFindNone in Heqsm. setoid_rewrite map_map in Heqsm. unfold compose in Heqsm.
    simpl in Heqsm. rewrite map_id in Heqsm. dorn Heqsfa; cpx;[]. rewrite Heqsfa. refl.
Qed.

Global Instance eqfunEquiv {A B:Type}: Equivalence (@eqfun A B).
Proof using.
  constructor; introv; unfold eqfun; try congruence.
Qed.

Lemma combine_of_map_snd {A B C :Type} (f: B->C) (la:list A) lb :
  combine la (map f lb) = map (fun x => (fst x, f (snd x))) (combine la lb).
Proof.
  revert lb.
  induction la as [| a la Hind]; intros;[|destruct lb as [|b lb]]; simpl; auto.
  f_equal.
  eauto.
Qed.

Lemma vmap_nest_same {NVar:Type} {deq : Deq NVar}  (vl vi vr : list NVar):
  let subOuter := combine vi vr  in
  let subInner := combine vl vi in
  let sub := combine vl vr in
  length vi = length vr
  -> length vi = length vl
  -> NoDup vi
  -> eqfun (ALFindEndo sub) ((ALFindEndo subOuter) ∘ (ALFindEndo subInner)).
Proof using.
  simpl. intros Hd H1l H2l a.
  rewrite (combine_map_snd2 vr vi) at 1 by omega.
  rewrite (combine_map_fst2 vi vr) at 3 by omega.
  unfold ALFindEndo, ALFindDef. simpl.  simpl. unfold compose. simpl.
  remember  (ALFind (combine vl (map fst (combine vi vr))) a) as ss.
  do 1 rewrite combine_of_map_snd.
  setoid_rewrite combine_of_map_snd in Heqss.
  replace (map (fun x : NVar * (NVar * NVar) => (fst x, snd (snd x))) (combine vl (combine vi vr)))
          with (ALMapRange snd  (combine vl (combine vi vr))) by refl.
  replace (map (fun x : NVar * (NVar * NVar) => (fst x, fst (snd x))) (combine vl (combine vi vr)))
     with (ALMapRange fst  (combine vl (combine vi vr))) in Heqss by refl.
  setoid_rewrite ALFindMap3.
  setoid_rewrite ALFindMap3 in Heqss.
  subst.
  dALFind  sa; simpl; symmetry in Heqsa.
- admit.
- assert (~ LIn a (remove_nvars vl vi)) as Ha by admit.
  apply ALFindNone in Heqsa.
  setoid_rewrite <- combine_map_fst2 in Heqsa;[| rewrite length_combine_eq; omega].
  rewrite in_remove_nvars in Ha.
  dALFind sia; auto.
  symmetry in Heqsia.
  apply ALFindSome in Heqsia.
  apply in_combine_l in Heqsia. tauto.
Abort.

Require Import SetoidList.
(* move to SquiggleEq.AssocList *)
   Lemma ALRangeRelCombine {V T:Type} (lv:list V) lt1 lt2  (R: T-> T-> Prop):
    eqlistA R lt1 lt2 -> ALRangeRel R (combine lv lt1) (combine lv lt2).
 Proof using.
   intros Heq. revert lv.
   induction Heq;destruct lv; simpl; eauto.
 Qed.


Require Import include_frm.
Require Import sep_auto.

Set Implicit Arguments.

(* Aabsdata _ _ imply OSAbstMod.get *)

Lemma emp_disj:
  forall  (A B T : Type) (MC: PermMap A B T)   O ,
    disjoint O emp.
Proof.
  intros.
  unfolds.
  exists O.
  apply map_join_emp.
Qed.

Hint Resolve emp_disj : abst_solver_base.

Lemma absdata_elim :
  forall s O gamma x y P,
    (s, O, gamma) |= Aabsdata x y ** P ->
    get O x = Some y.
Proof.
  intros.
  destruct s as [ [ [ [ ] ] ] ].
  simpl in *.
  simp join.
  eapply  join_sig_get_disj; eauto.
Qed.

(*
Lemma disj_is_disjoin :
  forall a b,
    disjoint a b -> OSAbstMod.disj a b.
Proof.
  intros.
  unfold OSAbstMod.disj.
  unfold disjoint in H.
  intros.
  simpljoin.
  unfold join in H.
  simpl in H.
  unfold OSAbstMod.join in H.
  lets ff: H a0.
  destruct (OSAbstMod.get a a0);
  destruct (OSAbstMod.get b a0);
  auto.
Qed.
*)

Lemma absdata_elim' :
  forall s O O' gamma x y P,
    (s, O, gamma) |= Aabsdata x y ** P ->
    disjoint O O' ->
    get (merge O O') x = Some y.
Proof.
  intros.
  destruct s as [ [ [ [ ] ] ] ].
  simpl in *.
  simp join.
  eapply  join_sig_get_disj in H3.
  simp join.
  eapply disj_get_merge_get; eauto.
  unfolds; simpl; auto.
Qed.

Lemma get_set_idneq:
  forall (O: OSAbstMod.listset) Of id id' x y,
    disjoint O Of ->
    get O id' = Some y ->
    get O id = Some x ->
    id <> id' ->
    get (merge (set O id' y) Of) id = Some x.
Proof.
  intros.
  eapply disj_get_merge_get .
  unfolds; simpl; auto.
  eapply abst_get_set_disj; eauto.
  eapply get_set_neq; eauto.
Qed.

Lemma get_set_idneq':
  forall (O: OSAbstMod.listset) O' x y x' y' y'',
    disjoint O O' ->
    get O x = Some y ->
    get O x' = Some y' ->
    x <> x' ->
    get (merge (set O x y'') O')  x' = Some y'.
Proof.
  intros.
  eapply disj_get_merge_get .
  unfolds; simpl ; auto.
  eapply abst_get_set_disj; eauto.
  eapply get_set_neq; eauto.
Qed.

Lemma absdata_elim'' :
  forall (s : taskst) (O O' O'' : OSAbstMod.map)
         (gamma : absop) (x x': absdataid) (y y' y'' : absdata) (P : asrt),
    O'' = set O x y'' ->
    (s, O, gamma) |= Aabsdata x y ** Aabsdata x' y' ** P ->
    disjoint O O' ->
    get (merge O'' O') x' = Some y' /\ disjoint O'' O'.
Proof.
  intros.
  simpl in H0.
  simp join.
  apply join_sig_get_disj in H9.
  simp join.
  apply join_sig_get_disj in H4.
  simp join.
  assert (get O x' = Some y').
  eapply sub_get_get; eauto.
  split.
  eapply  get_set_idneq'; eauto.
  introv Hf.
  subst x.
  tryfalse.
  eapply abst_get_set_disj; eauto.
  unfolds; simpl; auto.
  unfolds; simpl; auto.
Qed.

Lemma eqdomO_same:forall O,eqdomO O O.
Proof.
  intros.
  unfolds;split; intros.
  split; auto.
  eexists.
  split;eauto.
  unfolds.
  intros;split;auto.
Qed.
(*
Lemma set_eqdom: forall O Of id x y, OSAbstMod.disj O Of -> OSAbstMod.get O id = Some x -> eqdomO (OSAbstMod.merge O Of) (OSAbstMod.merge (OSAbstMod.set O id y) Of).
Proof.
  intros.
  eapply OSAbstMod.eqdom_merge_set; eauto.
Qed.
*)
Lemma eqdomtls_trans : forall a b c, eqdomtls a b -> eqdomtls b c -> eqdomtls a c.
Proof.
  intros.
  unfold eqdomtls in *.
  intro.
  rewrite H.
  auto.
Qed.

Lemma eqdomO_trans:forall O O' O'', eqdomO O O' -> eqdomO O' O'' -> eqdomO O O''.
Proof.
  intros; unfold eqdomO in *.
  simpljoin.
  intros; split.
  intros.
  rewrite H.
  auto.
  intros.
  lets fff: H2 H3.
  simpljoin.
  lets bb: H1 H4.
  simpljoin.
  exists x0.
  split; auto.
  eapply eqdomtls_trans; eauto.
Qed.

(*

Lemma set_eqdom': forall O O' Of id x y, OSAbstMod.disj O' Of -> OSAbstMod.get O' id = Some x ->eqdomO (OSAbstMod.merge O Of) (OSAbstMod.merge O' Of) -> eqdomO (OSAbstMod.merge O Of) (OSAbstMod.merge (OSAbstMod.set O' id y) Of).
Proof.
  intros.
  eapply eqdomO_trans;eauto.
  eapply set_eqdom;eauto.
Qed.
*)

Lemma get_set_ideq:
  forall(O: OSAbstMod.listset)  Of id y y',
    disjoint O Of ->
    get O id =  Some y' ->
    isRw y' = true ->
    get (merge (set O id y) Of) id = Some y.
Proof.
  intros.
  eapply disj_get_merge_get; eauto.
  eapply abst_get_set_disj; eauto.
  eapply get_set_eq.
Qed.

Lemma abst_disj_merge_set_eq:
  forall x y id (O: OSAbstMod.listset) Of,
    disjoint O Of ->
    get O id = Some x ->
    isRw x = true ->
    merge (set O id y) Of = set (merge O Of) id y.
Proof.
  intros.
  unfold disjoint in H.
  destruct H.
  eapply  join_merge_set_eq; eauto.
Qed.

Lemma abst_disj_merge_set_eq':
  forall x y y' x' id id' (O: OSAbstMod.listset) Of,
    disjoint O Of ->
    get O id = Some x ->
    get O id' = Some x' ->
    merge (set (set O id y) id' y') Of =set (set (merge O Of) id y) id' y'.
Proof.
  intros.
  unfolds in H.
  destruct H.
  assert (merge (set (set O id y) id' y') Of = set (merge (set O id y) Of) id' y').
  assert (id = id' \/ id <> id') by tauto.
  destruct H2.
  eapply  join_merge_set_eq; eauto.
  eapply  join_set_set; eauto.
  subst.
  eapply get_set_eq ; eauto.
  eapply  join_merge_set_eq; eauto.
  eapply  join_set_set; eauto.
  eapply get_set_neq ; eauto.
  rewrite H2.
  assert (merge (set O id y) Of = set (merge O Of) id y).
  eapply abst_disj_merge_set_eq;eauto.
  unfolds.
  eauto.
  rewrite H3.
  auto.
Qed.

Lemma abst_set_get_neq'':
  forall id1 id2 y (O: OSAbstMod.listset),
    id1<>id2 ->
    get (set O id2 y) id1 = get O id1.
Proof.
  intros.
  erewrite get_set_neq; eauto.
Qed.

Lemma abs_join_sig_set_join:
  forall a b (O O1 : OSAbstMod.map) id,
    join (sig id a) O1 O -> join (sig id b) O1 (set O id b).
Proof.
  intros.
  eapply  join_sig_set; eauto.
Qed.

Ltac find_absdata' Hp id :=
  match Hp with
    | ?A ** ?B =>
      match find_absdata' A id with
        | some ?a => constr:(some a)
        | none ?a =>
          match find_absdata' B id with
            | some ?b => constr:(some (a + b)%nat)
            | none ?b => constr:(none (a + b)%nat)
          end
      end
    | Aabsdata id _  => constr:(some 1%nat)
    | _ => constr:(none 1%nat)
  end.

Ltac find_absdata Hp id :=
  let x := find_absdata' Hp id in
  eval compute in x.

Lemma get_none_joinisig:
  forall (qls:EcbMod.map)  qid x,
    get qls qid = None ->
    joinsig qid x qls (set qls qid x).
Proof.
  intros.
  unfolds.
  eapply get_join_sig_set; eauto.
Qed.

Lemma joinisig_get_none:
  forall (qls :EcbMod.map)  qls' qid x,
    joinsig qid x qls qls' ->
    get qls qid = None /\ qls'= (set qls qid x).
Proof.
  intros.
  split.
  apply join_sig_get_disj in H.
  simp join.
  auto.
  unfolds; simpl; auto.
  apply get_join_sig_set_rev; auto.
Qed.

Ltac absdata_solver :=
  match goal with
    | H : (_,?O,_) |= ?P |- get (merge ?O _) ?id = Some _ =>
      match find_absdata P id with
        | none _ => fail 1
        | some ?n =>
          sep lift n in H; eapply absdata_elim' in H; eauto with abst_solver_base
      end
    | H : (_,?O,_) |= ?P |- get ?O ?id = Some _ =>
      match find_absdata P id with
        | none _ => fail 1
        | some ?n =>
          sep lift n in H; eapply absdata_elim in H; eauto with abst_solver_base
      end
    | |- merge (set (set _ _ _) _ _) _ =
         set ( set (merge _ _) _ _) _ _    =>
      eapply  abst_disj_merge_set_eq';first [absdata_solver | eauto ]
    | |- merge (set _ _ _ ) _ = set (merge _ _) _ _ =>
      eapply abst_disj_merge_set_eq;first [absdata_solver | eauto ]
    | |- get (set _ _ _) _ = Some _ =>
      try solve  [ eapply  get_set_eq; auto
                 | erewrite abst_set_get_neq'';[ absdata_solver | auto ;try (intro; tryfalse)]]
    | |- _ _ _ _ _ => try solve [eapply get_none_joinisig;eauto]
  end.

Import DeprecatedTactic.

Lemma cancel_absdata_p:
  forall s O gamma gamma' P Q id a b,
    (forall O', (s, O', gamma) |= P -> (s, O', gamma') |= Q) ->
    ((s, O, gamma) |= Aabsdata id a ** P -> (s, set O id b, gamma') |= Aabsdata id b ** Q).
Proof.
  intros.
  simpl in *;mytac.
  exists empmem.
  destruct s as [[[[]]]].
  simpl in H5.
  simpl in H6.
  subst x;simpl in H1.
  exists m m.
  exists (sig id b) x3 (set O id b).
  simpl;mytac.
  eapply abs_join_sig_set_join; eauto.
  auto.
Qed.

Lemma cancel_absdata_p':
  forall s O gamma P id a b,
    (s, O, gamma) |= Aabsdata id a ** P -> (s, set O id b, gamma) |= Aabsdata id b ** P.
Proof.
  introv Hx.
  intros.
  simpl in *;mytac.
  exists empmem.
  destruct s as [[[[]]]].
  simpl in H5.
  simpl in H4.
  subst x;simpl in H0.
  exists m m.
  exists (sig id b) x3 (set O id b).
  simpl;mytac.
  eapply abs_join_sig_set_join; eauto.
  auto.
Qed.

Ltac get_absdata_number' P id :=
  match P with
    | ?A ** ?B => match get_absdata_number' A id with
                    | (some ?m) => constr:(some m)
                    | (none ?m) => match get_absdata_number' B id with
                                     | (some ?n) => constr:(some (m + n)%nat)
                                     | (none ?n) => constr:(none (m + n)%nat)
                                   end
                  end
    | Aabsdata id _ => constr:(some 1%nat)
    | _ => constr:(none 1%nat)
  end.

Ltac get_absdata_number P id :=
  let y := get_absdata_number' P id in
  eval compute in y.

Ltac cancel_absdata :=
  match goal with
    | H: (?s,?O,_) |= ?P |- (?s,set ?O ?id _,_) |= ?Q =>
      match (get_absdata_number P id) with
        | some ?n => match (get_absdata_number Q id) with
                     | some ?m =>
                       sep lift n in H; sep lift m;
                       generalize dependent H; eapply cancel_absdata_p; intros
                     | _ => idtac
                   end
        | _ => idtac
      end
  end.

Ltac cancel_absdata' :=
  match goal with
    | |- (?s,set ?O ?id _,_) |= ?P =>
      match (get_absdata_number P id) with
        | some ?n => sep lift n; eapply cancel_absdata_p'; cancel_absdata'
        | _ => idtac
      end
    | _ =>idtac
  end.

(*

Ltac ins_aop :=
  match goal with
    | H: (_, ?O, ?aop) |= _ |- _ |= <|| ?aop' ||> ** _ =>
      instantiate (1:=aop')
  end.

Ltac ins_abst' P O tm:=
  match P with
    | ?P1 ** ?P2 => match (ins_abst' P2 O tm) with
                      | ?O' => ins_abst' P1 O' tm
                    end
    | HECBList (EcbMod.set ?ecbls ?x ?b) =>
      constr:(OSAbstMod.set O absecblsid (absecblist (EcbMod.set ecbls x b)))
    | HTCBList (TcbMod.set ?tcbls ?x ?b) =>
      constr:(OSAbstMod.set O abstcblsid (abstcblist (TcbMod.set tcbls x b)))
    | HTime tm => constr:(O)
    | HTime ?tm' => constr:(OSAbstMod.set O ostmid (ostm tm'))
    | _ => constr:(O)
  end.

Ltac ins_abst:=
  match goal with
    | H: (_,?O,_) |= HECBList _ ** HTCBList _ ** HTime ?tm ** HCurTCB _ ** _ |- _|= ?P =>
      match ins_abst' P O tm with
        | ?O' => instantiate (1:=O')
      end
  end.
Ltac exists_O_aop:=
  do 2 eexists;splits;[ ins_aop;ins_abst | | ].

Definition absimp'':= fun p p' : asrt =>
forall (s : taskst) (O : osabst) (gamma : absop),
(s, O, gamma) |= p ->
forall Of : OSAbstMod.map,
OSAbstMod.disj O Of ->
exists O' gamma',
(s, O', gamma') |= p'/\
OSAbstMod.disj O' Of /\
hmstepstar gamma (OSAbstMod.merge O Of) gamma' (OSAbstMod.merge O' Of) .

Lemma absimp'_imp_absimp:
 forall P P',absimp' P P' -> absimp' P P'.
  intros.
  unfold absimp,absimp' in *.
  intros.
  lets Hx: H H0 H1.
  mytac;do 2 eexists;splits;eauto.
Qed.

Ltac disj_solver:=
    match goal with
      | |- OSAbstMod.disj (OSAbstMod.set _ _ _) _ =>
        eapply abst_get_set_disj;[ auto;absdata_solver | disj_solver;auto ]
      | _ => auto
    end.

(*
Ltac eqdomO_solver :=
  match goal with
    | |- eqdomO _ _ => first [ eapply eqdomO_same | eapply set_eqdom'; [disj_solver | absdata_solver | eqdomO_solver]]
  end. *)

Lemma hmstepS_One:
  forall a b c d,
    hmstep a b c d->
    hmstepstar a b c d.
Proof.
  intros.
  eapply spec_stepS;
   [
      eauto  | eapply spec_stepO].
Qed.

*)


From Ltac2 Require Import Ltac2.
Require Import Waterproof.tactics.unfold.

Require Import Waterproof.notations.notations.
Require Import Reals.
Require Import Waterproof.load.
Import databases_RealsAndIntegers.
(*Require Import Waterproof.populate_database.waterproof_integers.
Require Import Waterproof.populate_database.waterproof_reals.*)
Open Scope R_scope.

(** * Sequences in metric spaces *)
(** * TODO change the naming in this file *)
Definition convergence {M : Metric_Space}
                       (a : ℕ → Base M)
                       (c : Base M) :=
  ∀ ε : ℝ, ε > 0 ⇒
    ∃ N : ℕ, ∀ n : ℕ, (n ≥ N)%nat ⇒
      dist M (a n) c < ε.

Definition bounded {X : Metric_Space} (a : ℕ → Base X) :=
  ∃ q : Base X,
    ∃ M : ℝ, M > 0 ⇒
      ∀ n : ℕ, dist X (a n) q ≤ M.

Declare Scope metric_scope.
Notation "a ⟶ c" := (convergence a c) (at level 20) : metric_scope.
Local Ltac2 unfold_convergence    ()          := unfold convergence.
Local Ltac2 unfold_convergence_in (h : ident) := unfold convergence in $h.
Ltac2 Notation "Expand" "the" "definition" "of" "⟶" cl(opt(seq("in", "(", ident, ")"))) :=
  expand_def_framework unfold_convergence unfold_convergence_in cl.

(* With -->, waterproof complains, giving the following error:
    Command not supported (No proof-editing in progress)*)

Notation "a '_converges' 'to_' p" := (convergence a p) (at level 68) : metric_scope.
Notation "a 'converges' 'to' p" := (convergence a p) (at level 68, only parsing) : metric_scope.
Ltac2 Notation "Expand" "the" "definition" "of" "converges" "to" cl(opt(seq("in", "(", ident, ")"))) :=
  expand_def_framework unfold_convergence unfold_convergence_in cl.

(* Index shift*)
Require Import Waterproof.AllTactics.
Require Import Waterproof.populate_database.all_databases.
Require Import Waterproof.load_database.RealsAndIntegers.
Lemma relation_shift {X : Metric_Space} (a : nat -> Base X) (k : nat) (n : nat) (n_ge_k : (n ≥ k)%nat) :
  a ((n - k) + k)%nat = a n.
Proof.
We conclude that (a (n - k + k) = a n)%nat.
Qed.

#[export] Hint Resolve relation_shift : waterproof_integers.
#[export] Hint Extern 1 (_ = _) => (rewrite relation_shift) : waterproof_integers.

Close Scope R_scope.


(** Projet LTPF **)

(*
|-------+--------------+--------------|
|       | Bousquet Thomas | Catteau Pierrick |
|-------+--------------+--------------|
| 1.1.1 |              |             x|
| 1.1.2 |              |             x|
| 1.1.3 |              |             x|
| 1.1.4 |              |              |
| 1.2.1 |              |              |
|-------+--------------+--------------|
| 2.1.1 |              |              |
| 2.1.2 |              |              |
| 2.1.3 |              |              |
| 2.1.4 |              |              |
| 2.2.1 |              |              |
| 2.2.2 |              |              |
| 2.3.1 |              |              |
| 2.3.2 |              |              |
| 2.3.3 |              |              |
| 2.4.1 |              |              |
| 2.4.2 |              |              |
| 2.4.3 |              |              |
| 2.4.4 |              |    non traité|
|-------+--------------+--------------|
| 3.1   |              |              |
| 3.2   |              |              |
| 3.3.1 |              |              |
| 3.3.2 |              |              |
| 3.3.3 |              |              |
| 3.4   |              |              |
| 3.5   |              |              |
| 3.6   |              |              |
| 3.7.1 |              |              |
| 3.7.2 |              |              |
| 3.7.3 |              |              |
| 3.7.4 |              |              |
| 3.7.5 |              |              |
| 3.8   |              |              |
| 3.9   |              |              |
|-------+--------------+--------------|
 *)

(** 2.3.1 **)

(* On importe les bibliothèques de Coq utiles pour le TD   *)

Require Import Bool Arith List.
Import List.ListNotations.

(* ========================================================================== *)
(** * Préliminaires *)
(** ** Syntaxe des expressions arithétiques *)

Inductive aexp :=
| Aco : nat -> aexp (** constantes *)
| Ava : nat -> aexp (** variables *)
| Apl : aexp -> aexp -> aexp
| Amu : aexp -> aexp -> aexp
| Amo : aexp -> aexp -> aexp
.

(** ** Syntaxe des expressions booléennes *)

Inductive bexp :=
| Btrue : bexp
| Bfalse : bexp
| Bnot : bexp -> bexp
| Band : bexp -> bexp -> bexp
| Bor : bexp -> bexp -> bexp
| Beq : bexp -> bexp -> bexp    (* test égalité de bexp *)
| Beqnat : aexp -> aexp -> bexp (* test égalité de aexp *)
.

(** ** Syntaxe du langage impératif WHILE *)

Inductive winstr :=
| Skip   : winstr
| Assign : nat -> aexp -> winstr
| Seq    : winstr -> winstr -> winstr
| If     : bexp -> winstr -> winstr -> winstr
| While  : bexp -> winstr -> winstr
.

(* -------------------------------------------------- *)
(** ** États *)

Definition state := list nat.

Fixpoint get (x:nat) (s:state) : nat :=
match x,s with
| 0   , v::_      => v
| S x1, _::l1 => get x1 l1
| _   , _         => 0
end.

Fixpoint update (s:state) (v:nat) (n:nat): state :=
match v,s with
| 0   , a :: l1 => n :: l1
| 0   , nil     => n :: nil
| S v1, a :: l1 => a :: (update l1 v1 n)
| S v1, nil     => 0 :: (update nil v1 n)
end.

(* ----------------------------------------------- *)
(** ** Sémantique fonctionnelle de aexp et de bexp *)

Fixpoint evalA (a: aexp) (s: state) : nat :=
  match a with
  | Aco n => n
  | Ava x => get x s
  | Apl a1 a2 =>  evalA a1 s + evalA a2 s
  | Amu a1 a2 =>  evalA a1 s * evalA a2 s
  | Amo a1 a2 =>  evalA a1 s - evalA a2 s
  end.

Definition eqboolb b1 b2 : bool :=
  match b1, b2  with
  | true , true  => true
  | false, false => true
  | _    , _     => false
  end.

Fixpoint eqnatb n1 n2 : bool :=
  match n1, n2 with
  | O    , O     => true
  | S n1', S n2' => eqnatb n1' n2'
  | _    , _     => false
  end.

Fixpoint evalB (b : bexp) (s : state) : bool :=
  match b with
  | Btrue => true
  | Bfalse => false
  | Bnot b => negb (evalB b s)
  | Band e1 e2 => (evalB e1 s) && (evalB e2 s)
  | Bor e1 e2 => (evalB e1 s) || (evalB e2 s)
  | Beq e1 e2 => eqboolb (evalB e1 s) (evalB e2 s)
  | Beqnat n1 n2 => eqnatb (evalA n1 s) (evalA n2 s)
  end.

(* ========================================================================== *)

(** * SOS (Sémantique opérationnelle à petits pas) du langage While *)

Inductive config :=
| Inter : winstr -> state -> config
| Final : state -> config.

(* La relation pour un pas de SOS *)

Inductive SOS_1: winstr -> state -> config -> Prop :=
| SOS_Skip     : forall s,
                 SOS_1 Skip s (Final s)

| SOS_Assign   : forall x a s,
                 SOS_1 (Assign x a) s (Final (update s x (evalA a s)))

| SOS_Seqf     : forall i1 i2 s s1,
                 SOS_1 i1 s (Final s1) ->
                 SOS_1 (Seq i1 i2) s (Inter i2 s1)
| SOS_Seqi     : forall i1 i1' i2 s s1,
                 SOS_1 i1 s (Inter i1' s1) ->
                 SOS_1 (Seq i1 i2) s (Inter (Seq i1' i2) s1)

| SOS_If_true  : forall b i1 i2 s,
                 evalB b s = true  ->
                 SOS_1 (If b i1 i2) s (Inter i1 s)
| SOS_If_false : forall b i1 i2 s,
                 evalB b s = false ->
                 SOS_1 (If b i1 i2) s (Inter i2 s)

| SOS_While    : forall b i s,
                 SOS_1 (While b i) s (Inter (If b (Seq i (While b i)) Skip) s)
.

(** Fermeture réflexive-transitive de SOS_1 *)
(** Cette sémantique donne toutes les configurations atteignables
    par un (AST de) programme en partant d'un état initial.
 *)

Inductive SOS : config -> config -> Prop :=
| SOS_stop  : forall c, SOS c c
| SOS_again : forall i1 s1 c2 c3,
              SOS_1 i1 s1 c2 -> SOS c2 c3 ->
              SOS (Inter i1 s1) c3.

(* ========================================================================== *)

Definition N0 := Aco 0.
Definition N1 := Aco 1.
Definition N2 := Aco 2.
Definition N3 := Aco 3.
Definition N4 := Aco 4.

(** * I *)

(** *** Calcul du carré avec des additions *)
(** On code dans While un programme Pcarre correspondant à
    while not (i=n) do {i:= 1+i; x:= y+x ; y:= 2+y} *)
Definition Il := 0.
Definition Ir := Ava Il.
Definition Xl := 1.
Definition Xr := Ava Xl.
Definition Yl := 2.
Definition Yr := Ava Yl.

Definition incrI := Assign Il (Apl N1 Ir).
Definition incrX := Assign Xl (Apl Yr Xr).
Definition incrY := Assign Yl (Apl N2 Yr).
Definition corps_carre := Seq incrI (Seq incrX incrY).
Definition Pcarre_2 := While (Bnot (Beqnat Ir (Aco 2))) corps_carre.
Definition Pcarre n := While (Bnot (Beqnat Ir (Aco n))) corps_carre.
(** Nouveau : on peut jouer avec des programmes qui bouclent *)
Definition Pcarre_inf := While Btrue corps_carre.

Lemma SOS_Pcarre_2_1er_tour : SOS (Inter Pcarre_2 [0;0;1]) (Inter Pcarre_2 [1; 1; 3]).
Proof.
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_true. reflexivity. }
  eapply SOS_again.
  {unfold corps_carre. apply SOS_Seqi. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqi. apply SOS_Seqf. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqf. cbv[incrY]. apply SOS_Assign. }
  cbn.
  apply SOS_stop.
Qed.

Theorem SOS_Pcarre_inf_1er_tour : SOS (Inter Pcarre_inf [0;0;1]) (Inter Pcarre_inf [1; 1; 3]).
Proof.
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_true. reflexivity. }
  eapply SOS_again.
  {unfold corps_carre. apply SOS_Seqi. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqi. apply SOS_Seqf. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqf. cbv[incrY]. apply SOS_Assign. }
  cbn.
  apply SOS_stop.
Qed.

Theorem SOS_Pcarre_2_V0 : SOS (Inter Pcarre_2 [0;0;1]) (Final [2;4;5]).
Proof.
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_true. reflexivity. }
  eapply SOS_again.
  {unfold corps_carre. apply SOS_Seqi. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqi. apply SOS_Seqf. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqf. cbv[incrY]. apply SOS_Assign. }
  cbn.
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_true. reflexivity. }
  eapply SOS_again.
  {unfold corps_carre. apply SOS_Seqi. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqi. apply SOS_Seqf. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqf. cbv[incrY]. apply SOS_Assign. }
  cbn.
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_false. reflexivity. }
  eapply SOS_again.
  { apply SOS_Skip. }
  apply SOS_stop.
Qed.

(** Le but de la suite est d'éviter les redites, puis éventuellement
    de considérer le cas général Pcarre. *)

(** Propriété essentielle de SOS, qui a un intérêt pratique. *)
Theorem SOS_trans : forall c1 c2 c3, SOS c1 c2 -> SOS c2 c3 -> SOS c1 c3.
Proof.
  intros c1 c2 c3.
  intros h1.
  induction h1.
  - intro h2. apply h2.
  - intro h2. eapply SOS_again.
  { apply H. }
  { apply IHh1. apply h2. }
Qed.

(** Il n'est pas demandé de faire celui-ci
    (bien qu'un copié-collé d'un lemme précédent fonctionne). *)
Lemma SOS_Pcarre_2_2e_tour : SOS (Inter Pcarre_2 [1; 1; 3]) (Inter Pcarre_2 [2; 4; 5]).
Proof.
Admitted.

Theorem SOS_Pcarre_2_fini : SOS (Inter Pcarre_2 [2; 4; 5]) (Final [2; 4; 5]).
Proof.
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_false. cbn. reflexivity. }
  eapply SOS_again.
  { apply SOS_Skip. }
  apply SOS_stop.
Qed.

(** Même énoncé que SOS_Pcarre_2_V0. Utiliser SOS_trans *)
Theorem SOS_Pcarre_2_fin_V1 : SOS (Inter Pcarre_2 [0;0;1]) (Final [2;4;5]).
Proof.
  apply SOS_trans with (Inter Pcarre_2 [1; 1; 3]).
  - apply SOS_Pcarre_2_1er_tour.
  - apply SOS_trans with (Inter Pcarre_2 [2; 4; 5]).
    + apply SOS_Pcarre_2_2e_tour.
    + apply SOS_Pcarre_2_fini.
Qed.

(** Généralisation à Pcarre *)

(** On a besoin de deux lemmes arithmétiques, démontrables avec la tactique ring. *)
Lemma Sn_2 n : S n + S n = S (S (n + n)).
Proof. ring. Qed.

Lemma Sn_carre n : S n * S n = S (n + n + n * n).
Proof. ring. Qed.

Definition invar_cc n := [n; n*n; S (n+n)].
Theorem SOS_corps_carre n : SOS (Inter corps_carre (invar_cc n)) (Final (invar_cc (S n))).
Proof.
  eapply SOS_again.
  { unfold corps_carre. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  { apply SOS_Seqf. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  { cbv[incrY]. apply SOS_Assign. }
  cbn. unfold invar_cc. rewrite Sn_2. rewrite Sn_carre. apply SOS_stop.
Qed.

(** Celui-ci est court mais difficile. Laisser Admitted au début. *)
Fixpoint SOS_seq i1 i2 s1 s2 (so : SOS (Inter i1 s1) (Final s2)) :
  SOS (Inter (Seq i1 i2) s1) (Inter i2 s2).
Proof.
Admitted.

(** Réutiliser les lemmes précédents (facile et très court). *)
Lemma SOS_corps_carre_inter n i :
  SOS (Inter (Seq corps_carre i) (invar_cc n)) (Inter i (invar_cc (S n))).
Proof.
  apply SOS_seq. apply SOS_corps_carre.
Qed.

Lemma eqnatb_refl : forall n, eqnatb n n = true.
Proof.
  intro n.
  induction n.
  - reflexivity.
  - cbn. apply IHn.
Qed.

(** Réutiliser les lemmes précédents (facile). *)
Lemma SOS_Pcarre_tour :
  forall n i, eqnatb i n = false ->
  SOS (Inter (Pcarre n) (invar_cc i)) (Inter (Pcarre n) (invar_cc (S i))).
Proof.
  intros n i.
  intros h.
  eapply SOS_again.
  { unfold Pcarre. apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_true. cbn. rewrite h. reflexivity. }
  apply SOS_corps_carre_inter.
Qed.

(** Facile *)
Theorem SOS_Pcarre_n_fini :
  forall n, SOS (Inter (Pcarre n) (invar_cc n)) (Final (invar_cc n)).
Proof.
  intro n.
  eapply SOS_again.
  { unfold Pcarre. apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_false. cbn. rewrite eqnatb_refl. reflexivity. }
  eapply SOS_again.
  { apply SOS_Skip. }
  apply SOS_stop.
Qed.

Theorem SOS_Pcarre_2_fin_V2 : SOS (Inter Pcarre_2 [0;0;1]) (Final [2;4;5]).
Proof.
  eapply SOS_trans.
  { apply SOS_Pcarre_tour. reflexivity. }
  eapply SOS_trans.
  { apply SOS_Pcarre_tour. reflexivity. }
  eapply SOS_trans.
  { apply SOS_Pcarre_n_fini. }
  apply SOS_stop.
Qed.

(** On peut dire des choses sur la version qui boucle. *)
Lemma SOS_Pcarre_inf_tour :
  forall i,
  SOS (Inter Pcarre_inf (invar_cc i)) (Inter Pcarre_inf (invar_cc (S i))).
Proof.
  intro i.
  eapply SOS_again.
  {unfold Pcarre_inf. apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_true. cbn. reflexivity. }
  apply SOS_corps_carre_inter.
Qed.

Theorem SOS_Pcarre_inf_n :
  forall i,
  SOS (Inter Pcarre_inf [0; 0; 1]) (Inter Pcarre_inf (invar_cc i)).
Proof.
  (**
  intro i.
  induction i.
  -{unfold Pcarre_inf. cbv[invar_cc]. cbn. apply SOS_stop. }
  -apply SOS_trans with (Inter Pcarre_inf (invar_cc (S i))).
   {apply IHi.} *)
Admitted.


Require Export XR_eq_IZR.

Local Open Scope R_scope.

Lemma IZR_neq : forall z1 z2:Z,
  z1 <> z2 ->
  IZR z1 <> IZR z2.
Proof.
  intros x y h.
  unfold not.
  intro eq.
  unfold not in h.
  apply h.
  apply eq_IZR.
  exact eq.
Qed.


(*
 * Copyright (c) 2021 BedRock Systems, Inc.
 *
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
Require Import iris.bi.bi.
Require Import iris.bi.extensions.
Require Export bedrock.lang.bi.prelude.

(** * Step-indexed entailment *)
(** We axiomatize a generalization [P ⊢{n} Q] of Iris entailment that
satisfies

- [(P ⊢ Q) ↔ ∀ n, P ⊢{n} Q]

- [P ≡{n}≡ Q ↔ (P ⊢{n} Q) ∧ (Q ⊢{n} P)]

This generalization gives us a proof technique for lemmas of the form
[∃ x : A, P x ≡{n}≡ ∃ y : B, Q y] where the two sides quantify over
different types.

The cost of this generalization is that, at least for the particular
[P]s and [Q]s we care about, we have to restate the usual introduction
and elimination rules of the BI connectives in terms of [⊢{n}], prove
such connectives monotone, et cetera.

Another cost derives from the fact that the IPM is based on [⊢], so
proofs about [⊢{n}] involve more manual reasoning than IPM-based
proofs.

Note: We're defining the interface lazily. It covers only those
connectives we've needed. It could easily be fleshed out to cover
everything in Iris. *)

Reserved Notation "P '⊢{' n } Q"
  (at level 99, n at next level, Q at level 200, right associativity,
   format "'[' P  '/' '⊢{' n '}'  Q ']'").
Reserved Notation "P '⊢@{' PROP , n } Q"
  (at level 99, PROP, n at next level, Q at level 200,
   right associativity).
Reserved Notation "'(⊢{' n } )".
Reserved Notation "'(⊢@{' PROP , n } )".
Reserved Notation "P '⊣⊢{' n } Q"
  (at level 95, n at next level, no associativity,
   format "'[' P  '/' '⊣⊢{' n '}'  Q ']'").
Reserved Notation "P '⊣⊢@{' PROP , n } Q"
  (at level 95, PROP, n at next level, no associativity).

Reserved Notation "'⊢{' n } Q"
  (at level 20, n at next level, Q at level 200, format "'⊢{' n }  Q").
Reserved Notation "'⊢@{' PROP , n } Q"
  (at level 20, PROP, n at next level, Q at level 200).
(** Force left-factoring. See iris.bi.notation. *)
Reserved Notation "'(⊢@{' PROP , n } Q )".

Class EntailsN (PROP : Type) : Type := entailsN (n : nat) : relation PROP.
#[global] Instance : Params (@entailsN) 3 := {}.
#[global] Hint Mode EntailsN ! : typeclass_instances.
#[global] Arguments entailsN {_}%type_scope {_} _%nat_scope (_ _)%bi_scope : assert.

Notation "P '⊢{' n } Q" := (entailsN n P Q) : stdpp_scope.
Notation "P '⊢@{' PROP , n } Q" :=
  (@entailsN PROP _ n P Q) (only parsing) : stdpp_scope.
Notation "'(⊢{' n } )" := (entailsN n) (only parsing) : stdpp_scope.
Notation "'(⊢@{' PROP , n } )" :=
  (@entailsN PROP _ n) (only parsing) : stdpp_scope.
Notation "P '⊣⊢{' n } Q" := ((P ⊢{n} Q) ∧ (Q ⊢{n} P)) : stdpp_scope.
Notation "P '⊣⊢@{' PROP , n } Q" :=
  ((P ⊢@{PROP,n} Q) ∧ (Q ⊢@{PROP,n} P)) (only parsing) : stdpp_scope.

(** Incomplete mixin. Extend as needed, but please use additional
mixins for things like, e.g., [bi_later] and [fupd] in order to follow
the Iris mixin structure.

Notice that many primitive laws in [iris.bi.interface] follow from
[entails_entailsN], [dist_entailsN] and do not need to be axiomatized.
*)
Section mixin.
  Context (PROP : bi) `{EntailsN PROP}.
  Implicit Types P Q : PROP.

  Record BiEntailsNMixin : Prop := {
    bi_entailsN_mixin_entailsN_trans P Q R n : (P ⊢{n} Q) → (Q ⊢{n} R) → (P ⊢{n} R);
    bi_entailsN_mixin_entails_entailsN P Q : (P ⊢ Q) ↔ ∀ n, P ⊢{n} Q;
    bi_entailsN_mixin_dist_entailsN P Q n : P ≡{n}≡ Q ↔ (P ⊣⊢{n} Q);

    (** HOL: [bi_pure], [bi_and], [bi_or], [bi_impl], [bi_forall], [bi_exist] *)
    bi_entailsN_mixin_pure_elimN' (P : Prop) Q n : (P → True ⊢{n} Q) → ⌜P⌝ ⊢{n} Q;
    bi_entailsN_mixin_and_introN P Q R n : (P ⊢{n} Q) → (P ⊢{n} R) → P ⊢{n} Q ∧ R;
    bi_entailsN_mixin_impl_introN_r P Q R n : (P ∧ Q ⊢{n} R) → P ⊢{n} Q → R;
    bi_entailsN_mixin_forall_introN {A} P (Q : A → PROP) n :
      (∀ a, P ⊢{n} Q a) → (P ⊢{n} ∀ a, Q a);
    bi_entailsN_mixin_exist_elimN {A} (P : A → PROP) Q n :
      (∀ a, P a ⊢{n} Q) → (∃ a, P a) ⊢{n} Q;

    (** BI: [bi_sep], [bi_emp], [bi_wand] *)
    bi_entailsN_mixin_sep_monoN P P' Q Q' n :
      (P ⊢{n} Q) → (P' ⊢{n} Q') → (P ∗ P' ⊢{n} Q ∗ Q');
    bi_entailsN_mixin_wand_introN_r P Q R n : (P ∗ Q ⊢{n} R) → P ⊢{n} Q -∗ R;

    (** Modalities: [bi_persistently] *)
  }.
End mixin.

Class BiEntailsN (PROP : bi) : Type := {
  bi_entailsN_entailsN :> EntailsN PROP;
  bi_entailsN_mixin : BiEntailsNMixin PROP;
}.
#[global] Hint Mode BiEntailsN ! : typeclass_instances.
#[global] Arguments bi_entailsN_entailsN : simpl never.

(** Projecting properties from the mixin. *)
Section properties.
  Context `{BiEntailsN PROP}.
  Implicit Types P Q : PROP.

  Lemma entailsN_trans P Q R n : (P ⊢{n} Q) → (Q ⊢{n} R) → (P ⊢{n} R).
  Proof. apply bi_entailsN_mixin_entailsN_trans, bi_entailsN_mixin. Qed.
  Lemma entails_entailsN P Q : (P ⊢ Q) ↔ ∀ n, P ⊢{n} Q.
  Proof. apply bi_entailsN_mixin_entails_entailsN, bi_entailsN_mixin. Qed.
  Lemma dist_entailsN P Q n : P ≡{n}≡ Q ↔ (P ⊣⊢{n} Q).
  Proof. apply bi_entailsN_mixin_dist_entailsN, bi_entailsN_mixin. Qed.

  Lemma pure_elimN' (P : Prop) Q n : (P → True ⊢{n} Q) → ⌜P⌝ ⊢{n} Q.
  Proof. apply bi_entailsN_mixin_pure_elimN', bi_entailsN_mixin. Qed.
  Lemma and_introN P Q R n : (P ⊢{n} Q) → (P ⊢{n} R) → P ⊢{n} Q ∧ R.
  Proof. apply bi_entailsN_mixin_and_introN, bi_entailsN_mixin. Qed.
  Lemma impl_introN_r P Q R n : (P ∧ Q ⊢{n} R) → P ⊢{n} Q → R.
  Proof. apply bi_entailsN_mixin_impl_introN_r, bi_entailsN_mixin. Qed.
  Lemma forall_introN {A} P (Q : A → PROP) n : (∀ a, P ⊢{n} Q a) → (P ⊢{n} ∀ a, Q a).
  Proof. apply bi_entailsN_mixin_forall_introN, bi_entailsN_mixin. Qed.
  Lemma exist_elimN {A} (P : A → PROP) Q n : (∀ a, P a ⊢{n} Q) → (∃ a, P a) ⊢{n} Q.
  Proof. apply bi_entailsN_mixin_exist_elimN, bi_entailsN_mixin. Qed.

  Lemma sep_monoN P P' Q Q' n : (P ⊢{n} Q) → (P' ⊢{n} Q') → (P ∗ P' ⊢{n} Q ∗ Q').
  Proof. apply bi_entailsN_mixin_sep_monoN, bi_entailsN_mixin. Qed.
  Lemma wand_introN_r P Q R n : (P ∗ Q ⊢{n} R) → P ⊢{n} Q -∗ R.
  Proof. apply bi_entailsN_mixin_wand_introN_r, bi_entailsN_mixin. Qed.
End properties.

Definition emp_validN `{BiEntailsN PROP} (n : nat) (P : PROP) : Prop :=
  emp ⊢{n} P.
#[global] Arguments emp_validN {_ _} _%nat_scope _%I : simpl never, assert.
#[global] Hint Opaque emp_validN : typeclass_instances.

Notation "'⊢{' n } Q" := (emp_validN n Q) : stdpp_scope.
Notation "'⊢@{' PROP , n } Q" := (@emp_validN PROP _ n Q)
  (only parsing) : stdpp_scope.
Notation "'(⊢@{' PROP , n } Q )" := (@emp_validN PROP _ n Q)
  (only parsing) : stdpp_scope.

#[global] Instance entailsN_rewrite_relation `{BiEntailsN PROP} n :
  RewriteRelation (⊢@{PROP,n}) := {}.

(** The following theory is incomplete. Extend as needed. To use a
connective under [⊢{n}], you generally need its introduction rules,
elimination rules, and monotonicity properties. *)
Section theory.
  Context `{BiEntailsN PROP}.
  Implicit Types P Q : PROP.
  Notation "'(⊢{' n } )" := (⊢@{PROP,n}) (only parsing).

  #[global] Instance entailsN_po n : PreOrder (⊢@{PROP,n}).
  Proof.
    split.
    - intros P. by apply entails_entailsN.
    - repeat intro. by eapply entailsN_trans.
  Qed.

  (** Rewriting *)
  #[global] Instance: Params (@entailsN) 3 := {}.
  Lemma entailsN_ne n : Proper (dist n ==> dist n ==> iff) (⊢{n}).
  Proof.
    intros P1 P2 [HP1 HP2]%dist_entailsN.
    intros Q1 Q2 [HQ1 HQ2]%dist_entailsN.
    split=>?. by rewrite HP2 -HQ1. by rewrite HP1 -HQ2.
  Qed.
  #[global] Instance entailsN_proper n : Proper (equiv ==> equiv ==> iff) (⊢{n}).
  Proof. repeat intro. apply entailsN_ne; by apply equiv_dist. Qed.

  #[global] Instance: Params (@emp_validN) 3 := {}.
  #[global] Instance emp_validN_proper n :
    Proper (equiv ==> iff) (@emp_validN PROP _ n).
  Proof. exact: entailsN_proper. Qed.

  (** [bi_pure] *)
  Lemma True_introN P n : P ⊢{n} True.
  Proof. apply entails_entailsN, bi.True_intro. Qed.
  Lemma False_elimN P n : False ⊢{n} P.
  Proof. apply entails_entailsN, bi.False_elim. Qed.
  Lemma pure_introN (P : Prop) Q n : P → Q ⊢{n} ⌜P⌝.
  Proof. intros. by apply entails_entailsN, bi.pure_intro. Qed.
  Lemma pure_monoN (P Q : Prop) n : (P → Q) → (⌜P⌝ ⊢@{PROP,n} ⌜Q⌝).
  Proof. intros. by apply entails_entailsN, bi.pure_mono. Qed.
  #[global] Instance pure_monoN' n : Proper (impl ==> (⊢{n})) bi_pure.
  Proof. repeat intro. by apply pure_monoN. Qed.
  #[global] Instance pure_flip_monoN n : Proper (impl --> flip (⊢{n})) bi_pure.
  Proof. repeat intro. by apply pure_monoN. Qed.

  (** [bi_and] *)
  Lemma and_elimN_r P Q n : P ∧ Q ⊢{n} Q.
  Proof. apply entails_entailsN, bi.and_elim_r. Qed.
  Lemma and_elimN_l P Q n : P ∧ Q ⊢{n} P.
  Proof. apply entails_entailsN, bi.and_elim_l. Qed.
  Lemma and_mono P P' Q Q' n : (P ⊢{n} Q) → (P' ⊢{n} Q') → P ∧ P' ⊢{n} Q ∧ Q'.
  Proof.
    intros. apply and_introN.
    - by etrans; first apply and_elimN_l.
    - by etrans; first apply and_elimN_r.
  Qed.
  Lemma and_monoN_r P P' Q' n : (P' ⊢{n} Q') → (P ∧ P' ⊢{n} P ∧ Q').
  Proof. intros. by apply and_mono. Qed.
  Lemma and_monoN_l P P' Q n : (P ⊢{n} Q) → (P ∧ P' ⊢{n} Q ∧ P').
  Proof. intros. by apply and_mono. Qed.
  #[global] Instance and_monoN n : Proper ((⊢{n}) ==> (⊢{n}) ==> (⊢{n})) bi_and.
  Proof. repeat intro. by apply and_mono. Qed.
  #[global] Instance uPred_and_flip_monoN n :
    Proper ((⊢{n}) --> (⊢{n}) --> flip (⊢{n})) bi_and.
  Proof. repeat intro. by apply and_mono. Qed.

  (** [bi_impl] *)
  Lemma impl_introN_l P Q R n : (Q ∧ P ⊢{n} R) → (P ⊢{n} Q → R).
  Proof. rewrite comm. apply impl_introN_r. Qed.
  Lemma impl_elimN_r P Q n : (P ∧ (P → Q)) ⊢{n} Q.
  Proof. apply entails_entailsN, bi.impl_elim_r. Qed.
  Lemma impl_elimN_r' P Q R n : (Q ⊢{n} P → R) → (P ∧ Q ⊢{n} R).
  Proof. intros ->. apply impl_elimN_r. Qed.
  Lemma impl_elimN_l P Q n : ((P → Q) ∧ P) ⊢{n} Q.
  Proof. apply entails_entailsN, bi.impl_elim_l. Qed.
  Lemma impl_elimN_l' P Q R n : (P ⊢{n} Q → R) → (P ∧ Q ⊢{n} R).
  Proof. intros ->. apply impl_elimN_l. Qed.
  Lemma impl_elimN P Q R n : (P ⊢{n} Q → R) → (P ⊢{n} Q) → (P ⊢{n} R).
  Proof.
    intros HR HQ. trans (P ∧ P)%I; first by apply and_introN.
    rewrite {1}HQ HR. apply impl_elimN_r.
  Qed.
  Lemma impl_monoN P P' Q Q' n : (Q ⊢{n} P) → (P' ⊢{n} Q') → (P → P') ⊢{n} (Q → Q').
  Proof. intros HQ HP. apply impl_introN_l. rewrite HQ -HP. apply impl_elimN_r. Qed.
  #[global] Instance impl_monoN' n : Proper ((⊢{n}) --> (⊢{n}) ==> (⊢{n})) bi_impl.
  Proof. repeat intro. by apply impl_monoN. Qed.
  #[global] Instance impl_flip_monoN' n :
    Proper ((⊢{n}) ==> (⊢{n}) --> flip (⊢{n})) bi_impl.
  Proof. repeat intro. by apply impl_monoN. Qed.
  Lemma pure_implN_1 (P Q : Prop) n : ⌜P → Q⌝ ⊢@{PROP,n} ⌜P⌝ → ⌜Q⌝.
  Proof. apply entails_entailsN, bi.pure_impl_1. Qed.
  Lemma pure_implN_2 `{!BiPureForall PROP} (P Q : Prop) n :
    (⌜P⌝ → ⌜Q⌝) ⊢@{PROP,n} ⌜P → Q⌝.
  Proof. apply entails_entailsN, bi.pure_impl_2. Qed.
  Lemma entailsN_impl P Q n : (P ⊢{n} Q) → ⊢{n} P → Q.
  Proof. intros HP. apply impl_introN_r. rewrite HP. apply and_elimN_r. Qed.
  Lemma impl_entailsN P Q n `{!Affine P} : ( ⊢{n} P → Q ) → P ⊢{n} Q.
  Proof. intros. rewrite -(bi.emp_and P). by apply impl_elimN_l'. Qed.
  Lemma entailsN_impl_True P Q n : (P ⊢{n} Q) ↔ (True ⊢{n} P → Q).
  Proof.
    split.
    - intros <-. apply entails_entailsN. by rewrite -bi.entails_impl_True.
    - intros. rewrite -[P](left_id True%I bi_and). by apply impl_elimN_l'.
  Qed.
  Lemma entailsN_eq_True P Q n : (P ⊢{n} Q) ↔ ((P → Q) ⊣⊢{n} True).
  Abort.

  (** [bi_forall] *)
  Lemma forall_elimN {A} (P : A → PROP) a n : (∀ a, P a) ⊢{n} P a.
  Proof. apply entails_entailsN, bi.forall_elim. Qed.
  Lemma forall_elim {A} P (Q : A → PROP) n : (P ⊢{n} ∀ a, Q a) → ∀ a, P ⊢{n} Q a.
  Proof. intros HP a. rewrite HP. apply forall_elimN. Qed.
  Lemma forall_monoN {A} (P Q : A → PROP) n :
    (∀ a, P a ⊢{n} Q a) → (∀ a, P a) ⊢{n} (∀ a, Q a).
  Proof.
    intros HP. apply forall_introN=>a. rewrite -(HP a). apply forall_elimN.
  Qed.
  #[global] Instance forall_monoN' {A} n :
    Proper (pointwise_relation A (⊢{n}) ==> (⊢{n})) bi_forall.
  Proof. repeat intro. by apply forall_monoN. Qed.
  #[global] Instance forall_flip_monoN' {A} n :
    Proper (pointwise_relation A (flip (⊢{n})) ==> flip (⊢{n})) bi_forall.
  Proof. repeat intro. by apply forall_monoN. Qed.

  (** [bi_exist] *)
  Lemma exist_introN {A} (P : A → PROP) a n : P a ⊢{n} ∃ a, P a.
  Proof. apply entails_entailsN, bi.exist_intro. Qed.
  Lemma exist_introN' {A} P (Q : A → PROP) a n : (P ⊢{n} Q a) → P ⊢{n} ∃ a, Q a.
  Proof. etrans; eauto using exist_introN. Qed.
  Lemma exist_monoN {A} (P Q : A → PROP) n :
    (∀ a : A, P a ⊢{n} Q a) → (∃ a, P a) ⊢{n} ∃ a, Q a.
  Proof. intros. apply exist_elimN=>a. exact: exist_introN'. Qed.
  #[global] Instance exist_monoN' {A} n :
    Proper (pointwise_relation A (⊢{n}) ==> (⊢{n})) bi_exist.
  Proof. repeat intro. by apply exist_monoN. Qed.
  #[global] Instance uPred_exist_flip_monoN' {A} n :
    Proper (pointwise_relation A (flip (⊢{n})) ==> flip (⊢{n})) bi_exist.
  Proof. repeat intro. by apply exist_monoN. Qed.

  (** [bi_sep] *)
  Lemma sep_monoN_l P P' Q' n : (P' ⊢{n} Q') → P ∗ P' ⊢{n} P ∗ Q'.
  Proof. intros. by eapply sep_monoN. Qed.
  Lemma sep_monoN_r P P' Q n : (P ⊢{n} Q) → P ∗ P' ⊢{n} Q ∗ P'.
  Proof. intros. by eapply sep_monoN. Qed.
  #[global] Instance sep_monoN' n : Proper ((⊢{n}) ==> (⊢{n}) ==> (⊢{n})) bi_sep.
  Proof. repeat intro. by apply sep_monoN. Qed.
  #[global] Instance sep_flip_monoN' n :
    Proper ((⊢{n}) --> (⊢{n}) --> flip (⊢{n})) bi_sep.
  Proof. repeat intro. by apply sep_monoN. Qed.

  (** [bi_emp] *)
  Lemma emp_sep_1N P n : P ⊢{n} emp ∗ P.
  Proof. apply entails_entailsN, bi.emp_sep_1. Qed.
  Lemma emp_sep_2N P n : emp ∗ P ⊢{n} P.
  Proof. apply entails_entailsN, bi.emp_sep_2. Qed.

  (** [bi_wand] *)
  Lemma wand_elimN_l' P Q R n : (P ⊢{n} Q -∗ R) → (P ∗ Q ⊢{n} R).
  Proof. intros ->. apply entails_entailsN, bi.wand_elim_l. Qed.
  Lemma wand_elimN_r' P Q R n : (Q ⊢{n} P -∗ R) → (P ∗ Q ⊢{n} R).
  Proof. intros. rewrite comm. by apply wand_elimN_l'. Qed.
  Lemma wand_elimN_r P Q n : P ∗ (P -∗ Q) ⊢{n} Q.
  Proof. by etrans; last by apply wand_elimN_r'. Qed.
  Lemma wand_elimN_l P Q n : (P -∗ Q) ∗ P ⊢{n} Q.
  Proof. by etrans; last by apply wand_elimN_l'. Qed.
  Lemma wand_introN_l P Q R n : (Q ∗ P ⊢{n} R) → P ⊢{n} Q -∗ R.
  Proof. intros. apply wand_introN_r. by rewrite comm. Qed.
  Lemma wand_monoN P P' Q Q' n : (Q ⊢{n} P) → (P' ⊢{n} Q') → (P -∗ P') ⊢{n} (Q -∗ Q').
  Proof.
    intros HQP HPQ. apply wand_introN_r. rewrite HQP -HPQ. by apply wand_elimN_l'.
  Qed.
  #[global] Instance wand_monoN' n : Proper ((⊢{n}) --> (⊢{n}) ==> (⊢{n})) bi_wand.
  Proof. repeat intro. by apply wand_monoN. Qed.
  #[global] Instance wand_flip_monoN' n :
    Proper ((⊢{n}) ==> (⊢{n}) --> flip (⊢{n})) bi_wand.
  Proof. repeat intro. by apply wand_monoN. Qed.

  (** [bi_persitently] *)
  Lemma persistently_forall_2N `{BiPersistentlyForall PROP} {A} (P : A → PROP) n :
    (∀ a, <pers> P a) ⊢{n} <pers> (∀ a, P a).
  Proof. apply entails_entailsN, persistently_forall_2. Qed.

  (** [bi_later] *)
  Lemma later_forall_2N {A} (P : A → PROP) n : (∀ a, ▷ P a) ⊢{n} ▷ (∀ a, P a).
  Proof. apply entails_entailsN, bi.later_forall_2. Qed.

  (** [bi_affinely] *)
  Lemma affinely_monoN P Q n : (P ⊢{n} Q) → (<affine> P ⊢{n} <affine> Q).
  Proof. rewrite /bi_affinely. by intros ->. Qed.
  #[global] Instance affinely_monoN' n : Proper ((⊢{n}) ==> (⊢{n})) bi_affinely.
  Proof. repeat intro. by apply affinely_monoN. Qed.
  #[global] Instance affinely_flip_monoN' n :
    Proper ((⊢{n}) --> flip (⊢{n})) bi_affinely.
  Proof. repeat intro. by apply affinely_monoN. Qed.
  Lemma affinely_idempN P n : <affine> <affine> P ⊣⊢{n} <affine> P.
  Proof. apply dist_entailsN. by rewrite bi.affinely_idemp. Qed.
  Lemma affinely_introN' P Q n : (<affine> P ⊢{n} Q) → (<affine> P ⊢{n} <affine> Q).
  Proof. intros <-. apply affinely_idempN. Qed.
  Lemma affinely_introN P Q n `{!Affine P} : (P ⊢{n} Q) → (P ⊢{n} <affine> Q).
  Proof. intros <-. by apply entails_entailsN, bi.affinely_intro. Qed.
  Lemma affinely_elimN P n : <affine> P ⊢{n} P.
  Proof. apply entails_entailsN, bi.affinely_elim. Qed.
  Lemma afifnely_elimN_emp P n : <affine> P ⊢{n} emp.
  Proof. apply entails_entailsN, bi.affinely_elim_emp. Qed.

  (** [only_provable] *)
  #[local] Transparent only_provable.
  Lemma only_provable_introN (P : Prop) Q `{!Affine Q} n : P → Q ⊢{n} [| P |].
  Proof. intros HP. apply: affinely_introN. exact: pure_introN. Qed.
  Lemma only_provable_elimN' (P : Prop) Q n : (P → True ⊢{n} Q) → [| P |] ⊢{n} Q.
  Proof. rewrite/only_provable affinely_elimN. exact: pure_elimN'. Qed.
  Lemma only_provable_monoN (P Q : Prop) n : (P → Q) → [| P |] ⊢@{PROP,n} [| Q |].
  Proof. intros. by apply affinely_monoN, pure_monoN. Qed.
  #[global] Instance only_provable_monoN' n : Proper (impl ==> (⊢{n})) only_provable.
  Proof. repeat intro. by apply only_provable_monoN. Qed.
  #[global] Instance only_provable_flip_monoN n :
    Proper (impl --> flip (⊢{n})) only_provable.
  Proof. repeat intro. by apply only_provable_monoN. Qed.

End theory.


(*|

=============================
Example: Simple spinlock
=============================

This example is a liveness proof for the following simple C program. It encodes the program as a hand-written state machine, with states referring to labeled points.

::

  type Mutex = bool;
  const UNLOCKED = false;
  const LOCKED = true;

  void lock(Mutex *m) {
    // pc0
    for cas(m, UNLOCKED, LOCKED) {}
    // control goes directly to pc1 (see `thread`)
  }

  void unlock(Mutex *m) {
    // pc1
    *m = UNLOCKED;
    // pc2
  }

  void thread(Mutex *m) {
    lock(m);
    unlock(m);
  }

  void main() {
    Mutex *m = malloc(sizeof(Mutex));
    // these two threads are what is modeled
    spawn(thread, m);
    spawn(thread, m);
  }

What we reason about is two threads running `lock(m); unlock(m)` (assuming m starts out allocated).

|*)

From RecordUpdate Require Import RecordUpdate.
From stdpp Require Import functions.

From TLA Require Import logic.

Module spec.

  Inductive pc := pc0 | pc1 | pc2.
  Inductive Tid := tidA | tidB.

  #[global]
  Instance tid_eqdecision : EqDecision Tid.
  Proof.
    solve_decision.
  Defined.

  (* the state consists of the state of the mutex, and program counters for two
  threads, tidA and tidB *)
  Record state :=
    mkState { lock: bool; pcs: Tid → pc; }.

  #[global]
  Instance _eta : Settable _ := settable! mkState <lock; pcs>.

  Definition cas_fail (t0: Tid): action state :=
    λ s s', (s.(pcs) t0 = pc0 ∧ s.(lock) = true)
            ∧ s' = s.

  Definition cas_succ (t0: Tid): action state :=
    λ s s', s.(pcs) t0 = pc0 ∧ s.(lock) = false
            ∧ s' = s <|lock := true|>
                     <|pcs ::= <[ t0 := pc1 ]> |>.

  Definition unlock (t0: Tid): action state :=
    λ s s', s.(pcs) t0 = pc1
            ∧ s' = s <|lock := false|>
                     <|pcs ::= <[ t0 := pc2 ]> |>.

  Definition step (t0: Tid): action state :=
      λ s s', cas_fail t0 s s' ∨ cas_succ t0 s s' ∨ unlock t0 s s'.

  Definition init: state → Prop :=
    λ s, s = {| lock := false; pcs := λ _, pc0; |}.

  Definition next : action state :=
    λ s s', step tidA s s' ∨ step tidB s s' ∨ s' = s.

  (* safety is mutual exclusion *)
  Definition safe: state → Prop :=
    λ s, ¬ (s.(pcs) tidA = pc1 ∧ s.(pcs) tidB = pc1).

  Definition fair: predicate state :=
    weak_fairness (step tidA) ∧ weak_fairness (step tidB).

  (* liveness means both threads terminate *)
  Definition terminated: state → Prop :=
    λ s, s.(pcs) tidA = pc2 ∧ s.(pcs) tidB = pc2.

End spec.

Import spec.

Section example.

Implicit Types (s: state) (t: Tid).

Hint Unfold init next step safe fair terminated : stm.
Hint Unfold cas_fail cas_succ unlock : stm.

Lemma enabled_thread t :
  enabled (step t) = λ s, s.(pcs) t ≠ pc2.
Proof.
  apply pred_ext => s.
  unfold enabled; split.
  - autounfold with stm. intros [s' Hstep];
      (intuition subst);
      try congruence.
  - intros.
    autounfold with stm.
    destruct s as [l pcs0]; simpl in *.
    destruct (pcs0 t) eqn:?; [ | | congruence ].
    * destruct l; simpl; eexists (mkState _ _); eauto.
    * eexists (mkState _ _); eauto.
Qed.

Ltac stm_simp :=
  autounfold with stm;
  intros; (intuition (repeat deex; subst; trivial));
  rewrite ?enabled_eq ?enabled_thread;
  repeat deex;
  repeat (match goal with
        | s: state |- _ => (destruct s; cbn in * )
        | H: ?x = ?x |- _ => clear H
        | H: @eq pc _ _ |- _ => solve [ inversion H ]
        | H: @eq state (mkState _ _) (mkState _ _) |- _ =>
            invc H; cbn in *
        | H: context[@set state _ _ _ _ _] |- _ =>
            progress (unfold set in H; simpl in H)
        | H: @eq bool _ _ |- _ => solve [ inversion H ]
        | _ => progress (unfold set; simpl)
        | _ => rewrite fn_lookup_insert
        | _ => rewrite -> fn_lookup_insert_ne by congruence
        | _ => progress cbn in *
        end).

Ltac stm :=
  stm_simp;
  try solve [ intuition (repeat deex; eauto) ];
  try congruence.

Definition exclusion_inv: state → Prop :=
  λ s, (s.(pcs) tidA = pc1 → s.(lock) ∧ s.(pcs) tidB ≠ pc1) ∧
       (s.(pcs) tidB = pc1 → s.(lock) ∧ s.(pcs) tidA ≠ pc1).

Hint Unfold exclusion_inv : stm.

Lemma exclusion_inv_ok :
  ⌜init⌝ ∧ □⟨next⟩ ⊢ □⌜exclusion_inv⌝.
Proof.
  apply init_invariant.
  - stm.
  - stm.
Qed.

Theorem safety :
  ⌜init⌝ ∧ □⟨next⟩ ⊢ □ ⌜safe⌝.
Proof.
  rewrite exclusion_inv_ok.
  apply always_impl_proper.
  unseal; stm.
Qed.

Theorem wf_threads_combine :
  (weak_fairness (step tidA) ∧ weak_fairness (step tidB)) ==
  weak_fairness (λ s s', step tidA s s' ∨ step tidB s s')%type.
Proof.
  apply wf_combine.
  - rewrite /tla_enabled.
    (* rewrite ?enabled_thread. *)
    (* first, to have any hope here we'd need to make [wf_combine] internal and
    carry out this proof under the assumption of `□⟨next⟩`, but also this
    doesn't seem true at all: it's equivalent to [enabled (step tidA) → ◇
    enabled (step tidB) → ◇ (step tidA)], but this is obvious false in an
    execution which is just the initial state and then infinite stuttering *)
Abort.

(** wrapper for [exclusion_inv_ok] to "upgrade" from a semantics with [next] to
one that incorporates the invariant *)
Lemma add_safety :
  ⌜init⌝ ∧ □⟨next⟩ ⊢
  ⌜init⌝ ∧ □⟨λ s s', next s s' ∧ exclusion_inv s ∧ exclusion_inv s'⟩.
Proof.
  tla_pose (exclusion_inv_ok).
  rewrite combine_preds //.
Qed.

(*|

---------------------
Proving termination
---------------------

Why does this program terminate? The basic reasoning in this proof is fairly brute force. However, we must use the assumption of weak fairness in order to guarantee that each thread makes progress (as opposed to stuttering or starving). The main rule is wf1, which gives a `~~>` from weak fairness of an action.

The tricky part about the mutex example is getting started, because we don't know whether thread A or thread B will acquire the lock first, and thus we're not sure whether the action `step tidA` will happen or `step tidB`. The way we resolve this in the proof is to show that `step tidA` eventually runs and results in one of two possibilities: either tidA acquires the lock (and moves on to `pc1`), or it fails to acquire the lock. Now the crucial reasoning step is that if tidA doesn't acquire the lock, then tidB must hold it. In general we only know that tidB is in its critical section, but in fact because the state machine is so trivial that the entire critical section is just `pc1`.

Now we have a "diverging" leads to, which leads to one of two possibilities. TLA gives a way to construct a single leads-to from a "lattice" of leads-tos, as long as the eventually converge to some goal state. In this example, once either tidA or tidB acquire the lock, the remaining execution is sequential, so the divergence is very simple. As a result we use `leads_to_fork2`, a very special case of the lattice rule that just gives a way to diverge to `q ∨ r` and then reconverge to some goal.

|*)

Lemma init_to_terminate :
  ⌜init⌝ ∧ □⟨next⟩ ∧ fair ⊢ ⌜init⌝ ~~> ⌜terminated⌝.
Proof.
  unfold fair.
(*|
This manipulation (which unfortunately is messy because things are so syntactic) brings the `exclusion_inv` invariant into scope. We need this because the intermediate assertions in this proof don't all mention the lock state, and the invariant helps us infer it from the program counters of the two threads. (A more precise invariant could avoid all mention of locks.)
|*)
  rewrite <- tla_and_assoc. rewrite -> add_safety. tla_simp.

(*|
The first creative step is to lay out what two possibilities are possible from `init`. As described above, either thread A acquires the lock, or B is in its critical section and A is waiting.
|*)
  apply (leads_to_fork2
           ⌜λ s, s.(pcs) tidA = pc1 ∧ s.(pcs) tidB = pc0⌝
           ⌜λ s, s.(pcs) tidA = pc0 ∧ s.(pcs) tidB = pc1⌝).
(*|
This is actually the non-obvious initial divergence where tidA runs and either succeeds or fails. Automation makes short work of it. Note that we could just as well get this result from thread B.
|*)
  - rewrite combine_or_preds.
    tla_apply (wf1 (step tidA)); stm.

  -
(*|
Next we reason through a sequence of states, connected by wf1. First A steps and releases the lock, then B steps twice to acquire and release.
|*)

    leads_to_trans ⌜λ s, s.(pcs) tidA = pc2 ∧
                         s.(pcs) tidB = pc0 ∧
                         s.(lock) = false⌝.
    { tla_apply (wf1 (step tidA)); stm. }
    leads_to_trans ⌜ λ s, s.(pcs) tidA = pc2 ∧ s.(pcs) tidB = pc1⌝.
    { tla_apply (wf1 (step tidB)); stm. }
    tla_apply (wf1 (step tidB)); stm.
  -
(*|
The other branch is symmetric, with B releasing the lock and then A acquiring and releasing.
|*)
    leads_to_trans ⌜λ s, s.(pcs) tidB = pc2 ∧
                         s.(pcs) tidA = pc0 ∧
                         s.(lock) = false⌝.
    { tla_apply (wf1 (step tidB)); stm. }
    leads_to_trans ⌜ λ s, s.(pcs) tidB = pc2 ∧ s.(pcs) tidA = pc1⌝.
    { tla_apply (wf1 (step tidA)); stm. }
    tla_apply (wf1 (step tidA)); stm.
Qed.

(*|
Below is an alternate proof of the same termination theorem. Instead of using the special case `leads_to_fork2`, we use the lattice rule with a lattice that fairly explicitly gives the states. Some of the paths in this lattice are actually linear chains, which can be optimized away, but maybe in some cases the lattice is easier to think about.
|*)

Inductive L := start | A1 | Afin | AfinB1 | B1 | Bfin | BfinA1 | goal.

Definition Llt (l1 l2: L) : Prop :=
  match l2, l1 with
  | start, A1 | A1, Afin | Afin, AfinB1 => True
  | start, B1 | B1, Bfin | Bfin, BfinA1 => True
  | AfinB1, goal | BfinA1, goal => True
  | _, _ => False
  end.

Theorem Llt_wf : well_founded Llt.
Proof.
  prove_wf [goal; AfinB1; Afin; A1; BfinA1; Bfin; B1; start].
Qed.

Definition h (label: L) : state → Prop :=
  match label with
  | start => init

  | A1 => λ s, s.(pcs) tidA = pc1 ∧ s.(pcs) tidB = pc0
  | Afin => λ s, s.(pcs) tidA = pc2 ∧ s.(pcs) tidB = pc0 ∧ s.(lock) = false
  | AfinB1 => λ s, s.(pcs) tidA = pc2 ∧ s.(pcs) tidB = pc1

  | B1 => λ s, s.(pcs) tidB = pc1 ∧ s.(pcs) tidA = pc0
  | Bfin => λ s, s.(pcs) tidB = pc2 ∧ s.(pcs) tidA = pc0 ∧ s.(lock) = false
  | BfinA1 => λ s, s.(pcs) tidB = pc2 ∧ s.(pcs) tidA = pc1

  | goal => terminated
  end.

Hint Extern 1 (Llt _ _) => exact I : core.

Lemma init_to_terminate_lattice_proof :
  ⌜init⌝ ∧ □⟨next⟩ ∧ fair ⊢ ⌜init⌝ ~~> ⌜terminated⌝.
Proof.
  unfold fair.
  apply (lattice_leads_to Llt_wf h start goal); [ done | done | ].
  intros l Hne.

  rewrite <- tla_and_assoc. rewrite -> add_safety. tla_simp.

  (* split the proof into one case per label *)
  destruct l; cbn [h]; try congruence.

  - (* start *)
    leads_to_trans ⌜λ s, h A1 s ∨ h B1 s⌝; swap 1 2.
    { apply pred_leads_to => s.
      intros [|]; [ exists A1 | exists B1 ]; eauto. }
    tla_apply (wf1 (step tidA)); stm.
  - (* A1 *)
    leads_to_trans ⌜h Afin⌝; swap 1 2.
    { apply pred_leads_to => s. exists Afin; eauto. }

    tla_apply (wf1 (step tidA)); stm.
  - (* Afin *)
    leads_to_trans ⌜h AfinB1⌝; swap 1 2.
    { apply pred_leads_to => s. exists AfinB1; eauto. }

    tla_apply (wf1 (step tidB)); stm.
  - (* AfinB1 *)
    leads_to_trans ⌜terminated⌝; swap 1 2.
    { apply pred_leads_to => s. exists goal; eauto. }
    tla_apply (wf1 (step tidB)); stm.

  - (* B1 *)
    leads_to_trans ⌜h Bfin⌝; swap 1 2.
    { apply pred_leads_to => s. exists Bfin; eauto. }

    tla_apply (wf1 (step tidB)); stm.
  - (* Bfin *)
    leads_to_trans ⌜h BfinA1⌝; swap 1 2.
    { apply pred_leads_to. exists BfinA1; eauto. }

    tla_apply (wf1 (step tidA)); stm.
  - (* BfinA1 *)
    leads_to_trans ⌜terminated⌝; swap 1 2.
    { apply pred_leads_to => s. exists goal; eauto. }
    tla_apply (wf1 (step tidA)); stm.
Qed.

Lemma eventually_terminate :
  ⌜init⌝ ∧ □⟨next⟩ ∧ fair ⊢ ◇ ⌜terminated⌝.
Proof.
  eapply leads_to_apply; [ | apply init_to_terminate ].
  tla_prop.
Qed.

End example.


(** a test for the derivation of new container types **)
Inductive or2 (A B : Prop) : Type :=
	or2_introl : A -> or2 A B | or2_intror : B -> or2 A B.

Load addContainer.

(* MetaCoq Run (addType or). *)
(* MetaCoq Run (addType sum). *)

(* MetaCoq Run (addType or2). *)
(* Next Obligation. *)
(*   induction H. *)

(*   induction H eqn: X. *)
(*   dependent induction H. *)
(*   induction H. *)
(*   destruct H. *)
(*   - now constructor. *)
(*   - now constructor. *)
(* Defined. *)

MetaCoq Run (addType list).
Next Obligation.
  induction X.
  - constructor.
  - constructor.
    + apply AH.
    + apply IHX.
Defined.
Print list_inst.
(* Next Obligation. *)
(* apply True. *)
(* Defined. *)
(* Next Obligation. *)
(* apply I. *)
(* Defined. *)

Print All_Forall.All.

Inductive All2 {A : Type} (P : A -> Type) : list A -> Type :=
    All2_nil : All2 P []
  | All2_cons : forall (x : A) (l : list A), P x -> All2 P l -> All2 P (x :: l).

(* MetaCoq Run (addType (@All2)). *)

Inductive t2 (A : Type) : nat -> Type :=
    nilt2 : t2 A 0
  | const2 : A -> forall n : nat, t2 A n -> t2 A (S n).

(* Obligation Tactic := idtac. *)

MetaCoq Run (addType t2).
Next Obligation.
  induction X.
  - constructor.
  - constructor.
    + apply AH.
    + apply IHX.
Defined.

Print t2_inst.
Print t2ᵗ0.
Print t2ᵗ.

(* Next Obligation. *)
(* cbn.  intros. *)
(* apply True. *)
(* Defined. *)
(* Next Oblgiation. *)


Require Import TT2BDD.TT.
Require Import BoolEq.
Require Import core.Model.
Require Import String.
Require Import List.
Require Import Utils.

Definition matchInputCell
    (ttm: Model TTMetamodel_EObject TTMetamodel_ELink)
    (cell : Cell)
    (ins: list (string*bool)):
        bool :=
    match Cell_getPort cell ttm with
    | Some (Build_Abstract_Port InputPortEClass p) =>
        existsb (fun input =>
            andb (String.eqb (fst input) (InputPort_getName p))
                (Bool.eqb (snd input) (Cell_getValue cell)))
            ins
    | _ => true
    end.

Definition matchRow
    (ttm: Model TTMetamodel_EObject TTMetamodel_ELink)
    (row : Row)
    (ins: list (string*bool)):
        bool :=
    match Row_getCells row ttm with
    | Some cells => forallb (fun cell => matchInputCell ttm cell ins) cells
    | _ => true
    end.

Definition outputCells
    (ttm: Model TTMetamodel_EObject TTMetamodel_ELink)
    (row : Row):
        list Cell :=
    match Row_getCells row ttm with
    | Some cells =>
        filter (fun cell =>
            match Cell_getPort cell ttm with
            | Some (Build_Abstract_Port OutputPortEClass _) => true
            | _ => false
            end
            ) cells
    | _ => nil
    end.

Definition cellToPair
    (ttm: Model TTMetamodel_EObject TTMetamodel_ELink)
    (cell : Cell):
        string*bool :=
    match Cell_getPort cell ttm with
        | Some (Build_Abstract_Port OutputPortEClass p) => (OutputPort_getName p,Cell_getValue cell)
        | Some (Build_Abstract_Port InputPortEClass p) => (InputPort_getName p,Cell_getValue cell)
        | _ => (""%string, Cell_getValue cell)
    end.

Definition outputOfRow
    (ttm: Model TTMetamodel_EObject TTMetamodel_ELink)
    (row : Row):
        list (string*bool) :=
    match Row_getCells row ttm with
    | Some cells =>
        map (cellToPair ttm) (outputCells ttm row)
    | _ => nil
    end.

Definition eval
    (ttm: Model TTMetamodel_EObject TTMetamodel_ELink)
    (tt : TruthTable)
    (ins: list (string*bool)):
        list (string*bool) :=
    match TruthTable_getRows tt ttm with
    | Some rows =>
        flat_map (outputOfRow ttm)  (filter (fun row => matchRow ttm row ins) rows)
    | _ => nil
    end.

Definition valueOf
    (portValues: list (string*bool))
    (portName: string)
    :=
    let values := (nodup bool_dec (map snd (filter (fun p => String.eqb (fst p) portName) portValues))) in
    match values with
    | false :: nil => Some false
    | true :: nil => Some true
    | _ => None
    end.

Definition allInputPorts
    (ttm: Model TTMetamodel_EObject TTMetamodel_ELink)
    (tt : TruthTable) :=
    filter
        (fun port => match port with
        | (Build_Abstract_Port InputPortEClass p) => true
        | _ => false
        end)
        (optionListToList (TruthTable_getPorts tt ttm)).


(**************************************************************************
* TLC: A library for Coq                                                  *
* Keys for environment signature.
**************************************************************************)

Set Implicit Arguments.
Require Import TLC.LibTactics TLC.LibList TLC.LibLogic TLC.LibNat TLC.LibEpsilon TLC.LibReflect.
Require Export TLC.LibFset.
Require Export LibFresh.

(** * Abstract Definition of Key for an environment. *)

Module Type KeyType.

(** We leave the type of variables abstract. *)

Parameter key : Set.

(** This type is inhabited. *)

Parameter key_inhab : Inhab key.

(** This type is comparable. *)
Parameter key_comp : Comparable key.
Instance  key_comparable : Comparable key := key_comp.

(** We can build sets of variables. *)

Definition keys := fset key.

(** Finally, we have a means of generating fresh variables. *)

Parameter key_gen : keys -> key.
Parameter key_gen_spec : forall E, (key_gen E) \notin E.
Parameter key_fresh : forall (L : keys), { x : key | x \notin L }.

Axiom key_freshes : forall L n, { xs : list key | fresh key L n xs}.
End KeyType.