From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq.
From mathcomp Require Import choice fintype prime tuple finfun finset bigop.
Require Import tree_traversal rank_select insert_delete set_clear dynamic.

(** * A formalization of succinct dynamic bit vectors *)

(** OUTLINE:
  0. Section btree
  1. Section dtree
       Definition daccess, drank, dselect_1 and dselect_0.
  2. Section insert
  3. Section dinsert
  4. Section set_clear
  5. Section delete
  6. Section ddelete
  7. Section example
*)

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

Ltac decompose_rewrite :=
  let H := fresh "H" in
  case/andP || (move=>H; rewrite ?H ?(eqP H)).

Ltac decomp ok := move: ok => /=; repeat decompose_rewrite.

Section btree.

Variables D A : Type.

Inductive btree : Type :=
  | Bnode : color -> btree -> D -> btree -> btree
  | Bleaf : A -> btree.

End btree.

Section dtree.

Definition dtree := btree (nat * nat) (seq bool).

Fixpoint dflatten (B : dtree) :=
  match B with
  | Bnode _ l _ r => dflatten l ++ dflatten r
  | Bleaf s => s
  end.

Notation size_df t := (size (dflatten t)).
Notation ones_df t := (count_mem true (dflatten t)).

Variables low high : nat.  (* (w ^ 2)./2 and (w ^ 2).*2 *)

Fixpoint wf_dtree (B : dtree) :=
  match B with
  | Bnode _ l (num, ones) r =>
    [&& num == size_df l, ones == ones_df l, wf_dtree l & wf_dtree r]
  | Bleaf arr => low <= size arr < high
  end.

Lemma dtree_ind (P : dtree -> Prop) :
  (forall c (l r : dtree) num ones,
      num = size_df l -> ones = ones_df l -> wf_dtree l /\ wf_dtree r ->
      P l -> P r -> P (Bnode c l (num, ones) r)) ->
  (forall s, low <= size s < high -> P (Bleaf _ s)) ->
  forall B, wf_dtree B -> P B.
Proof.
  move=> HN HL; elim => [c l IHl [num ones] r IHr | s] //=.
    move/andP => [/eqP Hones] /andP [/eqP Hnum] /andP [wfl wfr].
    apply: HN; auto.
  by apply: HL.
Qed.

Fixpoint dsize (B : dtree) :=
  match B with
  | Bnode _ l (n, _) r => n + dsize r
  | Bleaf s => size s
  end.

Fixpoint daccess (B : dtree) (i : nat) :=
  match B with
  | Bnode _  l (num, ones) r =>
    if i < num then daccess l i else daccess r (i - num)
  | Bleaf s =>
    nth false s i
  end.

Fixpoint drank (B : dtree) (i : nat) :=
  match B with
  | Bnode _ l (num, ones) r =>
    if i < num then drank l i else ones + drank r (i - num)
  | Bleaf s =>
    rank true i s
  end.

Definition drank_size B := drank B (dsize B).

Fixpoint dselect_1 (B : dtree) (i : nat) :=
  match B with
  | Bnode _ l (num, ones) r =>
    if i <= ones then dselect_1 l i else num + dselect_1 r (i - ones)
  | Bleaf s => select true i s
  end.

Fixpoint dselect_0 (B : dtree) (i : nat) :=
  match B with
  | Bnode _ l (num, ones) r =>
    let zeroes := num - ones
    in if i <= zeroes then dselect_0 l i else num + dselect_0 r (i - zeroes)
  | Bleaf s => select false i s
  end.

Fixpoint dones (B : dtree) :=
  match B with
  | Bnode _ l (_, o) r => o + dones r
  | Bleaf s => count_mem true s
  end.

Definition access (s : seq bool) i := nth false s i.

Lemma daccessE (B : dtree) : wf_dtree B -> daccess B =1 access (dflatten B).
Proof.
  move: B.
  apply: dtree_ind => // c l r num ones -> -> _ IHl IHr i /=.
  by rewrite IHl IHr /access nth_cat.
Qed.

Lemma drankE (B : dtree) i : wf_dtree B ->
  drank B i = rank true i (dflatten B).
Proof.
  move=> wf; move: B wf i.
  apply: dtree_ind => // c l r num ones -> -> _ IHl IHr i /=.
  rewrite rank_cat ltn_neqAle IHl IHr (rank_size _ _ _ erefl).
  by case: ifP.
Qed.

Lemma dselect_1E (B : dtree) i : wf_dtree B ->
dselect_1 B i = select true i (dflatten B).
Proof.
  move=> wf; move: B wf i.
  apply: dtree_ind => // c l r num ones -> -> _ IHl IHr i /=.
  by rewrite select_cat IHl IHr.
Qed.

Lemma predC_bool b : predC (pred1 b) =1 pred1 (negb b).
Proof. by case. Qed.

Lemma count_mem_false_true (s : seq bool) :
  count_mem false s + count_mem true s = size s.
Proof.
  by rewrite -(count_predC (pred1 false)) (eq_count (predC_bool false)).
Qed.

Lemma dselect_0E (B : dtree) i : wf_dtree B ->
dselect_0 B i = select false i (dflatten B).
Proof.
  move=> wf; move: B wf i.
  apply: dtree_ind => // c l r num ones -> -> _ IHl IHr i /=.
  by rewrite select_cat -IHl -IHr -[in X in X - _]count_mem_false_true addnK.
Qed.

Lemma dsizeE (B : dtree) : wf_dtree B -> dsize B = size_df B.
Proof.
  move=> wf; move: B wf.
  apply: dtree_ind => // c l r num ones Hnum Hones _ IHl IHr /=.
  by rewrite Hnum IHr size_cat.
Qed.

Lemma donesE (B : dtree) : wf_dtree B -> dones B = ones_df B.
Proof.
  move=> wf; move: B wf.
  apply: dtree_ind => // c l r num ones Hnum Hones _ IHl IHr /=.
  by rewrite Hones IHr count_cat.
Qed.

Corollary drank_all (B : dtree) :
  wf_dtree B -> drank B (dsize B) = ones_df B.
Proof. move => wf. by rewrite drankE // /rank dsizeE // take_size. Qed.

End dtree.

Notation size_df t := (size (dflatten t)).
Notation ones_df t := (count_mem true (dflatten t)).

Section insert.

Variables D A : Type.
Variable addD : D -> D -> D.
Variable subD : D -> D -> D.

Definition balance col (l r : btree D A) dl : btree D A :=
  match col with
  | Red => Bnode Red l dl r
  | Black => match l, r with
             | Bnode Red (Bnode Red a da b) dab c, d =>
               Bnode Red (Bnode Black a da b) dab
                         (Bnode Black c (subD dl dab) d)
             | Bnode Red a da (Bnode Red b db c), d =>
               Bnode Red (Bnode Black a da b) (addD da db)
                         (Bnode Black c (subD (subD dl da) db) d)
             | a, Bnode Red (Bnode Red b db c) dbc d =>
               Bnode Red (Bnode Black a dl b) (addD dl db)
                         (Bnode Black c (subD dbc db) d)
             | a, Bnode Red b db (Bnode Red c dc d) =>
               Bnode Red (Bnode Black a dl b) (addD dl db)
                         (Bnode Black c dc d)
             | _, _ => Bnode Black l dl r
             end
  end.

Definition balanceL col (l r : btree D A) dl : btree D A :=
  match col with
  | Red => Bnode Red l dl r
  | Black => match l with
             | Bnode Red (Bnode Red a da b) dab c =>
               Bnode Red (Bnode Black a da b) dab
                         (Bnode Black c (subD dl dab) r)
             | Bnode Red a da (Bnode Red b db c) =>
               Bnode Red (Bnode Black a da b) (addD da db)
                         (Bnode Black c (subD (subD dl da) db) r)
             | _ => Bnode Black l dl r
             end
  end.

Definition balanceR col (l r : btree D A) dl : btree D A :=
  match col with
  | Red => Bnode Red l dl r
  | Black => match r with
             | Bnode Red (Bnode Red b db c) dbc d =>
               Bnode Red (Bnode Black l dl b) (addD dl db)
                         (Bnode Black c (subD dbc db) d)
             | Bnode Red b db (Bnode Red c dc d) =>
               Bnode Red (Bnode Black l dl b) (addD dl db)
                         (Bnode Black c dc d)
             | _ => Bnode Black l dl r
             end
  end.

Variable bins_leaf : A -> bool -> nat -> btree D A.
Variable lt_index : nat -> D -> bool.
Variable right_index : nat -> D -> nat.
Variable insD : D -> bool -> D.

Fixpoint bins (B : btree D A) b i : btree D A :=
  match B with
  | Bleaf s => bins_leaf s b i
  | Bnode c l d r =>
      if lt_index i d
      then balanceL c (bins l b i) r (insD d b)
      else balanceR c l (bins r b (right_index i d)) d
    end.

Definition binsert (B : btree D A) b i : btree D A :=
  match bins B b i with
  | Bleaf s => Bleaf _ s
  | Bnode _ l d r => Bnode Black l d r
  end.

(*
 * Following Appel (2011), pp. 6 - 8
 *
 * ctxt = "color context", or the color of
 * the parent node
 *
 * bh = "black height", i.e. # of black nodes on the
 * path from the root
 *)
Fixpoint is_redblack (B : btree D A) ctxt bh :=
  match B with
  | Bleaf _ => bh == 0
  | Bnode c l _ r =>
    match c, ctxt with
    | Red, Red => false
    | Red, Black => is_redblack l Red bh
                    && is_redblack r Red bh
    | Black, _ => (bh > 0) && is_redblack l Black (bh.-1) &&
                              is_redblack r Black (bh.-1)
    end
  end.

Definition nearly_redblack B bh :=
  match B with
  | Bnode Red l _ r => is_redblack l Black bh && is_redblack r Black bh
  | _ => is_redblack B Black bh
  end.

Hypothesis Hbins_leaf : forall a b i, is_redblack (bins_leaf a b i) Black 0.

Lemma is_redblack_Red_Black B n :
  is_redblack B Red n -> is_redblack B Black n.
Proof. by case: B => /= [[]|]. Qed.

Lemma balanceL_Black_nearly_is_redblack l r n b :
  nearly_redblack l n -> is_redblack r Black n ->
  is_redblack (balanceL Black l r b) Black n.+1.
Proof.
  case: l => [[[[] lll ? llr|?] ? [[] lrl ? lrr|?]|ll ? lr]|?] /=;
    repeat decompose_rewrite => //;
    by rewrite !is_redblack_Red_Black -?(eqP H1).
Qed.

Lemma balanceR_Black_nearly_is_redblack l r n b :
  nearly_redblack r n -> is_redblack l Black n ->
  is_redblack (balanceR Black l r b) Black n.+1.
Proof.
  case: r => [[[[] rll ? rlr|?] ? [[] rrl ? rrr|?]|rl ? rr]|?] /=;
    repeat decompose_rewrite => //;
    by rewrite !is_redblack_Red_Black -?(eqP H1).
Qed.

Lemma is_redblack_nearly_redblack B c n :
  is_redblack B c n -> nearly_redblack B n.
Proof.
  case: B => //= -[]; case: c => // l p r /andP [Hl Hr].
  by rewrite !is_redblack_Red_Black.
Qed.

Lemma bins_is_redblack B b i n :
  (is_redblack B Black n -> nearly_redblack (bins B b i) n) /\
  (is_redblack B Red n -> is_redblack (bins B b i) Black n).
Proof.
  elim: B i n => [c l IHl d r IHr | a] i n; last first.
    split => /= /eqP -> //; exact: is_redblack_nearly_redblack.
  have Hbk : is_redblack (Bnode Black l d r) Black n ->
             is_redblack (bins (Bnode Black l d r) b i) Black n.
    rewrite {3}[Black]lock /= -lock => /andP [/andP [/prednK <- Hl] Hr].
    case: ifP => Hi.
      rewrite balanceL_Black_nearly_is_redblack //; by apply IHl.
    rewrite balanceR_Black_nearly_is_redblack //; by apply IHr.
  split; case: c => //.
  + move=> /= /andP [Hl Hr].
    case: ifP => Hi /=; [move: Hr | move: Hl] => /is_redblack_Red_Black ->;
      rewrite /= ?andbT; by [apply IHl | apply IHr].
  + move/Hbk; exact: is_redblack_nearly_redblack.
Qed.

Definition is_red D A (B : btree D A) :=
  if B is Bnode Red _ _ _ then true else false.

Lemma binsert_is_redblack B b i n :
  is_redblack B Red n ->
  is_redblack (binsert B b i) Red (n + is_red (bins B b i)).
Proof.
  move/(proj2 (bins_is_redblack _ b i _)).
  rewrite /binsert addnC.
  destruct bins => //=.
  case: c => //= /andP [Hd1 Hd2].
  by rewrite !is_redblack_Red_Black.
Qed.

Corollary binsert_is_redblack' B b i n :
  is_redblack B Red n -> exists n', is_redblack (binsert B b i) Red n'.
Proof. esplit; apply /binsert_is_redblack /H. Qed.

End insert.

Section dinsert.

Variables low high : nat.  (* (w ^ 2)./2 and (w ^ 2).*2 *)
Hypothesis Hlow : low.*2 <= high.
Hypothesis Hhigh : 1 < high.

Definition addD d1 d2 := (d1.1 + d2.1, d1.2 + d2.2).
Definition subD d1 d2 := (d1.1 - d2.1, d1.2 - d2.2).
Local Notation balance := (balance addD subD).
Local Notation balanceL := (balanceL addD subD).
Local Notation balanceR := (balanceR addD subD).
Local Notation wf_dtree_l := (wf_dtree low high).

Definition dins_leaf s b i :=
  let s' := insert1 s b i in
  if size s + 1 == high then
    let n  := size s' %/ 2 in let sl := take n s' in let sr := drop n s' in
    Bnode Red (Bleaf _ sl) (n, count_mem true sl) (Bleaf _ sr)
  else Bleaf _ s'.

Definition lt_index i (d : nat * nat) := i < fst d.
Definition right_index i (d : nat * nat) := i - fst d.
Definition insD (d : nat * nat) b := (d.1.+1, d.2+b).

Definition dins : dtree -> bool -> nat -> dtree :=
  bins addD subD dins_leaf lt_index right_index insD.
Definition dinsert : dtree -> bool -> nat -> dtree :=
  binsert addD subD dins_leaf lt_index right_index insD.

Lemma dins_leaf_is_redblack a b i : is_redblack (dins_leaf a b i) Black 0.
Proof. rewrite /dins_leaf; by case: ifP. Qed.

(* Red-blackness invariant *)
Corollary dinsert_is_redblack B b i n :
  is_redblack B Red n -> exists n', is_redblack (dinsert B b i) Red n'.
Proof. apply /binsert_is_redblack' /dins_leaf_is_redblack. Qed.

(* Correctness of balance *)

Lemma dflatten_node c l d r :
  dflatten (Bnode c l d r) = dflatten l ++ dflatten r.
Proof. by []. Qed.

Lemma dflatten_balance c l r d : dflatten (balance c l r d) = dflatten l ++ dflatten r.
Proof.
  rewrite /balance. case: c. exact: dflatten_node.
  case: l => [[[[] lll llD llr|llA] lD [[] lrl lrD lrr|lrA]|ll lD lr]|lA] /=;
  case: r => [[[[] rll rlD rlr|rlA] rD [[] rrl rrD rrr|rrA]|rl rD rr]|rA] /=;
    try done; by rewrite !catA.
Qed.

Lemma dflatten_balanceL c l r d: dflatten (balanceL c l r d) = dflatten l ++ dflatten r.
Proof.
  rewrite /balanceL. case: c. exact: dflatten_node.
  case: l => [[[[] lll llD llr|llA] lD [[] lrl lrD lrr|lrA]|ll lD lr]|lA] //=;
    by rewrite !catA.
Qed.

Lemma dflatten_balanceR c l r d: dflatten (balanceR c l r d) = dflatten l ++ dflatten r.
Proof.
  rewrite /balanceR. case: c. exact: dflatten_node.
  case: r => [[[[] rll rlD rlr|rlA] rD [[] rrl rrD rrr|rrA]|rl rD rr]|rA] //=;
    by rewrite !catA.
Qed.

(* Correctness of dinsert *)

Definition wf_dtree' t :=
  if t is Bleaf s then size s < high else wf_dtree_l t.

Lemma wf_dtree_dtree' t : wf_dtree_l t -> wf_dtree' t.
Proof. by case: t => //= s /andP[_ ->]. Qed.

Lemma wf_dtree'_dtree t : wf_dtree' t -> wf_dtree 0 high t.
Proof.
  elim: t => //= c l IHl [n o] r IHr; repeat decompose_rewrite => /=.
  by rewrite !(IHl,IHr,wf_dtree_dtree').
Qed.

Lemma wf_dtree'_node c l d r :
  wf_dtree' (Bnode c l d r) = wf_dtree low high (Bnode c l d r).
Proof. by []. Qed.

Lemma dins_leafE s b i :
  size s < high -> dflatten (dins_leaf s b i) = insert1 s b i.
Proof.
  rewrite /dins /dins_leaf. case: ifP => Hi Hs //.
  by rewrite dflatten_node /dflatten cat_take_drop.
Qed.

Lemma dinsE (B : dtree) b i :
  wf_dtree_l B -> dflatten (dins B b i) = insert1 (dflatten B) b i.
Proof.
  move => wf; move: B wf b i. apply: dtree_ind => //.
  + move => c l r num ones Hnum Hones _ IHl IHr /= b i.
    case: ifPn => ?.
     - by rewrite dflatten_balanceL IHl /insert1 insert_catL -?Hnum.
     - by rewrite dflatten_balanceR IHr /insert1 insert_catR -?Hnum // leqNgt.
  + move => s /andP [_] Hs b i /=.
    by rewrite dins_leafE.
Qed.

Lemma dinsertE (B : dtree) b i :
  wf_dtree' B -> dflatten (dinsert B b i) = insert1 (dflatten B) b i.
Proof.
  case: B => [c l d r | s] wf.
    rewrite /dinsert -(dinsE b i) /binsert /dins //; by case: bins.
  rewrite /dinsert /binsert /dins -dins_leafE /=; by case: dins_leaf.
Qed.

(* Well-formedness lemmas
 * Show that dinsert always returns a well-formed tree
 *)

Lemma balanceL_wf c (l r : dtree) d :
  wf_dtree_l (Bnode c l d r) -> wf_dtree_l (balanceL c l r d).
Proof.
  case: c d => /= -[n o] /andP[Hn] /andP[Ho] /andP[wfl wfr].
    by rewrite wfl wfr Hn Ho.
  case: l wfl Hn Ho => [[[[] ? [??] ?|?] [??] [[] ? [??] ?|?] | ? [??] ?]|?] /=;
    rewrite wfr; repeat decompose_rewrite;
    by rewrite ?(size_cat,count_cat,addKn,eqxx).
Qed.

Lemma balanceR_wf c (l r : dtree) d :
   wf_dtree_l (Bnode c l d r) -> wf_dtree_l (balanceR c l r d).
Proof.
  case: c d => /= -[n o] /andP[Hn] /andP[Ho] /andP[wfl wfr].
    by rewrite wfl wfr Hn Ho.
  case: r wfr Hn Ho => [[[[] ? [??] ?|?] [??] [[] ? [??] ?|?] | ? [??] ?]|?] /=;
    rewrite wfl; repeat decompose_rewrite;
    by rewrite ?(size_cat,count_cat,addKn,eqxx).
Qed.

Lemma leq_half n : n./2 <= n.
Proof. by rewrite -{2}(odd_double_half n) -addnn addnA leq_addl. Qed.

Lemma dins_leaf_wf s b i : size s < high -> wf_dtree' (dins_leaf s b i).
Proof.
  move=> Hs.
  rewrite /dins_leaf addn1 divn2.
  case: ifP => Hsize /=.
    rewrite ?(eqxx,size_insert1,(eqP Hsize),size_drop,size_takel,leq_half) //.
    have:= half_leq Hlow; rewrite doubleK => Hlow'.
    set hhigh := high./2.
    rewrite Hlow' -(odd_double_half high) -addnn addnA addnK.
    have Hup : 0 < odd high + high./2.
      by rewrite -addn1 leq_add // (half_leq Hhigh).
    rewrite -add1n leq_add // (leq_trans Hlow' (leq_addl _ _)).
    by rewrite -addn1 leq_add // (half_leq Hhigh).
  move: Hs.
  by rewrite size_insert1 leq_eqVlt Hsize /= => ->.
Qed.

Lemma dins_wf (B : dtree) b i :
  wf_dtree low high B -> wf_dtree low high (dins B b i).
Proof.
  move => wf;  move: B wf b i.
  apply: dtree_ind =>
         [c l r num ones -> -> [wfl wfr] IHl IHr b i | s Hs b i] /=.
    case: ifP => Hi.
      apply: balanceL_wf => /=;
      by rewrite IHl wfr dinsE // size_insert1 count_insert1 eqb_id !eqxx.
    apply: balanceR_wf => /=; by rewrite IHr wfl !eqxx.
  have/andP[Hs1 Hs2]:= Hs.
  have:= dins_leaf_wf b i Hs2.
  case Hins: dins_leaf => [//|s'] /= ->.
  move: Hins; rewrite /dins_leaf.
  case: ifP => // _ [] <-.
  by rewrite size_insert1 (leq_trans Hs1).
Qed.

Lemma recolor_node_wf c c' d (l r : dtree) :
  wf_dtree' (Bnode c l d r) -> wf_dtree' (Bnode c' l d r).
Proof. by []. Qed.

Definition is_leaf (t : dtree) := if t is Bleaf _ then true else false.

Lemma dins_leaf_leaf t b i : is_leaf (dins t b i) ==> is_leaf t.
Proof.
  apply/implyP.
  case: t => //= c l [n o] r.
  case: ifP => _ /=; rewrite /balanceL /balanceR; case: c => //=;
    by case: dins => //= -[] // [[] ? ? ?|?] [n' o'] [[] ? ? ?|?].
Qed.

Lemma dinsert_wf (B : dtree) b i :
  wf_dtree' B -> wf_dtree' (dinsert B b i).
Proof.
  rewrite /dinsert /binsert -/dins => wf.
  have:= @dins_leaf_leaf B b i.
  case Hins: (dins B b i) => [c' l' [? ?] r' | s'] Hlf.
    apply (@recolor_node_wf c').
    case: B wf Hins {Hlf} => [c l [num ones] r | s] wf Hins.
      apply wf_dtree_dtree'.
      by rewrite -Hins dins_wf.
    rewrite -Hins /=.
    by apply dins_leaf_wf.
  case: B wf Hins Hlf => //= s Hs Hins b'.
  move: (dins_leaf_wf b i Hs) => /=.
  by rewrite Hins.
Qed.

(* Interaction with other operations *)

Definition dinsert_wf0 B b i wf := wf_dtree'_dtree (@dinsert_wf B b i wf).

Lemma dinsert_rank (B : dtree) b i j :
  wf_dtree' B -> drank (dinsert B b i) j =
                 rank true j (insert1 (dflatten B) b i).
Proof.
  move => wf; by rewrite -dinsertE // (@drankE 0 high) // dinsert_wf0.
Qed.

Lemma dinsert_select1 (B : dtree) b i j : wf_dtree' B ->
  dselect_1 (dinsert B b i) j = select true j (insert1 (dflatten B) b i).
Proof.
  move => wf; by rewrite -dinsertE // (@dselect_1E 0 high) // dinsert_wf0.
Qed.

Lemma dinsert_select0 (B : dtree) b i j : wf_dtree' B ->
 dselect_0 (dinsert B b i) j = select false j (insert1 (dflatten B) b i).
Proof.
  move => wf; by rewrite -dinsertE // (@dselect_0E 0 high) // dinsert_wf0.
Qed.

End dinsert.

Section set_clear.

Variables low high : nat.
Hypothesis Hlow : low.*2 <= high.
Hypothesis Hhigh : 1 < high.
Local Notation wf_dtree' := (wf_dtree' low high).

Fixpoint bset (B : dtree) i : (dtree * bool) :=
  match B with
  | Bleaf s => (Bleaf _ (bit_set s i), ~~ (nth true s i))
  | Bnode c l (num, ones) r =>
    if i < num
    then let (l', flip) := bset l i
         in  (Bnode c l' (num, ones + flip) r, flip)
    else let (r', flip) := bset r (i - num)
         in  (Bnode c l (num, ones) r', flip)
  end.

Fixpoint bclear (B : dtree) i : (dtree * bool) :=
  match B with
  | Bleaf s => (Bleaf _ (bit_clear s i), nth true s i)
  | Bnode c l (num, ones) r =>
    if i < num
    then let (l', flip) := bclear l i
         in (Bnode c l' (num, ones - flip) r, flip)
    else let (r', flip) := bclear r (i - num)
         in  (Bnode c l (num, ones) r', flip)
  end.

Definition dbitset (B : dtree) i := fst (bset B i).

Definition dbitclear (B : dtree) i := fst (bclear B i).

Lemma dbitsetE (B : dtree) i :
  wf_dtree' B -> dflatten (dbitset B i) = bit_set (dflatten B) i.
Proof.
  move=> /wf_dtree'_dtree wf; move: B wf i; rewrite /bit_set.
  apply: dtree_ind => // c l r num ones -> -> _ IHl IHr i /=.
  rewrite update_cat -IHl -IHr /dbitset /=.
  by case: ifP; case: bset => // l' [].
Qed.

Lemma dbitclearE (B : dtree) i :
  wf_dtree' B -> dflatten (dbitclear B i) = bit_clear (dflatten B) i.
Proof.
  move=> /wf_dtree'_dtree wf; move: B wf i; rewrite /bit_clear.
  apply: dtree_ind => // c l r num ones -> -> _ IHl IHr i /=.
  rewrite update_cat -IHl -IHr /dbitclear /=.
  by case: ifP; case: bclear => // l' [].
Qed.

Lemma size_bset (B : dtree) i : size_df (bset B i).1 = size_df B.
Proof.
  elim: B i => [c l IHl [num ones] r IHr | s] //= i; last by rewrite -size_update.
  case: ifP; by rewrite (surjective_pairing (bset _ _)) /= !size_cat (IHl,IHr).
Qed.

Lemma size_bclear (B : dtree) i : size_df (bclear B i).1 = size_df B.
Proof.
  elim: B i => [c l IHl [num ones] r IHr | s] //= i; last by rewrite -size_update.
  case: ifP; by rewrite (surjective_pairing (bclear _ _)) /= !size_cat (IHl,IHr).
Qed.

Lemma size_dbitset (B : dtree) i : size_df (dbitset B i) = size_df B.
Proof. by rewrite /dbitset size_bset. Qed.

Lemma size_dbitclear (B : dtree) i : size_df (dbitclear B i) = size_df B.
Proof. by rewrite /dbitclear size_bclear. Qed.

Lemma is_redblack_dbitset (B : dtree) i c n :
  is_redblack B c n = is_redblack (dbitset B i) c n.
Proof.
  rewrite /dbitset.
  elim: B i c n => //= cB l IHl [nn o] r IHr i c n //.
  case: ifP; by rewrite (surjective_pairing (bset _ _)) /= -!(IHl,IHr).
Qed.

Lemma is_redblack_dbitclear (B : dtree) i c n :
  is_redblack B c n = is_redblack (dbitclear B i) c n.
Proof.
  rewrite /dbitclear.
  elim: B i c n => //= cB l IHl [nn o] r IHr i c n //.
  case: ifP; by rewrite (surjective_pairing (bclear _ _)) /= -!(IHl,IHr).
Qed.

Lemma ones_dbitset (B : dtree) i :
  wf_dtree low high B -> i < size_df B ->
  ones_df B + (bset B i).2 = ones_df (bset B i).1.
Proof.
  rewrite /dbitset.
  move=> wf Hsize; move: B wf i Hsize.
  apply: dtree_ind => //= [ c l r num ones -> -> [wfl wfr] IHl IHr i /= Hi
                          | s Hs i Hi ]; last by rewrite addnC -count_bit_set.
  case: ifP => Hil; rewrite (surjective_pairing (bset _ _)) /= !count_cat.
  - by rewrite addnAC IHl.
  - rewrite -!addnA IHr // -add1n.
    by rewrite -(ltn_add2l (size_df l)) -size_cat subnKC // leqNgt Hil.
Qed.

Lemma flip_bit_bclear (B : dtree) i :
  wf_dtree low high B -> i < size_df B -> (bclear B i).2 = daccess B i.
Proof.
  move=> wf; move: B wf i.
  apply: dtree_ind; last by move => ????; apply set_nth_default.
  move => c l r num ones Hnum Hones [wfl wfr] IHl IHr i /=.
  rewrite size_cat Hnum => Hsz.
  case: ifP => Hi; rewrite (surjective_pairing (bclear _ _)) (IHl,IHr) //.
  by rewrite -subSn ?leq_subLR // leqNgt Hi.
Qed.

Lemma ones_dbitclear (B : dtree) i :
  wf_dtree low high B -> i < size_df B ->
  ones_df (dbitclear B i) = ones_df B - daccess B i.
Proof.
  rewrite /dbitclear.
  move=> wf Hsize; move: B wf i Hsize.
  apply: dtree_ind => //=
    [c l r num ones -> -> [wfl wfr] IHl IHr i /= Hi | s Hs i Hi];
    last by rewrite -count_bit_clear.
  case: ifP => Hil; rewrite (surjective_pairing (bclear _ _)) /= !count_cat.
  - by rewrite IHl // addnC [in RHS]addnC -addnBA // (daccessE wfl) true_count_pos.
  - have Hilr: i - size_df l < size_df r.
      by rewrite -(ltn_add2l (size_df l)) -size_cat subnKC // leqNgt Hil.
    by rewrite IHr // addnBA // (daccessE wfr) true_count_pos.
Qed.

Lemma wf_dbitset (B : dtree) i :
  wf_dtree' B -> wf_dtree' (dbitset B i).
Proof.
  case: B => [c l d r | s] wf; last by rewrite /= size_bit_set.
  apply wf_dtree_dtree'.
  move: wf i; rewrite wf_dtree'_node; move: {c l d r} (Bnode _ _ _ _).
  apply: dtree_ind => //= [c l r num ones -> -> [wfl wfr] IHl IHr|s Hs] i;
    last by rewrite size_bit_set.
  rewrite /dbitset /=.
  case: ifP => Hil; rewrite (surjective_pairing (bset _ _)) /= (wfl,wfr).
  - by rewrite size_bset ones_dbitset // !eqxx IHl.
  - by rewrite IHr !eqxx.
Qed.

Lemma wf_dbitclear (B : dtree) i :
  wf_dtree' B -> wf_dtree' (dbitclear B i).
Proof.
  case: B => [c l d r | s] wf; last by rewrite /= size_bit_clear.
  apply wf_dtree_dtree'.
  move: wf i; rewrite wf_dtree'_node; move: {c l d r} (Bnode _ _ _ _).
  apply: dtree_ind => [c l r num ones -> -> [wfl wfr] IHl IHr|s Hs] i /=;
    last by rewrite size_bit_clear.
  rewrite /dbitclear /=.
  case: ifP => Hil; rewrite (surjective_pairing (bclear _ _)) /= (wfl,wfr).
  - by rewrite size_bclear ones_dbitclear // flip_bit_bclear // !eqxx IHl.
  - by rewrite IHr !eqxx.
Qed.

End set_clear.

Section delete.

Variables D A : Type.
Variable mkD : btree D A -> D.
Variable addD : D -> D -> D.
Variable subD : D -> D -> D.

Definition rbnode c l r := Bnode c l (mkD l) r.
Definition bnode l r := Bnode Black l (mkD l) r.
Definition rnode l r := Bnode Red l (mkD l) r.
Local Notation leaf a := (Bleaf _ a : btree D A).

Record deleted_btree: Type := MkD
  { d_tree :> btree D A; d_down: bool; d_del: D }.

Definition balanceL' col (l : deleted_btree) d r : deleted_btree :=
  let d' := subD d (d_del l) in
  let stay tr := MkD tr false (d_del l) in
  let down tr := MkD tr true (d_del l) in
  if ~~ d_down l
  then stay (Bnode col l d' r)
  else match col, r with
  | _, Bnode Black (Bnode Red rll rld rlr) rd rr =>
    stay (Bnode col
                (Bnode Black l d' rll)
                (addD rld d')
                (Bnode Black rlr (subD rd rld) rr))
  | Red, Bnode Black (Bleaf _ as rl) rd rr
  | Red, Bnode Black (Bnode Black _ _ _ as rl) rd rr =>
    stay (Bnode Black (Bnode Red l d' rl) (addD d' rd) rr)
  | Black, Bnode Red (Bnode Black (Bnode Black _ _ _ as rll) rld rlr) rd rr
  | Black, Bnode Red (Bnode Black (Bleaf _ as rll) rld rlr) rd rr =>
    stay (Bnode Black
               (Bnode Black
                      (Bnode Red l d' rll)
                      (addD d' rld)
                      rlr)
               (addD d' rd)
               rr)
  | Black, Bnode Red (Bnode Black (Bnode Red rlll rlld rllr) rld rlr) rd rr =>
    stay (Bnode Black
               (Bnode Black l d' rlll)
               (addD rlld d')
               (Bnode Red
                      (Bnode Black rllr (subD rld rlld) rlr)
                      (subD rd rlld)
                      rr))
  | Black, Bnode Black (Bleaf _ as rl) rd rr
  | Black, Bnode Black (Bnode Black _ _ _ as rl) rd rr =>
    down (Bnode Black (Bnode Red l d' rl) (addD d' rd) rr)
  | _, _ => stay (Bnode col l d' r)
  end.

Definition balanceR' col l d (r : deleted_btree) : deleted_btree :=
  let stay tr := MkD tr false (d_del r) in
  let down tr := MkD tr true (d_del r) in
  if ~~ d_down r
  then stay (Bnode col l d r)
  else match col, l with
  | _, Bnode Black ll ld (Bnode Red lrl lrd lrr) =>
    stay (Bnode col
                (Bnode Black ll ld lrl)
                (addD ld lrd)
                (Bnode Black lrr (subD d (addD ld lrd)) r))
  | Red, Bnode Black ll ld (Bleaf _ as lr)
  | Red, Bnode Black ll ld (Bnode Black _ _ _ as lr) =>
    stay (Bnode Black ll ld (Bnode Red lr (subD d ld) r))
  | Black, Bnode Red ll ld (Bnode Black lrl lrd (Bnode Black _ _ _ as lrr))
  | Black, Bnode Red ll ld (Bnode Black lrl lrd (Bleaf _ as lrr)) =>
    stay (Bnode
            Black
            ll
            ld
            (Bnode Black lrl lrd (Bnode Red lrr (subD d (addD ld lrd)) r)))
  | Black, Bnode Red ll ld (Bnode Black lrl lrd (Bnode Red lrrl lrrd lrrr)) =>
    stay (Bnode Black (Bnode Red ll ld (Bnode Black lrl lrd lrrl))
                (addD (addD ld lrd) lrrd)
                (Bnode Black lrrr (subD d (addD (addD ld lrd) lrrd)) r))
  | Black, Bnode Black ll ld (Bleaf _ as lr)
  | Black, Bnode Black ll ld (Bnode Black _ _ _ as lr) =>
    down (Bnode Black ll ld (Bnode Red lr (subD d ld) r))
  | _, _ => stay (Bnode col l d r)
  end.

Lemma balanceL'_d_delE c (l : deleted_btree) d r :
  d_del (balanceL' c l d r) = d_del l.
Proof.
  case: l c r => l [] ? [] [[] rl ??|?] //=;
  case: rl => [[] rll ??|?] //=;
  case: rll => [[]???|?] //=.
Qed.

Lemma balanceR'_d_delE c l d (r : deleted_btree) :
  d_del (balanceR' c l d r) = d_del r.
Proof.
  case: r c l => r [] ? [] [[]?? lr|?] //=;
  case: lr => [[]?? lrr|?] //=;
  case: lrr => [[]???|?] //=.
Qed.

Variable lt_index : nat -> D -> bool.
Variable right_index : nat -> D -> nat.
Variable delete_leaf : A -> nat -> A * D.
Variable delete_from_leaves : color -> A -> A -> nat -> deleted_btree.

Fixpoint bdel B (i : nat) { struct B } : deleted_btree :=
  match B with
  | Bnode c (Bleaf l) d (Bleaf r) => delete_from_leaves c l r i
  | Bnode Black (Bnode Red (Bleaf ll) ld (Bleaf lr) as l) d (Bleaf r) =>
    if lt_index i d
    then balanceL' Black (bdel l i) d (Bleaf _ r)
    else balanceR' Black (Bleaf _ ll) ld
                   (delete_from_leaves Red lr r (right_index i ld))
  | Bnode Black (Bleaf l) ld (Bnode Red (Bleaf rl) d (Bleaf rr) as r) =>
    if lt_index (right_index i ld) d
    then balanceL' Black (delete_from_leaves Red l rl i)
                   (addD ld d) (Bleaf _ rr)
    else balanceR' Black (Bleaf _ l) ld (bdel r (right_index i ld))
  | Bnode c l d r =>
    if lt_index i d
    then balanceL' c (bdel l i) d r
    else balanceR' c l d (bdel r (right_index i d))
  | Bleaf x =>
    let (leaf, ret) := delete_leaf x i in
    MkD (Bleaf _ leaf) false ret
  end.

Definition is_deleted_redblack tr c bh :=
  if d_down tr
  then is_redblack tr Red bh.-1
  else is_redblack tr c bh.

Hypothesis Hdelete_from_leaves : forall c l d r i c' n,
  is_redblack (Bnode c (Bleaf D l) d (Bleaf D r)) c' n ->
  is_deleted_redblack (delete_from_leaves c l r i) c' n.

Lemma is_deleted_redblack_Red_Black B n :
  is_deleted_redblack B Red n -> is_deleted_redblack B Black n.
Proof. by case: B => [[[]???|?] [] ?]. Qed.

Lemma balanceL'_Black_deleted_is_redblack l d r n c :
  0 < n -> is_deleted_redblack l Black n.-1 -> is_redblack r Black n.-1 ->
  is_deleted_redblack (balanceL' Black l d r) c n.
Proof.
  case: l => [l [] ?] Hn okl okr;
  case: c n r l okr okl Hn => [] [//|n]
    [[[[] [[] rlll ? rllr|?] ? rlr|?] ? rr| [[] rll ? rlr| ?] ? rr]|?] l;
    rewrite /balanceL' /is_deleted_redblack //=; repeat decompose_rewrite;
    by rewrite // !is_redblack_Red_Black.
Qed.

Lemma balanceL'_Red_deleted_is_redblack l d r n :
  is_deleted_redblack l Red n -> is_redblack r Red n ->
  is_deleted_redblack (balanceL' Red l d r) Black n.
Proof.
  case: l => [l [] ?] okl okr;
  case: n r l okr okl => [//|n]
    [[[[] [[] rlll ? rllr|?] ? rlr|?] ? rr| [[] rll ? rlr| ?] ? rr]|?] l;
    rewrite /balanceL' /is_deleted_redblack //=; repeat decompose_rewrite;
    by rewrite // !is_redblack_Red_Black.
Qed.

Lemma balanceR'_Black_deleted_is_redblack l d r n c :
  0 < n -> is_redblack l Black n.-1 -> is_deleted_redblack r Black n.-1 ->
  is_deleted_redblack (balanceR' Black l d r) c n.
Proof.
  case: r => [r [] ?];
  case: c n l => [] [//|n] [[[[] lll ? llr|?] ?
    [[] lrl ? [[] lrrl ? lrrr|?]|?]|ll ? [[] lrl ? lrr|?]]|?] /=;
    rewrite /balanceR' /is_deleted_redblack //=; repeat decompose_rewrite;
    by rewrite // !is_redblack_Red_Black.
Qed.

Lemma balanceR'_Red_deleted_is_redblack l d r n :
  is_redblack l Red n -> is_deleted_redblack r Red n ->
  is_deleted_redblack (balanceR' Red l d r) Black n.
Proof.
  case: r => [r [] ?];
  case: l => [[[[] lll ? llr|?] ?
    [[] lrl ? [[] lrrl ? lrrr|?]|?]|ll ? [[] lrl ? lrr|?]]|?] /=;
    rewrite /balanceR' /is_deleted_redblack //=; repeat decompose_rewrite;
    by rewrite // !is_redblack_Red_Black.
Qed.

(* This tactic is not necessary,
   but if it is removed, a proof becomes more slower. *)
Ltac close_branch d H IHl IHr :=
 rewrite /=;
 try case:ifP=>?;
 repeat (apply balanceL'_Red_deleted_is_redblack ||
         apply balanceL'_Red_deleted_is_redblack ||
         apply balanceR'_Red_deleted_is_redblack ||
         apply balanceL'_Black_deleted_is_redblack ||
         apply balanceR'_Black_deleted_is_redblack ||
         apply IHl ||
         apply IHr ||
         apply (Hdelete_from_leaves (d:=d)));
 decomp H.

Lemma bdel_is_deleted_redblack B i n c :
  is_redblack B c n -> is_deleted_redblack (bdel B i) c n.
Proof.
elim: B c i n => [c l IHl d r IHr |a] p i n H //.
time (case: p c l IHl H => [] []// [[]//[[]//???|?]?[[]//???|?]|?] IHl H;
  try (by close_branch d H IHl IHr);
  case: r IHr H => [[]//[[]//???|?]?[[]//???|?]|?] IHr H;
  close_branch d H IHl IHr => //).
  rewrite /is_deleted_redblack /=;
  case: (delete_leaf a i) => //=.
(* 153s -> 73s by rewrite ? -> repeat apply || *)
Qed.

End delete.

Section ddelete.

Variables low high : nat.
Hypothesis Hlow : low.*2 <= high.
Hypothesis Hlow1 : low >= 1.
Let Hhigh : 1 < high.
Proof. by rewrite (leq_trans _ Hlow) // (leq_double 1 low). Qed.
Local Notation wf_dtree' := (wf_dtree' low high).
Local Notation wf_dtree_l := (wf_dtree low high).
Local Notation donesE' := (@donesE low high).
Local Notation dsizeE' := (@dsizeE low high).
Local Notation leaf a := (Bleaf _ a : dtree).
Definition mkD l := (dsize l, dones l).
Local Notation rbnode := (rbnode mkD).
Definition deleted_dtree := deleted_btree (nat * nat) (seq bool).
Local Notation balanceL' c B d b := (balanceL' addD subD c B d b).
Local Notation balanceR' c B d b := (balanceR' addD subD c B d b).

Definition delete_from_leaves (p : color) l r (i : nat) : deleted_dtree :=
  if i < size l
  then match low == size l, low == size r with
       | true, true =>
         MkD (leaf ((rcons (delete l i) (access r 0)) ++ (delete r 0)))
             true
             (1, access l i : nat)
       | true, false =>
         MkD (rbnode p (leaf (rcons (delete l i) (access r 0)))
                     (leaf (delete r 0)))
             false
             (1, access l i : nat)
       | false, _ =>
         MkD (rbnode p (leaf (delete l i)) (leaf r))
             false
             (1, access l i : nat)
       end
  else match low == size l, low == size r with
       | true, true =>
         MkD (leaf (l ++ (delete r (i - (size l)))))
             true
             (1, access r (i - (size l)) : nat)
       | false, true =>
         MkD (rbnode p (leaf (delete l (size l).-1))
                     (leaf (access l (size l).-1 :: delete r (i - size l))))
             false
             (1, access r (i - (size l)) : nat)
       | _, false =>
         MkD (rbnode p (leaf l) (leaf (delete r (i - size l))))
             false
             (1, access r (i - (size l)) : nat)
       end.

Lemma delete_from_leaves_deleted_redblack c l d r i c' n :
  is_redblack (Bnode c (leaf l) d (leaf r)) c' n ->
  is_deleted_redblack (delete_from_leaves c l r i) c' n.
Proof.
  case: c c' => -[] //;
  rewrite /is_deleted_redblack /delete_from_leaves;
  repeat case: ifP; repeat decompose_rewrite => //=.
Qed.

Notation ddel := (bdel addD subD lt_index right_index
                       (fun x i => (delete x i, (1, access x i : nat)))
                       delete_from_leaves).

(* Red-blackness invariant *)
Lemma ddel_is_deleted_redblack B i n c :
  is_redblack B c n -> is_deleted_redblack (ddel B i) c n.
Proof.
  apply /bdel_is_deleted_redblack /delete_from_leaves_deleted_redblack.
Qed.

Definition ddelete (B : dtree) i : dtree := ddel B i.

Corollary ddelete_is_redblack B i n :
  is_redblack B Red n -> exists n', is_redblack (ddelete B i) Red n'.
Proof.
  rewrite /ddelete => /(ddel_is_deleted_redblack i).
  rewrite /is_deleted_redblack /=.
  case:ifP; case: ddel => B' /= ? ? ? rb;
  eexists; apply rb.
Qed.

(* Correctness lemmas *)

Lemma balanceL'E c (l : deleted_dtree) d r :
  dflatten (balanceL' c l d r) = dflatten l ++ dflatten r.
Proof.
  move: l c r => [l [] ?] [] [] // [] [] [] [] [];
  intros; by rewrite //= -!catA //= -!catA.
Qed.

Lemma balanceR'E c l d (r : deleted_dtree) :
  dflatten (balanceR' c l d r) = dflatten l ++ dflatten r.
Proof.
  move: r c l => [r [] ?] [] [] // [] ? ? [[]|];
  try (intros; by rewrite //= -!catA //= -!catA);
  move => ? ? [] x; first case x; intros; by rewrite //= -!catA //= -!catA.
Qed.

Lemma delete_from_leavesE c l r i :
  low <= size l < high -> low <= size r < high ->
  dflatten (delete_from_leaves c l r i) = delete (l ++ r) i.
Proof.
  rewrite /delete_from_leaves delete_cat.
  case: ifP; case: ifP => //; case: ifP => //;
    try rewrite /delete /= take0 drop1 cat0s cat_rcons -!catA.
      case r => //= /eqP -> /eqP <-; by rewrite ltn0.
    case r => //= Hlow0 _ _ _ /andP []; by rewrite leqn0 Hlow0.
  move/eqP => -> /= Hnl Hi /andP [Hl Hl'] Hr'.
  have Hl0 : 0 < size l by move: Hl; rewrite leq_eqVlt Hnl /=; case: (size l).
  rewrite /delete /= /access drop_oversize ?prednK //.
  by rewrite cats0 -cat_rcons -take_nth prednK // take_oversize.
Qed.

Lemma ltn_subLR m n p : 0 < p -> (m - n < p) = (m < n + p).
Proof. case: p => //= p; by rewrite addnS !ltnS leq_subLR. Qed.

Lemma ddel_cat c l a b r i :
  wf_dtree_l (Bnode c l (a, b) r) ->
  dflatten (ddel (Bnode c l (a, b) r) i) =
  if i < a
  then dflatten (ddel l i) ++ dflatten r
  else dflatten l ++ dflatten (ddel r (i - a)).
Proof.
  rewrite /= /lt_index /right_index /=.
  time (case: ifP => Hc; case: c l r =>
      [] [[]// [??[??]?|?] [??] [??[??]?|?]|?]
      [[] [??[??]?|?] [??] [??[??]?|?]|?] wfB //;
    try case:ifP;
    rewrite ?(balanceL'E, balanceR'E, delete_cat, delete_from_leavesE,
              ltn_subLR, leq_trans Hlow1) //;
    move:wfB Hc; rewrite ?size_cat;
    do! decompose_rewrite => //=).
    (* 94s => 54s by delaying ltn_addr *)
  all: rewrite ?(subnDA, catA) //.
  by rewrite ltn_addr in H10.
Qed.

Lemma ddelE (B : dtree) i :
  wf_dtree_l B -> dflatten (ddel B i) = delete (dflatten B) i.
Proof.
  elim:B i => [c l IHl [??] r IHr|B] i wfB //.
  rewrite delete_cat.
  rewrite -IHl; last by decomp wfB.
  rewrite -IHr; last by decomp wfB.
  rewrite ddel_cat //; by decomp wfB.
Qed.

Lemma ddeleteE B i :
  wf_dtree' B -> dflatten (ddelete B i) = delete (dflatten B) i.
Proof.
  case: B => // c l d r wfB.
  rewrite -ddelE // /ddelete.
Qed.

(* Well-formedness *)

Lemma eq_addnC a b : a + b == b + a.
Proof. by rewrite addnC. Qed.

Lemma eq_addnC2 a b c : a + b + c == c + a + b.
Proof. by rewrite addnC addnA. Qed.

Lemma eq_addKn a b : a + b - a == b.
Proof. by rewrite addKn. Qed.

Lemma eq_addKn2 a b c : a + b + c - a == b + c.
Proof. by rewrite -addnA addKn. Qed.

Lemma eq_addKn3 a b c d : a + b + c + d - a == b + c + d.
Proof. by rewrite -!addnA addKn. Qed.

Lemma eq_addKn4 a b c d e : a + b + c + d + e - a == b + c + d + e.
Proof. by rewrite -!addnA addKn. Qed.

Lemma balanceL'_wf (B: deleted_dtree) d b c:
  wf_dtree_l B -> wf_dtree_l b ->
  subD d (d_del B) == mkD B ->
  wf_dtree_l (balanceL' c B d b).
Proof.
case: B d => B [] [s o] [s' o'] /= wfB wfb;
 rewrite /subD /mkD /= => /eqP [] Hs Ho.
 time (case: c b wfb Hs Ho =>
       [] [[] [[] [[]?[??]?|?] [??] [[]?[??]?|?]|?] [??] ?|?] wfb /=;
  decomp wfb; decomp wfB;
  rewrite ?(eqxx, dsizeE', donesE', size_cat, count_cat, addnA);
  by rewrite ?(eq_addnC, eq_addnC2, eq_addKn, eq_addKn2, eq_addKn3)).
by rewrite Hs Ho dsizeE' // donesE' // !eqxx /= wfB wfb.
Qed.

Lemma balanceR'_wf (B: deleted_dtree) d b c:
  wf_dtree_l B -> wf_dtree_l b ->
  d == mkD b ->
  wf_dtree_l (balanceR' c b d B).
Proof.
case: B b d => B [] [s o] b [s' o'] /= wfB wfb;
 rewrite /mkD /= => /eqP [] Hs Ho.
 time (case: c b wfb Hs Ho =>
       [] [[] ll [??] [[] [[]?[??]?|?] [??] [[]?[??]?|?]|?]|?] wfb /=;
  decomp wfb; decomp wfB;
  rewrite ?(eqxx, dsizeE', donesE', size_cat, count_cat, addnA);
  by rewrite ?(eq_addnC2, eq_addKn, eq_addKn2, eq_addKn3, eq_addKn4)).
by rewrite Hs Ho dsizeE' // donesE' // !eqxx wfB wfb.
Qed.

Lemma leq_predr (m n : nat) :
  (m == n) = false -> m <= n -> m <= n.-1.
Proof. rewrite leq_eqVlt => -> /= lo; by rewrite -ltnS (ltn_predK lo). Qed.

Lemma delete_from_leaves_wf l r i c:
  i < size l + size r ->
  low <= size l < high ->
  low <= size r < high ->
  wf_dtree_l (delete_from_leaves c l r i).
Proof.
  move=> sc /andP [wll wlh] /andP [wrl wrh].
  have szl: 0 < size l by apply (leq_trans Hlow1).
  have szr: 0 < size r by apply (leq_trans Hlow1).
  have szlp: (size l).-1 < size l by rewrite prednK // subnn.
  have szrp: (size r).-1 < size r by rewrite prednK // subnn.
  rewrite /delete_from_leaves; do! case: ifP; move=>rc lc /=; try (move=> Hi);
  rewrite ?(size_cat,size_rcons,size_delete,eqxx) //=;
  rewrite ?(prednK,wll,wlh,wrl,wrh) // -?(eqP rc,eqP lc);
  try (by rewrite leq_addr (leq_trans _ Hlow)// -addnn ltn_add2l prednK);
  rewrite ?leq_predr // ?ltn_subLR //; try by rewrite ltnW.
  by rewrite {1}(eqP lc) (eqP rc).
Qed.

Ltac prune_d_delE IHl IHr wfB :=
  rewrite ?(balanceL'_d_delE, balanceR'_d_delE, IHl, IHr) //; try by decomp wfB.

Lemma ddel_d_delE B i :
  wf_dtree_l B ->
  d_del (ddel B i) = (1, daccess B i : nat).
Proof.
  elim: B i => [[] l IHl [??] r IHr|//] i wfB /=;
  rewrite /lt_index /right_index;
  case: l IHl wfB => [[] ll [??] lr|?] IHl wfB;
  case: ifP => H; prune_d_delE IHl IHr wfB;
  case: r IHr wfB => [[] rl [??] rr|?] IHr wfB; prune_d_delE IHl IHr wfB;
  try case: ll lr IHl wfB => [[]?[??]?|?] [[]?[??]?|?] IHl wfB;
  prune_d_delE IHl IHr wfB;
  try case: rl rr IHr wfB => [[]?[??]?|?] [[]?[??]?|?] IHr wfB;
  try case: ifP => H'; prune_d_delE IHl IHr wfB.
  all: rewrite /delete_from_leaves;
    move:H; try move:H'; decomp wfB; do? case: ifP => //=.
  all: try (rewrite ltn_subLR; first by rewrite -size_cat H9);
    try rewrite -subnDA -size_cat //;
    rewrite ?(leq_trans Hlow1) //.
  rewrite ltn_subLR ?ltn_addr // in H9.
  by apply (leq_trans Hlow1).
Qed.

Lemma count_delete arr i :
  (count_mem true) (delete arr i) = (count_mem true) arr - nth false arr i.
Proof.
symmetry.
case H : (i < (size arr)).
  rewrite -(cat_take_drop i arr) /delete !count_cat cat_take_drop.
  rewrite (drop_nth false) // -cat1s count_cat /= addn0 eqb_id.
  by rewrite addnA (addnC (count _ _)) -addnA addKn.
move: H; rewrite ltnNge => /negbFE H.
rewrite nth_default // /delete take_oversize // drop_oversize ?leqW //.
by rewrite count_cat /= addn0 subn0.
Qed.

Lemma rcons_delete_access_behead a b i :
  low <= size b ->
  rcons (delete a i) (access b 0) ++ delete b 0 = (delete a i) ++ b.
Proof.
case: b => [|h b] //= H; first by rewrite leqNgt Hlow1 in H.
by rewrite -cats1 -catA /delete take0 drop1.
Qed.

Lemma nth_count a i :
  i < size a ->
  nth false a i <= (count_mem true) a.
Proof. move/(mem_nth false); rewrite -has_pred1 has_count; by case: nth. Qed.

Lemma pat1 (a b : bitseq) i :
  i < size a -> size (delete a i ++ b) = (size (a ++ b)).-1.
Proof.
move=> Hi; rewrite size_cat size_delete // size_cat.
by rewrite -!subn1 [LHS]addnC [in RHS]addnC -addnBA // (@leq_trans i.+1).
Qed.

Lemma pat2 a b i :
  i < size a ->
  count_mem true (delete a i ++ b) = count_mem true (a ++ b) - nth false a i.
Proof.
move=> H.
by rewrite count_cat count_delete !count_cat addnC addnBA ?nth_count // addnC.
Qed.

Lemma pat3 (a b : bitseq) i :
  (i < size a) = false -> i < size a + size b ->
  size (a ++ delete b (i - size a)) = (size (a ++ b)).-1.
Proof.
rewrite ltnNge; move/negPn => H H'.
rewrite size_cat addnC -size_cat pat1 // ?ltn_subLR //.
  by rewrite !size_cat addnC.
case: b H' => //; by rewrite addn0 ltnNge H.
Qed.

Lemma pat4 a b i :
  (i < size a) = false -> i < size a + size b ->
  (count_mem true) (a ++ delete b (i - size a))
  = ((count_mem true) (a ++ b)) - nth false b (i - size a).
Proof.
rewrite ltnNge; move/negPn => H H'.
rewrite count_cat addnC -count_cat pat2 // ?ltn_subLR //.
  by rewrite !count_cat addnC.
case: b H' => //; by rewrite addn0 ltnNge H.
Qed.

Lemma ltn_pred a : 0 < a -> a.-1 < a.
Proof. case: a => //=. Qed.

Lemma dsize_gt0 (B: dtree) : wf_dtree_l B -> size (dflatten B) > 0.
Proof.
move: B; apply: dtree_ind => [c l r num ones -> -> [wfl wfr] IHl IHr|s wf] /=.
  by rewrite size_cat ltn_addr.
rewrite (leq_trans Hlow1); by decomp wf.
Qed.

Lemma delete_from_leaves_d_delE a b i :
  i < size a + size b ->
  low <= size a < high ->
  low <= size b < high ->
  (size (dflatten (delete_from_leaves Red a b i)),
   (count_mem true) (dflatten (delete_from_leaves Red a b i)))
  = (size (a ++ b) - (d_del (delete_from_leaves Red a b i)).1,
     (count_mem true) (a ++ b) - (d_del (delete_from_leaves Red a b i)).2).
Proof.
  rewrite /delete_from_leaves => Hi Ha Hb.
  repeat case:ifP => ?;
    rewrite /access /= ?(pat1, pat2, pat3, pat4, rcons_delete_access_behead);
    rewrite //= ?subn1 //;
    (try by rewrite -size_cat //);
    decomp Ha; decomp Hb => //;
    try by apply ltn_pred, (leq_trans Hlow1).
  have Hb: 0 < size b by apply (leq_trans Hlow1).
  rewrite !size_cat !count_cat /= size_delete //; last rewrite ltn_subLR //.
  rewrite count_delete /= prednK // eqb_id addnCA addKn addnBA //.
  by rewrite nth_count // ltn_subLR.
Qed.

Ltac close_branch Hi IHl IHr wfB rbB :=
  let Hc := fresh "Hc" in
  try case: ifP => Hc;
  (apply balanceR'_wf => //
  || apply balanceL'_wf => //
  || apply delete_from_leaves_wf => //;
  rewrite /mkD /subD /addD /access;
  rewrite ?(ddel_d_delE,
            dsizeE', donesE', ddelE, @daccessE low high,
            count_delete, size_delete, subn1));
  (try apply delete_from_leaves_wf => //);
  rewrite ?delete_from_leaves_d_delE => //;
  try (apply IHl => // || apply IHr => //; rewrite ?ltn_subLR);
  try move: Hi Hc; decomp wfB => //; decomp rbB => //;
  try apply is_redblack_Red_Black => //;
  try rewrite -size_cat //;
  try rewrite size_cat ltn_addr // dsize_gt0 //;
  try apply dsize_gt0 => //.

Lemma ddel_wf (B : dtree) n i :
  0 < n ->
  i < dsize B ->
  is_redblack B Black n ->
  wf_dtree_l B ->
  wf_dtree_l (ddel B i).
Proof.
  move => Hn Hi rbB wfB; rewrite dsizeE' // in Hi; move: Hn Hi rbB wfB.
  rewrite /= /lt_index /right_index /=.
  elim: B n i => [[] l IHl [??] r IHr|?] n i Hn Hi rbB wfB;
    last by move/eqP: rbB Hn => /= ->.
  + rewrite /bdel -/ddel;
    case: l Hi rbB IHl IHr wfB =>
    [[]?[??]?|?] // Hi rbB IHl IHr wfB;
    try by (close_branch Hi (IHl n) (IHr n) wfB rbB).
    case: r Hi rbB IHl IHr wfB =>
    [[]?[??]?|?] Hi rbB IHl IHr wfB;
    by close_branch Hi (IHl n) (IHr n) wfB rbB.
  + case: n Hn rbB => [//|[|n]] Hn rbB.
  * case: l r Hi rbB IHl IHr wfB =>
    [[] [[]//|?] [??] [[]//|?]|?] [[] [[]//|?] [??] [[]|?]|?] //=
    Hi rbB IHl IHr wfB;
    try close_branch Hi (IHl 0) (IHr 0) wfB rbB;
    rewrite ?(size_cat, catA, ltn_subLR);
    try rewrite -!size_cat //;
    try rewrite size_cat ltn_addl // (leq_trans Hlow1) //;
    try by rewrite size_cat -ltn_subLR // (leq_trans Hlow1) //.
    - rewrite catA //.
    - rewrite count_cat //.
  * rewrite /=;
    time (case: l r Hi rbB IHl IHr wfB =>
          [[] ll [??] lr|?] [[] rl [??] rr|?] Hi rbB IHl IHr wfB //;
      try close_branch Hi (IHl n.+1) (IHr n.+1) wfB rbB;
      destruct ll, lr; close_branch Hi (IHl n.+1) (IHr n.+1) wfB rbB).
Qed.

Lemma ddelete_wf (B : dtree) n i :
  is_redblack B Black n ->
  i < size_df B ->
  wf_dtree' B ->
  wf_dtree' (ddelete B i).
Proof.
  case: n => [|n].
    case: B => [[]// [[]//???|s1] [n1 o1] [[]//???|s2]|s] //=.
      rewrite size_cat => _ Hi wf.
      apply /wf_dtree_dtree' /delete_from_leaves_wf => //; by decomp wf.
    move=> _ Hi Hs; rewrite size_delete //.
    by rewrite (ltn_predK Hi) ltnW.
  case: B => // c l [s o] r rb Hi wf.
  apply /wf_dtree_dtree' /(@ddel_wf _ n.+1); by rewrite // dsizeE'.
Qed.

End ddelete.

Section example.
Definition t : dtree :=
  Bnode Black
        (Bleaf _ [:: true; false; false])
        (3, 1)
        (Bnode Red
               (Bleaf _ [:: true; false; true])
               (3, 2)
               (Bleaf _ [:: true; true; true; true])).
Example drank_t : drank t 10 = 7. Proof. by []. Qed.
Example dselect1_t : dselect_1 t 7 = 10. Proof. by []. Qed.
Example dselect0_t : dselect_0 t 3 = 5. Proof. by []. Qed.
Example dinsert_t :
  dinsert 5 (* upper bound *) t false 9 =
  Bnode Black
        (Bnode Black
               (Bleaf _ [:: true; false; false])
               (3, 1)
               (Bleaf _ [:: true; false; true]))
        (6, 3)
        (Bnode Black
               (Bleaf _ [:: true; true])
               (2, 2)
               (Bleaf _ [:: true; false; true])).
Proof. by []. Qed.
Example ddelete_t :
  ddelete 3 (* lower bound *) t 2 =
  Bnode Black
        (Bleaf _ [:: true; false; true; false; true])
        (5, 3)
        (Bleaf _ [:: true; true; true; true]).
Proof. by []. Qed.
End example.

Section eq_btree.

Variables D A : eqType.

Fixpoint eq_btree (t1 t2 : btree D A) :=
  match t1,t2 with
  | Bleaf a, Bleaf b => a == b
  | Bnode c1 l1 d1 r1, Bnode c2 l2 d2 r2 =>
    (d1 == d2) && (c1 == c2) && (eq_btree l1 l2) && (eq_btree r1 r2)
  | Bnode _ _ _ _, Bleaf _
  | Bleaf _, Bnode _ _ _ _ => false
  end.

Lemma eq_dtree_refl (t : btree D A) : eq_btree t t.
Proof. elim t => [? l H1 ? r H2 /=|a //=]; by rewrite H1 H2 !eq_refl. Qed.

Lemma eq_dtree_iff t1 t2 : t1 = t2 <-> eq_btree t1 t2.
Proof.
  split => [->|]; first by rewrite eq_dtree_refl.
  move: t1 t2;
    elim => [? l1 lH1 ? r1 rH1|?]; elim => [? l2 lH2 ? r2 rH2 H|?] //;
  last by move/eqP => /= ->.
  move/andP: H; case; move/andP; case;
    move/andP; case; move/eqP => ->; move/eqP => -> H1 H2.
  by rewrite (lH1 _ H1) (rH1 _ H2).
Qed.

Lemma btree_eqP : Equality.axiom eq_btree.
Proof.
  move; case => [? l1 ? r1 |?]; case => [? l2 ? r2|?] //;
  set b:= (eq_btree _ _); case Hb : b; subst b;
  try (apply ReflectT; apply eq_dtree_iff => //); try apply ReflectF => //.
   by case => H1 H2 H3 H4; move: Hb; rewrite H1 H2 H3 H4 eq_dtree_refl.
  by case => H1; move: Hb; rewrite H1 eq_dtree_refl.
Qed.

Canonical btree_eqMixin := EqMixin btree_eqP.
Canonical btree_eqType := Eval hnf in EqType (btree D A) btree_eqMixin.

End eq_btree.


Require Import Category Functor Transform Equality ProofIrrelevance FunctionalExtensionality.

Module Comma.

Set Implicit Arguments.

Class comma_ob {A B C : Category} (S : A → C) (T : B → C) := {
    dom : [A];
    cod : [B];
    mph : ob[S] dom ~> ob[T] cod;
}.

Notation "dom[ c ]" := (@dom _ _ _ _ _ c) (at level 9).
Notation "cod[ c ]" := (@cod _ _ _ _ _ c) (at level 9).
Notation "mph[ c ]" := (@mph _ _ _ _ _ c) (at level 9).

Class comma_mph {A B C : Category} {S : A → C} {T : B → C} (t t' : comma_ob S T) := {
    source_mph : dom[t] ~> dom[t'];
    target_mph : cod[t] ~> cod[t'];
    commute : hom[S] source_mph >> mph[t'] = mph[t] >> hom[T] target_mph;
}.

Notation "source[ f ]" := (@source_mph _ _ _ _ _ _ _ f) (at level 9).
Notation "target[ f ]" := (@target_mph _ _ _ _ _ _ _ f) (at level 9).
Notation "commute[ f ]" := (@commute _ _ _ _ _ _ _ f) (at level 9).

Lemma comma_hom_simpl_eq {A B C: Category} {S: A → C} {T: B → C} {t t': comma_ob S T} (f g: comma_mph t t') :
    source[f] = source[g] -> target[f] = target[g] -> f = g.
destruct f, g. simpl.
intros eS eT.
destruct eS, eT.
assert (eC: commute0 = commute1).
apply proof_irrelevance.
now destruct eC.
Qed.

Program Definition comma_id {A B C: Category} {S: A → C} {T: B → C} (c: comma_ob S T) := {|
    source_mph := id (dom[c]);
    target_mph := id (cod[c]);
|}.
Next Obligation.
now rewrite !f_id_distr, cat_id_l, cat_id_r.
Defined.

Program Definition comma_comp {A B C: Category} {S: A → C} {T: B → C} {r s t: comma_ob S T}
    (f: comma_mph r s) (g: comma_mph s t) :=
{|
    source_mph := source[f] >> source[g];
    target_mph := target[f] >> target[g];
|}.
Next Obligation.
rewrite !f_commute.
rewrite <-cat_comp_assoc, cat_comp_assoc.
rewrite <-(commute[f]), (commute[g]).
now rewrite cat_comp_assoc.
Qed.

Lemma comma_id_r {A B C: Category} {S: A → C} {T: B → C} {s t: comma_ob S T} (f: comma_mph s t) : comma_comp f (comma_id _) = f.
apply comma_hom_simpl_eq ; simpl ; now rewrite cat_id_r.
Qed.

Lemma comma_id_l {A B C: Category} {S: A → C} {T: B → C} {s t: comma_ob S T} (f: comma_mph s t) : comma_comp (comma_id _) f = f.
apply comma_hom_simpl_eq ; simpl ; now rewrite cat_id_l.
Qed.

Lemma comma_comp_assoc {A B C: Category} {S: A → C} {T: B → C} {q r s t: comma_ob S T}
    (f: comma_mph q r) (g: comma_mph r s) (h: comma_mph s t) : comma_comp (comma_comp f g) h = comma_comp f (comma_comp g h).
apply comma_hom_simpl_eq ; simpl ; now rewrite cat_comp_assoc.
Qed.

End Comma.

Definition comma_cat {A B C: Category} (S: A → C) (T: B → C) : Category.
apply (Build_Category (Comma.comma_ob S T) Comma.comma_mph (fun x => Comma.comma_id x) (fun _ _ _ x y => Comma.comma_comp x y)) ; intros.
- apply Comma.comma_id_r.
- apply Comma.comma_id_l.
- apply Comma.comma_comp_assoc.
Defined.

(* Need shortcuts to be really usable *)
Definition cone_cat {I C: Category} (D: I → C) : Category := comma_cat delta_functor (unit_curry D).

(*
    Here, an object in cone_cat D is a triple (c : [C], unit, t : Δc ⥰ D)
    Let's make sure we can retrieve this data easily
*)
Definition cone_base {I C: Category} {D: I → C} (d : [cone_cat D]) : [C] := @Comma.dom _ _ _ _ _ d.
Definition cone_transform {I C: Category} {D: I → C} (d : [cone_cat D]) : Δ[cone_base d] ⇒ D := @Comma.mph _ _ _ _ _ d.

Lemma cone_naturality {I C: Category} {D: I → C} {i j : [I]} (d : [cone_cat D]) (u : i ~> j) :
    tf[cone_transform d] i >> hom[D] u = tf[cone_transform d] j.
Proof.
rewrite <- (nat[cone_transform d, u]). simpl. now rewrite cat_id_l.
Qed.

Program Definition construct_cone_transform {I C: Category} {D: I → C}
    (c : [C]) (tf : forall i : [I], c ~> ob[D] i)
    (nat : forall i j, forall u : i ~> j, tf i >> hom[D] u = tf j) : Δ[c] ⇒ D := {|
        transform := tf;
    |}.
Next Obligation.
rewrite cat_id_l. apply eq_sym. apply (nat a b f).
Defined.

Program Definition construct_cone {I C: Category} {D: I → C}
    (base : [C]) (tf : forall i : [I], base ~> ob[D] i)
    (nat : forall i j, forall u : i ~> j, tf i >> hom[D] u = tf j) : [cone_cat D] := {|
        Comma.dom := base;
        Comma.cod := tt;
    |}.
Next Obligation.
exact (construct_cone_transform base tf nat).
Defined.

(* A morphism of cone is morally a morphism in the category C s.t. all triangles commute *)
Program Definition morphism_to_cone_morphism {I C: Category} {D: I → C} (p1 p2 : [cone_cat D]) (f : cone_base p1 ~> cone_base p2)
(nat : forall i : [I], tf[cone_transform p1] i = f >> tf[cone_transform p2] i) : p1 ~> p2 := {|
    Comma.source_mph := f;
    Comma.target_mph := tt;
|}.
Next Obligation.
rewrite id_transform_id_r. apply transform_simpl_eq. apply functional_extensionality_dep. intro.
unfold compose_transform. simpl. specialize (nat x). unfold constant_transform_tf. apply eq_sym. assumption.
Defined.

Definition cone_mph_to_induced_mph {I C: Category} {D: I → C} {p1 p2 : [cone_cat D]} (phi : p1 ~> p2) :
    (cone_base p1 ~> cone_base p2) := @Comma.source_mph _ _ _ _ _ p1 p2 phi.

Lemma same_cone_morphism_same_induced_morphism {I C: Category} {D: I → C} (p1 p2 : [cone_cat D]) (phi phi' : p1 ~> p2) :
    phi = phi' -> cone_mph_to_induced_mph phi = cone_mph_to_induced_mph phi'.
Proof.
intro. now rewrite H.
Qed.


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

 We show that the functor `∫ F ⟶ C` is a Street opfibration

 *******************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Setcategories.
Require Import UniMath.CategoryTheory.DisplayedCats.StreetOpFibration.
Require Import UniMath.CategoryTheory.categories.CategoryOfSetCategories.
Require Import UniMath.CategoryTheory.GrothendieckConstruction.TotalCategory.
Require Import UniMath.CategoryTheory.GrothendieckConstruction.Projection.

Local Open Scope cat.

Section IsOpcartesianTotalSetCategory.
  Context {C : setcategory}
          (G : C ⟶ cat_of_setcategory)
          {e₁ e₂ : total_setcategory_of_set_functor G}
          {f : e₁ --> e₂}
          (Hf : is_z_isomorphism (pr2 f)).

  Section Factorization.
    Context {e₃ : total_setcategory_of_set_functor G}
            (g : e₁ --> e₃)
            (h : pr1 e₂ --> pr1 e₃)
            (p : pr1 g = pr1 f · h).

    Definition is_opcartesian_total_setcategory_of_set_functor_factor_unique
      : isaprop
          (∑ φ, # (pr1_total_category_of_set_functor G) φ = h
               ×
               f · φ = g).
    Proof.
      use invproofirrelevance.
      intros φ₁ φ₂.
      use subtypePath.
      {
        intro.
        apply isapropdirprod ; apply homset_property.
      }
      use eq_mor_category_of_set_functor.
      - exact (pr12 φ₁ @ !(pr12 φ₂)).
      - pose (q := eq_mor_category_of_set_functor_pr2 (pr22 φ₁ @ !(pr22 φ₂))).
        cbn in q.
        use (cancel_z_iso'
               (# (pr1 (# G (pr11 φ₁))) (pr2 f) ,, _)).
        {
          cbn.
          apply functor_on_is_z_isomorphism.
          exact Hf.
        }
        cbn.
        use (cancel_z_iso'
               (idtoiso
                  (eq_in_set_fiber (functor_comp G (pr1 f) (pr11 φ₁)) (pr2 e₁)))).
        rewrite !assoc.
        refine (q @ _) ; clear q.
        rewrite !assoc.
        apply maponpaths_2.
        rewrite !assoc'.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          apply maponpaths_2.
          apply (from_eq_cat_of_setcategory
                   (maponpaths (λ z, #G z) (pr12 φ₁ @ !(pr12 φ₂)))
                   (pr2 f)).
        }
        rewrite !assoc'.
        etrans.
        {
          do 3 apply maponpaths.
          etrans.
          {
            refine (!_).
            apply (pr1_idtoiso_concat
                     (maponpaths
                      (λ z, (pr11 z) (pr2 e₂))
                      (!(maponpaths
                           (λ z, # G z)
                           (pr12 φ₁ @ ! pr12 φ₂))))).
          }
          apply setcategory_refl_idtoiso.
        }
        rewrite id_right.
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          refine (!_).
          apply pr1_idtoiso_concat.
        }
        refine (!_).
        etrans.
        {
          refine (!_).
          exact (pr1_idtoiso_concat
                   _
                   (eq_in_set_fiber (functor_comp G (pr1 f) (pr11 φ₂)) (pr2 e₁))).
        }
        apply setcategory_eq_idtoiso.
    Qed.

    Definition is_opcartesian_total_setcategory_of_set_functor_factor_eq
      : pr1 (# G h) (pr1 (# G (pr1 f)) (pr2 e₁))
        =
        pr1 (# G (pr1 g)) (pr2 e₁).
    Proof.
      refine (!(eq_in_set_fiber (functor_comp G (pr1 f) h) (pr2 e₁)) @ _).
      apply maponpaths_2.
      do 2 apply maponpaths.
      exact (!p).
    Qed.

    Definition is_opcartesian_total_setcategory_of_set_functor_factor
      : e₂ --> e₃.
    Proof.
      refine (h ,, #(pr1 (#G h)) (inv_from_z_iso (_ ,, Hf)) · idtoiso _ · pr2 g).
      apply is_opcartesian_total_setcategory_of_set_functor_factor_eq.
    Defined.

    Definition is_opcartesian_total_setcategory_of_set_functor_factor_comm
      : f · is_opcartesian_total_setcategory_of_set_functor_factor
        =
        g.
    Proof.
      unfold is_opcartesian_total_setcategory_of_set_functor_factor.
      use eq_mor_category_of_set_functor.
      - cbn.
        exact (!p).
      - cbn.
        rewrite !assoc.
        apply maponpaths_2.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          apply maponpaths_2.
          etrans.
          {
            refine (!_).
            apply functor_comp.
          }
          etrans.
          {
            apply maponpaths.
            exact (z_iso_inv_after_z_iso (pr2 f ,, Hf)).
          }
          apply functor_id.
        }
        rewrite id_left.
        etrans.
        {
          refine (!_).
          apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp G _ _) _)).
        }
        apply setcategory_eq_idtoiso.
    Qed.
  End Factorization.

  Definition is_opcartesian_total_setcategory_of_set_functor
    : is_opcartesian_sopfib
        (pr1_total_category_of_set_functor G)
        f.
  Proof.
    intros e₃ g h p.
    use iscontraprop1.
    - exact (is_opcartesian_total_setcategory_of_set_functor_factor_unique g h).
    - simple refine (_ ,, (_ ,, _)).
      + exact (is_opcartesian_total_setcategory_of_set_functor_factor g h p).
      + abstract
          (cbn ;
           apply idpath).
      + exact (is_opcartesian_total_setcategory_of_set_functor_factor_comm g h p).
  Defined.
End IsOpcartesianTotalSetCategory.

Definition street_opfib_pr1_total_setcategory
          {C : setcategory}
          (G : C ⟶ cat_of_setcategory)
  : street_opfib
      (pr1_total_category_of_set_functor G).
Proof.
  intros x y f.
  simple refine (_ ,, (_ ,, _) ,, _ ,, _).
  - exact (y ,, pr1 (#G f) (pr2 x)).
  - exact (f ,, identity _).
  - apply identity_z_iso.
  - exact (!(id_right f)).
  - apply is_opcartesian_total_setcategory_of_set_functor.
    apply is_z_isomorphism_identity.
Defined.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime P A C D : Universe, ((wd_ O E /\ (wd_ A C /\ (wd_ P D /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ P A /\ (wd_ P C /\ (col_ P A P /\ (col_ P C D /\ col_ A P D))))))))) -> col_ P A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Add LoadPath "../from_compcert".
Require Import Libs.
Require Import Errors.
Require Import Polyhedra.
Require Import Loops.
Require Import Memory.
Require Import ArithClasses.
Require Import Permutation.
Require Import Sorted.
Require Import Instructions.
Require Import Bounds.
Require Import BoxedPolyhedra.
Require Import Psatz.
Require Import PolyBase.
Require Import PLang.
Require Import TimeStamp.
Require Import ExtractPoly.
Require Import Do_notation.
Require Import PermutInstrs.
Require Import Tilling.
Require Import SimpleLanguage.
Require Import Final.
Open Scope string_scope.
(*Set Implicit Arguments.*)
Open Scope Z_scope.

Set Implicit Arguments.

Fixpoint Midentity `{Numerical Num} n : Matrix Num n n :=
  match n with
    | O => exist _ [] eq_refl
    | S n' =>
      (1 ::: V0 n') :::
      Vmap (fun v => 0 ::: v) (Midentity n')
  end%numerical.

(*
TODO:

Lemma Midentity_correct `{Numerical Num}: forall n (v: Vector Num n),
  Midentity n × v = v.
Proof.
  induction' n as [|n]; intros.
  Case "O".
    apply PVeq_Veq. dest_vects. destruct v; clean.
  Case "S n".
    simpl.
    Vdestruct v as x v.
    specialize (IHn v).
    unfold Mprod_vect in *.

*)

Definition ZMidentity n : ZMatrix n n := Midentity n.
Definition ext_ZMidentity n : ZMatrix n (S n) :=
  Vmap (fun v => 1 ::: v) (ZMidentity n).

Unset Elimination Schemes.
Module SV := Validator BM SimpleLanguage.Instructions.
Definition optimize := SV.optimize.
Definition preservation := SV.preservation.

(* some functions to not mess up dependent types *)

Import SimpleLanguage.Instructions.

Inductive PExpression : Type :=
| PExp_const: list Z -> PExpression
| PExp_loc: Array_Id -> list (list Z) -> PExpression
| PExp_bin: PExpression -> Binary_opp -> PExpression -> PExpression
| PExp_opp: PExpression -> PExpression.

Fixpoint make_Expression n (pexp: PExpression): option (Expression n) :=
  match pexp with
  | PExp_const l =>
    do v <- make_vector (S n) l;
    Some (Exp_const v)
  | PExp_loc aid l =>
    do v <- mmap (make_vector (S n)) l;
    Some (Exp_loc (aid, v))
  | PExp_bin pl opp pr =>
    do l <- make_Expression n pl;
    do r <- make_Expression n pr;
    Some (Exp_bin l opp r)
  | PExp_opp pe =>
    do e <- make_Expression n pe;
    Some (Exp_opp  e)
  end.

Record PInstruction: Type :=
  { Pcontext_size: nat;
    Pwrite_loc: Array_Id * list (list Z);
    Pbody: PExpression;
    Pinstr_loop_vars : list ocaml_string;
    Pinstr_body_string : ocaml_string }.

Definition make_Instruction (pinstr: PInstruction): option Instruction :=
  let 'Build_PInstruction pnargs (paid, pwloc) pb lvars bstring:= pinstr in
  do wlocs <- mmap (make_vector (S pnargs)) pwloc;
  do b <- make_Expression pnargs pb;
  Some (Build_Instruction' (paid, wlocs) b lvars bstring).

Import SV.Per.Til.EP.L.
Import T.

Definition Pbound := list (Z * list Z).
Definition make_bound global_depth (pbnd: Pbound): option (bound global_depth) :=
  match pbnd with
    | [] => None
    | (z, l) :: pbnd' =>
      do v <- make_vector (S global_depth) l;
      do tl <-
        mmap (fun p: Z * list Z =>
          let (z, l) := p in
            do v <- make_vector (S global_depth) l;
            Some (z, v)) pbnd';
      Some ((z, v), tl)
  end.

Inductive Pstatement : Type :=
    PLoop : Pbound ->
            Pbound ->
            Pstatement_list -> Pstatement
  | PInstr : Instruction ->
             list (list Z) ->
             Pstatement
  with Pstatement_list  : Type :=
    Pstl_nil : Pstatement_list
  | Pstl_cons : Pstatement ->
                Pstatement_list -> Pstatement_list.

Fixpoint make_statement n (pst:Pstatement) : option (statement n) :=
  match pst with
  | PLoop plb pub pstlst =>
    do{;
      lb <- make_bound n plb;;
      ub <- make_bound n pub;;
      stlst <- make_statement_list (S n) pstlst;
      Some (Loop lb ub stlst)
    }
  | PInstr instr l =>
    do m <- make_matrix (context_size instr) (S n) l;
    Some (Instr instr m)
  end
with make_statement_list n pstlst : option (statement_list n) :=
  match pstlst with
  | Pstl_nil => Some stl_nil
  | Pstl_cons pst pstlst' =>
    do{;
      st <- make_statement n pst;;
      stlst <- make_statement_list n pstlst';
      Some (stl_cons st stlst)
    }
  end.

 Record PProgram :=
   { Pprog_nbr_global_parameters : nat;
     Pprog_main : Pstatement_list}.

 Definition make_Program pprog : option Program :=
   do stlst <- make_statement_list pprog.(Pprog_nbr_global_parameters) pprog.(Pprog_main);
   Some {| prog_nbr_global_parameters := pprog.(Pprog_nbr_global_parameters);
           prog_main := stlst|}.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C M Cprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ M A /\ (wd_ M B /\ (wd_ M C /\ (wd_ C Cprime /\ (wd_ M Cprime /\ (col_ A B Cprime /\ (col_ M A B /\ col_ M C Cprime)))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e480m2e240m1_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Export TransFunc.

Section ModelProperties.

(*This is the defintion of a secure state from the DAC security      *)
(*policy point of view.                                              *)

Definition DACSecureState (s : SFSstate) : Prop :=
  forall (u : SUBJECT) (o : OBJECT),
  match fsecmat (secmat s) o with
  | None => True
  | Some y =>
      (set_In u (ActReaders y) -> PreDACRead s u o) /\
      (set_In u (ActWriters y) -> PreDACWrite s u o)
  end.

(*This is the defintion of a secure state from the MAC security      *)
(*policy point of view. It says that an state is MAC secure if for   *)
(*each subject accesing an object, the security class of the former  *)
(*is dominates the security class of the object.                     *)

Definition MACSecureState (s : SFSstate) : Prop :=
  forall (u : SUBJECT) (o : OBJECT),
  match fsecmat (secmat s) o, fOSC (objectSC s) o, fSSC (subjectSC s) u with
  | None, _, _ => True
  | _, None, _ => True
  | _, _, None => True
  | Some x, Some y, Some z =>
      set_In u (ActReaders x) \/ set_In u (ActWriters x) -> le_sc y z
  end.

(*An state is secure if it's both DAC and MAC secure.                *)

Definition SecureState (s : SFSstate) : Prop :=
  DACSecureState s /\ MACSecureState s.

(*This is the definition of the *-property adapted from the          *)
(*Bell-LaPadula's model. It says that whenever a subject is accesing *)
(*an object for reading and, possibly, another object for writing,   *)
(*then the security class of any object that is being open for       *)
(*reading must be dominated by the security class of any             *)
(*of those objects that are already open for writing.                *)

Definition StarProperty (s : SFSstate) : Prop :=
  forall (u : SUBJECT) (o1 o2 : OBJECT),
  match
    fsecmat (secmat s) o1, fsecmat (secmat s) o2, fOSC (objectSC s) o2,
    fOSC (objectSC s) o1
  with
  | None, _, _, _ => True
  | _, None, _, _ => True
  | _, _, None, _ => True
  | _, _, _, None => True
  | Some w, Some x, Some y, Some z =>
      set_In u (ActWriters w) -> set_In u (ActReaders x) -> le_sc y z
  end.

(*We also want operations that deal securely with control            *)
(*attributes, i.e. the owners of an ACL, the security class          *)
(*associated with subjects and objects, etc.                         *)
(*Informally, the policy says that the owner of an object or a       *)
(*member of RootGrp are the only allowed to change the DAC           *)
(*control attributes associated with the object; that the members    *)
(*of SecAdmGrp are the ones that can change the MAC control          *)
(*attributes associated with subjects and objects; and that RootGrp  *)
(*must always be owner of all objects.                               *)

Inductive AclChanged : AccessCtrlListData -> AccessCtrlListData -> Prop :=
  | UR :
      forall (a : AccessCtrlListData) (b c : set SUBJECT),
      b <> c ->
      AclChanged
        (acldata (owner a) (group a) b (GroupReaders a)
           (UsersWriters a) (GroupWriters a) (UsersOwners a)
           (GroupOwners a))
        (acldata (owner a) (group a) c (GroupReaders a)
           (UsersWriters a) (GroupWriters a) (UsersOwners a)
           (GroupOwners a))
  | GR :
      forall (a : AccessCtrlListData) (b c : set GRPNAME),
      b <> c ->
      AclChanged
        (acldata (owner a) (group a) (UsersReaders a) b
           (UsersWriters a) (GroupWriters a) (UsersOwners a)
           (GroupOwners a))
        (acldata (owner a) (group a) (UsersReaders a) c
           (UsersWriters a) (GroupWriters a) (UsersOwners a)
           (GroupOwners a))
  | UW :
      forall (a : AccessCtrlListData) (b c : set SUBJECT),
      b <> c ->
      AclChanged
        (acldata (owner a) (group a) (UsersReaders a)
           (GroupReaders a) b (GroupWriters a) (UsersOwners a)
           (GroupOwners a))
        (acldata (owner a) (group a) (UsersReaders a)
           (GroupReaders a) c (GroupWriters a) (UsersOwners a)
           (GroupOwners a))
  | GW :
      forall (a : AccessCtrlListData) (b c : set GRPNAME),
      b <> c ->
      AclChanged
        (acldata (owner a) (group a) (UsersReaders a)
           (GroupReaders a) (UsersWriters a) b (UsersOwners a)
           (GroupOwners a))
        (acldata (owner a) (group a) (UsersReaders a)
           (GroupReaders a) (UsersWriters a) c (UsersOwners a)
           (GroupOwners a))
  | UO :
      forall (a : AccessCtrlListData) (b c : set SUBJECT),
      b <> c ->
      AclChanged
        (acldata (owner a) (group a) (UsersReaders a)
           (GroupReaders a) (UsersWriters a) (GroupWriters a) b
           (GroupOwners a))
        (acldata (owner a) (group a) (UsersReaders a)
           (GroupReaders a) (UsersWriters a) (GroupWriters a) c
           (GroupOwners a))
  | GO :
      forall (a : AccessCtrlListData) (b c : set GRPNAME),
      b <> c ->
      AclChanged
        (acldata (owner a) (group a) (UsersReaders a)
           (GroupReaders a) (UsersWriters a) (GroupWriters a)
           (UsersOwners a) b)
        (acldata (owner a) (group a) (UsersReaders a)
           (GroupReaders a) (UsersWriters a) (GroupWriters a)
           (UsersOwners a) c).

Inductive UNIXAttrChanged :
AccessCtrlListData -> AccessCtrlListData -> Prop :=
  | Owner :
      forall (a : AccessCtrlListData) (b c : SUBJECT),
      b <> c ->
      UNIXAttrChanged
        (acldata b (group a) (UsersReaders a) (GroupReaders a)
           (UsersWriters a) (GroupWriters a) (UsersOwners a)
           (GroupOwners a))
        (acldata c (group a) (UsersReaders a) (GroupReaders a)
           (UsersWriters a) (GroupWriters a) (UsersOwners a)
           (GroupOwners a))
  | Group :
      forall (a : AccessCtrlListData) (b c : GRPNAME),
      b <> c ->
      UNIXAttrChanged
        (acldata (owner a) b (UsersReaders a) (GroupReaders a)
           (UsersWriters a) (GroupWriters a) (UsersOwners a)
           (GroupOwners a))
        (acldata (owner a) c (UsersReaders a) (GroupReaders a)
           (UsersWriters a) (GroupWriters a) (UsersOwners a)
           (GroupOwners a)).

Inductive DACCtrlAttrHaveChanged (s t : SFSstate) (o : OBJECT) : Prop :=
  | ACL :
      forall y z : AccessCtrlListData,
      facl (acl s) o = Some y ->
      facl (acl t) o = Some z ->
      AclChanged y z -> DACCtrlAttrHaveChanged s t o
  | UNIX :
      forall y z : AccessCtrlListData,
      facl (acl s) o = Some y ->
      facl (acl t) o = Some z ->
      UNIXAttrChanged y z -> DACCtrlAttrHaveChanged s t o.

Inductive SecClassChanged : SecClass -> SecClass -> Prop :=
  | Level :
      forall (a : SecClass) (b c : set CATEGORY),
      b <> c -> SecClassChanged (sclass (level a) b) (sclass (level a) c)
  | Categ :
      forall (a : SecClass) (b c : SECLEV),
      b <> c -> SecClassChanged (sclass b (categs a)) (sclass c (categs a)).

Inductive MACObjCtrlAttrHaveChanged (s t : SFSstate) (o : OBJECT) : Prop :=
    SCo :
      forall x y : SecClass,
      fOSC (objectSC s) o = Some x ->
      fOSC (objectSC t) o = Some y ->
      SecClassChanged x y -> MACObjCtrlAttrHaveChanged s t o.

Inductive MACSubCtrlAttrHaveChanged (s t : SFSstate) (u : SUBJECT) : Prop :=
    SCu :
      forall x y : SecClass,
      fSSC (subjectSC s) u = Some x ->
      fSSC (subjectSC t) u = Some y ->
      SecClassChanged x y -> MACSubCtrlAttrHaveChanged s t u.

Definition ControlProperty (u : SUBJECT) (s t : SFSstate) : Prop :=
  (forall o : OBJECT,
   (DACCtrlAttrHaveChanged s t o -> ExecuterIsOwner s u o) /\
   (MACObjCtrlAttrHaveChanged s t o -> set_In u (groups s (SecAdmGrp s)))) /\
  (forall u0 : SUBJECT,
   MACSubCtrlAttrHaveChanged s t u0 -> set_In u (groups s (SecAdmGrp s))).

Definition PreservesControlProp (s : SFSstate) (op : Operation)
  (t : SFSstate) : Prop :=
  forall u : SUBJECT, TransFunc u s op t -> ControlProperty u s t.

(*Well-formedness system invariants.                                     *)
Axiom
  WFSI1 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (u : SUBJECT),
    (forall o : OBJECT,
     set_In o (DOM OBJeq_dec (files s)) -> ObjType o = File) ->
    TransFunc u s op t ->
    forall o : OBJECT, set_In o (DOM OBJeq_dec (files t)) -> ObjType o = File.

Axiom
  WFSI2 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (u : SUBJECT),
    (forall o : OBJECT,
     set_In o (DOM OBJeq_dec (directories s)) -> ObjType o = Directory) ->
    TransFunc u s op t ->
    forall o : OBJECT,
    set_In o (DOM OBJeq_dec (directories t)) -> ObjType o = Directory.

Axiom
  WFSI3 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (u : SUBJECT),
    DOM OBJeq_dec (acl s) =
    set_union OBJeq_dec (DOM OBJeq_dec (files s))
      (DOM OBJeq_dec (directories s)) ->
    TransFunc u s op t ->
    DOM OBJeq_dec (acl t) =
    set_union OBJeq_dec (DOM OBJeq_dec (files t))
      (DOM OBJeq_dec (directories t)).

Definition FuncPre1 (s : SFSstate) : Prop :=
  (forall o : OBJECT,
   set_In o (DOM OBJeq_dec (directories s)) -> ObjType o = Directory) /\
  (forall o : OBJECT, set_In o (DOM OBJeq_dec (files s)) -> ObjType o = File) /\
  DOM OBJeq_dec (acl s) =
  set_union OBJeq_dec (DOM OBJeq_dec (files s))
    (DOM OBJeq_dec (directories s)).

Axiom
  WFSI4 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (u : SUBJECT),
    DOM OBJeq_dec (acl s) = DOM OBJeq_dec (objectSC s) ->
    TransFunc u s op t -> DOM OBJeq_dec (acl t) = DOM OBJeq_dec (objectSC t).

Definition FuncPre2 (s : SFSstate) : Prop :=
  DOM OBJeq_dec (acl s) = DOM OBJeq_dec (objectSC s).

Axiom
  WFSI5 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (u : SUBJECT),
    Included (DOM OBJeq_dec (secmat s)) (DOM OBJeq_dec (acl s)) ->
    TransFunc u s op t ->
    Included (DOM OBJeq_dec (secmat t)) (DOM OBJeq_dec (acl t)).

Definition FuncPre3 (s : SFSstate) : Prop :=
  Included (DOM OBJeq_dec (secmat s)) (DOM OBJeq_dec (acl s)).

Axiom
  WFSI6 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (u : SUBJECT),
    IsPARTFUNC OBJeq_dec (acl s) ->
    TransFunc u s op t -> IsPARTFUNC OBJeq_dec (acl t).

Definition FuncPre4 (s : SFSstate) : Prop := IsPARTFUNC OBJeq_dec (acl s).

Axiom
  WFSI7 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (u : SUBJECT),
    IsPARTFUNC OBJeq_dec (secmat s) ->
    TransFunc u s op t -> IsPARTFUNC OBJeq_dec (secmat t).

Definition FuncPre5 (s : SFSstate) : Prop := IsPARTFUNC OBJeq_dec (secmat s).

Axiom
  WFSI8 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (u : SUBJECT),
    IsPARTFUNC OBJeq_dec (objectSC s) ->
    TransFunc u s op t -> IsPARTFUNC OBJeq_dec (objectSC t).

Definition FuncPre6 (s : SFSstate) : Prop :=
  IsPARTFUNC OBJeq_dec (objectSC s).

Axiom
  WFSI9 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (u : SUBJECT),
    IsPARTFUNC SUBeq_dec (subjectSC s) ->
    TransFunc u s op t -> IsPARTFUNC SUBeq_dec (subjectSC t).

Definition FuncPre7 (s : SFSstate) : Prop :=
  IsPARTFUNC SUBeq_dec (subjectSC s).

End ModelProperties.

Hint Unfold SecureState DACSecureState MACSecureState ControlProperty
  PreservesControlProp.

Hint Resolve UR GR UW GW UO GO Owner Group Level Categ.
Hint Resolve WFSI1 WFSI2 WFSI3 WFSI4 WFSI5 WFSI6 WFSI7 WFSI8 WFSI9.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e416m2e208m1_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e448m2e224m1_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.