Require Import MapProofs.Common.
Set Bullet Behavior "Strict Subproofs".
Require Import MapProofs.Bounds.
Require Import MapProofs.Tactics.
Require Import MapProofs.InsertProofs.
Require Import MapProofs.DeleteUpdateProofs.

Section WF_Part1.
Context {e : Type} {a : Type} {HEq : Eq_ e} {HOrd : Ord e} {HEqLaws : EqLaws e}  {HOrdLaws : OrdLaws e}.

(** ** Verification of [split] *)

Lemma split_Desc :
  forall x (s: Map e a) lb ub,
  Bounded s lb ub ->
  forall (P : Map e a * Map e a -> Prop),
  (forall s1 s2,
    Bounded s1 lb (Some x) ->
    Bounded s2 (Some x) ub ->
    size s = size s1 + size s2 + (if isSome (sem s x) then 1%Z else 0%Z) ->
    (forall i, sem s i = (if i == x then sem s i else sem s1 i ||| sem s2 i)) ->
    P (s1, s2)) ->
  P (split x s) : Prop.
Proof.
  intros ?? ?? HB.
  Ltac solveThis e := intros X HX; apply HX; clear X HX; [solve_Bounded e|solve_Bounded e| |f_solver e].
  induction HB.
  - solveThis e. reflexivity.
  - simpl.
    destruct (compare x x0) eqn:?.
  + solveThis e. replace (x == x0) with true by order e.
    simpl_options. lia.
  + apply IHHB1; intros s1_2 s1_3 HB1_2 HB1_3 Hsz Hsems1; clear IHHB1 IHHB2.
    applyDesc e (@link_Desc e a).
    solveThis e. destruct (sem s1 x); cbn -[Z.add] in *.
    * simpl. lia.
    * replace (x == x0) with false by order e. simpl.
      rewrite (sem_outside_below HB2) by solve_Bounds e. simpl. lia.
  + apply IHHB2; intros s2_2 s2_3 HB2_2 HB2_3 Hsz Hsems2; clear IHHB1 IHHB2.
    applyDesc e (@link_Desc e a).
    solveThis e. destruct (sem s2 x); cbn -[Z.add] in *.
    * simpl_options. lia.
    * replace (x == x0) with false by order e. simpl.
      rewrite (sem_outside_above HB1) by solve_Bounds e. simpl. lia.
Qed.

(** ** Verification of [union] *)

(* The [union] uses some nested pattern match that expand to a very large
   number of patterns in Coq. So let’s take them apart here *)
Lemma union_destruct :
  forall (P : Map e a -> Prop),
  forall s1 s2,
  (s2 = Tip -> P s1) ->
  (s1 = Tip -> P s2) ->
  (forall sz2 x vx, (s2 = Bin sz2 x vx Tip Tip) -> P (insertR x vx s1)) ->
  (forall sz1 x vx, (s1 = Bin sz1 x vx Tip Tip) -> P (insert x vx s2)) ->
  (forall sz1 x vx l1 r1, (s1 = Bin sz1 x vx l1 r1) ->
    P (
      match split x s2 with
      | pair l2 r2 =>
      match union r1 r2 with
      | r1r2 =>
      match union l1 l2 with
      | l1l2 => if andb  (PtrEquality.ptrEq l1l2 l1)
                         (PtrEquality.ptrEq r1r2 r1) : bool
                then s1 else link x vx l1l2 r1r2
      end end end)) ->
  P (union s1 s2).
Proof.
  intros P s1 s2 HTipR HTipL HSingletonR HSingletonL HBins.
  destruct s1, s2; simpl union;
  try destruct s1_1, s1_2;
  try destruct s2_1, s2_2;
  first [ eapply HBins; reflexivity
        | eapply HSingletonL; reflexivity
        | eapply HSingletonR; reflexivity
        | eapply HTipL; reflexivity
        | eapply HTipR; reflexivity
        | idtac
        ].
Qed.

Lemma union_Desc :
  forall (s1: Map e a) s2 lb ub,
  Bounded s1 lb ub ->
  Bounded s2 lb ub ->
  Desc' (union s1 s2) lb ub (fun i => sem s1 i ||| sem s2 i).
(* We use [Desc'] here, because the result of [union] is passed to [link], which
   does a full rebalance, and hence does not need to know anything about the size.
   If it turns out we need [size (union s1 s2)], we can still add it.
*)
Proof.
  intros ???? HB1 HB2.
  revert s2 HB2.
  induction HB1; intros s3 HB3.
  * apply union_destruct; intros; subst; try congruence.
    + solve_Desc e. intros. reflexivity.
    + solve_Desc e. intros. reflexivity.
    + inversion HB3; subst; clear HB3.
      clear H4 H5.
      (* We need to give [applyDesc] a hint about the bounds that we care about: *)
      assert (Bounded (@Tip e a) lb ub) by constructor.
      applyDesc e (@insertR_Desc e a).
      solve_Desc e. f_solver e.
  * apply union_destruct; intros; subst; try congruence.
    + solve_Desc e. f_solver e.
    + inversion HB3; subst; clear HB3.
      applyDesc e (@insertR_Desc e a).
      solve_Desc e. f_solver e.
    + inversion H3; subst; clear H3.
      applyDesc e (@insert_Desc e a). solve_Desc e. f_solver e.
    + inversion H3; subst; clear H3.
      eapply split_Desc; try eassumption.
      intros.
      applyDesc e IHHB1_1.
      applyDesc e IHHB1_2.
      destruct_ptrEq.
      - solve_Desc e. f_solver e.
      - applyDesc e (@link_Desc e a).
        solve_Desc e. f_solver e.
Qed.

(** ** Verification of [unions] *)

(* This is a bit of a lazy specification, but goes a long way *)

Lemma Forall_rev:
  forall A P (l : list A), Forall P (rev l) <-> Forall P l.
Proof. intros. rewrite !Forall_forall. setoid_rewrite <- in_rev. reflexivity. Qed.

Lemma oro_app: forall o l1 l2 (i : e),
  (fold_right (fun (h: Map e a) t => sem h i ||| t) o (l1 ++ l2)) =
  (fold_right (fun h t => sem h i ||| t) None l1) |||
  (fold_right (fun h t => sem h i ||| t) o l2).
Proof.
  intros. generalize dependent o. generalize dependent l2. induction l1; intros.
  - simpl. reflexivity.
  - simpl. rewrite IHl1. rewrite oro_assoc. reflexivity.
Qed.

Require Proofs.Data.Foldable.

Lemma unions_Desc:
  forall (ss: list (Map e a)) lb ub,
  Forall (fun s => Bounded s lb ub) ss ->
  Desc' (unions ss) lb ub (fun i => fold_right (fun h t => sem h i ||| t) None ss).
Proof.
  intros.
  unfold unions.
  (* Switch to a fold right *)
  rewrite Proofs.Data.Foldable.hs_coq_foldl'_list.
  rewrite <- fold_left_rev_right.
  rewrite <- (rev_involutive ss).
  rewrite <- (rev_involutive ss), Forall_rev in H.
  generalize dependent (rev ss). intros.
  rewrite rev_involutive.

  induction H.
  * simpl. applyDesc e (@empty_Desc e a). solve_Desc e. f_solver e.
  * simpl fold_right.
    applyDesc e IHForall.
    applyDesc e union_Desc.
    solve_Desc e.
    intro i.
    rewrite Hsem0, Hsem. rewrite oro_app. simpl. rewrite oro_None_r. reflexivity.
Qed.

(** ** Verification of [insertWithR] *)
Lemma insertWithR_Desc:
  forall (f: a -> a -> a) y v s lb ub,
  Bounded s lb ub ->
  isLB lb y = true ->
  isUB ub y = true ->
  Desc (insertWithR f y v s) lb ub (if isSome (sem s y) then size s else (1 + size s)%Z)
      (fun i => (if i == y then match (sem s y) with
                                | None => Some v
                                | Some x => Some (f x v)
                                end  else None ||| sem s i )).
Proof.
  intros ?????? HB HLB HUB.
  induction HB; intros.
  * simpl.
    applyDesc e (@singleton_Desc e a); try eassumption; solve_Desc e.
  * subst; cbn -[Z.add].
    destruct (compare y x) eqn:?.
    + rewrite compare_Eq in Heqc.
      rewrite Heqc.
      rewrite ?isSome_oro, ?isSome_Some, ?orb_true_r, ?orb_true_l.
      solve_Desc e.
    + clear IHHB2.
      applyDesc e IHHB1.
      rewrite (sem_outside_below HB2) by order_Bounds e.
      replace (y == x) with false by order_Bounds e.
      simpl_options. destruct (sem s1 y) eqn:?; simpl isSome in *; try lia;
      applyDesc e (@balanceL_Desc e a); solve_Desc e.
    + clear IHHB1.
      applyDesc e IHHB2.
      rewrite (sem_outside_above HB1) by order_Bounds e.
      replace (y == x) with false by order_Bounds e.
      simpl_options. destruct (sem s2 y) eqn:?; simpl_options; try lia; applyDesc e (@balanceR_Desc e a);
      solve_Desc e.
Qed.

(** ** Verification of [splitLookup] *)

(* Rewrite to avoid local [go] and StrictTriple *)
Fixpoint splitLookup' (k : e) (s : Map e a) : (Map e a * option a * Map e a) :=
  match s with
   | Tip => (Tip, None, Tip)
   | Bin _ kx x l r => match GHC.Base.compare k kx with
     | Lt => match splitLookup' k l with
               | (lt, z, gt) => match link kx x gt r with
                                              | gt' => (lt, z, gt')
                                            end
             end
     | Gt => match splitLookup' k r with
               | (lt, z, gt) => match link kx x l lt with
                                              | lt' => (lt', z, gt)
                                            end
             end
     | Eq => (l, Some x, r)
    end
 end.

Lemma splitLookup_splitLookup' : forall x map, splitLookup x map  = splitLookup' x map.
Proof.
  intros.
  unfold splitLookup.
  induction map.
  * simpl.
    rewrite <- IHmap1. clear IHmap1.
    rewrite <- IHmap2. clear IHmap2.
    destruct (compare x k).
    + reflexivity.
    + destruct (_ x map1); reflexivity.
    + destruct (_ x map2); reflexivity.
  * reflexivity.
Qed.

Lemma splitLookup_Desc:
  forall x s lb ub,
  Bounded s lb ub ->
  forall (P : Map e a * option a * Map e a -> Prop),
  (forall s1 b s2,
    Bounded s1 lb (Some x) ->
    Bounded s2 (Some x) ub ->
    b = sem s x ->
    (forall i, sem s i =
          (if i == x then sem s i
           else  (sem s1 i ||| sem s2 i))) ->
    P (s1, b, s2)) ->
  P (splitLookup x s) : Prop.
Proof.
  intros ?? ?? HB.
  rewrite splitLookup_splitLookup'.
  induction HB.
  Ltac solveThis e ::= intros X HX; apply HX; clear X HX; [solve_Bounded e|solve_Bounded e|try reflexivity |f_solver e].
  * solveThis e.
  * simpl.
    destruct (compare x x0) eqn:?.
    + solveThis e.
      replace (x == x0) with true by order_Bounds e.
      simpl_options.
      assert (sem s1 x = None). { eapply sem_outside_above. apply HB1. solve_Bounds e. }
      rewrite H3. simpl. reflexivity.
    + apply IHHB1.
      intros s1_2 b s1_3 HB1_2 HB1_3 Hb Hsems1.
      clear IHHB1 IHHB2.
      applyDesc e (@link_Desc e a).
      solveThis e.
      replace (x == x0) with false by order_Bounds e.
      rewrite (sem_outside_below HB2) by order_Bounds e.
      simpl_options. assumption.
    + apply IHHB2.
      intros s2_2 b s2_3 HB2_2 HB2_3 Hb Hsems2.
      clear IHHB1 IHHB2.
      applyDesc e (@link_Desc e a).
      solveThis e.
      replace (x == x0) with false by order_Bounds e.
      rewrite (sem_outside_above HB1) by order_Bounds e.
      simpl_options. assumption.
Qed.

(** ** Verification of [unionWith_Desc] *)
Lemma unionWith_destruct :
  forall (P : Map e a -> Prop),
  forall s1 s2 f,
  (s2 = Tip -> P s1) ->
  (s1 = Tip -> P s2) ->
  (forall sz2 x vx, (s2 = Bin sz2 x vx Tip Tip) -> P (insertWithR f x vx s1)) ->
  (forall sz1 x vx, (s1 = Bin sz1 x vx Tip Tip) -> P (insertWith f x vx s2)) ->
  (forall sz1 x vx l1 r1, (s1 = Bin sz1 x vx l1 r1) ->
    P (
      match splitLookup x s2 with
      | (l2, mb, r2) =>
      match unionWith f r1 r2 with
      | r1r2 =>
      match unionWith f l1 l2 with
      | l1l2 => match mb with
                |None => link x vx l1l2 r1r2
                | Some y => link x (f vx y) l1l2 r1r2
                end
      end end end)) ->
  P (unionWith f s1 s2).
Proof.
  intros P s1 s2 f HTipR HTipL HSingletonR HSingletonL HBins.
  destruct s1, s2; simpl union;
  try destruct s1_1, s1_2;
  try destruct s2_1, s2_2;
  first [ eapply HBins; reflexivity
        | eapply HSingletonL; reflexivity
        | eapply HSingletonR; reflexivity
        | eapply HTipL; reflexivity
        | eapply HTipR; reflexivity
        | idtac
        ].
Qed.

Lemma unionWith_Desc :
  forall (s1: Map e a) s2 lb ub f,
  Bounded s1 lb ub ->
  Bounded s2 lb ub ->
  Desc' (unionWith f s1 s2) lb ub (fun i => match sem s1 i, sem s2 i with
                                            |Some x, Some y => Some (f x y)
                                            | Some x, _ => Some x
                                            | _, Some y => Some y
                                            | _, _ => None
                                            end).
Proof.
intros ????? HB1 HB2.
  revert s2 HB2.
  induction HB1; intros s3 HB3.
  * apply unionWith_destruct; intros; subst; try congruence.
    + solve_Desc e. f_solver e.
    + solve_Desc e. f_solver e.
    + inversion HB3; subst; clear HB3.
      clear H4 H5.
      (* We need to give [applyDesc] a hint about the bounds that we care about: *)
      assert (Bounded (@Tip e a) lb ub) by constructor.
      applyDesc e insertWithR_Desc.
      solve_Desc e. f_solver e.
  * apply unionWith_destruct; intros; subst; try congruence.
    + solve_Desc e. f_solver e.
    + inversion HB3; subst; clear HB3.
      applyDesc e insertWithR_Desc.
      solve_Desc e. f_solver e.
      assert (sem s1 x0 = sem s1 i). apply sem_resp_eq. order e. rewrite H1 in Hsem.
      rewrite Heqo0 in Hsem. simpl in Hsem. symmetry. assumption.
      assert (sem s1 x0 = sem s1 i) by (apply sem_resp_eq; order e). rewrite H1 in Hsem.
      rewrite Heqo0 in Hsem. assert (x0 == x = true) by (order e). rewrite H3 in Hsem.
      simpl in Hsem. symmetry. assumption.
      assert (sem s2 i = sem s2 x0) by (apply sem_resp_eq; order e).
      rewrite <- H1 in Hsem. rewrite Heqo1 in Hsem.
      assert (sem s1 x0 = None). eapply sem_outside_above. eassumption. solve_Bounds e.
      rewrite H3 in Hsem. assert (x0 == x = false) by (order e). rewrite H4 in Hsem.
      simpl in Hsem. symmetry. assumption.
      assert (sem s1 x0 = None). erewrite sem_resp_eq. apply Heqo0. order e.
      rewrite H1 in Hsem. assert (x0 == x = false) by (order e). rewrite H3 in Hsem.
      simpl in Hsem. assert (sem s2 x0 = None). erewrite sem_resp_eq.
      apply Heqo1. order e. rewrite H4 in Hsem. symmetry. assumption.
      assert (sem s1 x0 = Some a0). erewrite sem_resp_eq. apply Heqo0. order e.
      rewrite H1 in Hsem. simpl in Hsem. symmetry. assumption.
      assert (sem s1 x0 = None). erewrite sem_resp_eq. apply Heqo0. order e.
      rewrite H1 in Hsem. assert (x0 == x = true) by (order e). rewrite H3 in Hsem.
      simpl in Hsem. symmetry. assumption.
      assert (sem s1 x0 = None). erewrite sem_resp_eq. apply Heqo0. order e.
      assert (x0 == x = false) by (order e). rewrite H1 in Hsem. rewrite H3 in Hsem.
      simpl in Hsem. assert (sem s2 x0 = Some a0). erewrite sem_resp_eq. apply Heqo1.
      order e. rewrite H4 in Hsem. symmetry. assumption.
      destruct (sem s1 x0); simpl in Hsem. inversion Hsem. destruct (x0 == x); simpl in Hsem.
      inversion Hsem. destruct (sem s2 x0); simpl in Hsem; inversion Hsem.
    + inversion H3; subst; clear H3.
      applyDesc e (@insertWith_Desc e a). solve_Desc e. f_solver e;
      assert (sem s3 x0 = sem s3 i) by (apply sem_resp_eq; order e); rewrite <- H1 in Heqo0;
      rewrite Heqo0 in Hsem; symmetry; assumption.
    + inversion H3; subst; clear H3.
      eapply splitLookup_Desc; try eassumption.
      intros.
      applyDesc e IHHB1_1.
      applyDesc e IHHB1_2. destruct b.
      - applyDesc e (@link_Desc e a). apply showDesc'. split.
        (*Not using solve_Desc because it was very slow*)
        solve_Bounded e. f_solver e; rewrite H5 in Hsem0;
        rewrite <- Hsem1; assumption.
      - applyDesc e (@link_Desc e a). apply showDesc'. split.
        solve_Bounded e. f_solver e; rewrite H5 in Hsem0; rewrite <-Hsem1; assumption.
Qed.

Require Import Coq.Classes.Morphisms.
(** ** Verification of [insertWithKeyR] *)
(*Need to add assumption that f is proper*)
Lemma insertWithKeyR_Desc:
  forall (f: e -> a -> a -> a) y v (s: Map e a) lb ub,
  Bounded s lb ub ->
  Proper ((fun i j : e => _GHC.Base.==_ i j = true) ==> eq) f ->
  isLB lb y = true ->
  isUB ub y = true ->
  Desc (insertWithKeyR f y v s) lb ub (if isSome (sem s y) then size s else (1 + size s)%Z)
      (fun i => (if i == y then match (sem s y) with
                                | None => Some v
                                | Some x => Some (f i x v)
                                end  else None ||| sem s i )).
Proof.
  intros ?????? HB HP HLB HUB.
  induction HB; intros.
  * simpl.
    applyDesc e (@singleton_Desc e a); try eassumption; solve_Desc e.
  * subst; cbn -[Z.add].
    destruct (compare y x) eqn:?.
    + rewrite compare_Eq in Heqc.
      rewrite Heqc.
      rewrite ?isSome_oro, ?isSome_Some, ?orb_true_r, ?orb_true_l.
      solve_Desc e. f_solver e. assert (f x v0 v = f i v0 v). apply equal_f.
      apply equal_f. apply HP. order e. rewrite H1. reflexivity.
    + clear IHHB2.
      applyDesc e IHHB1.
      rewrite (sem_outside_below HB2) by order_Bounds e.
      replace (y == x) with false by order_Bounds e.
      simpl_options. destruct (sem s1 y) eqn:?; simpl isSome in *; try lia;
      applyDesc e (@balanceL_Desc e a); solve_Desc e.
    + clear IHHB1.
      applyDesc e IHHB2.
      rewrite (sem_outside_above HB1) by order_Bounds e.
      replace (y == x) with false by order_Bounds e.
      simpl_options. destruct (sem s2 y) eqn:?; simpl_options; try lia; applyDesc e (@balanceR_Desc e a);
      solve_Desc e.
Qed.

(** ** Verification of [unionWithKey] *)

Lemma unionWithKey_destruct :
  forall (P : Map e a -> Prop),
  forall s1 s2 f,
  (s2 = Tip -> P s1) ->
  (s1 = Tip -> P s2) ->
  (forall sz2 x vx, (s2 = Bin sz2 x vx Tip Tip) -> P (insertWithKeyR f x vx s1)) ->
  (forall sz1 x vx, (s1 = Bin sz1 x vx Tip Tip) -> P (insertWithKey f x vx s2)) ->
  (forall sz1 x vx l1 r1, (s1 = Bin sz1 x vx l1 r1) ->
    P (
      match splitLookup x s2 with
      | (l2, mb, r2) =>
      match unionWithKey f r1 r2 with
      | r1r2 =>
      match unionWithKey f l1 l2 with
      | l1l2 => match mb with
                |None => link x vx l1l2 r1r2
                | Some y => link x (f x vx y) l1l2 r1r2
                end
      end end end)) ->
  P (unionWithKey f s1 s2).
Proof.
  intros P s1 s2 f HTipR HTipL HSingletonR HSingletonL HBins.
  destruct s1, s2; simpl union;
  try destruct s1_1, s1_2;
  try destruct s2_1, s2_2;
  first [ eapply HBins; reflexivity
        | eapply HSingletonL; reflexivity
        | eapply HSingletonR; reflexivity
        | eapply HTipL; reflexivity
        | eapply HTipR; reflexivity
        | idtac
        ].
Qed.

Lemma unionWithKey_Desc :
  forall (s1: Map e a) s2 lb ub f,
  Bounded s1 lb ub ->
  Bounded s2 lb ub ->
  Proper ((fun i j : e => _GHC.Base.==_ i j = true) ==> eq) f ->
  Desc' (unionWithKey f s1 s2) lb ub (fun i => match sem s1 i, sem s2 i with
                                            |Some x, Some y => Some (f i x y)
                                            | Some x, _ => Some x
                                            | _, Some y => Some y
                                            | _, _ => None
                                            end).
Proof.
intros ????? HB1 HB2 HP.
  revert s2 HB2.
  induction HB1; intros s3 HB3.
  * apply unionWithKey_destruct; intros; subst; try congruence.
    + solve_Desc e. f_solver e.
    + solve_Desc e. f_solver e.
    + inversion HB3; subst; clear HB3.
      clear H4 H5.
      (* We need to give [applyDesc] a hint about the bounds that we care about: *)
      assert (Bounded (@Tip e a) lb ub) by constructor.
      eapply insertWithKeyR_Desc. apply H. apply HP. assumption. assumption. intros.
      solve_Desc e. f_solver e.
  * apply unionWithKey_destruct; intros; subst; try congruence.
    + solve_Desc e. f_solver e.
    + inversion HB3; subst; clear HB3.
      eapply insertWithKeyR_Desc. solve_Bounded e. apply HP. assumption. assumption. intros.
      solve_Desc e. f_solver e.
      assert (sem s1 x0 = sem s1 i). apply sem_resp_eq. order e. rewrite H5 in H4.
      rewrite Heqo0 in H4. simpl in H4. symmetry. assumption.
      assert (sem s1 x0 = sem s1 i) by (apply sem_resp_eq; order e). rewrite H5 in H4.
      rewrite Heqo0 in H4. assert (x0 == x = true) by (order e). rewrite H6 in H4.
      simpl in H4. symmetry. assumption.
      assert (sem s2 i = sem s2 x0) by (apply sem_resp_eq; order e).
      rewrite <- H5 in H4. rewrite Heqo1 in H4.
      assert (sem s1 x0 = None). eapply sem_outside_above. eassumption. solve_Bounds e.
      rewrite H6 in H4. assert (x0 == x = false) by (order e). rewrite H9 in H4.
      simpl in H4. symmetry. assumption.
      assert (sem s1 x0 = None). erewrite sem_resp_eq. apply Heqo0. order e.
      rewrite H5 in H4. assert (x0 == x = false) by (order e). rewrite H6 in H4.
      simpl in H4. assert (sem s2 x0 = None). erewrite sem_resp_eq.
      apply Heqo1. order e. rewrite H9 in H4. symmetry. assumption.
      assert (sem s1 x0 = Some a0). erewrite sem_resp_eq. apply Heqo0. order e.
      rewrite H5 in H4. simpl in H4. symmetry. assumption.
      assert (sem s1 x0 = None). erewrite sem_resp_eq. apply Heqo0. order e.
      rewrite H5 in H4. assert (x0 == x = true) by (order e). rewrite H6 in H4.
      simpl in H4. symmetry. assumption.
      assert (sem s1 x0 = None). erewrite sem_resp_eq. apply Heqo0. order e.
      assert (x0 == x = false) by (order e). rewrite H6 in H4. rewrite H5 in H4.
      simpl in H4. assert (sem s2 x0 = Some a0). erewrite sem_resp_eq. apply Heqo1.
      order e. rewrite H9 in H4. symmetry. assumption.
      destruct (sem s1 x0); simpl in H4. inversion H4. destruct (x0 == x); simpl in H4.
      inversion H4. destruct (sem s2 x0); simpl in H4; inversion H4.
    + inversion H3; subst; clear H3.
      applyDesc e (@insertWithKey_Desc e a). solve_Desc e. f_solver e;
      assert (sem s3 x0 = sem s3 i) by (apply sem_resp_eq; order e); rewrite <- H1 in Heqo0.
      destruct (sem s3 x0). assert (f x0 vx a2 = f i vx a2). apply equal_f. apply equal_f.
      apply HP. order e. rewrite H3 in Hsem. rewrite Heqo0 in Hsem. symmetry. assumption.
      rewrite <- Hsem. assumption.
      destruct (sem s3 x0). assert (f x0 vx a1 = f i vx a1). apply equal_f. apply equal_f.
      apply HP. order e. rewrite H3 in Hsem. rewrite Heqo0 in Hsem. inversion Hsem.
      rewrite Heqo0 in Hsem. inversion Hsem.
      destruct (sem s3 x0). assert (f x0 vx a1 = f i vx a1). apply equal_f. apply equal_f.
      apply HP. order e. rewrite H3 in Hsem. rewrite Heqo0 in Hsem. inversion Hsem.
      rewrite Heqo0 in Hsem. inversion Hsem.
    + inversion H3; subst; clear H3.
      eapply splitLookup_Desc; try eassumption.
      intros.
      applyDesc e IHHB1_1.
      applyDesc e IHHB1_2. destruct b.
      - applyDesc e (@link_Desc e a). apply showDesc'. split.
        (*Not using solve_Desc because it was very slow*)
        solve_Bounded e. f_solver e.
        assert (f x0 vx a0 = f i vx a0). apply equal_f. apply equal_f. apply HP. order e.
        rewrite H4. reflexivity.
        all : (rewrite H5 in Hsem0; rewrite <- Hsem1; assumption).
      - applyDesc e (@link_Desc e a). apply showDesc'. split.
        solve_Bounded e. f_solver e; rewrite H5 in Hsem0; rewrite <-Hsem1; assumption.
Qed.

(** ** Verification of [unionsWith] *)
Lemma unionsWith_Desc:
  forall (ss: list (Map e a)) f lb ub,
  Forall (fun s => Bounded s lb ub) ss ->
  Desc' (unionsWith f ss) lb ub (fun i => fold_left (fun t h => match t with
                                                                 | Some y =>
                                                                   match (sem h i) with
                                                                    | Some x => Some (f y x)
                                                                    | _ => t
                                                                   end
                                                                  | _ => (sem h i)
                                                                  end) ss None).
Proof.
  intros.
  unfold unionsWith.
  (* Switch to a fold right *)
  rewrite Proofs.Data.Foldable.hs_coq_foldl'_list.
  rewrite <- fold_left_rev_right.
  rewrite <- (rev_involutive ss).
  rewrite <- (rev_involutive ss), Forall_rev in H.
  generalize dependent (rev ss). intros.
  rewrite rev_involutive.

  induction H.
  * simpl. applyDesc e (@empty_Desc e a). solve_Desc e. f_solver e.
  * simpl fold_right.
    applyDesc e IHForall.
    applyDesc e unionWith_Desc.
    solve_Desc e.
    intro i.
    rewrite Hsem0, Hsem. simpl. rewrite fold_left_app. simpl. destruct (fold_left
    (fun (t : option a) (h : Map e a) =>
     match t with
     | Some y => match sem h i with
                 | Some x0 => Some (f  y x0)
                 | None => t
                 end
     | None => sem h i
     end) (rev l) None); destruct (sem x i ) eqn : ?; reflexivity.
Qed.

(** ** Verification of [link2] *)

(** This is called  [merge] for Set *)

Lemma link2_eq: forall (l r: Map e a), link2 l r =
  match l, r with
  | Tip, r => r
  | l, Tip => l
  | (Bin sizeL x vx lx rx as l), (Bin sizeR y vy ly ry as r) =>
    if Sumbool.sumbool_of_bool
         ((delta GHC.Num.* sizeL) GHC.Base.< sizeR)
    then balanceL y vy (link2 l ly) ry
    else if Sumbool.sumbool_of_bool
              ((delta GHC.Num.* sizeR) GHC.Base.< sizeL)
         then balanceR x vx lx (link2 rx r)
         else glue l r
  end.
Proof.
  intros l r.
  destruct l; [|auto].
  destruct r; [|auto].
  unfold link2 at 1, link2_func at 1;
  lazymatch goal with
    |- Wf.Fix_sub ?A ?R ?Rwf ?P ?F_sub ?x = ?rhs =>
    apply (@Wf.WfExtensionality.fix_sub_eq_ext A R Rwf P F_sub x)
  end.
Qed.

Program Fixpoint link2_Desc (s1: Map e a)  (s2: Map e a)
  {measure (map_size s1 + map_size s2)} :
    forall x lb ub,
      Bounded s1 lb (Some x) ->
      Bounded s2 (Some x) ub  ->
      isLB lb x = true ->
      isUB ub x = true->
      Desc (link2 s1 s2) lb ub (size s1 + size s2)
           (fun i => sem s1 i ||| sem s2 i)
  := _.
Next Obligation.
  intros.
  rewrite link2_eq.
  inversion H; subst; clear H;
    inversion H0; subst; clear H0;
      try solve [solve_Desc e].
  destruct (Sumbool.sumbool_of_bool _);
    only 2: destruct (Sumbool.sumbool_of_bool _);
    rewrite ?Z.ltb_lt, ?Z.ltb_ge in *.
  - applyDesc e link2_Desc.
    applyDesc e (@balanceL_Desc e a). rewrite size_Bin in Hsz. solve_size.
    solve_Desc e.
  - applyDesc e link2_Desc.
    applyDesc e (@balanceR_Desc e a). rewrite size_Bin in Hsz. solve_size.
    solve_Desc e.
  - applyDesc e (@glue_Desc e a).
    solve_Desc e.
Qed.

(** ** Verification of [splitMember] *)

(* Rewrite to avoid local [go] and StrictTriple *)
Fixpoint splitMember' (k : e) (s : Map e a) : (Map e a * bool * Map e a)%type :=
  match s with
   | Tip => (Tip, false, Tip)
   | Bin _ kx x l r => match GHC.Base.compare k kx with
     | Lt => match splitMember' k l with
               | (lt, z, gt) => match link kx x gt r with
                                              | gt' => (lt, z, gt')
                                            end
             end
     | Gt => match splitMember' k r with
               | (lt, z, gt) => match link kx x l lt with
                                              | lt' => (lt', z, gt)
                                            end
             end
     | Eq => (l, true, r)
    end
 end.

Lemma splitMember_splitMember' : forall x s, splitMember x s  = splitMember' x s.
Proof.
  intros.
  unfold splitMember.
  induction s.
  * simpl.
    rewrite <- IHs1. clear IHs1.
    rewrite <- IHs2. clear IHs2.
    destruct (compare x k).
    + reflexivity.
    + destruct (_ x s2); reflexivity.
    + destruct (_ x s3); reflexivity.
  * reflexivity.
Qed.

Lemma splitMember_Desc:
  forall x s lb ub,
  Bounded s lb ub ->
  forall (P : Map e a * bool * Map e a -> Prop),
  (forall s1 b s2,
    Bounded s1 lb (Some x) ->
    Bounded s2 (Some x) ub ->
    b = isSome (sem s x) ->
    (forall i, sem s i =
          (if i == x then sem s i
           else  (sem s1 i ||| sem s2 i))) ->
    P (s1, b, s2)) ->
  P (splitMember x s) : Prop.
Proof.
  intros ?? ?? HB.
  rewrite splitMember_splitMember'.
  induction HB.
  Ltac solveThis e ::= intros X HX; apply HX; clear X HX; [solve_Bounded e|solve_Bounded e|try reflexivity |f_solver e].
  * solveThis e.
  * simpl.
    destruct (compare x x0) eqn:?.
    + solveThis e.
      replace (x == x0) with true by order_Bounds e.
      simpl_options.
      reflexivity.
    + apply IHHB1.
      intros s1_2 b s1_3 HB1_2 HB1_3 Hb Hsems1.
      clear IHHB1 IHHB2.
      applyDesc e (@link_Desc e a).
      solveThis e.
      replace (x == x0) with false by order_Bounds e.
      rewrite (sem_outside_below HB2) by order_Bounds e.
      simpl_options. assumption.
    + apply IHHB2.
      intros s2_2 b s2_3 HB2_2 HB2_3 Hb Hsems2.
      clear IHHB1 IHHB2.
      applyDesc e (@link_Desc e a).
      solveThis e.
      replace (x == x0) with false by order_Bounds e.
      rewrite (sem_outside_above HB1) by order_Bounds e.
      simpl_options. assumption.
Qed.

End WF_Part1.

Section WF_Part2.

Context {e : Type} {a b c : Type} {HEq : Eq_ e} {HOrd : Ord e} {HEqLaws : EqLaws e}  {HOrdLaws : OrdLaws e}.

(** ** Verification of [intersection] *)

Lemma intersection_Desc:
  forall (s1: Map e a) (s2 : Map e b) lb ub,
  Bounded s1 lb ub ->
  Bounded s2 lb ub ->
  Desc' (intersection s1 s2) lb ub
        (fun i => ando' (sem s1 i) (sem s2 i)).
Proof.
  intros ???? HB1 HB2.
  revert s2 HB2.
  induction HB1; intros s3 HB3.
  - simpl. solve_Desc e. f_solver e.
    unfold ando' in Heqo. destruct (sem s3 i); congruence.
  - simpl.
    destruct s3 eqn:Hs3.
    + rewrite <- Hs3 in *.
      clear Hs3 s e0 b0 m1 m2.
      eapply splitMember_Desc; [eassumption|].
      intros s4' p s5' HB1 HB2 Hb Hi.
      applyDesc e IHHB1_1.
      applyDesc e IHHB1_2.
      destruct p.
      * destruct_ptrEq.
        -- solve_Desc e. unfold ando' in *. f_solver e.
           rewrite Hi in Hsem0. congruence.
        -- applyDesc e (@link_Desc e a).
           solve_Desc e. unfold ando' in *.
           f_solver e;
             try solve [rewrite Hi in Hsem0;
                        rewrite <- Hsem0; symmetry; assumption].
      * applyDesc e (@link2_Desc e a).
        solve_Desc e. unfold ando' in *.
        f_solver e;
          try solve [rewrite Hi in Hsem0;
                     rewrite <- Hsem0; symmetry; assumption].
    + solve_Desc e. f_solver e.
Qed.

(** Verificataion of [intersectionWith] *)
Lemma intersectionWith_Desc:
  forall (s1: Map e a) (s2: Map e b) (f: a -> b -> c) lb ub,
  Bounded s1 lb ub ->
  Bounded s2 lb ub ->
  Desc' (intersectionWith f s1 s2) lb ub
        (fun i => match (sem s1 i), (sem s2 i) with
                  | Some x, Some b => Some (f x b)
                  | _, _ => None end).

Proof.
  intros ????? HB1 HB2.
  revert s2 HB2.
  induction HB1; intros s3 HB3.
  - simpl. solve_Desc e. f_solver e.
  - simpl.
    destruct s3 eqn:Hs3.
    + rewrite <- Hs3 in *.
      clear Hs3 s e0 b0 m1 m2.
      eapply splitLookup_Desc; [eassumption|].
      intros s4' p s5' HB1 HB2 Hb Hi.
      applyDesc e IHHB1_1.
      applyDesc e IHHB1_2.
      destruct p.
      * applyDesc e (@link_Desc e c).
        (*Also taking long see*)
        apply showDesc'. split. solve_Bounded e.
        f_solver e; rewrite Hi in Hsem0;
          rewrite <- Hsem1; assumption.
      * applyDesc e (@link2_Desc e c).
        apply showDesc'. split. solve_Bounded e.
        f_solver e; rewrite Hi in Hsem0;
          rewrite <-Hsem1; assumption.
    + solve_Desc e. f_solver e.
Qed.

(** ** Veritication of [intersectionWithKey] *)

(*Had to add assumption that f is Proper*)

Lemma intersectionWithKey_Desc:
  forall (s1: Map e a) (s2 : Map e b) (f: e -> a -> b -> c) lb ub,
  Bounded s1 lb ub ->
  Bounded s2 lb ub ->
  Proper ((fun i j : e => _GHC.Base.==_ i j = true) ==> eq) f ->
  Desc' (intersectionWithKey f s1 s2) lb ub
        (fun i => match (sem s1 i), (sem s2 i) with
                  | Some a, Some b => Some (f i a b)
                  | _, _ => None end).

Proof.
  intros ????? HB1 HB2 HP.
  revert s2 HB2.
  induction HB1; intros s3 HB3.
  - simpl. solve_Desc e. reflexivity.
  - simpl.
    destruct s3 eqn:Hs3.
    + rewrite <- Hs3 in *.
      clear Hs3 s e0 b0 m1 m2.
      eapply splitLookup_Desc; [eassumption|].
      intros s4' p s5' HB1 HB2 Hb Hi.
      applyDesc e IHHB1_1.
      applyDesc e IHHB1_2.
      destruct p.
      * applyDesc e (@link_Desc e c).
        (*Also taking long see*)
        apply showDesc'. split. solve_Bounded e.
        f_solver e.
        f_equal. do 2 apply equal_f. apply HP. order e.
        all :( try (rewrite Hi in Hsem0;
                    rewrite <- Hsem1; assumption)).
      * applyDesc e (@link2_Desc e c).
        apply showDesc'. split. solve_Bounded e.
        f_solver e; rewrite Hi in Hsem0;
          rewrite <-Hsem1; assumption.
    + solve_Desc e. f_solver e.
Qed.

(** ** Verification of [difference] *)

(** A wart: Because we are in a section that fixes [a],
we get this proof only for invocations of [difference] where
boths maps have the same element type. This does not
affect the proof, but requires some Coq proof structure engineering
to fix. *)

Lemma difference_destruct :
  forall (P : Map e a -> Prop),
  forall s1 s2,
  (s1 = Tip -> P Tip) ->
  (s2 = Tip -> P s1) ->
  (forall sz2 x vx l2 r2, (s2 = Bin sz2 x vx l2 r2) ->
    P (
      match split x s1 with
      | pair l1 r1 =>
      match difference r1 r2 with
      | r1r2 =>
      match difference l1 l2 with
      | l1l2 => if size l1l2 + size r1r2 == size s1
                then s1 else link2 l1l2 r1r2
      end end end)) ->
  P (@difference e a b _ _ s1 s2).
Proof.
  intros P s1 s2 HTipL HTipR HBins.
  destruct s1, s2; simpl difference;
  try destruct s1_1, s1_2;
  try destruct s2_1, s2_2;
  first [ eapply HBins; reflexivity
        | eapply HTipL; reflexivity
        | eapply HTipR; reflexivity
        | idtac
        ].
Qed.

Require Import Coq.Program.Tactics.

Open Scope Z_scope.

Lemma difference_Desc :
  forall (s1: Map e a) (s2 : Map e b) lb ub,
  Bounded s1 lb ub ->
  Bounded s2 lb ub ->
  forall (P : Map e a -> Prop),
  (forall s,
    Bounded s lb ub ->
    size s <= size s1 ->
    (size s = size s1 -> forall i, sem s i = sem s1 i) ->
    (forall i, sem s i = diffo' (sem s1 i) (sem s2 i)) ->
    P s) ->
  P (difference s1 s2).
Proof.
  intros s1 s2 lb ub Hb1 Hb2.
  revert s1 Hb1. induction Hb2; intros sl Hb1; apply hide.
  Ltac showP := apply unhide; intros X HX; apply HX; clear X HX; only 3: intro.
  - simpl.
    destruct sl; (showP; [assumption | reflexivity | reflexivity | f_solver e]).
  - apply difference_destruct; intros; subst.
    + (showP; [assumption | order Z | reflexivity | unfold diffo'; f_solver e]).
    + (showP; [assumption | order Z | reflexivity | unfold diffo'; f_solver e]).
    + eapply split_Desc; try eassumption.
      intros sl1 sl2 HBsl1 HBsl2 Hsz Hsem. inversion H3; subst; clear H3.
      eapply IHHb2_1. solve_Bounded e. intros sil ????. clear IHHb2_1.
      eapply IHHb2_2. solve_Bounded e. intros sir ????. clear IHHb2_2.
      destruct (_ == _) eqn:Hcomp.
      * showP; [assumption | reflexivity | reflexivity | ].
        assert (size sl1 + size sl2 <= size sl) by (destruct (sem sl x0); simpl in *;  lia).
        change (size sil + size sir =? size sl = true) in Hcomp.
        rewrite Z.eqb_eq in Hcomp.
        lapply H4; [intro; subst; clear H4|lia].
        lapply H8; [intro; subst; clear H8|lia].
        assert (sem sl x0 = None) by (destruct (sem sl x0); simpl in *; try reflexivity; lia).
        unfold diffo' in *.
        f_solver e. (* TODO: More stuff that [f_solver] should do *)
      * applyDesc e (@link2_Desc e a).
        showP.
        -- assumption.
        -- destruct (sem sl x0); simpl in *; lia.
        -- assert (sem sl x0 = None) by (destruct (sem sl x0); simpl in *; try reflexivity; lia).
           rewrite H11 in Hsz.
           simpl in Hsz.
           lapply H4; [intro; subst|lia].
           lapply H8; [intro; subst|lia].
           clear H4 H8.
           f_solver e.
        -- unfold diffo' in *. f_solver e.
Qed.

End WF_Part2.


(* Extension for [mgraph] of the library GraphTheory
   About Directed Acyclic Multigraphs, in which the relation being linked by a walk is well-founded
 *)

From Coq Require Import Bool.
Set Warnings "-notation-overridden". (* to ignore warnings due to the import of ssreflect *)
From mathcomp Require Import all_ssreflect zify.
Set Warnings "notation-overridden".
From GraphTheory Require Import mgraph.
From Yalla Require Import mll_prelim graph_more.

Import EqNotations.

Set Mangle Names.
Set Mangle Names Light.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

(** ** Directed paths in a multigraph *)
Definition path {Lv Le : Type} {G : graph Lv Le} := seq (edge G).

Definition path_endpoint {Lv Le : Type} {G : graph Lv Le} (b : bool) (s : G) (p : path) :=
  match b with
  | false => head s [seq source e | e <- p]
  | true => last s [seq target e | e <- p]
  end.
Notation path_source := (path_endpoint false).
Notation path_target := (path_endpoint true).

(** ** Directed walks in a multigraph *)
(*
Fixpoint walk {Lv Le : Type} {G : graph Lv Le} (x y : G) (w : path) :=
  if w is e :: w' then (source e == x) && walk (target e) y w' else x == y.
*)
(* TODO beaucoup de doublon avec uwalk : généraliser ? demander à DP *)

(* Any path can be seen as an unoriented path *)
Coercion upath_of_path {Lv Le : Type} {G : graph Lv Le} (p : @path _ _ G) : upath :=
  [seq forward e | e <- p].

Lemma uwalk_walk {Lv Le : Type} {G : graph Lv Le} (p : @path _ _ G) {s t : G} :
  uwalk s t p = walk s t p.
Proof. revert s t. induction p as [ | ? ? IH] => s t //=. by rewrite IH. Qed.

Lemma endpoint_upath_path {Lv Le : Type} {G : graph Lv Le} (b : bool) (s : G) (p : path) :
  upath_endpoint b s p = path_endpoint b s p.
Proof. destruct b; by rewrite /= -map_comp. Qed.

Lemma walk_endpoint {Lv Le : Type} {G : graph Lv Le} (p : path) (x y : G) :
  walk x y p -> path_source x p = x /\ path_target x p = y.
Proof. rewrite -uwalk_walk -!endpoint_upath_path. apply uwalk_endpoint. Qed.

Lemma walk_sub_middle {Lv Le : Type} {G : graph Lv Le} (s t : G) (p q : path) :
  walk s t (p ++ q) -> path_target s p = path_source t q.
Proof. rewrite -!uwalk_walk -!endpoint_upath_path /upath_of_path map_cat. apply uwalk_sub_middle. Qed.

Lemma walk_subK {Lv Le : Type} {G : graph Lv Le} (s t : G) (p q : path) :
  walk s t (p ++ q) -> walk s (path_target s p) p /\ walk (path_source t q) t q.
Proof. rewrite -!uwalk_walk -!endpoint_upath_path /upath_of_path map_cat. apply uwalk_subK. Qed.

Lemma walk_sub {Lv Le : Type} {G : graph Lv Le} (s t : G) (p q r : path) :
  walk s t (p ++ q ++ r) -> walk (path_target s p) (path_source t r) q.
Proof. rewrite -!uwalk_walk -!endpoint_upath_path /upath_of_path !map_cat. apply uwalk_sub. Qed.

Lemma walk_cat {Lv Le : Type} {G : graph Lv Le} (s i t : G) (p q : path) :
  walk s i p -> walk i t q -> walk s t (p ++ q).
Proof. rewrite -!uwalk_walk /upath_of_path map_cat. apply uwalk_cat. Qed.

Lemma walk_rcons {Lv Le : Type} {G : graph Lv Le} (s t : G) (p : path) (e : edge G) :
  walk s t (rcons p e) = (walk s (source e) p) && (target e == t).
Proof. rewrite -!uwalk_walk /upath_of_path map_rcons. apply uwalk_rcons. Qed.

Lemma walk_subgraph {Lv Le : Type} (G : graph Lv Le) V E C (s t : @subgraph_for _ _ G V E C) p :
  walk s t p -> walk (val s) (val t) [seq val e | e <- p].
Proof.
  revert s t. induction p as [ | [a A] p IH] => s t //=.
  cbnb. move => /andP[-> W]. splitb.
  change (target a) with (val (Sub (target a) (C _ _ (valP (exist _ a A))) : subgraph_for C)).
  by apply IH.
Qed.

Lemma walk_dual {Lv Le : Type} (G : graph Lv Le) p u v :
  @walk _ _ (dual G) u v p = @walk _ _ G v u (rev p).
Proof.
  revert u v. induction p as [ | e p IH] => u v //=.
  by rewrite rev_cons walk_rcons IH andb_comm.
Qed.

Lemma walk_edge {Lv Le : Type} (G : graph Lv Le) (e : edge G) :
  walk (source e) (target e) [:: e].
Proof. splitb. Qed.

Definition acyclic {Lv Le : Type} (G : graph Lv Le) :=
  forall (x : G) (p : path), walk x x p -> p = [::].

(** ** Directed Acyclic Multigraph *)
Record dam (Lv Le : Type) : Type := Dam {
    mgraph_of :> graph Lv Le;
    acy : acyclic mgraph_of;
  }.

(** ** Acyclicity is preserved by taking subgraphs *)
Lemma acy_subdam {Lv Le : Type} (G : dam Lv Le) V E C :
  acyclic (@subgraph_for _ _ G V E C).
Proof.
  intros ? ? P.
  assert (A := acy (walk_subgraph P)).
  by revert A => /eqP; rewrite map_nil => /eqP-->.
Qed.

Definition subdam_for {Lv Le : Type} {G : dam Lv Le} {V : {set G}} E C :=
  Dam (@acy_subdam _ _ _ V E C).

Definition remove_vertex_dam {Lv Le : Type} {G : dam Lv Le} (z : G) :=
  subdam_for (@consistent_del1 _ _ _ z).

(** ** Acyclicity is preserved by duality *)
Lemma dual_acy {Lv Le : Type} (G : graph Lv Le) :
  acyclic G -> acyclic (dual G).
Proof.
  intros C v p W.
  rewrite walk_dual in W.
  specialize (C _ _ W).
  by apply /eqP; rewrite -rev_nil; apply /eqP.
Qed.

Definition dual_dam {Lv Le : Type} (G : dam Lv Le) := Dam (dual_acy (@acy _ _ G)).

(** ** The relation being linked by a walk is well-founded in dam *)
Definition is_connected_strict {Lv Le : Type} {G : graph Lv Le} (t s : G) :=
  exists p, (p != [::]) && walk s t p.

Definition is_connected_strict_rev {Lv Le : Type} {G : graph Lv Le} (s t : G) :=
  is_connected_strict t s.

Lemma acc_is_connected_strict_edges {Lv Le : Type} (G : graph Lv Le) (u : G) :
  (forall e, source e = u -> Acc is_connected_strict (target e)) ->
  Acc is_connected_strict u.
Proof.
  intro H.
  constructor => v [p /andP[/eqP-P W]].
  destruct p as [ | e p]; first by []. clear P.
  revert W => /= /andP[/eqP-E W]. subst u.
  specialize (H _ erefl).
  destruct p as [ | f p].
  { by revert W => /= /eqP-<-. }
  apply (Acc_inv H).
  exists (f :: p). rewrite W. splitb.
Qed.

Lemma well_founded_dam_empty {Lv Le : Type} (G : graph Lv Le) :
  #|G| = 0 -> well_founded (@is_connected_strict _ _ G).
Proof. intros N x. apply card0_eq in N. by specialize (N x). Qed.

Lemma well_founded_dam_below {Lv Le : Type} (G : dam Lv Le) (v : G) :
  well_founded (@is_connected_strict _ _ (remove_vertex_dam v)) ->
  forall (u : remove_vertex v) p, walk v (val u) p ->
  Acc is_connected_strict (val u).
Proof.
  intros Rwf u. induction u as [[u U] IH] using (well_founded_ind Rwf).
  move => p /= VU.
  apply acc_is_connected_strict_edges. intros e ?. subst u.
  assert (E : e \in ~: edges_at v).
  { rewrite in_set edges_at_eq. splitb.
    all: apply /eqP => ?; subst v.
    - clear IH. contradict U; apply /negP. by rewrite !in_set negb_involutive.
    - assert (F := acy (walk_cat VU (walk_edge e))).
      by revert F => /eqP; rewrite cat_nil => /andP[_ /eqP-?]. }
  set UT := walk_edge e.
  change (target e) with (val (target (Sub e E : edge (remove_vertex v)))) in UT.
  refine (IH _ _ _ (walk_cat VU UT)).
  exists [:: Sub e E]. splitb. cbnb.
Qed.

Lemma well_founded_dam_removed {Lv Le : Type} (G : dam Lv Le) (v : G) :
  well_founded (@is_connected_strict _ _ (remove_vertex_dam v)) ->
  Acc is_connected_strict v.
Proof.
  intro. constructor => u [p /andP[/eqP-P W]].
  assert (U : u \in [set~ v]).
  { rewrite !in_set. apply /eqP => ?. subst u.
    contradict P. apply (acy W). }
  now refine (@well_founded_dam_below _ _ _ _ _ (Sub u U) _ W).
Qed.

Lemma well_founded_dam {Lv Le : Type} (G : dam Lv Le) :
  well_founded (@is_connected_strict _ _ G).
Proof.
  revert G.
  enough (H : forall n (G : dam Lv Le), #|G| = n -> well_founded (@is_connected_strict _ _ G))
    by (intro G; by apply (H #|G|)).
  intro n; induction n as [ | n IH]; intros G N.
  { by apply well_founded_dam_empty. }
  intro v.
  apply well_founded_dam_removed, IH.
  rewrite -(remove_vertex_card v) in N. simpl in *. lia.
Qed.

Lemma dual_rev {Lv Le : Type} (G : dam Lv Le) u v :
  @is_connected_strict _ _ (dual_dam G) u v <-> @is_connected_strict_rev _ _ G u v.
Proof. split; move => [p ?]; exists (rev p); by rewrite -walk_dual rev_nil. Qed.

Lemma well_founded_dam_rev {Lv Le : Type} (G : dam Lv Le) :
  well_founded (@is_connected_strict_rev _ _ G).
Proof. apply (Morphisms_Prop.well_founded_morphism _ _ (@dual_rev _ _ G)), well_founded_dam. Qed.


(** ** Raamsdonk's Characterisation *)

  Require Import core core_axioms fintype fintype_axioms.
  Import ScopedNotations.
From Chapter9 Require Export reduction.

Lemma sn_mstep {n} (s t : tm n):
  star step s t -> sn step s -> sn step t.
Proof.
  eauto using sn_forward_star.
Qed.

Inductive SN : forall {n}, tm n -> Prop :=
| SNeu n (M: tm n): SNe M -> SN M
| SAbs n A (M: tm (S n)) : SN M -> SN (lam A M)
| SRed n (M M': tm n): SNRed M M' -> SN M' -> SN M
with SNe : forall {n}, tm n -> Prop :=
| SVar n (x: fin n) : SNe (ids x)
| SApp n (R: tm n) M : SNe R -> SN M -> SNe (app R M)
with SNRed : forall {n}, tm n -> tm n -> Prop :=
| SBeta n A (M : tm (S n)) N M': SN N -> M' = M[N..] -> SNRed (app (lam A M) N) M'
| SAppl n (R R': tm n) M : SNRed R R' -> SNRed (app R M) (app R' M).

Scheme SN_ind_2 := Minimality for SN Sort Prop
                   with SNe_ind_2  := Minimality for SNe Sort Prop
                    with redSN_ind_2 := Minimality for SNRed Sort Prop.
Combined Scheme SN_multind from SN_ind_2, SNe_ind_2, redSN_ind_2.

Lemma sn_appL {n} (s : tm n) (t : tm n) :
  sn step (app s t) -> sn step s.
Proof. apply (@sn_morphism _ _ _ _ (fun s => app s t)); eauto using @step. Qed.

Lemma sn_subst_tm {m n} (f : fin m -> tm n) (s : tm m) :
  sn step (subst_tm f s) -> sn step s.
Proof. apply sn_morphism. eauto using step_inst. Qed.

Lemma closed_lam {n}  (s : tm (S n)) A:
  sn step s -> sn step (lam A s).
Proof.
  induction 1 as [M H IH]. constructor. intros M' C. inv C. auto.
Qed.

Lemma closed_appR n (M: tm n) (N: tm n)  :
  sn step (app M N) -> sn step N.
Proof. eapply sn_morphism. eauto. Qed.

Set Implicit Arguments.
Unset Strict Implicit.

(** Weak Head Reduction *)
Inductive redsn : forall n,  tm n -> tm n -> Prop :=
 | redsn_beta n A (M: tm (S n)) (N: tm n) : sn step N -> redsn (app (lam A M) N) (subst_tm (N.:ids) M)
 | redsn_app n (R R' : tm n) (M : tm n) : redsn R R' -> redsn (app R M) (app R' M).

Lemma fundamental_backwards n (M: tm (S n)) (N: tm n) A:
   sn step N -> sn step (subst_tm (N.: ids) M) -> sn step (app (lam A M) N).
Proof.
  intros sn_N sn_M'.
  assert (H: sn step M) by (now apply sn_subst_tm in sn_M').
  revert M H sn_M'. induction sn_N as [N sn_N IH_N].
  induction 1 as [M sn_M IH_M]. intros H. constructor. intros M' C. inv C.
  - constructor. intros M' H'. inv H. now apply H.
  - inv C. rename b2 into M'. eapply IH_M. assumption.
    eauto using sn_mstep, mstep_beta.
  - eapply IH_N; eauto.
    + eauto using sn_mstep, mstep_beta.
Qed.

(** Neutral terms *)
Fixpoint neutral n (M: tm n) :=
  match M with
  | var_tm  x => True
  | app  s t => neutral s
  | _ => False
  end.

Lemma neutral_preservation n (M N: tm n):
  neutral  M -> step M N ->  neutral N.
Proof. intros H. induction 1; simpl in *; intuition. Qed.

Lemma sn_confluence n (M: tm n):
  forall M' M'', redsn M M' -> step M M'' -> M' = M'' \/ exists M''', redsn M'' M''' /\ star step M' M'''.
Proof.
  induction M as [x | T M IHM | M1 IHM1 M2 IHM2]; intros M' M'' D E; inv D; inv E.
  - now left.
  - inv E. right. eexists. split.
    + now constructor.
    + apply mstep_inst. eauto.
  - right. eexists. split. econstructor. inv H; eauto. apply mstep_beta; eauto.
  - inv D.
  - destruct (IHM _ _ D E) as [IH|(M''&IH1&IH2)].
    + subst. now left.
    + right. eexists. split.
      * econstructor. eassumption.
      * eapply mstep_app. assumption. constructor.
  - right. eexists. split.
    + constructor. eassumption.
    + eapply mstep_app. constructor. eauto.
Qed.

Lemma redsn_backwards n (M M': tm n):
 redsn M M' -> sn step M' -> sn step M.
Proof.
 induction 1 as [|n M M' N H IH].
 - intros D. eapply fundamental_backwards; eauto.
 - intros D. specialize (IH (sn_appL _ _ D)).
   assert (sn_N: sn step N) by (now apply closed_appR in D).
   revert M IH M' D H. induction sn_N as [N sn_N IH_N]. induction 1 as [M sn_M IH_M].
   constructor. intros M_N C. inv C.
   + inv H.
   + destruct (sn_confluence H C) as [E|(M'''&C1&C2)].
     * now subst.
     * eapply IH_M with (M' := M'''); eauto.
       eapply sn_mstep; [|eassumption]. eapply mstep_app; eauto.
   + eapply IH_N; eauto.
     * inv D. apply H. now constructor.
Qed.

Lemma sn_app_neutral n (N : tm n) :
   sn step N -> forall (M: tm n), neutral M -> sn step M -> sn step (app M N).
Proof.
  induction 1 as [N sn_N IH_N].
  induction 2 as [M sn_M IH_M].
  constructor. intros M' C. inv C.
  - contradiction.
  - eauto using neutral_preservation.
  - eauto using sn.
Qed.

Lemma SN_sn :
  (forall n (M: tm n), SN M -> sn step M)
/\ (forall n (M: tm n), SNe M -> sn step M /\ neutral M)
/\ (forall n (M: tm n) M', SNRed M M' -> redsn M M') .
Proof.
  apply SN_multind; intros.
  - intuition.
  - now apply closed_lam.
  - eauto using redsn_backwards.
  - split; [|now constructor].
    + constructor. intros M H. inv H.
  - split; [|intuition].
    + now apply sn_app_neutral.
  - subst. now constructor.
  - now constructor.
Qed.

Ltac invTm :=
match goal with
|[_ : var_tm _ = ren_tm ?R ?M' |- _] => inv M'; simpl in *; try congruence
|[_ : lam _ _ = ren_tm ?R ?M' |- _] => inv M'; simpl in *; try congruence
|[_ : app _ _ = ren_tm ?R ?M' |- _] => inv M'; simpl in *; try congruence
|[H: lam _ _ = lam _ _ |- _] => inv H
|[H: app _ _ = app _ _|- _] => inv H
|[H: ids _ = ids _|- _] => inv H
end.

Hint Constructors SN SNe SNRed.

Lemma anti_rename:
  (forall n (M: tm n), SN M -> forall n' M' (R: fin n' -> fin n), M = ren_tm R M' -> SN M')
 /\ (forall n (M: tm n), SNe M -> forall n' M' (R: fin n' -> fin n), M = ren_tm R M' -> SNe M')
 /\ (forall n (M N: tm n), SNRed M N -> forall n' (R: fin n' -> fin n) M', M = ren_tm R M' -> exists N', N = ren_tm R N' /\ SNRed M' N').
Proof.
  apply SN_multind; intros; repeat invTm; subst; eauto.
  (* TODO asimpl * does not exist anymore. was not needed here anyways *)
    (* asimpl in *; subst; eauto. *)
  - destruct (H0 _ _ _ (eq_refl _)) as (M''&->&?).
    eapply SRed; eauto.
  - asimpl in H.
    destruct M'; simpl in *; try congruence.
    inv H; now constructor.
  - exists (M'0_1 [M'0_2..]).
    split. now asimpl. constructor; eauto.
  - destruct (H0 _ _ _ (eq_refl (ren_tm R0 M'1))) as (N'&->&A2).
    exists (app N' M'2). split; [reflexivity| now constructor].
Qed.

Lemma rename :
  (forall n (M: tm n), SN M -> forall n' (R: fin n -> fin n'), SN (ren_tm R M))
  /\   (forall n (M: tm n),  SNe M -> forall n' (R: fin n -> fin n'), SNe (ren_tm R M))
  /\ (forall n (M N: tm n), SNRed M N -> forall n' (R: fin n -> fin n'), SNRed (ren_tm R M) (ren_tm R N)).
Proof.
  (* apply SN_multind; intros; asimpl in *; eauto. *)
  apply SN_multind; asimpl; intros; eauto.
  - constructor.
  - intros. subst. constructor. auto. now asimpl.
Qed.

Lemma ext_SN n (M: tm n) (p: fin n) :
  SN (app M (var_tm p)) -> SN M.
Proof.
  intros H. remember (app M (var_tm p)) as Mp. revert M p HeqMp.
  induction H; intros; subst.
  - inv H. now constructor.
  - inv HeqMp.
  - inv H.
    + apply SAbs. eapply anti_rename. exact H0.
      instantiate (1 := p..). substify. now asimpl.
    + eapply SRed. exact H. eapply IHSN. reflexivity.
Qed.

(** ** Logical Relation *)
Fixpoint Red {n} (A : ty) : tm n -> Prop :=
  match A with
  | Base => fun s => SN s
  | Fun A B => fun s =>
      forall n' (S : fin n -> fin n') (t : tm n'), Red A t -> Red B (app (ren_tm S s) t)
  end.

Definition RedS {n n'} (S: fin n -> tm n') (Gamma: fin n -> ty) :=
  forall i, Red (Gamma i) (S i).

Lemma rename_red m n (f : fin m -> fin n) (s : tm m) A :
  Red A s -> Red A (ren_tm f s).
Proof.
  revert s. destruct A as [| A B]; intros s; cbn.
  - intros H. now apply rename.
  - intros H n' g t lt. asimpl. now apply H.
Qed.

Lemma cr A:
  (forall n (M: tm n), Red A M -> SN M) /\ (forall n (M: tm n), SNe M -> Red A M) /\ (forall n (M M': tm n), SNRed M M' -> Red A M' -> Red A M).
Proof.
  induction A as [|A IHA B IHB].
  - repeat split; intros.
    + assumption.
    + now apply SNeu.
    + now apply SRed with (M' := M').
  - repeat split; intros.
    + eapply anti_rename with (R := shift) (M := ren_tm shift M); [|reflexivity].
      eapply ext_SN, IHB. cbn in H. apply H, IHA. apply SVar with (x:= var_zero).
    + intros g' R N H'. apply IHB.
      apply SApp. now apply rename. now intuition.
    + intros g' R N rn. apply IHB with (M' := app (ren_tm R M') N).
     * constructor. now apply rename.
     * apply H0, rn.
Qed.

Lemma red_var n (p: fin n) A:
  Red A (var_tm p).
Proof. apply cr, SVar. Qed.

From Chapter9 Require Export preservation.

Lemma main_lemma n (M: tm n)  A Gamma:
  Gamma |- M : A ->  forall n' (S: fin n -> tm n'), RedS S Gamma  -> Red A (subst_tm S M).
Proof.
  induction 1; intros.
  - cbn. apply H.
    - intros m R N rn.
    eapply cr.
    + cbn. econstructor.
      * eapply cr; eauto.
      * reflexivity.
    +
      (* oldasimpl. *)
      asimpl.
      eapply IHhas_type. intros [|]; eauto.
      * cbn. unfold funcomp.
        (* adrian: had to insert the following line *)
        change (fun x : fin n' => @var_tm m (R x)) with (funcomp var_tm R).
       renamify.
        apply rename_red. eauto.
  - cbn.  specialize (IHhas_type2 _ _ H1).
    specialize (IHhas_type1  _ _ H1 n' id _ IHhas_type2).
    asimpl in IHhas_type1. eauto.
Qed.

Lemma id_red g Gamma: @RedS g g ids Gamma.
Proof. intros i. now apply red_var. Qed.

Lemma norm n (M: tm n) (A: ty) Gamma: Gamma |- M : A -> SN M.
Proof.
  intros C.
  assert (H := main_lemma C (@id_red n Gamma)).
  asimpl in H. now apply cr in H.
Qed.


Require Import Relation_Definitions Relation_Operators
               Omega Arith ListSet FSetInterface.

(* ******************************************************* *)
(* VERSION 4 *)

(** * Discusson *)

(**

   We follow Joshua Guttman's Establishing and Preserving Protocol
   Security Goals.  Except where we don't...

   Start with sorts: names, nonces, data, symmetric keys, asymmetric
   keys. Let messages be the disjoint union of all these.

   Basic values include names, nonces, data, and keys.  "These keys
   include parameters and also the range of a key constructor" Latter
   presumably refers to pk and privk.  Not clear what "parameter"
   means there.

   About "variables", or "indeterminates": if names, etc are viewed as
   subsorts of message, then one should have variables at each sort.
   But if---as in JG's EPPSG paper---one allows variables to be
   replaced by any message, then names, nonce, etc should be viewed as
   predicates.

   EPPSG makes a distinction between parameters and variables...not
   clear on the difference.

   Note.  When we want to have functions like that that operate on
   certain "messages" only, like keys or names, then we do view keys
   and names as types.  When you want to treat these as messages then
   you must explcitly wrap them in their constructors.  As in

   [ (Enc (Data d) (pk n) ) ]  not just
   [ (Enc       d  (pk n) ) ]

   Too bad, though, since the only way the latter could be well-typed
   is via the former verbose version so you'd hope it could be
   "inferred".  But no, that's an accident: could certainly have two
   constructors with the same input and output types...
   Moral: subsort inclusion has to be made explicit.

*)

(** * Texts *)
(** ** Definition *)
Variable Text : Set.

(** ** Decidable equality for texts *)
Variable eq_text_dec : forall (x y:Text), {x = y} + {x <> y}.
Hint Resolve eq_text_dec.

(*********************************************************************)

(** * Keys *)

(** Interesting design choices about keys. Here we do not model
   symmetric and asymmetric keys as separate types; the distinction is
   just different constructor/injections into the key type.
   Sometimes simpler.  Possible issue is with key inverses...?
*)

(** ** Definition *)
Variable Key : Set.

Parameter K_p : set Key.

(** ** Inverse relation for keys *)
Variable inv : relation Key.

(** ** Decidable equality for keys *)
Variable eq_key_dec : forall (x y:Key), {x=y} + {x<>y}.
Hint Resolve eq_key_dec.

(*********************************************************************)

(** * Messages *)
(** ** Inductive  definition for messages *)
Inductive msg : Set :=
  | T : Text -> msg
  | K : Key -> msg
  | P : msg -> msg -> msg
  | E : msg -> Key -> msg.
Hint Constructors msg.

(** ** Decidable equality for messages *)
Definition eq_msg_dec : forall x y : msg,
  {x = y} + {x <> y}.
Proof.
intros.
decide equality.
Qed.
Hint Resolve eq_msg_dec.

(** ** Sign messages *)
Inductive smsg :=
  | xmit_msg : msg -> smsg
  | recv_msg : msg -> smsg.

Notation "+ m" := (xmit_msg m) (at level 30) : ma_scope.
Notation "- m" := (recv_msg m) : ma_scope.

(* Convert sign messages to messages *)
Definition smsg_2_msg (m : smsg) : msg :=
   match m with
   | (xmit_msg x) => x
   | (recv_msg  x) => x
   end.

(** ** Atomic messages *)
Inductive atomic : msg -> Prop :=
  |atomic_text : forall t, atomic (T t)
  |atomic_key : forall k, atomic (K k).
Hint Constructors atomic.

(** ** Concatenated messages *)
Inductive pair : (msg -> Prop) :=
  | pair_step : forall m1 m2, pair (P m1 m2).
Hint Constructors pair.

(** ** Encrypted messages *)
Inductive enc : msg -> Prop :=
  | enc_step : forall m k, enc (E m k).
Hint Constructors enc.

(** ** Basic messages *)
(** Treat basic as a predicate, not a subtype *)
Inductive basic : msg -> Prop :=
  | b_text : forall t, basic (T t)
  | b_key : forall k, basic (K k)  .
Hint Constructors basic.

(** ** Simple message *)
(** A message is simple if it is not a concatenated (paired) message *)
Inductive simple : msg -> Prop :=
  | simple_step : forall m, ~ pair m -> simple m.

Lemma enc_imp_simple : forall x k, simple (E x k).
Proof.
intros x k.
apply simple_step.
unfold not. intro Hpair.
inversion Hpair.
Qed.

(** ** Some basic results about atomic, paired, simple, and basic messages *)
Lemma pair_not_atomic :
  forall m, pair m -> ~ atomic m.
Proof.
unfold not.
intros m HConc HAtom.
inversion HConc; inversion HAtom; subst; discriminate.
Qed.

Lemma atom_not_pair:
  forall m, atomic m -> ~ pair m.
Proof.
unfold not.
intros m HAtom Hpair.
inversion Hpair; inversion HAtom; subst; discriminate.
Qed.

Lemma enc_not_basic : forall m1 m2, ~ basic (P m1 m2).
Proof.
unfold not.
intros m1 m2 HBasic.
inversion HBasic.
Qed.

Lemma atomic_imp_simple : forall a, atomic a -> simple a.
Proof.
intros a Hatom.
apply simple_step.
apply atom_not_pair; assumption.
Qed.

(*********************************************************************)

(** * Freeness assumptions about pair and encryption *)
(* Both of them are provable in this context *)

(** ** For pair *)
(** If two concatenated (or encrypted) messages are equal then each
component of the first is equal the corresponding componet of the second *)
Lemma pair_free : forall m1 m2 m1' m2',
                 P m1 m2 = P m1' m2' -> m1 = m1' /\ m2 = m2'.
Proof.
intros m1 m2 m1' m2' HPeq.
injection HPeq. auto.
Qed.

(** ** For Encryption *)
Lemma enc_free : forall m k m' k',
                 E m k = E m' k' -> m = m' /\ k = k'.
Proof.
intros m k m' k' HEeq.
injection HEeq.
auto.
Qed.

(** * Ingredient.   Called "carried by" in some CPSA pubs. *)
(** ** Definition *)
Inductive ingred : msg -> msg -> Prop :=
| ingred_refl : forall m, ingred m m
| ingred_pair_l : forall m l r,
    ingred m l -> ingred m (P l r)
| ingred_pair_r : forall m l r,
    ingred m r -> ingred m (P l r)
| ingred_encr : forall m x k,
    ingred m x -> ingred m (E x k).

Notation "a <st b" := (ingred a b) (at level 30) : ss_scope.

Open Scope ss_scope.

(** ** Properties *)
(** *** Transitive *)
Lemma ingred_trans :
  forall x y z,  x <st y -> y <st z -> x <st z.
Proof.
intros x y z Sxy Syz.
induction Syz.
  subst; auto.
  subst; apply ingred_pair_l; apply IHSyz; assumption.
  subst; apply ingred_pair_r; apply IHSyz; assumption.
  apply ingred_encr; apply IHSyz; assumption.
Qed.
Hint Resolve ingred_trans.

(** *** Some other basic results about ingredients *)
Lemma ingred_pair : forall (x y z:msg), x <> (P y z) ->
                                  x <st (P y z) ->
                                  x <st y \/ x <st z.
Proof.
intros x y z Hneq Hst.
inversion Hst; subst.
  elim Hneq; trivial.
  auto.
  auto.
Qed.
Hint Resolve ingred_pair.

Lemma ingred_enc : forall (x y :msg) (k:Key), x <> (E y k) ->
                                 x <st (E y k) ->
                                 x <st y.
Proof.
intros x y k Hneq Hst.
inversion Hst; subst.
  elim Hneq; trivial.
  auto.
Qed.
Hint Resolve ingred_enc.

(*********************************************************************)

(** * Size of messages *)
(** ** Definition *)
Fixpoint size (m:msg) :=
  match m with
   | T t => 1
   | K k => 1
   | P m1 m2 => (size m1) + (size m2)
   | E x k => (size x) + 1
   end.

(** Size of every message is always positive *)
Lemma zero_lt_size : forall x, 0 < size x.
Proof.
intro x.
induction x; simpl; omega.
Qed.
Hint Resolve zero_lt_size.

Lemma size_lt_plus_l : forall x y, size x < size x + size y.
Proof.
intros x y.
assert (size x + 0 < size x  + size y).
apply plus_lt_compat_l. apply zero_lt_size.
rewrite (plus_comm (size x) 0) in H.
rewrite (plus_O_n (size x)) in H. auto.
Qed.

(** ** Realtionship between ingredient and size *)

(** Size of an ingredient x is always less than or equal
 size of message y if x is an ingredient of y. *)
Lemma ingred_lt :
  forall x y, x <st y -> size(x) <= size(y).
Proof.
intros x y Hst.
induction Hst; subst; simpl; omega.
Qed.

Lemma ingred_ge_size_eq :
  forall x y, x <st y -> size(x) >= size(y) -> x=y.
Proof.
intros x y Hst Hsize_gt.
inversion Hst; subst.
  auto.

  assert (Hx_lt_l : size x <= size l). apply ingred_lt; auto.
   assert (Hl_lt_Plr : size l < size (P l r)).
     simpl. apply size_lt_plus_l.
   assert (Hx_lt_Plr : size x < size (P l r)). omega.
   contradict Hsize_gt. omega.

  assert (Hx_lt_r : size x <= size r). apply ingred_lt; auto.
   assert (Hl_lt_Plr : size r < size (P l r)).
     simpl. rewrite <- (plus_comm). apply size_lt_plus_l.
   assert (Hx_lt_Plr : size x < size (P l r)). omega.
   contradict Hsize_gt. omega.

  assert (Hx_lt_l : size x <= size x0). apply ingred_lt; auto.
   assert (Hx0_lt_E : size x0 < size (E x0 k)).
     simpl. omega.
   assert (Hx_lt_E : size x < size (E x0 k)). omega.
   contradict Hsize_gt. omega.
Qed.
Hint Resolve ingred_ge_size_eq.

(** If each message is an ingredient of each other,
then they are equal *)
Lemma ingred_eq : forall (x y :msg), x <st y -> y <st x -> x = y.
Proof.
intros x y Hxy Hyx.
apply ingred_ge_size_eq.
auto.
apply ingred_lt; auto.
Qed.
Hint Resolve ingred_eq.

Lemma atomic_ingred_eq :
   forall x a, atomic a -> ingred x a -> x=a.
Proof.
intros x a Hat Hin.
inversion Hat; subst; inversion Hin; auto.
Qed.
Hint Resolve atomic_ingred_eq.

(*********************************************************************)

(** * Component *)
(** Intuitively, a message x is a component of a message m
if we can get x just by seperation out all the pairs in m,
without using decryption *)

(** ** Component of a message *)
(** A message t0 is an e-ingredients of message t
if t is in the smallest set containing t0 and closed
under concatenation with arbitrary term t1, i.e,
if t0 is an atomic value of t *)
Inductive e_ingred : relation msg :=
  | e_ingred_refl : forall (t0:msg), e_ingred t0 t0
  | e_ingred_pair_l : forall t0 t1 t2,
      e_ingred t0 t1 -> e_ingred t0 (P t1 t2)
  | e_ingred_pair_r : forall t0 t1 t2,
     e_ingred t0 t2 -> e_ingred t0 (P t1 t2).
Hint Constructors e_ingred.

Inductive comp : relation msg :=
  | comp_step : forall m1 m2,
                simple m1 -> e_ingred m1 m2 -> comp m1 m2.
Notation "a <com b" := (comp a b) (at level 30) : ss_scope.
Hint Constructors comp.

(** ** Component implies ingredient *)
Lemma e_ingred_imp_ingred : forall m1 m2, e_ingred m1 m2 -> ingred m1 m2.
Proof.
intros m1 m2 Hein.
induction Hein; subst.
  apply ingred_refl.
  apply ingred_pair_l; assumption.
  apply ingred_pair_r; assumption.
Qed.

Lemma comp_imp_ingred : forall (m1 m2:msg), m1 <com m2 -> m1 <st m2.
Proof.
intros m1 m2 Hcom.
apply e_ingred_imp_ingred.
inversion Hcom; subst; assumption.
Qed.

(** ** Concatenation or pairing preserves components *)
(** If a message x is a component an other message m1,
it also is a component of every message which is concatenated from
m1 and an abitrary message m2 *)
Lemma preserve_comp_l : forall x m1 m2, comp x m1 -> comp x (P m1 m2).
Proof.
intros x m1 m2 Hcom.
inversion Hcom; subst.
apply comp_step.
 auto.
 apply e_ingred_pair_l; assumption.
Qed.

Lemma preserve_comp_r : forall x m1 m2, comp x m2 -> comp x (P m1 m2).
Proof.
intros x m1 m2 Hcom.
inversion Hcom; subst.
apply comp_step.
 auto.
 apply e_ingred_pair_r; assumption.
Qed.

(** ** An atomic message is a component of itself *)
Lemma comp_atomic_cyclic : forall a, atomic a -> comp a a.
Proof.
intros a Hatom.
constructor.
  apply atomic_imp_simple; assumption.
  apply e_ingred_refl.
Qed.

(** ** A simple message is a component of itself *)
Lemma comp_simple_cyclic : forall a, simple a -> comp a a.
Proof.
intros a Hsim.
constructor; [assumption |constructor].
Qed.

(*********************************************************************)

(** * K-ingredients *)
Section K_relation.
(** A message t0 is an k-ingredients of message t
if t is in the smallest set containing t0 and closed
under encryption and concatenation with arbitrary term t1, i.e,
if t0 is an atomic value of t *)
Variable F : Set.
Parameter inj_F_K : F -> Key.
Axiom inj_F_K_inj : forall x y : F, inj_F_K x = inj_F_K y -> x = y.
Coercion inj_F_K : F >-> Key.
Inductive k_ingred : relation msg :=
  | k_ingred_refl : forall (t0:msg), k_ingred t0 t0
  | k_ingred_pair_l : forall (t0 t1 t2 : msg),
      k_ingred t0 t1 -> k_ingred t0 (P t1 t2)
  | k_ingred_pair_r : forall (t0 t1 t2 : msg),
     k_ingred t0 t2 -> k_ingred t0 (P t1 t2)
  | k_ingred_enc : forall (t0 t1 : msg) (k : F),
     k_ingred t0 t1 -> k_ingred t0 (E t1 k).
Hint Constructors k_ingred.
End K_relation.
Variable A : Set.
Variable B : A -> Key.
Variable m1 m2 : msg.


Require Import Coq.Reals.Reals.
Require Import Coq.micromega.Psatz.
Require Import SMTC.Tactic.

Set SMT Solver "z3".
Local Open Scope R_scope.

Axiom by_z3 : forall (P : Prop), P.

Lemma sum_div :
  forall (a b c d : R),
    c > 0 -> d > 0 -> a > 0 -> b > 0 ->
    (a + b) / (c + d) <= (a/c) + (b/d).
Proof.
  intros. smt solve; apply by_z3.
Qed.

Lemma sum_div_denom :
  forall (a c d : R),
    c > 0 -> d > 0 -> a > 0 ->
    a / (c + d) <= (a/c) + (a/d).
Proof.
  intros. smt solve; apply by_z3.
Qed.

Lemma sum_div_num :
  forall (a b c : R),
    c <> 0 ->
    (a + b) / c = (a/c) + (b/c).
Proof.
  intros. smt solve; apply by_z3.
Qed.

Require Import Coquelicot.Coquelicot.
Require Import Coq.Logic.Classical_Prop.

Ltac breakAbstraction :=
  cbv beta iota delta - [Rle Rge abs Rabs].

Ltac rewrite_R0 :=
  repeat first [ rewrite Rmult_0_l
               | rewrite Rmult_0_r
               | rewrite Rplus_0_r
               | rewrite Rplus_0_l
               | rewrite Rminus_0_r
               | rewrite Rminus_0_l ].

Lemma reals_dense :
  forall (x y : R),
    x < y ->
    exists z : R, x < z < y.
Proof.
  intros x y Hxy.
  pose proof (archimed (1/(y - x))).
  destruct H. clear H0.
  generalize dependent (IZR (up (1 / (y - x)))). intros n H.
  pose proof (archimed (n * x)). destruct H0.
  generalize dependent (IZR (up (n * x))). intros m H0 H1.
  exists (m / n).
  assert ((y - x) * / (y - x) = 1) by (apply Rinv_r; psatzl R).
  assert ((y - x) * n > 1).
  { unfold Rdiv in *. rewrite Rmult_1_l in *. psatz R. }
  cut (n * x < m < n * y).
  { assert (n * / n = 1) by (apply Rinv_r; psatz R).
    intros. unfold Rdiv. generalize dependent (/n). intros.
    assert (n > 0) by psatz R.
    clear - H4 H5 H6. split; psatz R. }
  { psatz R. }
Qed.
Lemma closed_continuous :
  forall {T : UniformSpace} (D : T -> Prop),
    closed D ->
    forall (f : R -> T) (u l : R),
      l < u ->
      (forall r, l <= r < u -> D (f r)) ->
      continuous f u ->
      D (f u).
Proof.
  intros. apply NNPP; intro.
  unfold closed, open, continuous, locally, filterlim,
  filter_le, filtermap in *.
  specialize (H _ H3). specialize (H2 _ H).
  simpl in *. destruct H2 as [eps H2].
  cbv beta iota zeta delta - [ not abs ] in H2.
  destruct (reals_dense (Rmax l (u - eps)) u).
  { destruct eps. simpl. unfold Rmax.
    destruct (Rle_dec l (u - pos)); psatzl R. }
  apply H2 with (y:=x) in H1; auto.
  { destruct eps. simpl in *. compute.
    destruct (Rcase_abs (x + - u)); try psatzl R.
    assert (u - pos < x).
    { revert H4. unfold Rmax. destruct (Rle_dec l (u - pos)); psatzl R. }
    psatzl R. }
  { revert H4. apply Rmax_case_strong; intros; psatzl R. }
Qed.

Require Import Coq.Classes.RelationClasses.
Require Import Setoid Relation_Definitions.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Reals.RIneq.
Global Instance Reflexive_Rge : Reflexive Rge.
Proof.
  red. intro. apply Req_ge. reflexivity.
Qed.

Global Instance Reflexive_Rle : Reflexive Rle.
Proof.
  red. intro. apply Req_ge. reflexivity.
Qed.
Global Instance Transitive_Rge : Transitive Rge.
Proof.
  red. intros. eapply Rge_trans; eauto.
Qed.

Global Instance Transitive_Rle : Transitive Rle.
Proof.
  red. intros. eapply Rle_trans; eauto.
Qed.

Local Open Scope R.

(*
  Add Parametric Relation : R Rle
      reflexivity proved by Rle_refl
      transitivity proved by Rle_trans
        as Rle_setoid_relation.*)
Definition such_that {A : Type} (P : A -> Prop) (R : relation A) :=
  fun x y => P x /\ R x y.

Global Instance Proper_Rmult_1 : Morphisms.Proper (Rle ++> such_that (fun x => x >= 0) eq ++>
                                                       Rle) Rmult.
Proof.
  red. red. red. intros. red in H0. destruct H0. rewrite H1.
  psatz R.
Qed.
Global Instance Proper_Rmult_2 : Morphisms.Proper (such_that (fun x => x >= 0) eq ++> Rle ++>
                                                             Rle) Rmult.
Proof.
  red. red. red. intros. red in H. destruct H. subst x.
  psatz R.
Qed.

Class Cond (A : Prop) := holds : A.
Hint Extern 1 (Cond ?A) =>
(* The goals coming from setoid_rewriting might contain this
spurious assumption *)
try match goal with [ H : Morphisms.apply_subrelation |- _ ] => clear H end;
  red; shelve (* This postpones the subgoal *)
       : typeclass_instances.

(** The trick: postpone the Cond subgoal but still ask for the Proper
subgoal to be resolved *)
Lemma such_that_shelve A (P : A -> Prop) R x :
  Cond (P x) ->
  Morphisms.Proper R x ->
  Morphisms.Proper (such_that P R) x.
Proof. repeat red; intuition. Qed.

Hint Extern 4 (Morphisms.Proper (such_that _ _) _) =>
class_apply such_that_shelve : typeclass_instances.
(* This is needed as the such_that_shelve lemma could apply all the
time and loop *)

Global Instance Proper_Rplus :
  Proper (Rle ==> Rle ==> Rle) Rplus.
Proof.
  red. red. red. intros. apply Rplus_le_compat ; assumption.
Qed.

Global Instance Proper_Rminus :
  Proper (Rle ==> Rle --> Rle) Rminus.
Proof.
  red. red. red. intros. unfold Rminus.
  apply Rplus_le_compat;
    [assumption | apply Ropp_le_contravar ; assumption].
Qed.

Global Instance Proper_Rplus_Rge :
  Proper (Rge ==> Rge ==> Rge) Rplus.
Proof.
  red. red. red. intros. apply Rplus_ge_compat ; assumption.
Qed.

Global Instance Proper_Rminus_Rge :
  Proper (Rge ==> Rge --> Rge) Rminus.
Proof.
  red. red. red. intros. unfold Rminus.
  apply Rplus_ge_compat;
    [assumption | apply Ropp_ge_contravar ; assumption].
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Classes.Morphisms.
Require Import Coqlib.
Require Import Values.
Require Import Memory.
Require Import Functor.
Require Import Monad.
Require Import Lens.
Require Export Lift.

(** * Prerequisites *)

(** We're going to lift the memory operations and theorems from a base
  type [bmem] to a "richer" type [mem], which contains [bmem] as a
  component. Formally, this means that we have a [Lens mem bmem] which
  provides us with well-behaved accessors to the [bmem] component
  inside of [mem]. While this is enough to lift most of the memory
  operations and theorems, we do have additional prerequisites. *)

(** First, in order to lift [MemoryOps], we need to know the value of
  the empty memory state of the richer type [mem]; indeed there's no
  way we would be able to construct that just from [empty : bmem].
  However, the simpler memory state contained within this empty [mem]
  should correspond to the empty [bmem] from the base memory states. *)

Class LiftMemoryOps {mem bmem: Type} (π: mem -> bmem)
  `{bmem_ops: Mem.MemoryOps bmem}
  `{bmem_set: !LensOps π} :=
{
  liftmem_empty: mem
}.

Class LiftMemoryStates {mem bmem: Type} (π: mem -> bmem)
  `{mem_liftops: LiftMemoryOps _ _ π}: Prop :=
{
  liftmem_lens :> Lens π;
  liftmem_get_empty: get π liftmem_empty = Mem.empty
}.

(** Furthermore, we need to know how the extra information fits with
  memory injections. Indeed, we could decide that, if the smaller
  [bmem]s contained inside two [mem]s inject into one another, then
  the larger memory states also inject into one another (that is,
  ignore the extra information for the purposes of memory injections),
  but then we would have no guarantee at all regarding the way in
  which this extra information evolves with program execution.
  The other extreme would be to simply make use of the powerset
  functor to lift [inject], so that two large memory states would
  inject into one another only if they contain exactly the same
  extra information. But this means it would be impossible for
  this extra information to evolve with program execution.

  Instead, we simply let the user specify how the extra information
  affects injection by giving a relation on the larger structures
  which is independent of the original memory states which are
  contained within. This is expressed by the
  [liftmem_inject_same_context] hypothesis below. Relations which
  respect this requirement are equivalent to relations on the quotient
  sets [mem / same_context], where [same_context] relates two larger
  memory states which differ only by the base memory state they
  contain. *)

Class LiftInjectOps {smem bsmem tmem btmem} (σ: smem -> bsmem) (τ: tmem -> btmem)
  `{smem_lift_ops: LiftMemoryOps smem bsmem σ}
  `{tmem_lift_ops: LiftMemoryOps tmem btmem τ}
  `{stinj_ops: !Mem.InjectOps bsmem btmem} :=
{
  liftmem_context_inject: smem -> tmem -> Prop
}.

Class LiftInjections {smem bsmem tmem btmem} σ τ
  `{inj_lift_ops: LiftInjectOps smem bsmem tmem btmem σ τ}: Prop :=
{
  liftinj_sspec :> LiftMemoryStates σ;
  liftinj_tspec :> LiftMemoryStates τ;
  liftmem_inject_same_context :>
    Proper (same_context σ ==> same_context τ ==> impl) liftmem_context_inject
}.

(** For homogenous injections, we must also require that [context_inject]
  be reflexive, so as to prove [neutral_inject]. If that proves to be too
  restrictive, we could introduce the equivalent [inject_neutral] for the
  context, and weaken the following to require only that [inject_neutral]
  elements be proper. *)

Class LiftModelOps {mem bmem} (π: mem -> bmem)
  `{liftmem_ops: LiftMemoryOps mem bmem π}
  `{inj_ops: !Mem.InjectOps bmem bmem}
  `{liftinj_ops: !LiftInjectOps π π}
  `{mm_ops: !Mem.ModelOps bmem} :=
{
}.

Class LiftModel {mem bmem} (π: mem -> bmem)
  `{liftmm_ops: LiftModelOps mem bmem π}: Prop :=
{
  lifthinj_liftinj :> LiftInjections π π;
  lifthinj_context_inject_refl :> Reflexive liftmem_context_inject
}.

(** Using all of this, we can build a set of memory operations on the
  source type [mem] from the operations on the view type [bmem]. *)

Section LIFTOPS.
  Global Instance liftmem_ops `{mem_liftops: LiftMemoryOps}:
    Mem.MemoryOps mem :=
  {
    empty :=
      liftmem_empty;
    nextblock wm :=
      lift Mem.nextblock wm;
    alloc wm lo hi :=
      lift (fun m => Mem.alloc m lo hi) wm;
    free wm b lo hi :=
      lift (fun m => Mem.free m b lo hi) wm;
    load chunk wm b ofs :=
      lift (fun m => Mem.load chunk m b ofs) wm;
    store chunk wm b ofs v :=
      lift (fun m => Mem.store chunk m b ofs v) wm;
    loadbytes wm b ofs n :=
      lift (fun m => Mem.loadbytes m b ofs n) wm;
    storebytes wm b ofs vs :=
      lift (fun m => Mem.storebytes m b ofs vs) wm;
    perm wm b ofs k p :=
      lift (fun m => Mem.perm m b ofs k p) wm;
    valid_pointer wm b ofs :=
      lift (fun m => Mem.valid_pointer m b ofs) wm;
    drop_perm wm b lo hi p :=
      lift (fun m => Mem.drop_perm m b lo hi p) wm;
    extends wm1 wm2 :=
      lift Mem.extends wm1 wm2
  }.
End LIFTOPS.

(** * Lifting the properties *)

Section LIFTDERIVED.
  Context `{HW: LiftMemoryStates}.

  (** Show that the operations derived from the [Mem.MemoryOps]
    instance above are equivalent to lifting the operations derived
    from the original [Mem.MemoryOps]. *)

  Theorem lift_loadv chunk wm addr:
    Mem.loadv chunk wm addr =
    lift (fun m => Mem.loadv chunk m addr) wm.
  Proof.
    reflexivity.
  Qed.

  Theorem lift_storev chunk a v wm:
    Mem.storev chunk wm a v =
    lift (fun m => Mem.storev chunk m a v) wm.
  Proof.
    unfold Mem.storev.
    destruct a; reflexivity.
  Qed.

  Theorem lift_free_list l wm:
    Mem.free_list wm l =
    lift (fun m => Mem.free_list m l) wm.
  Proof with lift_auto.
    revert wm.
    induction l as [ | [[b lo] hi] l IHl]; intros...
    destruct (Mem.free (get π wm) b lo hi)...
    rewrite IHl...
    destruct (Mem.free_list b0 l)...
  Qed.

  Theorem lift_valid_block (wm: mem) (b: block):
    Mem.valid_block wm b <->
    lift (fun m => Mem.valid_block m b) wm.
  Proof.
    reflexivity.
  Qed.

  Theorem lift_range_perm (wm: mem) b lo hi k p:
    Mem.range_perm wm b lo hi k p <->
    lift (fun m => Mem.range_perm m b lo hi k p) wm.
  Proof.
    reflexivity.
  Qed.

  Theorem lift_valid_access (wm: mem) chunk b ofs p:
    Mem.valid_access wm chunk b ofs p <->
    lift (fun m => Mem.valid_access m chunk b ofs p) wm.
  Proof.
    reflexivity.
  Qed.

  Theorem lift_weak_valid_pointer (wm: mem) b ofs:
    Mem.weak_valid_pointer wm b ofs =
    lift (fun m => Mem.weak_valid_pointer m b ofs) wm.
  Proof.
    reflexivity.
  Qed.
End LIFTDERIVED.

Hint Rewrite
  @lift_loadv
  @lift_storev
  @lift_free_list
  @lift_valid_block
  @lift_range_perm
  @lift_valid_access
  @lift_weak_valid_pointer
  using typeclasses eauto : lift.

(** Replace [(get Mem.empty)] by the underlying [Mem.empty]. *)
Hint Rewrite
  @liftmem_get_empty
  using typeclasses eauto: lens.

Section LIFTMEM.
  Context mem bmem `{Hmem: LiftMemoryStates mem bmem}.

  Local Arguments fmap : simpl never.

  Global Instance liftmem_spec:
    Mem.MemoryStates bmem -> Mem.MemoryStates mem.
  Proof.
    intro Hbmem; esplit.
    lift Mem.nextblock_pos.
    lift Mem.valid_not_valid_diff.
    lift Mem.perm_implies.
    lift Mem.perm_cur_max.
    lift Mem.perm_cur.
    lift Mem.perm_max.
    lift Mem.perm_valid_block.
    lift Mem.perm_dec.
    lift Mem.range_perm_implies.
    lift Mem.range_perm_cur.
    lift Mem.range_perm_max.
    lift Mem.valid_access_implies.
    lift Mem.valid_access_valid_block.
    lift Mem.valid_access_perm.
    lift Mem.valid_pointer_nonempty_perm.
    lift Mem.valid_pointer_valid_access.
    lift Mem.weak_valid_pointer_spec.
    lift Mem.valid_pointer_implies.
    lift Mem.nextblock_empty.
    lift Mem.perm_empty.
    lift Mem.valid_access_empty.
    lift Mem.valid_access_load.
    lift Mem.load_valid_access.
    lift Mem.load_type.
    lift Mem.load_cast.
    lift Mem.load_int8_signed_unsigned.
    lift Mem.load_int16_signed_unsigned.
    lift Mem.load_float64al32.
    lift Mem.loadv_float64al32.
    lift Mem.range_perm_loadbytes.
    lift Mem.loadbytes_range_perm.
    lift Mem.loadbytes_load.
    lift Mem.load_loadbytes.
    lift Mem.loadbytes_length.
    lift Mem.loadbytes_empty.
    lift Mem.loadbytes_concat.
    lift Mem.loadbytes_split.
    lift Mem.nextblock_store.
    lift Mem.store_valid_block_1.
    lift Mem.store_valid_block_2.
    lift Mem.perm_store_1.
    lift Mem.perm_store_2.
    lift Mem.valid_access_store.
    lift Mem.store_valid_access_1.
    lift Mem.store_valid_access_2.
    lift Mem.store_valid_access_3.
    lift Mem.load_store_similar.
    lift Mem.load_store_same.
    lift Mem.load_store_other.
    lift Mem.load_store_pointer_overlap.
    lift Mem.load_store_pointer_mismatch.
    lift Mem.load_pointer_store.
    lift Mem.loadbytes_store_same.
    lift Mem.loadbytes_store_other.
    lift Mem.store_signed_unsigned_8.
    lift Mem.store_signed_unsigned_16.
    lift Mem.store_int8_zero_ext.
    lift Mem.store_int8_sign_ext.
    lift Mem.store_int16_zero_ext.
    lift Mem.store_int16_sign_ext.
    lift Mem.store_float32_truncate.
    lift Mem.store_float64al32.
    lift Mem.storev_float64al32.
    lift Mem.range_perm_storebytes.
    lift Mem.storebytes_range_perm.
    lift Mem.perm_storebytes_1.
    lift Mem.perm_storebytes_2.
    lift Mem.storebytes_valid_access_1.
    lift Mem.storebytes_valid_access_2.
    lift Mem.nextblock_storebytes.
    lift Mem.storebytes_valid_block_1.
    lift Mem.storebytes_valid_block_2.
    lift Mem.storebytes_store.
    lift Mem.store_storebytes.
    lift Mem.loadbytes_storebytes_same.
    lift Mem.loadbytes_storebytes_other.
    lift Mem.load_storebytes_other.
    lift Mem.storebytes_concat.
    lift Mem.storebytes_split.
    lift Mem.alloc_result.
    lift Mem.nextblock_alloc.
    lift Mem.valid_block_alloc.
    lift Mem.fresh_block_alloc.
    lift Mem.valid_new_block.
    lift Mem.valid_block_alloc_inv.
    lift Mem.perm_alloc_1.
    lift Mem.perm_alloc_2.
    lift Mem.perm_alloc_3.
    lift Mem.perm_alloc_4.
    lift Mem.perm_alloc_inv.
    lift Mem.valid_access_alloc_other.
    lift Mem.valid_access_alloc_same.
    lift Mem.valid_access_alloc_inv.
    lift Mem.load_alloc_unchanged.
    lift Mem.load_alloc_other.
    lift Mem.load_alloc_same.
    lift Mem.load_alloc_same'.
    lift Mem.range_perm_free.
    lift Mem.free_range_perm.
    lift Mem.nextblock_free.
    lift Mem.valid_block_free_1.
    lift Mem.valid_block_free_2.
    lift Mem.perm_free_1.
    lift Mem.perm_free_2.
    lift Mem.perm_free_3.
    lift Mem.valid_access_free_1.
    lift Mem.valid_access_free_2.
    lift Mem.valid_access_free_inv_1.
    lift Mem.valid_access_free_inv_2.
    lift Mem.load_free.
    lift Mem.nextblock_drop.
    lift Mem.drop_perm_valid_block_1.
    lift Mem.drop_perm_valid_block_2.
    lift Mem.range_perm_drop_1.
    lift Mem.range_perm_drop_2.
    lift Mem.perm_drop_1.
    lift Mem.perm_drop_2.
    lift Mem.perm_drop_3.
    lift Mem.perm_drop_4.
    lift Mem.load_drop.
    lift Mem.extends_refl.
    lift Mem.load_extends.
    lift Mem.loadv_extends.
    lift Mem.loadbytes_extends.
    lift Mem.store_within_extends.
    lift Mem.store_outside_extends.
    lift Mem.storev_extends.
    lift Mem.storebytes_within_extends.
    lift Mem.storebytes_outside_extends.
    lift Mem.alloc_extends.
    lift Mem.free_left_extends.
    lift Mem.free_right_extends.
    lift Mem.free_parallel_extends.
    lift Mem.valid_block_extends.
    lift Mem.perm_extends.
    lift Mem.valid_access_extends.
    lift Mem.valid_pointer_extends.
    lift Mem.weak_valid_pointer_extends.
    lift Mem.perm_free_list.
    exact tt.
  Qed.
End LIFTMEM.

Section LIFTINJ.
  Context `{Hinj: LiftInjections}.

  Global Instance liftmem_inj: Mem.InjectOps smem tmem :=
  {
    inject i wm1 wm2 :=
      Mem.inject i (get σ wm1) (get τ wm2) /\
      liftmem_context_inject wm1 wm2
  }.

  (** A version of [liftmem_inject_same_context] fine-tuned
    for use with eauto *)
  Lemma liftmem_inject_same_context_2 m1 n1 m2 n2:
    liftmem_context_inject m1 m2 ->
    same_context σ m1 n1 ->
    same_context τ m2 n2 ->
    liftmem_context_inject n1 n2.
  Proof.
    intros H H1 H2.
    eapply liftmem_inject_same_context;
    eassumption.
  Qed.

  Hint Immediate liftmem_inject_same_context_2 : lift.

  Global Instance liftinj_spec:
    Mem.MemoryInjections bsmem btmem -> Mem.MemoryInjections smem tmem.
  Proof.
    split; try typeclasses eauto.
    lift Mem.mi_freeblocks.
    lift Mem.valid_block_inject_1.
    lift Mem.valid_block_inject_2.
    lift Mem.perm_inject.
    lift Mem.range_perm_inject.
    lift Mem.valid_access_inject.
    lift Mem.valid_pointer_inject.
    lift Mem.weak_valid_pointer_inject.
    lift Mem.address_inject.
    lift Mem.valid_pointer_inject_no_overflow.
    lift Mem.weak_valid_pointer_inject_no_overflow.
    lift Mem.valid_pointer_inject_val.
    lift Mem.weak_valid_pointer_inject_val.
    lift Mem.inject_no_overlap.
    lift Mem.different_pointers_inject.
    lift Mem.disjoint_or_equal_inject.
    lift Mem.aligned_area_inject.
    lift Mem.load_inject.
    lift Mem.loadv_inject.
    lift Mem.loadbytes_inject.
    lift Mem.store_mapped_inject.
    lift Mem.store_unmapped_inject.
    lift Mem.store_outside_inject.
    lift Mem.storev_mapped_inject.
    lift Mem.storebytes_mapped_inject.
    lift Mem.storebytes_unmapped_inject.
    lift Mem.storebytes_outside_inject.
    lift Mem.alloc_right_inject.
    lift Mem.alloc_left_unmapped_inject.
    lift Mem.alloc_left_mapped_inject.
    lift Mem.alloc_parallel_inject.
    lift Mem.free_left_inject.
    lift Mem.free_list_left_inject.
    lift Mem.free_right_inject.
    lift Mem.free_inject.
    lift Mem.drop_outside_inject.
  Qed.
End LIFTINJ.

Section LIFTMS.
  Context `{Hinj: LiftModel}.

  Global Instance lift_mm_ops: Mem.ModelOps mem := {
    inject_neutral thr wm :=
      Mem.inject_neutral thr (get π wm)
  }.

  Global Instance lift_mem:
    Mem.MemoryModel bmem -> Mem.MemoryModel mem := {}.
  Proof.
    lift Mem.empty_inject_neutral.
    lift Mem.alloc_inject_neutral.
    lift Mem.store_inject_neutral.
    lift Mem.drop_inject_neutral.
    lift_partial Mem.neutral_inject.
      split; now eauto with lift.
  Qed.
End LIFTMS.


(***********************************************************************

 Subbicategories

 We consider two ways of constructing subbicategories. One by selecting
 1-cells and one by selecting both 0-cells and 1-cells.

 Contents
 1. Subbicategory by selecting 1-cells
 2. Subbicategory by selecting both 0-cells and 1-cells

 ***********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma.

Local Open Scope cat.

(**
 1. Subbicategory by selecting 1-cells
 *)
Section Sub1CellBicategory.
  Context (B : bicat)
          (P : ∏ (x y : B), x --> y -> UU)
          (Pid : ∏ (x : B), P _ _ (id₁ x))
          (Pcomp : ∏ (x y z : B) (f : x --> y) (g : y --> z),
                   P  _ _ f → P _ _ g → P _ _ (f · g)).

  Definition disp_sub1cell_disp_cat
    : disp_cat_ob_mor B.
  Proof.
    use make_disp_cat_ob_mor.
    - exact (λ _, unit).
    - exact (λ _ _ _ _ f, P _ _ f).
  Defined.

  Definition disp_sub1cell_disp_cat_id_comp
    : disp_cat_id_comp _ disp_sub1cell_disp_cat.
  Proof.
    use tpair.
    - exact (λ _ _, Pid _).
    - exact (λ _ _ _ _ _ _ _ _ p q, Pcomp _ _ _ _ _ p q).
  Defined.

  Definition disp_sub1cell_disp_cat_data
    : disp_cat_data B.
  Proof.
    use tpair.
    - exact disp_sub1cell_disp_cat.
    - exact disp_sub1cell_disp_cat_id_comp.
  Defined.

  Definition disp_sub1cell_prebicat : disp_prebicat B
    := disp_cell_unit_bicat disp_sub1cell_disp_cat_data.

  Definition disp_sub1cell_bicat : disp_bicat B
    := disp_cell_unit_bicat disp_sub1cell_disp_cat_data.

  Definition disp_2cells_isaprop_sub1cell_bicat    : disp_2cells_isaprop disp_sub1cell_bicat.
  Proof.
    apply disp_2cells_isaprop_cell_unit_bicat.
  Defined.

  Definition disp_locally_groupoid_sub1cell_bicat
    : disp_locally_groupoid disp_sub1cell_bicat.
  Proof.
    apply disp_locally_groupoid_cell_unit_bicat.
  Defined.

  Definition disp_sub1cell_univalent_2_1
             (HP : ∏ (x y : B) (f : x --> y), isaprop (P _ _ f))
    : disp_univalent_2_1 disp_sub1cell_bicat.
  Proof.
    use disp_cell_unit_bicat_univalent_2_1.
    intros.
    apply HP.
  Defined.

  Definition disp_sub1cell_univalent_2_0
             (HB : is_univalent_2_1 B)
             (HP : ∏ (x y : B) (f : x --> y), isaprop (P _ _ f))
    : disp_univalent_2_0 disp_sub1cell_bicat.
  Proof.
    use disp_cell_unit_bicat_univalent_2_0.
    - exact HB.
    - intros ; apply HP.
    - simpl ; intro.
      apply isasetunit.
    - simpl.
      intros.
      apply isapropunit.
  Qed.

  Definition disp_sub1cell_univalent_2
             (HB : is_univalent_2_1 B)
             (HP : ∏ (x y : B) (f : x --> y), isaprop (P _ _ f))
    : disp_univalent_2 disp_sub1cell_bicat.
  Proof.
    split.
    - use disp_sub1cell_univalent_2_0.
      + exact HB.
      + exact HP.
    - use disp_sub1cell_univalent_2_1.
      exact HP.
  Defined.

  Definition sub1cell_bicat
    : bicat
    := total_bicat disp_sub1cell_bicat.

  Definition is_univalent_2_1_sub1cell_bicat
             (HB : is_univalent_2_1 B)
             (HP : ∏ (x y : B) (f : x --> y), isaprop (P _ _ f))
    : is_univalent_2_1 sub1cell_bicat.
  Proof.
    use total_is_univalent_2_1.
    - exact HB.
    - use disp_sub1cell_univalent_2_1.
      exact HP.
  Defined.

  Definition is_univalent_2_0_sub1cell_bicat
             (HB : is_univalent_2 B)
             (HP : ∏ (x y : B) (f : x --> y), isaprop (P _ _ f))
    : is_univalent_2_0 sub1cell_bicat.
  Proof.
    use total_is_univalent_2_0.
    - exact (pr1 HB).
    - use disp_sub1cell_univalent_2_0.
      + exact (pr2 HB).
      + exact HP.
  Defined.

  Definition is_univalent_2_sub1cell_bicat
             (HB : is_univalent_2 B)
             (HP : ∏ (x y : B) (f : x --> y), isaprop (P _ _ f))
    : is_univalent_2 sub1cell_bicat.
  Proof.
    split.
    - use is_univalent_2_0_sub1cell_bicat.
      + exact HB.
      + exact HP.
    - use is_univalent_2_1_sub1cell_bicat.
      + exact (pr2 HB).
      + exact HP.
  Defined.
End Sub1CellBicategory.

(**
 2. Subbicategory by selecting both 0-cells and 1-cells
 *)
Section SubBicategory.
  Context {B : bicat}
          (P₀ : B → UU)
          (P₁ : ∏ (x y : B), x --> y -> UU)
          (P₁id : ∏ (x : B), P₁ _ _ (id₁ x))
          (P₁comp : ∏ (x y z : B) (f : x --> y) (g : y --> z),
              P₁  _ _ f → P₁ _ _ g → P₁ _ _ (f · g)).

  Definition disp_subbicat : disp_bicat B
    := sigma_bicat
         B
         (disp_sub1cell_bicat B P₁ P₁id P₁comp)
         (disp_fullsubbicat
            (total_bicat (disp_sub1cell_bicat B P₁ P₁id P₁comp))
            (λ z, P₀ (pr1 z))).

  Definition disp_2cells_isaprop_subbicat
    : disp_2cells_isaprop disp_subbicat.
  Proof.
    apply disp_2cells_isaprop_sigma.
    - apply disp_2cells_isaprop_sub1cell_bicat.
    - apply disp_2cells_isaprop_fullsubbicat.
  Defined.

  Definition disp_locally_groupoid_subbicat
             (HB : is_univalent_2 B)
    : disp_locally_groupoid disp_subbicat.
  Proof.
    use disp_locally_groupoid_sigma.
    - exact HB.
    - apply disp_2cells_isaprop_sub1cell_bicat.
    - apply disp_2cells_isaprop_fullsubbicat.
    - apply disp_locally_groupoid_sub1cell_bicat.
    - apply disp_locally_groupoid_fullsubbicat.
  Defined.

  Definition disp_subbicat_univalent_2_1
             (HP₁ : ∏ (x y : B) (f : x --> y), isaprop (P₁ x y f))
    : disp_univalent_2_1 disp_subbicat.
  Proof.
    use sigma_disp_univalent_2_1_with_props.
    - apply disp_2cells_isaprop_sub1cell_bicat.
    - apply disp_2cells_isaprop_fullsubbicat.
    - apply disp_sub1cell_univalent_2_1.
      exact HP₁.
    - apply disp_fullsubbicat_univalent_2_1.
  Defined.

  Definition disp_subbicat_univalent_2_0
             (HB : is_univalent_2 B)
             (HP₀ : ∏ (x : B), isaprop (P₀ x))
             (HP₁ : ∏ (x y : B) (f : x --> y), isaprop (P₁ x y f))
    : disp_univalent_2_0 disp_subbicat.
  Proof.
    use sigma_disp_univalent_2_0_with_props.
    - exact HB.
    - apply disp_2cells_isaprop_sub1cell_bicat.
    - apply disp_2cells_isaprop_fullsubbicat.
    - apply disp_sub1cell_univalent_2_1.
      exact HP₁.
    - apply disp_fullsubbicat_univalent_2_1.
    - apply disp_locally_groupoid_sub1cell_bicat.
    - apply disp_locally_groupoid_fullsubbicat.
    - apply disp_sub1cell_univalent_2_0.
      + apply HB.
      + exact HP₁.
    - use disp_univalent_2_0_fullsubbicat.
      + use total_is_univalent_2.
        * apply disp_sub1cell_univalent_2.
          ** apply HB.
          ** exact HP₁.
        * exact HB.
      + intro.
        apply HP₀.
  Defined.

  Definition subbicat
    : bicat
    := total_bicat disp_subbicat.

  Definition eq_2cell_subbicat
             {x y : subbicat}
             {f g : x --> y}
             {α β : f ==> g}
             (p : pr1 α = pr1 β)
    : α = β.
  Proof.
    use subtypePath.
    {
      intro.
      simpl.
      apply isapropdirprod ; apply isapropunit.
    }
    exact p.
  Qed.

  Definition is_invertible_2cell_subbicat
             {x y : subbicat}
             {f g : x --> y}
             (α : f ==> g)
             (Hα : is_invertible_2cell (pr1 α))
    : is_invertible_2cell α.
  Proof.
    use make_is_invertible_2cell.
    - exact (Hα^-1 ,, tt ,, tt).
    - abstract
        (use eq_2cell_subbicat ;
         apply vcomp_rinv).
    - abstract
        (use eq_2cell_subbicat ;
         apply vcomp_linv).
  Defined.

  Definition invertible_2cell_subbicat
             {x y : subbicat}
             {f g : x --> y}
             (Hα : invertible_2cell (pr1 f) (pr1 g))
    : invertible_2cell f g.
  Proof.
    use make_invertible_2cell.
    - exact (pr1 Hα ,, tt ,, tt).
    - use is_invertible_2cell_subbicat.
      exact Hα.
  Defined.

  Definition from_is_invertible_2cell_subbicat
             {x y : subbicat}
             {f g : x --> y}
             (α : f ==> g)
             (Hα : is_invertible_2cell α)
    : is_invertible_2cell (pr1 α).
  Proof.
    use make_is_invertible_2cell.
    - exact (pr1 (Hα^-1)).
    - abstract
        (exact (maponpaths pr1 (vcomp_rinv Hα))).
    - abstract
        (exact (maponpaths pr1 (vcomp_linv Hα))).
  Defined.

  Definition from_invertible_2cell_subbicat
             {x y : subbicat}
             {f g : x --> y}
             (Hα : invertible_2cell f g)
    : invertible_2cell (pr1 f) (pr1 g).
  Proof.
    use make_invertible_2cell.
    - exact (pr11 Hα).
    - use from_is_invertible_2cell_subbicat.
      exact Hα.
  Defined.

  Definition is_univalent_2_1_subbicat
             (HB : is_univalent_2_1 B)
             (HP₁ : ∏ (x y : B) (f : x --> y), isaprop (P₁ x y f))
    : is_univalent_2_1 subbicat.
  Proof.
    use total_is_univalent_2_1.
    - exact HB.
    - use disp_subbicat_univalent_2_1.
      exact HP₁.
  Defined.

  Definition is_univalent_2_0_subbicat
             (HB : is_univalent_2 B)
             (HP₀ : ∏ (x : B), isaprop (P₀ x))
             (HP₁ : ∏ (x y : B) (f : x --> y), isaprop (P₁ x y f))
    : is_univalent_2_0 subbicat.
  Proof.
    use total_is_univalent_2_0.
    - exact (pr1 HB).
    - use disp_subbicat_univalent_2_0.
      + exact HB.
      + exact HP₀.
      + exact HP₁.
  Defined.

  Definition is_univalent_2_subbicat
             (HB : is_univalent_2 B)
             (HP₀ : ∏ (x : B), isaprop (P₀ x))
             (HP₁ : ∏ (x y : B) (f : x --> y), isaprop (P₁ x y f))
    : is_univalent_2 subbicat.
  Proof.
    split.
    - use is_univalent_2_0_subbicat.
      + exact HB.
      + exact HP₀.
      + exact HP₁.
    - use is_univalent_2_1_subbicat.
      + exact (pr2 HB).
      + exact HP₁.
  Defined.
End SubBicategory.