From Minirust.def Require Import ty encoding thm wf le utils.
From Minirust.proof Require Import defs.
From Minirust.proof.lemma Require Import utils subslice le.
Require Import List Nat PeanoNat Bool Lia ssreflect.
Import ListNotations.

Section tuple.

Context {memory: Memory}.
Context {fields: Fields}.
Context {size: Size}.

Notation t := (TTuple fields size).
Context (props_IH : Forall (fun ty : Ty => wf ty -> Props ty) (map snd fields)).
Context (Hwf: wf t).

Lemma fields_fit_size_l : fields_fit_size fields size.
apply Hwf.
Qed.

(* the `i < size` argument is not really required here. It's only for historical reasons *)
Lemma fields_disjoint_l : forall i j1 j2, i < size -> j1 < length fields -> j2 < length fields -> j1 <> j2 ->
contains i (interval_of_field (nth j1 fields (0,TBool))) = true ->
contains i (interval_of_field (nth j2 fields (0, TBool))) = false.
Proof.
intros.
inversion Hwf.
inversion H5.
inversion H7.
apply (H9 i j1 j2); auto.
Qed.

Lemma props_fields : Forall Props (map snd fields).
Proof.
assert (Forall wf (map snd fields)). {
  inversion Hwf as (_ & _ & H & _).
  clear Hwf.
  induction fields. { apply Forall_nil. }
  simpl.
  destruct a as [_left x].
  simpl in H.
  apply Forall_cons.
  { inversion H. auto. }

  apply IHf.
  { simpl in props_IH. inversion props_IH. auto. }
  { inversion H. auto. }
}

clear Hwf.
induction fields. { apply Forall_nil. }

apply Forall_cons.
{ inversion props_IH. apply H2. inversion H. auto. }

apply IHf.
{ inversion props_IH. auto. }
{ inversion H. auto. }
Qed.

Lemma dec_to_enc {vals l} a
(Hl: length l = size)
(Ha: length a = size)
(H : transpose (map (decode_tuple_field decode l) fields) = Some vals)
: exists l', encode_tuple_fields a fields encode vals = Some l' /\ length l' = size.
Proof.
pose proof props_fields as Hprops.
pose proof fields_fit_size_l as Hfit.

clear Hwf.
clear props_IH.

generalize dependent fields.
generalize dependent a.

induction vals as [|v vals IH]. {
  intros. destruct fields0. { simpl. eexists _. auto. }
  pose proof transpose_len H.
  rewrite map_length in H0.
  discriminate H0.
}

intros a Ha fs H Hprops Hfit.
destruct fs as [|[off ty] fs].
{ pose proof transpose_len H. discriminate H0. }

simpl.

assert (exists ll, decode ty ll = Some v). {
  simpl in H.
  set D := (subslice_with_length _ _ _) in H.
  destruct (decode ty D) eqn:E; cycle 1. { discriminate H. }
  set tr := transpose _ in H.
  destruct tr; cycle 1. { simpl in H. discriminate H. }
  simpl in H.
  exists D.
  rewrite E.
  inversion H. auto.
}

assert (Props ty). { inversion Hprops. auto. }

destruct (PR_RT1 _ H1 v H0) as (ll & Henc & _).
rewrite Henc.
simpl.

set a' := (write_subslice_at_index _ _ _).
refine (IH a' _ fs _ _ _ ).
{ apply write_subslice_length. auto.
{ inversion Hfit.
  simpl in H4.
  rewrite Ha.
  rewrite (PR_ENCODE_LEN _ H1 v ll Henc).
  auto.
}
}
{ simpl in H.
  destruct (decode ty (subslice_with_length l off (ty_size ty))); cycle 1. { discriminate H. }
  destruct (transpose (map (decode_tuple_field decode l) fs)); cycle 1. { discriminate H. }
  inversion H.
  auto.
}
{ inversion Hprops. auto. }
{ inversion Hfit. auto. }
Qed.

Lemma tuple_dec [l v] (H: decode t l = Some v) :
  length l = size /\
  exists vals,
  transpose (map (decode_tuple_field decode l) fields) = Some vals /\
  v = VTuple vals /\
  exists l', encode t v = Some l' /\ length l' = size.
Proof.
unfold decode in H. fold decode in H. unfold decode_tuple in H.
set tr := transpose _ in H.
destruct tr as [vals|] eqn:Htr; cycle 1. { discriminate H. }

simpl in H.
destruct (Nat.eqb_spec (length l) size); cycle 1. { discriminate H. }

split. { auto. }
exists vals.
simpl in H. inversion H. clear H v H1.

set H1 := transpose _ = Some vals.
assert (H1). { auto. }
unfold H1 in *. clear H1.

split; auto.
split; auto.

unfold encode. fold encode. unfold encode_tuple.

unfold assuming.
simpl.

assert (length vals = length fields). {
  rewrite <- (transpose_len H).
  apply map_length.
}

destruct (Nat.eqb_spec (length vals) (length fields)); cycle 1. { lia. }

simpl.

refine (dec_to_enc _ e _ H).
apply repeat_length.
Qed.

Lemma tuple_encode_len : encode_len t.
Proof.
intros v l Henc.
unfold encode in Henc. fold encode in Henc. unfold encode_tuple in Henc.
destruct v as [| | |vals|]; try discriminate Henc.
simpl in Henc.
unfold assuming in Henc.
destruct (length vals =? length fields); try discriminate Henc.
simpl in Henc.

(* note that we cannot prove `length vals = length fields` *)
(* it's not a problem though, encode_tuple_fields terminates when one of the lists is empty *)

assert (forall a, length a = size -> forall ll, encode_tuple_fields a fields encode vals = Some ll -> length ll = size); cycle 1. {
  simpl.
  refine (H (repeat Uninit size) _ l Henc).
  apply repeat_length.
}

pose proof fields_fit_size_l as Hfit.
pose proof props_fields as Hprops.
clear props_IH Hwf Henc.
generalize dependent vals.

induction fields as [|[off sub_ty] fs IH].
{ intros. simpl in H0. inversion H0. rewrite <- H2. auto. }

intros.
destruct vals as [|v vals].
{ simpl in H0. inversion H0. rewrite <- H2. auto. }

simpl in H0.
destruct (encode sub_ty v) eqn:E; cycle 1.
{ simpl in H0. discriminate H0. }

simpl in H0.
refine (IH _ _ vals (write_subslice_at_index a off l0) _ _ _); auto.
{ inversion Hfit. auto. }
{ inversion Hprops. auto. }
apply write_subslice_length; auto.
inversion Hfit.
simpl in H3.
rewrite H.
inversion Hprops.
rewrite (PR_ENCODE_LEN _ H7 _ _ E).
auto.
Qed.

Lemma encode_nth_some {l off sub_ty j vals} def
  (Hj : j < length fields)
  (Hvals_len : length vals = length fields)
  (Hfieldsj : nth j fields (0, TBool) = (off, sub_ty))
  (H : encode_tuple_fields (repeat Uninit size) fields encode vals = Some l)
: exists subl, encode sub_ty (nth j vals def) = Some subl.
Proof.
pose proof (repeat_length Uninit size) as Ha.
pose proof props_fields as Hprops.
pose proof fields_fit_size_l as Hfit.

clear props_IH Hwf.

generalize dependent (repeat Uninit size).
generalize dependent vals.
generalize dependent j.
induction fields as [|[off' sub_ty'] fs IH].
{ simpl in *. lia. }

intros.
destruct vals as [|v vals].
{ simpl in *. lia. }

destruct j as [|j]. {
  simpl in *.
  destruct (encode sub_ty' v) eqn:E; try discriminate.
  simpl in H.
  exists l1.
  inversion Hfieldsj.
  rewrite <- H2.
  auto.
}

simpl.
simpl in H.
destruct (encode sub_ty' v) eqn:E; try discriminate.
simpl in H.
refine (IH _ _ j _ _ vals _ _ H _); auto.
{ inversion Hprops. auto. }
{ inversion Hfit. auto. }
{ simpl in *. lia. }

apply write_subslice_length. { auto. }
rewrite Ha.
assert (length l1 = ty_size sub_ty') as ->. {
  inversion Hprops.
  apply (PR_ENCODE_LEN _ H2 _ _ E).
}
inversion Hfit.
simpl in H2.
auto.
Qed.

Lemma encode_nth_rest {fs i vals a r l}
  (Hfit: fields_fit_size fs size)
  (Hprops: Forall Props (map snd fs))
  (H : existsb (contains i) (map interval_of_field fs) = false)
  (Hi: i < size)
  (Ha_len : length a = size)
  (Hlens : length vals = length fs)
  (Hr: nth i a Uninit = r)
  (Henc: encode_tuple_fields a fs encode vals = Some l)
: nth i l Uninit = r.
Proof.
clear props_IH Hwf.

generalize dependent vals.
generalize dependent a.

induction fs as [|[off sub_ty] fs IH].
{ intros. simpl in Henc. inversion Henc. rewrite <- H1. auto. }

intros.
destruct vals as [|v vals].
{ simpl in *. discriminate. }

simpl in Henc.
destruct (encode sub_ty v) eqn:E'; try discriminate.
simpl in Henc.

simpl in H.
destruct (contains i (off, ty_size sub_ty)) eqn:E; try discriminate.
simpl in H.

assert (length l0 = ty_size sub_ty) as Hl0. {
  inversion Hprops.
  apply (PR_ENCODE_LEN _ H2 _ _ E').
}

refine (IH _ _ _ (write_subslice_at_index a off l0) _ _ vals _ _); auto.
{ inversion Hfit. auto. }
{ inversion Hprops. auto. }
{ apply write_subslice_length; auto.
  rewrite Hl0.
  inversion Hfit.
  simpl in H2.
  rewrite Ha_len.
  auto.
}
{ rewrite <- Hl0 in E.
  rewrite <- Hr.
  refine (subslice_write_nth_miss _ E).
  rewrite Hl0.
  rewrite Ha_len.
  inversion Hfit.
  simpl in H2.
  auto.
}
Qed.

Lemma encode_nth_miss {i vals l}
  (H : existsb (contains i) (map interval_of_field fields) = false)
  (Hi: i < size)
  (Hlens : length vals = length fields)
  (Henc: encode_tuple_fields (repeat Uninit size) fields encode vals = Some l)
: nth i l Uninit = Uninit.
Proof.
refine (encode_nth_rest fields_fit_size_l props_fields H Hi _ Hlens _ Henc).
{ apply repeat_length. }
{ apply nth_repeat. }
Qed.

Lemma encode_nth_hit {i l j vals} def
  (Hj : j < length fields)
  (Hvals_len : length vals = length fields)
  (H : encode_tuple_fields (repeat Uninit size) fields encode vals = Some l)
  (Hcont : contains i (interval_of_field (nth j fields (0,TBool))) = true)
: let (off, sub_ty) := nth j fields (0, TBool) in
exists subl, encode sub_ty (nth j vals def) = Some subl /\  nth i l Uninit = nth (i-off) subl Uninit.
Proof.
pose proof (repeat_length Uninit size) as Ha.
pose proof props_fields as Hprops.
pose proof fields_fit_size_l as Hfit.
pose proof fields_disjoint_l as Hdisj.

clear props_IH Hwf.

generalize dependent (repeat Uninit size).
generalize dependent vals.
generalize dependent j.

induction fields as [|f fs IH].
{ intros. simpl in Hj. lia. }

intros j Hj Hcont vals Hvals_len a H0 Ha.

destruct f as [off sub_ty] eqn:F.

destruct j as [|j]; cycle 1. {
  destruct vals as [|v vals]. { simpl in Hvals_len. lia. }
  simpl.
  simpl in H0.
  destruct (encode sub_ty v) eqn:E; cycle 1.
  { simpl in H0. discriminate H0. }
  refine (IH _ _ _ j _ _ vals _ (write_subslice_at_index a off l0) _ _); auto.
  { inversion Hprops. auto. }
  { inversion Hfit. auto. }
  { intros i' j1 j2 Hi' Hj1 Hj2 Hdiff Ht.
    refine (Hdisj i' (S j1) (S j2) Hi' _ _ _ _); simpl; try lia.
    auto.
  }
  { simpl in Hj. lia. }
  { apply write_subslice_length; auto.
    rewrite Ha.
    inversion Hprops.
    rewrite (PR_ENCODE_LEN _ H2 _ _ E).
    inversion Hfit.
    simpl in H6.
    auto.
  }
}

destruct vals as [|v vals].
{ simpl in *. discriminate Hvals_len. }

destruct (encode sub_ty v) eqn:E; cycle 1.
{ simpl in *. rewrite E in H0. discriminate. }

exists l0.
split. { auto. }
simpl in H0.

assert (length l0 = ty_size sub_ty) as Hl0. {
  inversion Hprops.
  apply (PR_ENCODE_LEN _ H2 _ _ E).
}

assert (off + length l0 <= length a) as Hfitl0. {
  rewrite Ha.
  rewrite Hl0.
  inversion Hfit.
  apply H2.
}

assert (nth i (write_subslice_at_index a off l0) Uninit = nth (i - off) l0 Uninit). {
  apply subslice_write_nth_hit; auto.
  { rewrite Hl0. auto. }
}

rewrite E in H0.
simpl in H0.

assert (i < size) as Hi. {
  unfold contains in Hcont.
  simpl in Hcont.
  destruct (andb_prop _ _ Hcont) as [_ Hil].
  destruct (Nat.ltb_spec i (off + ty_size sub_ty)); try discriminate Hil.
  assert (off + ty_size sub_ty <= size); cycle 1. { lia. }
  rewrite Ha in Hfitl0.
  rewrite <- Hl0.
  auto.
}

assert (length vals = length fs) as Hvfs_len.
{ simpl in Hvals_len. lia. }

refine (encode_nth_rest _ _ _ Hi _ Hvfs_len H _); auto; cycle 3.
{ apply write_subslice_length; auto. }
{ inversion Hfit. auto. }
{ inversion Hprops. auto. }

clear - Hdisj Hcont Hi.
simpl in Hcont.

assert (forall j, j < length fs -> contains i (interval_of_field (nth j fs (0,TBool))) = false). {
  intros j Hj.
  refine (Hdisj i 0 (S j) Hi _ _ _ _); try (simpl; lia).
  simpl. auto.
}
clear - H.

induction fs as [|[off sub_ty] fs IH].
{ simpl. auto. }

simpl.
assert (contains i (off, ty_size sub_ty) = false) as ->. {
  refine (H 0 _).
  simpl. lia.
}
simpl.
apply IH.
intros j Hj.
refine (H (S j) _).
simpl. lia.
Qed.

Lemma subslice_encode {l off sub_ty j vals def}
  (Hj : j < length fields)
  (Hvals_len : length vals = length fields)
  (Hfieldsj : nth j fields (0, TBool) = (off, sub_ty))
  (Hl: length l = size)
  (H : encode_tuple_fields (repeat Uninit size) fields encode vals = Some l)
: Some (subslice_with_length l off (ty_size sub_ty)) = encode sub_ty (nth j vals def).
Proof.
destruct (encode_nth_some def Hj Hvals_len Hfieldsj H) as (l' & Henc).
rewrite Henc.
f_equal.

assert (length (subslice_with_length l off (ty_size sub_ty)) = ty_size sub_ty). {
  rewrite subslice_length; auto.
  rewrite Hl.
  pose proof fields_fit_size_l as Hfit.
  pose proof (proj1 (Forall_nth _ _) Hfit) as Hfit_nth.
  assert (sub_ty = nth j (map snd fields) TBool) as ->. {
    rewrite (map_nth_switchd (0,TBool) _); auto.
    rewrite Hfieldsj.
    auto.
  }
  pose proof (Hfit_nth j (0,TBool) Hj).
  rewrite Hfieldsj in H0.
  simpl in H0.
  auto.
}

assert (length l' = ty_size sub_ty). {
  pose proof props_fields as Hprops.
  pose proof (proj1 (Forall_nth _ _) Hprops) as Hprops_nth.
  assert (sub_ty = nth j (map snd fields) TBool) as ->. {
    rewrite (map_nth_switchd (0,TBool) _); auto.
    rewrite Hfieldsj.
    auto.
  }
  assert (j < length (map snd fields)) as HF.
  { rewrite map_length. auto. }

  pose proof (Hprops_nth j TBool HF).
  apply (PR_ENCODE_LEN _ H1 _ _ Henc).
}

refine (nth_ext _ _ Uninit Uninit _ _).
{ rewrite H1. auto. }
intros i Hi.

assert (i < ty_size sub_ty).
{ rewrite <- H0. auto. }

rewrite subslice_nth; auto. {
  rewrite Hl.
  pose proof fields_fit_size_l as Hfit.
  pose proof (proj1 (Forall_nth _ _) Hfit) as Hfit_nth.
  assert (sub_ty = nth j (map snd fields) TBool) as ->. {
    rewrite (map_nth_switchd (0,TBool) _); auto.
    rewrite Hfieldsj.
    auto.
  }
  pose proof (Hfit_nth j (0,TBool) Hj).
  simpl in H3.
  rewrite Hfieldsj in H3.
  simpl in H3.
  auto.
}

assert (contains (i+off) (interval_of_field (nth j fields (0, TBool))) = true). {
  rewrite Hfieldsj.
  unfold contains.
  simpl.
  destruct (Nat.leb_spec off (i + off)); try lia.
  simpl.
  destruct (Nat.ltb_spec (i + off) (off + ty_size sub_ty)); lia.
}

pose proof (encode_nth_hit def Hj Hvals_len H H3).
rewrite Hfieldsj in H4.
destruct H4 as (l'' & Henc' & ->).
assert (l' = l'') as ->.
{ rewrite Henc' in Henc. inversion Henc. auto. }
f_equal.
lia.
Qed.

Lemma tuple_rt1 : rt1 t.
intros v [l Hdec].
destruct (tuple_dec Hdec) as (Hlen & vals & Htr & -> & l' & Henc & Hlen').
exists l'.
split. { auto. }
unfold decode. fold decode. unfold decode_tuple.

assert (length vals = length fields) as Hvals_len. {
  rewrite <- (transpose_len Htr).
  rewrite map_length.
  auto.
}

assert (transpose (map (decode_tuple_field decode l') fields) = Some vals); cycle 1. {
  rewrite H.
  simpl.
  rewrite (tuple_encode_len _ _ Henc).
  simpl.
  rewrite Nat.eqb_refl.
  auto.
}

assert (encode_tuple_fields (repeat Uninit size) fields encode vals = Some l'). {
  unfold encode in Henc. fold encode in Henc. unfold encode_tuple in Henc.
  simpl in Henc.
  unfold assuming in Henc.
  rewrite Hvals_len in Henc.
  rewrite Nat.eqb_refl in Henc.
  simpl in Henc.
  auto.
}

apply (transpose_nth_ext (VBool true)).
{ rewrite map_length. auto. }

intros def j Hj.
rewrite map_length in Hj.
rewrite (map_nth_switchd (0,TBool)); auto.
destruct (nth j fields (0, TBool)) as [off sub_ty] eqn:Hfieldsj.
unfold decode_tuple_field.
rewrite Hfieldsj.

assert (rt1 sub_ty) as Hsub_rt1. {
  pose proof props_fields as Hprops.
  pose proof (proj1 (Forall_nth _ _) Hprops) as Hprops_nth.
  assert (sub_ty = nth j (map snd fields) TBool) as ->. {
    rewrite (map_nth_switchd (0,TBool) _); auto.
    rewrite Hfieldsj.
    auto.
  }
  refine (PR_RT1 _ (Hprops_nth j _ _)).
  rewrite map_length. auto.
}

assert (Some (subslice_with_length l' off (ty_size sub_ty)) = encode sub_ty (nth j vals def)); cycle 1. {
  assert (decode_tuple_field decode l (nth j fields (0,TBool)) = Some (nth j vals def)). {
    pose proof (transpose_nth Htr).
    rewrite <- H1; cycle 1. { rewrite map_length. auto. }
    rewrite (map_nth_switchd (0,TBool)); auto.
  }
  assert (is_valid_for sub_ty (nth j vals def)). {
    unfold decode_tuple_field in H1.
    rewrite Hfieldsj in H1.
    eexists _.
    apply H1.
  }
  destruct (Hsub_rt1 _ H2) as (lsub & Hsubenc & Hsubdec).
  assert (lsub = subslice_with_length l' off (ty_size sub_ty)) as <-; cycle 1. { auto. }
  rewrite <- H0 in Hsubenc.
  inversion Hsubenc.
  auto.
}

apply subslice_encode; auto.
Qed.

Lemma tuple_rt2 : rt2 t.
intros l v Hdec.
destruct (tuple_dec Hdec) as (Hlen & vals & Htr & -> & l' & Henc & Hlen').
exists l'.
split. { auto. }
apply (le_nth Uninit). { lia. }
intros i Hi.

pose proof fields_fit_size_l as Hfit.
pose proof (proj1 (Forall_nth _ _) Hfit) as Hfit_nth.

pose proof props_fields as Hprops.
pose proof (proj1 (Forall_nth _ _) Hprops) as Hprops_nth.

assert (length vals = length fields) as Hvals_len. {
  pose proof transpose_len Htr.
  rewrite <- H.
  rewrite map_length.
  auto.
}

destruct (existsb (contains i) (map interval_of_field fields)) eqn:Hex; cycle 1. {
  unfold encode in Henc. fold encode in Henc. unfold encode_tuple in Henc.
  simpl in Henc.
  unfold assuming in Henc.
  rewrite Hvals_len in Henc.
  rewrite (Nat.eqb_refl (length fields)) in Henc.
  simpl in Henc.
  rewrite (encode_nth_miss Hex _ Hvals_len Henc).
  { rewrite <- Hlen'. auto. }
  simpl.
  auto.
}

destruct (proj1 (existsb_exists _ _) Hex) as (interval & Hin & Hcont).
destruct (In_nth _ _ (0,0) Hin) as [j [Hj Hnth]].
rewrite map_length in Hj.

unfold encode in Henc. fold encode in Henc. unfold encode_tuple in Henc.
simpl in Henc.
unfold assuming in Henc.
rewrite Hvals_len in Henc.
rewrite (Nat.eqb_refl (length fields)) in Henc.
simpl in Henc.

destruct (nth j fields (0, TBool)) as [off sub_ty] eqn:Hdestr.

assert (off + ty_size sub_ty <= size) as Hfitsub. {
  pose proof Hfit_nth j (0, TBool) Hj.
  rewrite Hdestr in H.
  simpl in H.
  auto.
}

assert (interval = (off, ty_size sub_ty)) as ->. {
  rewrite (map_nth_switchd (0, TBool)) in Hnth; auto.
  rewrite Hdestr in Hnth.
  auto.
}

assert (contains i (interval_of_field (nth j fields (0, TBool))) = true) as Hcont'. {
  rewrite <- Hcont.
  f_equal.
  rewrite Hdestr.
  auto.
}

assert (off <= i /\ i < off + ty_size sub_ty) as [Ho1 Ho2]. {
  unfold contains in Hcont.
  simpl in Hcont.
  destruct (andb_prop _ _ Hcont) as [A B].
  split.
  { destruct (Nat.leb_spec off i); lia. }
  { destruct (Nat.ltb_spec i (off + ty_size sub_ty)); lia. }
}

pose proof (encode_nth_hit (VBool true) Hj Hvals_len Henc Hcont') as F.
rewrite Hdestr in F.
destruct F as (subl & Hsubenc & ->).

assert (j < length (map (decode_tuple_field decode l) fields)) as H''.
{ rewrite map_length. auto. }
pose proof (transpose_nth Htr (VBool true) j H'').
rewrite (map_nth_switchd (0,TBool) Hj) in H.
unfold decode_tuple_field in H.
rewrite Hdestr in H.
simpl in H.
replace (nth i l Uninit) with (nth (i-off+off) l Uninit); cycle 1.
{ f_equal. lia. }

rewrite <- (@subslice_nth _ off (ty_size sub_ty) (i-off) l Uninit); try lia.
apply le_nth_rev. { apply le_abstract_byte_refl. }
remember (nth j vals (VBool true)) as v.
assert (Props sub_ty) as Hsubprops. {
  assert (j < length (map snd fields)) as H'. { rewrite map_length. auto. }
  pose proof (Hprops_nth j TBool H').
  rewrite (map_nth_switchd (0,TBool)) in H0; auto.
  rewrite Hdestr in H0.
  auto.
}

destruct (PR_RT2 _ Hsubprops _ _ H) as (ll & B & C).
assert (subl = ll) as ->. {
  rewrite B in Hsubenc.
  inversion Hsubenc.
  auto.
}

auto.
Qed.

Lemma tuple_mono1 : mono1 t.
intros v1 v2 Hle [l1 Hdec1] [l2 Hdec2].
destruct (tuple_dec Hdec1) as (Hlen1 & vals1 & Htr1 & -> & l1' & Henc1 & Hlen1').
destruct (tuple_dec Hdec2) as (Hlen2 & vals2 & Htr2 & -> & l2' & Henc2 & Hlen2').
exists l1', l2'.
split. { auto. }
split. { auto. }

apply (le_nth Uninit). { lia. }
intros i Hi.

assert (length vals1 = length fields) as Hvals_len1. {
  apply transpose_len in Htr1.
  rewrite map_length in Htr1.
  auto.
}

assert (length vals2 = length fields) as Hvals_len2. {
  apply transpose_len in Htr2.
  rewrite map_length in Htr2.
  auto.
}

assert (encode_tuple_fields (repeat Uninit size) fields encode vals1 = Some l1') as Henc1'. {
  unfold encode in Henc1. fold encode in Henc1. unfold encode_tuple in Henc1.
  simpl in Henc1.
  unfold assuming in Henc1.
  rewrite Hvals_len1 in Henc1.
  rewrite (Nat.eqb_refl (length fields)) in Henc1.
  simpl in Henc1.
  auto.
}

assert (encode_tuple_fields (repeat Uninit size) fields encode vals2 = Some l2') as Henc2'. {
  unfold encode in Henc2. fold encode in Henc2. unfold encode_tuple in Henc2.
  simpl in Henc2.
  unfold assuming in Henc2.
  rewrite Hvals_len2 in Henc2.
  rewrite (Nat.eqb_refl (length fields)) in Henc2.
  simpl in Henc2.
  auto.
}

destruct (existsb (contains i) (map interval_of_field fields)) eqn:Hex; cycle 1. {
  rewrite (encode_nth_miss Hex _ Hvals_len1 Henc1').
  { rewrite <- Hlen1'. auto. }
  simpl.
  auto.
}

destruct (proj1 (existsb_exists _ _) Hex) as (interval & Hin & Hcont).
destruct (In_nth _ _ (0,0) Hin) as [j [Hj Hnth]].
rewrite map_length in Hj.

destruct (nth j fields (0, TBool)) as [off sub_ty] eqn:Hdestr.

assert (interval = (off, ty_size sub_ty)) as ->. {
  rewrite (map_nth_switchd (0, TBool)) in Hnth; auto.
  rewrite Hdestr in Hnth.
  auto.
}

assert (contains i (interval_of_field (nth j fields (0, TBool))) = true) as Hcont'. {
  rewrite Hdestr.
  auto.
}

pose proof encode_nth_hit (VBool true) Hj Hvals_len1 Henc1' Hcont' as F1.
rewrite Hdestr in F1.
destruct F1 as (subl1 & Hsubenc1 & ->).

pose proof encode_nth_hit (VBool true) Hj Hvals_len2 Henc2' Hcont' as F2.
rewrite Hdestr in F2.
destruct F2 as (subl2 & Hsubenc2 & ->).

apply le_nth_rev. { apply le_abstract_byte_refl. }

assert (Props sub_ty) as Hsubprops. {
  pose proof props_fields as Hprops.
  pose proof (proj1 (Forall_nth _ _) Hprops) as Hprops_nth.
  assert (j < length (map snd fields)). { rewrite map_length. auto. }
  pose proof (Hprops_nth j TBool H).
  rewrite (map_nth_switchd (0,TBool)) in H0.
  rewrite map_length in H; auto.
  rewrite Hdestr in H0.
  auto.
}

assert (decode sub_ty (subslice_with_length l1 off (ty_size sub_ty)) = Some (nth j vals1 (VBool true))) as Hdec1_. {
  assert (j < length (map (decode_tuple_field decode l1) fields)). { rewrite map_length. auto. }
  pose proof transpose_nth Htr1 (VBool true) j H.
  rewrite (map_nth_switchd (0, TBool)) in H0; auto.
  unfold decode_tuple_field in H0.
  rewrite Hdestr in H0.
  auto.
}

assert (is_valid_for sub_ty (nth j vals1 (VBool true))) as Hval1. {
  exists (subslice_with_length l1 off (ty_size sub_ty)).
  auto.
}

assert (decode sub_ty (subslice_with_length l2 off (ty_size sub_ty)) = Some (nth j vals2 (VBool true))) as Hdec2_. {
  assert (j < length (map (decode_tuple_field decode l2) fields)). { rewrite map_length. auto. }
  pose proof transpose_nth Htr2 (VBool true) j H.
  rewrite (map_nth_switchd (0, TBool)) in H0; auto.
  unfold decode_tuple_field in H0.
  rewrite Hdestr in H0.
  auto.
}

assert (is_valid_for sub_ty (nth j vals2 (VBool true))) as Hval2. {
  exists (subslice_with_length l2 off (ty_size sub_ty)).
  auto.
}

assert (le (nth j vals1 (VBool true)) (nth j vals2 (VBool true))) as Hle_vs. {
  assert (le vals1 vals2). { auto. }
  assert (length vals1 = length vals2). { apply (le_len H). }
  assert (j < length vals1). { rewrite Hvals_len1. auto. }
  refine (@le_nth_rev _ j _ _ _ (VBool true) _ H).
  apply le_val_refl.
}

remember (nth j vals1 (VBool true)) as v1.
remember (nth j vals2 (VBool true)) as v2.

destruct (PR_MONO1 _ Hsubprops v1 v2 Hle_vs Hval1 Hval2) as (ll1 & ll2 & He1 & He2 & Hle').
assert (subl1 = ll1) as -> . { rewrite He1 in Hsubenc1. inversion Hsubenc1. auto. }
assert (subl2 = ll2) as -> . { rewrite He2 in Hsubenc2. inversion Hsubenc2. auto. }
auto.
Qed.

Lemma tuple_mono2 : mono2 t.
intros l1 l2 Hle.
destruct (decode t l1) eqn:Hdec1; try (simpl; done).
destruct (tuple_dec Hdec1) as (Hlen1 & vals1 & Htr1 & -> & l1' & Henc1 & Hlen1').
unfold decode. fold decode. unfold decode_tuple.

assert (exists vals2, transpose (map (decode_tuple_field decode l2) fields) = Some vals2 /\ le vals1 vals2) as (vals2 & Htr & Hle'); cycle 1. {
  rewrite Htr.
  assert (length l2 =? size = true) as ->. {
    pose proof le_len Hle.
    rewrite <- H.
    rewrite Hlen1.
    apply Nat.eqb_refl.
  }
  simpl.
  auto.
}

pose proof props_fields as Hprops.
pose proof fields_fit_size_l as Hfit.

clear Hwf props_IH Henc1 l1' Hlen1' Hdec1.

assert (length vals1 = length fields) as Hval_len1. {
  pose proof (transpose_len Htr1).
  rewrite map_length in H.
  auto.
}

generalize dependent vals1.

induction fields as [|[off sub_ty] fs IH].
{ intros. exists []. split. { auto. } destruct vals1; try discriminate. simpl. auto. }

intros.
simpl map.
simpl map in Htr1.

destruct vals1 as [|v1 vals1]. { discriminate. }
simpl in Htr1.

destruct (decode sub_ty (subslice_with_length l1 off (ty_size sub_ty))) as [v1_|] eqn:E1; try discriminate.
destruct (transpose (map (decode_tuple_field decode l1) fs)) as [vals1_|] eqn:E2; try discriminate.

simpl in Htr1.
assert (v1_ = v1) as ->. { inversion Htr1. auto. }
assert (vals1_ = vals1) as ->. { inversion Htr1. auto. }

assert (exists v2, decode sub_ty (subslice_with_length l2 off (ty_size sub_ty)) = Some v2 /\ le v1 v2) as (v2 & Hdec_v2 & Hlev); cycle 1. {
  rewrite Hdec_v2.
  assert (Some vals1 = Some vals1). { auto. }
  assert (length vals1 = length fs). { simpl in Hval_len1. lia. }
  assert (Forall Props (map snd fs)) as Hp. { inversion Hprops. auto. }
  assert (fields_fit_size fs size) as Hf. { inversion Hfit. auto. }
  destruct (IH Hp Hf vals1 H H0) as (vals2 & Htr2 & Hle_vals2).
  exists (v2 :: vals2).
  split. { simpl. rewrite Htr2. simpl. auto. }
  simpl. auto.
}

assert (length l2 = size) as Hlen2. {
  rewrite <- (le_len Hle).
  auto.
}

assert (size >= off + ty_size sub_ty) as Hsubfit.
{ inversion Hfit. auto. }

assert (le (subslice_with_length l1 off (ty_size sub_ty)) (subslice_with_length l2 off (ty_size sub_ty))). {
  apply (le_nth Uninit). {
    rewrite subslice_length. { rewrite Hlen1. auto. }
    rewrite subslice_length. { rewrite Hlen2. auto. }
    auto.
  }
  intros i Hi.
  assert (length l1 >= off + ty_size sub_ty).
  { rewrite Hlen1. auto. }

  assert (i < ty_size sub_ty) as Hi2. {
    rewrite (subslice_length H) in Hi.
    auto.
  }
  rewrite subslice_nth. { auto. } { rewrite Hlen1. auto. }
  rewrite subslice_nth. { auto. } { rewrite Hlen2. auto. }
  apply le_nth_rev; auto.
  apply le_abstract_byte_refl.
}
assert (Props sub_ty) as Hsubprops. { inversion Hprops. auto. }

pose proof PR_MONO2 _ Hsubprops _ _ H.
rewrite E1 in H0.
destruct (decode sub_ty (subslice_with_length l2 off (ty_size sub_ty))); cycle 1. { contradiction. }
exists v. split. { auto. }
auto.
Qed.

Lemma tuple_props : Props t.
Proof.
split.
- auto.
- apply tuple_rt1.
- apply tuple_rt2.
- apply tuple_mono1.
- apply tuple_mono2.
- apply tuple_encode_len.
Qed.

End tuple.


Require Import
  Coq.Arith.Arith
  Coq.ZArith.ZArith
  Coq.micromega.Lia
  Coq.Strings.String
  Hask.Control.Monad
  Data.Monoid
  Data.PartialMap
  EnsemblesExt
  Lib
  Ltac
  RWSP.

Set Universe Polymorphism.

From Equations Require Import Equations.
Set Equations With UIP.

Derive NoConfusion NoConfusionHom Subterm EqDec for Ascii.ascii.
Derive NoConfusion NoConfusionHom Subterm EqDec for string.
Derive NoConfusion NoConfusionHom Subterm EqDec for Z.
Next Obligation. now apply Z.eq_dec. Defined.
Derive NoConfusion NoConfusionHom Subterm EqDec for nat.
Derive NoConfusion NoConfusionHom Subterm EqDec for bool.

Generalizable All Variables.

(** A partial magma defines a constrained version of its binary operation.
    This operation is typically not associative, since order of operation can
    matter. *)
Class PartialMagma (A : Type) := {
  pappendLim (x y : A) : option A;
}.

Instance nat_PartialMagma (limit : nat) : PartialMagma nat := {
  pappendLim := λ (x y : nat),
    let z := x + y in
    if limit <? z
    then None
    else Some z
}.

Section Pact.

Import ListNotations.

Inductive Ty : Set :=
  | TUnit
  | TPair : Ty → Ty → Ty
  | TString
  | TInteger
  | TDecimal
  | TBool
  | TTime
  (* | TKeyset *)
  (* | TGuard *)
  | TList : Ty → Ty
  (* | TObject *)
  (* | TFunc *)
  (* | TPact *)
  (* | TTable *)
  (* | TSchema *)
.

Derive NoConfusion NoConfusionHom Subterm EqDec for Ty.

Fixpoint denoteTy (t : Ty) : Set :=
  match t with
  | TUnit     => unit
  | TPair x y => denoteTy x * denoteTy y
  | TString   => string
  | TInteger  => Z
  | TDecimal  => nat
  | TBool     => bool
  | TTime     => nat
  | TList t   => list (denoteTy t)
  end.

Declare Scope Type_scope.
Bind Scope Type_scope with Ty.
Delimit Scope Ty_scope with ty.

Notation "⟦ t ⟧" := (denoteTy t%ty) (at level 9) : type_scope.

(* This couldn't be derived due to the recursion at [VList]. *)
Equations Value_EqDec t : EqDec ⟦t⟧ :=
  Value_EqDec TUnit tt tt := left _;
  Value_EqDec (TPair t1 t2) (x1, y1) (x2, y2)
    with @eq_dec _ (Value_EqDec t1) x1 x2 := {
      | left  _ with @eq_dec _ (Value_EqDec (t2)) y1 y2 := {
        | left _  => left _
        | right _ => right _
      }
      | right _ => right _
  };
  Value_EqDec TString s1 s2
    with eq_dec s1 s2 := {
      | left _  => left _
      | right _ => right _
    };
  Value_EqDec TInteger i1 i2
    with eq_dec i1 i2 := {
      | left _  => left _
      | right _ => right _
    };
  Value_EqDec TDecimal d1 d2
    with eq_dec d1 d2 := {
      | left _  => left _
      | right _ => right _
    };
  Value_EqDec TBool b1 b2
    with eq_dec b1 b2 := {
      | left _  => left _
      | right _ => right _
    };
  Value_EqDec TTime t1 t2
    with eq_dec t1 t2 := {
      | left _  => left _
      | right _ => right _
    };
  Value_EqDec (TList _)   ([]) ([]) := left _;
  Value_EqDec (TList _)   ((_ :: _)) ([]) := right _;
  Value_EqDec (TList _)   ([]) ((_ :: _)) := right _;
  Value_EqDec (TList ty)  ((x1 :: xs1)) ((y1 :: ys1))
    with @eq_dec _ (Value_EqDec ty) x1 y1 := {
      | left _  with @eq_dec _ (list_eqdec (Value_EqDec ty)) xs1 ys1 := {
        | left _  => left _
        | right _ => right _
      }
      | right _ => right _
    }.

#[export]
Instance Value_EqDec' {t} : EqDec ⟦t⟧ := Value_EqDec t.

(******************************************************************************
 * Capability Semantics
 *)

Record CapSig : Set := {
  name : string;
  paramTy : Ty
}.

Derive NoConfusion NoConfusionHom Subterm EqDec for CapSig.

Record Cap (s : CapSig) : Set := MkCap {
  param : ⟦paramTy s⟧
}.

Derive NoConfusion NoConfusionHom Subterm EqDec for Cap.

Record MCapSig : Set := {
  baseSig : CapSig;
  valueTy : Ty
}.

Derive NoConfusion NoConfusionHom Subterm EqDec for MCapSig.

Record MCap (s : MCapSig) : Set := MkMCap {
  base : Cap (baseSig s);
  value : ⟦valueTy s⟧
}.

Derive NoConfusion NoConfusionHom Subterm EqDec for MCap.

Inductive ACap : Set :=
  | Unmanaged {csig : CapSig}  : Cap csig  → ACap
  | Managed   {csig : MCapSig} : MCap csig → ACap.

Derive NoConfusion NoConfusionHom Subterm EqDec for ACap.

Record PactEnv := {
  granted : Ensemble ACap;
}.

Record PactState := {
  resources : Ensemble { s : MCapSig & ⟦valueTy s⟧ };
}.

Record PactLog := MkPactLog {}.

#[export]
Program Instance PactLog_Semigroup : Semigroup PactLog := {
  mappend := λ _ _, MkPactLog
}.

#[export]
Program Instance PactLog_Monoid : Monoid PactLog := {
  mempty := MkPactLog
}.
Next Obligation.
  destruct a.
  split; intros.
Qed.
Next Obligation.
  destruct a.
  split; intros.
Qed.

Definition PactM := @RWSP PactEnv PactState PactLog.

Record DefCap `(s : CapSig) : Type := {
  predicate : Cap s → PactM (Ensemble ACap)
}.

Derive NoConfusion NoConfusionHom Subterm for DefCap.

Arguments predicate {s} _.

Record DefMCap `(s : MCapSig) : Type := {
  base_def : DefCap (baseSig s);
  manager  : ⟦valueTy s⟧ → ⟦valueTy s⟧ → PactM ⟦valueTy s⟧
}.

Derive NoConfusion NoConfusionHom Subterm for DefMCap.

Arguments manager {s} _.

Import EqNotations.

(* The functions below all take a [DefCap] because name resolution must happen
   in the parser, since capability predicates can themselves refer to the
   current module. *)

Definition install_capability `(D : DefMCap s) (c : MCap s) : PactM () :=
  let '(MkMCap _ (MkCap _ arg) val) := c in

  (* jww (2022-07-15): This should only be possible to do in specific
     contexts, otherwise a user could install as much resource as they needed.

     jww (2022-07-15): What if the resource had already been installed? *)

  (* "Installing" a capability means assigning a resource amount associated
     with that capability, that is consumed by future calls to
     [with_capability]. *)
  modify (λ st, {| resources := insert_dep s val (resources st) |}).

Definition __claim_resource `(D : DefMCap s) (c : MCap s) : PactM () :=
  let '(MkMCap _ (MkCap _ arg) val) := c in

  (* Check the current amount of resource associated with this capability, and
     whether the requested amount is available. If so, update the available
     amount. Note: unit is used to represent unmanaged capabilities. *)
  st   <- get ;
  mng  <- demand (find_dep s (resources st)) ;
  mng' <- manager D mng val ;
  put {| resources := insert_dep s mng' (resources st) |}.

(** [with_capability] grants a capability [C] to the evaluation of [f].

    There are three results of this operation:

    1. a predicate is evaluated to determine if the operation can proceed,
       which raises an exception if not;

    2. [f] is able to evaluate more permissively;

    3. a resource is consumed in order to grant the capability.

    (2) is easily modeled by imagining that [with_capability] introduces a
    dynamic boolean variable (in the Lisp sense) for each capability [C] and
    sets it to true for the scope of evaluating [f], if the predicate in (1)
    succeeds. Later, [require_capability] tests if this boolean is true and
    raises an exception otherwise. There is no other functionality for
    unmanaged capabilities.

    A managed capability provides the same, but in addition deducts from a
    stateful resource after the predicate, but before defining and setting the
    dynamic boolean. If there is not enough resource available, it raises an
    exception. [install_capability] sets the initial amount of the
    resource. *)
Definition with_capability__unmanaged `(D : DefCap s) (c : Cap s)
           `(f : PactM a) : PactM a :=
  let acap := Unmanaged c in

  (* Check whether the capability has already been granted. If so, this
     operation is a no-op. *)
  env <- ask ;
  b   <- decide (acap ∈ granted env) ;
  if b : bool
  then f
  else
    let '(MkCap _ arg) := c in

    (* If the predicate passes, we are good to grant the capability. Note that
       the predicate may return a list of other capabilities to be "composed"
       with this one. *)
    compCaps <- predicate D c ;

    (* The process of "granting" consists merely of making the capability
       visible in the reader environment to the provided expression. *)
    local (λ r, {| granted := Add _ (compCaps ∪ granted r) acap |}) f.

Definition with_capability__managed `(D : DefMCap s) (c : MCap s)
           `(f : PactM a) : PactM a :=
  let acap := Managed c in

  (* Check whether the capability has already been granted. If so, this
     operation is a no-op. *)
  env <- ask ;
  b   <- decide (acap ∈ granted env) ;
  if b : bool
  then f
  else
    let '(MkMCap _ (MkCap _ arg) val) := c in

    (* If the predicate passes, we are good to grant the capability. Note that
       the predicate may return a list of other capabilities to be "composed"
       with this one. *)
    (* jww (2022-07-18): Can the predicate for a managed capability also see
       the value passed to [with-capability]? *)
    compCaps <- predicate (base_def s D) (base _ c) ;

    __c

    (* The process of "granting" consists merely of making the capability
       visible in the reader environment to the provided expression. *)
    local (λ r, {|  granted := Add _ (compCaps ∪ granted r) acap |}) f.

Definition require_capability (c : ACap) : PactM () :=
  (* Note that the request resource amount must match the original
     with-capability exactly.

     jww (2022-07-15): Is this intended? *)

  (* Requiring a capability means checking whether it has been granted at any
     point within the current scope of evaluation. *)
  env <- ask ;
  require (c ∈ granted env).

End Pact.


From iris.algebra Require Export cmra.
From iris.bi Require Import notation.

Record uPred (M : ucmra) : Type := UPred {
  uPred_holds :> M → Prop;
  uPred_proper : Proper ((≡) ==> iff) uPred_holds
}.
Bind Scope bi_scope with uPred.
Arguments uPred_holds {_} _%I _ : simpl never.
Add Printing Constructor uPred.
Global Instance: Params (@uPred_holds) 2 := {}.
Global Existing Instance uPred_proper.

Section ofe.
  Context {M : ucmra}.

  Inductive uPred_equiv' (P Q : uPred M) : Prop :=
    { uPred_in_equiv : ∀ x, ✓ x → P x ↔ Q x }.
  Instance uPred_equiv : Equiv (uPred M) := uPred_equiv'.

  Instance uPred_equivalence : Equivalence uPred_equiv.
  Proof.
    split.
    + by intros P; split=> x ?.
    + by intros P Q HPQ; split=> x ?; symmetry; apply HPQ.
    + intros P Q Q' HP HQ; split=> x ?.
      by trans (Q x);[apply HP|apply HQ].
  Qed.

  Canonical Structure uPredO : ofe := discreteO (uPred M).
End ofe.
Arguments uPredO : clear implicits.

(** logical entailement *)
Inductive uPred_entails {M} (P Q : uPred M) : Prop :=
  { uPred_in_entails : ∀ x, ✓ x → P x → Q x }.

(** logical connectives *)
Program Definition uPred_emp_def {M} : uPred M :=
  {| uPred_holds x := x ≡ ε |}.
Solve Obligations with solve_proper.

Definition uPred_emp_aux : seal (@uPred_emp_def). Proof. by eexists. Qed.
Definition uPred_emp := uPred_emp_aux.(unseal).
Arguments uPred_emp {M}.
Definition uPred_emp_eq :
  @uPred_emp = @uPred_emp_def := uPred_emp_aux.(seal_eq).

Definition uPred_pure_def {M} (φ : Prop) : uPred M :=
  {| uPred_holds x := φ |}.
Definition uPred_pure_aux : seal (@uPred_pure_def). Proof. by eexists. Qed.
Definition uPred_pure := uPred_pure_aux.(unseal).
Arguments uPred_pure {M}.
Definition uPred_pure_eq :
  @uPred_pure = @uPred_pure_def := uPred_pure_aux.(seal_eq).

Program Definition uPred_and_def {M} (P Q : uPred M) : uPred M :=
  {| uPred_holds x := P x ∧ Q x |}.
Solve Obligations with solve_proper.
Definition uPred_and_aux : seal (@uPred_and_def). Proof. by eexists. Qed.
Definition uPred_and := uPred_and_aux.(unseal).
Arguments uPred_and {M}.
Definition uPred_and_eq: @uPred_and = @uPred_and_def := uPred_and_aux.(seal_eq).

Program Definition uPred_or_def {M} (P Q : uPred M) : uPred M :=
  {| uPred_holds x := P x ∨ Q x |}.
Solve Obligations with solve_proper.
Definition uPred_or_aux : seal (@uPred_or_def). Proof. by eexists. Qed.
Definition uPred_or := uPred_or_aux.(unseal).
Arguments uPred_or {M}.
Definition uPred_or_eq: @uPred_or = @uPred_or_def := uPred_or_aux.(seal_eq).

Program Definition uPred_impl_def {M} (P Q : uPred M) : uPred M :=
  {| uPred_holds x := P x → Q x |}.
Next Obligation.
  intros M P Q x1 x2 Hx. by rewrite Hx.
Qed.
Definition uPred_impl_aux : seal (@uPred_impl_def). Proof. by eexists. Qed.
Definition uPred_impl := uPred_impl_aux.(unseal).
Arguments uPred_impl {M}.
Definition uPred_impl_eq :
  @uPred_impl = @uPred_impl_def := uPred_impl_aux.(seal_eq).

Program Definition uPred_forall_def {M A} (Ψ : A → uPred M) : uPred M :=
  {| uPred_holds x := ∀ a, Ψ a x |}.
Next Obligation.
  intros M P Q x1 x2 Hx. by setoid_rewrite Hx.
Qed.
Definition uPred_forall_aux : seal (@uPred_forall_def). Proof. by eexists. Qed.
Definition uPred_forall := uPred_forall_aux.(unseal).
Arguments uPred_forall {M A}.
Definition uPred_forall_eq :
  @uPred_forall = @uPred_forall_def := uPred_forall_aux.(seal_eq).

Program Definition uPred_exist_def {M A} (Ψ : A → uPred M) : uPred M :=
  {| uPred_holds x := ∃ a, Ψ a x |}.
Next Obligation.
  intros M P Q x1 x2 Hx. by setoid_rewrite Hx.
Qed.
Definition uPred_exist_aux : seal (@uPred_exist_def). Proof. by eexists. Qed.
Definition uPred_exist := uPred_exist_aux.(unseal).
Arguments uPred_exist {M A}.
Definition uPred_exist_eq: @uPred_exist = @uPred_exist_def := uPred_exist_aux.(seal_eq).

Program Definition uPred_sep_def {M} (P Q : uPred M) : uPred M :=
  {| uPred_holds x := ∃ x1 x2, x ≡ x1 ⋅ x2 ∧ P x1 ∧ Q x2 |}.
Solve Obligations with solve_proper.
Definition uPred_sep_aux : seal (@uPred_sep_def). Proof. by eexists. Qed.
Definition uPred_sep := uPred_sep_aux.(unseal).
Arguments uPred_sep {M}.
Definition uPred_sep_eq: @uPred_sep = @uPred_sep_def := uPred_sep_aux.(seal_eq).

Program Definition uPred_wand_def {M} (P Q : uPred M) : uPred M :=
  {| uPred_holds x := ∀ x',
       ✓ (x ⋅ x') → P x' → Q (x ⋅ x') |}.
Next Obligation.
  intros M P Q x1 x2 Hx. by setoid_rewrite Hx.
Qed.
Definition uPred_wand_aux : seal (@uPred_wand_def). Proof. by eexists. Qed.
Definition uPred_wand := uPred_wand_aux.(unseal).
Arguments uPred_wand {M}.
Definition uPred_wand_eq :
  @uPred_wand = @uPred_wand_def := uPred_wand_aux.(seal_eq).

(* Core is strange in a linear setting,
    so we have substituted core x ↦ ε in the following definition.
    This is essentially plainly. *)
Definition uPred_persistently_def {M} (P : uPred M) : uPred M :=
  {| uPred_holds x := P ε |}.
Definition uPred_persistently_aux : seal (@uPred_persistently_def). Proof. by eexists. Qed.
Definition uPred_persistently := uPred_persistently_aux.(unseal).
Arguments uPred_persistently {M}.
Definition uPred_persistently_eq :
  @uPred_persistently = @uPred_persistently_def := uPred_persistently_aux.(seal_eq).

Program Definition uPred_ownM_def {M : ucmra} (a : M) : uPred M :=
  {| uPred_holds x := a ≡ x |}.
Solve Obligations with solve_proper.
Definition uPred_ownM_aux : seal (@uPred_ownM_def). Proof. by eexists. Qed.
Definition uPred_ownM := uPred_ownM_aux.(unseal).
Arguments uPred_ownM {M}.
Definition uPred_ownM_eq :
  @uPred_ownM = @uPred_ownM_def := uPred_ownM_aux.(seal_eq).

(** Primitive logical rules.
    These are not directly usable later because they do not refer to the BI
    connectives. *)
Module uPred_primitive.
Definition unseal_eqs :=
  (uPred_emp_eq, uPred_pure_eq, uPred_and_eq, uPred_or_eq, uPred_impl_eq, uPred_forall_eq,
  uPred_exist_eq, uPred_sep_eq, uPred_wand_eq,
  uPred_persistently_eq, uPred_ownM_eq).
Ltac unseal :=
  rewrite !unseal_eqs /=.

Section primitive.
Context {M : ucmra}.
Implicit Types φ : Prop.
Implicit Types P Q : uPred M.
Implicit Types A : Type.
Arguments uPred_holds {_} !_ _ /.
Local Hint Immediate uPred_in_entails : core.

Notation "P ⊢ Q" := (@uPred_entails M P%I Q%I) : stdpp_scope.
Notation "(⊢)" := (@uPred_entails M) (only parsing) : stdpp_scope.
Notation "P ⊣⊢ Q" := (@uPred_equiv M P%I Q%I) : stdpp_scope.
Notation "(⊣⊢)" := (@uPred_equiv M) (only parsing) : stdpp_scope.

Notation "'emp'" := uPred_emp : bi_scope.
Notation "'True'" := (uPred_pure True) : bi_scope.
Notation "'False'" := (uPred_pure False) : bi_scope.
Notation "'⌜' φ '⌝'" := (uPred_pure φ%type%stdpp) : bi_scope.
Infix "∧" := uPred_and : bi_scope.
Infix "∨" := uPred_or : bi_scope.
Infix "→" := uPred_impl : bi_scope.
Notation "∀ x .. y , P" :=
  (uPred_forall (λ x, .. (uPred_forall (λ y, P)) ..)) : bi_scope.
Notation "∃ x .. y , P" :=
  (uPred_exist (λ x, .. (uPred_exist (λ y, P)) ..)) : bi_scope.
Infix "∗" := uPred_sep : bi_scope.
Infix "-∗" := uPred_wand : bi_scope.
Notation "<pers> P" := (uPred_persistently P) : bi_scope.

(** Entailment *)
Lemma entails_po : PreOrder (⊢).
Proof.
  split.
  - by intros P; split=> x ?.
  - intros P Q Q' HP HQ. split=> x ? ?. by apply HQ, HP.
Qed.
Lemma entails_anti_sym : AntiSymm (⊣⊢) (⊢).
Proof. intros P Q HPQ HQP; split=> x n; by split; [apply HPQ|apply HQP]. Qed.
Lemma equiv_spec P Q : (P ⊣⊢ Q) ↔ (P ⊢ Q) ∧ (Q ⊢ P).
Proof.
  split.
  - intros HPQ; split; split=> x i; apply HPQ; done.
  - intros [??]. exact: entails_anti_sym.
Qed.
Lemma equiv_entails P Q : (P ⊣⊢ Q) ↔ (P ⊢ Q) ∧ (Q ⊢ P).
Proof.
  split.
  - intros HPQ; split; split=> x i; by apply HPQ.
  - intros [??]. exact: entails_anti_sym.
Qed.

(** Non-expansiveness and setoid morphisms *)
Lemma pure_ne n : Proper (iff ==> dist n) (@uPred_pure M).
Proof. intros φ1 φ2 Hφ. unseal. split. intros ??. simpl. done. Qed.

Lemma and_ne : NonExpansive2 (@uPred_and M).
Proof.
  intros n P P' HP Q Q' HQ; unseal; split=> x ?.
  split; (intros [??]; split; [by apply HP|by apply HQ]).
Qed.

Lemma or_ne : NonExpansive2 (@uPred_or M).
Proof.
  intros n P P' HP Q Q' HQ; split=> x ?.
  unseal; split; (intros [?|?]; [left; by apply HP|right; by apply HQ]).
Qed.

Lemma impl_ne :
  NonExpansive2 (@uPred_impl M).
Proof.
  intros n P P' HP Q Q' HQ; split=> x ?.
  unseal; split; intros HPQ ?; apply HQ, HPQ, HP; eauto using cmra_validN_le.
Qed.

Lemma sep_ne : NonExpansive2 (@uPred_sep M).
Proof.
  intros n P P' HP Q Q' HQ; split=> x ?.
  unseal; split; intros (x1&x2&?&?&?); ofe_subst x;
    exists x1, x2; split_and!; try (apply HP || apply HQ); setoid_subst;
    eauto using cmra_valid_op_l, cmra_valid_op_r.
Qed.

Lemma wand_ne :
  NonExpansive2 (@uPred_wand M).
Proof.
  intros n P P' HP Q Q' HQ; split=> x ?; unseal; split; intros HPQ x' ??;
    apply HQ, HPQ, HP; eauto using cmra_valid_op_r.
Qed.

Lemma forall_ne A n :
  Proper (pointwise_relation _ (dist n) ==> dist n) (@uPred_forall M A).
Proof.
  by intros Ψ1 Ψ2 HΨ; unseal; split=> n' x; split; intros HP a; apply HΨ.
Qed.

Lemma exist_ne A n :
  Proper (pointwise_relation _ (dist n) ==> dist n) (@uPred_exist M A).
Proof.
  intros Ψ1 Ψ2 HΨ.
  unseal; split=> x ?; split; intros [a ?]; exists a; by apply HΨ.
Qed.

Lemma persistently_ne : NonExpansive (@uPred_persistently M).
Proof.
  intros P1 P2 Hp H.
  unseal. split=> x?. simpl. split; apply H; eauto using ucmra_unit_valid.
Qed.

Lemma pure_proper : Proper (iff ==> (≡)) (@uPred_pure M).
Proof. unseal. done. Qed.

Lemma and_proper : Proper ((≡) ==> (≡) ==> (≡)) (@uPred_and M).
Proof.
  unseal. intros ?? [] ?? []. split. naive_solver.
Qed.

Lemma or_proper : Proper ((≡) ==> (≡) ==> (≡)) (@uPred_or M).
Proof.
  unseal. intros ?? [] ?? []. split. naive_solver.
Qed.

Lemma impl_proper : Proper ((≡) ==> (≡) ==> (≡)) (@uPred_impl M).
Proof.
  unseal. intros ?? [] ?? []. split. naive_solver.
Qed.

Lemma sep_proper : Proper ((≡) ==> (≡) ==> (≡)) (@uPred_sep M).
Proof.
  unseal. intros ?? [] ?? []. split. simpl.
  intros ??. split; intros (? & ? & ? & ? & ?).
  - setoid_subst. naive_solver (eauto using cmra_valid_op_l, cmra_valid_op_r).
  - setoid_subst. naive_solver (eauto using cmra_valid_op_l, cmra_valid_op_r).
Qed.

Lemma wand_proper : Proper ((≡) ==> (≡) ==> (≡)) (@uPred_wand M).
Proof.
  unseal. intros ?? [] ?? []. split. naive_solver (eauto using cmra_valid_op_l, cmra_valid_op_r).
Qed.

Lemma forall_proper A :
  Proper (pointwise_relation _ (≡) ==> (≡)) (@uPred_forall M A).
Proof.
  by intros Ψ1 Ψ2 HΨ; unseal; split=> n' x; split; intros HP a; apply HΨ.
Qed.

Lemma exist_proper A :
  Proper (pointwise_relation _ (≡) ==> (≡)) (@uPred_exist M A).
Proof.
  intros Ψ1 Ψ2 HΨ.
  unseal; split=> x ?; split; intros [a ?]; exists a; by apply HΨ.
Qed.

Lemma persistently_proper : Proper ((≡) ==> (≡)) (@uPred_persistently M).
Proof.
  intros ???. unseal. split. intros ??. simpl. destruct H as [H].
  eauto using ucmra_unit_valid.
Qed.

Lemma ownM_proper : Proper ((≡) ==> (≡)) (@uPred_ownM M).
Proof.
  intros ???. unseal. split=> ??. setoid_subst. done.
Qed.

(** Introduction and elimination rules *)
Lemma pure_intro φ P : φ → P ⊢ ⌜φ⌝.
Proof. by intros ?; unseal; split. Qed.
Lemma pure_elim' φ P : (φ → True ⊢ P) → ⌜φ⌝ ⊢ P.
Proof. unseal; intros HP; split=> x ??. by apply HP. Qed.
Lemma pure_forall_2 {A} (φ : A → Prop) : (∀ x : A, ⌜φ x⌝) ⊢ ⌜∀ x : A, φ x⌝.
Proof. by unseal. Qed.

Lemma and_elim_l P Q : P ∧ Q ⊢ P.
Proof. by unseal; split=> x ? [??]. Qed.
Lemma and_elim_r P Q : P ∧ Q ⊢ Q.
Proof. by unseal; split=> x ? [??]. Qed.
Lemma and_intro P Q R : (P ⊢ Q) → (P ⊢ R) → P ⊢ Q ∧ R.
Proof. intros HQ HR; unseal; split=> x ??; by split; [apply HQ|apply HR]. Qed.

Lemma or_intro_l P Q : P ⊢ P ∨ Q.
Proof. unseal; split=> x ??; left; auto. Qed.
Lemma or_intro_r P Q : Q ⊢ P ∨ Q.
Proof. unseal; split=> x ??; right; auto. Qed.
Lemma or_elim P Q R : (P ⊢ R) → (Q ⊢ R) → P ∨ Q ⊢ R.
Proof.
  intros HP HQ; unseal; split=> x ? [?|?].
  - by apply HP.
  - by apply HQ.
Qed.

Lemma impl_intro_r P Q R : (P ∧ Q ⊢ R) → P ⊢ Q → R.
Proof.
  unseal; intros HQ; split=> ????.
  apply HQ; naive_solver eauto using uPred_mono, cmra_included_includedN, cmra_validN_le.
Qed.
Lemma impl_elim_l' P Q R : (P ⊢ Q → R) → P ∧ Q ⊢ R.
Proof.
  unseal; intros HP ; split=> x ? [??].
  apply HP; auto.
Qed.

Lemma forall_intro {A} P (Ψ : A → uPred M): (∀ a, P ⊢ Ψ a) → P ⊢ ∀ a, Ψ a.
Proof. unseal; intros HPΨ; split=> x ?? a; by apply HPΨ. Qed.
Lemma forall_elim {A} {Ψ : A → uPred M} a : (∀ a, Ψ a) ⊢ Ψ a.
Proof. unseal; split=> x ? HP; apply HP. Qed.

Lemma exist_intro {A} {Ψ : A → uPred M} a : Ψ a ⊢ ∃ a, Ψ a.
Proof. unseal; split=> x ??; by exists a. Qed.
Lemma exist_elim {A} (Φ : A → uPred M) Q : (∀ a, Φ a ⊢ Q) → (∃ a, Φ a) ⊢ Q.
Proof. unseal; intros HΦΨ; split=> x ? [a ?]; by apply HΦΨ with a. Qed.

(** BI connectives *)
Lemma sep_mono P P' Q Q' : (P ⊢ Q) → (P' ⊢ Q') → P ∗ P' ⊢ Q ∗ Q'.
Proof.
  intros HQ HQ'; unseal.
  split; intros x ? (x1&x2&?&?&?); exists x1,x2; setoid_subst; split;
    eauto 7 using cmra_valid_op_l, cmra_valid_op_r, uPred_in_entails.
Qed.
Lemma emp_sep_1 P : P ⊢ emp ∗ P.
Proof.
  unseal; split; intros x ??. exists ε, x. rewrite left_id; simpl; eauto.
Qed.
Lemma emp_sep_2 P : emp ∗ P ⊢ P.
Proof.
  unseal; split; intros x ? (x1&x2&?&?&?); setoid_subst.
  by rewrite left_id.
Qed.
Lemma sep_comm' P Q : P ∗ Q ⊢ Q ∗ P.
Proof.
  unseal; split; intros x ? (x1&x2&?&?&?); exists x2, x1; by rewrite (comm op).
Qed.
Lemma sep_assoc' P Q R : (P ∗ Q) ∗ R ⊢ P ∗ (Q ∗ R).
Proof.
  unseal; split; intros x ? (x1&x2&Hx&(y1&y2&Hy&?&?)&?).
  exists y1, (y2 ⋅ x2); split_and?; auto.
  + by rewrite (assoc op) -Hy -Hx.
  + by exists y2, x2.
Qed.
Lemma wand_intro_r P Q R : (P ∗ Q ⊢ R) → P ⊢ Q -∗ R.
Proof.
  unseal=> HPQR; split=> x ?? x' ??; apply HPQR; auto.
  exists x, x'; split_and?; auto.
Qed.
Lemma wand_elim_l' P Q R : (P ⊢ Q -∗ R) → P ∗ Q ⊢ R.
Proof.
  unseal =>HPQR. split; intros x ? (?&?&?&?&?). setoid_subst.
  eapply HPQR; eauto using cmra_valid_op_l.
Qed.

(** Persistently *)
Lemma persistently_mono P Q : (P ⊢ Q) → <pers> P ⊢ <pers> Q.
Proof. intros HP; unseal; split=> x ? /=. apply HP, ucmra_unit_valid. Qed.

Lemma persistently_idemp_2 P : <pers> P ⊢ <pers> <pers> P.
Proof. unseal; split=> x ?? //. Qed.

Lemma persistently_emp_2 : emp ⊢ <pers> emp.
Proof. unseal; by split => n x ? /=. Qed.

Lemma persistently_and_2 (P Q : uPred M) : (<pers> P ∧ <pers> Q) ⊢ (<pers> (P ∧ Q)).
Proof. by unseal. Qed.

Lemma persistently_forall_2 {A} (Ψ : A → uPred M) : (∀ a, <pers> Ψ a) ⊢ (<pers> ∀ a, Ψ a).
Proof. by unseal. Qed.
Lemma persistently_exist_1 {A} (Ψ : A → uPred M) : (<pers> ∃ a, Ψ a) ⊢ (∃ a, <pers> Ψ a).
Proof. by unseal. Qed.

Lemma persistently_absorbing P Q : <pers> P ∗ Q ⊢ <pers> P.
Proof. unseal; split=> n x ? /=. naive_solver. Qed.

Lemma persistently_and_sep_elim P Q : <pers> P ∧ Q ⊢ P ∗ Q.
Proof.
  unseal; split=> x ? [??]; exists ε, x; simpl in *. by rewrite left_id.
Qed.

Lemma persistently_impl_persistently P Q : (<pers> P → <pers> Q) ⊢ <pers> (<pers> P → Q).
Proof.
  unseal; split=> /= x ? HPQ x'. naive_solver.
Qed.

(** Own *)
Lemma ownM_op (a1 a2 : M) :
  uPred_ownM (a1 ⋅ a2) ⊣⊢ uPred_ownM a1 ∗ uPred_ownM a2.
Proof.
  unseal; split=> x ?; split.
  - intros H. exists a1, a2. simpl in H.
    split. { by rewrite H. }
    split; by simpl.
  - simpl. by intros (x1&x2 & -> & -> & ->).
Qed.

Lemma ownM_unit : uPred_ownM ε ⊣⊢ emp.
Proof. unseal. split; naive_solver. Qed.

Lemma ownM_valid x : uPred_ownM x ⊢ ⌜ ✓ x ⌝.
Proof.
  unseal. split. simpl. intros. setoid_subst. done.
Qed.

(** Consistency/soundness statement *)
(** The lemmas [pure_soundness] and [internal_eq_soundness] should become an
instance of [siProp] soundness in the future. *)
Lemma pure_soundness φ : (emp ⊢ ⌜ φ ⌝) → φ.
Proof. unseal=> -[H]. by apply (H ε); simpl; eauto using ucmra_unit_valid. Qed.

End primitive.
End uPred_primitive.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import NatTrans.Main.
From Categories Require Import Adjunction.Adjunction Adjunction.Duality.
From Categories Require Import Ext_Cons.Comma.
From Categories Require Import Basic_Cons.Terminal Basic_Cons.Facts.Term_IsoCat.
From Categories Require Import Cat.Cat_Iso.
From Categories Require Import Archetypal.Discr.Discr Archetypal.Discr.NatFacts.

(** A functor G : D –≻ C has a left adjoint if and only if
the comma category (Comma (Func_From_SingletonCat x) G) has
an initial object for any (x : C).

Dually, a functor F : C –≻ D has a right adjoint if and only
if the comma category (Comma F (Func_From_SingletonCat x))
has a terminal object for any (x : D).
 *)

(**
If the comma category (Comma (Func_From_SingletonCat x) G) has
an initial object for any (x : C). Then G : D –≻ C has
a left adjoint.
*)

Section Universal_Morphism_Right_Adjonit.
  Context
    {C D : Category}
    (G : (D --> C)%functor)
    (HU_init : ∀ (x : C), (𝟘_ (Comma (Const_Func 1 x) G))%object ).

  Local Definition Universal_Morphism_Lem :
    ∀ c a h, CMH_right (t_morph (HU_init c) a) = CMH_right h.
  Proof.
    intros c a h.
    apply f_equal.
    apply (t_morph_unique (HU_init c)).
  Qed.

  Local Ltac smart_apply_Universal_Morphism_Lem :=
    match goal with
      [|- CMH_right ?A = ?B] =>
      match type of A with
        ?W =>
        let M :=
            (eval cbn in W)
        in
        match M with
          Comma_Hom _ _ ?X ?Y =>
          evar (U : Comma_Hom _ _ X Y);
            replace B with (CMH_right ?U);
            [
              eapply
                (
                  Universal_Morphism_Lem
                    _
                    Y
                    (
                      Build_Comma_Hom
                        _
                        _
                        X
                        Y
                        tt
                        B
                        _
                    )
                )
            |
            reflexivity
            ]
        end
      end
    end.

  Program Definition Universal_Morphism_Right_Adjonit_Func : (C --> D)%functor
    :=
      {|
        FO :=
          fun c =>
            CMO_trg (terminal (HU_init c));
        FA :=
          fun c c' h =>
            CMH_right
              (t_morph
                 (HU_init c)
                 (@Build_Comma_Obj
                    _
                    _
                    _
                    (Const_Func 1 c)
                    G
                    tt
                    (CMO_trg (terminal (HU_init c')))
                    ((CMO_hom (terminal (HU_init c'))) ∘ h)%morphism
                 )
              )
      |}.

  Next Obligation.
  Proof.
    smart_apply_Universal_Morphism_Lem.
    Unshelve.
    cbn; auto.
  Qed.

  Next Obligation.
  Proof.
    smart_apply_Universal_Morphism_Lem.
    Unshelve.
    {
      cbn.
      rewrite F_compose.
      rewrite assoc.
      simpl_ids;
      match goal with
      [|- ((G _a) ((CMH_right ?A)) ∘ ((G _a) (CMH_right ?B)) ∘ _)%morphism = _] =>
        cbn_rewrite (CMH_com B);
          do 2 rewrite assoc_sym;
          cbn_rewrite (CMH_com A); auto
      end.
    }
  Qed.

  Local Obligation Tactic := idtac.

  Program Definition Universal_Morphism_Right_Adjonit_unit :
    (Functor_id C --> G ∘ Universal_Morphism_Right_Adjonit_Func)%nattrans
    :=
      {|
        Trans := fun c => CMO_hom (terminal (HU_init c))
      |}
  .

  Next Obligation.
  Proof.
    intros c c' h.
    cbn.
    match goal with
      [|- _ = (G _a (CMH_right ?A) ∘ _)%morphism] =>
      cbn_rewrite (CMH_com A)
    end.
    auto.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Universal_Morphism_Right_Adjonit_unit_obligation_1.
  Qed.

  Program Definition Universal_Morphism_Right_Adjonit :
    (Universal_Morphism_Right_Adjonit_Func ⊣ G)%functor
    :=
      {|
        adj_unit := Universal_Morphism_Right_Adjonit_unit;
        adj_morph_ex :=
          fun c d f =>
            CMH_right
              (t_morph
                 (HU_init c)
                 (@Build_Comma_Obj
                    _
                    _
                    _
                    (Const_Func 1 c)
                    G
                    tt
                    d
                    f
                 )
              )
      |}
  .

  Next Obligation.
  Proof.
    intros c d f.
    cbn in *.
    match goal with
      [|- _ = (G _a (CMH_right ?A) ∘ _)%morphism] =>
      cbn_rewrite (CMH_com A)
    end.
    auto.
  Qed.

  Next Obligation.
  Proof.
    intros c d f g h H1 H2.
    cbn in *.
    rewrite <- (id_unit_right _ _ f) in H1, H2.
    symmetry in H1, H2.
    set (W :=
           @Build_Comma_Obj
             _
             _
             _
             (Const_Func 1 c)
             G
             tt
             d
             f
        )
    .
    let tac u H
        :=
        (
          change u with
          (
            CMH_right
              (
                Build_Comma_Hom
                  _
                  _
                  (terminal (HU_init c))
                  W
                  tt
                  u
                  H
              )
          )
        )
    in
    tac g H1;
      tac h H2
    .
    transitivity (CMH_right (t_morph (HU_init c) W));
      [symmetry|];
      apply (Universal_Morphism_Lem c W)
    .
  Qed.

End Universal_Morphism_Right_Adjonit.

(**
if a functor G : D –≻ C has a left adjoint then the comma
category (Comma (Func_From_SingletonCat x) G) has
an initial object for any (x : C).
*)
Section Right_Adjoint_Universal_Morphism.
  Context
    {C D : Category}
    {F : (C --> D)%functor}
    {G : (D --> C)%functor}
    (Adj : (F ⊣ G)%functor)
    (x : C).

  Program Definition Right_Adjoint_Universal_Morphism_terminal :
    (Comma (Const_Func 1 x) G)
    :=
      {|
        CMO_src := tt;
        CMO_trg := (F _o x)%object;
        CMO_hom := Trans (adj_unit Adj) x
      |}.

  Program Definition Right_Adjoint_Universal_Morphism_t_morph
          (u : (Comma (Const_Func 1 x) G))
    :
      Comma_Hom _ _ Right_Adjoint_Universal_Morphism_terminal u
    :=
      {|
        CMH_left := tt;
        CMH_right :=
          @adj_morph_ex
            _
            _
            _
            _
            Adj
            x
            (CMO_trg u)
            (CMO_hom u)
      |}.

  Next Obligation.
  Proof.
    simpl_ids.
    symmetry.
    apply (@adj_morph_com _ _ _ _ Adj).
  Qed.

  Program Definition Right_Adjoint_Universal_Morphism :
    (𝟘_ (Comma (Const_Func 1 x) G))%object
    :=
      {|
        terminal := Right_Adjoint_Universal_Morphism_terminal;
        t_morph := Right_Adjoint_Universal_Morphism_t_morph
      |}.

  Next Obligation.
  Proof.
    assert (Hf := CMH_com f).
    assert (Hg := CMH_com g).
    cbn in *.
    simpl_ids in Hf; simpl_ids in Hg.
    symmetry in Hf, Hg.
    apply Comma_Hom_eq_simplify.
    match goal with
      [|- ?A = ?B] =>
      destruct A; destruct B; trivial
    end.
    eapply (@adj_morph_unique _ _ _ _ Adj); eauto.
  Qed.

End Right_Adjoint_Universal_Morphism.

(**
If the comma category (Comma F (Func_From_SingletonCat x)) has
an initial object for any (x : D). Then F : D –≻ C has
a right adjoint.
*)
Section Universal_Morphism_Left_Adjonit.
  Context
    {C D : Category}
    (F : (C --> D)%functor)
    (HU_term : ∀ (x : D), (𝟙_ (Comma F (Const_Func 1 x)))%object).

  Definition Universal_Morphism_Left_Adjonit_HU_init
             (x : (D^op)%category)
    :
      (𝟘_ (Comma ((@Const_Func 1 (D ^op) x)) (F^op)))%object
    :=
      Term_IsoCat
        (
          Opposite_Cat_Iso
            (
              Isomorphism_Compose
                (Comma_Opposite_Iso F (@Const_Func 1 D x))
                (Comma_Left_Func_Iso
                   (@Func_From_SingletonCat_Opposite D x) (F ^op))
            )
        )
        (HU_term x).

  Definition Universal_Morphism_Left_Adjonit
    :
      (F ⊣ (
               Universal_Morphism_Right_Adjonit_Func
                 (F ^op)
                 Universal_Morphism_Left_Adjonit_HU_init
             )^op
      )%functor
    :=
      Adjunct_Duality
        (
          @Universal_Morphism_Right_Adjonit
            (D^op)
            (C^op)
            (F^op)
            Universal_Morphism_Left_Adjonit_HU_init
        )
  .

End Universal_Morphism_Left_Adjonit.

(**
if a functor F : C –≻ D has a right adjoint then the comma
category (Comma F (Func_From_SingletonCat x)) has
an terminal object for any (x : D).
*)
Section Left_Adjoint_Universal_Morphism.
  Context
    {C D : Category}
    {F : (C --> D)%functor}
    {G : (D --> C)%functor}
    (Adj : (F ⊣ G)%functor)
    (x : D).

  Definition Left_Adjoint_Universal_Morphism
    : (𝟙_ (Comma F (Const_Func 1 x)))%object
    :=
      Term_IsoCat
        (
          Opposite_Cat_Iso
            (
              Isomorphism_Compose
                (
                  Comma_Left_Func_Iso
                    (Inverse_Isomorphism (@Func_From_SingletonCat_Opposite D x))
                    (F ^op)
                )
                (Inverse_Isomorphism
                   (Comma_Opposite_Iso F (@Const_Func 1 D x)))
            )
        )
        (Right_Adjoint_Universal_Morphism (Adjunct_Duality Adj) x)
  .

End Left_Adjoint_Universal_Morphism.


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

Set Implicit Arguments.
Unset Strict Implicit.

Require Import Arith.
Require Export universe.

Ltac cw := autorewrite with cw; try tv; try am.

Module Category.
Export Universe.

Module Notations.

Definition Objects  := R (o_(b_(j_ DOT ))).
Definition Composition := R (c_(m_(p_ DOT ))).
Definition Identity := R (i_(d_ (t_ DOT ))).
Definition Structure := R (s_ (t_ (r_ DOT))).
(*** the latter is a placeholder for any additional
structure we might want to put on ****)

Definition objects a := V Objects a.
Definition morphisms a := V Underlying a.
Definition composition a := V Composition a.
Definition identity a  := V Identity a.
Definition structure a := V Structure a.

Definition create (o m:E) (c : E2) (i:E1) (s:E):=
denote Objects o (
denote Underlying m (
denote Composition
(L m (fun u => L (Z m (fun v => source u = target v)) (c u))) (
denote Identity (L o i) (
denote Structure s (
stop))))).

Lemma objects_create :forall o m c i s, objects (create o m c i s) = o.
ir; uf objects; uf create. drw.
Qed.

Lemma morphisms_create : forall o m c i s, morphisms
(create o m c i s) = m.
ir; uf morphisms; uf create. drw.
Qed.

Lemma structure_create : forall o m c i s,
structure (create o m c i s) = s.
Proof.
ir; uf structure; uf create. drw.
Qed.

Lemma composition_create : forall o m c i s,
composition (create o m c i s) =
L m (fun u => (L (Z m (fun v => source u = target v)) (c u))).
Proof.
ir. uf create. uf composition. drw.
Qed.

Lemma identity_create : forall o m c i s,
identity (create o m c i s)  = L o i.
Proof.
ir. uf create. uf identity. drw.
Qed.

Hint Rewrite objects_create morphisms_create composition_create
identity_create : cw.

Definition comp a u v := V v (V u (composition a)).
Definition id a x := V x (identity a).

Definition like a := a = create (objects a)
(morphisms a) (comp a) (id a) (structure a).

Lemma create_extensionality : forall o m c i  s o1 m1 c1 i1 s1,
o = o1 -> m = m1 ->
(forall u v, inc u m -> inc v m -> source u = target v
-> c u v = c1 u v) ->
(forall x, inc x o -> i x = i1 x) ->
s = s1 ->
create o m c i s = create o1 m1 c1 i1 s1.
Proof.
ir. wr H. wr H0.
assert (lem1:
L m (fun u => L (Z m (fun v => source u = target v)) (c u)) =
L m (fun u => L (Z m (fun v => source u = target v)) (c1 u))).
ap Function.create_extensionality. tv.
ir. ap Function.create_extensionality. tv.
ir. ap H1. am. Ztac. Ztac.

assert (lem2: L o i = L o i1).
ap Function.create_extensionality. tv.
au.
uf create. rw lem1. rw lem2. rw H3. reflexivity.
Qed.

Lemma create_like : forall o m c i s,
like (create o m c i s).
Proof.
ir. uf like. ap create_extensionality.
rw objects_create; tv. rw morphisms_create; tv.
ir.
uf comp.
rw composition_create.
rw create_V_rewrite. rw create_V_rewrite.
tv. Ztac. am. ir.
uf id. rw identity_create.
rw create_V_rewrite. tv. am.
rw structure_create. tv. Qed.

Definition is_ob a x := inc x (objects a).
Definition is_mor a u := inc u (morphisms a).

End Notations.
Export Notations.

Lemma is_ob_create : forall o m c i  s x,
is_ob (create o m c i s) x = (inc x o).
Proof.
ir.
uf is_ob. cw.
Qed.

Lemma is_mor_create : forall o m c i s u,
is_mor (create o m c i s) u = (inc u m).
Proof.
ir. uf is_mor. cw.
Qed.

Lemma comp_create : forall o m c i s u v,
inc u m -> inc v m -> source u = target v ->
comp (create o m c i s) u v = c u v.
Proof.
ir. uf comp. cw. aw.
Ztac.
Qed.

Lemma id_create : forall o m c i s x,
inc x o ->
id (create o m c i s) x = i x.
Proof.
ir. uf id. cw. aw.
Qed.

(**** axioms ****)

Definition are_composable a f g :=
is_mor a f &
is_mor a g &
source f = target g.

Definition is_ob_facts a x :=
is_ob a x &
is_mor a (id a x) &
source (id a x) = x &
target (id a x) = x &
(forall f, is_mor a f-> source f = x -> comp a f (id a x) = f) &
(forall f, is_mor a f-> target f = x -> comp a (id a x) f = f).

Definition is_mor_facts a f:=
is_mor a f &
is_ob a (source f) &
is_ob a (target f) &
comp a (id a (target f)) f = f &
comp a f (id a (source f)) = f &
Arrow.like f.

Definition are_composable_facts a f g:=
are_composable a f g &
is_mor a (comp a f g) &
source (comp a f g) = source g &
target (comp a f g) = target f.

Definition axioms a :=
(forall x, is_ob a x = is_ob_facts a x) &
(forall u, is_mor a u = is_mor_facts a u) &
(forall u v, are_composable a u v = are_composable_facts a u v) &
(forall u v w, are_composable a u v -> are_composable a v w ->
   (comp a (comp a u v) w) = (comp a u (comp a v w))) &
like a.

Definition composable a u v :=
axioms a & are_composable a u v.

Definition mor a u := axioms a & is_mor a u.

Definition ob a x := axioms a & is_ob a x.

Definition mor_facts c u :=
mor c u &
ob c (source u) &
ob c (target u) &
comp c (id c (target u)) u = u &
comp c u (id c (source u)) = u &
Arrow.like u.

Lemma mor_facts_rw : forall c u,
mor c u = mor_facts c u.
Proof.
ir. ap iff_eq; ir.
cp H; uh H; ee. cp H; uh H; ee.
rwi H3 H1. uh H1; ee.
uhg; xd. uhg; xd. uhg; xd. uh H; ee; am.
Qed.

Definition ob_facts c x :=
ob c x &
mor c (id c x) &
composable c (id c x) (id c x) &
source (id c x) = x &
target (id c x) = x &
comp c (id c x) (id c x) = (id c x)&
(forall u, mor c u -> source u = x -> comp c u (id c x) = u)&
(forall u, mor c u -> target u = x -> comp c (id c x) u = u).

Lemma ob_facts_rw : forall c x,
ob c x = ob_facts c x.
Proof.
ir. ap iff_eq; ir. cp H; uh H; ee.
cp H; uh H; ee. clear H6. cp H1; uh H1; ee.
rwi H H6. uh H6; ee.
uhg; xd. uhg; xd.
uhg; xd. uhg; xd.
rw H8; rw H9; tv.
ir. ap H10. lu. am.
ir. ap H11; lu. lu.
Qed.

Definition composable_facts c u v :=
axioms c &
are_composable c u v &
mor c u &
mor c v &
mor c (comp c u v)&
source u = target v &
source (comp c u v) = source v &
target (comp c u v) = target u.

Lemma composable_facts_rw : forall c u v,
composable c u v = composable_facts c u v.
Proof.
ir; ap iff_eq; ir. cp H; uh H; ee.
cp H; uh H; ee. clear H6.
uhg; dj; try am.
uhg; ee. am. lu. uhg; ee; lu.
rwi H4 H1. uh H1; ee. uhg; ee; try am.
uh H7; ee; am.
rwi H4 H7. uh H7. ee. am.
rwi H4 H7. uh H7. ee. am.
uhg; uh H; xd.
Qed.

Lemma show_composable : forall c u v,
mor c u -> mor c v -> source u = target v ->
composable c u v.
Proof.
ir. cp H; uh H; ee. cp H; uh H; ee.
uhg; ee. am. uh H0; ee. uhg; ee; try am.
Qed.

Lemma show_composable_facts : forall c u v,
mor c u -> mor c v -> source u = target v ->
composable_facts c u v.
Proof.
ir. wr composable_facts_rw; ap show_composable; am.
Qed.

Definition associativity_facts c u v w :=
composable_facts c u v &
composable_facts c v w &
composable_facts c u (comp c v w) &
composable_facts c (comp c u v) w &
comp c u (comp c v w) = comp c (comp c u v) w.

Lemma show_associativity_facts : forall c u v w,
composable c u v -> composable c v w ->
associativity_facts c u v w.
Proof.
ir. cp H; uh H; ee.
cp H; uh H; ee. clear H7.
uhg.
do 4 (wr composable_facts_rw).
ee; try am.
rwi composable_facts_rw H0;
rwi composable_facts_rw H1.
uh H0; uh H1; ee.
ap show_composable.
am. am.
rw H20. am.
ap show_composable.
rwi composable_facts_rw H1; uh H1; ee; am.
rwi composable_facts_rw H0; uh H0; ee; am.
rwi composable_facts_rw H1; uh H1; ee.
rw H12.
uh H0; ee. uh H14; ee. am.
sy; ap H6. am. uh H0; ee; am.
Qed.

Definition morphism_property (o m:E) (c:E2) (i:E1) u:=
inc u m  & inc (source u) o & inc (target u) o &
c u (i (source u)) = u &
c (i (target u)) u = u &
Arrow.like u.

Definition object_property (o m:E) (i:E1) x :=
inc x o & inc (i x) m & source (i x) = x & target (i x) = x.

Definition composable_property (m:E) (c:E2)  u v:=
inc u m & inc v m & source u = target v &
inc (c u v) m &
source (c u v) = source v &
target (c u v) = target u.

Definition property (o m:E) (c:E2) (i:E1) :=
(forall x, inc x o = object_property o m i x) &
(forall u, inc u m = morphism_property o m c i u) &
(forall u v, inc u m -> inc v m -> source u = target v ->
   composable_property m c  u v) &
(forall u v w, inc u m -> inc v m -> inc w m ->
   source u = target v -> source v = target w ->
   c (c u v) w = c u (c v w)).

Lemma are_composable_create_rw : forall o m c i s u v,
are_composable (create o m c i s) u v =
(inc u m & inc v m & source u = target v).
Proof.
ir. ap iff_eq; ir. uh H.
rwi is_mor_create H. rwi is_mor_create H. xd.
uhg. do 2 (rw is_mor_create). xd.
Qed.

Lemma create_axioms : forall o m (c : E2) (i:E1) (s:E),
property o m c i ->
axioms (create o m c i s).
Proof.
ir.
set (k:=(create o m c i s)).

assert (lem1 : forall u v, are_composable k u v =
(inc u m & inc v m & source u = target v)).
ir. ap iff_eq; ir. ufi k H0.
rwi are_composable_create_rw H0.
xd.
uf k. rw are_composable_create_rw.
xd.
uh H; ee.

assert (lem2: forall u, is_mor k u = inc u m).
ir. ap iff_eq; ir. ufi k H3.
rwi is_mor_create H3. am.
uf k; rw is_mor_create; am.

assert (lem3: forall u v, inc u m -> inc v m ->
source u = target v -> comp k u v = c u v).
ir. uf k. rw comp_create; tv.

assert (lem5: forall x, inc x o -> id k x = i x).
ir. uf k. rw id_create. tv. am.

assert (lem6: forall (x:E), is_ob k x = inc x o).
ir; ap iff_eq; ir. ufi k H3. rwi is_ob_create H3. am.
uf k; rw is_ob_create; am.

(*** the proof of axioms ***)
(*** mor facts ***)
uhg; ee; ir.
ap iff_eq; ir. cp H3; rwi lem6 H3.
rwi H H3. uh H3; ee.
uhg; dj. am. rw lem2. rw lem5. am. am.
rw lem5; am.
rw lem5; am. rw lem5. rw lem3.
rwi lem2 H12. rwi H0 H12. uh H12; ee.
wr H13. am. wr lem2. am.
wr lem5. wr lem2. am. am. rw H7. am.
am. rw lem3. rw lem5. rwi lem2 H13.
rwi H0 H13. uh H13; ee. wr H14.
am. lu. wr lem2. am. wr lem2. am.
rw H10. sy; am. lu.

ap iff_eq; ir. rwi lem2 H3.
rwi H0 H3. uh H3; ee.
uhg; ee. rw lem2; am. rw lem6; am. rw lem6; am.
rw lem3. rw lem5. am. am.
rww lem5. rwi H H5. lu. am.
rww lem5. rwi H0 H3. uh H3; ee.
rwi H H10. uh H10; ee. am.

rww lem3. rw lem5. am. am.
rw lem5. rwi H H4. uh H4; ee.
am. am. rw lem5. rwi H H4.
uh H4; ee. sy; am. am. am.
lu.

ap iff_eq; ir. cp H3; uh H3; ee.
rwi lem2 H3. rwi lem2 H5.
util (H1 u v). am. am. am.
uh H7; ee.
uhg; xd. rw lem2. rww lem3.
rww lem3. rww lem3. lu.

(*** associativity ***)
assert (inc u m).
wr lem2; lu.
assert (inc v m).
wr lem2; lu.
assert (inc w m).
wr lem2; lu.
assert (source u = target v). lu.
assert (source v = target w). lu.
rww lem3. rww lem3. rww lem3. rww lem3.
rwi lem1 H3; rwi lem1 H4; ee.
ap H2; try am.
rww lem3. cp (H1 _ _ H6 H7 H9).
lu.
rww lem3. cp (H1 _ _ H5 H6 H8).
util (H1 v w). am. am. am.
uh H11; ee. rw H16. am.

util (H1 u v). am. am. am.
rw lem3. uh H10; ee. am. am. am. am.
rww lem3. util (H1 u v). am. am. am.
uh H10; ee. rw H14. am.

uf k.
ap create_like.
Qed.

Lemma ob_existence_rw : forall a x,
ob a x = (exists f, (mor a f & source f = x)).
Proof.
ir. ap iff_eq; ir.
rwi ob_facts_rw H. uh H; ee. sh (id a x); xd.
nin H. ee. rwi mor_facts_rw H. uh H; ee. wr H0; am.
Qed.

Lemma left_id: forall a b x u,
ob a x -> mor a u -> target u = x -> a = b ->
comp a (id b x) u = u.
Proof.
ir. rwi mor_facts_rw H0; uh H0; ee.
wr H2; wr H1; am.
Qed.

Lemma right_id : forall a b x u,
ob a x -> mor a u -> source u = x -> a= b ->
comp a u (id b x) = u.
Proof.
ir. rwi mor_facts_rw H0; uh H0; ee.
wr H2; wr H1; am.
Qed.

Lemma left_id_unique : forall a e x,
axioms a -> mor a e ->
source e = x ->
(forall f, composable a e f -> comp a e f = f) ->
e = id a x.
Proof.
ir.
rwi mor_facts_rw H0. wr H1. uh H0; ee.
transitivity (comp a e (id a x)).
rw right_id; try tv; try lu. wr H1; am.
wr H2. wr H1; tv. ap show_composable.
am. rwi ob_facts_rw H3; uh H3; ee; am.
rwi ob_facts_rw H3; uh H3; ee; sy; am.
Qed.

Lemma right_id_unique : forall a e x,
axioms a -> mor a e ->
target e = x ->
(forall f, composable a f e -> comp a f e = f) ->
e = id a x.
Proof.
ir.
rwi mor_facts_rw H0. wr H1. uh H0; ee.
transitivity (comp a (id a (target e)) e).
rw left_id; try tv; try lu.
ap H2. ap show_composable.
rwi ob_facts_rw H4; uh H4; ee; am. am.
rwi ob_facts_rw H4; uh H4; ee; am.
Qed.

Definition same_data (o m : E) (c : E2) (i: E1)
(o1 m1 : E) (c1 : E2) (i1: E1):=
(forall x, inc x o = inc x o1) &
(forall u, inc u m = inc u m1) &
(forall u v, inc u m -> inc v m -> source u = target v -> c u v = c1 u v) &
(forall x, inc  x o -> i x = i1 x).

Lemma ob_create : forall o m c i s x,
property o m c i-> ob (create o m c i s) x = inc x o.
Proof.
ir.
set (k:= create o m c i s).
assert (lem0 : axioms k).
uf k; ap create_axioms; am.
assert (lem1 : forall x, ob k x = is_ob k x).
ir. ap iff_eq; ir. lu. uhg; ee; am.
rw lem1. uf k; rw is_ob_create; tv.
Qed.

Lemma mor_create : forall o m c i s u,
property o m c i-> mor (create o m c i s) u = inc u m.
Proof.
ir.
set (k:= create o m c i s).
assert (lem0 : axioms k).
uf k; ap create_axioms; am.
assert (lem1 : forall u, mor k u = is_mor k u).
ir. ap iff_eq; ir. lu. uhg; ee; am.
rw lem1. uf k; rw is_mor_create; tv.
Qed.

Lemma uncomp : forall a b u v u1 v1,
a = b -> u = u1 -> v = v1 -> comp a u v = comp b u1 v1.
Proof.
ir. rw H; rw H0; rw H1; tv.
Qed.

Lemma U_morphisms : forall a,
(U a) = morphisms a.
Proof.
ir. tv.
Qed.

Lemma is_mor_mor : forall a u,
axioms a -> is_mor a u -> mor a u.
Proof.
ir. uh H; ee.
rwi H1 H0. uhg; uh H0; xd.
uhg; au.
Qed.

Lemma is_ob_ob : forall a x,
axioms a -> is_ob a x -> ob a x.
Proof.
ir. uh H; ee.
rwi H H0. uhg; uh H0; xd.
uhg; au.
Qed.

Lemma ob_is_ob : forall a x,
ob a x -> is_ob a x.
Proof.
ir. lu.
Qed.

Lemma mor_id : forall a x,
ob a x -> mor a (id a x).
Proof.
ir. rwi ob_facts_rw H; uh H; ee. am.
Qed.

Lemma mor_id_rw : forall a x,
ob a x -> mor a (id a x) = True.
Proof.
ir. ap iff_eq; ir; try tv. app mor_id.
Qed.

Lemma source_id : forall a x,
ob a x -> source (id a x) = x.
Proof.
ir. rwi ob_facts_rw H; uh H; ee. am.
Qed.

Lemma target_id : forall a x,
ob a x -> target (id a x) = x.
Proof.
ir. rwi ob_facts_rw H; uh H; ee. am.
Qed.

Lemma ob_source : forall a u,
mor a u -> ob a (source u) = True.
Proof.
ir. rwi mor_facts_rw H; uh H; ee.
ap iff_eq; ir; try tv; try am.
Qed.

Lemma ob_target : forall a u,
mor a u -> ob a (target u) = True.
Proof.
ir. rwi mor_facts_rw H; uh H; ee.
ap iff_eq; ir; try tv; try am.
Qed.

Lemma mor_comp : forall a b u v,
mor a u -> mor a v ->
source u = target v -> a = b -> mor a (comp b u v)= True.
Proof.
ir. wr H2. assert (composable_facts a u v).
ap show_composable_facts; am.
ap iff_eq; ir; try tv; try am. lu.
Qed.

Lemma source_comp : forall a u v,
mor a u -> mor a v ->
source u = target v -> source (comp a u v) = source v.
Proof.
ir. assert (composable_facts a u v).
ap show_composable_facts; am. lu.
Qed.

Lemma target_comp : forall a u v,
mor a u -> mor a v ->
source u = target v ->target (comp a u v) = target u.
Proof.
ir. assert (composable_facts a u v).
ap show_composable_facts; am. lu.
Qed.

Lemma assoc : forall a b u v w,
mor a u -> mor a v -> mor a w ->
source u = target v -> source v = target w ->
a= b ->
comp a (comp b u v) w = comp a u (comp b v w).
Proof.
ir. wr H4.
assert (associativity_facts a u v w).
ap show_associativity_facts; ap show_composable;
am.
uh H5; ee. sy; am.
Qed.

Lemma mor_arrow_like : forall a u,
mor a u -> Arrow.like u.
Proof.
ir. rwi mor_facts_rw H. lu.
Qed.

Hint Rewrite left_id right_id mor_id_rw source_id target_id
ob_source ob_target mor_comp source_comp target_comp : cw.

Lemma mor_inc_U : forall a u,
mor a u -> inc u (U a).
Proof.
ir. change (is_mor a u); lu.
Qed.

Lemma mor_is_mor : forall a u,
mor a u -> is_mor a u.
Proof.
ir. lu.
Qed.

Definition opp' a :=
Notations.create (objects a) (Image.create (morphisms a) flip)
(fun u v => flip (comp a (flip v) (flip u)))
(fun x => flip (id a x)) (structure a).

Lemma is_ob_opp' : forall a x,
is_ob (opp' a) x = is_ob a x.
Proof.
ir. uf opp'. rw is_ob_create. tv.
Qed.

Lemma structure_opp' : forall a, structure (opp' a) =
structure a.
Proof.
ir. uf opp'. rww structure_create.
Qed.

Lemma inc_image_create_flip : forall a u,
inc u (Image.create (morphisms a) flip) = is_mor (opp' a) u.
Proof.
ir. uf opp'. rw is_mor_create. tv.
Qed.

Lemma is_mor_opp' : forall a u,
is_mor (opp' a) u = is_mor a (flip u).
Proof.
ir. uf opp'. rw is_mor_create.
rw Image.inc_rw. app iff_eq; ir.
nin H. ee. wr H0. rw flip_flip.
am.
sh (flip u). ee. am. rww flip_flip.
Qed.

Lemma comp_opp' : forall a u v,
is_mor (opp' a) u -> is_mor (opp' a) v ->
source u = target v ->
comp (opp' a) u v = flip (comp a (flip v) (flip u)).
Proof.
ir. uf opp'. rw comp_create. tv.
rww inc_image_create_flip.
rww inc_image_create_flip. am.
Qed.

Lemma id_opp' : forall a x,
is_ob (opp' a) x ->
id (opp' a) x = flip (id a x).
Proof.
ir. uf opp'. rw id_create. tv.
ufi opp' H. rwi is_ob_create H. am.
Qed.

Lemma opp'_opp' : forall a,
axioms a -> opp' (opp' a) = a.
Proof.
ir. assert (like a).
lu.  uh H0.
transitivity (create (objects a) (morphisms a) (comp a) (id a)
(structure a)).
assert (Image.create (Image.create (morphisms a) flip) flip
= morphisms a).
ap extensionality; uhg; ir. rwi Image.inc_rw H1.
nin H1. ee. rwi Image.inc_rw H1. nin H1. ee.
wr H2. wr H3. rw flip_flip. am.
ap Image.show_inc. sh (flip x). ee.
ap Image.show_inc. sh x. ee. am. tv.
rww flip_flip.

uf opp'. ap create_extensionality.
rww objects_create. rw morphisms_create.
am.
rw morphisms_create. rw H1. ir.
rw comp_create. rw flip_flip. rw flip_flip. rww flip_flip.
ap Image.show_inc. sh v; ee; try am. tv.
ap Image.show_inc. sh u; ee; try tv; try am.
rw source_flip. rw target_flip. sy; am.
apply mor_arrow_like with a. app is_mor_mor.
apply mor_arrow_like with a. app is_mor_mor.
rw objects_create. ir.
rw id_create. rww flip_flip. am. rww structure_create.
sy; am.
Qed.

Lemma opp'_axioms : forall a,
axioms a -> axioms (opp' a).
Proof.
ir.
assert (morli : forall u, is_mor a u -> Arrow.like u).
ir. uh H; ee. rwi H1 H0. uh H0; ee. am.
assert (obidli : forall x, is_ob a x -> Arrow.like (id a x)).
ir. uh H. ee. rwi H H0. uh H0. ee.
ap morli. am.
assert (flifli : forall u, flip (flip u) = u).
ir. rw flip_flip. tv.

uf opp'. ap create_axioms.
assert (ax : axioms a).
am.
uh H; ee.
assert (alike : like a).
am. clear H3.
uhg; dj;
try (ap iff_eq; ir).

assert (ob a x). apply is_ob_ob. am. am.
uhg; ee. am.
ap Image.show_inc. sh (id a x). ee.
ap mor_is_mor. ap mor_id. ap is_ob_ob. am.
am. tv. rw source_flip. rww target_id.
ap obidli. am.
rw target_flip. rww source_id. app obidli.
lu.

assert (mor a (flip u)).
rwi Image.inc_rw H4. nin H4; ee.
ap is_mor_mor. am. wr H5. rw flip_flip.
am.

uhg; ee. am. wr (flifli u).
rw source_flip.
uh H5; ee. rwi H0 H6. lu.
ap morli. lu.
wr source_flip.
ap ob_is_ob. rww ob_source.
rw like_flip. ap morli. lu.
rw flip_flip. rw left_id. rww flip_flip.
wr target_flip. rww ob_target.
rw like_flip. ap morli. lu.
am. rww target_flip.
rw like_flip. ap morli. lu. tv.
rw flip_flip. rw right_id. rww flip_flip.
wr source_flip. rww ob_source.
rw like_flip. ap morli. lu.
am. rww source_flip.
rw like_flip. ap morli. lu. tv.
rw like_flip. ap morli. lu.
lu.

assert (mor a (flip u)).
rwi Image.inc_rw H5. nin H5; ee. wr H8. rw flip_flip.
app is_mor_mor.
assert (mor a (flip v)).
rwi Image.inc_rw H6. nin H6; ee. wr H9. rw flip_flip.
app is_mor_mor.
assert (Arrow.like u).
rw like_flip. ap morli. ap mor_is_mor. am.
assert (Arrow.like v).
rw like_flip. ap morli. ap mor_is_mor. am.

uhg; ee. am. am. am.
ap Image.show_inc.
sh (comp a (flip v) (flip u)). ee.
ap mor_is_mor. rw mor_comp. tv.
am. am. rw source_flip. rw target_flip. sy; am.
rw like_flip. ap morli. ap mor_is_mor. tv.
rw like_flip. ap morli. ap mor_is_mor. am. tv.
tv. rw source_flip. rw target_comp. rww target_flip.

am. am. rw source_flip. rw target_flip. sy; am. am. am.
ap morli. ap mor_is_mor. rw mor_comp.
tv. am. am.
 rw source_flip. rw target_flip. sy; am.

tv. am. tv.
rw target_flip. rw source_comp. rww source_flip.

am. am. rw source_flip. rww target_flip.
sy; am. am.

ap morli. ap mor_is_mor. rw mor_comp.
tv. am. am.
 rww source_flip. rww target_flip. sy; am.

tv.
rw flip_flip. rw flip_flip.

assert (mor a (flip u)).
rwi Image.inc_rw H6. nin H6; ee. wr H11. rw flip_flip.
app is_mor_mor.
assert (mor a (flip v)).
rwi Image.inc_rw H7. nin H7; ee. wr H12. rw flip_flip.
app is_mor_mor.
assert (mor a (flip w)).
rwi Image.inc_rw H8. nin H8; ee. wr H13. rw flip_flip.
app is_mor_mor.
assert (Arrow.like u).
rw like_flip. ap morli. ap mor_is_mor. am.
assert (Arrow.like v).
rw like_flip. ap morli. ap mor_is_mor. am.
assert (Arrow.like w).
rw like_flip. ap morli. ap mor_is_mor. am.

rw assoc. tv. am. am. am.
rww source_flip. rww target_flip. sy; am.
sy; rww source_flip; rww target_flip. tv.
Qed.

Definition opp a := Y (axioms a) (opp' a) a.

Lemma axioms_opp : forall a,
axioms (opp a) = axioms a.
Proof.
ir. apply by_cases with (axioms a); ir.
assert (opp a = opp' a).
uf opp. ap (Y_if  H). tv.
rw H0.
ap iff_eq; ir. am. ap opp'_axioms. am.
assert (opp a = a).
uf opp. ap (Y_if_not H). tv. rww H0.
Qed.

Lemma opp_axioms : forall a, axioms a -> axioms (opp a).
Proof.
ir. rww axioms_opp.
Qed.

Lemma opp_opp : forall a, opp (opp a) = a.
Proof.
ir. apply by_cases with (axioms a); ir.
assert (opp a = opp' a).
uf opp. ap (Y_if  H). tv.
rw H0.
assert (axioms (opp' a)). ap opp'_axioms. am.
assert (opp (opp' a) = opp' (opp' a)).
uf opp. ap (Y_if  H1). reflexivity.
rw H2. rw opp'_opp'. tv. am.
assert (opp a = a).
uf opp. ap (Y_if_not H). tv. rw H0.
uf opp. ap (Y_if_not H). tv.
Qed.

Lemma structure_opp : forall a, structure (opp a) = structure a.
Proof.
ir.
apply by_cases with (axioms a); ir.
assert (opp a = opp' a).
uf opp. ap (Y_if  H). tv.
rw H0. rww structure_opp'.
assert (opp a = a).
uf opp. ap (Y_if_not H). tv.
rww H0.
Qed.

Lemma ob_opp' : forall a x,
axioms a ->
ob (opp' a) x = ob a x.
Proof.
ir.
sy. ap iff_eq; ir.
uhg; ee. ap opp'_axioms. lu.
rw is_ob_opp'. lu.
uhg; ee. am.
wr is_ob_opp'. lu.
Qed.

Lemma mor_opp' : forall a u,
axioms a ->
mor (opp' a) u = mor a (flip u).
Proof.
ir.
assert (lem : forall b v, axioms b ->
mor (opp' b) v -> mor b (flip v)).
ir. uhg; ee. am. uh H1; ee.
rwi is_mor_opp' H2. am.
ap iff_eq; ir. au.
assert (u = flip (flip u)).
rw flip_flip; tv.
uhg; ee. ap opp'_axioms. am.
rw is_mor_opp'. app  mor_is_mor.
Qed.

Lemma unfold_opp : forall a, axioms a ->
opp a = opp' a.
Proof.
ir. uf opp. ap (Y_if H). tv.
Qed.

Lemma ob_opp : forall a x,
ob (opp a) x = ob a x.
Proof.
ir. ap iff_eq; ir.
assert (axioms a). wr axioms_opp. uh H; ee; am.
rwi unfold_opp H. rwi ob_opp' H. am.
am. am.
assert (axioms a). uh H; ee; am.
rww unfold_opp. rww ob_opp'.
Qed.

Lemma mor_opp : forall a u,
mor (opp a) u = mor a (flip u).
Proof.
ir. ap iff_eq; ir.
assert (axioms a). wr axioms_opp. uh H; ee; am.
rwi unfold_opp H. rwi mor_opp' H. am.
am. am.
assert (axioms a). uh H; ee; am.
rww unfold_opp. rww mor_opp'.
Qed.

Lemma comp_opp : forall a u v,
mor (opp a) u -> mor (opp a) v -> source u = target v ->
comp (opp a) u v = flip (comp a (flip v) (flip u)).
Proof.
ir. assert (axioms a).
wr axioms_opp. uh H; ee; am.
rw unfold_opp. rw comp_opp'.
tv. ap mor_is_mor. wrr unfold_opp.
ap mor_is_mor. wrr  unfold_opp. tv. am.
Qed.

Lemma id_opp : forall a x,
ob (opp a) x ->
id (opp a) x = flip (id a x).
Proof.
ir. assert (axioms a).
wr axioms_opp. uh H; ee; am.
rw unfold_opp. rww id_opp'. ap ob_is_ob.
wrr unfold_opp. am.
Qed.

Lemma composable_opp : forall a u v,
axioms a ->
composable (opp a) u v = composable a (flip v) (flip u).
Proof.
ir. ap iff_eq; ir.
rwi composable_facts_rw H0; ap show_composable;
try (wr mor_opp; lu); try (rw mor_opp; lu).
rw source_flip. rw target_flip; try (sy; lu).
apply mor_arrow_like with (opp a); lu.
apply mor_arrow_like with (opp a); lu.
rwi composable_facts_rw H0. ap show_composable.
uh H0; ee. rww mor_opp. rww mor_opp.
lu. uh H0; ee.
wr source_flip. wr target_flip.
sy; am. rw like_flip. apply mor_arrow_like with a; lu.
rw like_flip; apply mor_arrow_like with a; lu.
Qed.

Definition are_inverse a u v :=
mor a u & mor a v &
source u = target v &
source v = target u &
comp a u v = id a (source v) &
comp a v u = id a (source u).

Lemma are_inverse_symm :forall a u v,
are_inverse a u v -> are_inverse a v u.
Proof.
ir. uh H; ee. uhg; ee; try am.
Qed.

Definition invertible a u :=
exists v, are_inverse a u v.

Definition inverse a u := choose (are_inverse a u).

Lemma invertible_inverse :
forall a u, invertible a u -> are_inverse a u (inverse a u).
Proof.
ir. exact (choose_pr H).
Qed.

Lemma inverse_unique : forall a u v w,
are_inverse a u v -> are_inverse a u w -> v = w.
Proof.
ir. uh H; uh H0; ee.
transitivity (comp a (comp a v u) w).
rw assoc. rw H4.
rw right_id. tv.
uh H0; ee. cw. am.  rww H3. tv.
am. am. am. am. am. tv.
rw H10. cw. cw.  sy; am.
Qed.

Lemma inverse_uni : forall v w,
(exists a, exists u, (are_inverse a u v & are_inverse a u w)) ->
v = w.
Proof.
ir. nin H. nin H. ee.
exact (inverse_unique H H0).
Qed.

Lemma inverse_eq : forall a u v,
are_inverse a u v -> inverse a u = v.
Proof.
ir. ap inverse_uni. sh a. sh u. ee.
ap invertible_inverse. uhg. sh v; am. am.
Qed.

Lemma inverse_invertible : forall a u,
invertible a u -> invertible a (inverse a u).
Proof.
ir. uhg. sh u. ap are_inverse_symm.
ap invertible_inverse. am.
Qed.

Lemma inverse_inverse : forall a u,
invertible a u -> inverse a (inverse a u) = u.
Proof.
ir. apply inverse_unique with a (inverse a u).
ap invertible_inverse. ap inverse_invertible. am.
ap are_inverse_symm. ap invertible_inverse. am.
Qed.

Lemma source_inverse : forall a u,
invertible a u -> source (inverse a u) = target u.
Proof.
ir. cp (invertible_inverse H). uh H0; ee.
lu.
Qed.

Lemma target_inverse : forall a u,
invertible a u -> target (inverse a u) = source u.
Proof.
ir. cp (invertible_inverse H). uh H0; ee.
sy; lu.
Qed.

Lemma left_inverse : forall a u,
invertible a u -> comp a (inverse a u) u = id a (source u).
Proof.
ir. cp (invertible_inverse H). uh H0; ee. am.
Qed.

Lemma right_inverse : forall a u,
invertible a u -> comp a u (inverse a u) = id a (target u).
Proof.
ir. cp (invertible_inverse H). uh H0; ee.
rwi source_inverse H4. am. am.
Qed.

Lemma mor_inverse : forall a u,
invertible a u ->
mor a (inverse a u).
Proof.
ir. cp (invertible_inverse H). uh H0; ee. lu.
Qed.

Lemma mor_inverse_rw : forall a b u,
invertible a u -> a = b ->
mor a (inverse b u) = True.
Proof.
ir. app iff_eq; ir. wr H0. app mor_inverse.
Qed.

Hint Rewrite source_inverse target_inverse left_inverse
right_inverse mor_inverse_rw :cw.

Lemma composable_inverse_left : forall a u,
invertible a u -> composable a (inverse a u) u.
Proof.
ir. cp (invertible_inverse H). uh H0; ee.
ap show_composable; lu.
Qed.

Lemma composable_inverse_right : forall a u,
invertible a u -> composable a u (inverse a u).
Proof.
ir. cp (invertible_inverse H). uh H0; ee.
ap show_composable; lu.
Qed.

Lemma composable_inverse : forall a u v,
composable a u v -> invertible a u -> invertible a v ->
composable a (inverse a v) (inverse a u).
Proof.
ir.
cp (invertible_inverse H0).
cp (invertible_inverse H1).
cp H. rwi composable_facts_rw H; uh H; ee.
ap show_composable. lu. lu.
rw source_inverse; try am. rw target_inverse; try am.
sy; am.
Qed.

Lemma invertible_comp_are_inverse : forall a u v,
composable a u v -> invertible a u -> invertible a v ->
are_inverse a (comp a u v) (comp a (inverse a v) (inverse a u)).
Proof.
ir.
cp (invertible_inverse H0).
cp (invertible_inverse H1).
cp H. rwi composable_facts_rw H; uh H; ee.

uhg; ee; try am. cw. lu. lu.
cw.
sy; lu.
cw.  lu. lu. cw. sy; lu.
cw. lu. lu. cw. sy; lu.
cw.
rw assoc.
assert (comp a v (comp a (inverse a v) (inverse a u))=
inverse a u).
wr assoc. cw.
cw. cw. cw. cw. cw. lu. cw. cw.  sy; lu. tv.
rw H12. cw. lu. lu. cw. lu. lu.
cw. sy; lu. lu. cw. lu. lu. cw.
sy; lu. tv. lu. lu. cw. sy; lu.
rw assoc.
assert (comp a (inverse a u) (comp a u v) = v).
wrr assoc. cw. cw. sy; lu. cw. cw.
rw H12. cw. cw. cw. cw. cw. sy; lu. cw. tv.
Qed.

Lemma invertible_comp : forall a u v,
composable a u v -> invertible a u -> invertible a v ->
invertible a (comp a u v).
Proof.
ir. uhg; sh (comp a (inverse a v) (inverse a u)).
ap invertible_comp_are_inverse; am.
Qed.

Lemma inverse_comp : forall a u v,
composable a u v -> invertible a u -> invertible a v ->
inverse a (comp a u v) = comp a (inverse a v) (inverse a u).
Proof.
ir. ap inverse_eq. ap invertible_comp_are_inverse; am.
Qed.

Lemma identity_are_inverse : forall a x,
ob a x -> are_inverse a (id a x) (id a x).
Proof.
ir. rwi ob_facts_rw H. uh H; ee.
uhg; ee; try am. cw. cw. cw. cw.
Qed.

Lemma inverse_id : forall a x,
ob a x -> inverse a (id a x) = id a x.
Proof.
ir. ap inverse_eq. ap identity_are_inverse; am.
Qed.

Hint Rewrite inverse_id : cw.

Ltac alike :=
match goal with
id1 : (mor _ ?X1) |- (Arrow.like ?X1) =>
exact (mor_arrow_like id1) |
_=>fail
end.

End Category.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D E F X Dprime : Universe, ((wd_ A B /\ (wd_ A D /\ (wd_ B C /\ (wd_ D E /\ (wd_ D Dprime /\ (wd_ C Dprime /\ (wd_ A C /\ (wd_ B D /\ (wd_ E F /\ (wd_ E C /\ (wd_ C D /\ (wd_ F C /\ (wd_ F D /\ (wd_ X C /\ (wd_ X D /\ (wd_ E A /\ (wd_ B F /\ (col_ A B C /\ (col_ A B D /\ (col_ A E F /\ (col_ B E F /\ col_ D C Dprime))))))))))))))))))))) -> col_ A B E)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D0 D Y0 Y X : Universe, ((wd_ B A /\ (wd_ A D0 /\ (wd_ B D0 /\ (wd_ B C /\ (wd_ A C /\ (wd_ B D /\ (wd_ C D /\ (wd_ Y B /\ (wd_ Y A /\ (wd_ D A /\ (wd_ Y X /\ (wd_ Y0 D /\ (wd_ B Y0 /\ (wd_ A Y0 /\ (wd_ Y D /\ (col_ B C Y /\ (col_ Y0 D Y /\ (col_ A B X /\ (col_ B D Y /\ col_ B D0 D))))))))))))))))))) -> col_ B C D)).
Proof.
  time tac.
Qed.

End FOFProblem.