Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Naturality.
Require Import Category.Functor.Bifunctor.
Require Import Category.Structure.Monoidal.Proofs.
Require Import Category.Structure.Monoidal.Cartesian.
Require Import Category.Structure.Monoid.
Require Import Category.Structure.Group.

Generalizable All Variables.

Section CartesianMonoid.

Context `{@CartesianMonoidal C}.
Context (mon : C).
Context `{@MonoidObject C _ grp}.

Lemma mempty_right_diagonal : mappend ∘ id ⨂ (mempty ∘ eliminate) ∘ ∆ grp ≈ id.
Proof.
  rewrite bimap_comp_id_left.
  rewrite comp_assoc.
  rewrite mempty_right.
  apply proj_left_diagonal.
Qed.

Lemma mempty_left_diagonal : mappend ∘ (mempty ∘ eliminate) ⨂ id ∘ ∆ grp ≈ id.
Proof.
  rewrite bimap_comp_id_right.
  rewrite comp_assoc.
  rewrite mempty_left.
  apply proj_right_diagonal.
Qed.

End CartesianMonoid.

Section GroupProofs.

Context `{@CartesianMonoidal C}.
Context (grp : C).
Context `{@GroupObject C _ grp}.

(* This proof is analogous to the following
   proof that y = x⁻¹ for an
   element y with yx = I:

     y = yI
       = y(xx⁻¹)
       = (yx)x⁻¹
       = (yx)x⁻¹
       = Ix⁻¹
       = x⁻¹ *)
Lemma left_inverse_unique
  (X : C) (f : X ~> grp) (f_inv : X ~> grp)
  (f_left_inverse : mappend ∘ f_inv ⨂ f ∘ ∆ X ≈ mempty ∘ eliminate) :
  f_inv ≈ inverse[grp] ∘ f.
Proof.
  rewrite <- (id_left f_inv).
  (* ... = yI *)
  rewrite <- mempty_right_diagonal.
  rewrite <- (comp_assoc _ ∆grp f_inv).
  rewrite <- (diagonal_natural _ _ f_inv); simpl.
  rewrite !comp_assoc;
  rewrite <- (comp_assoc _ (_ ⨂ _) (_ ⨂ _)).
  rewrite <- bimap_comp.
  rewrite <- (comp_assoc _ eliminate _).
  rewrite (unit_terminal (eliminate ∘ f_inv) (eliminate ∘ f)).
  rewrite !comp_assoc.
  (* ... = y(xx⁻¹) *)
  rewrite <- right_inverse.
  assert (mappend ∘ id ⨂ inverse[grp] ∘ ∆grp ∘ f ≈ mappend ∘ (id ⨂ inverse[grp] ∘ ∆grp ∘ f)) as R  by (rewrite comp_assoc; cat);
    rewrite R; clear R.
  rewrite bimap_comp.
  rewrite !comp_assoc.
  (* ... = (yx)x⁻¹ *)
  rewrite mappend_assoc_sym.
  rewrite <- (comp_assoc _ _ f).
  rewrite <- (diagonal_natural _ _ f); simpl.
  rewrite !comp_assoc.
  rewrite <- bimap_comp;
  rewrite id_left.
  rewrite <- (id_right f_inv).
  rewrite bimap_comp.
  rewrite !comp_assoc;
  rewrite <- (comp_assoc _ (tensor_assoc ⁻¹) _).
  rewrite <- from_tensor_assoc_natural.
  rewrite !comp_assoc;
  rewrite <- (comp_assoc _ (id ⨂ ∆X) (∆X)).
  rewrite diagonal_tensor_assoc.
  rewrite <- (comp_assoc tensor_assoc _ _);
  rewrite (comp_assoc _ tensor_assoc _);
  rewrite <- (comp_assoc _ (tensor_assoc ⁻¹) _).
  rewrite iso_from_to;
  rewrite id_right.
  rewrite !comp_assoc;
  rewrite <- 2!(comp_assoc mappend _ _).
  rewrite <- 2!bimap_comp;
  rewrite id_right.
  rewrite !comp_assoc.
  (* ... = Ix⁻¹ *)
  rewrite f_left_inverse.
  rewrite (unit_terminal eliminate (eliminate ∘ (inverse[grp] ∘ f))).
  rewrite !comp_assoc;
  rewrite <- 2!(comp_assoc _ inverse[grp] f).
  rewrite bimap_comp.
  rewrite <- (comp_assoc _ _ ∆X).
  assert ((inverse[grp] ∘ f) ⨂ (inverse[grp] ∘ f) ≈ map (inverse[grp] ∘ f)) as R
    by reflexivity;
  rewrite R; clear R.
  rewrite <- (comp_assoc _ _ ∆X).
  rewrite (diagonal_natural _ _ (inverse[grp] ∘ f)).
  simpl.
  rewrite !comp_assoc.
  (* ... = x⁻¹ *)
  rewrite mempty_left_diagonal.
  cat.
Qed.

(* This proof is analogous to the following
   proof y⁻¹x⁻¹ = (xy)⁻¹: Calculate

     (y⁻¹x⁻¹)(xy) = y⁻¹(x⁻¹(xy))
                  = y⁻¹((x⁻¹x)y)
                  = y⁻¹(Iy)
                  = y⁻¹y
                  = I

   Then use the lemma above. *)
Lemma mappend_inverse : mappend ∘ inverse[grp] ⨂ inverse[grp] ≈ inverse[grp] ∘ mappend ∘ braid.
Proof.
  rewrite <- (comp_assoc inverse[grp] mappend braid).
  apply left_inverse_unique.
  (* (y⁻¹x⁻¹)(xy) = ... *)
  rewrite bimap_comp.
  rewrite <- bimap_id_right_left.
  rewrite !comp_assoc.
  (* ... = y⁻¹(x⁻¹(xy)) *)
  rewrite mappend_assoc.
  rewrite <- bimap_id_id.
  rewrite <- (comp_assoc _ tensor_assoc _).
  rewrite <- to_tensor_assoc_natural.
  rewrite comp_assoc;
  rewrite <- (comp_assoc _ (id ⨂ mappend) _).
  rewrite <- bimap_comp;
  rewrite id_left.
  (* ... = y⁻¹((x⁻¹x)y) *)
  rewrite mappend_assoc_sym.
  rewrite <- (comp_assoc _ tensor_assoc _).
  rewrite <- to_tensor_assoc_natural.
  rewrite !comp_assoc;
  rewrite <- (comp_assoc mappend _ _).
  rewrite <- bimap_comp;
  rewrite id_left.
  rewrite diagonal_braid2.
  rewrite !comp_assoc;
  rewrite <- (comp_assoc _ tensor_assoc (tensor_assoc ⁻¹)).
  rewrite iso_to_from;
  rewrite id_right.
  rewrite <- (comp_assoc _ (inverse[grp] ⨂ _) _).
  rewrite <- bimap_comp;
  rewrite id_right.
  rewrite hexagon_rotated.
  rewrite !comp_assoc;
  rewrite <- (comp_assoc _ (inverse[grp] ⨂ braid) _).
  rewrite <- bimap_comp;
  rewrite id_right.
  rewrite braid_invol.
  rewrite <- bimap_id_id.
  rewrite <- (comp_assoc _ (tensor_assoc ⁻¹) _).
  rewrite <- from_tensor_assoc_natural.
  rewrite !comp_assoc;
  rewrite <- (comp_assoc _ (tensor_assoc ⁻¹) _).
  rewrite iso_from_to;
  rewrite id_right.
  rewrite <- (bimap_id_left_right ∆grp ∆grp).
  rewrite !comp_assoc;
  rewrite <- (comp_assoc _ tensor_assoc _).
  rewrite <- bimap_id_id.
  rewrite <- to_tensor_assoc_natural.
  rewrite !comp_assoc;
  rewrite <- (comp_assoc mappend (inverse[grp] ⨂ _) _).
  rewrite <- bimap_comp;
  rewrite id_right.
  rewrite <- (comp_assoc _ braid _).
  rewrite <- bimap_braid.
  rewrite !comp_assoc;
  rewrite <- (comp_assoc _ ((inverse[grp] ⨂ id) ⨂ id) _).
  rewrite <- bimap_comp;
  rewrite id_left.
  rewrite <- (comp_assoc _ (mappend ⨂ id) _).
  rewrite <- bimap_comp;
  rewrite id_left.
  rewrite !comp_assoc.
  (* ... = y⁻¹(Iy) *)
  rewrite left_inverse.
  rewrite bimap_comp_id_right.
  rewrite !comp_assoc.
  (* ... = y⁻¹y *)
  rewrite mempty_left.
  rewrite <- (comp_assoc _ (eliminate ⨂ id) braid).
  rewrite bimap_braid.
  rewrite comp_assoc.
  rewrite unit_left_braid.
  rewrite <- (id_left inverse[grp]).
  rewrite bimap_comp.
  rewrite comp_assoc;
  rewrite <- (comp_assoc _ _ tensor_assoc).
  rewrite to_tensor_assoc_natural.
  rewrite comp_assoc.
  rewrite triangle_identity_right.
  rewrite comp_assoc;
  rewrite <- (comp_assoc _ _ tensor_assoc).
  rewrite iso_from_to;
  rewrite id_right.
  rewrite <- (comp_assoc _ _ (∆grp ⨂ id[grp])).
  rewrite <- bimap_comp;
  rewrite id_right.
  rewrite <- bimap_id_right_left.
  rewrite !comp_assoc.
  rewrite <- (comp_assoc _ unit_right _).
  rewrite <- to_unit_right_natural.
  rewrite !comp_assoc.
  (* ... = I *)
  rewrite left_inverse.
  rewrite <- !comp_assoc.
  rewrite eliminate_comp.
  reflexivity.
Qed.

End GroupProofs.


Require Export SfLib.
Require Export HelperFunctions.

Inductive bplustree (b: nat) (X:Type) : Type :=
  | bptLeaf : list (nat * X) -> bplustree b X
  | bptNode : list (nat * (bplustree b X)) -> bplustree b X
  .

Notation "[[ b , X | x , .. , y ]]" := (bptLeaf b X (cons x .. (cons y []) ..)) (at level 100, format
  "[[ b , X | '[v ' x , .. , y ']' ]]").
Notation "{{ b , X | f , x , .. , y }}" := (bptNode b X f (cons x .. (cons y []) ..)) (at level 99, format
  "{{ b , X | '[v  ' '//' f , '//' x , .. , y ']' '//' }}").

Example test := bptLeaf 2 bool [(1, true), (2, false)].

Inductive appears_in_kvl {X:Type} (sk: nat) : list (nat * X) -> Prop :=
  | aik_here: forall v l,		appears_in_kvl sk ((sk, v)::l)
  | aik_later: forall k v l,	appears_in_kvl sk l -> appears_in_kvl sk ((k, v)::l).

Inductive kv_appears_in_kvl {X:Type} (sk: nat) (sv: X) : list (nat * X) -> Prop :=
  | kv_aik_here: forall l,		kv_appears_in_kvl sk sv ((sk, sv)::l)
  | kv_aik_later: forall k v l,	kv_appears_in_kvl sk sv l -> kv_appears_in_kvl sk sv ((k, v)::l).

Lemma kv_appears_in_kvl_impl_appears_in_kvl: forall (X: Type) (k: nat) (v: X) (l: list (nat * X)),
  kv_appears_in_kvl k v l -> appears_in_kvl k l.
Proof.
  intros.
  induction H; constructor; assumption.
Qed.

Inductive appears_in_tree {X:Type} {b: nat} (sk: nat) : bplustree b X -> Prop :=
  | ait_leaf: forall l,	appears_in_kvl sk l -> appears_in_tree sk (bptLeaf b X l)
  | ait_node_last: forall k1 k2 v1 v2,
		appears_in_tree sk v2 -> k2 <= sk ->
		appears_in_tree sk (bptNode b X [(k1, v1), (k2, v2)])
  | ait_node_here: forall k1 k2 v1 v2 l,
		appears_in_tree sk v1 -> k1 <= sk /\ sk < k2 ->
		appears_in_tree sk (bptNode b X ((k1, v1)::(k2, v2)::l))
  | ait_node_later: forall x k1 k2 v1 v2 l,
  		appears_in_tree sk (bptNode b X ((k1, v1)::(k2, v2)::l)) ->
  		k1 <= sk ->
		appears_in_tree sk (bptNode b X (x::(k1, v1)::(k2, v2)::l)).

Inductive kv_appears_in_tree {X:Type} {b: nat} (sk: nat) (sv: X) : bplustree b X -> Prop :=
  | kv_ait_leaf: forall l,	kv_appears_in_kvl sk sv l -> kv_appears_in_tree sk sv (bptLeaf b X l)
  | kv_ait_node_last: forall k1 k2 v1 v2,
		kv_appears_in_tree sk sv v2 -> k2 <= sk ->
		kv_appears_in_tree sk sv (bptNode b X [(k1, v1), (k2, v2)])
  | kv_ait_node_here: forall k1 k2 v1 v2 l,
		kv_appears_in_tree sk sv v1 -> k1 <= sk /\ sk < k2 ->
		kv_appears_in_tree sk sv (bptNode b X ((k1, v1)::(k2, v2)::l))
  | kv_ait_node_later: forall x k1 k2 v1 v2 l,
  		kv_appears_in_tree sk sv (bptNode b X ((k1, v1)::(k2, v2)::l)) ->
  		k1 <= sk ->
		kv_appears_in_tree sk sv (bptNode b X (x::(k1, v1)::(k2, v2)::l)).

Inductive kvl_sorted {X: Type}: list (nat * X) -> Prop :=
    kvl_sorted_0    : kvl_sorted []
  | kvl_sorted_1    : forall (n: nat) (x: X),
		kvl_sorted [(n, x)]
  | kvl_sorted_cons : forall (n1 n2: nat) (x1 x2: X) (lst: list (nat * X)),
		kvl_sorted ((n2,x2)::lst) ->
		blt_nat n1 n2 = true ->
		kvl_sorted ((n1,x1)::(n2,x2)::lst).

(* Some props for having a prop apply to all elements in a list *)
Inductive all_values (X : Type) (P : X -> Prop) : list (nat * X) -> Prop :=
  | av_empty : all_values X P []
  | av_next : forall (x:X) (n: nat) (l: list (nat * X)), all_values X P l -> P x -> all_values X P ((n,x)::l)
.
Inductive all_keys (X : Type) (P : nat -> Prop) : list (nat * X) -> Prop :=
  | ak_empty : all_keys X P []
  | ak_next : forall (x:X) (n: nat) (l: list (nat * X)), all_keys X P l -> P n -> all_keys X P ((n,x)::l)
.
Inductive all (P : nat -> Prop) : list nat -> Prop :=
  | a_empty : all P []
  | a_next : forall (n: nat) (l: list nat), all P l -> P n -> all P (n::l)
.

Inductive all_values_eq_prop (X: Type)(P: X -> X -> Prop) : list (nat * X) -> Prop :=
  | alep_0    : all_values_eq_prop X P []
  | alep_1    : forall (x:X) (n: nat), all_values_eq_prop X P [(n, x)]
  | alep_next : forall (x1 x2:X) (n1 n2: nat) l,
                  all_values_eq_prop X P ((n2, x2) :: l) ->
                  P x1 x2 ->
                  all_values_eq_prop X P ((n1, x1) :: (n2, x2) :: l).

(* Some helper functions for checking if a number is above or below a given number *)
Definition below (n: nat) : nat -> Prop :=
  fun o => blt_nat o n = true.
Definition below_equal (n: nat) : nat -> Prop :=
  fun o => ble_nat o n = true.
Definition between (n m: nat) : nat -> Prop :=
  fun o => andb (ble_nat n o) (blt_nat o m) = true.
Definition above (m: nat) : nat -> Prop :=
  fun o => ble_nat m o = true.