From Equations Require Import Equations.
From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import eqtype ssrnat prime order seq path.
From favssr Require Import prelude bintree bst adt.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import Order.POrderTheory.
Import Order.TotalTheory.
Open Scope order_scope.

Section Intro.
Context {A : Type}.

Variant col := Red | Black.

Definition eqcol (c1 c2 : col) :=
  match c1, c2 with
  | Red, Red => true
  | Black, Black => true
  | _, _ => false
  end.

Lemma eqcolP : Equality.axiom eqcol.
Proof. by move; case; case; constructor. Qed.

Canonical col_eqMixin := EqMixin eqcolP.
Canonical col_eqType := Eval hnf in EqType col col_eqMixin.

Definition rbt A := tree (A * col).

Definition R l a r : rbt A := Node l (a, Red) r.
Definition B l a r : rbt A := Node l (a, Black) r.

Definition color (t : rbt A) : col :=
  if t is Node _ (_, c) _ then c else Black.

Definition paint (c : col) (t : rbt A) : rbt A :=
  if t is Node l (a, _) r then Node l (a,c) r else leaf.

Lemma paint2 c1 c2 t : paint c2 (paint c1 t) = paint c2 t.
Proof. by case: t=>//= l [a c] r. Qed.

Lemma paint_black t : color (paint Black t) = Black.
Proof. by case: t=>//= l [a c] r. Qed.

End Intro.

Section Invariants.
Context {A : Type}.

(* red nodes must have black children *)

Fixpoint invc (t : rbt A) : bool :=
  if t is Node l (_, c) r
    then [&& ((c == Red) ==> (color l == Black) && (color r == Black)), invc l & invc r]
    else true.

(* all paths from the root to a leaf have the same number of black nodes *)

Fixpoint bh (t : rbt A) : nat :=
  if t is Node l (_, c) _ then bh l + (c == Black) else 0.

Fixpoint invh (t : rbt A) : bool :=
  if t is Node l _ r
    then [&& bh l == bh r, invh l & invh r]
    else true.

Lemma invh_paint c t : invh t -> invh (paint c t).
Proof. by case: t=>//=l [a c'] r. Qed.

Lemma bh_paint_red t :
  color t = Black -> bh (paint Red t) = bh t - 1.
Proof.
case: t=>//= l [a c] r -> /=.
by rewrite addn0 addnK.
Qed.

Lemma bh_gt0 t : t <> leaf -> color t = Black -> (0 < bh t)%N.
Proof. by case: t=>//=l [a c] r _ -> /=; rewrite addn1. Qed.

(* TODO separate induction principles for invc/invh? *)
Definition invch (t : rbt A) : bool := invc t && invh t.

Lemma invch_ind (P : rbt A -> Prop) :
  P (Leaf (A*col)) ->
  (forall l a c r,
   (c == Red) ==> (color l == Black) && (color r == Black) -> invc l -> invc r ->
   bh l == bh r -> invh l -> invh r ->
   P l -> P r ->
   P (Node l (a,c) r)) ->
  forall t, invch t -> P t.
Proof.
move=>Pl Pn; elim=>//= l IHl [a c] r IHr /andP [/and3P [I Hcl Hcr] /and3P [E Hhl Hhr]].
by apply: Pn=>//; [apply: IHl| apply: IHr]; apply/andP; split.
Qed.

Arguments invch_ind [P].

Definition rbt_inv (t : rbt A) : bool :=
  invch t && (color t == Black).

(* Logarithmic Height *)

Lemma height_black_height t :
  invch t -> (height t <= 2 * bh t + (color t == Red))%N.
Proof.
elim/invch_ind=>{t}//=l _ c r H1 Hcl Hcr /eqP E Hhl Hhr Hl Hr.
case: c H1=>/= [/andP [/eqP Hcll /eqP Hclr]|_].
- rewrite Hcll E /= addn0 in Hl *; rewrite Hclr /= addn0 in Hr.
  by rewrite leq_add2r addn0 geq_max Hl Hr.
rewrite addn0 mulnDr muln1 {2}(_ : 2 = 1 + 1) // addnA leq_add2r geq_max.
apply/andP; split.
- by apply: (leq_trans Hl); rewrite leq_add2l; case: eqP.
by apply: (leq_trans Hr); rewrite E leq_add2l; case: eqP.
Qed.

Corollary bound_bht t :
  rbt_inv t -> (height t)./2 <= bh t.
Proof.
case/andP=>Hch /eqP Hb.
rewrite -(doubleK (bh t)); apply: half_leq; rewrite -muln2 mulnC.
by move: (height_black_height Hch); rewrite Hb /= addn0.
Qed.

Lemma bh_size1 t :
  invch t -> (2 ^ (bh t) <= size1_tree t)%N.
Proof.
elim/invch_ind=>{t}//=l _ c r _ _ _ /eqP E _ _ Hl Hr.
case: c=>/=; first by rewrite addn0; apply/(leq_trans Hl)/leq_addr.
rewrite expnD expn1 muln2 -addnn; apply: leq_add=>//.
by rewrite E.
Qed.

Lemma rbt_log_height t :
  rbt_inv t -> ((height t)./2 <= up_log 2 (size1_tree t))%N.
Proof.
move=>/[dup] H; case/andP=>[H12 _]; apply: leq_trans; first by exact: bound_bht.
rewrite -(@leq_exp2l 2 _ _ (isT : 1%N < 2)).
by apply/(leq_trans (bh_size1 H12))/up_logP.
Qed.

End Invariants.

Arguments invch_ind [A P].

Section SetImplementation.
Context {disp : unit} {T : orderType disp}.

(* insertion *)

Equations baliL : rbt T -> T -> rbt T -> rbt T :=
baliL (Node (Node t1 (a, Red) t2) (b, Red)  t3                  ) c t4 => R (B t1 a t2) b (B t3 c t4);
baliL (Node  t1                   (a, Red) (Node t2 (b, Red) t3)) c t4 => R (B t1 a t2) b (B t3 c t4);
baliL        tl                                                   a tr => B tl a tr.

Equations baliR : rbt T -> T -> rbt T -> rbt T :=
baliR t1 a (Node       t2              (b, Red) (Node t3 (c, Red) t4)) => R (B t1 a t2) b (B t3 c t4);
baliR t1 a (Node (Node t2 (b, Red) t3) (c, Red)       t4)              => R (B t1 a t2) b (B t3 c t4);
baliR tl a             tr                                              => B tl a tr.

Fixpoint ins (x : T) (t : rbt T) : rbt T :=
  match t with
  | Leaf => R leaf x leaf
  | Node l (a, Black) r => match cmp x a with
                           | LT => baliL (ins x l) a r
                           | EQ => B l a r
                           | GT => baliR l a (ins x r)
                           end
  | Node l (a, Red) r => match cmp x a with
                         | LT => R (ins x l) a r
                         | EQ => R l a r
                         | GT => R l a (ins x r)
                         end
  end.

Definition insert x t := paint Black (ins x t).

(* a weaker version of invc *)

Definition invc2 (t : rbt T) := invc (paint Black t).

Lemma invc2I t : invc t -> invc2 t.
Proof. by rewrite /invc2; case: t=>//=l [a c] r /= /and3P [_ ->->]. Qed.

Lemma invc_baliL l a r :
  invc2 l -> invc r -> invc (baliL l a r).
Proof.
rewrite /invc2.
funelim (baliL l a r); simp baliL=>/= /[swap] ->; rewrite !andbT //.
- by case/and3P=>_->->.
- by case/andP; case/and3P=>_->->->.
by case/and4P; case/andP=>->->_->->.
Qed.

Lemma bh_baliL l a r :
  bh l == bh r -> bh (baliL l a r) == bh l + 1.
Proof. by funelim (baliL l a r); simp baliL=>//=; rewrite !addn0. Qed.

Lemma invh_baliL l a r :
  invh l -> invh r -> bh l == bh r ->
  invh (baliL l a r).
Proof.
funelim (baliL l a r); simp baliL=>/= /[swap] ->; rewrite !andbT ?addn0 //.
- by case/and4P=>/eqP<-/eqP<- ->->->; rewrite !eq_refl.
- by case/and4P; rewrite addn1.
- by case/andP=>->->->.
- by case/and3P=>/eqP->/and3P [/eqP->->->] ->->; rewrite !eq_refl.
- by case/and3P=>->/and3P[->->->]->->.
- by case/and3P; rewrite addn1.
- by case/and5P=>/eqP<-/and3P[/eqP->->->] /eqP<- ->->->; rewrite !eq_refl.
- by case/and5P=>->/and3P [->->->] ->->->->.
by case/and3P=>->/and3P[->->->]->->.
Qed.

Lemma invc_baliR l a r :
  invc l -> invc2 r -> invc (baliR l a r).
Proof.
rewrite /invc2; funelim (baliR l a r); simp baliR=>/=->//.
- by rewrite andbT; case/and3P=>_->->.
- by case/and4P=>-> _ ->->.
by case/and3P=>/and3P [_->->]->->.
Qed.

Lemma bh_baliR l a r :
  bh l == bh r -> bh (baliR l a r) == bh l + 1.
Proof. by funelim (baliR l a r); simp baliR=>//=; rewrite !addn0. Qed.

Lemma invh_baliR l a r :
  invh l -> invh r -> bh l == bh r ->
  invh (baliR l a r).
Proof.
funelim (baliR l a r); simp baliR=>/=->/=; rewrite ?andbT ?addn0 //.
- by case/and4P=>/eqP->/eqP<-->->/eqP->; rewrite !eq_refl.
- by case/and4P; rewrite addn1.
- by case/and5P=>/eqP->->/eqP->->->/eqP->; rewrite !eq_refl.
- by case/and4P; rewrite addn1.
- by case/and5P=>/eqP->/and3P [/eqP<- ->->] /eqP->->->/eqP->; rewrite !eq_refl.
- by case/and5P=>->/and3P [->->->] ->->->->.
by case/and3P=>->->->->.
Qed.

Lemma invc_ins x t :
  invc t ->
  invc2 (ins x t) && ((color t == Black) ==> invc (ins x t)).
Proof.
elim: t=>//= l IHl [a c] r IHr /and3P [E Hl Hr].
case/andP: (IHl Hl)=>{IHl} H2l Hil; case/andP: (IHr Hr)=>{IHr} H2r Hir.
case: c E=>/= [/andP [Hcll Hclr]|_].
- rewrite {}Hcll /= in Hil; rewrite {}Hclr /= in Hir.
  rewrite andbT; case: (cmp x a); rewrite /invc2 /=.
  - by rewrite Hil Hr.
  - by rewrite Hl Hr.
  by rewrite Hl Hir.
case: (cmp x a)=>/=.
- suff: invc (baliL (ins x l) a r) by move/[dup]/invc2I=>->->.
  by apply: invc_baliL.
- by rewrite /invc2 /= Hl Hr.
suff: invc (baliR l a (ins x r)) by move/[dup]/invc2I=>->->.
by apply: invc_baliR.
Qed.

Lemma invh_ins x t :
  invh t ->
  invh (ins x t) && (bh (ins x t) == bh t).
Proof.
elim: t=>//= l IHl [a c] r IHr /and3P [/eqP E Hl Hr].
case/andP: (IHl Hl)=>{IHl} H2l Hil; case/andP: (IHr Hr)=>{IHr} H2r Hir.
case: c=>/=; case: (cmp x a)=>/=; rewrite ?addn0.
- by rewrite -E Hil H2l Hr.
- by rewrite E Hl Hr eq_refl.
- by rewrite E eq_sym Hir Hl H2r eq_refl.
- apply/andP; split.
  - by apply: invh_baliL=>//; rewrite -E.
  by rewrite -(eqP Hil); apply: bh_baliL; rewrite -E.
- by rewrite E Hl Hr !eq_refl.
apply/andP; split.
- by apply: invh_baliR=>//; rewrite eq_sym E.
by apply: bh_baliR; rewrite eq_sym E.
Qed.

Corollary inv_insert x t : invch t -> invch (insert x t).
Proof.
rewrite /invch /insert; case/andP=>Hc Hh.
case/andP: (invc_ins x Hc); rewrite /invc2=>-> _ /=.
by rewrite invh_paint //; case/andP: (invh_ins x Hh).
Qed.

Corollary rbt_insert x t : rbt_inv t -> rbt_inv (insert x t).
Proof.
rewrite /rbt_inv /insert paint_black eq_refl andbT.
by case/andP=>/(inv_insert x).
Qed.

(* deletion by replacing *)

Equations baldL : rbt T -> T -> rbt T -> rbt T :=
baldL (Node t1 (a, Red) t2) b  t3                                          => R (B t1 a t2) b t3;
baldL       t1              a (Node t2                      (b, Black) t3) => baliR t1 a (R t2 b t3);
baldL       t1              a (Node (Node t2 (b, Black) t3) (c, Red)   t4) => R (B t1 a t2) b (baliR t3 c (paint Red t4));
baldL       tl              a       tr                                     => R tl a tr.

Equations baldR : rbt T -> T -> rbt T -> rbt T :=
baldR  t1                                        a (Node t2 (b, Red) t3) => R t1 a (B t2 b t3);
baldR (Node t1 (a, Black) t2)                    b  t3                   => baliL (R t1 a t2) b t3;
baldR (Node t1 (a, Red) (Node t2 (b, Black) t3)) c  t4                   => R (baliL (paint Red t1) a t2) b (B t3 c t4);
baldR       tl                                   a  tr                   => R tl a tr.

Fixpoint split_min (l : rbt T) (a : T) (r : rbt T) : T * rbt T :=
  if l is Node l' (a', c') r'
    then let: (x, m) := split_min l' a' r' in
         (x, if c' == Black then baldL m a r else R m a r)
    else (a, r).

Fixpoint del (x : T) (t : rbt T) : rbt T :=
  if t is Node l (a, _) r then
    match cmp x a with
    | LT => let l' := del x l in
            if (l != leaf) && (color l == Black) then baldL l' a r else R l' a r
    | EQ => if r is Node lr (ar, _) rr
            then let: (a', r') := split_min lr ar rr in
                 if color r == Black then baldR l a' r' else R l a' r'
            else l
    | GT => let r' := del x r in
            if (r != leaf) && (color r == Black) then baldR l a r' else R l a r'
    end
    else leaf.

Definition delete x t := paint Black (del x t).

Lemma invh_baldL_invc l a r :
  invh l -> invh r -> bh l + 1 == bh r -> invc r ->
  invh (baldL l a r) && (bh (baldL l a r) == bh r).
Proof.
funelim (baldL l a r); simp baldL=>//=; rewrite ?addn0.
- move=>_ /and3P [E24 /and3P [E23 -> H3] H4].
  rewrite eqn_add2r=>E /and3P [/eqP Ec _ _]; rewrite E /= andbT.
  have H': bh t3 == bh (paint Red t4).
  - by rewrite bh_paint_red // -(eqP E23) -(eqP E24) addnK.
  apply/andP; split.
  - rewrite eq_sym; have {1}->: (0%N = bh t3) by rewrite -(eqP E23) (eqP E).
    by apply: bh_baliR.
  by apply: invh_baliR=>//; rewrite invh_paint.
- move=>_ H; rewrite eqn_add2r=>E /andP [Hc2 Hc3].
  apply/andP; split; first by apply: invh_baliR=>//=; rewrite addn0.
  have->: bh t2 = bh (Leaf (T * col)) by rewrite /= -(eqP E).
  by apply: bh_baliR=>/=; rewrite addn0.
- by move=>->->->.
- by move=>_ _; rewrite addn1.
- by move=>_ _; rewrite addn1.
- move=>-> /and3P [E24 /and3P [E23 -> H3] H4].
  rewrite eqn_add2r=>E /and3P [/eqP Ec _ _]; rewrite E /= andbT.
  have H': bh t3 == bh (paint Red t4).
  - by rewrite bh_paint_red // -(eqP E23) -(eqP E24) addnK.
  apply/andP; split.
  - by rewrite eq_sym (eqP E) (eqP E23); apply: bh_baliR.
  by apply: invh_baliR=>//; rewrite invh_paint.
move=>H H2; rewrite eqn_add2r=>E2; case/andP=>Hc2 Hc3.
apply/andP; split; first by apply: invh_baliR=>//=; rewrite addn0.
have->: bh t2 = bh (Node t (s0, Black) t0)by  rewrite /= -(eqP E2).
by apply: bh_baliR=>/=; rewrite addn0.
Qed.

Lemma invc2_baldL l a r :
  invc2 l -> invc r -> invc2 (baldL l a r).
Proof.
funelim (baldL l a r); simp baldL; rewrite /invc2 =>//=.
- move=>_ /and3P [_ /andP [-> H3] H4] /=.
  by apply: invc_baliR=>//; rewrite /invc2 paint2; apply/invc2I.
- by move=>_ H; apply/invc2I/invc_baliR.
- by move=>->->.
- by move=>->.
- by move=>->->.
- move=>-> /and3P [_ /andP [-> H3] H4] /=.
  by apply: invc_baliR=>//; rewrite /invc2 paint2; apply: invc2I.
by move=>H1 H2; apply/invc2I/invc_baliR.
Qed.

Lemma invc_baldL l a r :
  invc2 l -> invc r -> color r == Black -> invc (baldL l a r).
Proof.
funelim (baldL l a r); simp baldL; rewrite /invc2 =>//=.
- by move=>_ H _; apply: invc_baliR.
- by move=>->->->.
- by move=>->.
by move=>H1 H2 _; apply: invc_baliR.
Qed.

Lemma invh_baldR_invc l a r :
  invh l -> invh r -> bh l == bh r + 1 -> invc l ->
  invh (baldR l a r) && (bh (baldR l a r) == bh l).
Proof.
funelim (baldR l a r); simp baldR=>//=; rewrite ?andbT ?addn0.
- by case/andP=>->->; rewrite eq_refl.
- by move=>_ _ _; case/and5P; case/andP.
- case/and5P=>E12 H1 /eqP <- H2 -> _ E1 /and4P [/eqP Ec _ _ _].
  rewrite (eqP E12) eqn_add2r in E1.
  rewrite E1 /= andbT andbC (eqP E12) andbA andbb.
  have E' : bh (paint Red t1) = bh t2 by rewrite bh_paint_red // (eqP E12) addnK.
  apply/andP; split=>//.
  - by rewrite -E'; apply/bh_baliL; rewrite E'.
  apply: invh_baliL=>//; first by rewrite invh_paint.
  by rewrite E'.
- move=>H _; rewrite eqn_add2r=>E1 _.
  apply/andP; split; first by apply/invh_baliL=>//=; rewrite addn0.
  have->: bh t1 = bh (R t1 a t2) by rewrite /= addn0.
  by apply/bh_baliL=>/=; rewrite addn0.
- by move=>->->->; rewrite eq_refl.
- by move=>_ _; rewrite addn1.
- by case/andP=>/eqP->_ _; rewrite addn1.
- by move=>_ _ _; case/and5P; case/andP.
- case/and5P=>E12 H1 /eqP <- H2 -> -> E; case/and4P=>/eqP Ec Hc1 Hc2 Hc3.
  rewrite /= andbT andbC (eqP E12) andbA andbb.
  have E' : bh (paint Red t1) = bh t2 by rewrite bh_paint_red // (eqP E12) addnK.
  apply/and3P; split=>//.
  - by rewrite -E'; apply/bh_baliL; rewrite E'.
  - apply: invh_baliL=>//; first by rewrite invh_paint.
    by rewrite E'.
  by rewrite -(eqn_add2r 1) -(eqP E) eq_sym.
move=>H1 H2; rewrite eqn_add2r=>E _.
apply/andP; split; first by apply: invh_baliL=>//=; rewrite addn0.
have->: bh t1 = bh (R t1 a t2) by rewrite /= addn0.
by apply/bh_baliL=>/=; rewrite addn0.
Qed.

Lemma invc2_baldR l a r :
  invc l -> invc2 r -> invc2 (baldR l a r).
Proof.
funelim (baldR l a r); simp baldR=>//=; rewrite /invc2 /= ?andbT //.
- case/and4P=>_ H1 H2 -> _; rewrite andbT.
  by apply/invc_baliL=>//; rewrite /invc2 paint2; apply/invc2I.
- case/andP=>H1 H2 _.
  by apply/invc2I/invc_baliL=>//; rewrite /invc2 /= H1 H2.
- by move=>->->.
- by move=>->->.
- by case/and5P; case/andP.
- case/and4P=>E H1 H2 ->->; rewrite /= andbT.
  by apply/invc_baliL=>//; rewrite /invc2 paint2; apply/invc2I.
case/andP=>H1 H2 H0.
by apply/invc2I/invc_baliL=>//; rewrite /invc2 /= H1 H2.
Qed.

Lemma invc_baldR l a r :
  invc l -> invc2 r -> color l == Black ->
  invc (baldR l a r).
Proof.
funelim (baldR l a r); simp baldR=>//=; rewrite /invc2 /=.
- case/andP=>H1 H2 _ _.
  by apply/invc_baliL=>//; rewrite /invc2 /= H1 H2.
- by move=>->->->.
case/andP=>H1 H2 H0 _.
by apply/invc_baliL=>//; rewrite /invc2 /= H1 H2.
Qed.

Lemma split_min_invc l a r x t :
  split_min l a r = (x, t) ->
  invc l -> invc r ->
  invc2 t && ((color l == Black) && (color r == Black) ==> invc t).
Proof.
elim: l a r t=>/= [|l' IHl [a' c'] r' _] a r t.
- by case =>_->_ /[dup]/invc2I->->/=; apply: implybT.
case Hsm: (split_min l' a' r')=>[x0 m][E0 Et]; rewrite {x0}E0 in Hsm.
case/and3P=>I Hl' Hr' Hr; case/andP: (IHl _ _ _ Hsm Hl' Hr')=>H2m /implyP Hm.
rewrite /invc2; case: c' Et I=><- /=.
- by move/Hm=>->; rewrite Hr.
move=>_; apply/andP; split; first by apply/invc2_baldL.
by apply/implyP=>Hcr; apply/invc_baldL.
Qed.

Lemma split_min_invh l a r x t :
  split_min l a r = (x, t) ->
  invc l -> invc r -> invh l -> invh r ->
  bh l == bh r ->
  invh t && (bh t == bh l).
Proof.
elim: l a r t=>/= [|l' IHl [a' c'] r' _] a r t.
- by case=>_->_ _ _ ->; rewrite eq_sym.
case Hsm: (split_min l' a' r')=>[x0 m][E0 Et]; rewrite {x0}E0 in Hsm.
case/and3P=>_ Hcl' Hcr' Hcr; case/and3P=>E' Hhl' Hhr' Hhr.
case/andP: (IHl _ _ _ Hsm Hcl' Hcr' Hhl' Hhr' E'); rewrite /invch=>Hhm Em.
case: c' Et=><-/=.
- by rewrite !addn0=>/eqP <-; rewrite Em Hhm Hhr.
move/eqP=>E''; rewrite E''.
by apply: invh_baldL_invc=>//; rewrite -E'' eqn_add2r.
Qed.

Lemma invc_del x t :
  invc t ->
  invc2 (del x t) && ((color t == Red) ==> invc (del x t)).
Proof.
elim: t=>//= l IHl [a c] r IHr /and3P [E Hl Hr].
case/andP: (IHl Hl)=>{IHl} H2l Hil; case/andP: (IHr Hr)=>{IHr} H2r Hir.
rewrite /invc2 /=; case: c E=>/= [/andP [Hcll Hclr]|_]; case: (cmp x a).
- case: eqP=>El /=; first by rewrite El /= Hclr Hr.
  rewrite Hcll; apply/andP; split; last by apply: invc_baldL.
  - by apply/invc2I/invc_baldL.
- case: {H2r Hir} r Hr Hclr=>/=.
  - by move=>_ _; apply/andP; split=>//; apply/invc2I.
  move=>lr [ar cr] rr /and3P [_ Hclr Hcrr] ->.
  case Hsm: (split_min lr ar rr)=>[a' r'] /=.
  case/andP: (split_min_invc Hsm Hclr Hcrr)=>H2r' Hr'.
  apply/andP; split; last by apply: invc_baldR.
  by apply/invc2I/invc_baldR.
- case: eqP=>Er /=; first by rewrite Er /= Hcll Hl.
  rewrite Hclr; apply/andP; split; last by apply: invc_baldR.
  by apply/invc2I/invc_baldR.
- case: eqP=>El /=; first by rewrite El /= Hr.
  rewrite andbT; case Hcl: (color l)=>/=.
  - by move: Hil; rewrite Hcl /= Hr => ->.
  by apply: invc2_baldL.
- rewrite andbT; case: {H2r Hir} r Hr=>/=.
  - by move=>_; apply: invc2I.
  move=>lr [ar cr] rr /and3P [E Hclr Hcrr].
  case Hsm: (split_min lr ar rr)=>[a' r'] /=.
  case/andP: (split_min_invc Hsm Hclr Hcrr)=>H2r' /implyP Hr'.
  case: cr E=>/=.
  - by move/Hr'=>->; rewrite Hl.
  by move=>_; apply: invc2_baldR.
case: eqP=>Er /=; first by rewrite Er /= Hl.
rewrite andbT; case Hcr: (color r)=>/=.
- by move: Hir; rewrite Hcr /= Hl => ->.
by apply: invc2_baldR.
Qed.

Lemma invh_del x t :
  invch t ->
  invh (del x t) && (bh (del x t) == bh t - (color t == Black)).
Proof.
elim/invch_ind=>{t}//= l a c r I Hcl Hcr /eqP E Hhl Hhr /andP [Hhdl Icl] /andP [Hhdr Icr].
rewrite addnK; case: (cmp x a)=>/=.
- case: eqP=>El /=; first by rewrite El /= in E *; rewrite -E Hhr.
  move: Icl; case Cl: (color l)=>/=.
  - by rewrite subn0 =>/eqP->; rewrite addn0 E Hhdl Hhr eq_refl.
  rewrite -(eqn_add2r 1) subnK; last by apply: bh_gt0.
  by rewrite E=>Ed; apply: invh_baldL_invc.
- case: {I Hhdr Icr}r E Hcr Hhr; first by rewrite Hhl eq_refl.
  move=>lr [ar cr] rr /= E /and3P [Ecr Hclr Hcrr] /and3P [Ebr Hhlr Hhrr].
  case Hsm: (split_min lr ar rr)=>[a' r'] /=.
  case/andP: (split_min_invh Hsm Hclr Hcrr Hhlr Hhrr Ebr)=>Hhr' E'.
  move: E; case Ccr: cr=>/=.
  - by rewrite !addn0=>->; rewrite Hhl Hhr' eq_refl eq_sym /= !andbT.
  by move=>E; apply: invh_baldR_invc=>//; rewrite E eqn_add2r eq_sym.
case: eqP=>Er /=; first by rewrite Er /= in E *; rewrite E Hhl.
move: Icr; case Cr: (color r)=>/=.
- by rewrite subn0 =>/eqP->; rewrite addn0 E Hhdr Hhl eq_refl.
rewrite -(eqn_add2r 1) subnK; last by apply: bh_gt0.
by rewrite -E eq_sym=>Ed; apply: invh_baldR_invc.
Qed.

Corollary inv_delete x t : invch t -> invch (delete x t).
Proof.
move/[dup]=>H; rewrite /invch /delete; case/andP=>Hc _.
case/andP: (invc_del x Hc); rewrite /invc2=>-> _ /=.
by rewrite invh_paint //; case/andP: (invh_del x H).
Qed.

Corollary rbt_delete x t : rbt_inv t -> rbt_inv (delete x t).
Proof.
rewrite /rbt_inv /delete paint_black eq_refl andbT.
by case/andP=>/(inv_delete x).
Qed.

(* correctness via sorted lists *)

Lemma inorder_paint c (t : rbt T) : inorder_a (paint c t) = inorder_a t.
Proof. by case: t=>//=l [a c0] r. Qed.

Lemma inorder_baliL l a r : inorder_a (baliL l a r) = inorder_a l ++ a :: inorder_a r.
Proof.
by funelim (baliL l a r); simp baliL=>//=; rewrite -!catA // !cat_cons -catA.
Qed.

Lemma inorder_baliR l x r : inorder_a (baliR l x r) = inorder_a l ++ x :: inorder_a r.
Proof.
by funelim (baliR l x r); simp baliR=>//=; rewrite -!catA.
Qed.

Lemma inorder_ins x t :
  bst_list_a t -> inorder_a (ins x t) = ins_list x (inorder_a t).
Proof.
rewrite /bst_list_a; elim: t=>//= l IHl [a c] r IHr.
rewrite sorted_cat_cons_cat=>/andP [H1 H2].
rewrite inslist_sorted_cat_cons_cat //.
case: cmpE=>Hx /=.
- case: ltgtP Hx=>//_ _; rewrite -cat1s in H2.
  case: c=>/=.
  - by rewrite IHr // (cat_sorted2 H2).
  by rewrite inorder_baliR IHr // (cat_sorted2 H2).
- by rewrite Hx ltxx eq_refl; case: c.
case: c=>/=.
- by rewrite IHl // (cat_sorted2 H1).
by rewrite inorder_baliL IHl // (cat_sorted2 H1).
Qed.

Corollary inorder_insert x t :
  bst_list_a t ->
  inorder_a (insert x t) = ins_list x (inorder_a t).
Proof.
rewrite /insert => H.
by rewrite inorder_paint; apply: inorder_ins.
Qed.

Lemma inorder_baldL l a r :
  inorder_a (baldL l a r) = inorder_a l ++ a :: inorder_a r.
Proof.
by funelim (baldL l a r); simp baldL=>//=;
rewrite inorder_baliR //= inorder_paint -!catA.
Qed.

Lemma inorder_baldR l a r :
  inorder_a (baldR l a r) = inorder_a l ++ a :: inorder_a r.
Proof.
by funelim (baldR l a r); simp baldR=>//=;
rewrite inorder_baliL //= inorder_paint -!catA !cat_cons -!catA.
Qed.

Lemma inorder_split_min (l r t : rbt T) a x :
  split_min l a r = (x, t) ->
  x :: inorder_a t = inorder_a l ++ a :: inorder_a r.
Proof.
elim: l a r t=>/= [|ll IHl [al cl] rl _] a r t; first by case=>->->.
case Hsm: (split_min ll al rl)=>[x0 l'][Hx <-] /=.
rewrite {}Hx in Hsm; case: cl=>/=.
- by rewrite -cat_cons (IHl _ _ _ Hsm).
by rewrite inorder_baldL -cat_cons (IHl _ _ _ Hsm).
Qed.

Lemma inorder_del x t :
  bst_list_a t -> inorder_a (del x t) = del_list x (inorder_a t).
Proof.
rewrite /bst_list_a /=; elim: t=>//=l IHl [a c] r IHr /[dup] H.
rewrite sorted_cat_cons_cat=>/andP [H1 H2].
rewrite dellist_sorted_cat_cons_cat //.
case: cmpE=>Hxa /=.
- case: ltgtP Hxa=>//_ _; rewrite -cat1s in H2.
  case: ifP=>/= _.
  - by rewrite inorder_baldR IHr // (cat_sorted2 H2).
  by rewrite IHr // (cat_sorted2 H2).
- rewrite Hxa eq_refl.
  case: {IHr H H2}r=>//=; first by rewrite cats0.
  move=>lr [ar cr] rr.
  case Hsm: (split_min lr ar rr)=>[a' r'] /=.
  move: (inorder_split_min Hsm)=>Esm.
  case: cr=>/=; first by rewrite Esm.
  by rewrite inorder_baldR Esm.
case: ifP=>/= _.
- by rewrite inorder_baldL IHl // (cat_sorted2 H1).
by rewrite IHl // (cat_sorted2 H1).
Qed.

Corollary inorder_delete x t :
  bst_list_a t ->
  inorder_a (delete x t) = del_list x (inorder_a t).
Proof.
rewrite /delete => H.
by rewrite inorder_paint; apply: inorder_del.
Qed.

(* corollaries *)

Definition invariant (t : rbt T) := bst_list_a t && rbt_inv t.

Lemma invariant_empty : invariant leaf.
Proof. by []. Qed.

Corollary invariant_insert x (t : rbt T) :
  invariant t -> invariant (insert x t).
Proof.
rewrite /invariant /bst_list_a => /andP [H1 H2].
apply/andP; split; last by apply: rbt_insert.
by rewrite inorder_insert //; apply: ins_list_sorted.
Qed.

Corollary inorder_insert_list x (t : rbt T) :
  invariant t ->
  inorder_a (insert x t) =i [predU1 x & inorder_a t].
Proof.
rewrite /invariant /bst_list_a => /andP [H1 _].
by rewrite inorder_insert //; apply: inorder_ins_list_pred.
Qed.

Corollary invariant_delete x (t : rbt T) :
  invariant t -> invariant (delete x t).
Proof.
rewrite /invariant /bst_list_a => /andP [H1 H2].
apply/andP; split; last by apply: rbt_delete.
by rewrite inorder_delete //; apply: del_list_sorted.
Qed.

Corollary inorder_delete_list x (t : rbt T) :
  invariant t ->
  inorder_a (delete x t) =i [predD1 inorder_a t & x].
Proof.
rewrite /invariant /bst_list_a => /andP [H1 H2].
by rewrite inorder_delete //; apply: inorder_del_list_pred.
Qed.

Corollary inv_isin_list (t : rbt T) :
  invariant t ->
  isin_a t =i inorder_a t.
Proof. by rewrite /invariant => /andP [H1 _]; apply: inorder_isin_list_a. Qed.

Definition SetRBT :=
  @ASetM.make _ (rbt T)
    leaf insert delete isin_a
    (pred_of_seq \o inorder_a) invariant
    invariant_empty inorder_a_empty_pred
    invariant_insert inorder_insert_list
    invariant_delete inorder_delete_list
    inv_isin_list.

(* deletion by joining *)

Equations? join (l r : rbt T) : rbt T by wf (size_tree l + size_tree r) lt :=
join Leaf t => t;
join t Leaf => t;
join (Node t1 (a, Red) t2) (Node t3 (c, Red) t4) =>
  match join t2 t3 with
  | Node u2 (b, Red) u3 => R (R t1 a u2) b (R u3 c t4)
  | t23 => R t1 a (R t23 c t4)
  end;
join (Node t1 (a, Black) t2) (Node t3 (c, Black) t4) =>
  match join t2 t3 with
  | Node u2 (b, Red) u3 => R (B t1 a u2) b (B u3 c t4)
  | t23 => baldL t1 a (B t23 c t4)
  end;
join t1 (Node t2 (a, Red) t3) => R (join t1 t2) a t3;
join (Node t1 (a, Red) t2) t3 => R t1 a (join t2 t3).
Proof.
all: apply: ssrnat.ltP.
- rewrite !addnA -addn1 leq_add2r.
  nat_norm; rewrite [X in (_<=X.+1)%N]addnC addnA -addnA -addnS.
  by apply: leq_addr.
- rewrite ltn_add2r -addn1 leq_add2r.
  by apply: leq_addl.
- rewrite !addnA -addn1 leq_add2r.
  by apply: leq_addr.
rewrite !addnA -addn1 leq_add2r.
nat_norm; rewrite [X in (_<=X.+1)%N]addnC addnA -addnA -addnS.
by apply: leq_addr.
Qed.

Fixpoint del_j (x : T) (t : rbt T) : rbt T :=
  if t is Node l (a, _) r then
    match cmp x a with
    | LT => if (l != leaf) && (color l == Black)
              then baldL (del_j x l) a r
              else R (del_j x l) a r
    | EQ => join l r
    | GT => if (r != leaf) && (color r == Black)
              then baldR l a (del_j x r)
              else R l a (del_j x r)
    end
    else leaf.

Definition delete_j x t := paint Black (del_j x t).

Lemma invc_join l r :
  invc l -> invc r ->
  invc2 (join l r) &&
      ((color l == Black) && (color r == Black) ==> invc (join l r)).
Proof.
funelim (join l r); simp join=>/=.
- by move=>_ /[dup] /invc2I ->->/=; apply: implybT.
- case: p=>a c; rewrite /invc2 /= =>/and3P [->->->] _; apply: implybT.
- rewrite -!andbA andbT.
  case/and4P=>Hc1 Hc2 H1 H2; case/and4P=>Hc3 Hc4 H3 H4.
  rewrite /invc2; case Ej: (join t2 t3)=>[|l [x c'] r]/=.
  - by rewrite H1 Hc4 H4.
  move: (H H2 H3); rewrite /invc2 Ej /= -!andbA Hc2 Hc3 /=.
  case/and5P=>Hl Hr + _ _; case: {Ej} c'=>/=; rewrite H1 Hc4 Hl Hr H4 //.
  by case/andP=>->->; rewrite Hc1.
- rewrite -andbA; rewrite /invc2 /= eq_refl !andbT in H *.
  case/and4P=>_ Hc2 -> H2 H0 /=.
  by case/andP: (H H2 H0)=>_ /implyP; apply.
- move=>H0; rewrite -andbA; rewrite /invc2 /= andbT in H *.
  case/and4P=>Hc2 _ H2 ->; rewrite andbT.
  by case/andP: (H H0 H2)=>_ /implyP; apply.
case/andP=>H1 H2; case/andP=>H3 H4.
case Ej: (join t2 t3)=>[|l [x c'] r]/=.
- suff: invc (baldL t1 a (B (Leaf (T * col)) c t4)) by move/[dup]/invc2I=>->->.
  by apply: invc_baldL=>//=; apply/invc2I.
rewrite Ej /invc2 /= in H.
case/andP: (H H2 H3); case/andP=>Hl Hr.
case: {Ej H}c'=>/=.
- by rewrite /invc2 /= H1 Hl Hr H4.
move=>_; suff: invc (baldL t1 a (B (Node l (x, Black) r) c t4)) by move/[dup]/invc2I=>->->.
apply: invc_baldL=>//=; first by apply/invc2I.
by rewrite Hl Hr H4.
Qed.

Lemma invh_baldL_black l a r :
  invh l -> invh r -> bh l + 1 == bh r -> color r = Black ->
  invh (baldL l a r) && (bh (baldL l a r) == bh r).
Proof.
funelim (baldL l a r); simp baldL=>//=; rewrite ?addn0.
- move=>_ H; rewrite eqn_add2r=> E _.
  apply/andP; split; first by apply: invh_baliR=>//=; rewrite addn0.
  have-> : bh t2 = bh (@Leaf (T*col)) by rewrite -(eqP E).
  by apply: bh_baliR=>/=; rewrite addn0.
- by move=>->->->.
- by move=>_ _; rewrite addn1.
move=>H1 H2; rewrite eqn_add2r=>E _.
apply/andP; split; first by apply: invh_baliR=>//=; rewrite addn0.
have->: bh t2 = bh (Node t (s0, Black) t0) by rewrite -(eqP E).
by apply: bh_baliR=>/=; rewrite addn0.
Qed.

Lemma invh_join l r :
  invh l -> invh r -> bh l == bh r ->
  invh (join l r) && (bh (join l r) == bh l).
Proof.
funelim (join l r); simp join=>/=.
- by move=>_->; rewrite eq_sym.
- by case: p=>_ c->; rewrite eq_refl.
- case/and3P=>/eqP E12 H1 H2; case/and3P=>/eqP E34 H3 H4.
  rewrite eqn_add2r addn0=>E13.
  have E23: bh t2 == bh t3 by rewrite -E12.
  case/andP: (H H2 H3 E23); case: (join t2 t3)=>[|l [x c'] r]/=.
  - by rewrite E12 -E34 -(eqP E23) H1 H4=>_ /eqP <-.
  case/and3P=>/eqP E Hl Hr; case: c'=>/=; rewrite !addn0 H1 Hl Hr H4 /= !andbT E.
  - by rewrite -E34 -(eqP E23) E12; move/eqP=>->; rewrite eq_refl.
  by move/eqP->; rewrite E12 -E34 -(eqP E23) !eq_refl.
- case/and3P=>/eqP E12 H1 H2 H03.
  rewrite addn0 H1 eq_refl /= andbT =>E10.
  have E20: bh t2 == bh t0 + 1 by rewrite -E12.
  by case/andP: (H H2 H03 E20)=>->/eqP->; rewrite E12 eq_refl.
- move=>H0; case/and3P=>/eqP E23 H2 H3.
  rewrite !addn0 H3 -E23 andbC=>E2; rewrite (eqP E2) andbA andbb andbT.
  by case/andP: (H H0 H2 E2)=>->/eqP->/=; rewrite andbT.
case/and3P=>/eqP E12 H1 H2; case/and3P=>/eqP E34 H3 H4.
rewrite eqn_add2r=>E13.
have E23: bh t2 == bh t3 by rewrite -E12.
case/andP: (H H2 H3 E23); case: (join t2 t3)=>[|l [x c'] r]/=.
- move=>_ E2'.
  have->: bh t1 + 1 = bh (B (Leaf (T * col)) c t4) by rewrite /= E12 -(eqP E2').
  apply/invh_baldL_black=>//=.
  - by rewrite H4 andbT -E34 -(eqP E23).
  by rewrite eqn_add2r E12 eq_sym.
case/and3P=>/eqP E Hl Hr; case: c'=>/=.
- rewrite !addn0 H1 Hl Hr H4 /= !andbT E => /eqP ->.
  by rewrite E12 -E34 -(eqP E23) !eq_refl.
move=>E2.
have->: bh t1 + 1 = bh (B (Node l (x, Black) r) c t4) by rewrite /= (eqP E2) E12.
apply/invh_baldL_black=>//=.
- by rewrite (eqP E2) -E34 E23 E Hl Hr H4 eq_refl.
by rewrite (eqP E2) E12.
Qed.

Lemma invc_del_j x t :
  invc t ->
  invc2 (del_j x t) && ((color t == Red) ==> invc (del_j x t)).
Proof.
elim: t=>//= l IHl [a c] r IHr /and3P [E Hl Hr].
case/andP: (IHl Hl)=>{IHl} H2l Hil; case/andP: (IHr Hr)=>{IHr} H2r Hir.
rewrite /invc2 /=; case: c E=>/= [/andP [Hcll Hclr]|_]; case: (cmp x a).
- case: eqP=>El /=; first by rewrite El /= Hclr Hr.
  rewrite Hcll; apply/andP; split; last by apply: invc_baldL.
  - by apply/invc2I/invc_baldL.
- by case/andP: (invc_join Hl Hr); rewrite /invc2 Hcll Hclr =>->.
- case: eqP=>Er /=; first by rewrite Er /= Hcll Hl.
  rewrite Hclr; apply/andP; split; last by apply: invc_baldR.
  by apply/invc2I/invc_baldR.
- case: eqP=>El /=; first by rewrite El /= Hr.
  rewrite andbT; case Hcl: (color l)=>/=.
  - by move: Hil; rewrite Hcl /= Hr => ->.
  by apply: invc2_baldL.
- by rewrite andbT; case/andP: (invc_join Hl Hr).
case: eqP=>Er /=; first by rewrite Er /= Hl.
rewrite andbT; case Hcr: (color r)=>/=.
- by move: Hir; rewrite Hcr /= Hl => ->.
by apply: invc2_baldR.
Qed.

Lemma invh_del_j x t :
  invch t ->
  invh (del_j x t) && (bh (del_j x t) == bh t - (color t == Black)).
Proof.
elim/invch_ind=>{t}//= l a c r I Hcl Hcr /eqP E Hhl Hhr /andP [Hhdl Icl] /andP [Hhdr Icr].
rewrite addnK; case: (cmp x a)=>/=.
- case: eqP=>El /=; first by rewrite El /= in E *; rewrite -E Hhr.
  move: Icl; case Cl: (color l)=>/=.
  - by rewrite subn0 =>/eqP->; rewrite addn0 E Hhdl Hhr eq_refl.
  rewrite -(eqn_add2r 1) subnK; last by apply: bh_gt0.
  by rewrite E=>Ed; apply: invh_baldL_invc.
- by apply: invh_join=>//; rewrite E eq_refl.
case: eqP=>Er /=; first by rewrite Er /= in E *; rewrite E Hhl.
move: Icr; case Cr: (color r)=>/=.
- by rewrite subn0 =>/eqP->; rewrite addn0 E Hhdr Hhl eq_refl.
rewrite -(eqn_add2r 1) subnK; last by apply: bh_gt0.
by rewrite -E eq_sym=>Ed; apply: invh_baldR_invc.
Qed.

Corollary inv_delete_j x t : invch t -> invch (delete_j x t).
Proof.
move/[dup]=>H; rewrite /invch /delete_j; case/andP=>Hc _.
case/andP: (invc_del_j x Hc); rewrite /invc2=>-> _ /=.
by rewrite invh_paint //; case/andP: (invh_del_j x H).
Qed.

Corollary rbt_delete_j x t : rbt_inv t -> rbt_inv (delete_j x t).
Proof.
rewrite /rbt_inv /delete_j paint_black eq_refl andbT.
by case/andP=>/(inv_delete_j x).
Qed.

Lemma inorder_join l r :
  inorder_a (join l r) = inorder_a l ++ inorder_a r.
Proof.
funelim (join l r); simp join=>//=.
- by rewrite cats0.
- case H23: (join t2 t3)=>[|l' [x c'] r']/=; rewrite {}H23 /= in H.
  - by rewrite -!catA cat_cons catA -H.
  case: c'=>/=.
  - by rewrite -!catA cat_cons -(cat_cons x) catA H -!catA cat_cons.
  by rewrite H -!catA cat_cons.
- by rewrite H /= -!catA cat_cons.
- by rewrite H /= -catA.
case H23: (join t2 t3)=>[|l' [x c'] r']/=; rewrite {}H23 /= in H.
- by rewrite inorder_baldL /= -!catA cat_cons catA -H.
case: c'=>/=.
- by rewrite -!catA cat_cons -(cat_cons x) catA H -!catA cat_cons.
by rewrite inorder_baldL /= H -!catA cat_cons.
Qed.

Lemma inorder_del_j x t :
  bst_list_a t -> inorder_a (del_j x t) = del_list x (inorder_a t).
Proof.
rewrite /bst_list_a /=; elim: t=>//=l IHl [a c] r IHr /[dup] H.
rewrite sorted_cat_cons_cat=>/andP [H1 H2].
rewrite dellist_sorted_cat_cons_cat //.
case: cmpE=>Hx /=.
- case: ltgtP Hx=>//_ _; rewrite -cat1s in H2.
  case: ifP=>/= _.
  - by rewrite inorder_baldR IHr // (cat_sorted2 H2).
  by rewrite IHr // (cat_sorted2 H2).
- by rewrite Hx eq_refl inorder_join.
case: ifP=>/= _.
- by rewrite inorder_baldL IHl // (cat_sorted2 H1).
by rewrite IHl // (cat_sorted2 H1).
Qed.

Corollary inorder_delete_j x t :
  bst_list_a t ->
  inorder_a (delete_j x t) = del_list x (inorder_a t).
Proof.
rewrite /delete_j => H.
by rewrite inorder_paint; apply: inorder_del_j.
Qed.

Corollary invariant_delete_j x (t : rbt T) :
  invariant t -> invariant (delete_j x t).
Proof.
rewrite /invariant /bst_list_a => /andP [H1 H2].
apply/andP; split; last by apply: rbt_delete_j.
by rewrite inorder_delete_j //; apply: del_list_sorted.
Qed.

Corollary inorder_delete_j_list x (t : rbt T) :
  invariant t ->
  inorder_a (delete_j x t) =i [predD1 inorder_a t & x].
Proof.
rewrite /invariant /bst_list_a => /andP [H1 H2].
by rewrite inorder_delete_j //; apply: inorder_del_list_pred.
Qed.

Definition SetRBTj :=
  @ASetM.make _ (rbt T)
    leaf insert delete_j isin_a
    (pred_of_seq \o inorder_a) invariant
    invariant_empty inorder_a_empty_pred
    invariant_insert inorder_insert_list
    invariant_delete_j inorder_delete_j_list
    inv_isin_list.

End SetImplementation.

Section Exercises.

(* Exercise 8.1 *)

Lemma log_height_inv {A} (t : rbt A) :
  invch t ->
  (height t)./2 <= up_log 2 (size1_tree t) + 1.
Proof.
Admitted.

(* Exercise 8.2 *)

Fixpoint bhs {A} (t : rbt A) : seq nat :=
  if t is Node l (_,c) r then
    let H := bhs l ++ bhs r in
    if c == Black then map S H else H
  else [::0].

Lemma same_black {T : eqType} (t : rbt T) : invh t <-> undup (bhs t) = [::bh t].
Proof.
Admitted.

(* Exercise 8.3 *)

Definition rbt_of_list {A} (xs : seq A) : rbt A :=
  Leaf (A*col).  (* FIXME *)

Lemma inorder_rol {A} (xs : seq A) : inorder_a (rbt_of_list xs) = xs.
Proof.
Admitted.

Lemma rbt_rol {T : eqType} (xs : seq T) : rbt_inv (rbt_of_list xs).
Proof.
Admitted.

End Exercises.


Set Warnings "-notation-overridden".

Require Export Category.

Set Universe Polymorphism.

Record SomeSet : Type :=
{
  carrier :> Type;
  carrier_setoid :> Setoid carrier
}.

Notation "Set[ X ]" := (@Build_SomeSet X _).

Record Function {X:Type} (S:Setoid X) {Y:Type} (S1:Setoid Y) :=
{
  function :> X -> Y;
  function_respects :>
    Proper (equiv ==> equiv ) function
}.
Arguments Function {X} S {Y} S1: assert.
Arguments function {X S Y S1} _ _: assert.
Arguments function_respects {X S Y S1} f x y _: assert.

Program Instance functions_setoid (X Y: SomeSet) : Setoid (Function X Y) :=
{
  equiv := fun f g => forall x, @equiv _ Y (f x) (g x)
}.
Next Obligation.
  split.
  - unfold Reflexive.
    intros f x. reflexivity.
  - unfold Symmetric.
    intros f g eq x.
    rewrite (eq x).
    reflexivity.
  - unfold Transitive.
    intros f g h eq1 eq2 x.
    rewrite (eq1 x).
    rewrite (eq2 x).
    reflexivity.
Defined.

Program Definition identity_function (X:SomeSet) : Function X X :=
{|
  function := fun x => x
|}.
Next Obligation.
  unfold Proper. unfold respectful.
  intros x y I. apply I.
Defined.

Program Definition compose_function
  {X Y Z: SomeSet} (f:Function Y Z) (g:Function X Y) : Function X Z :=
{|
  function := fun x => f (g x)
|}.
Next Obligation.
  unfold Proper; unfold respectful; simpl.
  intros.
  apply function_respects.
  apply function_respects.
  assumption.
Defined.

(* The category of sets and functions *)
Program Instance Sets : Category :=
{
  Obj := SomeSet;
  Hom := fun X Y => Function X Y;
  id := identity_function;
  compose := fun _ _ _ => compose_function
}.
Next Obligation.
  unfold Proper; unfold respectful.
  intros f f' eq1 g g' eq2 x.
  simpl in *.
  rewrite (eq1 (g x)).
  apply function_respects.
  rewrite (eq2 x).
  reflexivity.
Defined.
Next Obligation.
  reflexivity.
Defined.
Next Obligation.
  reflexivity.
Defined.
Next Obligation.
  reflexivity.
Defined.


Require Import FCF.FCF.
Require Import Coq.Classes.Morphisms.

Create HintDb rat discriminated.
Create HintDb ratsimpl discriminated.

Hint Immediate (@reflexivity Rat eqRat _) : rat.
Hint Immediate (@reflexivity Rat leRat _) : rat.

Lemma maxRat_same r : maxRat r r = r.
Proof. intros; cbv [maxRat]; destruct (bleRat r r) eqn:?; trivial. Qed.
Lemma minRat_same r : minRat r r = r.
Proof. intros; cbv [minRat]; destruct (bleRat r r) eqn:?; trivial. Qed.

Hint Rewrite ratSubtract_0 minRat_same maxRat_same : ratsimpl.

Lemma ratDistance_same r : ratDistance r r == 0.
Proof. cbv [ratDistance]; autorewrite with ratsimpl; auto with rat. Qed.

Hint Rewrite ratDistance_same : ratsimpl.


(** the concept of morphism between actegories that is a functor between the
    categories acted upon that is compatible with the action structures

Written by Ralph Matthes in close correspondence with the code in [UniMath.CategoryTheory.MonoidalOld.MonoidalFunctorsWhiskered]

Naming is inspired from Actegories for the Working Amthematician by Matteo Capucci and Bruno Gavranović,
available at https://arxiv.org/abs/2203.16351

There are lax and non-lax versions of morphisms: the lax morphisms of V-actegories are called lax V-linear functors, and the non-lax version the V-linear functors, where the difference is that in the latter the crucial natural transformation called the lineator is required to be an isomorphism.

The non-lax version is not called strong so as to avoid confusion with the usual denomination of the lineator as the strength of the underlying functor. [lineator_lax] is that notion of strength together with the laws governing it.

2022
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Functors.
Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal.
Require Import UniMath.CategoryTheory.Actegories.Actegories.
Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories.
Require Import UniMath.CategoryTheory.coslicecat.
Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects.

Local Open Scope cat.

Import BifunctorNotations.
Import MonoidalNotations.
Import ActegoryNotations.

Section LinearFunctors.

  Context {V : category} (Mon_V : monoidal V). (** given the monoidal category that acts upon categories *)

Section TheDefinitions.

  Context {C D : category} (ActC : actegory Mon_V C) (ActD : actegory Mon_V D) (F: functor C D).

  (** (Weak) Linear functors **)
  (* Linear functor data *)

  Definition lineator_data : UU := ∏ (v : V) (x : C), D ⟦ v ⊗_{ActD} F x, F (v ⊗_{ActC} x) ⟧.
  Identity Coercion lineator_data_funclass : lineator_data >-> Funclass.

  (** Properties **)
  Definition lineator_nat_left (ld : lineator_data)
    := ∏ (v : V) (x1 x2 : C) (g : C⟦x1,x2⟧),
      v ⊗^{ActD}_{l} # F g · ld v x2 = ld v x1 · # F (v ⊗^{ActC}_{l} g).

  Definition lineator_nat_right (ld : lineator_data)
    := ∏ (v1 v2 : V) (x : C) (f : V⟦v1,v2⟧),
      f ⊗^{ActD}_{r} F x · ld v2 x = ld v1 x · # F (f ⊗^{ActC}_{r} x).

  Definition preserves_unitor (ld : lineator_data)
    := ∏ (x : C), ld I_{Mon_V} x · # F au^{ActC}_{x} = au^{ActD}_{F x}.

  Definition preserves_unitorinv (ld : lineator_data)
    := ∏ (x : C), auinv^{ActD}_{F x} · ld I_{Mon_V} x = # F auinv^{ActC}_{x}.

  Definition preserves_actor (ld : lineator_data) : UU :=
    ∏ (v w : V) (x : C),  ld (v ⊗_{Mon_V} w) x · #F (aα^{ActC}_{v,w,x}) =
                            aα^{ActD}_{v,w,F x} · v ⊗^{ActD}_{l} (ld w x) · ld v (w ⊗_{ActC} x).

  Definition preserves_actorinv  (ld : lineator_data) : UU :=
    ∏ (v w : V) (x : C), aαinv^{ActD}_{v,w,F x} · ld (v ⊗_{Mon_V} w) x =
                           v ⊗^{ActD}_{l} (ld w x) · ld v (w ⊗_{ActC} x) · #F (aαinv^{ActC}_{v,w,x}).

  (* the order of the entries follws that of [fmonoidal_laxlaws] *)
  Definition lineator_laxlaws (ld : lineator_data) : UU :=
    lineator_nat_left ld × lineator_nat_right ld × preserves_actor ld × preserves_unitor ld.

  Lemma isaprop_lineator_laxlaws (ld : lineator_data) : isaprop (lineator_laxlaws ld).
  Proof.
    apply isapropdirprod; [| apply isapropdirprod ; [| apply isapropdirprod]];
      repeat (apply impred; intro); apply D.
  Qed.

  Definition lineator_lax : UU := ∑ (ld : lineator_data), lineator_laxlaws ld.

  Definition lineator_lindata (ll : lineator_lax) : lineator_data := pr1 ll.
  Coercion lineator_lindata : lineator_lax >-> lineator_data.

  Definition lineator_linlaws (ll : lineator_lax) : lineator_laxlaws ll := pr2 ll.

  Definition lineator_linnatleft (ll : lineator_lax) : lineator_nat_left ll := pr12 ll.
  Definition lineator_linnatright (ll : lineator_lax) : lineator_nat_right ll := pr122 ll.

  Definition lineator_preservesactor (ll : lineator_lax) : preserves_actor ll := pr1 (pr222 ll).

  Lemma lineator_preservesactorinv (ll : lineator_lax) : preserves_actorinv ll.
  Proof.
    intros v w x.
    rewrite assoc'.
    apply (z_iso_inv_on_right _ _ _ (z_iso_from_actor_iso Mon_V ActD _ _ _)).
    cbn.
    etrans.
    2: { repeat rewrite assoc. apply cancel_postcomposition.
         apply lineator_preservesactor. }
    repeat rewrite assoc'.
    etrans.
    { apply pathsinv0, id_right. }
    apply maponpaths.
    etrans.
    2: { rewrite <- functor_comp.
         apply maponpaths.
         apply pathsinv0, (actegory_actorisolaw Mon_V ActC). }
    apply pathsinv0, functor_id.
  Qed.

  Definition lineator_preservesunitor (ll : lineator_lax) : preserves_unitor ll := pr2 (pr222 ll).

  Lemma lineator_preservesunitorinv (ll : lineator_lax) : preserves_unitorinv ll.
  Proof.
    intro x.
    apply (z_iso_inv_on_right _ _ _ (_,,_,, actegory_unitorisolaw Mon_V ActD (F x))).
    cbn.
    rewrite <- (lineator_preservesunitor ll).
    repeat rewrite assoc'.
    etrans.
    { apply pathsinv0, id_right. }
    apply maponpaths.
    etrans.
    2: { rewrite <- functor_comp.
         apply maponpaths.
         apply pathsinv0, (actegory_unitorisolaw Mon_V ActC x). }
    apply pathsinv0, functor_id.
  Qed.

  Definition lineator_strongly (ld : lineator_data) : UU
    := ∏ (v : V) (x : C), is_z_isomorphism (ld v x).

  Definition pointwise_z_iso_from_lineator_strongly {ld : lineator_data}
    (pas : lineator_strongly ld) (v : V) (x : C) :
    z_iso (v ⊗_{ActD} F x) (F (v ⊗_{ActC} x)) := ld v x ,, pas v x.

  Lemma preserves_actor_of_inverse_lineator_strongly
        {ld : lineator_data}
        (pα : preserves_actor ld)
        (ls : lineator_strongly ld) (v w : V) (x : C) :
    (is_z_isomorphism_mor (ls (v ⊗_{Mon_V} w) x))
       · aα^{ActD}_{v, w, F x} =
    (#F (aα^{ActC}_{v,w,x}))
      · (is_z_isomorphism_mor (ls v (w ⊗_{ActC} x)))
      · (v ⊗^{ActD}_{l} (is_z_isomorphism_mor (ls w x))).
  Proof.
    set (lsv_wx := pointwise_z_iso_from_lineator_strongly ls v (w ⊗_{ActC} x)).
    set (lsvw_x := pointwise_z_iso_from_lineator_strongly ls (v ⊗_{Mon_V} w) x).
    set (lsfv := functor_on_z_iso
          (leftwhiskering_functor ActD v)
          (pointwise_z_iso_from_lineator_strongly ls w x)).
    apply (z_iso_inv_on_left _ _ _ _ lsfv).
    apply pathsinv0.
    apply (z_iso_inv_on_left _ _ _ _ lsv_wx).
    rewrite assoc'.
    rewrite assoc'.
    etrans.
    2: {
      apply maponpaths.
      rewrite assoc.
      exact (pα v w x).
    }
    etrans.
    2: {
      rewrite assoc.
      apply maponpaths_2.
      exact (! pr222 lsvw_x).
    }
    apply (! id_left _).
  Qed.

  Lemma lineatorinv_nat_right {ld : lineator_data} (ls : lineator_strongly ld) (lrn : lineator_nat_right ld)
    (v1 v2 : V) (x : C) (f : V⟦v1,v2⟧) :
    (is_z_isomorphism_mor (ls v1 x)) · f ⊗^{ActD}_{r} F x =  #F (f ⊗^{ActC}_{r} x) · (is_z_isomorphism_mor (ls v2 x)).
  Proof.
    set (ldiso := ld v1 x ,, ls v1 x : z_iso _ _).
    apply (z_iso_inv_on_right _ _ _ ldiso).
    rewrite assoc.
    etrans.
    2: {
      apply maponpaths_2.
      apply lrn.
    }
    rewrite assoc'.
    unfold is_z_isomorphism_mor.
    rewrite (pr12 (ls v2 x)).
    apply (! id_right _).
  Qed.

  Lemma lineatorinv_nat_left {ld : lineator_data} (ls : lineator_strongly ld) (lln : lineator_nat_left ld)
    (v : V) (x1 x2 : C) (f : C⟦x1,x2⟧) :
      (is_z_isomorphism_mor (ls v x1)) · v ⊗^{ActD}_{l} # F f = # F (v ⊗^{ActC}_{l} f) · (is_z_isomorphism_mor (ls v x2)).
  Proof.
    set (ldiso := ld v x1 ,, ls v x1 : z_iso _ _).
    apply (z_iso_inv_on_right _ _ _ ldiso).
    rewrite assoc.
    etrans.
    2: {
      apply maponpaths_2.
      apply lln.
    }
    rewrite assoc'.
    unfold is_z_isomorphism_mor.
    rewrite (pr12 (ls v x2)).
    apply (! id_right _).
  Qed.

  Definition lineator : UU := ∑ (ll : lineator_lax), lineator_strongly ll.

  Definition lineator_lineatorlax (lin : lineator) : lineator_lax := pr1 lin.
  Coercion lineator_lineatorlax : lineator >-> lineator_lax.

  Definition lineator_linstrongly (lin : lineator) : lineator_strongly lin := pr2 lin.

  (** We now show that everything behaves as expected **)
  Definition functor_imageofaction : bifunctor V C D
    := compose_bifunctor_with_functor ActC F.

  Definition functor_actionofrightimage : bifunctor V C D
    := compose_functor_with_bifunctor (functor_identity _) F ActD.

  Definition lineator_is_nattrans_type : UU
    := binat_trans functor_actionofrightimage functor_imageofaction.

Section LineatorNatural.

  (* I really don't know how to call the following lemma *)

  Context {ld : lineator_data} (lnl : lineator_nat_left ld) (lnr : lineator_nat_right ld).

  Definition lineator_is_nattrans_data : binat_trans_data functor_actionofrightimage functor_imageofaction.
  Proof.
    use make_binat_trans_data.
    intros v x.
    apply ld.
  Defined.

  Lemma lineator_is_nattrans_law : is_binat_trans lineator_is_nattrans_data.
  Proof.
    use tpair.
    - intros v x1 x2 g.
      apply lnl.
    - intros v1 v2 x f.
      apply lnr.
  Qed.

  Definition lineator_is_nattrans : lineator_is_nattrans_type :=
    lineator_is_nattrans_data,,lineator_is_nattrans_law.

  Lemma lineator_is_nattrans_full (v1 v2 : V) (x1 x2 : C) (f : V⟦v1,v2⟧) (g : C⟦x1,x2⟧) :
      f ⊗^{ActD} # F g · ld v2 x2 = ld v1 x1 · # F (f ⊗^{ActC} g).
  Proof.
    intros.
    etrans.
    { unfold functoronmorphisms1.
      rewrite assoc'.
      rewrite lnl.
      apply assoc. }
    rewrite lnr.
    rewrite assoc'.
    apply maponpaths.
    apply pathsinv0, functor_comp.
  Qed.

 End LineatorNatural.

  Definition lineator_inv_is_nattrans_type : UU
    := binat_trans functor_imageofaction functor_actionofrightimage.

  (* name follows [lineator_is_nattrans], for lack of a better proposition *)
  Definition lineator_inv_is_nattrans
    {ld : lineator_data}
    (lnl : lineator_nat_left ld) (lnr : lineator_nat_right ld) (ls : lineator_strongly ld)
    : lineator_inv_is_nattrans_type
    := inv_binattrans_from_binatiso(α:=lineator_is_nattrans lnl lnr) ls.

  (* Strictly linear functors *)
  Definition lineator_strictly (ld : lineator_data) : UU
    := ∏ (v : V) (x : C), ∑ (pf : v ⊗_{ActD} (F x) = F (v ⊗_{ActC} x)), ld v x = transportf _ pf (identity (v ⊗_{ActD} (F x))).

  Lemma lineator_strictly_is_strongly  {ld : lineator_data} (lst : lineator_strictly ld) : lineator_strongly ld.
  Proof.
    intros v x.
    use (iso_stable_under_equalitytransportf (pr2 (lst v x)) (is_z_isomorphism_identity (v ⊗_{ActD} F x))).
  Qed.

End TheDefinitions.

Arguments lineator_lindata {_ _ _ _ _} _ _ _.
Arguments lineator_laxlaws {_ _ _ _ _} _.
Arguments lineator_strongly {_ _ _ _ _} _.
Arguments lineator_preservesactor {_ _ _ _ _} _ _ _ _.
Arguments lineator_preservesunitor {_ _ _ _ _} _ _.
Arguments lineator_linstrongly {_ _ _ _ _} _ _ _.

(** towards a bicategory of actegories *)
  Definition identity_lineator_data {C : category} (Act : actegory Mon_V C) :
    lineator_data Act Act (functor_identity C).
  Proof.
    - intros v x. apply identity.
  Defined.

  Lemma identity_lineator_laxlaws {C : category} (Act : actegory Mon_V C) :
    lineator_laxlaws (identity_lineator_data Act).
  Proof.
    split4; intros x1; unfold identity_lineator_data; intros.
    - rewrite id_left. apply id_right.
    - rewrite id_left. apply id_right.
    - rewrite id_right.
      rewrite (bifunctor_leftid Act).
      rewrite id_right.
      apply id_left.
    - apply id_left.
  Qed.

  Definition identity_lineator_lax {C : category} (Act : actegory Mon_V C) :
    lineator_lax Act Act (functor_identity C)
    := identity_lineator_data Act ,, identity_lineator_laxlaws Act.

  Definition identity_lineator_strongly {C : category} (Act : actegory Mon_V C) :
    lineator_strongly (identity_lineator_lax Act).
  Proof.
    - intros v x. apply is_z_isomorphism_identity.
  Defined.

  Definition identity_lineator {C : category} (Act : actegory Mon_V C) : lineator Act Act (functor_identity C)
    := identity_lineator_lax Act ,, identity_lineator_strongly Act.

Section Composition.

    Context {C D E : category} {ActC : actegory Mon_V C} {ActD : actegory Mon_V D} {ActE : actegory Mon_V E}
    {F : C ⟶ D} {G : D ⟶ E}.

Section CompositionOfLaxLineators.

  Context (Fl : lineator_lax ActC ActD F) (Gl : lineator_lax ActD ActE G).

  Definition comp_lineator_data : lineator_data ActC ActE (F ∙ G).
  Proof.
    intros v x.
    exact (lineator_lindata Gl v (F x) · #G (lineator_lindata Fl v x)).
  Defined.

  Lemma comp_lineator_laxlaws : lineator_laxlaws comp_lineator_data.
  Proof.
    split4; intro; unfold comp_lineator_data; intros; cbn.
    - etrans.
      2: { rewrite assoc'. apply maponpaths. apply functor_comp. }
      etrans.
      2: { do 2 apply maponpaths. apply lineator_linnatleft. }
      rewrite functor_comp.
      repeat rewrite assoc.
      apply cancel_postcomposition.
      apply lineator_linnatleft.
    - etrans.
      2: { rewrite assoc'. apply maponpaths. apply functor_comp. }
      etrans.
      2: { do 2 apply maponpaths. apply lineator_linnatright. }
      rewrite functor_comp.
      repeat rewrite assoc.
      apply cancel_postcomposition.
      apply lineator_linnatright.
    - assert (auxF := lineator_preservesactor Fl v w x).
      assert (auxG := lineator_preservesactor Gl v w (F x)).
      rewrite (bifunctor_leftcomp ActE).
      etrans.
      2: { repeat rewrite assoc. apply cancel_postcomposition.
           repeat rewrite assoc'. do 2 apply maponpaths.
           apply pathsinv0, lineator_linnatleft. }
      etrans.
      2: { apply cancel_postcomposition.
           repeat rewrite assoc. apply cancel_postcomposition.
           exact auxG. }
      repeat rewrite assoc'. apply maponpaths.
      repeat rewrite <- functor_comp.
      apply maponpaths.
      etrans; [ exact auxF |].
      apply assoc'.
    - assert (auxF := lineator_preservesunitor Fl x).
      assert (auxG := lineator_preservesunitor Gl (F x)).
      etrans; [| exact auxG].
      clear auxG.
      rewrite <- auxF.
      clear auxF.
      repeat rewrite assoc'.
      apply maponpaths.
      apply pathsinv0, functor_comp.
  Qed.

  Definition comp_lineator_lax : lineator_lax ActC ActE (F ∙ G) := comp_lineator_data,,comp_lineator_laxlaws.

End CompositionOfLaxLineators.

Section CompositionOfLineators.

  Context (Fl : lineator ActC ActD F) (Gl : lineator ActD ActE G).

  Definition comp_lineator_strongly_inverse (v : V) (x : C) : E ⟦ G (F (v ⊗_{ ActC} x)), v ⊗_{ ActE} G (F x) ⟧ :=
    #G (pr1 (lineator_linstrongly Fl v x)) · pr1 (lineator_linstrongly Gl v (F x)).

  Lemma comp_lineator_strongly_inverse_is_inverse (v : V) (x : C) :
    is_inverse_in_precat (comp_lineator_lax Fl Gl v x) (comp_lineator_strongly_inverse v x).
  Proof.
    split; cbn; unfold comp_lineator_data.
    - etrans.
      { repeat rewrite assoc'.
        apply maponpaths.
        unfold comp_lineator_strongly_inverse.
        rewrite assoc.
        apply cancel_postcomposition.
        rewrite <- functor_comp.
        apply maponpaths.
        apply (pr12 (lineator_linstrongly Fl v x)). }
      rewrite functor_id.
      rewrite id_left.
      apply (pr12 (lineator_linstrongly Gl v (F x))).
    - unfold comp_lineator_strongly_inverse.
      etrans.
      { repeat rewrite assoc'.
        apply maponpaths.
        rewrite assoc.
        apply cancel_postcomposition.
        apply (pr22 (lineator_linstrongly Gl v (F x))). }
      rewrite id_left.
      rewrite <- functor_comp.
      etrans.
      { apply maponpaths.
        apply (pr22 (lineator_linstrongly Fl v x)). }
      apply functor_id.
  Qed.

  Definition comp_lineator_strongly : lineator_strongly (comp_lineator_lax Fl Gl).
  Proof.
    intros v x.
    exact (comp_lineator_strongly_inverse v x,,comp_lineator_strongly_inverse_is_inverse v x).
  Defined.

  Definition comp_lineator : lineator ActC ActE (F ∙ G)
    := comp_lineator_lax Fl Gl ,, comp_lineator_strongly.

End CompositionOfLineators.

End Composition.

End LinearFunctors.

Section TransformationsOfActegories.

  Context {V : category} {Mon_V : monoidal V} {C D : category} {ActC : actegory Mon_V C} {ActD : actegory Mon_V D}.

  Definition is_linear_nat_trans {F G : functor C D}
    (Fl : lineator_lax Mon_V ActC ActD F) (Gl : lineator_lax Mon_V ActC ActD G)(ξ : F ⟹ G) : UU :=
    ∏ (v : V) (x : C), Fl v x · ξ (v ⊗_{ActC} x) = v ⊗^{ActD}_{l} ξ x · Gl v x.

  Lemma isaprop_is_linear_nat_trans {F G : functor C D}
    (Fl : lineator_lax Mon_V ActC ActD F) (Gl : lineator_lax Mon_V ActC ActD G)
    (ξ : F ⟹ G) : isaprop (is_linear_nat_trans Fl Gl ξ).
  Proof.
    apply impred; intro v; apply impred; intro x. apply D.
  Qed.

  Lemma is_linear_nat_trans_pointwise_inverse {F G : functor C D}
    (Fl : lineator_lax Mon_V ActC ActD F) (Gl : lineator_lax Mon_V ActC ActD G)
    (ξ : F ⟹ G) (isnziξ : is_nat_z_iso ξ) :
    is_linear_nat_trans Fl Gl ξ -> is_linear_nat_trans Gl Fl (nat_z_iso_inv (ξ,,isnziξ)).
  Proof.
    intros islnt v x.
    cbn.
    set (aux := (_,,is_z_iso_leftwhiskering_z_iso (actegory_action Mon_V ActD) v (ξ x) (isnziξ x)  : z_iso _ _)).
    apply pathsinv0, (z_iso_inv_on_right _ _ _ aux).
    rewrite assoc.
    apply (z_iso_inv_on_left _ _ _ _ (_,,isnziξ (v ⊗_{ActC} x))).
    cbn.
    apply (!(islnt v x)).
  Qed.

  Lemma is_linear_nat_trans_identity {F : functor C D} (Fl : lineator_lax Mon_V ActC ActD F) :
    is_linear_nat_trans Fl Fl (nat_trans_id F).
  Proof.
    intros v c.
    rewrite id_right.
    etrans.
    2: { apply cancel_postcomposition. apply pathsinv0, (bifunctor_leftid ActD). }
    apply pathsinv0, id_left.
  Qed.

  Lemma is_linear_nat_trans_comp {F G H : functor C D}
    (Fl : lineator_lax Mon_V ActC ActD F)
    (Gl : lineator_lax Mon_V ActC ActD G)
    (Hl : lineator_lax Mon_V ActC ActD H) {ξ1 : F ⟹ G} {ξ2 : G ⟹ H}
    (islnt1 : is_linear_nat_trans Fl Gl ξ1)
    (islnt2 : is_linear_nat_trans Gl Hl ξ2) : is_linear_nat_trans Fl Hl (nat_trans_comp _ _ _ ξ1 ξ2).
  Proof.
    intros v x.
    cbn.
    rewrite (bifunctor_leftcomp ActD).
    rewrite assoc.
    etrans.
    { apply cancel_postcomposition.
      apply islnt1. }
    do 2 rewrite assoc'.
    apply maponpaths.
    apply islnt2.
  Qed.

End TransformationsOfActegories.

Section StrongFunctors.

  Definition tensorialstrength {C : category} (M : monoidal C) (F : functor C C) : UU :=
    lineator_lax M (actegory_with_canonical_self_action M)
      (actegory_with_canonical_self_action M) F.

  Identity Coercion id_tensorialstrength : tensorialstrength >-> lineator_lax.

  Lemma tensorialstrength_lineator_nat_left {C : category} (M : monoidal C)
    {F : functor C C} (ts : tensorialstrength M F) :
    lineator_nat_left _ _ _ _ ts =
      ∏ (v x1 x2 : C) (g : C ⟦ x1, x2 ⟧),
      v ⊗^{ M}_{l} # F g · ts v x2 = ts v x1 · # F (v ⊗^{ M}_{l} g).
  Proof.
    apply idpath.
  Qed.

  Lemma tensorialstrength_lineator_nat_right {C : category} (M : monoidal C)
    {F : functor C C} (ts : tensorialstrength M F) :
    lineator_nat_right _ _ _ _ ts =
      ∏ (v1 v2 x : C) (f : C ⟦ v1, v2 ⟧),
      f ⊗^{ M}_{r} F x · ts v2 x = ts v1 x · # F (f ⊗^{ M}_{r} x).
  Proof.
    apply idpath.
  Qed.

  Lemma tensorialstrength_preserves_unitor {C : category} (M : monoidal C)
    {F : functor C C} (ts : tensorialstrength M F) :
    preserves_unitor _ _ _ _ ts = ∏ c : C, ts I_{M} c · # F lu^{M}_{c} = lu^{M}_{F c}.
  Proof.
    apply idpath.
  Qed.

  Lemma tensorialstrength_preserves_actor {C : category} (M : monoidal C)
    {F : functor C C} (ts : tensorialstrength M F) :
    preserves_actor _ _ _ _ ts = ∏ v w x : C,
        ts (v ⊗_{M} w) x · # F α^{M}_{v, w, x} =
          α^{M}_{v, w, F x} · v ⊗^{M}_{l} ts w x · ts v (w ⊗_{M} x).
  Proof.
    apply idpath.
  Qed.

Section LiftedStrength.

  Context {V : category} (Mon_V : monoidal V)
          {W : category} (Mon_W : monoidal W)
          {F : W ⟶ V} (U : fmonoidal Mon_W Mon_V F)
          {C D : category} (ActC : actegory Mon_V C) (ActD : actegory Mon_V D) (FF :  C ⟶ D).

  Definition liftedstrength : UU :=
    lineator_lax Mon_W (lifted_actegory Mon_V ActC Mon_W U) (lifted_actegory Mon_V ActD Mon_W U) FF.

  Identity Coercion id_liftedstrength : liftedstrength >-> lineator_lax.

End LiftedStrength.

  Definition pointedtensorialstrength {C : category} (M : monoidal C) (F : functor C C) : UU :=
    liftedstrength M (monoidal_pointed_objects M) (forget_monoidal_pointed_objects_monoidal M)
                   (actegory_with_canonical_self_action M) (actegory_with_canonical_self_action M) F.

  Goal ∏ (C : category)(M : monoidal C) (F : functor C C), pointedtensorialstrength M F =
    lineator_lax (monoidal_pointed_objects M) (actegory_with_canonical_pointed_action M)
                                              (actegory_with_canonical_pointed_action M) F.
  Proof.
    intros.
    apply idpath.
  Qed.

  Identity Coercion id_pointedtensorialstrength : pointedtensorialstrength >-> liftedstrength.

  Lemma pointedtensorialstrength_lineator_nat_left {C : category} (M : monoidal C)
    {F : functor C C} (pts : pointedtensorialstrength M F):
    lineator_nat_left _ _ _ _ pts =
      ∏ (v : coslice_cat_total C I_{M}) (x1 x2 : C) (g : C⟦x1,x2⟧),
      pr1 v ⊗^{ M}_{l} # F g · pts v x2 = pts v x1 · # F (pr1 v ⊗^{ M}_{l} g).
  Proof.
    apply idpath.
  Qed.

  Lemma pointedtensorialstrength_lineator_nat_right {C : category} (M : monoidal C)
    {F : functor C C} (pts : pointedtensorialstrength M F):
    lineator_nat_right _ _ _ _ pts =
      ∏ (v1 v2 : coslice_cat_total C I_{M}) (x : C) (f : coslice_cat_total C I_{M} ⟦v1,v2⟧),
      pr1 f ⊗^{ M}_{r} F x · pts v2 x = pts v1 x · # F (pr1 f ⊗^{ M}_{r} x).
  Proof.
    apply idpath.
  Qed.

  Lemma pointedtensorialstrength_preserves_unitor {C : category} (M : monoidal C)
    {F : functor C C} (pts : pointedtensorialstrength M F):
    preserves_unitor _ _ _ _ pts ≃
      ∏ c : C, pts I_{ monoidal_pointed_objects M} c · # F lu^{M}_{c} = lu^{M}_{F c}.
  Proof.
    use weqimplimpl.
    - intros H c.
      assert (Hc := H c). clear H.
      cbn in Hc.
      unfold total_unit, lifted_action_unitor_data in Hc. cbn in Hc.
      do 2 rewrite (bifunctor_rightid M) in Hc. do 2 rewrite id_left in Hc.
      exact Hc.
    - intros H c.
      cbn.
      unfold total_unit, lifted_action_unitor_data. cbn.
      do 2 rewrite (bifunctor_rightid M). do 2 rewrite id_left.
      apply H.
    - apply impred; intro c. apply C.
    - apply impred; intro c. apply C.
  Qed.

  Lemma pointedtensorialstrength_preserves_actor {C : category} (M : monoidal C)
    {F : functor C C} (pts : pointedtensorialstrength M F) :
    preserves_actor _ _ _ _ pts ≃
      ∏ (v w : coslice_cat_total C I_{M}) (x : C),
      pts (v ⊗_{monoidal_pointed_objects M} w) x · # F α^{M}_{pr1 v, pr1 w, x} =
          α^{M}_{pr1 v, pr1 w, F x} · pr1 v ⊗^{M}_{l} pts w x · pts v (pr1 w ⊗_{M} x).
  Proof.
    use weqimplimpl.
    - intros H v w x.
      assert (Hinst := H v w x). clear H.
      cbn in Hinst.
      unfold lifted_actor_data in Hinst. cbn in Hinst.
      do 2 rewrite (bifunctor_rightid M) in Hinst. do 2 rewrite id_left in Hinst.
      exact Hinst.
    - intros H v w x.
      cbn.
      unfold lifted_actor_data. cbn.
      do 2 rewrite (bifunctor_rightid M). do 2 rewrite id_left.
      apply H.
    - do 3 (apply impred; intro). apply C.
    - do 3 (apply impred; intro). apply C.
  Qed.

End StrongFunctors.


(** * rel: the main model of heterogeneous binary relations *)

Require Bool.
Require Export boolean prop.
Require Import kat.

Set Printing Universes.

(** We fix a type universe U and show that heterogeneous relations
between types in this universe form a kleene algebra.  *)

Universe U.
Definition hrel (n m: Type@{U}) := n -> m -> Prop.
Identity Coercion fun_of_hrel : hrel >-> Funclass.

(** * Relations as a (bounded, distributive) lattice *)

(** lattice operations and laws are obtained for free, by two
   successive pointwise liftings of the [Prop] lattice *)

Canonical Structure hrel_lattice_ops n m :=
  lattice.mk_ops (hrel n m) leq weq cup cap neg bot top.

Global Instance hrel_lattice_laws n m:
  lattice.laws (BDL+STR+CNV+DIV) (hrel_lattice_ops n m) := pw_laws _.

(** * Relations as a residuated Kleene allegory *)

Section RepOps.
  Implicit Types n m p : Type@{U}.

(** relational composition *)
Definition hrel_dot n m p (x: hrel n m) (y: hrel m p): hrel n p :=
  fun i j => exists2 k, x i k & y k j.

(** converse (or transpose) *)
Definition hrel_cnv n m (x: hrel n m): hrel m n :=
  fun i j => x j i.

(** left / right divisions *)
Definition hrel_ldv n m p (x: hrel n m) (y: hrel n p): hrel m p :=
  fun i j => forall k, x k i -> y k j.

Definition hrel_rdv n m p (x: hrel m n) (y: hrel p n): hrel p m :=
  fun j i => forall k, x i k -> y j k.

Section i.
  Variable n: Type@{U}.
  Variable x: hrel n n.
  (** finite iterations of a relation *)
  Fixpoint iter u := match u with O => @eq _ | S u => hrel_dot _ _ _ x (iter u) end.
  (** Kleene star (reflexive transitive closure) *)
  Definition hrel_str: hrel n n := fun i j => exists u, iter u i j.
  (** strict iteration (transitive closure) *)
  Definition hrel_itr: hrel n n := hrel_dot n n n x hrel_str.
End i.

End RepOps.

(** packing all operations into a monoid; note that the unit on [n] is
   just the equality on [n], i.e., the identity relation on [n] *)

(** We need to eta-expand @eq here. This generates the universe
constraint [U <= Coq.Init.Logic.8] (where the latter is the universe of
the type argument to [eq]). Without the eta-expansion, the definition
would yield the constraint [U = Coq.Init.Logig.8], which is too strong
and leads to universe inconsistencies later on. *)

Canonical Structure hrel_monoid_ops :=
  monoid.mk_ops Type@{U} hrel_lattice_ops hrel_dot (fun n => @eq n) hrel_itr hrel_str hrel_cnv hrel_ldv hrel_rdv.

(** binary relations form a residuated Kleene allegory *)
#[export] Instance hrel_monoid_laws: monoid.laws (BDL+STR+CNV+DIV) hrel_monoid_ops.
Proof.
  assert (dot_leq: forall n m p : Type@{U},
   Proper (leq ==> leq ==> leq) (hrel_dot n m p)).
   intros n m p x y H x' y' H' i k [j Hij Hjk]. exists j. apply H, Hij. apply H', Hjk.
  constructor; (try now left); intros.
   apply hrel_lattice_laws.
   intros i j. firstorder.
   intros i j. firstorder congruence.
   intros i j. firstorder.
   intros i j. reflexivity.
   intros x y E i j. apply E.
   intros i j E. exists O. exact E.
   intros i k [j Hij [u Hjk]]. exists (S u). firstorder.
   assert (E: forall i, (iter n x i: hrel n n) ⋅ z ≦ z).
    induction i. simpl. firstorder now subst.
    rewrite <-H0 at 2. transitivity (x⋅((iter n x i: hrel n n)⋅z)).
     simpl. firstorder congruence. now apply dot_leq.
    intros i j [? [? ?] ?]. eapply E. repeat eexists; eauto.
   reflexivity.
   intros i k [[j Hij Hjk] Hik]. exists j; trivial. split; firstorder.
   split. intros E i j [k Hik Hkj]. apply E in Hkj. now apply Hkj.
    intros E i j Hij k Hki. apply E. firstorder.
   split. intros E i j [k Hik Hkj]. apply E in Hik. now apply Hik.
    intros E i j Hij k Hki. apply E. firstorder.
Qed.

(** * Relations as a Kleene algebra with tests *)

(** "decidable" sets or predicates: Boolean functions

Similar to [hrel_monoid_ops] we need to eta-expand the definition of
dset to avoid forcing [U = pw] and obtain [U <= pw] instead *)

Definition dset: ob hrel_monoid_ops -> lattice.ops := fun Y => pw_ops bool_lattice_ops Y.

(** injection of decidable predicates into relations, as sub-identities *)
Definition hrel_inj n (x: dset n): hrel n n := fun i j => i=j /\ x i.

(** packing relations and decidable sets as a Kleene algebra with tests *)
Canonical Structure hrel_kat_ops :=
  kat.mk_ops hrel_monoid_ops dset hrel_inj.

(** We need to impose the constraint [U < pw] before proving this
lemma since otherwise we have [U = pw] afterwards. This leads to a
universe inconsistency when trying load ugregex_dec, kat_completeness
(as exported by kat_tac) and rel at the same time. *)

Constraint U < pw.
#[export] Instance hrel_kat_laws: kat.laws hrel_kat_ops.
Proof.
  constructor. apply lower_laws. intro. apply (pw_laws (H:=lower_lattice_laws)).
  assert (inj_leq: forall n, Proper (leq ==> leq) (@hrel_inj n)).
   intros n e f H i j [E H']. split. assumption. revert H'. apply mm_bool_Prop, H.
  constructor; try discriminate.
  apply inj_leq.
  apply op_leq_weq_1.
  intros _ x y i j. split.
   intros [E H']. setoid_rewrite Bool.orb_true_iff in H'.
    destruct H'; [left|right]; split; assumption.
   intros [[E H']|[E H']]; split; trivial; setoid_rewrite Bool.orb_true_iff; now auto.
  intros _ i j. compute. intuition discriminate.
  intros ? i j. compute. tauto.
  intros ? p q i j. split.
   intros [E H']. setoid_rewrite Bool.andb_true_iff in H'. exists i; split; tauto.
   intros [k [ik Hi] [kj Hk]]. subst. split; trivial. setoid_rewrite Bool.andb_true_iff; now split.
Qed.

(** * Functional relations  *)

Definition frel {A B: Set} (f: A -> B): hrel A B := fun x y => y = f x.

Lemma frel_comp {A B C: Set} (f: A -> B) (g: B -> C): frel f ⋅ frel g ≡ frel (fun x => g (f x)).
Proof.
  apply antisym. intros x z [y -> ->]. reflexivity.
  simpl. intros x z ->. eexists; reflexivity.
Qed.

#[export] Instance frel_weq {A B}: Proper (pwr eq ==> weq) (@frel A B).
Proof. unfold frel; split; intros ->; simpl. apply H. apply eq_sym, H. Qed.

Ltac fold_hrel := ra_fold hrel_monoid_ops.
Tactic Notation "fold_hrel" "in" hyp_list(H) := ra_fold hrel_monoid_ops in H.
Tactic Notation "fold_hrel" "in" "*" := ra_fold hrel_monoid_ops in *.


(*|
###########################################################
How to "extract" ``Z`` from subset type ``{z : Z | z > 0}``
###########################################################

:Link: https://stackoverflow.com/q/26493911
|*)

(*|
Question
********

If a function take ``Z`` as arguments, it should also be possible to
take any subset of ``Z``, right? For example, ``Zmod`` takes two ``Z``
and return ``Z``. Can I improve on this method with subset types
without reimplementing it?

I want this:
|*)

Require Import ZArith.
Open Scope Z_scope.

Definition Z_gt0 := {z | z > 0}.

Fail Definition mymod (n1 n2 : Z_gt0) := Zmod n1 n2. (* .fails *)

(*|
But Coq complains that ``n1 is expected to have type Z``, of course.
How can I make it work with ``Z_gt0``? Coerce?

This question is related to my other one here: `Random nat stream and
subset types in Coq
<https://stackoverflow.com/questions/26475258/random-nat-stream-and-subset-types-in-coq>`__

**Edit:** ``proj1_sig`` might do the trick, thanks Coq IRC channel!
|*)

(*|
Answer
******

``proj1_sig`` is the usual way to go. Another solution is to pattern
match:

.. code-block:: coq

    match z1 with
      exist _ z hz => ...
    end

``z`` will be your projection, and ``hz`` will be a proof that ``z >
0``. I usually leave the first parameter anonymous since I know that
``z : Z``.

I recent version of Coq, there is another way to do it, using ``let``
(because ``sig`` is an inductive with only one constructor):
|*)

Definition Zmod_gt0 (z1 z2 : Z_gt0) : Z :=
  let (a, _) := z1 in
  let (b, _) := z2 in
  Zmod a b.


Require Export CaseLtac Arith Omega Coq.Program.Equality.

Module Id.

(** We define a new inductive datatype [Id] so that we won't confuse
    identifiers and numbers.  We use [sumbool] to define a computable
    equality operator on [Id]. *)

Inductive t : Type :=
  T : string -> t.

Theorem eq_id_dec : forall id1 id2 : t, {id1 = id2} + {id1 <> id2}.
Proof.
   intros id1 id2.
   destruct id1 as [n1]. destruct id2 as [n2].
   destruct (string_dec n1 n2) as [Heq | Hneq].
   Case "n1 = n2".
     left. rewrite Heq. reflexivity.
   Case "n1 <> n2".
     right. intros contra. inversion contra. apply Hneq. apply H0.
Defined.

Lemma eq_id : forall (T:Type) x (p q:T),
              (if eq_id_dec x x then p else q) = p.
Proof.
  intros.
  destruct (eq_id_dec x x).
  Case "x = x".
    reflexivity.
  Case "x <> x (impossible)".
    destruct n. reflexivity. Qed.

End Id.

Definition id := Id.t.

Definition txnid := Id.t.

Definition state := id -> nat.

Definition effect := state -> state.

Definition empty_state : state :=
  fun _ => 0.

Definition id_eff : effect := fun st => st.

Definition update (st : state) (x : id) (n : nat) : state :=
  fun x' => if Id.eq_id_dec x x' then n else st x'.

Definition txn_log := txnid -> bool.

Definition empty_txn_log : txn_log := fun _ => false.

Definition commit (tl : txn_log) (n : id) : txn_log :=
  fun n' => if Id.eq_id_dec n n' then true else tl n'.

Check (1,2).

Definition context := prod state txn_log.

Definition empty_ctx : (context) := (empty_state, empty_txn_log).

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp.

Fixpoint aeval (st: state)(a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2 => (aeval st a1) - (aeval st a2)
  end.

Fixpoint beval (st : state)(b : bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2 => leb (aeval st a1) (aeval st a2)
  end.
(** ** Syntax *)

(**  c ::= SKIP
         | x ::= a
         | c ;; c
         | WHILE b DO c END       <-- Removed
         | IFB b THEN c ELSE c FI
]]
*)
Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  (*| CIf : bexp -> com -> com -> com*)
  | CPar : com -> com -> com
  | CTxn : txnid -> (effect * com) -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
(*
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).
*)
Notation "c1 ||| c2" :=
  (CPar c1 c2) (at level 100, right associativity).
Notation "'TXN' << n >> { c }" :=
  (CTxn n (id_eff,c)) (at level 60, right associativity).
Notation "'TXNF' << n >> { F [ c ] }" :=
  (CTxn n (F,c)) (at level 70, right associativity).

Lemma seq_cons_invertibility: forall c1 c2, (c1;;c2) = c2 -> False.
Proof.
  Admitted.

Module Test1.

Definition X := Id.T "x".
Definition Y := Id.T "y".
Definition Z := Id.T "z".

(* X := X + 2 *)
Definition par_plus : com :=
  TXN <<Id.T "txnL">> {X ::= (APlus (AId X) (ANum 1))} ||| TXN <<Id.T "txnR">> {X ::= (APlus (AId X) (ANum 2))}.

End Test1.

Reserved Notation "x '-t->' y" (at level 40).

Inductive txn_step : (com * state * effect) -> ((option com) * effect) -> Prop :=
  | TS_Skip : forall (st : state)(F : effect),
               (SKIP, st, F) -t-> (None, F)
  | TS_Ass : forall (st : state)(F: effect)(a : aexp)(n : nat)(x : id),
              aeval st a = n ->
              (x ::= a, st, F) -t->
                   (None, fun st => update (F st) x n)
  | TS_Seq1 : forall c1 c1' c2 st F F',
               (c1, st, F) -t-> (Some c1', F') ->
               (c1;;c2, st, F) -t-> (Some (c1';;c2), F')
  | TS_Seq2 : forall c1 c2 st F F',
               (c1, st, F) -t-> (None, F') ->
               (c1;;c2, st, F) -t-> (Some c2, F')
  where "x '-t->' y" := (txn_step x y).

Reserved Notation "x '--->' y" (at level 50).

Definition com_step_relation := (com * context) -> ((option com) * context) -> Prop.

Inductive step : com_step_relation :=
  | S_Skip : forall (ctx : context)(F : effect),
               (SKIP, ctx) ---> (None, ctx)
  | S_Ass : forall (tl:txn_log)(st : state)(F: effect)(a : aexp)(n : nat)(x : id),
              aeval st a = n ->
              (x ::= a, (st,tl)) ---> (None, (update st x n,tl))
  | S_Seq1 : forall c1 c1' c2 ctx ctx',
               (c1, ctx) ---> (Some c1', ctx') ->
               (c1;;c2, ctx) ---> (Some (c1';;c2), ctx')
  | S_Seq2 : forall c1 c2 ctx ctx',
               (c1, ctx) ---> (None, ctx') ->
               (c1;;c2, ctx) ---> (Some c2, ctx')
  | S_Par1 : forall c1 c1' c2 ctx ctx',
               (c1, ctx) ---> (Some c1', ctx') ->
               (c1 ||| c2, ctx) ---> (Some (c1' ||| c2), ctx')
  | S_Par2 : forall c1 c2 c2' ctx ctx',
               (c2, ctx) ---> (Some c2', ctx') ->
               (c1 ||| c2, ctx) ---> (Some (c1 ||| c2'), ctx')
  | S_Par3 : forall c1 c2 ctx ctx',
               (c1, ctx) ---> (None, ctx') ->
               (c1 ||| c2, ctx) ---> (Some c2, ctx')
  | S_Par4 : forall c1 c2 ctx ctx',
               (c2, ctx) ---> (None, ctx') ->
               (c1 ||| c2, ctx) ---> (Some c1, ctx')
  (*| S_Txn1 : forall c c' st F,
               (c,st,id_eff) -t-> (Some c',F) ->
               (TXN {c}, st) ---> (Some (TXNF {F[c']}), st)
  | S_Txn2 : forall c st F,
               (c,st,id_eff) -t-> (None,F) ->
               (TXN {c}, st) ---> (None, st)*)
  | S_TxnF1 : forall n c c' st tl F F',
                (c,st,F) -t-> (Some c',F') ->
                (TXNF <<n>> {F[c]}, (st,tl)) ---> (Some (TXNF <<n>> {F[c']}), (st,tl))
  | S_TxnF2 : forall n c st tl F F',
                (c,st,F) -t-> (None,F') ->
                (TXNF <<n>> {F[c]}, (st,tl)) ---> (None, (F' st, commit tl n))
  where "x '--->' y" := (step x y).

(** Multi-step reduction *)

Reserved Notation " t '--->*' t' "(at level 40).

Inductive multi_step : (com * context) -> ((option com) * context) -> Prop :=
  | base_step  : forall c opc' ctx ctx',
                    (c,ctx) ---> (opc',ctx') ->
                    (c,ctx) --->* (opc',ctx')
  | trans_step : forall c c' opc'' ctx ctx' ctx'',
                    (c,ctx) ---> (Some c',ctx') ->
                    (c',ctx') --->* (opc'',ctx'')  ->
                    (c,ctx) --->* (opc'',ctx'')
  where "t '--->*' t' " := (multi_step t t').

Notation "c1 '/' ctx '||' ctx'" := ((c1,ctx) --->* (None,ctx'))
(at level 40, ctx at level 39).

(** ** Assertions *)

Definition Assertion := context -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall ctx, P ctx -> Q ctx.

Notation "P ->> Q" :=
  (assert_implies P Q) (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall ctx ctx',
    (c / ctx || ctx')  ->
    P ctx ->
    Q ctx'.

Notation "{{ P }} c {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

Definition relation (X: Type) := X->X->Prop.

Definition ccrelation := relation context.

Inductive rstar {X:Type} (R: relation X) : relation X :=
  | rstar_refl  : forall (x : X), rstar R x x
  | rstar_trans : forall (x y z : X),
                    R x y ->
                    rstar R y z ->
                    rstar R x z.
Notation "R '^*'" := (rstar R) (at level 60).

Inductive refl_closure {X:Type} (R : relation X) : relation X :=
  | rclos_refl : forall (x : X), refl_closure R x x.

Notation "'ID+' R" := (refl_closure R) (at level 60).

SearchPattern (_*_ -> _).

Print fst.

Definition foo : (nat*nat) -> nat := fun p => let (x,_) := p in x.

Check (fun x y => x).

Definition interleaved_step (R : ccrelation) (c:com) (ctx:context)
        (opc:option com) (ctx':context) : Prop :=
                 (c,ctx) ---> (opc,ctx') \/ (opc = Some c /\ R ctx ctx').

Notation " 'RSTEP' '(' c ',' ctx ')' '-(' R ')->' '(' opc ',' ctx' ')'" :=
  (interleaved_step R c ctx opc ctx') (at level 40, c at level 39).

Inductive interleaved_multi_step (R : ccrelation) (c : com) (ctx : context)
          (opc' : option com) (ctx' : context) : Prop :=
 | interleaved_base : RSTEP (c,ctx) -(R)-> (opc',ctx') ->
                      interleaved_multi_step R c ctx opc' ctx'
 | interleaved_trans : forall c1 ctx1,
                        (c,ctx) ---> (Some c1,ctx1) ->
                        interleaved_multi_step R c1 ctx1 opc' ctx' ->
                        interleaved_multi_step R c ctx opc' ctx'.

Check interleaved_multi_step_ind.
Check list_ind.

Notation " 'R*STEP' '(' c , ctx ')' '-(' R ')->*' '(' opc ',' ctx' ')'" :=
  (interleaved_multi_step R c ctx opc ctx')(at level 40).

Definition step_guaranteed (R G :ccrelation) (c :com) (ctx : context) :=
  (forall opc' ctx', (c,ctx) ---> (opc',ctx') -> G ctx ctx')
    /\
  (forall c' opc'' ctx' ctx'',  R*STEP (c,ctx) -(R)->* (Some c',ctx') ->
                              (c',ctx') ---> (opc'',ctx'') ->
                              G ctx' ctx'').

Definition RG_quintuple (R G : ccrelation)(P : Assertion) (c:com)
           (Q : Assertion): Prop :=
  forall st, P st ->
         (* All terminating states st' satisfy the post-condition *)
         (forall st', R*STEP (c,st) -(R)->* (None,st')  -> Q st')
         (* Every transition starting from st satisfies the guarantee *)
      /\ (step_guaranteed R G c st).

Notation "{{ R ',' P }} c {{ G ',' Q }}" :=
  (RG_quintuple R G P c Q) (at level 90, c at next level).


Require Import Logic.Class.Eq.

Require Import Logic.STLC.Syntax.

Declare Scope STLC_Context_scope.

Inductive Binding (b v:Type) : Type :=
| BType : b -> Binding b v          (* Adding base type to context              *)
| BVar  : v -> T b -> Binding b v   (* Adding variable to context               *)
.

Arguments Binding {b} {v}.
Arguments BType   {b} {v}.
Arguments BVar    {b} {v}.

Notation "t ::: *" := (BType t)
    (at level 1, no associativity)      : STLC_Context_scope.

Notation "x ::: Ty" :=(BVar x Ty)
    (at level 5, no associativity)      : STLC_Context_scope.

Inductive Context (b v:Type) : Type :=
| O         : Context b v
| CtxSnoc   : Context b v -> @Binding b v -> Context b v
.

Arguments Context {b} {v}.
Arguments O       {b} {v}.
Arguments CtxSnoc {b} {v}.

Notation "G ; x" := (CtxSnoc G x)
    (at level 50, left associativity) : STLC_Context_scope.

Open Scope STLC_Context_scope.

Inductive FindT (b v:Type) : @Context b v -> b -> Prop :=
| FindTZ : forall (G:Context) (t:b), FindT b v (G ; t ::: *) t
| FindTS : forall (G:Context) (t:b) (k:Binding),
    FindT b v G t -> FindT b v (G ; k) t
.

Arguments FindT  {b} {v}.
Arguments FindTZ {b} {v}.
Arguments FindTS {b} {v}.

Notation "G >> t" := (FindT G t)
    (at level 60, no associativity) : STLC_Context_scope.

Lemma findTRev : forall (b v:Type) (G:Context) (x:v) (Ty:T b) (t : b),
    G ; x ::: Ty >> t -> G >> t.
Proof.
    intros b v G x Ty t H1. remember (G ; x ::: Ty) as G' eqn:E.
    revert G x Ty E. destruct H1 as [G t|G t k H1]; intros G' x Ty H2.
    - inversion H2.
    - inversion H2. subst. assumption.
Qed.

Lemma findTRev' : forall (b v:Type) (G:@Context b v) (t t':b),
    G ; t ::: * >> t' -> t = t' \/ G >> t'.
Proof.
    intros b v G t t' H1. remember (G;t ::: *) as G' eqn:E.
    revert G t E. destruct H1 as [G t|G t k H2];
    intros G' t' H3; inversion H3.
    - left. reflexivity.
    - subst. right. assumption.
Qed.

Inductive FindV (b v:Type) (e:Eq v) : Context -> Binding -> Prop :=
| FindVZ : forall (G:Context) (x:v) (Ty:T b),
    FindV b v e (G ; x ::: Ty) (x ::: Ty)
| FindVK : forall (G:Context) (k:Binding) (t:b),
    FindV b v e G k -> FindV b v e (G ; t ::: * ) k
| FindVS : forall (G:Context) (x y:v) (Ty Ty':T b),
    x <> y                                  ->
    FindV b v e G (x ::: Ty)                ->
    FindV b v e (G ; y ::: Ty') (x ::: Ty)
.

Arguments FindV  {b} {v} {e}.
Arguments FindVZ {b} {v} {e}.
Arguments FindVK {b} {v} {e}.
Arguments FindVS {b} {v} {e}.

Notation "G :>> k" := (FindV G k)
    (at level 60, no associativity) : STLC_Context_scope.

Lemma findVRev : forall (b v:Type) (e:Eq v) (G:Context) (t:b) (x:v) (Ty:T b),
    G ; t ::: * :>> x ::: Ty -> G :>> x ::: Ty.
Proof.
    intros b v e G t x Ty H1.
    remember (G ; t ::: *) as G' eqn:E. remember (x ::: Ty) as k eqn:F.
    revert G t x Ty E F. destruct H1 as [G x Ty|G k Ty H1|G x y Ty Ty' H1 H2];
    intros G' t x' Sy H3 H4.
    - inversion H3.
    - inversion H3. subst. assumption.
    - inversion H3.
Qed.

Lemma findVRev' : forall (b v:Type) (e:Eq v) (G:Context) (x x':v) (Ty Ty':T b),
    G ; x' ::: Ty' :>> x ::: Ty -> (x = x' /\ Ty = Ty') \/ G :>> x ::: Ty.
Proof.
    intros b v e G x x' Ty Ty' H1. remember (G;x' ::: Ty') as G' eqn:E.
    remember (x ::: Ty) as k eqn:F. revert G x x' Ty Ty' E F.
    destruct H1 as [G x Ty|G k t H2|G x y Ty Ty' H2 H3];
    intros G' x' y' Sy' Sy H4 H5.
    - inversion H4. subst. inversion H5. subst. left. split; reflexivity.
    - inversion H4.
    - inversion H4. subst. inversion H5. subst. right. assumption.
Qed.

Definition ctxIncl (b v:Type)(e:Eq v)(G H:Context) : Prop :=
    (forall (t:b), G >> t -> H >> t) /\
    (forall (x:v) (Ty:T b), G :>> x ::: Ty -> H :>> x ::: Ty).

Arguments ctxIncl {b} {v} {e}.

Notation "G <= H"  := (ctxIncl G H)
    (at level 70, no associativity) : STLC_Context_scope.

Open Scope STLC_Context_scope.

Lemma ctxInclO : forall (b v:Type) (e:Eq v) (G:@Context b v),
    O <= G.
Proof.
    intros b v e G. split.
    - intros Ty H1. remember O as H eqn:E. revert G E.
      induction H1 as [G Ty|G Ty k H1 IH]; intros G' H2; inversion H2.
    - intros x Ty H1. remember (x ::: Ty) as k eqn:E.
      remember O as H eqn:F. revert G x Ty E F.
      induction H1 as [G x Ty|G k Ty H1 IH|G x y Ty Sy H1 H2 IH];
      intros G' x' Ty' H3 H4; inversion H4.
Qed.

Lemma ctxInclRefl : forall (b v:Type) (e:Eq v) (G:@Context b v),
    G <= G.
Proof. intros b v e G. split; auto. Qed.

Lemma ctxInclTrans : forall (b v:Type) (e:Eq v) (G H K:@Context b v),
    G <= H -> H <= K -> G <= K.
Proof. intros b v e G H K [H1 H2] [H3 H4]. split; auto. Qed.

Lemma ctxInclExtendTy : forall (b v:Type) (e:Eq v) (G H:Context) (t:b),
    G <= H -> G ; t ::: * <= H ; t ::: *.
Proof.
    intros b v e G H t [H1 H2]. split.
    - intros t' H3.  remember (G ; t ::: * ) as G' eqn:E.
      revert G H H1 H2 t E. destruct H3 as [G t|G t k H1].
        + intros G' H H2 H3 t' H4. inversion H4. apply FindTZ.
        + intros G' H H2 H3 t' H4. inversion H4. subst.
          apply FindTS, H2. assumption.
    - intros x t' H3. constructor. apply H2. apply findVRev in H3. assumption.
Qed.

Lemma ctxInclExtendVar : forall (b v:Type)(e:Eq v)(G H:Context)(x:v)(Ty:T b),
    G <= H -> G ; x ::: Ty <= H ; x ::: Ty.
Proof.
    intros b v e G H x Ty [H1 H2]. split.
    - intros Sy H3. apply FindTS, H1. apply findTRev in H3. assumption.
    - intros x' Ty' H3.
      remember (G ; x ::: Ty) as G' eqn:E. remember (x' ::: Ty') as k eqn:F.
      revert G H x Ty H1 H2 x' Ty' E F.
      destruct H3 as [G x Ty|G k Ty H1|G x y Ty Sy H1 H2];
      intros G' H x' Ty' H3 H4 y' Sy' H5 H6.
        + inversion H5. apply FindVZ.
        + inversion H5.
        + inversion H5. subst. apply FindVS; try assumption.
          apply H4. assumption.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_diagonalsmeet.
Require Export GeoCoq.Elements.OriginalProofs.proposition_29B.
Require Export GeoCoq.Elements.OriginalProofs.proposition_26A.

Section Euclid.

Context `{Ax:euclidean_euclidean}.

Lemma proposition_34 :
   forall A B C D,
   PG A C D B ->
   Cong A B C D /\ Cong A C B D /\ CongA C A B B D C /\ CongA A B D D C A /\ Cong_3 C A B B D C.
Proof.
intros.
assert ((Par A C D B /\ Par A B C D)) by (conclude_def PG ).
assert (Par A C B D) by (forward_using lemma_parallelflip).
let Tf:=fresh in
assert (Tf:exists M, (BetS A M D /\ BetS C M B)) by (conclude lemma_diagonalsmeet);destruct Tf as [M];spliter.
assert (BetS B M C) by (conclude axiom_betweennesssymmetry).
assert (Col B M C) by (conclude_def Col ).
assert (Col B C M) by (forward_using lemma_collinearorder).
assert (~ Meet A B C D) by (conclude_def Par ).
assert (neq A B) by (conclude_def Par ).
assert (neq C D) by (conclude_def Par ).
assert (~ Col B C A).
 {
 intro.
 assert (Col A B C) by (forward_using lemma_collinearorder).
 assert (eq C C) by (conclude cn_equalityreflexive).
 assert (Col C D C) by (conclude_def Col ).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (TS A B C D) by (conclude_def TS ).
assert (CongA A B C B C D) by (conclude proposition_29B).
assert (~ Col B C D).
 {
 intro.
 assert (Col C D B) by (forward_using lemma_collinearorder).
 assert (eq B B) by (conclude cn_equalityreflexive).
 assert (Col A B B) by (conclude_def Col ).
 assert (Meet A B C D) by (conclude_def Meet ).
 assert (~ Meet A B C D) by (conclude_def Par ).
 contradict.
 }
assert (CongA B C D D C B) by (conclude lemma_ABCequalsCBA).
assert (CongA A B C D C B) by (conclude lemma_equalanglestransitive).
assert (Col C B M) by (forward_using lemma_collinearorder).
assert (nCol C B A).
 {
 assert (nCol B C A) by auto.
 forward_using lemma_NCorder.
 }
assert (TS A C B D) by (conclude_def TS ).
assert (CongA A C B C B D) by (conclude proposition_29B).
assert (nCol A B C) by (forward_using lemma_NCorder).
assert (CongA B C A A C B) by (conclude lemma_ABCequalsCBA).
assert (CongA B C A C B D) by (conclude lemma_equalanglestransitive).
assert (Triangle A B C) by (conclude_def Triangle ).
assert (nCol D C B) by (conclude lemma_equalanglesNC).
assert (Triangle D C B) by (conclude_def Triangle ).
assert (Cong B C C B) by (conclude cn_equalityreverse).
assert ((Cong A B D C /\ Cong A C D B /\ CongA B A C C D B)) by (conclude proposition_26A).
assert (Cong A B C D) by (forward_using lemma_congruenceflip).
assert (Cong A C B D) by (forward_using lemma_congruenceflip).
assert (Cong C A B D) by (forward_using lemma_congruenceflip).
assert (Cong C B B C) by (conclude cn_equalityreverse).
assert (Cong_3 C A B B D C) by (conclude_def Cong_3 ).
assert (CongA C A B B D C) by (conclude lemma_equalanglesflip).
assert (Cong A D D A) by (conclude cn_equalityreverse).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (eq D D) by (conclude cn_equalityreflexive).
assert (neq A C) by (forward_using lemma_angledistinct).
assert (neq C A) by (conclude lemma_inequalitysymmetric).
assert (neq C D) by (forward_using lemma_angledistinct).
assert (neq B A) by (forward_using lemma_angledistinct).
assert (neq D B) by (forward_using lemma_angledistinct).
assert (neq B D) by (conclude lemma_inequalitysymmetric).
assert (Out C A A) by (conclude lemma_ray4).
assert (Out C D D) by (conclude lemma_ray4).
assert (Out B A A) by (conclude lemma_ray4).
assert (Out B D D) by (conclude lemma_ray4).
assert (Cong B A C D) by (forward_using lemma_congruenceflip).
assert (Cong C A B D) by (forward_using lemma_congruenceflip).
assert (Cong B D C A) by (conclude lemma_congruencesymmetric).
assert (~ Col A B D).
 {
 intro.
 assert (eq D D) by (conclude cn_equalityreflexive).
 assert (Col C D D) by (conclude_def Col ).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (CongA A B D D C A) by (conclude_def CongA ).
close.
Qed.

End Euclid.