Require Import CertiGraph.prim.prim_env.
Require Export CertiGraph.priq.priq_arr_specs.
Require Import CertiGraph.graph.MathUAdjMatGraph.
Require Import CertiGraph.graph.SpaceUAdjMatGraph1.
Require Export CertiGraph.prim.prim1.

Local Open Scope Z_scope.

Section PrimSpec.

Context {size : Z}.
Context {inf : Z}.
Context {Z_EqDec : EquivDec.EqDec Z eq}.

Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Global Existing Instance CompSpecs.

Definition G := @UAdjMatGG size inf.
Identity Coercion UAdjMatGG_G: G >-> UAdjMatGG.

Definition getCell_spec :=
  DECLARE _getCell
  WITH g: G,
       graph_ptr: pointer_val,
       addresses: list val,
       u: V,
       i : V
  PRE [tptr (tptr tint), tint, tint]
    PROP (0 <= i < size;
          0 <= u < size)
    PARAMS (pointer_val_val graph_ptr;
           Vint (Int.repr u);
           Vint (Int.repr i))
    GLOBALS ()
    SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_symm_mat size g) (pointer_val_val graph_ptr) addresses)
  POST [tint]
    PROP ()
    RETURN (Vint (Int.repr (Znth i (Znth u (@graph_to_symm_mat size g)))))
    SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_symm_mat size g) (pointer_val_val graph_ptr) addresses).

Definition initialise_list_spec :=
  DECLARE _initialise_list
  WITH arr : val, old_list: list val, a: Z
  PRE [tptr tint, tint, tint]
     PROP ( writable_share Tsh;
            repable_signed a;
            0 < size <= Int.max_signed
          )
     PARAMS ( arr; Vint (Int.repr size); Vint (Int.repr a))
     GLOBALS ()
     SEP (data_at Tsh (tarray tint size) (old_list) (arr))
  POST [ tvoid ]
     PROP ()
     LOCAL ()
     SEP (data_at Tsh (tarray tint size) (list_repeat (Z.to_nat size) (Vint (Int.repr a))) arr
         ).

Definition initialise_matrix_spec :=
  DECLARE _initialise_matrix
  WITH arr : val, old_contents: list (list Z), a: Z, addresses : list val
  PRE [tptr (tarray tint size), tint]
     PROP ( writable_share Tsh;
            Zlength old_contents = size;
            forall row, In row old_contents -> Zlength row = size;
            repable_signed a;
            0 < size <= Int.max_signed; (*this is not enough for malloc, requires*)
            size * (4 * size) <= Ptrofs.max_signed (*you can alloc the entire matrix. Can derive above from here*)
          )
     PARAMS ( arr ; Vint (Int.repr a) )
     GLOBALS ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh old_contents arr addresses)
  POST [ tvoid ]
     PROP ()
     LOCAL ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (list_repeat (Z.to_nat size) (list_repeat (Z.to_nat size) a)) arr addresses).

Definition prim_spec :=
  DECLARE _prim
  WITH g: G, garbage: list V, gptr : pointer_val, r: Z, parent_ptr : pointer_val, addresses : list val
  PRE [tptr (tptr tint), tint, tint, tint, tptr tint]
     PROP ( writable_share Tsh;
            vvalid g r;
            size * (4 * size) <= Ptrofs.max_signed
          )
     PARAMS ( pointer_val_val gptr; (Vint (Int.repr size)); (Vint (Int.repr inf)); (Vint (Int.repr r)); pointer_val_val parent_ptr)
     GLOBALS ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_symm_mat size g) (pointer_val_val gptr) addresses;
          data_at Tsh (tarray tint size) (map (fun x => Vint (Int.repr x)) garbage) (pointer_val_val parent_ptr)
         )
  POST [ tvoid ]
     EX mst: G,
     EX fmst: FiniteGraph mst,
     EX parents: list V,
     PROP ( (*connected_graph mst;*)
            @minimum_spanning_forest size inf mst g;
            Permutation (EList mst) (map (fun v => eformat (v, Znth v parents))
              (filter (fun v => Znth v parents <? size) (nat_inc_list (Z.to_nat size))))
          )
     RETURN ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_symm_mat size g) (pointer_val_val gptr) addresses;
          data_at Tsh (tarray tint size) (map (fun x => Vint (Int.repr x)) parents) (pointer_val_val parent_ptr)
         ).

Definition mallocN_spec {CS: compspecs} :=
  DECLARE _mallocN
  WITH n: Z
  PRE [tint]
  PROP (4 <= n <= Int.max_unsigned)
  PARAMS (Vint (Int.repr n))
  GLOBALS ()
  SEP ()
  POST [ tptr tvoid ]
  EX v: pointer_val,
  PROP (malloc_compatible n (pointer_val_val v))
  LOCAL (temp ret_temp (pointer_val_val v))
  SEP (data_at_ Tsh (tarray tint (n / sizeof tint)) (pointer_val_val v) *
       free_tok (pointer_val_val v) n).

Definition freeN_spec {CS: compspecs} :=
  DECLARE _freeN
  WITH sh: share, p: pointer_val, n: Z, contents: list Z
    PRE [tptr tvoid]
    PROP ()
    PARAMS (pointer_val_val p)
    GLOBALS ()
    SEP (data_at sh (tarray tint n)
                 (map Vint (map Int.repr contents))
                 (pointer_val_val p) *
        free_tok (pointer_val_val p) (sizeof tint * n))
  POST [tvoid]
    PROP () LOCAL () SEP (emp).

Definition Gprog: funspecs :=
  ltac:(with_library prog
                     [(@push_spec size inf _);
                     (@pq_emp_spec size inf _);
                     (@popMin_spec size inf Z_EqDec _);
                     (@adjustWeight_spec size inf _);
                     (@init_spec size _);
                     freePQ_spec;
                     mallocN_spec;
                     freeN_spec;
                     getCell_spec;
                     initialise_list_spec;
                     initialise_matrix_spec;
                     prim_spec
       ]).

End PrimSpec.


From HoTT Require Import Basics.
From HoTT Require Import Types.Sigma.
From HoTT Require Import Types.Forall.
From HoTT Require Import Categories.
Require Import Misc.
Require Import Limits.Graph.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.

Section ConeCategory.
  Context `{Funext}.
  Context {C : PreCategory}.
  Context {Size Arrows : Type}.
  Context (Gr : Graph C Size Arrows).

  Definition CnMphComp {c1 c2 c3 : Cone Gr} (m2 : ConeMorphism c2 c3) (m1 : ConeMorphism c1 c2) :
    ConeMorphism c1 c3.
  Proof.
    srapply mkCnMph; [ exact (cnmph_mph m2 o cnmph_mph m1) | ].
    intro n. rewrite <- associativity. rewrite cnmph_comm. apply cnmph_comm.
  Defined.

  Lemma path_ConeMorphism {c1 c2 : Cone Gr} (m1 m2 : ConeMorphism c1 c2) :
    cnmph_mph m1 = cnmph_mph m2 -> m1 = m2.
  Proof.
    destruct m1; destruct m2; simpl. intro Hmph.
    generalize dependent cnmph_comm0. generalize dependent cnmph_comm.
    rewrite <- Hmph. clear Hmph cnmph_mph0.
    intros comm comm0. f_ap. apply path_forall. intro n.
    apply hset_has_UIP. apply trunc_morphism.
  Qed.

  Definition CnMphId (c : Cone Gr) : ConeMorphism c c.
  Proof.
    srapply mkCnMph; [ exact 1 | ].
    intro n; apply right_identity.
  Defined.

  Lemma CnMphCompAssoc {c1 c2 c3 c4}
             (m12 : ConeMorphism c1 c2) (m23 : ConeMorphism c2 c3) (m34 : ConeMorphism c3 c4) :
    CnMphComp (CnMphComp m34 m23) m12 = CnMphComp m34 (CnMphComp m23 m12).
  Proof. apply path_ConeMorphism. simpl. apply associativity. Qed.

  Lemma CnMphCompRightId {c1 c2} (m : ConeMorphism c1 c2) : CnMphComp m (CnMphId c1) = m.
  Proof. apply path_ConeMorphism. apply right_identity. Qed.

  Lemma CnMphCompLeftId {c1 c2} (m : ConeMorphism c1 c2) : CnMphComp (CnMphId c2) m = m.
  Proof. apply path_ConeMorphism. apply left_identity. Qed.

  Definition ConeMorphism_sig_T (c1 c2 : Cone Gr) :=
    { m : morphism C (cn_top c1) (cn_top c2)
    & forall(n : Size), cn_side c2 n o m = cn_side c1 n }.
  Lemma issig_ConeMorphism (c1 c2 : Cone Gr) : ConeMorphism_sig_T c1 c2 <~> ConeMorphism c1 c2.
  Proof. issig. Qed.
  Global Instance CnMphIsHSet (c1 c2 : Cone Gr) : IsHSet (ConeMorphism c1 c2).
  Proof.
    eapply istrunc_equiv_istrunc; [ exact (issig_ConeMorphism c1 c2) | ].
    typeclasses eauto.
  Qed.

  Definition ConeCategory : PreCategory :=
    Build_PreCategory
       ConeMorphism
       CnMphId
       (@CnMphComp)
       (@CnMphCompAssoc)
       (@CnMphCompLeftId)
       (@CnMphCompRightId)
       CnMphIsHSet.

  Lemma cnmph_comp {a b c : object ConeCategory} :
    forall(f : morphism ConeCategory a b),
    forall(g : morphism ConeCategory b c),
      cnmph_mph (g o f) = cnmph_mph g o cnmph_mph f.
  Proof. intros f g. reflexivity. Qed.
  Lemma cnmph_id (a : object ConeCategory) :
    cnmph_mph (CnMphId a) = 1.
  Proof. reflexivity. Qed.
  Definition cnmph_Functor : Functor ConeCategory C.
  Proof.
    srapply Build_Functor; [ exact cn_top | intros s d; exact cnmph_mph | | ]; intros; reflexivity.
  Defined.

  Definition preComposeCone {x : object C} (cn : Cone Gr) (f : morphism C x (cn_top cn)) : Cone Gr.
  Proof.
    srapply mkCone; [ exact x | exact (fun n => cn_side cn n o f) | ].
    intro a; simpl. rewrite <- associativity. rewrite (cn_comm cn). reflexivity.
  Defined.
  Definition preComposeConeProj {x : object C} (cn : Cone Gr) (f : morphism C x (cn_top cn)) :
    ConeMorphism (preComposeCone cn f) cn.
  Proof. srapply mkCnMph; [ exact f | intro n; reflexivity ]. Defined.
End ConeCategory.


Require Export CatSem.CAT.monad_haskell.
Require Export CatSem.CAT.cat_TYPE.

Notation "X *" := (option X) (at level 5).

Section freshness.

(** b fresh for z =>  z{a:=x} == z{a:=b}{b:=x} *)

Variable P : Monad TYPE.
Variable X : Type.
Variable z : P (X*).
Variable a : P (X).
Implicit Arguments kleisli [C F a b].
Implicit Arguments weta [C F c].

Definition fresh_subst := kleisli P (a:=X*) (b:=X * *)
  (fun x => match x in option _ return P (X * *) with
            | Some x => weta P (Some (Some x))
            | None => weta P None
            end).

Definition left_subst := kleisli P
  (fun x => match x in option _ return P X with
           | Some x => weta P x
           | None =>  a
           end).

Definition right_subst := kleisli P
   (fun x => match x in option _ return P X with
             | Some x' => match x' with
                                   | Some x'' => weta P x''
                                   | None => a
                                   end
             | None => a
             end).

Lemma don: left_subst z = right_subst (fresh_subst z).
Proof.
  unfold left_subst.
  unfold right_subst.
  unfold fresh_subst.
  rew (klkl P) .
  assert (H:= kl_eq P).
  simpl in H.
  apply H.
  intros.
  destruct x; simpl; auto.
  rew (etakl P).
  rew (etakl P).
Qed.

End freshness.

Section freshness2.

(** b fresh for z =>  z{b:=x} == z *)

Variable P : Monad TYPE.

Variable X : TYPE.

Variable z : P X.

Definition z' : P(X*) := lift (M:=P) (@Some X) z.

Variable a : P X.

Implicit Arguments kleisli [C F a b].
Implicit Arguments weta [C F c].

Definition freshsubst := kleisli P (a:=X*)(b:=X)
     (fun x => match x with
               | Some x => weta P x
               | None => a
               end).

Lemma don2 : freshsubst z' = z.
Proof.
  unfold freshsubst.
  unfold z'.
  unfold lift.
  simpl.
  rew (klkl P).
  app (kleta_id (FM:=P)).
  intros.
  rew (etakl P).
Qed.

End freshness2.

(*
  simpl.
  simpl.
  rew (etakl P).

Check inj.

  simpl.
  generalize a; clear a.

Require Export CatSem.ULC.ULC_syntax.

Section freshness.

Variable X : Type.

Variable z : ULC (X* ).
Variable a : ULC X.

Definition fresh_subst := _subst
  (fun x => match x in option _ return ULC (X * * ) with
            | Some x => Var (Some (Some x))
            | None => Var None
            end).

Definition left_subst := _subst
  (fun x => match x in option _ return ULC X with
           | Some x => Var x
           | None => a
           end).

Definition right_subst := _subst
   (fun x => match x in option _ return ULC X with
             | Some x' => match x' with
                                   | Some x'' => Var x''
                                   | None => a
                                   end
             | None => a
             end).
Check _subst.
Check left_subst.

Require Import Coq.Program.Equality.

Lemma don: left_subst z = right_subst (fresh_subst z).
unfold left_subst.
unfold right_subst.
unfold fresh_subst.
generalize a.
clear a.
generalize z.
clear z.
intro z.
dependent inversion z;
simpl; intros.
destruct o;
simpl; auto.
apply f_equal.
*)


From Coq Require Import Lists.List.
From Coq Require Import Bool.Bool.
From Coq Require Import Logic.FunctionalExtensionality.
Require Import RBT.Verif.RBtree_Type.
Require Import RBT.Verif.RBtree_Definition.
Require Import RBT.Verif.Half_Tree.
Require Import RBT.Verif.relation_map.
Require Import RBT.Verif.Abstract.

Section Section_general_split.

Context {rbt:RBtree_setting}.
Existing Instance rbt.

Fixpoint general_split(lbool rbool : Key -> bool)  (t : Tag) (s : RBtree)  (b: list Half_tree):
 list Half_tree * RBtree :=
 match s with
 |Empty => (b, Empty)
 |T co l y v t' r =>
    if (lbool y) then
        general_split lbool rbool (Optt t t') l
              ((false,co ,y,f(f v t') t ,default, tag_tree_t (Optt t t') r)::b)
      else if (rbool y) then
        general_split lbool rbool ( Optt t t' ) r
              ((true,co ,y,f(f v t') t ,default, tag_tree_t (Optt t t' ) l)::b)
      else
        (b, T co (tag_tree_t (Optt t t') l) y (f v (Optt t t')) default (tag_tree_t (Optt t t') r))
end.

Definition general_split_simpl (lbool rbool : Key -> bool) (s: RBtree) := general_split lbool rbool default s nil.

Definition lb_rb_tree lb rb (s : RBtree): Prop :=
match s with
|Empty => True
|T co le y v t ri => lb y = false /\ rb y = false
end.

(*GENERAL SPLIT PROPERTIES---------------------------------------------*)
Theorem general_split_lbrb_tree :
  forall lb rb lo hi  tree h  t l s ,
  (forall Rb,  lb Rb  = negb (rb Rb ) \/ (lb Rb = false /\ rb Rb = false))->
    SearchTree' lo tree hi -> SearchTree_half lo h hi
      -> (l , s) = general_split lb rb t tree h ->
               lb_rb_tree lb rb s.
Proof.
  intros. revert h t l s  H1 H2.
  induction H0.
  - intros.
    inversion H2. subst.
    reflexivity.
  - intros.
    simpl in H2.
    pose proof search_popro lo l k H0_.
    pose proof search_popro k r hi H0_0.
    remember (lb k) as m.
    remember (rb k) as n.
    destruct m.
    + clear IHSearchTree'2.
      eapply IHSearchTree'1; try eassumption.
      eapply ST_cons_false; try eassumption.
      eapply search_tag_tree_t; try eassumption.
      right. auto.
    + destruct n.
      * clear IHSearchTree'1.
        eapply IHSearchTree'2; try eassumption.
        eapply ST_cons_true; try eassumption.
        eapply search_tag_tree_t; try eassumption.
        right. auto.
      *
        inversion H2. subst.
        simpl.
        split.
        symmetry. auto.
        symmetry. auto.
Qed.
Theorem general_split_ST_pro:
  forall lb rb lo hi  tree h  t l s ,
  (forall Rb,  lb Rb  = negb (rb Rb ) \/ (lb Rb = false /\ rb Rb = false))->
    SearchTree' lo tree hi -> SearchTree_half lo h hi ->
     (l , s) = general_split lb rb t tree h ->
     ( exists x  y,  SearchTree_half x l y /\ SearchTree' x s y /\
                      ( lo <= x /\ y <= hi) ).
Proof.
  intros. revert lo hi h t l s  H0 H1 H2.
  induction tree.
  - intros.
     simpl in H2.
     inversion H2. subst.
     exists lo. exists hi.
     split.
     * auto.
     * split.
       auto.
       split.
       right. reflexivity.
       right. reflexivity.
  - intros.
    simpl in H2.
    inversion H0.
    subst.
    pose proof search_popro lo tree1 k H11.
    pose proof search_popro k tree2 hi H12.
    remember (lb k) as m.
    remember (rb k) as n.
    destruct m.
    + (* left part *)
       clear IHtree2.
       assert (SearchTree_half lo
       ((false, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) tree2) :: h) k).
     { eapply ST_cons_false; try eassumption.  apply search_tag_tree_t. auto.
        right. auto. }

       pose proof IHtree1 lo k _ _ _ _ H11 H5 H2.
       destruct H6. destruct H6. super_destruct H6.
       exists x. exists x0.
       split. auto.
       split. auto.
       split. auto.
       tr.
    + destruct n.
      * (* right part*)
        assert (SearchTree_half k
       ((true, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) tree1) :: h) hi).
     { eapply ST_cons_true; try eassumption.  apply search_tag_tree_t. auto.
       right. auto.   }

       pose proof IHtree2 k hi _ _ _ _ H12 H5 H2.
       destruct H6. destruct H6. super_destruct H6.
       exists x. exists x0.
       split. auto.
       split. auto.
       split. tr.
       auto.
      * (* middle part*)
        clear IHtree1 IHtree2.
        exists lo. exists hi.
        inversion H2. subst.
        split.
        auto.
        split.
        apply ST_T. apply search_tag_tree_t. auto. apply search_tag_tree_t. auto.
        split.
       right. reflexivity.
       right. reflexivity.
Qed.
Theorem general_split_ST:
  forall lb rb lo hi  tree h  t l s ,
  (forall Rb,  lb Rb  = negb (rb Rb ) \/ (lb Rb = false /\ rb Rb = false))->
    SearchTree' lo tree hi -> SearchTree_half lo h hi ->
     lb hi = true /\ rb lo = true ->
     (l , s) = general_split lb rb t tree h ->
     ( exists x  y,  SearchTree_half x l y /\ SearchTree' x s y /\
                      (lb y = true /\ rb x = true) ).
Proof.
  intros. revert lo hi h t l s  H0 H1 H2 H3.
  induction tree.
  - intros.
     simpl in H3.
     inversion H3. subst.
     exists lo. exists hi.
     split.
     * auto.
     * split.
       auto.
       auto.
  - intros.
    simpl in H3.
    inversion H0.
    subst.
    pose proof search_popro lo tree1 k H12.
    pose proof search_popro k tree2 hi H13.
    remember (lb k) as m.
    remember (rb k) as n.
    destruct m.
    + (* left part *)
       clear IHtree2.
       assert (SearchTree_half lo
       ((false, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) tree2) :: h) k).
     { eapply ST_cons_false; try eassumption.  apply search_tag_tree_t. auto.
       right. auto.  }
       eapply IHtree1. apply H12. apply H6.
       split. symmetry. tauto.
      tauto.
      apply H3.
    + destruct n.
      * (* right part*)
        assert (SearchTree_half k
       ((true, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) tree1) :: h) hi).
     { eapply ST_cons_true; try eassumption.  apply search_tag_tree_t. auto.
       right. auto.   }
    eapply IHtree2. apply H13. apply H6.
       split. apply H2. symmetry. tauto.
      apply H3.
      * (* middle part*)
        clear IHtree1 IHtree2.
        exists lo. exists hi.
        inversion H3. subst.
        split.
        auto.
        split.
        apply ST_T. apply search_tag_tree_t. auto. apply search_tag_tree_t. auto.
        auto.
Qed.
Theorem general_split_ST_prepro:
  forall lb rb lo hi  tree h  t l s ,
  (forall Rb,  lb Rb  = negb (rb Rb ) \/ (lb Rb = false /\ rb Rb = false))->
    SearchTree' lo tree hi -> SearchTree_half lo h hi ->
     lb hi = true /\ rb lo = true ->
     (l , s) = general_split lb rb t tree h ->
     ( exists x  y,  SearchTree_half x l y /\ SearchTree' x s y /\
                     (lb y = true /\ rb x = true) /\ ( lo <= x /\ y <= hi) ).
Proof.
  intros. revert lo hi h t l s  H0 H1 H2 H3.
  induction tree.
  - intros.
     simpl in H3.
     inversion H3. subst.
     exists lo. exists hi.
     split.
     * auto.
     * split.
       auto.
       split.
       auto.
       split.
       right. reflexivity.
       right. reflexivity.
  - intros.
    simpl in H3.
    inversion H0.
    subst.
    pose proof search_popro lo tree1 k H12.
    pose proof search_popro k tree2 hi H13.
    remember (lb k) as m.
    remember (rb k) as n.
    destruct m.
    + (* left part *)
       clear IHtree2.
       assert (SearchTree_half lo
       ((false, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) tree2) :: h) k).
     { eapply ST_cons_false; try eassumption.  apply search_tag_tree_t. auto.
        right. auto. }
       assert (lb k = true /\ rb lo = true ).
       { split. symmetry. tauto.
      tauto. }
       pose proof IHtree1 lo k _ _ _ _ H12 H6 H7 H3.
       destruct H8. destruct H8. super_destruct H8.
       exists x. exists x0.
       split. auto.
       split. auto.
       split.
       * split;auto.
       * split. auto.
       tr.
    + destruct n.
      * (* right part*)
        assert (SearchTree_half k
       ((true, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) tree1) :: h) hi).
     { eapply ST_cons_true; try eassumption.  apply search_tag_tree_t. auto.
       right. auto.   }
       assert (lb hi = true /\ rb k = true ).
       { split.
      tauto. symmetry. tauto. }
       pose proof IHtree2 k hi _ _ _ _ H13 H6 H7 H3.
       destruct H8. destruct H8. super_destruct H8.
       exists x. exists x0.
       split. auto.
       split. auto.
       split.
       tauto.
       split. tr.
       auto.
      * (* middle part*)
        clear IHtree1 IHtree2.
        exists lo. exists hi.
        inversion H3. subst.
        split.
        auto.
        split.
        apply ST_T. apply search_tag_tree_t. auto. apply search_tag_tree_t. auto.
        split.
       auto.
       split.
       right. reflexivity.
       right. reflexivity.
Qed.
(**保证split过后的 list Half_tree 的out ST 性质 *)
Theorem general_split_ST_out :
 forall lb rb lo hi tree h t l s olo ohi ,
    (forall Rb,  lb Rb  = negb (rb Rb ) \/ (lb Rb = false /\ rb Rb = false))->
    SearchTree' lo tree hi -> SearchTree_half lo h hi -> SearchTree_half_out olo h ohi ->
       (l , s) = general_split lb rb t tree h ->
         SearchTree_half_out  (min_k lo olo) l (max_k hi ohi).
Proof.
  intros. revert lo hi h t l s olo ohi H0 H1 H2 H3.
  induction tree.
  - intros.
    simpl in H3.
    inversion H3.
    subst.
    pose proof min_right lo olo.
    pose proof search_half_popro3_lte (min_k lo olo) h ohi olo H2 H4.
    eapply search_half_popro2_lte; try eassumption.
    apply max_right.
  - intros.
    simpl in H3.
    inversion H0.
    subst.
    pose proof search_popro lo tree1 k H12.
    pose proof search_popro k tree2 hi H13.
    remember (lb k) as m.
    remember (rb k) as n.
    destruct m.
    + (*left part*)
       clear IHtree2.
       assert (SearchTree_half lo
       ((false, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) tree2) :: h) k).
     { eapply ST_cons_false; try eassumption.  apply search_tag_tree_t. auto.
       right. auto.  }
       assert (SearchTree_half_out (min_k lo olo) ((false, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) tree2) :: h) (max_k hi ohi)).
      { eapply ST_out_cons; try eassumption.
        eapply ST_ht_false; try eassumption.
        eapply search_tag_tree_t; try eassumption. }
      pose proof IHtree1 _ _ _ (Optt t0 t) l s _ _ H12 H6 H7.
      assert ( min_k (min_k lo olo) lo = (min_k lo olo)).
      {
        apply min_lte.
        apply min_left. }
      assert ( (max_k (max_k hi ohi) k) = (max_k hi ohi)).
      { rewrite max_comm.
        apply max_lte.
        left.
        pose proof max_left hi ohi.
        tr. }
      rewrite <- H9.
      rewrite <- H10.
      rewrite min_comm.
      rewrite max_comm.
      apply H8; try eassumption.
    + destruct n.
      (*right part*)
     *  clear IHtree1.
        assert (SearchTree_half k
       ((true, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) tree1) :: h) hi).
     { eapply ST_cons_true; try eassumption.  apply search_tag_tree_t. auto.
       right. auto.  }
       assert (SearchTree_half_out (min_k lo olo) ((true, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) tree1) :: h) (max_k hi ohi)).
      { eapply ST_out_cons; try eassumption.
        eapply ST_ht_true; try eassumption.
        eapply search_tag_tree_t; try eassumption. }
      pose proof IHtree2 _ _ _ (Optt t0 t) l s _ _ H13 H6 H7.
      assert ( min_k (min_k lo olo) k = (min_k lo olo)).
      {
        apply min_lte.
        pose proof min_left lo olo.
        tr. }
      assert ( (max_k (max_k hi ohi) hi) = (max_k hi ohi)).
      { rewrite max_comm.
        apply max_lte.
        apply max_left.
      }
      rewrite <- H9.
      rewrite <- H10.
      rewrite min_comm.
      rewrite max_comm.
      apply H8; try eassumption.
     *
       clear IHtree1 IHtree2.
       inversion H3. subst.
       pose proof min_right lo olo.
    pose proof search_half_popro3_lte (min_k lo olo) h ohi olo H2 H6.
    eapply search_half_popro2_lte; try eassumption.
    apply max_right.
Qed.

(**保证split过后得到的half tree 和RBtree 满足 Abs性质*)
Theorem general_split_abs:
   forall lb rb lo hi tree h tmap hmap t l s,
  (forall Rb,  lb Rb  = negb (rb Rb ) \/ (lb Rb = false /\ rb Rb = false)) ->
   SearchTree' lo tree hi -> Abs tree tmap ->
  Forall (fun x =>  snd ( fst x) = default) h ->
   SearchTree_half lo h hi -> Abs_half h hmap ->
    (l , s ) = general_split lb rb t tree h -> Abs (complete_tree l s) (combine (tag_update t tmap) hmap).
Proof.
  intros. revert h tmap hmap t l s  H1 H2 H3 H4 H5.
  pose proof (search_popro _ _ _ H0).
  induction H0.
  - intros.
    inversion H2 ; subst.
    simpl in H6.
    inversion H6; subst.
    eapply complete_relate_pre; try eassumption.
    apply ST_E ; try eassumption.
  - intros.
    pose proof (search_popro _ _ _ H0_).
    pose proof (search_popro _ _ _ H0_0).
    inversion H0. subst.
    pose proof (IHSearchTree'1 H6); clear IHSearchTree'1 .
    pose proof (IHSearchTree'2 H7); clear IHSearchTree'2 .
    simpl in H5.
    remember (lb k ) as m.
    remember (rb k ) as n.
    destruct m.
    + (* left part *)
       clear H9.
       pose proof tag_tree_abs r (Optt t0 t) b H16.
       pose proof Abs_cons h hmap false c k (f (f v t) t0) default _ _ default H4 H9 (accumulate_default _  H2); clear H9.
       rewrite Optt_default in H10.
       rewrite tag_update_default in H10.
       assert (Forall P  ((false, c, k, f (f v t) t0, default,
         tag_tree_t (Optt t0 t) r) :: h)).
      { eapply Forall_cons. unfold P. simpl. reflexivity. try eassumption. }

      assert (SearchTree_half lo  ((false, c, k, f (f v t) t0, default,
         tag_tree_t (Optt t0 t) r) :: h) k).
      { eapply ST_cons_false; try eassumption.   eapply search_tag_tree_t; try eassumption.
       right. auto. }

      pose proof H8 _ _ _ _ _ _ H15 H9 H11 H10 H5 ; clear H8 H9 H10 H11 H5.
      rewrite tag_update_twice.
      rewrite f_tag in H12.
      remember (Optt t0 t) as tag.
      rewrite v_up_tagupdate_iff in H12.
       erewrite  <- (v_update_combine k v a b)   by (first [ res_simpl | res_intros | res_intro ]).
       rewrite tagupdate_combine.
       rewrite combine_comm.
       erewrite combine_asso  by (first [ res_simpl | res_intros | res_intro ]).
       auto.
    + destruct n.
      (* right part*)
      * clear H8.
        pose proof tag_tree_abs l (Optt t0 t) a H15.
       pose proof Abs_cons h hmap true c k (f (f v t) t0) default _ _ default H4 H8 (accumulate_default _ H2 );clear H8.
       rewrite Optt_default in H10.
       rewrite tag_update_default in H10.
       assert ( Forall P
        ((true, c, k, f (f v t) t0, default,
         tag_tree_t (Optt t0 t) l) :: h) ).
       { eapply Forall_cons. unfold P. simpl. reflexivity. auto. }
       assert (SearchTree_half k
        ((true, c, k, f (f v t) t0, default,
         tag_tree_t (Optt t0 t) l) :: h) hi ).
       { eapply ST_cons_true; try eassumption.  eapply search_tag_tree_t; try eassumption.
       right. auto.  }
       pose proof H9 _ _ _ _ _ _ H16 H8 H11 H10 H5; clear H10 H9 H8 H11 H5.

       rewrite tag_update_twice.
       rewrite f_tag in H12.
       remember (Optt t0 t) as tag.
       rewrite v_up_tagupdate_iff in H12.
       rewrite (combine_comm a b).
       erewrite  <- (v_update_combine k v b a)  by (first [ res_simpl | res_intros | res_intro ]).
       rewrite tagupdate_combine.
       rewrite combine_comm.
       erewrite combine_asso  by (first [ res_simpl | res_intros | res_intro ]).
       auto.
      * (* midlle part *)
        clear H9 H8.
         inversion H5. subst.
         remember (T c (tag_tree_t (Optt t0 t) l) k (f v (Optt t0 t)) default
        (tag_tree_t (Optt t0 t) r)) as tree.
        assert ( SearchTree' lo tree hi).
        { rewrite Heqtree. eapply ST_T. eapply search_tag_tree_t; try eassumption. eapply search_tag_tree_t; try eassumption. }
        assert (Abs tree
         ( tag_update default (v_update k (f v (Optt t0 t)) (combine ( tag_update (Optt t0 t) a) ( tag_update (Optt t0 t) b)) ))).
        { rewrite Heqtree. eapply Abs_T; try eassumption. eapply tag_tree_abs; try eassumption.  eapply tag_tree_abs; try eassumption. }
        pose proof complete_relate_pre _ _ _ _ _ _ H2 H3 H8 H9 H4.
        rewrite tag_update_default in H10.
        rewrite tag_update_twice.
        rewrite combine_comm in H10.
        rewrite combine_comm.
        remember (Optt t0 t) as tag.
        rewrite tag_v_update.
        remember (f v tag) as v2.
        rewrite tagupdate_combine.
        erewrite v_update_combine by (first [ res_simpl | res_intros |res_intro ]).
        erewrite <- v_update_combine by (first [ res_simpl | res_intros |res_intro ]).
        auto.
Qed.

Lemma general_split_tag_default:
  forall lb rb s t l  lo hi h b,
  (forall Rb,  lb Rb  = negb (rb Rb ) \/ (lb Rb = false /\ rb Rb = false)) ->
  SearchTree' lo s hi -> SearchTree_half lo l hi -> Forall P l -> (h , b) = general_split lb rb t  s l -> Forall P h.
Proof.
  intros.
  revert t l lo hi h b H0 H1 H2 H3.
  induction s.
  - intros. inversion H3. subst. auto.
  - intros.
    simpl in H3.
    inversion H0. subst.
    pose proof search_popro _ _ _ H0.
    remember (lb k) as u.
    remember (rb k) as w.
    destruct u.
    + (* left part *)
      assert (SearchTree_half lo
       ((false, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s2) :: l) k ).
      { eapply ST_cons_false; try eassumption.  eapply search_popro; try eassumption.  eapply search_tag_tree_t; try eassumption.
      right. auto.
       eapply search_popro; try eassumption.
      }
      assert (
      Forall P
       ((false, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s2) :: l)
      ).
      { eapply Forall_cons. reflexivity. auto.
       }
      apply ( IHs1 (Optt t0 t) ((false, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t)  s2) :: l) lo k h b H12 H5 H6 H3).
    + destruct w.
      * (* right part *)
       assert (SearchTree_half k
       ((true, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s1) :: l) hi ).
      { eapply ST_cons_true; try eassumption.  eapply search_popro; try eassumption.  eapply search_tag_tree_t; try eassumption. right. auto.
       eapply search_popro; try eassumption.
      }
      assert (
      Forall P
       ((true, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s1) :: l)
      ).
      { eapply Forall_cons. reflexivity. auto.
       }
      apply ( IHs2(Optt t0 t) ((true, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s1) :: l) _ _ h b H13 H5 H6 H3).
     *
      inversion H3.
      subst. auto.
Qed.

Lemma general_split_tag_default_tree:
  forall lb rb s t l  lo hi h b,
  (forall Rb,  lb Rb  = negb (rb Rb ) \/ (lb Rb = false /\ rb Rb = false)) ->
  SearchTree' lo s hi -> SearchTree_half lo l hi -> (h , b) = general_split lb rb t  s l -> default_tag_tree b \/ b = Empty.
Proof.
  intros.
  revert lo hi t l h b H0 H1 H2.
  induction s.
  - intros. inversion H2. subst. right. reflexivity.
  - intros. simpl in H2.
    inversion H0. subst.
    pose proof search_popro _ _ _ H0.
    remember (lb k) as u.
    remember (rb k) as w.
    destruct u.
    +
      assert (SearchTree_half lo
       ((false, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s2) :: l) k ).
      { eapply ST_cons_false; try eassumption.  eapply search_popro; try eassumption.  eapply search_tag_tree_t; try eassumption. right. auto.
       eapply search_popro; try eassumption.
      }
     eapply (IHs1 lo k (Optt t0 t) ((false, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s2) :: l) h b);try eassumption.
    + destruct w.
      * assert (SearchTree_half k
       ((true, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s1) :: l) hi ).
      { eapply ST_cons_true; try eassumption.  eapply search_popro; try eassumption. eapply search_tag_tree_t; try eassumption. right. auto.
       eapply search_popro; try eassumption.
      }
      eapply (IHs2 k hi (Optt t0 t) ((true, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s1) :: l) h b);try eassumption.
     *
      inversion H2.
      subst. left.  reflexivity.
Qed.
(** 保证split过后得到的half tree 和RBtree 满足 RB color性质*)
Theorem general_split_RB_co :
forall lb rb s l t h b ,
 (forall Rb,  lb Rb  = negb (rb Rb ) \/ (lb Rb = false /\ rb Rb = false)) ->
 is_redblack_color s Black -> is_redblack_color_half l Black ->
   (Red_tree s /\ fst_black' l \/ Black_tree s \/ (s = Empty /\ ~ l =nil)) ->
   (h , b) = general_split lb rb  t s l ->
   ( is_redblack_color b Black /\ is_redblack_color_half h Black ) /\
      (Red_tree b /\ fst_black' h \/ Black_tree b \/ (b = Empty /\ ~ h =nil)).
Proof.
  intros. revert l t h b H0 H1 H2 H3.
  induction s.
  - intros. inversion H3. subst.
     split.
     split. auto. auto.
     right. right.
     destruct H2 as [ [H2 H4] | [ H2 | [H2 H4]]].
     inversion H2.
     inversion H2.
     firstorder.
  - intros.
    simpl in H3.
    assert ( is_redblack_color s1 Black).
    { eapply isrb_left; try eassumption.
    }
    assert ( is_redblack_color s2 Black).
    { eapply isrb_right;try eassumption.
    }
    remember (lb k) as u.
    remember (rb k) as w.
    destruct u.
    + (* left part*)
    assert (is_redblack_color_half ((false, c, k, v, default,s2)::l) Black).
    {
     destruct H2 as [[H2 [H6 H7]] | [ H2 | [H2 H6]]].
     inversion H2. subst. inversion H0. subst. eapply IsRB_co_r_cons; try eassumption. eapply isb_isr_half; try eassumption.
     inversion H2. subst. eapply IsRB_co_b_cons; try eassumption.
     inversion H2.
    }
    assert (is_redblack_color_half ((false, c, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s2) :: l)
  Black).
  { eapply isrb_change_half. apply H6.  eapply isrb_bro; try eassumption.
   eapply isrb_tagupdate; try eassumption. eapply isrb_bro; try eassumption. }
      clear IHs2.
      assert (
      Red_tree s1 /\ fst_black' ((false, c, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s2) :: l) \/
Black_tree s1 \/
s1 = Empty /\ (false, c, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s2) :: l <> nil
      ).
      {
       destruct s1. right. right. split. reflexivity. discriminate.
       destruct c0.
       left. split. reflexivity. split. 2: discriminate.
        destruct c. inversion H0. subst. inversion H10. reflexivity.
       right. left. reflexivity.
      }
      apply (IHs1 ((false, c, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s2) :: l) (Optt t0 t) h b H4 H7 H8 H3 ).
     + destruct w.
      * (* right part *)
       assert (is_redblack_color_half ((false, c, k, v, default,s1)::l) Black).
    {
     destruct H2 as [[H2 [H6 H7]] | [ H2 | [H2 H6]]].
     inversion H2. subst. inversion H0. subst. eapply IsRB_co_r_cons; try eassumption. eapply isb_isr_half; try eassumption.
     inversion H2. subst. eapply IsRB_co_b_cons; try eassumption.
     inversion H2.
    }
    assert (is_redblack_color_half ((true, c, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s1) :: l)
  Black). { eapply isrb_change_half. apply H6. eapply isrb_bro; try eassumption.
   eapply isrb_tagupdate; try eassumption. eapply isrb_bro; try eassumption. }
      clear IHs1.
      assert (
      Red_tree s2 /\ fst_black' ((true, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s1) :: l) \/
Black_tree s2 \/
s2 = Empty /\ ((true, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s1) :: l) <> nil
      ).
      {
       destruct s2. right. right. split. reflexivity. discriminate.
       destruct c0.
       left. split. reflexivity. split. 2: discriminate.
        destruct c. inversion H0. subst. inversion H14. reflexivity.
       right. left. reflexivity.
      }
      apply (IHs2 ((true, c, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s1) :: l)  (Optt t0 t) h b);try eassumption.
     *
       inversion H3.
       split.  split. 2:auto.
       destruct H2 as [[H2 [H9 H10]] | [ H2 | [H2 H6]]].
       subst. inversion H2. subst. inversion H0. subst.
       eapply IsRB_co_r. eapply isrb_tagupdate; try eassumption.
       eapply isrb_tagupdate; try eassumption.
       inversion H2. subst. eapply IsRB_co_b.
       eapply isrb_tagupdate; try eassumption.
       eapply isrb_tagupdate; try eassumption.
       inversion H2.

       destruct H2 as [ [H9 H10 ] | [ H2 | [H2 H6]]].
       subst. inversion H9. subst.
        left. split. reflexivity. auto.
       subst. inversion H2. subst.
        right. left. reflexivity.
       subst. inversion H2.
Qed.
Theorem general_split_RB_co_loose :
forall lb rb s l t h b ,
 (forall Rb,  lb Rb  = negb (rb Rb ) \/ (lb Rb = false /\ rb Rb = false)) ->
 is_redblack_color s Black -> is_redblack_color_half_loose l Black ->
   (Red_tree s /\ fst_black l \/ Black_tree s \/ (s = Empty /\ ~ l =nil)) ->
   (h , b) = general_split lb rb  t s l ->
   ( is_redblack_color b Black /\ is_redblack_color_half_loose h Black ) /\
      (Red_tree b /\ fst_black h \/ Black_tree b \/ (b = Empty /\ ~ h =nil)).
Proof.
  intros. revert l t h b H0 H1 H2 H3.
  induction s.
  - intros. inversion H3. subst.
     split.
     split. auto. auto.
     right. right.
     destruct H2 as [ [H2 H4] | [ H2 | [H2 H4]]].
     inversion H2.
     inversion H2.
     firstorder.
  - intros.
    simpl in H3.
    assert ( is_redblack_color s1 Black).
    { eapply isrb_left; try eassumption.
    }
    assert ( is_redblack_color s2 Black).
    { eapply isrb_right;try eassumption.
    }
    remember (lb k) as u.
    remember (rb k) as w.
    destruct u.
    + (* left part*)

    assert (is_redblack_color_half_loose ((false, c, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s2) :: l)
  Black).
  { destruct H2 as [[H2 H7] | [ H2 | [H2 H6]]].
     inversion H2. subst. inversion H0. subst. eapply IsRB_co_r_cons_l; try eassumption.
     eapply isb_isr_half_loose; try eassumption. eapply isrb_tagupdate; try eassumption.
     inversion H2. subst. eapply IsRB_co_b_cons_l; try eassumption.  eapply isrb_tagupdate; try eassumption.
     inversion H2. }
      clear IHs2.
      assert (
      Red_tree s1 /\ fst_black ((false, c, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s2) :: l) \/
Black_tree s1 \/
s1 = Empty /\ (false, c, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s2) :: l <> nil
      ).
      {
       destruct s1. right. right. split. reflexivity. discriminate.
       destruct c0.
       left. split. reflexivity.
       inversion H0. subst. inversion H9. reflexivity.
       right. left. reflexivity.
      }
      apply (IHs1 ( (false, c, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s2) :: l) (Optt t0 t) h b H4 H6 H7 H3 ).
     + destruct w.
      * (* right part *)

    assert (is_redblack_color_half_loose ((true, c, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s1) :: l)
  Black).
    { destruct H2 as [[H2 H7] | [ H2 | [H2 H6]]].
     inversion H2. subst. inversion H0. subst. eapply IsRB_co_r_cons_l; try eassumption. eapply isb_isr_half_loose; try eassumption. eapply isrb_tagupdate; try eassumption.
     inversion H2. subst. eapply IsRB_co_b_cons_l; try eassumption. eapply isrb_tagupdate; try eassumption.
     inversion H2. }
      clear IHs1.
      assert (
      Red_tree s2 /\ fst_black ((true, c, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s1) :: l) \/
Black_tree s2 \/
s2 = Empty /\ ((true, c, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s1) :: l) <> nil
      ).
      {
       destruct s2. right. right. split. reflexivity. discriminate.
       destruct c0.
       left. split. reflexivity.
        destruct c. inversion H0. subst. inversion H13. reflexivity.
       right. left. reflexivity.
      }
      apply (IHs2 ((true, c, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s1) :: l)  (Optt t0 t) h b);try eassumption.
     *
       inversion H3.
       split.  split. 2:auto.
       destruct H2 as [[H2 H10] | [ H2 | [H2 H6]]].
       subst. inversion H2. subst. inversion H0. subst.
       eapply IsRB_co_r. eapply isrb_tagupdate; try eassumption.
       eapply isrb_tagupdate; try eassumption.
       inversion H2. subst. eapply IsRB_co_b.
       eapply isrb_tagupdate; try eassumption.
       eapply isrb_tagupdate; try eassumption.
       inversion H2.

       destruct H2 as [ [H9 H10 ] | [ H2 | [H2 H6]]].
       subst. inversion H9. subst.
        left. split. reflexivity. auto.
       subst. inversion H2. subst.
        right. left. reflexivity.
       subst. inversion H2.
Qed.

(** 保证split过后得到的half tree 和RBtree 满足 RB dep性质*)
Theorem general_split_RB_dep :
  forall lb rb s l n depth t h b,
   (forall Rb,  lb Rb  = negb (rb Rb ) \/ (lb Rb = false /\ rb Rb = false)) ->
  is_redblack_dep s n -> is_redblack_dep_half l depth n ->
   (h , b) = general_split lb rb t s l -> (exists n' d',  is_redblack_dep b n' /\
   is_redblack_dep_half h d' n' ).
Proof.
  intros. revert l n depth t h b H0 H1 H2.
  induction s.
  - intros. inversion H2. subst. exists O. exists depth. split.
     apply IsRB_dep_em.   inversion H0. subst. auto.
  - intros. simpl in H2.
    destruct (lb k).
    + (* left part *)
      clear IHs2.
      inversion H0.
      subst.
      apply (IHs1 ((false, Red, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s2) :: l)  n depth (Optt t0 t) h b); try eassumption.
      eapply IsRB_dep_r_cons. auto.
      eapply isrb_tagupdate_dep; try eassumption.
      subst.
      apply (IHs1 ((false, Black, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s2) :: l) n0  depth (Optt t0 t) h b ); try eassumption.
      eapply IsRB_dep_b_cons; try eassumption.
      eapply isrb_tagupdate_dep; try eassumption.
    + destruct (rb k).
    * (*right part*)
      clear IHs1.
      inversion H0.
      subst.
      apply (IHs2 ((true, Red, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s1) :: l)n depth (Optt t0 t) h b ); try eassumption.
      eapply IsRB_dep_r_cons. auto.
      eapply isrb_tagupdate_dep; try eassumption.
      subst.
      apply (IHs2 ((true, Black, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s1) :: l)  n0 depth (Optt t0 t) h b); try eassumption.
      eapply IsRB_dep_b_cons; try eassumption.
      eapply isrb_tagupdate_dep; try eassumption.
    * inversion H2. exists n. exists depth.
      split. 2: auto.
      inversion H0.
      subst. eapply IsRB_dep_r. eapply isrb_tagupdate_dep; try eassumption. eapply isrb_tagupdate_dep; try eassumption.
      subst. eapply IsRB_dep_b. eapply isrb_tagupdate_dep; try eassumption. eapply isrb_tagupdate_dep; try eassumption.
Qed.

Theorem general_split_RB_dep_enhance :
  forall lb rb s l n depth t h b,
   (forall Rb,  lb Rb  = negb (rb Rb ) \/ (lb Rb = false /\ rb Rb = false)) ->
  is_redblack_dep s n -> is_redblack_dep_half l depth n ->
   (h , b) = general_split lb rb t s l -> (exists n' ,  is_redblack_dep b n' /\
   is_redblack_dep_half h depth n' ).
Proof.
  intros. revert l n depth t h b H0 H1 H2.
  induction s.
  - intros. inversion H2. subst. exists O. split.
     apply IsRB_dep_em.   inversion H0. subst. auto.
  - intros. simpl in H2.
    destruct (lb k).
    + (* left part *)
      clear IHs2.
      inversion H0.
      subst.
      apply (IHs1 ((false, Red, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s2) :: l)  n depth (Optt t0 t) h b); try eassumption.
      eapply IsRB_dep_r_cons. auto.
      eapply isrb_tagupdate_dep; try eassumption.
      subst.
      apply (IHs1 ((false, Black, k, f (f v t) t0, default, tag_tree_t (Optt t0 t) s2) :: l) n0  depth (Optt t0 t) h b ); try eassumption.
      eapply IsRB_dep_b_cons; try eassumption.
      eapply isrb_tagupdate_dep; try eassumption.
    + destruct (rb k).
    * (*right part*)
      clear IHs1.
      inversion H0.
      subst.
      apply (IHs2 ((true, Red, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s1) :: l)n depth (Optt t0 t) h b ); try eassumption.
      eapply IsRB_dep_r_cons. auto.
      eapply isrb_tagupdate_dep; try eassumption.
      subst.
      apply (IHs2 ((true, Black, k, f (f v t) t0, default,
        tag_tree_t (Optt t0 t) s1) :: l)  n0 depth (Optt t0 t) h b); try eassumption.
      eapply IsRB_dep_b_cons; try eassumption.
      eapply isrb_tagupdate_dep; try eassumption.
    * inversion H2. exists n.
      split. 2: auto.
      inversion H0.
      subst. eapply IsRB_dep_r. eapply isrb_tagupdate_dep; try eassumption. eapply isrb_tagupdate_dep; try eassumption.
      subst. eapply IsRB_dep_b. eapply isrb_tagupdate_dep; try eassumption. eapply isrb_tagupdate_dep; try eassumption.
Qed.

Lemma general_split_leq :
 forall tree t0 h lo hi k0 ,
  SearchTree' lo tree k0 -> k0 < hi ->
  general_split (fun x: Key => x <=? k0) (fun x : Key => x <=? lo ) t0 tree h =
   general_split (fun x: Key => x <=? hi) (fun x : Key => x <=? lo ) t0 tree h .
Proof.
  intro.
  induction tree.
  - intros.
    simpl.
    reflexivity.
  - intros.
    inversion H. subst.
    apply search_popro in H10.
    assert (k <=? k0 = true).
    { eapply lteb_lte. tr. }
    assert (k <=? hi = true).
    { eapply lteb_lte. tr. }
    simpl.
    rewrite H1, H2.
    apply IHtree1.
    eapply search_popro2. try eassumption.
    auto. auto.
Qed.

End Section_general_split.


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

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                            Projet LogiCal                                *)
(*                                                                          *)
(*                     INRIA                        LRI-CNRS                *)
(*              Rocquencourt                        Orsay                   *)
(*                                                                          *)
(*                              May 29th 2002                               *)
(*                                                                          *)
(****************************************************************************)
(*                            Hurkens_set.v                                 *)
(****************************************************************************)

(** This is Hurkens paradox [Hurkens] in system U-, adapted by Herman
    Geuvers [Geuvers] to show the inconsistency in the pure calculus of
    constructions of a retract from Prop into a small type. This file
    focus on the case of a retract into a small type in impredicative
    Set. As a consequence, Excluded Middle in Set is inconsistent with
    the impredicativity of Set.

    References:

    - [Hurkens] A. J. Hurkens, "A simplification of Girard's paradox",
      Proceedings of the 2nd international conference Typed Lambda-Calculi
      and Applications (TLCA'95), 1995.

    - [Geuvers] "Inconsistency of Classical Logic in Type Theory", 2001
      (see www.cs.kun.nl/~herman/note.ps.gz).
*)

(** We show that Hurkens paradox still hold for a retract from the
    negative fragment of Prop only, into bool:Set *)

Section Hurkens_set_neg.

Variable p2b : Prop -> bool.
Variable b2p : bool -> Prop.
Definition dn (A : Prop) := (A -> False) -> False.
Hypothesis p2p1 : forall A : Prop, dn (b2p (p2b A)) -> dn A.
Hypothesis p2p2 : forall A : Prop, A -> b2p (p2b A).

Definition V := forall A : Set, ((A -> bool) -> A -> bool) -> A -> bool.
Definition U := V -> bool.
Definition sb (z : V) : V := fun A r a => r (z A r) a.
Definition le (i : U -> bool) (x : U) : bool :=
  x (fun A r a => i (fun v => sb v A r a)).
Definition induct (i : U -> bool) : Prop :=
  forall x : U, b2p (le i x) -> dn (b2p (i x)).
Definition WF : U := fun z => p2b (induct (z U le)).
Definition I (x : U) : Prop :=
  (forall i : U -> bool, b2p (le i x) -> dn (b2p (i (fun v => sb v U le x)))) ->
  False.

Lemma Omega : forall i : U -> bool, induct i -> dn (b2p (i WF)).
intros i y.
apply y.
unfold le, WF, induct in |- *.
apply p2p2.
intros x H0.
apply y.
exact H0.
Qed.

Lemma lemma : induct (fun u => p2b (I u)).
unfold induct in |- *.
intros x p.
intro H; apply H.
apply (p2p2 (I x)).
intro q.
apply (p2p1 (I (fun v : V => sb v U le x)) (q (fun u => p2b (I u)) p)).
intro H'; apply H'.
intro i.
apply q with (i := fun y => i (fun v : V => sb v U le y)).
Qed.

Lemma lemma2 : (forall i : U -> bool, induct i -> dn (b2p (i WF))) -> False.
intro x.
apply (p2p1 (I WF) (x (fun u => p2b (I u)) lemma)).
intro H; apply H.
intros i H0.
apply (x (fun y => i (fun v => sb v U le y))).
assert (H1 : dn (induct (fun y : U => i (fun v : V => sb v U le y)))).
assert (H0' : dn (b2p (le i WF))).
  intro H1; apply H1; exact H0.
apply (p2p1 _ H0').
intros y H2 H3.
apply H1.
intro H4.
unfold induct in H4.
unfold dn in H4.
apply (H4 y H2 H3).
Qed.

Theorem Hurkens_set_neg : False.
exact (lemma2 Omega).
Qed.

End Hurkens_set_neg.

Section EM_set_neg_inconsistency.

Variable EM_set_neg : forall A : Prop, {~ A} + {~ ~ A}.

Definition p2b (A : Prop) :=
  if EM_set_neg A then false else true.
Definition b2p (b : bool) := b = true.

Lemma p2p1 : forall A : Prop, ~ ~ b2p (p2b A) -> ~ ~ A.
Proof.
intro A.
unfold p2b in |- *.
destruct (EM_set_neg A) as [_| Ha].
  unfold b2p in |- *; intros H Hna; apply H; discriminate.
  tauto.
Qed.

Lemma p2p2 : forall A : Prop, A -> b2p (p2b A).
Proof.
intro A.
unfold p2b in |- *.
destruct (EM_set_neg A) as [Hna| _].
  intro Ha; elim (Hna Ha).
  intro; unfold b2p in |- *; reflexivity.
Qed.

Theorem not_EM_set_neg : False.
Proof.
apply Hurkens_set_neg with p2b b2p.
apply p2p1.
apply p2p2.
Qed.

End EM_set_neg_inconsistency.

Section EM_set_inconsistency.

Variable EM_set_neg : forall A : Prop, {A} + {~ A}.

Theorem not_EM_set : False.
Proof.
apply not_EM_set_neg.
intro A; apply EM_set_neg.
Qed.

End EM_set_inconsistency.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
Require Import fintype bigops prime binomial finset ssralg.
Require Import groups morphisms normal automorphism commutators zmodp.
Require Import gprod cyclic center pgroups gseries nilpotent sylow abelian.
Require Import maximal matrix mxrepresentation BGsection1.

(******************************************************************************)
(* This file should contain the useful material in B & G, section 2, that is  *)
(* not implicitly covered in mxrepresentation. We start with the three        *)
(* results that constitute B & G, Theorem 2.6: a main theorem, and the two    *)
(* corrolaries that make up the actual formulation of the theorem.            *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Import GroupScope GRing.Theory.
Open Local Scope ring_scope.

Section BGsection2.

Variable gT : finGroupType.
Implicit Type p : nat.

Lemma der1_odd_GL2_charf :
   forall (F : fieldType) (G : {group gT}) (rG : mx_representation F G 2),
 odd #|G| -> mx_repr_faithful rG -> [char F].-group G^`(1).
Proof.
move=> F G; elim: {G}_.+1 {-2}G (ltnSn #|G|) => // m IHm G le_g_m rG oddG ffG.
apply/pgroupP=> p p_pr pG'; rewrite !inE p_pr /=; apply/idPn=> p_nz.
have [P sylP] := Sylow_exists p G.
have nPG: G \subset 'N(P).
  apply/idPn=> pNG; pose N := 'N_G(P); have sNG: N \subset G := subsetIl _ _.
  have{IHm pNG} p'N': [char F].-group N^`(1).
    apply: IHm (subg_repr_faithful sNG ffG); last exact: oddSg oddG.
    rewrite -ltnS (leq_trans _ le_g_m) // ltnS proper_card //.
    by rewrite /proper sNG subsetI subxx.
  have{p'N'} tiPN': P :&: N^`(1) = 1%g.
    rewrite coprime_TIg ?(pnat_coprime (pHall_pgroup sylP)) //= -/N.
    apply: sub_in_pnat p'N' => q _; apply: contraL; move/eqnP->.
    by rewrite !inE p_pr.
  have sPN: P \subset N by rewrite subsetI normG (pHall_sub sylP).
  have{tiPN'} cPN: N \subset 'C(P).
    rewrite (sameP commG1P trivgP) -tiPN' subsetI commgS //.
    by rewrite commg_subr subsetIr.
  case/sdprodP: (Burnside_normal_complement sylP cPN) => _ /=.
  set K := 'O_p^'(G) => defG nKP _.
  have nKG: G \subset 'N(K) by rewrite normal_norm ?pcore_normal.
  suffices p'G': p^'.-group G^`(1) by case/eqnP: (pgroupP p'G' p p_pr pG').
  apply: pgroupS (pcore_pgroup p^' G); rewrite -quotient_cents2 //= -/K.
  by rewrite -defG quotient_mulgr /= -/K quotient_cents ?(subset_trans sPN).
pose Q := G^`(1) :&: P; have sQG: Q \subset G by rewrite subIset ?der_subS.
have nQG: G \subset 'N(Q) by rewrite normsI // normal_norm ?der_normalS.
have pQ: p %| #|Q|.
  have sylQ: p.-Sylow(G^`(1)) Q by apply: pSylow_normalI (der_normalS _ _) _.
  apply: contraLR pG'; rewrite -!p'natE // (card_Hall sylQ) -!partn_eq1 //.
  by rewrite part_pnat_id ?part_pnat.
have{IHm} abelQ: abelian Q.
  apply/commG1P; apply/eqP; apply/idPn => ntQ'.
  have{IHm} p'Q': [char F].-group Q^`(1).
    apply: IHm (subg_repr_faithful sQG ffG); last exact: oddSg oddG.
    rewrite -ltnS (leq_trans _ le_g_m) // ltnS proper_card //.
    rewrite /proper sQG subsetI //= andbC subEproper.
    case: eqP => [-> /= | _]; last by rewrite /proper (pHall_sub sylP) andbF.
    have: nilpotent P by rewrite (pgroup_nil (pHall_pgroup sylP)).
    move/forallP; move/(_ P); apply: contraL; rewrite subsetI subxx => -> /=.
    apply: contra ntQ'; rewrite /Q; move/eqP=> ->.
    by rewrite (setIidPr _) ?sub1G // commG1.
  case/eqP: ntQ';  have{p'Q'}: P :&: Q^`(1) = 1%g.
    rewrite coprime_TIg ?(pnat_coprime (pHall_pgroup sylP)) //= -/Q.
    apply: sub_in_pnat p'Q' => q _; apply: contraL; move/eqnP->.
    by rewrite !inE p_pr.
  by rewrite (setIidPr _) // comm_subG ?subsetIr.
wlog: F p_nz rG ffG / mx_reducible (subg_repr rG sQG).
  move=> IH_F; pose rQ := subg_repr rG sQG.
  have irrQ: mx_irreducible rQ by exact: IH_F ffG.
  case scalQ: (Q \subset [pred x | is_scalar_mx (rG x)]).
    case: irrQ => _; exists (pid_mx 1); rewrite rank_pid_mx ?andbT //.
    apply/submodmxP=> x; move/(subsetP scalQ); case/is_scalar_mxP=> a ->.
    by rewrite scalar_mxC subsetmxMl.
  case/subsetPn: scalQ => x Qx.
  rewrite !inE -mxminpoly_linear_is_scalar -ltnNge => non_scal_rx.
  have cQrx: (centgmx rQ (rG x)).
    by apply/centgmxP=> y Qy; rewrite -!(repr_mxM rQ) // (centsP abelQ).
  have:= MatrixGenField.non_linear_gen_reducible irrQ cQrx non_scal_rx.
  have fRM := MatrixGenField.genRM irrQ cQrx.
  apply: IH_F (map_repr fRM rG) _; last by rewrite map_mx_repr_faithful.
  by rewrite -(ringM_nat fRM) fieldM_eq0.
case=> // U; rewrite ltnS -eqn_leq eq_sym; case/andP=> Umod Uscal.
case/mx_Maeshke: (Umod) => [|V [Vmod sumUV tiUV]].
  have: p.-group Q by apply: pgroupS (pHall_pgroup sylP); rewrite subsetIr.
  by apply: sub_in_pnat=> q _; move/eqnP->; rewrite !inE p_pr.
have [u defU]: exists u : 'rV_2, (u :=: U)%MS.
  by move: (row_base U) (eq_row_base U); rewrite (eqP Uscal) => u; exists u.
have{tiUV Uscal} [v defV]: exists v : 'rV_2, (v :=: V)%MS.
  move/mxrank_disjoint_sum: tiUV; rewrite (eqP Uscal) (eqnP sumUV) => [[Vscal]].
  by move: (row_base V) (eq_row_base V); rewrite -Vscal => v; exists v.
pose B : 'M_(1 + 1) := col_mx u v; have{sumUV} uB: B \in unitmx.
  rewrite -row_full_unit /row_full eqn_leq rank_leq_row {1}addn1.
  by rewrite -sumsmxE -{1}(eqnP sumUV) mxrankS // sumsmxS ?defU ?defV.
pose Qfix (w : 'rV_2) := {in Q, forall y, w *m rG y <= w}%MS.
have{U defU Umod} u_fix: Qfix u.
  by move=> y Qy; rewrite /= (eqmxMr _ defU) defU (submodmxP _ _ Umod).
have{V defV Vmod} v_fix: Qfix v.
  by move=> y Qy; rewrite /= (eqmxMr _ defV) defV (submodmxP _ _ Vmod).
case/Cauchy: pQ => // x Qx oxp; have Gx := subsetP sQG x Qx.
case/subsetmxP: (u_fix x Qx) => a def_ux.
case/subsetmxP: (v_fix x Qx) => b def_vx.
have def_x: rG x = B^-1 *m block_mx a 0 0 b *m B.
  rewrite -mulmxA -[2]/(1 + 1)%N mul_block_col !mul0mx addr0 add0r.
  by rewrite -def_ux -def_vx -mul_col_mx mulKmx.
have ap1: a ^+ p = 1.
  suff: B^-1 *m block_mx (a ^+ p) 0 0 (b ^+ p) *m B = 1.
    move/(canRL (mulmxK uB)); move/(canRL (mulKVmx uB)); rewrite mul1mx.
    by rewrite mulmxV // -[2]/(1 + 1)%N scalar_mx_block; case/eq_block_mx.
  transitivity (rG x ^+ p); last first.
    by rewrite -(repr_mxX (subg_repr rG sQG)) // -oxp expg_order repr_mx1.
  elim: (p) => [|k IHk]; first by rewrite -scalar_mx_block mulmx1 mulVmx.
  rewrite !exprS -IHk def_x -!mulmxE !mulmxA mulmxK // -2!(mulmxA B^-1).
  by rewrite -[2]/(1 + 1)%N mulmx_block !mulmx0 !mul0mx !addr0 mulmxA add0r.
have ab1: a * b = 1.
  have: Q \subset <<[set y \in G | \det (rG y) == 1]>>.
  rewrite subIset // genS //; apply/subsetP=> yz; case/imset2P=> y z Gy Gz ->.
    rewrite inE !repr_mxM ?groupM ?groupV //= !detM (mulrCA _ (\det (rG y))).
    rewrite -!det_mulmx -!repr_mxM ?groupM ?groupV //.
    by rewrite mulKg mulVg repr_mx1 det1.
  rewrite gen_set_id; last first.
  apply/group_setP; split=> [|y z].
      by rewrite inE group1 /= repr_mx1 det1.
    case/setIdP=> Gy y1; case/setIdP=> Gz z1; rewrite inE groupM ?repr_mxM //=.
    by rewrite detM (eqP y1) (eqP z1) mulr1.
  move/subsetP; move/(_ x Qx); case/setIdP=> _.
  rewrite def_x !detM mulrAC -!detM -mulrA mulKr // -!mulmxE.
  rewrite -[2]/(1 + 1)%N det_lblock // [a]mx11_scalar [b]mx11_scalar.
  by rewrite !det_scalar1 -scalar_mxM; move/eqP->.
have{ab1 ap1 def_x} ne_ab: a != b.
  apply/eqP=> defa; have defb: b = 1.
    rewrite -ap1 (divn_eq p 2) modn2.
    have ->: odd p by rewrite -oxp (oddSg _ oddG) // cycle_subG.
    by rewrite addn1 exprS mulnC exprn_mulr exprS {1 3}defa ab1 exp1rn mulr1.
  suff x1: x \in [1] by rewrite -oxp (set1P x1) order1 in p_pr.
  apply: (subsetP ffG); rewrite inE Gx def_x defa defb -scalar_mx_block mulmx1.
  by rewrite mul1mx mulVmx ?eqxx.
have{a b ne_ab def_ux def_vx} nx_uv: forall w : 'rV_2,
  (w *m rG x <= w -> w <= u \/ w <= v)%MS.
- move=> w; case/subsetmxP=> c; have:= mulmxKV uB w.
  rewrite -[_ *m invmx B]hsubmxK [lsubmx _]mx11_scalar [rsubmx _]mx11_scalar.
  move: (_ 0) (_ 0) => dv du; rewrite mul_row_col !mul_scalar_mx => <-{w}.
  rewrite mulmx_addl -!scalemxAl def_ux def_vx mulmx_addr -!scalemxAr.
  rewrite !scalemxAl -!mul_row_col; move/(can_inj (mulmxK uB)).
  case/eq_row_mx => eqac eqbc; apply/orP.
  case: (eqVneq dv 0) => [-> | nz_dv].
    by rewrite scale0mx addr0 subsetmx_scale.
  case: (eqVneq du 0) => [-> | nz_du].
    by rewrite orbC scale0mx add0r subsetmx_scale.
  case/eqP: ne_ab; rewrite -[b]scale1mx -(mulVf nz_dv) -[a]scale1mx.
  by rewrite -(mulVf nz_du) -!scalemxA eqac eqbc !scalemxA !mulVf.
have{x Gx Qx oxp nx_uv} redG: forall y (A := rG y),
  y \in G -> (u *m A <= u /\ v *m A <= v)%MS.
- move=> y A Gy; have uA: row_free A by rewrite row_free_unit repr_mx_unit.
  have Ainj: forall w t : 'rV_2, (w *m A <= w -> t *m A <= w -> t *m A <= t)%MS.
    move=> w t; case/sub_rVP=> c ryww; case/sub_rVP=> d rytw.
    rewrite -(subsetmxMfree _ _ uA) rytw -scalemxAl ryww scalemxA mulrC.
    by rewrite -scalemxA subsetmx_scale.
  have{Qx nx_uv} nAx: forall w, Qfix w -> (w *m A <= u \/ w *m A <= v)%MS.
    move=> w nwQ; apply: nx_uv; rewrite -mulmxA -repr_mxM // conjgCV.
    rewrite repr_mxM ?groupJ ?groupV // mulmxA subsetmxMr // nwQ // -mem_conjg.
    by rewrite (normsP nQG).
  have [uAu | uAv] := nAx _ u_fix; have [vAu | vAv] := nAx _ v_fix; eauto.
  have [k ->]: exists k, A = A ^+ k.*2.
    exists #[y].+1./2; rewrite -mul2n -divn2 mulnC divnK.
      by rewrite -repr_mxX // expgS expg_order mulg1.
    by rewrite dvdn2 negbK; apply: oddSg oddG; rewrite cycle_subG.
  elim: k => [|k [IHu IHv]]; first by rewrite !mulmx1.
  case/sub_rVP: uAv => c uAc; case/sub_rVP: vAu => d vAd.
  rewrite doubleS !exprS !mulmxA; do 2!rewrite uAc vAd -!scalemxAl.
  by rewrite !subsetmx_scale.
suff trivG': G^`(1) = 1%g by rewrite /= trivG' cards1 gtnNdvd ?prime_gt1 in pG'.
apply/trivgP; apply: subset_trans ffG; rewrite gen_subG.
apply/subsetP=> yz; case/imset2P=> y z Gy Gz ->{yz}; rewrite inE groupR //=.
rewrite -(inj_eq (can_inj (mulKmx (repr_mx_unit rG (groupM Gz Gy))))).
rewrite mul1mx mulmx1 -repr_mxM ?(groupR, groupM) // -commgC !repr_mxM //.
rewrite -(inj_eq (can_inj (mulKmx uB))) !mulmxA !mul_col_mx.
case/redG: Gy; case/sub_rVP=> a uya; case/sub_rVP=> b vyb.
case/redG: Gz; case/sub_rVP=> c uzc; case/sub_rVP=> d vzd.
by do 2!rewrite uya vyb uzc vzd -?scalemxAl; rewrite !scalemxA mulrC (mulrC d).
Qed.

(* This is B & G, Theorem 2.6 (a) *)
Theorem charf'_GL2_abelian :
    forall (F : fieldType) (G : {group gT}) (rG : mx_representation F G 2),
  odd #|G| -> mx_repr_faithful rG -> [char F]^'.-group G -> abelian G.
Proof.
move=> F G rG oddG ffG char'G; apply/commG1P; apply/eqP.
rewrite trivg_card1 (pnat_1 _ (pgroupS _ char'G)) ?comm_subG //=.
exact: der1_odd_GL2_charf ffG.
Qed.

(* This is B & G, Theorem 2.6 (b) *)
Theorem charf_GL2_der_subS_abelian_Sylow :
    forall p (F : fieldType) (G : {group gT}) (rG : mx_representation F G 2),
    odd #|G| -> mx_repr_faithful rG -> p \in [char F] ->
  exists P : {group gT}, [/\ p.-Sylow(G) P, abelian P & G^`(1) \subset P].
Proof.
move=> p F G rG oddG ffG charFp.
have{oddG} pG': p.-group G^`(1).
  rewrite /pgroup -(eq_pnat _ (charf_eq charFp)).
  exact: der1_odd_GL2_charf ffG.
have{pG'} [P SylP sG'P]:= Sylow_superset (der_sub _ _) pG'.
exists P; split=> {sG'P}//; case/and3P: SylP => sPG pP _.
apply/commG1P; apply/trivgP; apply: subset_trans ffG; rewrite gen_subG.
apply/subsetP=> yz; case/imset2P=> y z Py Pz ->{yz}.
rewrite inE (subsetP sPG) ?groupR //=.
pose rP := subg_repr rG sPG; pose U := rfix_mx rP.
rewrite -(inj_eq (can_inj (mulKmx (repr_mx_unit rP (groupM Pz Py))))).
rewrite mul1mx mulmx1 -repr_mxM ?(groupR, groupM) // -commgC !repr_mxM //.
have{pP} pP: [char F].-group P by rewrite /pgroup (eq_pnat _ (charf_eq charFp)).
have: U != 0 by exact: rfix_pgroup_char.
rewrite -mxrank_eq0 -lt0n 2!leq_eqVlt ltnNge rank_leq_row orbF orbC eq_sym.
case/orP=> [Ufull | Uscal].
  suff{y z Py Pz} rP1: forall y, y \in P -> rP y = 1%:M by rewrite !rP1 ?mulmx1.
  move=> y Py; apply/row_matrixP=> i.
  by rewrite rowE -row1 (subsetmx_rfixP _ _ _) ?subsetmx_full.
have [u defU]: exists u : 'rV_2, (u :=: U)%MS.
  by move: (row_base U) (eq_row_base U); rewrite -(eqP Uscal) => u; exists u.
have fix_u: {in P, forall x, u *m rP x = u}.
  by move/eqmxP: defU; case/andP; move/subsetmx_rfixP.
have [v defUc]: exists u : 'rV_2, (u :=: U^C)%MS.
  have UCscal: \rank U^C = 1%N by rewrite mxrank_compl -(eqP Uscal).
  by move: (row_base _)%MS (eq_row_base U^C)%MS; rewrite UCscal => v; exists v.
pose B := col_mx u v; have uB: B \in unitmx.
  rewrite -row_full_unit -subset1mx -(eqmxMfull _ (sumsmx_compl_full U)).
  by rewrite mulmx1 -sumsmxE sumsmxS ?defU ?defUc.
have Umod: submodmx rP U by exact: rfix_submodmx.
pose W := rfix_mx (factmod_repr Umod).
have ntW: W != 0.
  apply: rfix_pgroup_char pP;
  rewrite eqmxMfull ?row_full_unit ?unitmx_inv ?row_ebase_unit //.
  by rewrite rank_copid_mx -(eqP Uscal).
have{ntW} Wfull: row_full W.
  by rewrite -col_leq_rank {1}mxrank_coker -(eqP Uscal) lt0n mxrank_eq0.
have svW: (in_factmod U v <= W)%MS by rewrite subsetmx_full.
have fix_v: {in P, forall x, v *m rG x - v <= u}%MS.
  move=> x Px /=; rewrite -[v *m _](sum_sub_fact_mod U) (in_factmodJ Umod) //.
  move/subsetmx_rfixP: svW => -> //; rewrite in_factmodK ?defUc // addrK.
  by rewrite defU val_submodP.
have fixB: {in P, forall x, exists2 a, u *m rG x = u & v *m rG x = v + a *m: u}.
  move=> x Px; case/subsetmxP: (fix_v x Px) => a def_vx.
  exists (a 0 0); first exact: fix_u.
  by rewrite addrC -mul_scalar_mx -mx11_scalar -def_vx subrK.
rewrite -(inj_eq (can_inj (mulKmx uB))) // !mulmxA !mul_col_mx.
case/fixB: Py => a uy vy; case/fixB: Pz => b uz vz.
by rewrite uy uz vy vz !mulmx_addl -!scalemxAl uy uz vy vz addrAC.
Qed.

End BGsection2.


(* =================================================================================== *)
(** * Σ-modules

    Content:
    - Definition of a signature (aka Σ-module) over the category of another signature Σ [signature_over]
    - Definition of the category Sig-modules (signature_over_category]
    - The action of 1-models yield signature over morphism [action_sig_over_mor]
    - Functor between 1-signatures and Σ-modules [sig_to_sig_over_functor]
    - starting from a 1-signature morphism f : S1 -> S2, a signature over S1 can be pushed out to
      a signature over S2. This actually induces a functor f* (and thus an opfibration)

TODO : factor this definition and the standard definition of signatures ?
(a lot of stuff was indeed copied and pasted from Signature.v)
*)
(* =================================================================================== *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.EpiFacts.

Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.

Require Import Modules.Prelims.lib.
Require Import Modules.Prelims.LModulesFibration.

Require Import Modules.Signatures.Signature.
Require Import Modules.Signatures.ModelCat.

Set Automatic Introduction.
Delimit Scope signature_over_scope with sigo.

Section OverSignatures.

(** We work in an arbitrary category [C] *)
Context {C : category}.

Local Notation MONAD := (Monad C).
Local Notation PRE_MONAD := (category_Monad C).
(* Local Notation BMOD := (bmod_disp C C). *)
Local Notation SIG := (signature C).

(** The 1-signature [Sig] is fixed in the following.
We will then consider Sig-modules in the following
 *)
Context (Sig : SIG).
Local Notation REP := (model Sig).
Local Notation REP_CAT := (rep_fiber_category Sig).

(** Notation for 1-model morphisms *)
Local Notation  "R →→ S" := (rep_fiber_mor  R S) (at level 6).

(** Notation for composition of 1-model morphisms *)
Let comp {R S T : REP} (f : R →→ S)(g : S →→ T) : R →→ T :=
  compose (C := REP_CAT) f g.

Local Infix  ";;" := comp.

(** Raw data for a [Sig]-module:
- each 1-model is assigned a module over itself
- 1-model morphisms are mapped to module morphisms *)
Definition signature_over_data :=
  ∑ F : (∏ R : REP, LModule R C),
        ∏ (R S : REP) (f : R →→ S),
          LModule_Mor _ (F R) (pb_LModule f (F S)).

Definition signature_over_on_objects (a : signature_over_data) : ∏ (R : REP), LModule R C
  := pr1 a.

Coercion signature_over_on_objects : signature_over_data >-> Funclass.

Definition signature_over_on_morphisms  (F : signature_over_data) {R S : REP}
  : ∏ (f:  R →→ S), LModule_Mor _ (F R) (pb_LModule f (F S))
  := pr2 F R S.

(** Notation for the map 1-model morphism -> module morphism *)
Notation "# F" := (signature_over_on_morphisms F) (at level 3) : signature_over_scope.

Definition signature_over_on_morphisms_cancel_pw (F : signature_over_data) {R S : REP}
           {u v : R →→ S}  (e : u = v) x : (# F u)%sigo x = (#F v)%sigo x.
  induction e.
  apply idpath.
Defined.

(** Statment that the raw data preserves identity *)
Definition signature_over_idax  (F : signature_over_data) :=
  ∏ (R : REP), ∏ x ,
  (# F (identity (C := REP_CAT) R))%sigo x = identity  _.

(** Statment that the raw data preserves composition *)
Definition signature_over_compax  (F : signature_over_data) :=
  ∏ R S T  (f : R →→ S) (g : S →→ T) ,
    (#F  (f ;; g))%sigo
      =
      (((# F f)%sigo :(F R : bmod_disp C C (R : Monad _)) -->[(f : Monad_Mor  _ _)] F S) ;; (#F g)%sigo)%mor_disp.

(** Raw data yields a Sig-module if it satisfies the previous functoriality conditions *)
Definition is_signature_over  (F : signature_over_data) : UU := signature_over_idax F × signature_over_compax F.

(** This statment is hProp *)
Lemma isaprop_is_signature_over (F : signature_over_data) : isaprop (is_signature_over F).
Proof.
  apply isofhleveldirprod.
  - repeat (apply impred; intro).
    apply homset_property.
  - repeat (apply impred; intro).
    apply (homset_property (category_LModule _ _)).
Qed.

(** A Sig-module sends functorially 1-model morphisms onto module morphisms *)
Definition signature_over : UU := ∑ F : signature_over_data, is_signature_over F.

Definition signature_over_data_from_signature_over (F : signature_over) : signature_over_data := pr1 F.
Coercion signature_over_data_from_signature_over : signature_over >-> signature_over_data.

(** Any 1-signature [sig] induces a Sig-module (indeed, this can be proven on paper using the
    forgetful functor 1-model -> monads) *)
Definition sig_over_data_from_sig (sig : signature C) : signature_over_data.
  use tpair.
  use (signature_on_objects sig).
  exact (fun R S f =>  signature_on_morphisms sig f).
Defined.

Local Notation OSig := sig_over_data_from_sig.

(** Functoriality conditions for a Sig-module induced by a signatre *)
Lemma is_sig_over_from_sig (sig : signature C) : is_signature_over (OSig sig).
  split.
  - use signature_id.
  - red.
    intros; use signature_comp.
Defined.

(** Sig-module from a 1-signature *)
Coercion sig_over_from_sig (sig : signature C) : signature_over :=
  (sig_over_data_from_sig sig ,, is_sig_over_from_sig sig).

(** The tautological Sig-module mapping a 1-model to the underlying monad *)
Definition tautological_signature_over : signature_over :=
  sig_over_from_sig tautological_signature.

(** A Sig-module preserves identity *)
Definition signature_over_id (F : signature_over) :
  ∏ (R : REP), ∏ x ,
  ((# F (identity (C:= REP_CAT) R)))%sigo x  = identity  _
  := pr1 (pr2 F).

(** A Sig-module preserves composition *)
Definition signature_over_comp (F : signature_over) {R S T : REP}
           (f : rep_fiber_mor R S) (g : rep_fiber_mor S T)
  :
    (#F  (f ;; g))%sigo
      =
      (((# F f)%sigo :(F R : bmod_disp C C (R : Monad _)) -->[(f : Monad_Mor  _ _)] F S) ;; (#F g)%sigo)%mor_disp
  := pr2 (pr2 F) _ _ _ _ _ .

(**

This last piece is about morphisms and category of over-signatures

*)

(** A Sig-module morphism between two Sig-modules [F] and [F'] is
    a natural family of module morphisms t = (F(R) -> F'(R))_R:
    for any 1-model morphism f : R -> S,
<<<
          F(f)
   F(R) ---------> F(S)
    |               |
    |               |
t_R |               | t_S
    |               |
    V               V
   F'(R)---------> F'(S)
            F'(f)
>>>
*)
Definition is_signature_over_Mor (F F' : signature_over_data)
           (t : ∏ R : REP, LModule_Mor R (F R)  (F' R))
  :=
    ∏ (R S : REP)(f : rep_fiber_mor R S),
    (((# F)%sigo f :   nat_trans _ _) : [_,_]⟦_,_⟧) ·
                                                  (t S : nat_trans _ _)
    =
    ((t R : nat_trans _ _) : [_,_]⟦_,_⟧) · ((#F')%sigo f : nat_trans _ _).

(** This last statment is hProp *)
Lemma isaprop_is_signature_over_Mor (F F' : signature_over_data) t :
  isaprop (is_signature_over_Mor F F' t).
Proof.
  repeat (apply impred; intro).
  apply homset_property.
Qed.

(** A Sig-module morphism is a naturaly family of module morphisms *)
Definition signature_over_Mor  (F F' : signature_over_data) : UU := ∑ X, is_signature_over_Mor F F' X.

Definition mkSignature_over_Mor {F F' : signature_over_data} X
           (hX : is_signature_over_Mor F F' X) : signature_over_Mor F F' :=
  X ,, hX.

(** Notation for Sig-module morphisms *)
Local Notation "F ⟹ G" := (signature_over_Mor F G) (at level 39) : signature_over_scope.

(** Homsets are hSet *)
Lemma isaset_signature_over_Mor (F F' : signature_over) : isaset (F ⟹ F')%sigo.
Proof.
  apply (isofhleveltotal2 2).
  + apply impred ; intro t; apply (homset_property (category_LModule _ _)).
  + intro x; apply isasetaprop, isaprop_is_signature_over_Mor.
Qed.

Definition signature_over_Mor_data
 {F F' : signature_over_data}(a : signature_over_Mor F F') := pr1 a.
Coercion signature_over_Mor_data : signature_over_Mor >-> Funclass.

(** A Sig-module morphism is natural *)
Definition signature_over_Mor_ax {F F' : signature_over} (a : (F ⟹ F')%sigo)
  : ∏ {R S : REP}(f : rep_fiber_mor R S),
    (((# F)%sigo f :   nat_trans _ _) : [_,_]⟦_,_⟧) ·
                                                  (a S : nat_trans _ _)
    =
    ((a R : nat_trans _ _) : [_,_]⟦_,_⟧) · ((#F')%sigo f : nat_trans _ _)
  := pr2 a.

(** A Sig-module morphism is natural (pointwise version of the naturality diagram) *)
Lemma signature_over_Mor_ax_pw {F F' : signature_over} (a : (F ⟹ F')%sigo)
  : ∏ {R S : REP}(f : rep_fiber_mor R S) x,
    (((# F)%sigo f :   nat_trans _ _) x) ·
                                       ((a S : nat_trans _ _) x)
    =
    ((a R : nat_trans _ _)  x) · (((#F')%sigo f : nat_trans _ _) x).
Proof.
  intros.
  assert (h := signature_over_Mor_ax a f).
  eapply nat_trans_eq_pointwise in h.
  apply h.
Qed.

(** Sig-module morphisms are equal if for any 1-model R, their R-component module morphism
  are equal *)
Lemma signature_over_Mor_eq (F F' : signature_over)(a a' : signature_over_Mor F F'):
  (∏ R, a R = a' R) -> a = a'.
Proof.
  intro H.
  assert (H' : pr1 a = pr1 a').
  { apply funextsec. intro; apply H. }
  apply (total2_paths_f H'), proofirrelevance, isaprop_is_signature_over_Mor.
Qed.

(** Intermediate data to build the category of Sig-modules *)
Definition signature_over_precategory_ob_mor  : precategory_ob_mor := make_precategory_ob_mor
   signature_over (fun F F' => signature_over_Mor F F').

(** The identity family of module morphisms yields a Sig-module morphism *)
Lemma is_signature_over_Mor_id (F : signature_over_data) : is_signature_over_Mor F F
     (fun R => identity (C:=category_LModule _ _) _).
Proof.
  intros ? ? ? .
  rewrite id_left, id_right.
  apply idpath.
Qed.

(** The identity Sig-module morphism *)
Definition signature_over_Mor_id (F : signature_over_data) : signature_over_Mor F F :=
    tpair _ _ (is_signature_over_Mor_id F).

(** Composition of two Sig-module morphisms yields a Sig-module morphism *)
Lemma is_signature_over_Mor_comp {F G H : signature_over} (a : signature_over_Mor F G) (b : signature_over_Mor G H)
  : is_signature_over_Mor F H (fun R  => (a R : category_LModule _ _ ⟦_,_⟧ ) · b R).
Proof.
  intros ? ? ?.
  etrans.
  apply (assoc (C:= [_,_])).
  etrans.
  apply ( cancel_postcomposition (C:= [_,_])).
  apply (signature_over_Mor_ax (F:=F) (F':=G) a f).
  rewrite <- (assoc (C:=[_,_])).
  etrans.
  apply (cancel_precomposition ([_,_])).
  apply signature_over_Mor_ax.
  rewrite assoc.
  apply idpath.
Qed.
(** Composition of Sig-module morphisms *)
Definition signature_over_Mor_comp {F G H : signature_over} (a : signature_over_Mor F G) (b : signature_over_Mor G H)
  : signature_over_Mor F H
  := tpair _ _ (is_signature_over_Mor_comp a b).

(** Intermediate data to build the category of Sig-modules *)
Definition signature_over_precategory_data : precategory_data.
Proof.
  apply (make_precategory_data (signature_over_precategory_ob_mor )).
  + intro a; simpl.
    apply (signature_over_Mor_id (pr1 a)).
  + intros a b c f g.
    apply (signature_over_Mor_comp f g).
Defined.

(** Axioms of categories:
 - identity is a neutral element for composition
 - composition is associative *)
Lemma is_precategory_signature_over_precategory_data :
   is_precategory signature_over_precategory_data.
Proof.
  apply make_is_precategory_one_assoc; simpl; intros.
  - unfold identity.
    simpl.
    apply signature_over_Mor_eq.
    intro x; simpl.
    apply (id_left (C:=category_LModule _ _)).
  - apply signature_over_Mor_eq.
    intro x; simpl.
    apply (id_right (C:=category_LModule _ _)).
  - apply signature_over_Mor_eq.
    intro x; simpl.
    apply (assoc (C:=category_LModule _ _)).
Qed.

(** The precategory of Sig-modules *)
Definition signature_over_precategory : precategory :=
  tpair (fun C => is_precategory C)
        (signature_over_precategory_data)
        (is_precategory_signature_over_precategory_data).

(** Homsets are hSet *)
Lemma signature_over_category_has_homsets : has_homsets signature_over_precategory.
Proof.
  intros F G.
  apply isaset_signature_over_Mor.
Qed.

(** Hence, we get the category of Sig-modules *)
Definition signature_over_category : category.
Proof.
  exists (signature_over_precategory).
  apply signature_over_category_has_homsets.
Defined.

Local Notation ι := sig_over_from_sig.
Local Notation  "S1 →→s S2" := (signature_over_Mor S1 S2) (at level 23).

(** The action of 1-models yield  signature over morphism *)
Definition action_sig_over_mor : ι Sig  →→s tautological_signature_over.
  use mkSignature_over_Mor.
  - use model_τ.
  - cbn.
    intros R S f.
    apply pathsinv0.
    apply (nat_trans_eq (homset_property _)).
    use (rep_fiber_mor_ax f).
Defined.

(** A 1-sig morphism yields a 2-sig morphism *)
Definition sig_sig_over_mor {S1 S2 : SIG} (f : signature_Mor S1 S2) : ι S1  →→s ι S2 :=
  @mkSignature_over_Mor (ι S1) (ι S2) (λ R : REP, f R)
                        (λ (R S : REP) (g : R →→ S), signature_Mor_ax f g).

Lemma sig_to_sig_over_is_functor :
  is_functor (make_functor_data (C := signature_category (C := C))(C' := signature_over_category)
                              ι (@sig_sig_over_mor)).
Proof.
  split.
  - intro S.
    use signature_over_Mor_eq.
    intro ; apply idpath.
  - intros S1 S2 S3 f1 f2.
    use signature_over_Mor_eq.
    intro ; apply idpath.
Qed.

Definition sig_to_sig_over_functor : functor (signature_category (C := C)) signature_over_category :=
  make_functor _ sig_to_sig_over_is_functor.

End OverSignatures.

Notation "# F" := (signature_over_on_morphisms _ F) (at level 3) : signature_over_scope.

Section PushoutOverSig.

  Definition po_signature_over_data
             {C} {S1 S2 : signature C} (f : signature_Mor S1 S2) (SS1 : signature_over S1)
  : signature_over_data S2.
  Proof.
    use tpair.
    - intro R.
      exact (SS1 (pb_rep f R)).
    - intros R S g.
      apply ((# SS1 (pb_rep_mor f g ))%sigo).
  Defined.

  Lemma  po_is_signature_over
        {C} {S1 S2 : signature C} (f : signature_Mor S1 S2) (SS1 : signature_over S1)
  : is_signature_over _ (po_signature_over_data f SS1).
  Proof.
    split.
    - intros R x.
      cbn.
      etrans;[|use signature_over_id ].
      apply (signature_over_on_morphisms_cancel_pw _ SS1).
      apply pb_rep_mor_id.
    - intros R S T u v.
      cbn -[compose].
      apply LModule_Mor_equiv; [apply homset_property|].
      apply nat_trans_eq;[apply homset_property|].
      intro x.
      etrans. {
        eapply (signature_over_on_morphisms_cancel_pw _ SS1).
        apply pb_rep_mor_comp.
      }
      rewrite signature_over_comp.
      apply idpath.
  Defined.

  Definition  po_signature_over
         {C} {S1 S2 : signature C} (f : signature_Mor S1 S2) (SS1 : signature_over S1) :
    signature_over S2 := _ ,, po_is_signature_over f SS1.

  Definition  po_signature_over_mor
              {C} {S1 S2 : signature C} (f : signature_Mor S1 S2) {SS1 SS1' : signature_over S1}
              (ff1 : signature_over_Mor _ SS1 SS1')
    :  signature_over_Mor _
                             (po_signature_over f SS1)(po_signature_over f SS1')
     :=
     mkSignature_over_Mor _ (F := po_signature_over f SS1)
                                 (F' := po_signature_over f SS1')
                                 (fun R => ff1 (pb_rep f R))
                                 (fun R S g =>  signature_over_Mor_ax _ ff1 _ ) .

End PushoutOverSig.


Require Import RelationClasses.
Require Import Bool.
Require Import List.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.

Require Import Event.
From PromisingLib Require Import DenseOrder.
Require Import Time.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Thread.
Require Import Configuration.

Set Implicit Arguments.

Inductive covered (loc:Loc.t) (ts:Time.t) (mem:Memory.t): Prop :=
| covered_intro
    from to msg
    (GET: Memory.get loc to mem = Some (from, msg))
    (ITV: Interval.mem (from, to) ts)
.

Inductive sim_memory (mem_src mem_tgt:Memory.t): Prop :=
| sim_memory_intro
    (COVER: forall loc ts, covered loc ts mem_src <-> covered loc ts mem_tgt)
    (MSG: forall loc from_tgt to val released_tgt
            (GET: Memory.get loc to mem_tgt = Some (from_tgt, Message.mk val released_tgt)),
        exists from_src released_src,
          <<GET: Memory.get loc to mem_src = Some (from_src, Message.mk val released_src)>> /\
          <<RELEASED: View.opt_le released_src released_tgt>>)
.

Program Instance sim_memory_PreOrder: PreOrder sim_memory.
Next Obligation.
  econs; try refl. i. esplits; eauto. refl.
Qed.
Next Obligation.
  ii. inv H. inv H0. econs; try etrans; eauto. i.
  exploit MSG0; eauto. i. des.
  exploit MSG; eauto. i. des.
  esplits; eauto. etrans; eauto.
Qed.

Lemma sim_memory_get
      loc from_tgt to val released_tgt mem_src mem_tgt
      (SIM: sim_memory mem_src mem_tgt)
      (GET: Memory.get loc to mem_tgt = Some (from_tgt, Message.mk val released_tgt)):
  exists from_src released_src,
    <<GET: Memory.get loc to mem_src = Some (from_src, Message.mk val released_src)>> /\
    <<RELEASED: View.opt_le released_src released_tgt>>.
Proof.
  eapply SIM. eauto.
Qed.

Lemma sim_memory_max_timemap
      mem_src mem_tgt
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (SIM: sim_memory mem_src mem_tgt):
  TimeMap.le (Memory.max_timemap mem_src) (Memory.max_timemap mem_tgt).
Proof.
  apply Memory.max_timemap_spec'; try by apply CLOSED_TGT; auto. i.
  destruct (Time.le_lt_dec (Memory.max_timemap mem_src loc) Time.bot).
  { esplits; eauto. apply CLOSED_TGT. }
  exploit Memory.max_timemap_closed; try apply CLOSED_SRC; eauto.
  instantiate (1 := loc). i. des.
  inv SIM. destruct (COVER loc (Memory.max_timemap mem_src loc)) as [C1 C2].
  exploit C1; eauto.
  { econs; eauto. apply Interval.mem_ub.
    destruct (mem_src loc).(Cell.WF). exploit VOLUME; eauto. i. des; auto.
    inv x. rewrite H1 in *. inv l.
  }
  i. inv x. inv ITV. destruct msg. ss.
  esplits; eauto.
Qed.

Lemma sim_memory_max_view
      mem_src mem_tgt
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (SIM: sim_memory mem_src mem_tgt):
  View.le (Memory.max_view mem_src) (Memory.max_view mem_tgt).
Proof.
  econs; apply sim_memory_max_timemap; auto.
Qed.

Lemma sim_memory_max_released
      mem_src mem_tgt loc ts
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (SIM: sim_memory mem_src mem_tgt):
  View.le (Memory.max_released mem_src loc ts) (Memory.max_released mem_tgt loc ts).
Proof.
  unfold Memory.max_released. econs; s.
  - ii. unfold TimeMap.add. condtac; [refl|].
    eapply sim_memory_max_timemap; eauto.
  - ii. unfold TimeMap.add. condtac; [refl|].
    eapply sim_memory_max_timemap; eauto.
Qed.

Lemma covered_disjoint
      mem1 mem2 loc from to
      (COVER: forall loc ts, covered loc ts mem1 -> covered loc ts mem2)
      (DISJOINT: forall to2 from2 msg2
                   (GET2: Memory.get loc to2 mem2 = Some (from2, msg2)),
          Interval.disjoint (from, to) (from2, to2)):
  forall to2 from2 msg2
    (GET2: Memory.get loc to2 mem1 = Some (from2, msg2)),
    Interval.disjoint (from, to) (from2, to2).
Proof.
  ii. exploit COVER; eauto.
  { econs; eauto. }
  i. inv x0. eapply DISJOINT; eauto.
Qed.

Lemma get_disjoint_covered_disjoint
      mem loc from to:
  (forall t f m, Memory.get loc t mem = Some (f, m) -> Interval.disjoint (from, to) (f, t)) ->
  (forall ts, covered loc ts mem -> ~ Interval.mem (from, to) ts).
Proof.
  ii. inv H0. eapply H; eauto.
Qed.

Lemma covered_disjoint_get_disjoint
      mem loc from to:
  (forall ts, covered loc ts mem -> ~ Interval.mem (from, to) ts) ->
  (forall t f m, Memory.get loc t mem = Some (f, m) -> Interval.disjoint (from, to) (f, t)).
Proof.
  ii. eapply H; eauto. econs; eauto.
Qed.

Lemma add_covered
      mem2 mem1 loc from to val released
      l t
      (ADD: Memory.add mem1 loc from to val released mem2):
  covered l t mem2 <->
  covered l t mem1 \/ (l = loc /\ Interval.mem (from, to) t).
Proof.
  econs; i.
  - inv H. revert GET. erewrite Memory.add_o; eauto. condtac; ss.
    + des. subst. i. inv GET. auto.
    + left. econs; eauto.
  - des.
    + inv H. econs; eauto.
      erewrite Memory.add_o; eauto. condtac; ss; eauto.
      des. subst. erewrite Memory.add_get0 in GET; eauto. congr.
    + subst. econs; eauto. erewrite Memory.add_o; eauto. condtac; ss.
      des; congr.
Qed.

Lemma split_covered
      mem2 mem1 loc ts1 ts2 ts3 val2 val3 released2 released3
      l t
      (SPLIT: Memory.split mem1 loc ts1 ts2 ts3 val2 val3 released2 released3 mem2):
  covered l t mem2 <-> covered l t mem1.
Proof.
  econs; i.
  - exploit Memory.split_get0; eauto. i. des.
    inv H. revert GET. erewrite Memory.split_o; eauto. repeat condtac; ss.
    + des. subst. i. inv GET. econs; eauto.
      eapply Interval.le_mem; eauto. econs; [refl|].
      inv SPLIT. inv SPLIT0. left. auto.
    + guardH o. des. subst. i. inv GET. econs; eauto.
      eapply Interval.le_mem; eauto. econs; [|refl].
      inv SPLIT. inv SPLIT0. left. auto.
    + i. econs; eauto.
  - exploit Memory.split_get0; eauto. i. des.
    inv H.
    destruct (loc_ts_eq_dec (l, to) (loc, ts3)); ss.
    + des. subst. rewrite GET3 in GET. inv GET.
      destruct (Time.le_lt_dec t ts2).
      * econs.
        { instantiate (2 := from). instantiate (2 := ts2).
          erewrite Memory.split_o; eauto. condtac; ss.
          des; congr.
        }
        { inv ITV. econs; ss. }
      * econs.
        { instantiate (2 := ts2). instantiate (2 := ts3).
          erewrite Memory.split_o; eauto. repeat condtac; ss.
          - des. subst. inv SPLIT. inv SPLIT0.
            exfalso. eapply Time.lt_strorder. eauto.
          - guardH o. des; congr.
        }
        { inv ITV. econs; ss. }
    + econs; eauto. erewrite Memory.split_o; eauto.
      repeat condtac; ss; eauto.
      * guardH o. des. subst. congr.
      * guardH o. guardH o0. des. subst.
        unguardH o. des; congr.
Qed.

Lemma lower_covered
      mem2 mem1 loc from to val released1 released2
      l t
      (LOWER: Memory.lower mem1 loc from to val released1 released2 mem2):
  covered l t mem2 <-> covered l t mem1.
Proof.
  econs; i.
  - inv H. revert GET. erewrite Memory.lower_o; eauto. condtac; ss.
    + des. subst. i. inv GET. econs; eauto.
      eapply Memory.lower_get0; eauto.
    + i. econs; eauto.
  - exploit Memory.lower_get0; eauto. i.
    inv H.
    destruct (loc_ts_eq_dec (l, to0) (loc, to)); ss.
    + des. subst. econs; eauto.
      erewrite Memory.lower_o; eauto. condtac.
      * rewrite GET in x0. inv x0. eauto.
      * ss. des; congr.
    + econs; eauto.
      erewrite Memory.lower_o; eauto. rewrite GET. condtac; ss.
      des; congr.
Qed.

Lemma sim_memory_add
      mem1_src mem1_tgt released_src
      mem2_src mem2_tgt released_tgt
      loc from to val
      (REL_LE: View.opt_le released_src released_tgt)
      (SRC: Memory.add mem1_src loc from to val released_src mem2_src)
      (TGT: Memory.add mem1_tgt loc from to val released_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  inv SIM. econs.
  - i. rewrite add_covered; [|eauto]. rewrite (@add_covered mem2_tgt); [|eauto].
    econs; i; des; (try by right).
    + left. eapply COVER. eauto.
    + left. eapply COVER. eauto.
  - i. revert GET. erewrite Memory.add_o; eauto. condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.add_o; eauto. condtac; ss.
    + erewrite (@Memory.add_o mem2_src); eauto. condtac; ss. eauto.
Qed.

Lemma sim_memory_split
      mem1_src mem1_tgt
      mem2_src mem2_tgt
      loc ts1 ts2 ts3 val2 val3 released2_src released3_src released2_tgt released3_tgt
      (REL_LE: View.opt_le released2_src released2_tgt)
      (SRC: Memory.split mem1_src loc ts1 ts2 ts3 val2 val3 released2_src released3_src mem2_src)
      (TGT: Memory.split mem1_tgt loc ts1 ts2 ts3 val2 val3 released2_tgt released3_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  inv SIM. econs.
  - i. rewrite split_covered; [|eauto]. rewrite (@split_covered mem2_tgt); [|eauto].
    apply COVER.
  - i. revert GET. erewrite Memory.split_o; eauto. repeat condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.split_o; eauto. condtac; ss.
    + erewrite (@Memory.split_o mem2_src); eauto. repeat condtac; ss.
      i. inv GET. guardH o. guardH o0. des. subst.
      exploit Memory.split_get0; try exact SRC; eauto. i. des.
      exploit Memory.split_get0; try exact TGT; eauto. i. des.
      exploit MSG; eauto. i. des. rewrite GET3 in GET. inv GET.
      esplits; eauto.
    + erewrite (@Memory.split_o mem2_src); eauto. repeat condtac; ss. eauto.
Qed.

Lemma sim_memory_lower
      mem1_src mem1_tgt
      mem2_src mem2_tgt
      loc from to val released1_src released1_tgt released2_src released2_tgt
      (REL_LE: View.opt_le released2_src released2_tgt)
      (SRC: Memory.lower mem1_src loc from to val released1_src released2_src mem2_src)
      (TGT: Memory.lower mem1_tgt loc from to val released1_tgt released2_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  inv SIM. econs.
  - i. rewrite lower_covered; [|eauto]. rewrite (@lower_covered mem2_tgt); [|eauto].
    apply COVER.
  - i. revert GET. erewrite Memory.lower_o; eauto. condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.lower_o; eauto. condtac; ss.
    + erewrite (@Memory.lower_o mem2_src); eauto. condtac; ss. eauto.
Qed.

Lemma sim_memory_promise
      loc from to val kind
      promises1_src mem1_src released_src promises2_src mem2_src
      promises1_tgt mem1_tgt released_tgt promises2_tgt mem2_tgt
      (REL_LE: View.opt_le released_src released_tgt)
      (PROMISE_SRC: Memory.promise promises1_src mem1_src loc from to val released_src promises2_src mem2_src kind)
      (PROMISE_TGT: Memory.promise promises1_tgt mem1_tgt loc from to val released_tgt promises2_tgt mem2_tgt kind)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  inv PROMISE_SRC; inv PROMISE_TGT.
  - eapply sim_memory_add; eauto.
  - eapply sim_memory_split; eauto.
  - eapply sim_memory_lower; eauto.
Qed.

Lemma sim_memory_closed_timemap
      mem_src mem_tgt
      tm
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_timemap tm mem_tgt):
  Memory.closed_timemap tm mem_src.
Proof.
  ii. exploit TGT; eauto. i. des.
  exploit sim_memory_get; eauto. i. des. eauto.
Qed.

Lemma sim_memory_closed_view
      mem_src mem_tgt
      view
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_view view mem_tgt):
  Memory.closed_view view mem_src.
Proof.
  econs.
  - eapply sim_memory_closed_timemap; eauto. apply TGT.
  - eapply sim_memory_closed_timemap; eauto. apply TGT.
Qed.

Lemma sim_memory_closed_opt_view
      mem_src mem_tgt
      view
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_opt_view view mem_tgt):
  Memory.closed_opt_view view mem_src.
Proof.
  inv TGT; econs. eapply sim_memory_closed_view; eauto.
Qed.

Lemma lower_sim_memory
      mem1 loc from to val released1 released2 mem2
      (LOWER: Memory.lower mem1 loc from to val released1 released2 mem2):
  sim_memory mem2 mem1.
Proof.
  econs.
  - i. eapply lower_covered. eauto.
  - i. erewrite Memory.lower_o; eauto. condtac; ss.
    + des. subst.
      erewrite Memory.lower_get0 in GET; eauto. inv GET.
      esplits; eauto. inv LOWER. inv LOWER0. auto.
    + esplits; eauto. refl.
Qed.

Lemma promise_lower_sim_memory
      promises1 mem1 loc from to val released1 released2 promises2 mem2
      (PROMISE: Memory.promise promises1 mem1 loc from to val released2 promises2 mem2 (Memory.op_kind_lower released1)):
  sim_memory mem2 mem1.
Proof.
  inv PROMISE. eapply lower_sim_memory. eauto.
Qed.

Lemma split_sim_memory
      mem0 loc ts1 ts2 ts3 val2 val3 released2 released3 mem1
      (SPLIT: Memory.split mem0 loc ts1 ts2 ts3 val2 val3 released2 released3 mem1):
  sim_memory mem1 mem0.
Proof.
  econs.
  - i. eapply split_covered. eauto.
  - i. exploit Memory.split_get0; eauto. i. des.
    erewrite Memory.split_o; eauto. repeat condtac; ss.
    + des. subst. congr.
    + guardH o. des. subst. rewrite GET3 in GET. inv GET.
      esplits; eauto. refl.
    + esplits; eauto. refl.
Qed.