Load "eztactics.v".

Require Import Arith.
Require Import List.
Require Import Specif.

Add LoadPath "Listkit" as Listkit.

Require Import Listkit.NthError.
Require Import Listkit.Foreach.

Require Import Term.
Require Import Shift.
Require Import Typing.

Hint Rewrite map_length: map.

Ltac map_omega :=
   autorewrite with map; omega.

(** * Simultaneous substitution of a list of terms beginning at De Bruijn index k *)
Fixpoint subst_env k vs tm {struct tm} :=
  match tm with
  | TmConst => tm
  | TmVar x =>
    if le_gt_dec k x then
      match nth_error vs (x-k) with
      | None => tm
      | Some v => v
      end
    else tm
  | TmPair l m => TmPair (subst_env k vs l) (subst_env k vs m)
  | TmProj b m => TmProj b (subst_env k vs m)
  | TmApp l m => TmApp (subst_env k vs l) (subst_env k vs m)
  | TmAbs n => TmAbs (subst_env (S k) (map (shift 0 1) vs) n)
end.

Lemma subst_env_nonfree_noop:
  forall N T env Vs n,
    Typing env N T ->
    n >= length env ->
      subst_env n Vs N = N.
Proof.
 induction N; simpl; intros T env Vs n tp n_big;
   auto; inversion tp; try (f_equal; eauto).
 (* Case TmVar *)
  break; [ | sauto].
  subst.
  case_eq (nth_error Vs (x - n)); [ | sauto].
  absurd (x < length env).
   efinish.
  efinish.
 (* Case TmAbs *)
 eapply IHN; efinish.
Qed.

Lemma subst_env_closed_noop:
  forall N T Vs n,
    Typing nil N T ->
      subst_env n Vs N = N.
Proof.
 intros.
 eapply subst_env_nonfree_noop; eauto.
 simpl; omega.
Qed.

(**
       Vs :: env'
env, env' |- tm       : ty
env       |- tm{Vs/k} : ty    (where k = length env)
*)
Lemma subst_env_preserves_typing:
  forall tm Vs env env' ty k,
    env_typing Vs env' ->
    Typing (env ++ env') tm ty ->
    k = length env ->
      Typing env (subst_env k Vs tm) ty.
Proof.
 induction tm; simpl; intros Vs env env' ty k Vs_tp tp k_eq;
    inversion tp; subst; eauto.
(* Case TmVar *)
  destruct Vs_tp as [Vs_env'_equilong Vs_tp].
  destruct (le_gt_dec (length env) x); auto.
   (* x is beyond length env *)
   assert (value ty = nth_error env' (x - length env)).
    apply nth_error_app; trivial.
(* TODO: Alternate version. Is this better? *)
   (* destruct (nth_error_dichot _ Vs (x-length env)) as [[bounds is_error] | [? ?]]. *)
   (*  refute. *)
   (*  apply nth_error_to_length in H. *)
   (*  apply nth_error_overflow in is_error. *)
   (*  omega. *)
   (* assert ({v : Term | nth_error Vs (x - length env) = value v}). *)
   (*  admit. *)
   (* destruct H3 as [v H3]. *)
   (* rewrite H3; simpl. *)
   (* cut (Typing nil v ty); [sauto | ]. *)
   (* eapply foreach2_ty_member; eauto. *)
    case_eq (nth_error Vs (x-length env));
      [intros v H_v | intros H_v; refute]; auto.
    (* Obtained value v for x-length env in Vs. *)
    apply Weakening_closed.
    eapply foreach2_ty_member; eauto.
   (* Bogus case of no value for x-length env. *)
   apply <- nth_error_overflow in H_v.
   apply nth_error_ok_rev in H.
   omega.
  (* Case of x in env. *)
  apply TVar.
  rewrite <- nth_error_ext_length in H0; auto.
(* Case TmAbs *)
 apply TAbs.
 replace (S (length env)) with (length (s::env)) by trivial.
 apply IHtm with env'; trivial.
 erewrite env_typing_shift_noop; eauto.
Qed.

Hint Resolve subst_env_preserves_typing.

Lemma subst_nil :
  forall N k, subst_env k nil N = N.
Proof.
 induction N; intros k; simpl; try (solve [f_equal; eauto]).
 (* Case TmVar *)
 rewrite nth_error_nil.
 destruct (le_gt_dec k x); auto.
Qed.

Hint Resolve subst_nil (* Used in the proof of @normalization@! *).

(** If a variable is bigger than [q + length env] then it is untouched
 by substituting ([q], [env]). *)
(* TODO: This might be a lemma that would be immediate from a lemma about
   subst_env and freevars. *)
Lemma subst_env_big_var :
  forall q x env,
    q + length env <= x ->
      TmVar x = subst_env q env (TmVar x).
Proof.
 intros.
 simpl.
 break; auto.
 nth_error_dichotomize bounds is_error v v_def; auto.
 finish.
Qed.

Lemma shift_subst_commute_hi:
  forall M env k q n,
    q + length env <= k ->
    shift k n (subst_env q env M) =
      subst_env q (map (shift k n) env) (shift k n M).
Proof.
 induction M; intros env k q n k_overbounds_subst.
 (* Case TmConst *)
      sauto.

 (* Case TmVar *)
     unfold shift at 3.
     unfold shift_var.
     destruct (le_gt_dec k x) ; [ | ].
      rewrite <- subst_env_big_var by omega.
      rewrite <- subst_env_big_var.
       simpl; unfold shift_var.
       break; finish.
      solve[map_omega].
     simpl.
     break.
      rewrite nth_error_map.
      nth_error_dichotomize bounds is_error v v_def.
       unfold shift_var.
       break; finish.
      sauto.
     simpl; unfold shift_var.
     break; finish.

 (* Case TmPair *)
    simpl; f_equal; seauto.

 (* Case TmProj *)
   simpl; f_equal; seauto.

 (* Case TmAbs *)
  simpl.
  rewrite IHM by (map_omega).
  f_equal.
  f_equal.
  rewrite map_map.
  rewrite map_map.
  apply map_ext; intros M'.
  apply shift_shift_commute.
  omega.

 (* Case TmApp *)
 simpl; f_equal; seauto.
Qed.

Lemma shift_subst_commute_lo:
  forall M env k q n,
    k <= q ->
    shift k n (subst_env q env M) =
      subst_env (q+n) (map (shift k n) env) (shift k n M).
Proof.
 induction M; simpl; intros env k q n k_low.
 (* TmConst *)
      sauto.

 (* TmVar *)
     unfold shift_var.
     (* Take cases on where x is in relation to k, q: *)
     case_eq (le_gt_dec q x); intros;
       case_eq (le_gt_dec k x); intros; try (solve[exfalso;omega]);
       destruct (le_gt_dec (q+n) (x+n)); try (solve[exfalso;omega]).
     (* Case k <= q <= x. *)
       replace (x+n-(q+n)) with (x-q) by omega.
       (* Take cases on whether x-q is defined in env: *)
       nth_error_dichotomize index_hi result_none V V_def;
         rewrite nth_error_map ; (rewrite result_none || rewrite V_def);
       simpl; unfold shift_var.
       (* Case length env <= x - q. *)
        rewrite H0; sauto.
       (* Case x - q < length env. *)
       sauto.
     (* Case k <= x < q. *)
      simpl; unfold shift_var.
      solve [breakauto].
     (* Case x < k <= q. *)
     breakauto.
     simpl; unfold shift_var.
     rewrite H0; sauto.

 (* Case TmPair *)
    f_equal; seauto.

 (* Case TmProj *)
   f_equal; seauto.

 (* Case TmAbs *)
  rewrite IHM by omega.
  f_equal.
  f_equal.
  rewrite map_map.
  rewrite map_map.
  apply map_ext; intros M'.
  apply shift_shift_commute.
  omega.

 (* Case TmApp *)
 f_equal; seauto.
Qed.

Lemma subst_env_concat_TmVar:
  forall
    (x : nat)
    (Vs : list Term)
    (Ws : list Term)
    (env : list Ty)
    (k : nat)
    (env_closed : env_typing (Vs ++ Ws) env)
    (VsWs_env_equilong : length (Vs ++ Ws) = length env)
    (env_closed' : foreach2_ty Term Ty (Vs ++ Ws) env
                    (fun (x0 : Term) (y : Ty) => Typing nil x0 y)),
      (subst_env k Vs (subst_env (k + length Vs) Ws (TmVar x)) =
       subst_env k (Vs ++ Ws) (TmVar x)).
Proof.
 intros.
 unfold subst_env at 3.
 unfold subst_env at 2.

 case_eq (le_gt_dec k x); [intros k_le_x ?|intros x_gt_x H].
 (* Case k <= x *)
  replace (x - (k + length Vs)) with (x - k - length Vs) by omega.

  destruct (equilong_nth_error Term Ty (Vs++Ws) env (x - k))
        as [[x_small [VW' [T' HH]]] | [x_large HH]]; trivial;
    destruct HH as [lookup_VWs lookup_env].
  (* Case x < k + length (Vs++Ws) *)

   destruct (le_gt_dec (k+length Vs) x).
   (* Case k+length Vs <= x *)
    rewrite <- rewrite_nth_error_app; [|omega].
    rewrite lookup_VWs; simpl.
    (* subst_env k Vs VW' = VW': *)
    apply subst_env_closed_noop with T'.
    (* Typing nil VW' T': *)
    eapply foreach2_ty_member; eauto; trivial.
   (* Case k+length Vs > x *)
   simpl; rewrite H.
   (rewrite <- nth_error_ext_length in lookup_VWs by omega);
   (rewrite <- nth_error_ext_length by omega; reflexivity).

  (* Case x >= k + length (Vs++Ws) *)
  rewrite app_length in x_large.
  rewrite <- rewrite_nth_error_app; [|omega].
  rewrite lookup_VWs; simpl.
  double_case.
  symmetry; apply subst_env_big_var; omega.

 (* Case k > x *)
 break; try easy.
 simpl.
 rewrite H; easy.
Qed.

(** If two successive substitutions are "independent" and adjacent then we can combine
   them into one. *)
Lemma subst_env_concat:
  forall N Vs Ws env k,
    env_typing (Vs++Ws) env->
    let k' := k + length Vs in
    let VWs := Vs++Ws in
      subst_env k Vs (subst_env k' Ws N) = subst_env k (VWs) N.
Proof.
 let triage := solve[simpl; f_equal; eauto] in
 induction N; intros Vs Ws env k env_closed;
     inversion env_closed as [VsWs_env_equilong env_closed'];
     trivial; try triage.

 (* Case TmVar *)
  eapply subst_env_concat_TmVar; eauto.

 (* Case TmAbs *)
 simpl; f_equal.
 rewrite map_app.
 replace (length Vs) with (length (map (shift 0 1) Vs)); [|apply map_length].
 replace (S(k+length (map (shift 0 1) Vs))) with
    (S k+length (map (shift 0 1) Vs)); [|easy].
 apply IHN with env; auto.
 rewrite <- map_app.
 erewrite env_typing_shift_noop; eauto.
Qed.

(** Shifting creates a term with a "dummy" (unused) variable;
    substituting at that variable has no effect, so we can drop it off
    the environment for substitution. *)
Lemma subst_dummyvar :
  forall N h t k,
    subst_env k (h::t) (shift k 1 N) = subst_env (S k) t (shift k 1 N).
Proof.
 induction N; intros h t k; try (solve[simpl; f_equal; eauto]).
 (* TmVar *)
 unfold shift, shift_var.
 destruct (le_gt_dec k x).
  unfold subst_env.
  replace (x+1-k) with (S (x - k)) by omega.
  replace (nth_error (h::t) (S (x-k))) with (nth_error t (x-k)) by auto.
  replace (x+1-(S k)) with (x - k) by omega.
  break; break; finish.
 unfold subst_env.
 break; break; finish.
Qed.

Require Import OutsideRange.

Lemma subst_var_outside_range:
  forall q env x,
    outside_range q (length env + q) x = true ->
      subst_env q env (TmVar x) = TmVar x.
Proof.
 unfold outside_range.
 intros.
 simpl.
 break; [|auto].
 nth_error_dichotomize a b c d.
  auto.
 destruct (le_gt_dec (length env + q) x).
  exfalso; omega.
 discriminate.
Qed.

Lemma subst_var_inside_range:
  forall q env x,
    outside_range q (length env + q) x = false ->
      exists X, value X = nth_error env (x-q) /\
                (subst_env q env (TmVar x)) = X.
Proof.
 unfold outside_range.
 intros.
 simpl.
 destruct (le_gt_dec q x).
  nth_error_dichotomize a b c d.
  destruct (le_gt_dec (length env + q) x).
   discriminate.
   exfalso; omega.
   destruct (le_gt_dec (length env + q) x).
   eauto.
  eauto.
 discriminate.
Qed.

Require Import Listkit.Sets.
Require Import Listkit.AllType.

Definition set_remove := Listkit.Sets.set_remove.

Require Import Coq.Logic.FunctionalExtensionality.  (* Assumes an axiom. *)

Lemma pred_is_minus_1:
   (fun x => x-1) = pred.
Proof.
 extensionality x.
 omega.
Qed.

Hint Resolve pred_is_minus_1.

(** [unshift q k] commutes with subst, if we offset the environment by
    [k] and [shift q k] all its terms.

    TODO: Consider making this use outside_range.
*)
Lemma subst_unshift :
  forall M env q k n,
    q <= n ->
    all_Type _ eq_nat_dec (fun x => Outside_Range q (k+q) x) (freevars M) ->
      subst_env n env (unshift q k M) =
      unshift q k (subst_env (n+k) (map (shift q k) env) M).
Proof.
 induction M; simpl; intros env q k n q_le_n fvs_dichot.
 (* Case TmConst *)
      sauto.

 (* Case TmVar *)
     assert (H : {x < q} + {x >= k+q}).
      unfold all_Type in fvs_dichot.
      apply fvs_dichot.
      simpl.
      auto.
     unfold unshift, shift, unshift_var, shift_var.
     simpl.
     rewrite nth_error_map.
     replace (x-(n+k)) with (x-k-n) by omega.

     destruct H.
     (* x < q *)
      break; break; break; try break; finish.
     (* x >= k + q *)
     destruct (le_gt_dec (k+q) x); [ | finish].
     destruct (le_gt_dec n (x-k)).
      destruct (le_gt_dec (n+k) x); [ | finish].
      nth_error_dichotomize bounds is_error v v_def.
       break; finish.
      rewrite unshift_shift; auto.
     destruct (le_gt_dec (n+k) x); [ finish | ].
     break; finish.

 (* Case TmPair *)
    apply all_Type_union_rev in fvs_dichot.
    destruct fvs_dichot as [fvs_left fvs_right].
    f_equal; eauto.
 (* Case TmProj *)
   f_equal; eauto.
 (* Case TmAbs *)
  simpl in *.
  rewrite map_map.
  replace (map (fun x => shift 0 1 (shift q k x)) env)
     with (map (fun x => shift (S q) k (shift 0 1 x)) env)
       by (apply map_ext ; intro M'; apply shift_shift_commute; solve [auto|omega]).
  rewrite IHM.
    rewrite -> map_map; solve [trivial].
   solve [omega].

  (* Obligation: that if {x-1 | x \in (S \\ {0})} is all outside [q, k+q),
     then {x | x \in S} is all outside [Sq, k+Sq). *)
  clear IHM.
  unfold all_Type in *.
  intros x H.
  destruct x.
   unfold Outside_Range.
   left; omega.
  specialize (fvs_dichot x).
  lapply fvs_dichot.
  unfold Outside_Range; firstorder omega.
  replace x with (pred (S x)) by omega.
  replace (fun x => x - 1) with pred by auto.
  apply set_map_intro.
  sauto.

 (* Case TmApp *)
 simpl in *.
 subst.
 apply all_Type_union_rev in fvs_dichot.
 destruct fvs_dichot.
 rewrite (IHM1 _ _ _ _) by (auto || omega).
 rewrite (IHM2 _ _ _ _) by (auto || omega).
 trivial.
Qed.

Import Setoid.

Lemma shift_var_0: forall n x, shift_var 0 n x = x + n.
Proof.
 unfold shift_var. intros. break; finish.
Qed.

(** After making a substitution, the freevars of the result is:
     - the freevars of the original term,
     - less the range of variables we replaced
     - union the freevars of all the substituted terms.
 *)
Lemma subst_Freevars:
  forall M env q,
    incl_sets _
      (freevars (subst_env q env M))
      (set_union eq_nat_dec
        (set_unions nat eq_nat_dec (map freevars env))
        (set_filter nat (fun x => outside_range q (length env + q) x) (freevars M))).
Proof.
 induction M; intros env q.
 (* Case TmConst *)
      simpl; auto.

 (* Case TmVar *)
     case_eq (outside_range q (length env + q) x); intro H.
     (* Case x is outside [q, k+q). *)
      rewrite subst_var_outside_range by trivial.
      simpl.
      rewrite H.
      apply incl_sets_union2.

     (* Case x is inside [q, k+q). *)
     destruct (subst_var_inside_range q env x H) as [M [H0 H1]].
     rewrite H1.
     apply incl_union_left.
     apply nth_error_set_unions with (n := x-q).
     rewrite nth_error_map.
     rewrite <- H0.
     sauto...

 (* Case TmPair *)
    simpl.
    rewrite IHM1 by auto.
    rewrite IHM2 by auto.
    rewrite set_filter_union.
    solve_set_union_inclusion. (* TODO: Make this opaque-ify anything that doesn't contain
                                        set_union *)

 (* Case TmProj *)
   simpl.
   apply IHM; auto.

 (* Case TmAbs *)
  simpl.
  rewrite IHM by auto.
  clear IHM.

  rewrite map_length.
  rewrite map_map.
  rewrite set_filter_map.
  rewrite union_remove.
  rewrite unions_remove.
  rewrite map_map.
  rewrite map_union.
  rewrite <- set_unions_map.
  rewrite map_map.

  (* Corresponding sides of the union are \subseteq *)

  apply incl_sets_union.
  (* Left side *)
   rewrite <- filter_remove.
   set (f := fun x : nat => outside_range (S q) (length env + S q) x).
   set (g := fun x : nat => outside_range q (length env + q) (x - 1)).
   setoid_rewrite filter_extensionality with (g:=g); [sauto|].
   intros.
   assert (x <> 0).
    apply set_remove_elim in H.
    intuition.
   unfold f, g.
   unfold outside_range.
   break; break; try (break; try break); auto; finish.
  (* Right side *)
  apply unions2_mor.
  apply compwise_eq_sets_map.
  intros x.
  setoid_replace (set_remove nat eq_nat_dec 0 (freevars (shift 0 1 x)))
            with (freevars (shift 0 1 x)).
   replace (fun x0 : nat => x0 - 1) with pred by auto.
    rewrite pred_freevars_shift; sauto.
  solve[apply remove_0_shift_0_1].

 (* Case TmApp *)
 simpl.
 rewrite IHM1 by auto.
 rewrite IHM2 by auto.
 setoid_rewrite set_filter_union.
 solve_set_union_inclusion.
Qed.

Require Import Listkit.listkit.

Lemma In_nth_error: forall A (x:A) xs, In x xs -> exists n, value x = nth_error xs n.
Proof.
 induction xs; simpl.
  intuition.
 intuition.
  exists 0.
  subst.
  auto.
 destruct H.
 exists (S x0).
 auto.
Qed.

Lemma subst_unused_noop:
  forall M env n,
    all nat (fun x => not (in_env_domain n env x)) (freevars M)
    -> subst_env n env M = M.
Proof.
 induction M; simpl; intros.
 (* Case TmConst *)
    auto.
 (* Case TmVar *)
   assert (~in_env_domain n env x).
    unfold all in H.
    apply H.
    unfold set_In.
    unfold In.
    auto.
   unfold in_env_domain in H0.
   break; auto.
   nth_error_dichotomize bounds is_error v v_def; finish.
 (* Case TmPair *)
    apply all_union in H.
    destruct H.
    f_equal; eauto.
 (* Case TmProj *)
   f_equal.
   auto.
 (* Case TmAbs *)
  rewrite IHM; [auto|].
  unfold all.
  unfold all in H.
  intros.
  cut (~in_env_domain (S n) env x).
   unfold in_env_domain.
   rewrite map_length.
   auto.
  destruct (eq_nat_dec x 0).
   unfold in_env_domain.
   omega.
  cut (~in_env_domain n env (x-1)).
   unfold in_env_domain.
   intros.
   omega.
  apply H.
  remember (fun x0 => x0-1) as pred.
  replace (x-1) with (pred x) by (subst;auto).
  apply set_map_intro.
  apply set_remove_intro.
  auto.
 (* Case TmApp *)
 rewrite all_union in H.
 rewrite IHM1, IHM2; tauto.
Qed.

Require Import Listkit.Map.

Lemma subst_factor :
  forall N m n env env',
    (* If *)
    (* 1. All freevars of all items in env are not in the domain of env', *)
    all _ (fun z =>
                all _ (fun x => not (in_env_domain m env' x)) (freevars z)) env ->
    (* 2. and the domain (m,env') does not contain n, and (n,env) does not contain m,
       i.e. they are nonoverlapping: *)
    (m+length env' <= n \/ n+length env <= m) ->
    (* Then *)
    (* We can "commute" the two substitutions, with a modification to one: *)
      subst_env m (map (subst_env n env) env') (subst_env n env N) =
      subst_env n env (subst_env m env' N).
(* TODO: reverse the orientation of that equation. *)
Proof.
 induction N; intros m n env env' H0 H1; simpl.
 (* Case TmConst *)
    trivial.
 (* Case TmVar *)
   (* Either we are in the range of [n x env] or we are in the range of
      [m x env'] or neither--since they don't overlap. *)
   set (P:= m <= x < m+length env').
   set (Q:= n <= x < n+length env).

   assert (H : not P /\ Q \/ P /\ not Q \/ not P /\ not Q).
    subst P Q.

    intuition.
     destruct (le_gt_dec x n);
       destruct (le_gt_dec x m);
       omega.
    destruct (le_gt_dec x n);
      destruct (le_gt_dec x m);
      omega.
   destruct H. (* ... as ... *)
    destruct H.
    subst P Q.
    assert (H3:x-n < length env) by omega.
    destruct (nth_error_exists _ env (x-n) H3)
      as [v v_def].
    set (v_fvs := freevars v).
    pose (v_fvs_notin_m_env' := nth_error_all _ _ _ _ _ v_def H0).
    clearbody v_fvs_notin_m_env'.
    assert (v_subst_env'_noop: forall f, subst_env m (map f env') v = v).
     intro f.
     apply subst_unused_noop.
     rewrite in_env_domain_map.
     auto.

    breakauto; breakauto.
     rewrite v_def.
     nth_error_dichotomize a' b' c' d'; try (omega).
     breakauto.
     rewrite v_def.
     simpl.
     auto.

    rewrite v_def; simpl.
    rewrite v_def; simpl.
    breakauto.
   destruct H; subst P Q.
    destruct H.

    assert (H3:x-m < length env') by omega.
    destruct (nth_error_exists _ env' (x-m) H3)
      as [v v_def].
    rewrite v_def; simpl.

    breakauto; breakauto.
     nth_error_dichotomize a b c d; try (omega).
     breakauto.

     rewrite nth_error_map.
     rewrite v_def.
     simpl.
     auto.
    simpl.
    rewrite nth_error_map.
    rewrite v_def.
    simpl.
    breakauto.

   destruct H.
   nth_error_dichotomize a b c d;
   nth_error_dichotomize a' b' c' d'.
      double_case.
      double_case.
      simpl.
      rewrite nth_error_map; rewrite b; rewrite b'; simpl.
      breakauto; breakauto.
     breakauto; breakauto.
      simpl.
      rewrite nth_error_map; rewrite b; rewrite d'; simpl.
      breakauto; breakauto.
     simpl.
     rewrite nth_error_map; rewrite b; rewrite d'; simpl.
     breakauto; breakauto.

   breakauto.
   breakauto; simpl.
     rewrite nth_error_map; rewrite b'; rewrite d; simpl.
     double_case.
    breakauto.
    rewrite nth_error_map; rewrite b'; rewrite d; simpl.
    breakauto; breakauto.
   breakauto.
   simpl.
   breakauto.
   simpl.
   rewrite d; simpl.
   breakauto.

 (* Case TmPair *)
    f_equal.
     apply IHN1; auto.
    apply IHN2; auto.

 (* Case TmProj *)
   f_equal.
   apply IHN; auto.

 (* Case TmAbs. *)
  f_equal.
  replace (S m) with (m + 1) by omega.
  replace (S n) with (n + 1) by omega.
  rewrite map_map.
  replace (fun x => shift 0 1 (subst_env n env x))
     with (fun x => subst_env (n+1) (map (shift 0 1) env) (shift 0 1 x)).
   replace (map (fun x : Term => subst_env (n+1) (map (shift 0 1) env) (shift 0 1 x)) env')
      with (map (subst_env (n+1) (map (shift 0 1) env)) (map (shift 0 1) env')).
    apply IHN.

     (* Preservation of the free-variable relationship. *)
     unfold (*all_terms,*) all in H0 |- *.
     intros Z Z_source x x_free_in_Z.
     destruct (map_image _ _ (shift 0 1) Z env Z_source) as [X' [X_X'_eq X'_in_env]].
     pose (n0 := H0 (unshift 0 1 Z)).
     subst Z.
     rewrite unshift_shift in n0.
     unfold in_env_domain in *.
     rewrite map_length.
     pose (n1 := n0 X'_in_env (unshift_var 0 1 x)).
     lapply n1.
      unfold unshift_var.
      break; omega.
     assert (x_free_in_Z': set_In x (set_map eq_nat_dec (shift_var 0 1) (freevars X'))).
      pose (H2 := freevars_shift_1 X' 0 1).
      unfold eq_sets, incl_sets in H2.
      solve [intuition].
(*
(* Could use instead this nice lemma about inverse functions and set_In: *)
(forall x, g (f x) = x) ->
 set_In x (map f xs) ->
 set_In (g x) xs.  *)

     apply set_map_image in x_free_in_Z'.
     destruct x_free_in_Z' as [x' [x'_def x'_in_X'_fvs]].
     subst x.

     rewrite unshift_var_shift_var.
     solve [trivial]...

    solve[map_omega].
   rewrite map_map; solve [trivial]...
  extensionality Z.
  rewrite shift_subst_commute_lo; [auto|].
  solve [omega]...
 (* Case TmApp. *)
 rewrite IHN1; auto.
 rewrite IHN2; auto.
Qed.

(* Some notations might be nice, but I'm not sure I've got the right ones yet.

(*
Notation "N { M / x }" := (subst_env x (M :: nil) N) (at level 900). *)
Notation "{ x / env } N" := (subst_env x env N) (at level 100).
Notation "{ x :/ M } N" := (subst_env x (M :: nil) N) (at level 100).

Notation "^^ M" := (shift 0 1 M) (at level 98).
Notation ",, M" := (unshift 0 1 M) (at level 98).
*)


(* 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                                                     *)

(** %\subsection*{ support :  distribution\_lemmas.v }%*)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export mult_by_scalars.
Require Export const.
Require Export sums.

(** - $r\sum_i a_i = \sum_i ra_i$ (in rings),
 - $r\sum_i v_i = \sum_i rv_i$ (in modules) and
 - $\sum_i r_i(r'_iv_i) = \sum_i (r_ir'_i)v_i$ *)

Lemma RING_sum_mult_dist_l :
 forall (R : ring) (n : Nat) (r : R) (a : seq n R),
 r rX sum a =' sum (pointwise (uncurry (RING_comp (R:=R))) (const_seq n r) a)
 in _.
simple induction n.
simpl in |- *.
auto with algebra.
intros.
apply Trans with (r rX sum (hdtl a)); auto with algebra; unfold hdtl in |- *.
apply Trans with (r rX (head a +' sum (Seqtl a))); auto with algebra.
apply Trans with (r rX head a +' r rX sum (Seqtl a)); auto with algebra.
apply
 Trans
  with
    (r rX head a +'
     sum
       (pointwise (uncurry (RING_comp (R:=R))) (Seqtl (const_seq (S n0) r))
          (Seqtl a))).
apply SGROUP_comp; auto with algebra.
apply
 Trans
  with
    (sum (pointwise (uncurry (RING_comp (R:=R))) (const_seq n0 r) (Seqtl a)));
 auto with algebra.
apply sum_comp.
apply toMap.
apply pointwise_comp; auto with algebra.
apply Sym.
change (Seqtl (const_seq (S n0) r) =' const_seq (pred (S n0)) r in _) in |- *.
apply Seqtl_const_seq.
apply Sym.
apply
 Trans
  with
    (sum
       (hdtl (pointwise (uncurry (RING_comp (R:=R))) (const_seq (S n0) r) a)));
 auto with algebra.
unfold hdtl in |- *.
apply
 Trans
  with
    (head (pointwise (uncurry (RING_comp (R:=R))) (const_seq (S n0) r) a) +'
     sum
       (pointwise (uncurry (RING_comp (R:=R))) (Seqtl (const_seq (S n0) r))
          (Seqtl a))); auto with algebra.
apply
 Trans
  with
    (head (pointwise (uncurry (RING_comp (R:=R))) (const_seq (S n0) r) a) +'
     sum
       (Seqtl (pointwise (uncurry (RING_comp (R:=R))) (const_seq (S n0) r) a)));
 auto with algebra.
Qed.

Lemma MODULE_sum_mult_dist_l :
 forall (R : ring) (M : module R) (n : Nat) (r : R) (a : seq n M),
 r mX sum a =' sum (mult_by_scalars (const_seq n r) a) in _.
simple induction n.
simpl in |- *.
auto with algebra.
intros.
apply Trans with (r mX sum (hdtl a)); auto with algebra; unfold hdtl in |- *.
apply Trans with (r mX (head a +' sum (Seqtl a))); auto with algebra.
apply Trans with (r mX head a +' r mX sum (Seqtl a)); auto with algebra.
apply
 Trans
  with
    (r mX head a +'
     sum (mult_by_scalars (Seqtl (const_seq (S n0) r)) (Seqtl a))).
apply SGROUP_comp; auto with algebra.
apply Trans with (sum (mult_by_scalars (const_seq n0 r) (Seqtl a)));
 auto with algebra.
apply sum_comp.
apply toMap.
apply mult_by_scalars_comp; auto with algebra.
apply Sym.
change (Seqtl (const_seq (S n0) r) =' const_seq (pred (S n0)) r in _) in |- *.
apply Seqtl_const_seq.
apply Trans with (sum (hdtl (mult_by_scalars (const_seq (S n0) r) a)));
 auto with algebra.
unfold hdtl in |- *.
apply
 Trans
  with
    (head (mult_by_scalars (const_seq (S n0) r) a) +'
     sum (mult_by_scalars (Seqtl (const_seq (S n0) r)) (Seqtl a)));
 auto with algebra.
apply
 Trans
  with
    (head (mult_by_scalars (const_seq (S n0) r) a) +'
     sum (Seqtl (mult_by_scalars (const_seq (S n0) r) a)));
 auto with algebra.
Qed.

Hint Resolve RING_sum_mult_dist_l MODULE_sum_mult_dist_l: algebra.

Lemma pointwise_module_assoc :
 forall (R : ring) (M : module R) (n : Nat) (r r' : seq n R) (m : seq n M),
 let rmult := uncurry (RING_comp (R:=R)) in
 mult_by_scalars r (mult_by_scalars r' m) ='
 mult_by_scalars (pointwise rmult r r') m in _.
intros.
intro i; simpl in |- *.
auto with algebra.
Qed.

Hint Resolve pointwise_module_assoc: algebra.


From Coq Require List.

From Tactical Require Import Misc.

Require Import SepLogic.Reification.Varmap.
Require Import SepLogic.Reification.Sorting.
Require Import SepLogic.Mem.
Require Export SepLogic.Pred.

Import PredNotations.
Local Open Scope pred.

Set Implicit Arguments.

(*! Setting up reified syntax *)
Global Instance pred_def A V : Default (pred A V) := @emp A V.

Section Mem.
  Context (A V:Type).
  Notation pred := (pred A V).
  Notation emp := (@emp A V).

  (* non-recursive part of reification *)
  Inductive op_element :=
  | Leaf (x:pred)
  | Atom (i:varmap.I)
  | LiftedProp (P:Prop)
  | ConstEmp
  .

  Definition interpret_e (vm: varmap.t pred) (e: op_element) : pred :=
    match e with
    | Leaf x => x
    | Atom i => varmap.find i vm
    | LiftedProp P => lift P
    | ConstEmp => emp
    end.

  Inductive op_tree :=
  | Element (e: op_element)
  | StarNode (l r: op_tree)
  .

  Fixpoint interpret (vm: varmap.t pred) t : pred :=
    match t with
    | Element e => interpret_e vm e
    | StarNode l r => star (interpret vm l) (interpret vm r)
    end.
End Mem.

(*! Boilerplate for doing reification *)
Local Ltac reify_helper A V term ctx :=
  let reify_rec term ctx := reify_helper A V term ctx in
  lazymatch ctx with
  | context[varmap.cons ?i term _] =>
    constr:( (ctx, Element (Atom A V i)) )
  | _ =>
    lazymatch term with
    | @emp _ _ => constr:( (ctx, Element (ConstEmp A V)) )
    | lift ?P => constr:( (ctx, Element (LiftedProp A V P)) )
    | star ?x ?y =>
      let ctx_x := reify_rec x ctx in
      let ctx_y := reify_rec y (fst ctx_x) in
      let r := (eval cbv [fst snd] in
                   (fst ctx_y, @StarNode A V (snd ctx_x) (snd ctx_y))) in
      constr:(r)
    | _ =>
      let v' := (eval cbv [varmap.length] in (varmap.length ctx)) in
      let ctx' := constr:( varmap.cons v' term ctx ) in
      constr:( (ctx', Element (Atom A V v')) )
    end
  end.

Local Ltac with_reified A V ctx x rx :=
  let ctx_t := reify_helper A V x ctx in
  let ctx := (eval cbv [fst] in (fst ctx_t)) in
  let t := (eval cbv [snd] in (snd ctx_t)) in
  rx ctx t.

Local Ltac init_reify A V x rx :=
  with_reified A V (varmap.empty (pred A V)) x rx.

Ltac quote_impl :=
  match goal with
  | |- @pimpl ?A ?V ?x ?y =>
    let init := init_reify A V in
    let then_do := with_reified A V in
    init x
         ltac:(
      fun ctx xt =>
        then_do ctx y
                ltac:(
          fun ctx' yt =>
            change (interpret ctx' xt ===> interpret ctx' yt)))
  end.

Ltac quote_eqn :=
  match goal with
  | |- @piff ?A ?V ?x ?y =>
    let init := init_reify A V in
    let then_do := with_reified A V in
    init x
         ltac:(
      fun ctx xt =>
        then_do ctx y
                ltac:(
          fun ctx' yt =>
            change (interpret ctx' xt === interpret ctx' yt)))
  end.

Ltac quote_impl_hyp H :=
  match type of H with
  | ?lhs ===> ?rhs =>
    match goal with
    | |- @pimpl ?A ?V ?x ?y =>
      let init := init_reify A V in
      let then_do := with_reified A V in
      init lhs ltac:(
        fun ctx _ =>
          then_do ctx rhs ltac:(
            fun ctx _ =>
              then_do ctx x ltac:(
                fun ctx xt =>
                  then_do ctx y ltac:(
                    fun ctx' yt =>
                      change (interpret ctx' xt ===> interpret ctx' yt)))))
    end
  end.

Ltac quote_eqn_hyp H :=
  match type of H with
  | ?lhs === ?rhs =>
    match goal with
    | |- @pimpl ?A ?V ?x ?y =>
      let init := init_reify A V in
      let then_do := with_reified A V in
      init lhs ltac:(
        fun ctx _ =>
          then_do ctx rhs ltac:(
            fun ctx _ =>
              then_do ctx x ltac:(
                fun ctx xt =>
                  then_do ctx y ltac:(
                    fun ctx' yt =>
                      change (interpret ctx' xt === interpret ctx' yt)))))
    end
  end.

Ltac quote_app_hyp H :=
  match type of H with
  | @predApply ?A ?V ?x ?m =>
    let init := init_reify A V in
    init x ltac:(
      fun ctx xt =>
        change x with (interpret ctx xt) in H
    )
  end.

Theorem reify_test A V (p1 p2 p3: pred A V) :
  p1 * p2 * p3 ===> p1 * (p2 * p3).
Proof.
  quote_impl.
Abort.

Theorem reify_with_hyp_test A V (p1 p2 p3: pred A V) :
  p3 * p2 ===> p2 ->
  p1 * p2 * p3 ===> p1 * (p2 * p3).
Proof.
  intros.
  quote_impl_hyp H.
Abort.

Theorem reify_app_test A V (p1: pred A V) m
        (H: p1 m) : True.
Proof.
  quote_app_hyp H.
Abort.

(*! Proving theorems on reified syntax *)
Module Norm.
  Section Mem.
    Context (A V:Type).
    Notation pred := (pred A V).
    Notation emp := (@emp A V).

    Notation op_tree := (op_tree A V).
    Notation op_element := (op_element A V).

    Import List.ListNotations.

    Lemma equiv_refl : forall (p:pred), p === p.
    Proof. reflexivity. Qed.
    Hint Resolve equiv_refl : core.

    Fixpoint flatten (t:op_tree) : list op_element :=
      match t with
      | Element e => match e with
                    | ConstEmp _ _ => []
                    | _ => [e]
                    end
      | StarNode l r => flatten l ++ flatten r
      end.

    Fixpoint int_l vm (l: list op_element) : pred :=
      match l with
      | [] => emp
      | e::es => star (interpret_e vm e) (int_l vm es)
      end.

    Fixpoint int_l' vm (acc:pred) (l: list op_element) : pred :=
      match l with
      | [] => acc
      | e::es => int_l' vm (acc * interpret_e vm e) es
      end.

    Definition interpret_l vm (l: list op_element) : pred :=
      match l with
      | [] => emp
      | e::es => int_l' vm (interpret_e vm e) es
      end.

    Theorem int_l'_to_int_l vm l acc :
      int_l' vm acc l === acc * int_l vm l.
    Proof.
      gen acc.
      induction l; intros; simpl.
      - rewrite star_emp_r; auto.
      - rewrite IHl.
        rewrite star_assoc; auto.
    Qed.

    Theorem interpret_l_to_int_l vm l :
      interpret_l vm l === int_l vm l.
    Proof.
      destruct l; simpl; auto.
      rewrite int_l'_to_int_l; auto.
    Qed.

    (* use a simple recursive definition using the above proof *)
    Ltac simplify :=
      rewrite ?interpret_l_to_int_l.

    Theorem int_l_app vm l1 l2 :
      int_l vm (l1 ++ l2) === int_l vm l1 * int_l vm l2.
    Proof.
      induction l1; simpl.
      rewrite star_emp_l; auto.
      rewrite <- star_assoc.
      rewrite IHl1; auto.
    Qed.

    Theorem interpret_flatten vm t :
      interpret vm t === interpret_l vm (flatten t).
    Proof.
      simplify.
      induction t; simpl.
      destruct e; simpl;
        try rewrite star_emp_r; auto.
      rewrite int_l_app.
      rewrite IHt1, IHt2; auto.
    Qed.

    Theorem int_l_perm vm l1 l2:
      Permutation l1 l2 ->
      int_l vm l1 === int_l vm l2.
    Proof.
      induction 1; simpl; auto.
      - rewrite IHPermutation; auto.
      - rewrite ?star_assoc.
        apply star_respects_iff; auto.
        rewrite star_comm; auto.
      - rewrite IHPermutation1, IHPermutation2; auto.
    Qed.

    Definition get_key (e:op_element) : option nat :=
      match e with
      | Atom _ _ i => Some (S i)
      | LiftedProp _ _ _ => Some 0
      | _ => None
      end.

    Theorem interpret_l_sort vm l :
      interpret_l vm l === interpret_l vm (sortBy get_key l).
    Proof.
      simplify.
      apply int_l_perm.
      apply sortBy_permutation.
    Qed.

    Theorem interpret_l_sort_impl vm l1 l2 :
      interpret_l vm (sortBy get_key l1) ===> interpret_l vm (sortBy get_key l2) ->
      interpret_l vm l1 ===> interpret_l vm l2.
    Proof.
      rewrite <- ?interpret_l_sort; auto.
    Qed.

    Theorem interpret_l_sort_iff vm l1 l2 :
      interpret_l vm (sortBy get_key l1) === interpret_l vm (sortBy get_key l2) ->
      interpret_l vm l1 === interpret_l vm l2.
    Proof.
      rewrite <- ?interpret_l_sort; auto.
    Qed.

    Local Fixpoint flatten_props (l: list Prop) : Prop :=
      match l with
      | [] => True
      | P::Ps => P /\ flatten_props Ps
      end.

    Fixpoint flatten_props1 (l: list Prop) : Prop :=
      match l with
      | [] => True
      | [P]%list => P
      | P::Ps => P /\ flatten_props1 Ps
      end.

    Theorem flatten_props1_ok l :
      flatten_props l <-> flatten_props1 l.
    Proof.
      destruct l.
      - firstorder.
      - induction l; simpl.
        firstorder.
        destruct l; firstorder.
    Qed.

    Fixpoint grab_props (l:list op_element) : list Prop * list op_element :=
      match l with
      | [] => ([], [])
      | e::es => let (acc, es') := grab_props es in
                match e with
                | LiftedProp _ _ P =>
                  (P::acc, es')
                | _ => (acc, e::es')
                end
      end.

    Definition int_props vm (x: list Prop * list op_element) : pred :=
      let '(P, es) := x in
      lift (flatten_props1 P) * interpret_l vm es.

    Local Definition int_props' vm (x: list Prop * list op_element) : pred :=
      let '(P, es) := x in
      lift (flatten_props P) * int_l vm es.

    Local Theorem int_props'_ok vm x :
      int_props vm x === int_props' vm x.
    Proof.
      unfold int_props, int_props'.
      destruct x.
      simplify.
      rewrite flatten_props1_ok.
      auto.
    Qed.

    Local Lemma abc_to_bac (p1 p2 p3:pred) :
      p1 * p2 * p3 === p2 * p1 * p3.
    Proof.
      apply star_respects_iff; auto.
      apply star_comm.
    Qed.

    Theorem interpret_grab_props vm l :
      interpret_l vm l === int_props vm (grab_props l).
    Proof.
      simplify.
      rewrite int_props'_ok.
      induction l; simpl.
      rewrite star_emp_r.
      apply emp_to_lift; auto.
      destruct_with_eqn (grab_props l).
      rewrite IHl.
      destruct a; simpl in *;
        rewrite ?star_assoc;
        try solve [ apply abc_to_bac] .
      rewrite lift_star; auto.
    Qed.

    Local Lemma impl_with_lifts (P Q:Prop) (p q: pred) :
      (P -> p ===> q /\ Q) ->
      lift P * p ===> lift Q * q.
    Proof.
      intros.
      apply impl_with_lift; intuition idtac.
      rewrite H.
      rewrite <- emp_to_lift; auto.
      rewrite star_emp_l; reflexivity.
    Qed.

    Local Lemma iff_with_lifts (P Q:Prop) (p q: pred) :
      (P -> p ===> q /\ Q) ->
      lift P * p ===> lift Q * q.
    Proof.
      intros.
      apply impl_with_lift; intuition idtac.
      rewrite H.
      rewrite <- emp_to_lift; auto.
      rewrite star_emp_l; reflexivity.
    Qed.

    Theorem grab_props_impl vm l1 l2 :
      (let (P, p) := grab_props l1 in
       let (Q, q) := grab_props l2 in
       flatten_props1 P ->
       interpret_l vm p ===> interpret_l vm q /\ flatten_props1 Q) ->
      interpret_l vm l1 ===> interpret_l vm l2.
    Proof.
      intros.
      rewrite ?interpret_grab_props.
      destruct (grab_props l1) as [P p].
      destruct (grab_props l2) as [Q q].
      simpl.
      apply impl_with_lifts; eauto.
    Qed.

    Theorem grab_props_iff vm l1 l2 :
      (let (P, p) := grab_props l1 in
       let (Q, q) := grab_props l2 in
       match P, Q with
       | nil, nil =>
         interpret_l vm p === interpret_l vm q
       | _, _ => False
       end) ->
      interpret_l vm l1 === interpret_l vm l2.
    Proof.
      intros.
      rewrite ?interpret_grab_props.
      destruct (grab_props l1) as [P p].
      destruct (grab_props l2) as [Q q].
      simpl.
      destruct P, Q; intros; try contradiction.
      simpl.
      rewrite H; auto.
    Qed.

    Theorem empty_props_optimization Ps Q :
      match Ps with
      | nil => Q
      | _ => flatten_props1 Ps /\ Q
      end <-> flatten_props1 Ps /\ Q.
    Proof.
      destruct Ps; simpl; firstorder.
    Qed.

    Theorem grab_props_apply vm l m :
      predApply (int_props vm (grab_props l)) m ->
      let (P, p) := grab_props l in
      let remaining_pred := predApply (interpret_l vm p) m in
      match P with
      | nil => remaining_pred
      | _ => flatten_props1 P /\ remaining_pred
      end.
    Proof.
      intros.
      destruct (grab_props l) as [P p].
      cbn [int_props] in H.
      cbv zeta.
      apply empty_props_optimization.
      apply lift_applied in H; auto.
    Qed.

  End Mem.
End Norm.

Ltac norm_reified :=
  rewrite ?Norm.interpret_flatten;
  apply Norm.interpret_l_sort_impl;
  apply Norm.grab_props_impl.

Ltac norm_reified_iff :=
  rewrite ?Norm.interpret_flatten;
  apply Norm.interpret_l_sort_iff;
  apply Norm.grab_props_iff.

(* for a predApply hypothesis with reified predicate *)
Ltac norm_reified_hyp H :=
  rewrite Norm.interpret_flatten in H;
  rewrite Norm.interpret_l_sort in H;
  rewrite Norm.interpret_grab_props in H;
  apply Norm.grab_props_apply in H.

Local Ltac destruct_ands_in H :=
  try match type of H with
      | _ /\ _ => let H' := fresh in
                destruct H as [H H'];
                destruct_ands_in H'
      end.

Ltac cleanup_normed_app H :=
  cbn [Norm.int_props
         Norm.flatten Norm.flatten_props1 Norm.interpret_l
         Norm.int_l' interpret_e Varmap.varmap.find
         PeanoNat.Nat.eqb
         app Sorting.sortBy Sorting.sort Sorting.insert_sort Sorting.insert
         Norm.get_key PeanoNat.Nat.leb
         Norm.grab_props] in H;
  try match type of H with
      | _ /\ _ =>
        let H' := fresh in
        destruct H as [H' H];
        destruct_ands_in H'
      end.

Ltac cleanup_normed_goal :=
  match goal with
  | |- True -> _ => intros _
  | _ => intros
  end;
  try match goal with
      | |- _ /\ True => split; [ | exact I ]
      end;
  repeat match goal with
         | [ H: _ /\ _ |- _ ] => destruct H
         end.

Ltac norm :=
  intros;
  match goal with
  | |- _ ===> _ =>
    quote_impl; norm_reified
  | |- _ === _ =>
    quote_eqn; norm_reified_iff
  end; simpl;
  cleanup_normed_goal.

Ltac norm_with H :=
  intros;
  quote_impl_hyp H;
  norm_reified; simpl;
  cleanup_normed_goal.

Ltac norm_hyp H :=
  quote_app_hyp H;
  norm_reified_hyp H;
  cleanup_normed_app H.

Ltac normed_cancellation :=
  try match goal with
      | |- _ /\ _ => split
      end;
  try match goal with
      | |- ?p ===> ?p => reflexivity
      | |- ?p === ?p => reflexivity
      | [ H: ?P |- ?P ] => exact H
      end.

Ltac cancel :=
  norm; normed_cancellation.

Module Demo.
  Ltac norm :=
    intros;
    quote_impl;
    norm_reified.

  Ltac simpl_flatten :=
    cbn [Norm.flatten app].

  Ltac simpl_sorting :=
    cbn [Sorting.sortBy Sorting.sort Sorting.insert_sort Sorting.insert
                        Norm.get_key PeanoNat.Nat.leb].

  Ltac simpl_grab_props :=
    cbn [Norm.grab_props].
End Demo.


(* 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 nat_trans.

Ltac lw := autorewrite with lw; try tv; try am.
Ltac lr := autorewrite with lw.

Module Limit.
Export Nat_Trans.

Definition Vertex := R (v_ (r_ (x_ DOT))).

Definition Edge := R (e_ (d_ (g_ DOT))).

Definition cone_create v e :=
denote Vertex v (
denote Edge e stop).

Definition vertex c := V Vertex c.
Definition edge_nt c := V Edge c.
Definition edge c x := ntrans (edge_nt c) x.
Definition socle c := target (edge_nt c).
Definition cone_source c := source (socle c).
Definition cone_target c := target (socle c).

Definition cone_like c := cone_create (vertex c) (edge_nt c) = c.

Lemma vertex_cone_create : forall v e, vertex (cone_create v e) = v.
Proof.
ir.
uf cone_create. uf vertex. drw.
Qed.

Lemma edge_nt_cone_create : forall v e, edge_nt (cone_create v e) = e.
Proof.
ir. uf cone_create. uf edge_nt. drw.
Qed.

Lemma cone_like_cone_create : forall v e,
cone_like (cone_create v e).
Proof. ir. uf cone_like.
rw vertex_cone_create. rww edge_nt_cone_create.
Qed.

Definition is_cone c :=
cone_like c &
Nat_Trans.axioms (edge_nt c) &
ob (cone_target c) (vertex c) &
source (edge_nt c) =
constant_functor (cone_source c) (cone_target c) (vertex c).

Lemma cone_extensionality : forall c d,
is_cone c -> is_cone d -> vertex c = vertex d ->
socle c = socle d ->
(forall x, ob (cone_source c) x -> edge c x = edge d x) ->
c = d.
Proof.
ir.
assert (cone_source c = cone_source d).
uf cone_source. rww H2.
assert (cone_target c = cone_target d).
uf cone_target; rww H2.
uh H; uh H0; ee. uh H; uh H0. wr H; wr H0.
rw H1. ap uneq.
app Nat_Trans.axioms_extensionality.
rw H11. rw H8.
rw H4; rw H5; rw H1. reflexivity.
ir. util (H3 x). uf cone_source. uf socle.
rw Nat_Trans.source_target. am. am. am.
Qed.

Definition cone_create2 f v e :=
cone_create v (Nat_Trans.create
(constant_functor (source f) (target f) v) f e).

Lemma is_cone_cone_create2 : forall f v e,
Functor.axioms f->
ob (target f) v->
(forall x, ob (source f) x -> mor (target f) (e x)) ->
(forall x, ob (source f) x -> source (e x) = v) ->
(forall x, ob (source f) x -> target (e x) = (fob f x)) ->
(forall u, mor (source f) u ->
comp (target f) (fmor f u) (e (source u)) = e (target u)) ->
is_cone (cone_create2 f v e).
Proof.
ir. uf cone_create2.
uhg; ee. ap cone_like_cone_create.
rw edge_nt_cone_create.
app Nat_Trans.create_axioms. uhg; ee.
app constant_functor_axioms. uh H; ee; am. uh H; ee; am. am.
rww source_constant_functor.
rww target_constant_functor.
ir. rwi source_constant_functor H5. au.
ir. rwi source_constant_functor H5.
rw fob_constant_functor. au. am. am.
ir. rwi source_constant_functor H5. au.
ir. rwi source_constant_functor H5.
rww fmor_constant_functor.
rww H4.
rww right_id. ap H1. rww  ob_target.
rw H2. tv. rww ob_target.
rw vertex_cone_create.
uf cone_target. uf socle.
rw edge_nt_cone_create.
rw target_create. am.
rw edge_nt_cone_create. rw source_create.
rw vertex_cone_create. uf cone_source;
uf cone_target; uf socle; rw edge_nt_cone_create.
rw target_create. tv.
Qed.

Lemma otarget_edge_nt : forall c,
otarget (edge_nt c) = cone_target c.
Proof.
ir. tv.
Qed.

Lemma osource_edge_nt : forall c,
is_cone c ->
osource (edge_nt c) = cone_source c.
Proof.
ir. uf cone_source. uf socle.
rw Nat_Trans.source_target. tv. lu.
Qed.

Definition cone_composable c u :=
is_cone c &
mor (cone_target c) u &
target u = vertex c.

Lemma cone_composable_rw : forall c u,
is_cone c -> mor (cone_target c) u -> target u = vertex c ->
cone_composable c u = True.
Proof.
ir. uf cone_composable.
app iff_eq; ir; try tv. xd.
Qed.

Definition cone_compose c u :=
cone_create (source u) (vcompose (edge_nt c)
(constant_nt (cone_source c) (cone_target c) u)).

Lemma vertex_cone_compose : forall c u ,
vertex (cone_compose c u) = source u.
Proof.
ir. uf cone_compose. rw vertex_cone_create. tv.
Qed.

Lemma edge_nt_cone_compose : forall c u,
edge_nt (cone_compose c u) = (vcompose (edge_nt c)
(constant_nt (cone_source c) (cone_target c) u)).
Proof. ir.
uf cone_compose. rw edge_nt_cone_create. tv.
Qed.

Lemma edge_cone_compose : forall c u x,
ob (cone_source c) x -> cone_composable c u ->
edge (cone_compose c u) x = comp (cone_target c) (edge c x) u.
Proof.
ir.
uf edge. rw edge_nt_cone_compose.
rw ntrans_vcompose.
rw otarget_edge_nt. ap uneq.
rw ntrans_constant_nt. tv. am.
rw osource_constant_nt. am.
Qed.

Lemma socle_cone_compose : forall c u,
socle (cone_compose c u) = socle c.
Proof.
ir. uf socle. rw edge_nt_cone_compose.
rw target_vcompose. tv.
Qed.

Lemma cone_target_cone_compose : forall c u,
cone_target (cone_compose c u) =
cone_target c.
Proof.
ir. uf cone_target. rw socle_cone_compose. tv.
Qed.

Lemma cone_source_cone_compose : forall c u,
cone_source (cone_compose c u) =
cone_source c.
Proof.
ir. uf cone_source. rw socle_cone_compose. tv.
Qed.

Lemma mor_edge : forall c x,
ob (cone_source c) x -> is_cone c ->
mor (cone_target c) (edge c x).
Proof.
ir. uf edge. ap mor_ntrans.
lu. rww osource_edge_nt. rww otarget_edge_nt.
Qed.

Lemma source_edge_nt : forall c,
is_cone c -> source (edge_nt c) =
constant_functor (cone_source c) (cone_target c) (vertex c).
Proof.
ir. uh H; ee. rw H2. tv.
Qed.

Lemma ob_vertex : forall c,
is_cone c -> ob (cone_target c) (vertex c).
Proof.
ir. uh H; ee. am.
Qed.

Lemma source_edge : forall c x,
ob (cone_source c) x -> is_cone c ->
source (edge c x) = vertex c.
Proof.
ir. uf edge. rw source_ntrans.
rw source_edge_nt.
rw fob_constant_functor. tv. am.
ap ob_vertex. am. am. lu.
rww osource_edge_nt.
Qed.

Lemma target_edge_nt : forall c,
target (edge_nt c) = socle c.
Proof.
ir. tv.
Qed.

Lemma target_edge : forall c x,
ob (cone_source c) x -> is_cone c ->
target (edge c x) = fob (socle c) x.
Proof.
ir. uf edge.
rw target_ntrans. tv. uh H0; ee. am.
ufi cone_source H. ufi socle H.
rwi source_target H. am.
uh H0; ee; am.
Qed.

Lemma commutativity : forall c u,
mor (cone_source c) u -> is_cone c ->
comp (cone_target c) (fmor (socle c) u) (edge c (source u)) =
edge c (target u).
Proof.
ir.
uh H0; ee. uf edge.
assert (cone_target c = otarget (edge_nt c)).
rww otarget_edge_nt.
assert (socle c = target (edge_nt c)).
rww target_edge_nt.
assert (lem1: forall y, ntrans (edge_nt c) y = edge c y).
ir. tv.
rw H4; rw H5.
wr carre.
rw source_edge_nt.
rw fmor_constant_functor. rw right_id. tv.
wr H4; am. wr H4. change (mor (cone_target c) (edge c (target u))).
app mor_edge. rww ob_target. uhg; ee; am.
rw lem1. rww source_edge. rww ob_target.
uhg; ee; am. rww otarget_edge_nt. am.
uhg; ee; am. am. rww osource_edge_nt. uhg; ee; am.
Qed.

Lemma cone_source_axioms : forall c, is_cone c ->
Category.axioms (cone_source c).
Proof.
ir. cp H. uh H; ee. uh H1; ee.
rwi osource_edge_nt H4. exact H4. am.
Qed.

Lemma cone_target_axioms : forall c, is_cone c ->
Category.axioms (cone_target c).
Proof.
ir. cp H. uh H; ee. uh H1; ee.
rwi otarget_edge_nt H5. exact H5.
Qed.

Lemma socle_axioms : forall c, is_cone c ->
Functor.axioms (socle c).
Proof.
ir. uh H; ee. uh H0; ee.
exact H6.
Qed.

Hint Rewrite vertex_cone_compose edge_nt_cone_compose
cone_composable_rw edge_cone_compose
socle_cone_compose
cone_target_cone_compose
cone_source_cone_compose
: lw.

Lemma is_cone_cone_compose : forall c u,
cone_composable c u ->
is_cone (cone_compose c u) = True.
Proof.
ir. ap iff_eq; ir; try tv.
uhg; ee. uf cone_like. uf cone_compose.
rw vertex_cone_create. rw edge_nt_cone_create. tv.
rw edge_nt_cone_compose.
rww vcompose_axioms. lu.
ap constant_nt_axioms.
ap cone_source_axioms. lu.
ap cone_target_axioms. lu. lu.
rw target_constant_nt. uh H; ee.
uh H; ee. rw H2; am.
rw cone_target_cone_compose. rw vertex_cone_compose.
uh H; ee. rww ob_source.
rw edge_nt_cone_compose.
rw source_vcompose. rw source_constant_nt.
rw cone_source_cone_compose. rw cone_target_cone_compose.
rw vertex_cone_compose. tv.
Qed.

Lemma cone_compose_cone_compose : forall a u v,
cone_composable a u -> composable (cone_target a) u v ->
cone_compose (cone_compose a u) v =
cone_compose a (comp (cone_target a) u v).
Proof.
ir.
rwi composable_facts_rw H0.
apply cone_extensionality.
rww is_cone_cone_compose. uf cone_composable; ee.
rww is_cone_cone_compose. rw cone_target_cone_compose.
lu.
rw vertex_cone_compose. sy; lu.
rww is_cone_cone_compose. uhg; ee. lu.
rww mor_comp. lu. lu. lu.
rw target_comp. lu. lu. lu. lu.
rw vertex_cone_compose. rw vertex_cone_compose.
rw source_comp. tv. lu. lu. lu.
rw socle_cone_compose. rw socle_cone_compose.
rw socle_cone_compose. tv.
ir. rw edge_cone_compose. rw cone_target_cone_compose.
rw edge_cone_compose. rw edge_cone_compose.
rw assoc. tv.
ap mor_edge. rwi cone_source_cone_compose H1.
rwi cone_source_cone_compose H1. am. lu.
uh H; ee. am. uh H0; ee; am.
rw source_edge. sy; lu.
rwi cone_source_cone_compose H1.
rwi cone_source_cone_compose H1.
am. lu. lu. tv.
rwi cone_source_cone_compose H1.
rwi cone_source_cone_compose H1.
am.
uhg; ee. lu. rww mor_comp.
uh H0; ee; am. uh H0; ee; am.  lu. rw target_comp.
lu. uh H0; ee; am. uh H0; ee; am.  lu.
rwi cone_source_cone_compose H1.
rwi cone_source_cone_compose H1.
am. am. rw cone_source_cone_compose.
rwi cone_source_cone_compose H1.
rwi cone_source_cone_compose H1. am.
uhg; ee. rww is_cone_cone_compose.
rw cone_target_cone_compose. uh H0; ee; am.
rw vertex_cone_compose. sy; lu.
Qed.

Definition is_uni a :=
is_cone a &
(forall u v, cone_composable a u -> cone_composable a v ->
cone_compose a u = cone_compose a v -> u = v).

Definition is_versal a :=
is_cone a &
(forall b, is_cone b -> socle b = socle a ->
(exists u, (cone_composable a u & cone_compose a u = b))).

Definition is_limit a :=
is_uni a & is_versal a.

Lemma is_limit_is_versal : forall a,
is_limit a -> is_versal a.
Proof. ir. lu. Qed.

Lemma is_limit_is_uni : forall a,
is_limit a -> is_uni a.
Proof. ir. lu. Qed.

Lemma is_limit_is_cone : forall a,
is_limit a -> is_cone a.
Proof.
ir. lu.
Qed.

Definition is_limit_of f a :=
is_limit a & socle a = f.

Definition has_limit f :=
exists a, is_limit_of f a.

Definition has_limits_over c b :=
(forall f,
Functor.axioms f -> source f = c -> target f = b ->
has_limit f).

Definition limit f :=
choose (is_limit_of f).

Lemma if_has_limit : forall f,
has_limit f -> is_limit_of f (limit f).
Proof.
ir. uh H.
exact (choose_pr H).
Qed.

Lemma is_limit_limit : forall f,
has_limit f -> is_limit (limit f).
Proof.
ir. cp (if_has_limit H). lu.
Qed.

Lemma socle_limit : forall f,
has_limit f -> socle (limit f) = f.
Proof.
ir. cp (if_has_limit H). lu.
Qed.

Definition cone_to_limit a b :=
choose (fun u => (cone_composable b u & cone_compose b u = a)).

Lemma cone_to_limit_pr : forall a b,
is_cone a -> is_limit b -> socle a = socle b ->
(cone_composable b (cone_to_limit a b)
& cone_compose b (cone_to_limit a b) = a).
Proof.
ir. uh H0; ee. uh H2; ee. util (H3 a). am. am.
cp (choose_pr H4). cbv beta in H5. ee.
am. uh H2; ee.
util (H3 a). am. am.
cp (choose_pr H4). cbv beta in H5. ee.
am.
Qed.

Lemma mor_cone_to_limit : forall a b y,
is_cone a -> is_limit b -> socle a = socle b ->
y = cone_target b ->
mor y (cone_to_limit a b).
Proof.
ir. cp (cone_to_limit_pr H H0 H1).
ee. uh H3; ee. rw H2; am.
Qed.

Lemma source_cone_to_limit : forall a b,
is_cone a -> is_limit b -> socle a = socle b ->
source (cone_to_limit a b) = vertex a.
Proof.
ir. cp (cone_to_limit_pr H H0 H1).
ee. transitivity (vertex (cone_compose b (cone_to_limit a b))).
rw vertex_cone_compose. tv.
rw H3. tv.
Qed.

Lemma target_cone_to_limit : forall a b,
is_cone a -> is_limit b -> socle a = socle b ->
target (cone_to_limit a b) = vertex b.
Proof.
ir. cp (cone_to_limit_pr H H0 H1).
ee. uh H2; ee. am.
Qed.

Lemma cone_compose_cone_to_limit : forall a b,
is_cone a -> is_limit b ->  socle a = socle b ->
cone_compose b (cone_to_limit a b) = a.
Proof.
ir. cp (cone_to_limit_pr H H0 H1).
ee. am.
Qed.

Lemma cone_composable_cone_to_limit : forall a b,
is_cone a -> is_limit b -> socle a = socle b ->
cone_composable b (cone_to_limit a b) = True.
Proof.
ir.
cp (cone_to_limit_pr H H0 H1).
ee. app iff_eq; ir; try am.
Qed.

Lemma cone_to_limit_cone_compose1 : forall a u,
is_limit a -> cone_composable a u ->
cone_to_limit (cone_compose a u) a = u.
Proof.
ir.
assert (lem1 : is_limit a). am.
uh H; ee. uh H; ee. ap H2.
uhg; ee. am. ap mor_cone_to_limit.
rww is_cone_cone_compose.
am.  rw socle_cone_compose. tv. tv.
rw target_cone_to_limit. tv. rww is_cone_cone_compose.
am.  rw socle_cone_compose. tv. am.
rw cone_compose_cone_to_limit. tv.
rww is_cone_cone_compose. am. rww socle_cone_compose.
Qed.

Lemma cone_to_limit_cone_compose : forall a b u,
is_limit b -> cone_composable a u ->
socle a = socle b ->
cone_to_limit (cone_compose a u) b =
comp (cone_target b) (cone_to_limit a b) u.
Proof.
ir. set (k:= comp (cone_target b) (cone_to_limit a b) u).
assert (cone_target a = cone_target b).
uf cone_target. rww H1.
assert (lem1 : is_cone a).
lu.
transitivity (cone_to_limit (cone_compose b k) b).
uf k. wr cone_compose_cone_compose.
rw cone_compose_cone_to_limit. tv. lu.
am. am.
rww cone_composable_cone_to_limit.
app show_composable. app mor_cone_to_limit.
wr H2. lu.
rww source_cone_to_limit. sy; lu.
rww cone_to_limit_cone_compose1.
uf k. uhg; ee. uh H; ee. uh H; ee; am.
rww mor_comp. app mor_cone_to_limit.
wr H2. lu. rww source_cone_to_limit. sy; lu.
rw target_comp.
rww target_cone_to_limit.
app mor_cone_to_limit.
wr H2; lu.
rww source_cone_to_limit. sy; lu.
Qed.

Definition cone_transform u c :=
cone_create (vertex c) (vcompose u (edge_nt c)).

Lemma vertex_cone_transform : forall u c,
vertex (cone_transform u c) = vertex c.
Proof.
ir. uf cone_transform. rww vertex_cone_create.
Qed.

Lemma edge_nt_cone_transform : forall u c,
edge_nt (cone_transform u c) = vcompose u (edge_nt c).
Proof.
ir. uf cone_transform. rww edge_nt_cone_create.
Qed.

Lemma socle_cone_transform : forall u c,
socle (cone_transform u c) = target u.
Proof.
ir. uf socle.
rww edge_nt_cone_transform. rww target_vcompose.
Qed.

Definition cone_transformable u c :=
is_cone c &
Nat_Trans.axioms u &
source u = socle c.

Lemma cone_source_cone_transform : forall u c,
cone_transformable u c ->
cone_source (cone_transform u c) = cone_source c.
Proof.
ir. uf cone_source.
rw socle_cone_transform.
uh H; ee. rww source_target. uf osource; rww H1.
Qed.

Lemma cone_target_cone_transform : forall u c,
cone_transformable u c ->
cone_target (cone_transform u c) = cone_target c.
Proof.
ir. uf cone_target.
rww socle_cone_transform.
uh H; ee. wr H1. rww target_source.
Qed.

Lemma edge_cone_transform : forall u c x,
ob (osource u) x -> cone_transformable u c ->
edge (cone_transform u c) x =
comp (cone_target c) (ntrans u x) (edge c x).
Proof.
ir. uf edge.
rw edge_nt_cone_transform. rw ntrans_vcompose.
uh H0; ee. wr target_source. rw H2. tv. am.
uh H0. ee. rw osource_edge_nt. uf cone_source.
wr H2. am. am.
Qed.

Lemma is_cone_cone_transform : forall u c,
cone_transformable u c -> is_cone (cone_transform u c).
Proof.
ir. uhg; ee.
uf cone_transform. app cone_like_cone_create.
rw edge_nt_cone_transform. rww vcompose_axioms.
lu. uh H; ee. uh H; ee. am.
uh H; ee. am.
rw vertex_cone_transform. rww cone_target_cone_transform.
uh H; ee. uh H; ee. am.
rw edge_nt_cone_transform.
rw source_vcompose. rw source_edge_nt.
rw cone_source_cone_transform.
rw cone_target_cone_transform. rww vertex_cone_transform.
am. am. lu.
Qed.

Definition cone_pushdown f c :=
cone_create (fob f (vertex c)) (htrans_left f (edge_nt c)).

Lemma vertex_cone_pushdown : forall f c,
vertex (cone_pushdown f c) = fob f (vertex c).
Proof.
ir. uf cone_pushdown. rww vertex_cone_create.
Qed.

Lemma edge_nt_cone_pushdown : forall f c,
edge_nt (cone_pushdown f c) = htrans_left f (edge_nt c).
Proof.
ir. uf cone_pushdown. rww edge_nt_cone_create.
Qed.

Lemma socle_cone_pushdown : forall f c,
socle (cone_pushdown f c) = fcompose f (socle c).
Proof.
ir. uf socle. rw edge_nt_cone_pushdown.
rw target_htrans_left. tv.
Qed.

Lemma cone_source_cone_pushdown : forall f c,
cone_source (cone_pushdown f c) = cone_source c.
Proof.
ir. uf cone_source. rw socle_cone_pushdown.
rw source_fcompose. tv.
Qed.

Lemma cone_target_cone_pushdown : forall f c,
cone_target (cone_pushdown f c) = target f.
Proof.
ir. uf cone_target. rw socle_cone_pushdown.
rww target_fcompose.
Qed.

Lemma edge_cone_pushdown : forall f c x,
ob (cone_source c) x -> is_cone c ->
edge (cone_pushdown f c) x = fmor f (edge c x).
Proof.
ir. uf edge.
rw edge_nt_cone_pushdown. rw ntrans_htrans_left.
tv. rww osource_edge_nt.
Qed.

Lemma is_cone_cone_pushdown : forall f c,
is_cone c -> Functor.axioms f -> source f = cone_target c ->
is_cone (cone_pushdown f c).
Proof.
ir. uhg; ee. uf cone_pushdown.
ap cone_like_cone_create.
rw edge_nt_cone_pushdown. app htrans_left_axioms.
uh H; ee. am. rw cone_target_cone_pushdown.
rw vertex_cone_pushdown.
app ob_fob. rw H1. uh H; ee; am.
rw edge_nt_cone_pushdown. rw source_htrans_left.
rw source_edge_nt.
rw fcompose_right_constant_functor.
rw cone_source_cone_pushdown.
rw cone_target_cone_pushdown.
rw vertex_cone_pushdown. tv. am. am.
app cone_source_axioms.
app ob_vertex. am.
Qed.

Lemma cone_pushdown_cone_pushdown : forall f g a,
is_cone a -> Functor.axioms f -> Functor.axioms g ->
source g = cone_target a -> source f = target g ->
cone_pushdown f (cone_pushdown g a) =
cone_pushdown (fcompose f g) a.
Proof.
ir.
ap cone_extensionality.
ap is_cone_cone_pushdown. ap is_cone_cone_pushdown.
am. am. am. am.
rw cone_target_cone_pushdown. am.
ap is_cone_cone_pushdown. am.
ap fcompose_axioms. am.
am. am. rw source_fcompose. am.
rw vertex_cone_pushdown.
rw vertex_cone_pushdown.
rw vertex_cone_pushdown.
rw fob_fcompose. tv. am.
am. am. rw H2. ap ob_vertex.
am.
rww socle_cone_pushdown. rww socle_cone_pushdown.
sy; rw socle_cone_pushdown.
rw fcompose_assoc. tv. am. am.
app socle_axioms. am. am.

ir. rwi cone_source_cone_pushdown H4.
rwi cone_source_cone_pushdown H4.
rw edge_cone_pushdown.
 rw edge_cone_pushdown.
rw edge_cone_pushdown.
rw fmor_fcompose. tv. am. am. am.
rw H2. ap mor_edge. am. am.
am. am. am. am. rw cone_source_cone_pushdown. am.
app is_cone_cone_pushdown.
Qed.

Definition cone_pullback f c :=
cone_create (vertex c) (htrans_right (edge_nt c) f).

Lemma vertex_cone_pullback : forall f c,
vertex (cone_pullback f c) = vertex c.
Proof.
ir. uf cone_pullback. rww vertex_cone_create.
Qed.

Lemma edge_nt_cone_pullback : forall f c,
edge_nt (cone_pullback f c) = htrans_right (edge_nt c) f.
Proof.
ir. uf cone_pullback. rww edge_nt_cone_create.
Qed.

Lemma socle_cone_pullback : forall f c,
socle (cone_pullback f c) = fcompose (socle c) f.
Proof.
ir. uf socle. rw edge_nt_cone_pullback.
rw target_htrans_right. tv.
Qed.

Lemma cone_source_cone_pullback : forall f c,
cone_source (cone_pullback f c) = source f.
Proof.
ir. uf cone_source. rw socle_cone_pullback.
rw source_fcompose. tv.
Qed.

Lemma cone_target_cone_pullback : forall f c,
cone_target (cone_pullback f c) = cone_target c.
Proof.
ir. uf cone_target. rw socle_cone_pullback.
rww target_fcompose.
Qed.

Lemma edge_cone_pullback : forall f c x,
ob (source f) x ->
edge (cone_pullback f c) x = edge c (fob f x).
Proof.
ir. uf edge.
rw edge_nt_cone_pullback. rw ntrans_htrans_right.
tv. am.
Qed.

Lemma is_cone_cone_pullback : forall f c,
is_cone c -> Functor.axioms f -> cone_source c = target f ->
is_cone (cone_pullback f c).
Proof.
ir. uhg; ee. uf cone_pullback.
ap cone_like_cone_create.
rw edge_nt_cone_pullback. app htrans_right_axioms.
uh H; ee. am. rww osource_edge_nt.

rw cone_target_cone_pullback.
rw vertex_cone_pullback.
app ob_vertex.
rw edge_nt_cone_pullback. rw source_htrans_right.
rw source_edge_nt.
rw fcompose_left_constant_functor.
rw cone_source_cone_pullback.
rw cone_target_cone_pullback.
rw vertex_cone_pullback. tv. am. sy; am.
app cone_target_axioms.
app ob_vertex. am.
Qed.

Lemma cone_compose_id : forall c,
is_cone c ->
cone_compose c (id (cone_target c) (vertex c)) = c.
Proof.
ir. ap cone_extensionality.
rww is_cone_cone_compose.
uhg; ee. am. ap mor_id. ap ob_vertex.
am. rww target_id. app ob_vertex. am.
rww vertex_cone_compose. rww source_id.
app ob_vertex. rww socle_cone_compose.
ir. rwi cone_source_cone_compose H0.
rww edge_cone_compose. rww right_id. app ob_vertex.
app mor_edge. rww source_edge.
uhg; ee. am. app mor_id. app ob_vertex.
rww target_id. app ob_vertex.
Qed.

Lemma cone_compose_cone_transform : forall f c u,
is_cone c -> cone_composable c u -> cone_transformable f c ->
cone_compose (cone_transform f c) u =
cone_transform f (cone_compose c u).
Proof.
ir. ap cone_extensionality.
rww is_cone_cone_compose.
uhg; ee. app is_cone_cone_transform.
rww cone_target_cone_transform. lu.
rww vertex_cone_transform. lu.
app is_cone_cone_transform.
uhg; ee. rww is_cone_cone_compose.
lu. rw socle_cone_compose. lu.
rw vertex_cone_compose; rww vertex_cone_transform.
rww vertex_cone_compose.
rw socle_cone_compose. rww socle_cone_transform.
rww socle_cone_transform.
ir.
rwi cone_source_cone_compose H2.
rwi cone_source_cone_transform H2; try am.
assert (osource f = cone_source c).
uf cone_source. uf osource. ap uneq; lu.
assert (otarget f = cone_target c).
uf cone_target. wr target_source.  ap uneq.
uh H1; ee. am. lu.

rw edge_cone_compose.
rw edge_cone_transform. rw edge_cone_transform.
rww cone_target_cone_transform.
rww cone_target_cone_compose.
rww edge_cone_compose. rww assoc.
app mor_ntrans. lu. uh H1; ee. rww H3.
sy; am. app  mor_edge. uh H0; ee. am.
rww source_ntrans. rww target_edge.
uh H1; ee. rww H6. lu. rww H3.
rww source_edge. sy; lu. rww H3.
uhg; ee. rww is_cone_cone_compose. lu.
rww socle_cone_compose. lu. rww H3. am.
rww cone_source_cone_transform.
uhg; ee. app is_cone_cone_transform.
rww cone_target_cone_transform. uh H0; ee; am.
rww vertex_cone_transform. lu.
Qed.

Lemma cone_to_limit_id : forall a b,
is_limit a -> a = b ->
cone_to_limit a b = id (cone_target b) (vertex b).
Proof.
ir. cp H.
uh H1; ee.
uh H1; ee. ap H3.
uhg; ee. am. ap mor_cone_to_limit. am.
wr H0; lu. rw H0; tv. rw H0; tv.
rw target_cone_to_limit. rw H0; tv. am.
wr H0; lu. rw H0; tv.
uhg; ee. am.
wr H0; ap mor_id. ap ob_vertex. am.
rw target_id. rw H0; tv. ap ob_vertex.
wr H0; am.
wr H0; rw cone_compose_cone_to_limit.
rw cone_compose_id. tv. am. am. am. tv.
Qed.

Lemma comp_edge_cone_to_limit : forall r s x b,
is_limit s -> is_cone r -> socle r = socle s ->
b = cone_target s -> ob (cone_source s) x ->
comp b (edge s x) (cone_to_limit r s) =
edge r x.
Proof.
ir.
transitivity (edge (cone_compose s (cone_to_limit r s)) x).
rw edge_cone_compose. rww H2. am.
rww cone_composable_cone_to_limit.
rw cone_compose_cone_to_limit. tv.
am. am. am.
Qed.

Lemma edge_nt_axioms : forall c,
is_cone c -> Nat_Trans.axioms (edge_nt c).
Proof.
ir. lu. Qed.

Lemma cone_transform_vident : forall f c,
f = socle c -> is_cone c ->
cone_transform (vident f) c = c.
Proof.
ir. uf cone_transform.
rw weak_left_vident. lu. app edge_nt_axioms. rww target_edge_nt.
Qed.

Lemma cone_transform_vcompose : forall u v c,
is_cone c -> cone_transformable v c ->
Nat_Trans.axioms u -> source u = target v ->
cone_transform (vcompose u v) c =
cone_transform u (cone_transform v c).
Proof.
ir. uh H0; ee.
uf cone_transform. rw vertex_cone_create. ap uneq.
rw edge_nt_cone_create.
rww vcompose_assoc.  app edge_nt_axioms.
Qed.

(**** stuff about limits and isomorphisms ****)

Lemma comp_cone_to_limit_inversely : forall a b c,
is_limit a -> is_limit b -> socle a = socle b ->
cone_target a = c ->
comp c (cone_to_limit a b) (cone_to_limit b a) =
id c (vertex b).
Proof.
ir.
assert (cone_target b = c).
uf cone_target. wr H1. am.
cp H; cp H0.
uh H4; uh H5; ee.
uh H4; uh H5. ee.

assert (composable c (cone_to_limit a b) (cone_to_limit b a)).
ap show_composable. app mor_cone_to_limit.
sy; am. app mor_cone_to_limit. sy; am. sy; am.
rww source_cone_to_limit. rww target_cone_to_limit.
sy; am.

ap H8.
uhg; ee. am. rw H3.
rww mor_comp.
ap mor_cone_to_limit. am. am. am. sy; am.
app mor_cone_to_limit. sy; am. sy; am.
rw source_cone_to_limit.
rww target_cone_to_limit. sy; am. am. am.
am.
rw target_comp. rww target_cone_to_limit.
app mor_cone_to_limit. sy; am.
app mor_cone_to_limit. sy; am. sy; am.
rw source_cone_to_limit.
rww target_cone_to_limit. sy; am. am. am.
am.
uhg; ee. am. rw H3. ap mor_id.
wr H3. ap ob_vertex. am.
rw target_id. tv. wr H3; app ob_vertex.
wr H3. wr cone_compose_cone_compose.
rw cone_compose_cone_to_limit. rw cone_compose_cone_to_limit.
rw cone_compose_id. tv. am. am. am. sy; am.
am. am. am.

uhg; ee.
am. app mor_cone_to_limit.
rww target_cone_to_limit.
rww H3.
Qed.

Lemma are_inverse_cone_to_limit : forall a b c,
is_limit a -> is_limit b -> socle a = socle b ->
cone_target a = c ->
are_inverse c (cone_to_limit a b) (cone_to_limit b a).
Proof.
ir.
assert (cone_target b = c).
uf cone_target. wr H1. am.
cp H; cp H0.
uh H4; uh H5; ee.
uh H4; uh H5. ee.
uhg; ee; try am.
app mor_cone_to_limit.
sy; am.
app mor_cone_to_limit. sy; am.
sy; am.
rww source_cone_to_limit. rww target_cone_to_limit.
sy; am.
rww target_cone_to_limit. rww source_cone_to_limit.
sy; am.
rw source_cone_to_limit.
app comp_cone_to_limit_inversely.
am. am. sy; am.
rww comp_cone_to_limit_inversely.
rww source_cone_to_limit. sy; am.
Qed.

Lemma invertible_cone_to_limit : forall a b c,
is_limit a -> is_limit b -> socle a = socle b ->
cone_target a = c ->
invertible c (cone_to_limit a b).
Proof.
ir.
uhg. sh (cone_to_limit b a).
app are_inverse_cone_to_limit.
Qed.

Lemma inverse_cone_to_limit : forall a b c,
is_limit a -> is_limit b -> socle a = socle b ->
cone_target a = c ->
inverse c (cone_to_limit a b) = cone_to_limit b a.
Proof.
ir.
cp (are_inverse_cone_to_limit H H0 H1 H2).
app inverse_eq.
Qed.

Lemma is_limit_cone_compose : forall a u,
is_limit a -> cone_composable a u ->
invertible (cone_target a) u ->
is_limit (cone_compose a u).
Proof.
ir.
assert (lem1: is_cone (cone_compose a u)).
rww is_cone_cone_compose.

uhg; ee.

(**** uni proof ****)
uhg; ee. am. ir.
assert (mor (cone_target a) u0).
uh H2; ee. rwi cone_target_cone_compose H5. am.

assert (mor (cone_target a) v).
uh H3; ee. rwi cone_target_cone_compose H6; am.
assert (source u = target u0). sy.
uh H2; ee. rwi vertex_cone_compose H8; am.
assert (source u = target v). sy.
uh H3; ee. rwi vertex_cone_compose H9; am.
assert (mor (cone_target a) u).
uh H0; ee. am.
rwi cone_compose_cone_compose H4.
rwi cone_compose_cone_compose H4.
uh H; ee. uh H; ee.
assert (comp (cone_target a) u u0 = comp (cone_target a) u v).
ap H11. uhg; ee. am. rww mor_comp.
rww target_comp.
lu.
uhg; ee. am. rww mor_comp.
rw target_comp. lu.
lu. lu. lu. am.
transitivity (comp (cone_target a) (inverse (cone_target a) u)
(comp (cone_target a) u u0)).
wr assoc.
rw left_inverse. rw left_id. tv.

rww ob_source. am. sy; am. tv. am.
ap mor_inverse.
am. am. am. rw source_inverse. tv. am. am. tv.
rw H12. wr assoc.
rw left_inverse. rw left_id. tv.
rww ob_source. am. sy; am. tv. am.
app mor_inverse. am. am.
rww source_inverse. am. tv. am. app show_composable.
am. app show_composable.

(*** versal proof ***)
assert (lema: target u = vertex a). lu.
uhg; ee. am. ir.
assert (lem0 : socle b = socle a).
rwi socle_cone_compose H3. am.
assert (lem2: composable (cone_target a) (inverse (cone_target a) u)
(cone_to_limit b a)).
ap show_composable. app mor_inverse.
app mor_cone_to_limit.
rw source_inverse.
rww target_cone_to_limit. lu.

sh (comp (cone_target a) (inverse (cone_target a) u)
(cone_to_limit b a)).
ee.
uhg; ee. am. rw cone_target_cone_compose.
rww mor_comp.
app mor_inverse.
app mor_cone_to_limit.
rww source_inverse. rww target_cone_to_limit.
rww target_comp. rww target_inverse.
assert (cone_target a = cone_target (cone_compose a u)).
rww cone_target_cone_compose.
rww vertex_cone_compose.
app mor_inverse. app mor_cone_to_limit.
rww source_inverse. rww target_cone_to_limit.

assert (mor (cone_target a) u). uh H0; ee; am.

rw cone_compose_cone_compose.
wr assoc. rww right_inverse.
rw left_id. rw cone_compose_cone_to_limit. tv.
am. am. am. rww ob_target.
app mor_cone_to_limit. rw target_cone_to_limit.
sy; am. am. am. am. tv. am.
app mor_inverse.
app mor_cone_to_limit.
rww target_inverse.
rww source_inverse. rww target_cone_to_limit.
tv. am. ap show_composable.
am. rww mor_comp.
app mor_inverse. app mor_cone_to_limit.
rww source_inverse. rww target_cone_to_limit.
rww target_comp. rww target_inverse.
app mor_inverse. app mor_cone_to_limit.
rww source_inverse. rww target_cone_to_limit.
Qed.

Lemma cone_to_limit_invertible_is_limit : forall a b,
is_limit b -> is_cone a -> socle a = socle b ->
invertible (cone_target b) (cone_to_limit a b) -> is_limit a.
Proof.
ir. assert  (a = cone_compose b (cone_to_limit a b)).
rw cone_compose_cone_to_limit. tv.
am.  am. am. rw H3.
ap is_limit_cone_compose. am.
uhg; ee. uh H; ee. uh H; ee; am.
app mor_cone_to_limit.
rww target_cone_to_limit. lu.
Qed.

(***** added in september: dotted *****)

Definition dotted a := cone_to_limit a (limit (socle a)).

Lemma source_dotted : forall a, is_cone a ->
has_limit (socle a) -> source (dotted a) = vertex a.
Proof.
ir.
uf dotted. rww source_cone_to_limit.
app is_limit_limit.
rww socle_limit.
Qed.

Lemma target_dotted : forall a, is_cone a ->
has_limit (socle a) -> target (dotted a) = vertex (limit (socle a)).
Proof.
ir.
uf dotted. rww target_cone_to_limit.
app is_limit_limit.
rww socle_limit.
Qed.

Lemma mor_dotted : forall a, is_cone a ->
has_limit (socle a) -> mor (cone_target a) (dotted a).
Proof.
ir.
uf dotted. app mor_cone_to_limit.
app is_limit_limit.
rww socle_limit.
uf cone_target. rww socle_limit.
Qed.

Lemma cone_target_limit : forall f,
has_limit f -> cone_target (limit f) = target f.
Proof.
ir. uf cone_target. rww socle_limit.
Qed.

Lemma cone_source_limit : forall f,
has_limit f -> cone_source (limit f) = source f.
Proof.
ir. uf cone_source. rww socle_limit.
Qed.

Lemma target_socle : forall a, target (socle a) = cone_target a.
Proof. ir. reflexivity. Qed.

Lemma source_socle : forall a, source (socle a) = cone_source a.
Proof. ir. reflexivity. Qed.

Lemma cone_composable_dotted : forall a, is_cone a ->
has_limit (socle a) -> cone_composable (limit (socle a))
(dotted a).
Proof.
ir. uf cone_composable. ee.
ap is_limit_is_cone. app is_limit_limit.
rww cone_target_limit.
rw target_socle.
app mor_dotted.
rww target_dotted.
Qed.

Lemma cone_compose_dotted : forall a, is_cone a ->
has_limit (socle a) -> cone_compose (limit (socle a)) (dotted a)
= a.
Proof.
ir. uf dotted.
rww cone_compose_cone_to_limit.
app is_limit_limit. rww socle_limit.
Qed.

Lemma dotted_cone_compose : forall u a,
cone_composable a u -> has_limit (socle a) ->
dotted (cone_compose a u) = comp (cone_target a) (dotted a) u.
Proof.
ir. uf dotted.
rw cone_to_limit_cone_compose.
rw socle_cone_compose.
rw cone_target_limit. rw target_socle. reflexivity.
am. app is_limit_limit. rw socle_cone_compose. am.
am. rw socle_limit. rw socle_cone_compose. tv.
rww socle_cone_compose.
Qed.

Lemma cone_to_limit_refl : forall a, is_limit a ->
cone_to_limit a a = id (cone_target a) (vertex a).
Proof.
ir. transitivity
(comp (cone_target a) (cone_to_limit a a) (cone_to_limit a a)).
wr cone_to_limit_cone_compose.
rw cone_compose_cone_to_limit. tv. lu. am.
tv. lu. rww cone_composable_cone_to_limit.
lu. tv.
rww comp_cone_to_limit_inversely.
Qed.

Lemma dotted_limit : forall f, Functor.axioms f -> has_limit f ->
dotted (limit f) = id (target f) (vertex (limit f)).
Proof.
ir. uf dotted.
rww socle_limit.
rw cone_to_limit_refl. rw cone_target_limit.
tv. am. app is_limit_limit.
Qed.

Lemma dotted_unique : forall f u, Functor.axioms f ->
has_limit f -> cone_composable (limit f) u ->
dotted (cone_compose (limit f) u) = u.
Proof.
ir. rw dotted_cone_compose.
rw dotted_limit.
rw cone_target_limit. rw left_id. tv.
assert (target f = cone_target (limit f)).
rww cone_target_limit. rw H2.
app ob_vertex. ap is_limit_is_cone. app is_limit_limit.
uh H1; ee. rwi cone_target_limit H2. am. am.
uh H1; ee. am. tv. am. am. am.
am. rww socle_limit.
Qed.

Lemma invertible_dotted_is_limit : forall a,
is_cone a -> has_limit (socle a) ->
invertible (cone_target a) (dotted a) -> is_limit a.
Proof.
ir.
assert (a = cone_compose (limit (socle a)) (dotted a)).
rww cone_compose_dotted.
rw H2. app is_limit_cone_compose.
app is_limit_limit.
app cone_composable_dotted.
rw cone_target_limit. rw target_socle. am. am.
Qed.

Lemma is_limit_invertible_dotted : forall a,
is_limit a -> invertible (cone_target a) (dotted a).
Proof.
ir. uf dotted.
assert (has_limit (socle a)).
uhg. sh a. uhg; ee. am. tv.
ap invertible_cone_to_limit. am. ap is_limit_limit.
am.
rww socle_limit. tv.
Qed.

(**** stuff about functors commuting with limits ***)

Section Commutation_Def.
Variable f a b: E.

Hypothesis cone_a : is_cone a.
Hypothesis limit_b : is_limit b.
Hypothesis fsource_cone_target : source f = cone_target a.
Hypothesis f_functor : Functor.axioms f.
Hypothesis compose_ntarg : fcompose f (socle a) = socle b.

Definition commutation :=
cone_to_limit (cone_pushdown f a) b.

Lemma source_commutation :
source commutation = fob f (vertex a).
Proof.
uf commutation.
rw source_cone_to_limit.
rww vertex_cone_pushdown. app is_cone_cone_pushdown.
am. rww socle_cone_pushdown.
Qed.

Lemma target_commutation :
target commutation  = vertex b.
Proof.
ir. uf commutation.
rw target_cone_to_limit. tv. app is_cone_cone_pushdown.
am. rww socle_cone_pushdown.
Qed.

Lemma cone_target_b : cone_target b = target f.
Proof.
uf cone_target. wr compose_ntarg.
rw target_fcompose. tv.
Qed.

Lemma mor_commutation :
mor (target f) commutation.
Proof.
uf commutation.
ap mor_cone_to_limit.
app is_cone_cone_pushdown. am.
rww socle_cone_pushdown.
rww cone_target_b.
Qed.

Lemma cone_composable_commutation :
cone_composable b commutation.
Proof.
uhg; ee. cp limit_b.
uh H; ee. lu.
rw cone_target_b.

ap mor_commutation.
rw target_commutation. tv.
Qed.

Lemma cone_compose_commutation :
cone_compose b commutation = cone_pushdown f a.
Proof.
uf commutation.
rw cone_compose_cone_to_limit. tv.
app is_cone_cone_pushdown. am.
rww socle_cone_pushdown.
Qed.

Lemma invertible_commutation_is_limit_cone_pushdown :
forall c, target f = c ->
invertible c commutation =
is_limit (cone_pushdown f a).
Proof.
ir. wr H. ap iff_eq; ir.
wr cone_compose_commutation.
app is_limit_cone_compose.
ap cone_composable_commutation.
rww cone_target_b.

uf commutation.
ap invertible_cone_to_limit.
am. am. rww socle_cone_pushdown.
rww cone_target_cone_pushdown.
Qed.

End Commutation_Def.

Section Cone_Pushdown_Cone_Compose.
Variables u a f: E.

Hypothesis K : is_cone a.
Hypothesis K0 : Functor.axioms f.
Hypothesis K1 : source f = cone_target a.
Hypothesis K2 : mor (source f) u.
Hypothesis K3 : target u = vertex a.

Lemma cone_composable_a_u : cone_composable a u.
Proof.
uhg; ee. am. wr K1; am. am.
Qed.

Lemma cone_pushdown_cone_compose :
cone_pushdown f (cone_compose a u) =
cone_compose (cone_pushdown f a) (fmor f u).
Proof.
ap cone_extensionality.
ap is_cone_cone_pushdown. rww is_cone_cone_compose.
ap cone_composable_a_u.
am. rww cone_target_cone_compose.
rww is_cone_cone_compose. uhg; ee.
app is_cone_cone_pushdown.
rww cone_target_cone_pushdown. app mor_fmor.
rww target_fmor. rww vertex_cone_pushdown.
rww K3.
rww vertex_cone_pushdown.
rww vertex_cone_compose.
rww vertex_cone_compose. rww source_fmor.
rww socle_cone_pushdown. rww socle_cone_compose.
rww socle_cone_compose. rww socle_cone_pushdown.
ir.
rwi cone_source_cone_pushdown H. rwi cone_source_cone_compose H.
rw edge_cone_pushdown.
rw edge_cone_compose. rw edge_cone_compose.
rw cone_target_cone_pushdown.
rw edge_cone_pushdown.
wr K1. wr comp_fmor. tv.
am. rw K1. app mor_edge. rww K1.
wrr K1. rww source_edge. sy; am.
am. am. rww cone_source_cone_pushdown.
uhg; ee. app is_cone_cone_pushdown.
rww cone_target_cone_pushdown.
app mor_fmor.
rww vertex_cone_pushdown. rww target_fmor.
rww K3. am. ap cone_composable_a_u.
rww cone_source_cone_compose. rww is_cone_cone_compose.
ap cone_composable_a_u.
Qed.

End Cone_Pushdown_Cone_Compose.

Section Cone_Pushdown_Cone_To_Limit.
Variables a b f : E.

Hypothesis K : Functor.axioms f.
Hypothesis K0 : is_cone a.
Hypothesis K1 : is_limit b.
Hypothesis K2 : socle a = socle b.
Hypothesis K3 : source f = cone_target b.
Hypothesis K4 : is_limit (cone_pushdown f b).

Lemma cone_compose_cone_pushdown_fmor_cone_to_limit :
cone_compose (cone_pushdown f b) (fmor f (cone_to_limit a b))
= cone_pushdown f a.
Proof.
assert (lem0 : is_cone b).
cp K1. uh H; ee. lu.
assert (lem1 : a = cone_compose b (cone_to_limit a b)).
rww cone_compose_cone_to_limit.
transitivity (cone_pushdown f (cone_compose b (cone_to_limit a b))).
assert (cone_pushdown f (cone_compose b (cone_to_limit a b))
= cone_compose (cone_pushdown f b) (fmor f (cone_to_limit a b))).
rw cone_pushdown_cone_compose. reflexivity.
am. am. am.
app mor_cone_to_limit.
rww target_cone_to_limit.
rw H. reflexivity.
assert (cone_compose b (cone_to_limit a b) = a).
rw cone_compose_cone_to_limit. tv. am. am.
am. rw H. reflexivity.
Qed.

Lemma fmor_cone_to_limit :
fmor f (cone_to_limit a b) =
cone_to_limit (cone_pushdown f a) (cone_pushdown f b).
Proof.
cp K4. uh H; ee. uh H; ee.
assert (is_cone b).
cp K1. uh H2; ee; lu.
assert (is_versal b). cp K1; lu.
ap H1.
uhg; ee. app is_cone_cone_pushdown.
rww cone_target_cone_pushdown. app mor_fmor. rw K3.
app mor_cone_to_limit.
rww target_fmor. rww vertex_cone_pushdown.
rww target_cone_to_limit. rw K3; app mor_cone_to_limit.
uhg; ee. app  is_cone_cone_pushdown.
rww cone_target_cone_pushdown.

ap mor_cone_to_limit. ap is_cone_cone_pushdown.
am. am. rw K3. uf cone_target. rww K2. am.
rww socle_cone_pushdown. rw socle_cone_pushdown.
rww K2.
rww cone_target_cone_pushdown.
rw target_cone_to_limit. tv. app is_cone_cone_pushdown.
rw K3; uf cone_target; rww K2. am.
rww socle_cone_pushdown. rw socle_cone_pushdown.
rww K2.
rw cone_compose_cone_pushdown_fmor_cone_to_limit.
sy; rw cone_compose_cone_to_limit. tv. app is_cone_cone_pushdown.
rw K3; uf cone_target; rww K2. am.
rw socle_cone_pushdown. rw socle_cone_pushdown. rww K2.
Qed.

End Cone_Pushdown_Cone_To_Limit.

Section Limit_Preservation_Invariance.
Variables a b f : E.

Hypothesis K : Functor.axioms f.
Hypothesis K0 : is_limit a.
Hypothesis K1 : is_limit b.
Hypothesis K2 : socle a = socle b.
Hypothesis K3 : source f = cone_target b.
Hypothesis K4 : is_limit (cone_pushdown f b).

Lemma invertible_cone_to_limit_a_b:
invertible (source f) (cone_to_limit a b).
Proof.
app invertible_cone_to_limit. rw K3; uf cone_target; rw K2.
tv.
Qed.

Lemma invertible_fmor_ctl :
invertible (target f) (fmor f (cone_to_limit a b)).
Proof.
app invertible_fmor.
app invertible_cone_to_limit. rw K3; uf cone_target; rww K2.
Qed.

Lemma limit_preservation_invariance :
is_limit (cone_pushdown f a).
Proof.
ir.
ap (cone_to_limit_invertible_is_limit
(a:= (cone_pushdown f a)) (b:=(cone_pushdown f b))).
am. app is_cone_cone_pushdown. cp K0; lu.
rw K3; uf cone_target; rww K2.
rw socle_cone_pushdown. rw socle_cone_pushdown.
rww K2.
wr fmor_cone_to_limit.
rw cone_target_cone_pushdown. ap invertible_fmor_ctl.
am. cp K0; lu. am. am.
am. am.
Qed.

End Limit_Preservation_Invariance.

Lemma cone_pushdown_are_inverse_invol : forall a f g,
is_cone a -> are_finverse f g ->
source f = cone_target a ->
cone_pushdown g (cone_pushdown f a) = a.
Proof.
ir. ap cone_extensionality.
ap is_cone_cone_pushdown. ap is_cone_cone_pushdown.
am. uh H0; ee; am. am.
uh H0; ee; am. rw cone_target_cone_pushdown.
uh H0; ee; am. am.
rw vertex_cone_pushdown. rw vertex_cone_pushdown.
wr fob_fcompose. uh H0; ee. rw H6.
rw fob_fidentity. tv. rw H1. ap ob_vertex. am.
uh H0; ee; am. uh H0; ee; am. uh H0; ee; am.
rw H1. ap ob_vertex. am.
rw socle_cone_pushdown. rw socle_cone_pushdown.
wr fcompose_assoc. uh H0; ee.
rw H6.
rw left_fidentity. tv.
ap socle_axioms. am. am. uh H0; ee; am.
uh H0; ee; am. ap socle_axioms. am.
uh H0; ee; am. am.

ir.
rwi cone_source_cone_pushdown H2.
rwi cone_source_cone_pushdown H2.
uh H0; ee.
rw edge_cone_pushdown.
rw edge_cone_pushdown.
wr fmor_fcompose. rw H7.
rw fmor_fidentity. tv.
rw H1. ap mor_edge. am. am. am.
am. am. rw H1. ap mor_edge. am. am. am. am.
rw cone_source_cone_pushdown. am.
ap is_cone_cone_pushdown. am. am. am.
Qed.

Lemma are_finverse_preserves_limits : forall a f g,
is_limit a -> are_finverse f g ->
source f = cone_target a ->
is_limit (cone_pushdown f a).
Proof.
ir.
uh H0; ee.
assert (is_cone a).
uh H; ee. uh H; ee. am.
assert (is_cone (cone_pushdown f a)).
ap is_cone_cone_pushdown. am.
am. am.

assert (lem1 : forall x, ob (source f) x ->
fob g (fob f x) = x).
ir. wr fob_fcompose. rw H6.
rw fob_fidentity. tv. am. am. am. am. am.

assert (lem2 : forall x, ob (target f) x ->
fob f (fob g x) = x).
ir. wr fob_fcompose. rw H5.
rw fob_fidentity. tv. rww H4. am. am. am. rww H4.

assert (lem3 : forall u, mor (source f) u ->
fmor g (fmor f u) = u).
ir. wr fmor_fcompose. rw H6. rw fmor_fidentity.
tv. am. am. am. am. am.

assert (lem4 : forall u, mor (target f) u ->
fmor f (fmor g u) = u).
ir. wr fmor_fcompose. rw H5. rw fmor_fidentity.
tv. rww H4.  am. am. am. rww H4.

uhg; ee.

(**** uni proof *****)

uhg; ee. am.
ir.
uh H9; ee.
uh H10; ee.
rwi cone_target_cone_pushdown H12.
rwi cone_target_cone_pushdown H14.

assert (cone_pushdown g (cone_pushdown f a) = a).
rw cone_pushdown_are_inverse_invol. tv. am.
uhg; ee; am. am.

assert (cone_compose a (fmor g u) =
cone_compose a (fmor g v)).
wr H16.
wr cone_pushdown_cone_compose.
sy; wr cone_pushdown_cone_compose.
rw H11. reflexivity.
am. am. rw cone_target_cone_pushdown. am.

rww H4.
am. ap is_cone_cone_pushdown. am. am. am. am.
rw cone_target_cone_pushdown. am. rw H4. am.
am.
uh H; ee. uh H; ee.
assert (fmor g u = fmor g v).
ap H19.
uhg; ee. am. wr H1. rw H3. ap mor_fmor.
am. rww H4.
rw target_fmor.
rw H13. rw vertex_cone_pushdown.
rw lem1. tv. rw H1. ap ob_vertex. am.
am. rww H4.
uhg; ee. am. wr H1. rw H3. ap mor_fmor.
am. rw H4. am.
rw target_fmor. rw H15.
rw vertex_cone_pushdown. rw lem1. tv.
rw H1. ap ob_vertex. am. am.
rww H4. am.
wr lem4. wr H20. rw lem4. tv.
am. am.

(***** versal proof ****)

uhg; ee. am. ir. cp H. uh H11. ee.
uh H12. ee.
util (H13 (cone_pushdown g b)).
ap is_cone_cone_pushdown. am. am.
uf cone_target. rw H10.
rw socle_cone_pushdown. rw target_fcompose. am.
rw socle_cone_pushdown. rw H10.
rw socle_cone_pushdown.
wr fcompose_assoc. rw H6.
rw left_fidentity. tv. app socle_axioms.
exact H1. am. am.
app socle_axioms. am. exact H1.

nin H14. ee. uh H14; ee.
sh (fmor f x). ee.
uhg; ee.
ap is_cone_cone_pushdown. am. am.
am.
rw cone_target_cone_pushdown. ap mor_fmor.
am. rw H1. am.
rw vertex_cone_pushdown.
rw target_fmor. rww H17. am. rww H1.
wr cone_pushdown_cone_compose. rw H15.
rw cone_pushdown_are_inverse_invol. tv.
am. uhg; ee; am. uf cone_target.
rw H10. rw socle_cone_pushdown.
rw target_fcompose. am. am. am.
am. rww H1. am.
Qed.

Lemma has_limits_over_finverse_invariance :
forall a b c,
Category.axioms a -> Category.axioms b -> Category.axioms c ->
has_limits_over c a ->
(exists f, (exists g,
(are_finverse f g & source f = a & target f = b))) ->
has_limits_over c b.
Proof.
ir.
nin H3. nin H3. ee.
uhg; ee. ir. uhg; ee.
set (k:= fcompose x0 f).
uh H3; ee.
assert (Functor.axioms k).
uf k. ap fcompose_axioms.
am. am. rw H11. rw H5. sy; am.
assert (source k = c).
uf k. rw source_fcompose. am.
assert (target k = a).
uf k. rw target_fcompose. wr H10. am.
assert (fcompose x k = f).
uf k. wr fcompose_assoc. rw H12.
rw left_fidentity. tv. am. rw H11. rw H5.
sy; am. am. am. am. am. rw H11.
rw H5. sy; am.

uh H2; ee. util (H2 k). am. am. am.
uh H18. nin H18. uh H18. ee.
sh (cone_pushdown x x1).
uhg; ee.
apply are_finverse_preserves_limits with x0. am.
uhg; ee; am. uf cone_target. rw H19.
rw H16. am.
rw socle_cone_pushdown. rw H19. am.
Qed.

End Limit.