(* Author: Christian Doczkal *)
(* Distributed under the terms of CeCILL-B. *)
From mathcomp Require Import all_ssreflect.
From RegLang Require Import misc languages dfa nfa regexp.

Set Default Proof Using "Type".

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

(** Preliminaries *)

(* to be used after simplification and rewriting with [tupleE] *)
Lemma behead_cons (T:Type) n (t : n.-tuple T) a : behead_tuple (cons_tuple a t) = t.
Proof.
  rewrite /cons_tuple /behead_tuple /=.
  case: t => t tP /=. set X := (behead_tupleP _). by rewrite (eq_irrelevance X tP).
Qed.

(** * Weak Monadic Second-Order Logic *)

(** We employ a minimal syntax for MSO formulas that permits only second-order
variables. *)

Inductive form :=
| Incl of  nat & nat
| Less of  nat & nat
| FF
| Imp of form & form
| Ex of form.

(** All variables are interpreted as finite sets (actually lists) of natural numbers *)
Definition valuation := nat -> seq nat.

Implicit Types (s t : form) (X Y : nat) (I : valuation) (N : seq nat).

Definition cons N I : valuation := fun k => if k is k'.+1 then I k' else N.

Fixpoint satisfies (I : valuation) (s : form) :=
  match s with
  | Incl X Y => {subset I X <= I Y}
  | Less X Y => forall x y, x \in I X -> y \in I Y -> x < y
  | FF => False
  | Imp s t => satisfies I s -> satisfies I t
  | Ex s => exists N, satisfies (cons N I) s
  end.

Fixpoint bound (s : form) : nat :=
  match s with
  | Incl X Y => maxn X.+1 Y.+1
  | Less X Y => maxn X.+1 Y.+1
  | FF => 0
  | Imp s t => maxn (bound s) (bound t)
  | Ex s => (bound s).-1
  end.

Definition agree n I I' := forall X, X < n -> I X =i I' X.

Lemma agree_dc n m I I' : n <= m -> agree m I I' -> agree n I I'.
Proof. move => A B X ltn_m. apply: B. exact: leq_trans A. Qed.

Lemma coincidence I I' s:
  agree (bound s) I I' -> satisfies I s <-> satisfies I' s.
Proof.
  elim: s I I' => [X Y|X Y||s IHs t IHt|s IHs] /= I I' C.
  - split.
    + move => A B. rewrite -!C ?leq_maxl ?leq_maxr //. exact: A.
    + move => A B. rewrite !C  ?leq_maxl ?leq_maxr //. exact: A.
  - split => H x y;[rewrite -!C|rewrite !C]; try solve [exact: H|by rewrite ?leq_maxl ?leq_maxr].
  - tauto.
  - by rewrite -(IHs I I') ?(IHt I I') //; apply: agree_dc C; rewrite ?leq_maxl ?leq_maxr.
  - have bound_s N : agree (bound s) (cons N I) (cons N I').
    { move => X. case: X C => //= Y A B. apply: A. rewrite -ltnS. by case: (bound s) B. }
    split.
    + move => [N] sat_s. exists N. rewrite -IHs; [exact: sat_s | exact: bound_s].
    + move => [N] sat_s. exists N. rewrite IHs; [exact: sat_s | exact: bound_s].
Qed.

Lemma weak_coincidence I I' s : (forall X, I X =i I' X) -> satisfies I s -> satisfies I' s.
Proof. move => H. by rewrite (@coincidence I I' s). Qed.

(** ** Language-Theoretic Interpretation *)

Section Language.
  Variables (char : finType).

  Definition I_of n (v : seq (n.-tuple bool)) : valuation :=
    fun X => [seq i <- iota 0 (size v) | nth false (nth [tuple of nseq n false] v i) X].

  Definition vec_of (w : word char) : seq (#|char|.-tuple bool) :=
    map (fun a => [tuple X == enum_rank a | X < #|char|]) w.

  Lemma I_of_vev_max k (a:char) w:
    k \in I_of (vec_of w) (enum_rank a) -> k < size w.
  Proof. by rewrite /vec_of /I_of mem_filter mem_iota add0n size_map => /andP[_]. Qed.

  Lemma I_of_vecP k a w: k < size w ->
    (k \in I_of (vec_of w) (enum_rank a) = (nth a w k == a)).
  Proof.
    move => H. rewrite /vec_of /I_of mem_filter mem_iota add0n size_map /=.
    rewrite (nth_map a) // H andbT.
    rewrite (nth_map (enum_rank a)) ?size_tuple ?ltn_ord //.
    by rewrite nth_ord_enum (inj_eq enum_rank_inj) eq_sym.
  Qed.

  Definition vec_lang n s := fun v : seq (n.-tuple bool) => satisfies (I_of v) s.

  Definition mso_lang s := fun w => vec_lang s (vec_of w).

  Lemma vec_of_hom : homomorphism vec_of.
  Proof. exact: map_cat. Qed.

  Lemma mso_preim s : mso_lang s =p preimage vec_of (@vec_lang #|char| s).
  Proof. done. Qed.

End Language.

Notation vec n := [finType of n.-tuple bool].

(** ** Translation from MSO Formulas to NFAs *)

(** propositional connectives *)

Definition nfa_for_bot n := dfa_to_nfa (dfa_void (vec n)).

Definition nfa_for_imp n (A B : nfa (vec n)) :=
  dfa_to_nfa (dfa_op implb (nfa_to_dfa A) (nfa_to_dfa B)).

(** MSO Primitives *)

Definition nfa_for_incl n X Y :=
  {| nfa_state := [finType of unit];
     nfa_s := setT;
     nfa_fin := setT;
     nfa_trans := fun p (v : vec n) q => nth false v X ==> nth false v Y |}.

Definition enfa_for_ltn n X Y : enfa (vec n) :=
  {| enfa_s := [set false];
     enfa_f := setT;
     enfa_trans := fun (c : option (vec n)) p q =>
                     match p,c,q with
                     | false, Some a, false => ~~ nth false a Y
                     | true, Some a, true => ~~ nth false a X
                     | false, None, true => true
                     | _,_,_ => false
                     end; |}.

Definition nfa_for_ltn n X Y := nfa_of (enfa_for_ltn n X Y).

(** Existential Quantification *)

Definition prj0 n (w : seq (vec n.+1)) : seq (vec n) :=
  map (fun v : vec (n.+1) => [tuple of behead v]) w.
Prenex Implicits prj0.

Definition trans_b0 n (A : nfa (vec n.+1)) (p q : A) :=
  [exists b, nfa_trans p [tuple of b :: nseq n false] q].
Arguments trans_b0 [n] A p q.

Definition nfa_for_ex n (A : nfa (vec n.+1)) : nfa (vec n) :=
  {| nfa_s := nfa_s A;
     nfa_fin := [set p | [exists (q | q \in nfa_fin A), connect (trans_b0 A) p q]];
     nfa_trans := fun p (v : vec n) q => [exists b, nfa_trans p [tuple of b::v] q] |}.

(** Translation to NFAs *)

Fixpoint nfa_of_form  n s {struct s} : nfa (vec n) :=
  match s with
  | Incl X Y => nfa_for_incl n X Y
  | Less X Y => nfa_for_ltn n X Y
  | FF => nfa_for_bot n
  | Imp s t => nfa_for_imp (nfa_of_form n s) (nfa_of_form n t)
  | Ex s => nfa_for_ex (nfa_of_form n.+1 s)
  end.

(** ** Correctness of the Translation *)

(** Correctness of Existential Quantification *)

Fixpoint glue (bs : seq bool) n (w : seq (vec n)) :=
  match bs,w with
  | b::bs,v::w => [tuple of b :: v] :: glue bs w
  | b::bs,[::] => [tuple of b :: nseq n false] :: glue bs [::]
  | nil,w => map (fun v : vec n => [tuple of false :: v]) w
  end.

Lemma nfa_for_exI n (A : nfa (vec n.+1)) b w :
  glue b w \in nfa_lang A -> w \in nfa_lang (nfa_for_ex A).
Proof.
  rewrite /nfa_lang !inE.
  case/exists_inP => s s1 s2. apply/exists_inP. exists s => //.
  elim: b w s {s1} s2 => [w p /=|b bs IH w p].
  - elim: w p => /= [|v w IHw] p.
    + rewrite /= inE => H. by apply/exists_inP; exists p.
    + apply: sub_exists => q /andP [q1 q2]. rewrite IHw // andbT.
     by apply/existsP;exists false.
  - case: w => [|v w] /=.
    + case/exists_inP => q q1 /IH /= q2. rewrite !inE in q2 *.
      apply: sub_exists q2 => r /andP [r1 r2].
      rewrite r1 (connect_trans (connect1 _) r2) // /trans_b0. by apply/existsP;exists b.
    + apply: sub_exists => q /andP [q1 q2]. rewrite IH // andbT. by apply/existsP;exists b.
Qed.

Lemma nfa_for_exE n (A : nfa (vec n.+1)) w :
  w \in nfa_lang (nfa_for_ex A) -> exists b : seq bool, glue b w \in nfa_lang A.
Proof.
  rewrite /nfa_lang /= !inE => H.
  suff S (q:A) : @nfa_accept _ (nfa_for_ex A) q w -> exists b, nfa_accept q (glue b w).
  { case/exists_inP : H => p p1 /S [b b1]. exists b. rewrite inE. by apply/exists_inP; exists p. }
  elim: w q {H} => [|v vs IH] q /=.
  - rewrite inE => /exists_inP [f f1 /connectP[p]].
    elim: p q => [x _ |p ps IHp q /= /andP [pth1 pth2]] /= E; first by exists nil; subst.
    case: (IHp _ pth2 E) => bs Hbs. case/existsP : pth1 => b pth1. exists (b::bs).
    by apply/exists_inP; exists p.
  - case/exists_inP => p /= /existsP [b p1] p2. case: (IH _ p2) => bs Hbs. exists (b::bs).
    by apply/exists_inP; exists p.
Qed.

Lemma size_glue b n (v : seq (vec n)) : size (glue b v) = maxn (size b) (size v).
Proof.
  elim: b v => [|b bs IH] v /=; first by rewrite max0n size_map.
  case: v => [|v vs]; by rewrite /= ?maxnSS IH ?maxn0.
Qed.

Lemma nth_glue0 b n (v : seq (vec n)) k :
  nth false (nth [tuple of nseq n.+1 false] (glue b v) k) 0 =
  nth false b k.
Proof.
  elim: k v b => [|k IH] [|v vs] [|b bs] //=.
  case: (ltnP k (size vs)) => A.
  - by rewrite (nth_map [tuple of nseq n false]) //.
  - by rewrite [_ _ _ k]nth_default // size_map.
Qed.

Lemma I_of_glue0 i b n (v : seq (vec n)) :
  i \in I_of (glue b v) 0 = nth false b i.
Proof.
  rewrite mem_filter mem_iota add0n leq0n andTb.
  rewrite nth_glue0 size_glue leq_max andbC.
  case: (ltnP i (size b)) => //= A. by rewrite nth_default ?andbF.
Qed.

Lemma nth_glueS b n (v : seq (vec n)) i k :
  nth false (nth [tuple of nseq n.+1 false] (glue b v) k) i.+1 =
  nth false (nth [tuple of nseq n false] v k) i.
Proof.
  elim: k v b => [|k IH] [|v vs] [|b bs] //=.
  - by rewrite IH !nth_nil nth_nseq if_same.
  - case: (ltnP k (size vs)) => A.
    + by rewrite (nth_map [tuple of nseq n false]).
    + by rewrite ![_ _ _ k]nth_default ?size_map.
Qed.

Lemma I_of_glueS i b n (v : seq (vec n)) k :
  i \in I_of (glue b v) k.+1 = nth false (nth [tuple of nseq n false] v i) k.
Proof.
  rewrite mem_filter mem_iota add0n leq0n andTb.
  rewrite nth_glueS size_glue leq_max andbC orbC.
  case: (ltnP i (size v)) => //= A.
  by rewrite [_ _ v i]nth_default // nth_nseq if_same andbF.
Qed.

Lemma vec_ex_glue s n (vs : seq (vec n)) :
  vec_lang (Ex s) vs -> exists bs, vec_lang s (glue bs vs).
Proof.
  rewrite /vec_lang /= => [[N sat_s]].
  exists [seq i \in N | i <- iota 0 (\max_(k <- N) k).+1].
  apply: weak_coincidence sat_s => X i.
  case: X => [|X].
  - rewrite I_of_glue0. case: (boolP (i < (\max_(k <- N) k).+1)) => ltn_max.
    + by rewrite (nth_map 0) ?size_iota // nth_iota.
    + rewrite nth_default ?size_map ?size_iota 1?leqNgt //.
      apply: contraNF ltn_max => H. rewrite ltnS. exact: bigmax_seq_sup H _ _.
  - rewrite I_of_glueS /= /I_of mem_filter mem_iota /= add0n.
    case: (ltnP i (size vs)) => H; first by rewrite andbT.
    rewrite andbF [nth _ _ i]nth_default //.
    by rewrite nth_nseq if_same.
Qed.

Lemma vec_lang0 s n (v : seq (vec n)) k :
  vec_lang s v <-> vec_lang s (v ++ nseq k [tuple of nseq n false]).
Proof.
  apply coincidence => X ? i. rewrite !mem_filter !mem_iota /= !add0n size_cat nth_cat.
  case: (boolP (i < size v)) => Hi; first by rewrite ltn_addr.
  by rewrite andbF !(nth_nseq,if_same).
Qed.

Lemma prj_glue bs n (v : seq (vec n)) :
  exists k, prj0 (glue bs v) = v ++ nseq k [tuple of nseq n false].
Proof.
  exists (size bs - size v). elim: bs v => [|b bs IH] v /=.
  - rewrite /prj0 -map_comp cats0 map_id_in //= => b. by rewrite !tupleE behead_cons.
  - case: v => [| v vs] /=; by rewrite IH /= ?subn0 ?subss !tupleE behead_cons.
Qed.

Lemma vec_Ex_prj0 s n (w : word (vec n.+1)) : vec_lang s w -> vec_lang (Ex s) (prj0 w).
Proof.
  rewrite /vec_lang => /= A.
  exists [seq i <- iota 0 (size w) | nth false (nth [tuple of nseq n.+1 false] w i) 0].
  apply: weak_coincidence A => X i. rewrite mem_filter mem_iota add0n /= /cons.
  case: X => [|X].
  + by rewrite mem_filter mem_iota /= add0n.
  + rewrite mem_filter mem_iota add0n size_map /prj0 andTb -nth_behead.
    (case: (boolP (i < _)); rewrite ?andbF ?andbT //) => A. congr nth.
      by erewrite nth_map.
Qed.

Lemma nfa_for_ex_correct n s (A : nfa (vec n.+1)) v:
  (forall u, reflect (vec_lang s u) (u \in nfa_lang A)) ->
  reflect (vec_lang (Ex s) v) (v \in nfa_lang (nfa_for_ex A)).
Proof.
  move => IHs. apply: (iffP idP).
  + case/nfa_for_exE => b. move/IHs. move/vec_Ex_prj0.
    case: (prj_glue b v) => k ->. by rewrite -vec_lang0.
  + case/vec_ex_glue => b. move/IHs. exact: nfa_for_exI.
Qed.

(** Correctness of the NFAs for the primitive operations *)

Lemma nfa_for_incl_correct X Y n (v : seq (vec n)):
  reflect (vec_lang (Incl X Y) v) (v \in nfa_lang (nfa_for_incl n X Y)).
Proof.
  rewrite /nfa_lang inE. apply: (equivP existsP).
  rewrite (_ : (exists _,_) <-> nfa_accept (tt : nfa_for_incl n X Y) v); last first.
  - split => [[x]|];[case: x|exists tt]; by rewrite inE.
  - rewrite (_ : vec_lang _ _ <-> (forall u, u \in v -> nth false u X -> nth false u Y)).
    + elim: v => //= v vs IH. split.
      * case/exists_inP => [[/implyP A] /IH B] u /predU1P []; first by move=>?;subst.
        exact: B.
      * move => A. apply/exists_inP; exists tt;[apply/implyP|].
        -- apply: A; exact: mem_head.
        -- apply/IH => u Hu. apply: A. by rewrite inE Hu orbT.
    + rewrite /vec_lang /=. split.
      * move => A u in_v u_X.
        set i := index u v.
        move: (A i). rewrite /I_of !mem_filter !mem_iota !add0n /=.
        rewrite index_mem in_v !andbT. rewrite nth_index //. by apply.
      * move => A => k. rewrite /I_of !mem_filter !mem_iota !add0n /=.
        case: (boolP (_ < _)); rewrite ?andbT ?andbF // => B.
        set u := nth [tuple of nseq n false] v k.
        apply A. by rewrite mem_nth.
Qed.

Definition zero_at n X := forall (v : vec n), nth false v X = false.

Lemma nfa_for_ltnP {X Y n} {v : seq (vec n)} :
  reflect (exists v1 v2, [/\ v = v1 ++ v2, {in v1,zero_at n Y} & {in v2,zero_at n X}])
          (v \in nfa_lang (nfa_for_ltn n X Y)).
Proof.
  move: v => v0. apply: (iffP (nfa_ofP _ _)).
  - rewrite /enfa_lang => [[[|_]]]; first by rewrite inE.
    suff S q v:
      enfa_accept (N := enfa_for_ltn n X Y) q v ->
      if q
      then {in v, zero_at n X}
      else (exists v1 v2, [/\ v = v1 ++ v2, {in v1,zero_at n Y} & {in v2,zero_at n X}]).
    { by move/S. }
    elim => // {v0 v} [||].
    + case => // _. by do 2 exists nil.
    + move => [|] a [|] //= v.
      * move => A _ B u. case/predU1P => [->|]; by [rewrite (negbTE A)| apply: B].
      * move => A _ [v1] [v2] [C D E].
        exists (a :: v1); exists v2; split => //; first by rewrite C.
        apply/forall_cons. split => //. by rewrite (negbTE A).
    + move => [|] [|] // v. by exists nil; exists v.
  - move => [v1] [v2] [->] A B. exists false; first by rewrite inE.
    elim: v1 A => /= [_|a v1 IH A].
    + (apply: EnfaNone; first instantiate (1 := true)) => //.
      elim: v2 B {v0} => [_|a s IH B].
      * constructor. by rewrite inE.
      * (apply: EnfaSome; first instantiate (1 := true)) => //=.
        -- by rewrite B ?inE ?eqxx.
        -- apply: IH => u C. apply B. by rewrite inE C orbT.
    + apply: EnfaSome; first instantiate (1 := false).
      * by rewrite /= A ?inE ?eqxx.
      * apply IH => u C. apply A. by rewrite inE C orbT.
Qed.

Lemma mem_I_of n (v : seq (vec n)) X k :
  (k \in I_of v X) = (k < size v) && nth false (nth [tuple of nseq n false] v k) X.
Proof. by rewrite mem_filter mem_iota add0n /= andbC. Qed.

Lemma nfa_for_ltn_correct X Y n (v : seq (vec n)):
  reflect (vec_lang (Less X Y) v) (v \in nfa_lang (nfa_for_ltn n X Y)).
Proof.
  apply: (iffP nfa_for_ltnP).
  - move => [v1] [v2] [A B C] i j.
    rewrite /I_of !mem_filter !mem_iota !add0n /= ![_ && (_ < _)]andbC.
    case: (boolP (_ < _)) => //= D. case: (boolP (_ < _)) => //= E F G.
    have Hi : i < size v1.
    { move: F. rewrite A nth_cat. case: (ifP _) => // /negbT H.
      rewrite C ?mem_nth //. rewrite -leqNgt in H.
      by rewrite -subSn // leq_subLR -size_cat -A. }
    have : size v1 <= j.
    { move: G. rewrite A nth_cat. case: (ltnP j (size v1)) => // H.
      by rewrite B ? mem_nth. }
    exact: leq_trans.
  - rewrite /vec_lang /= => A.
    case: (boolP (has predT (I_of v X))).
    + case/hasP => x0 /max_mem k_in_X _.
      set k := (\max_(i <- I_of v X) i) in k_in_X.
      have size_k: k < size v by move: k_in_X; rewrite mem_I_of => /andP[].
      have size_tk: size (take k.+1 v) = k.+1.
      { rewrite size_take.
        case: (ltnP k.+1 (size v)) size_k => // H1 H2.
        apply/eqP. by rewrite eqn_leq H1 H2. }
      exists (take k.+1 v); exists (drop k.+1 v); split; first by rewrite cat_take_drop.
      * move => u B. apply/negbTE/negP => D.
        pose i := index u (take k.+1 v).
        have E: i <= k by rewrite -ltnS -size_tk index_mem B.
        move: (A k i). case/(_ _ _)/Wrap => //; last by rewrite leqNgt ltnS E.
        rewrite mem_I_of (leq_ltn_trans E size_k) /=.
        rewrite /i index_take // nth_index //. exact: mem_take B.
      * move => u B. apply/negbTE/negP => D.
        pose i := k.+1 + index u (drop k.+1 v).
        have i_in_X : i \in I_of v X.
        { rewrite mem_I_of.
          rewrite -[v](cat_take_drop k.+1) size_cat size_tk.
          rewrite -addnS leq_add2l index_mem B andTb.
          rewrite nth_cat size_tk leqNgt leq_addr /= /i.
          by rewrite addnC -addnBA // subnn addn0 nth_index. }
        have: i <= k by apply: bigmax_seq_sup i_in_X _ _.
        by rewrite /i addSn -ltn_subRL subnn.
    + move/hasPn => /= B. exists [::], v; split => // u in_v.
      apply/negbTE/negP => D.
      pose i := index u v. move: (B i). case/(_ _)/Wrap => //.
      by rewrite mem_I_of index_mem in_v nth_index.
Qed.

Theorem nfa_of_form_correct n (v : seq (n.-tuple bool)) s :
  reflect (vec_lang s v) (v \in nfa_lang (nfa_of_form n s)).
Proof.
  elim: s n v => [X Y|X Y||s IHs t IHt|s IHs] /= n v.
  - exact: nfa_for_incl_correct.
  - exact: nfa_for_ltn_correct.
  - rewrite -dfa_to_nfa_correct in_simpl (negbTE (dfa_void_correct _ _)).
    by constructor.
  - rewrite -dfa_to_nfa_correct dfa_op_correct -!nfa_to_dfa_correct.
    by apply: (iffP implyP) => A /IHs/A/IHt.
  - exact: nfa_for_ex_correct.
Qed.

(** Greatest number used in first n variables *)
Definition lim I n := \max_(X < n) \max_(n <- I X) n.

Definition vec_of_val I n : seq (n.-tuple bool) :=
  [seq [tuple i \in I X | X < n] | i <- iota 0 (lim I n).+1].

Lemma vec_of_val_agrees : forall I n, agree n I (I_of (vec_of_val I n)).
Proof.
  move => I n X lt_n i.
  rewrite mem_filter mem_iota /= add0n size_map size_iota.
  case: (boolP (i < _)); rewrite ?(andbT,andbF) => A.
  + rewrite /vec_of_val.
    rewrite (nth_map 0) ?size_iota // nth_iota // add0n.
    by rewrite (nth_map (Ordinal lt_n)) ?size_enum_ord ?nth_enum_ord.
  + apply: contraNF A => A. rewrite ltnS. rewrite /lim.
    apply: bigmax_sup => //. instantiate (1 := Ordinal lt_n) => /=.
    exact: bigmax_seq_sup A _ _ .
Qed.

Lemma vec_of_valP I s : satisfies I s <-> satisfies (I_of (vec_of_val I (bound s))) s.
Proof. apply: coincidence. exact: vec_of_val_agrees. Qed.

Corollary satisfies_dec I s : decidable (satisfies I s).
Proof. apply: dec_iff (vec_of_valP I s).  exact: decP (nfa_of_form_correct _ _). Qed.

Corollary mso_dec s : decidable (exists I, satisfies I s).
Proof.
  pose n := bound s.
  case: (nfa_inhabP (nfa_of_form n s)) => A;[left|right].
  - case: A => w /(@nfa_of_form_correct n) Hw. by exists (I_of w).
  - move => [I sat_I_s]. apply A.
    exists (vec_of_val I n). apply/nfa_of_form_correct.
    by rewrite /vec_lang -vec_of_valP.
Qed.

Corollary vec_lang_regular n s : regular (@vec_lang n s).
Proof.
  apply/nfa_regular. exists (nfa_of_form n s) => x.
  apply: rwP. exact: nfa_of_form_correct.
Qed.

(** ** Regularity of the Language of an MSO formula *)

Corollary mso_regular (char: finType) s : regular (@mso_lang char s).
Proof.
  apply: regular_ext (mso_preim s).
  exact: preim_regular (@vec_of_hom _) (vec_lang_regular _ _).
Qed.

(** ** Translation from NFAs to WMSO *)

(** In order to translate NFAs to formulas, we define a number of defined
operations on top of the minimal syntax employed above. In particular, we make
use of the fact that [satisfies I s] is decidable and, hence, the logic behaves
classically. *)

Notation "I |= s" := (satisfies I s) (at level 50).

(** Propositional Connectives *)

Lemma satNNPP I s : ~ ~ I |= s -> I |= s.
Proof. case: (satisfies_dec I s); tauto. Qed.

Notation "s --> t" := (Imp s t) (at level 49, right associativity).
Definition Not s := Imp s FF.

Lemma satDN I s : I |= Not (Not s) <-> I |= s.
Proof. move: (@satNNPP I s) => /= ; tauto. Qed.

Lemma sat_imp I s t : I |= Imp s t <-> (I |= s -> I |= t).
Proof. done. Qed.

Lemma sat_not I s : I |= Not s <-> ~ I |= s.
Proof. done. Qed.

Definition TT := FF --> FF.

Lemma sat_true I : I |= TT.
Proof. done. Qed.

Definition And s t := Not (Imp s (Not t)).
Notation "s :/\: t" := (And s t) (at level 45).

Lemma sat_and I s t : I |= And s t <-> (I |= s /\ I |= t).
Proof.
  rewrite /And /Not /=. split => [A|]; last tauto.
  split; apply: satNNPP; tauto.
Qed.

Definition Or s t := Not s --> t.
Notation "s :\/: t" := (Or s t) (at level 47).

Lemma sat_or I s t : I |= s :\/: t <-> I |= s \/ I |= t.
Proof. rewrite /Or /Not /=. split;[case: (satisfies_dec I s)|];tauto. Qed.

Opaque And Or.

Definition Iff s t := (s --> t) :/\: (t --> s).
Notation "s <--> t" := (Iff s t) (at level 50).

Definition All s := Not (Ex (Not s)).

Lemma sat_all I s :
  I |= All s <-> (forall N, satisfies (cons N I) s).
Proof.
  split => [A N|A].
  - apply: satNNPP => B. apply: A. by exists N.
  - case: (satisfies_dec I (Ex (Not s))) => //= [[N B]].
    exfalso. exact: B.
Qed.

Opaque All.

(** Emptiness and Singletons *)

Definition empty X := All (Incl (X.+1) 0).

Lemma sat_empty I X :
  I |= empty X <-> I X =i pred0.
Proof.
  rewrite sat_all; split => [/= /(_ [::]) A k|A N k]; last by rewrite A.
  rewrite inE. apply: negbTE. apply/negP. by move/A.
Qed.

Lemma sat_emptyN I X :
  I |= Not (empty X) <-> (exists n, n \in I X).
Proof.
  rewrite satDN; split => [[N]|] /=.
  - case: (I X) => [|x IX _].
    + by case/(_ _)/Wrap.
    + by exists x; rewrite mem_head.
  - case => n A. exists [:: n.+1]. move/(_ _ A). by rewrite inE ltn_eqF.
Qed.

Definition single X := Not(empty X) :/\: All (Not(empty 0) --> Incl 0 X.+1 --> Incl X.+1 0).

Lemma sat_singles I X :
  I |= single X <-> exists n, I X =i [:: n].
Proof.
  rewrite sat_and sat_emptyN. split.
  - move => [[n A] B].
    exists n. move => m. rewrite inE. apply/idP/eqP => [H|-> //].
    move/sat_all/(_ [:: n]): B. rewrite 2!sat_imp. case/(_ _ _)/Wrap.
    + rewrite sat_emptyN. exists n. by rewrite inE.
    + move => k /=. by rewrite inE => /eqP->.
    + move/(_ _ H). by rewrite inE => /eqP->.
  - case => n A. split; first by exists n;rewrite A mem_head.
    apply/sat_all => N. rewrite 2!sat_imp sat_emptyN => /= [[k Hk] D] m E.
    move: (D _ Hk). rewrite A inE => /eqP ?; subst.
    rewrite A inE in E. by rewrite (eqP E).
Qed.

(** Big Operators *)

Notation "\or_ ( i <- r ) F" := (\big [Or/FF]_(i <- r)  F)
  (at level 42, F at level 42, i at level 0,
    format "'[' \or_ ( i  <-  r ) '/ '  F ']'").

Notation "\or_ ( i \in A ) F" := (\big [Or/FF]_(i <- enum A)  F)
  (at level 42, F at level 42, i at level 0,
    format "'[' \or_ ( i  \in  A ) '/ '  F ']'").

Notation "\and_ ( i <- r ) F" := (\big [And/TT]_(i <- r)  F)
  (at level 41, F at level 41, i at level 0,
    format "'[' \and_ ( i  <-  r ) '/ '  F ']'").

Notation "\and_ ( i \in A ) F" := (\big [And/TT]_(i <- enum A)  F)
 (at level 41, F at level 41, i at level 0,
 format "'[' \and_ ( i  \in  A ) '/ '  F ']'").

Lemma sat_orI (T:eqType) (s : seq T) x F I :
  x \in s -> I |= F x -> I |= \or_(i <- s) F i.
Proof. elim: s => // a s IH /predU1P [<-|/IH A]; rewrite big_cons sat_or; tauto. Qed.

Lemma sat_orE (T:eqType) (s : seq T) F I :
  I |= \or_(i <- s) F i -> exists2 x, x \in s & I |= F x.
Proof.
  elim: s => // [|a s IH]; first by rewrite big_nil.
  rewrite big_cons sat_or. case => [A|/IH [x A B]]; first by exists a => //; exact: mem_head.
  exists x => //. by rewrite inE A orbT.
Qed.

Lemma sat_bigand (T:eqType) (s : seq T) F I :
  I |= \and_(i <- s) F i <-> forall x, x \in s -> I |= F x.
Proof.
  elim: s => [|a s IH]; first by rewrite big_nil; split => // _; apply.
  rewrite big_cons sat_and IH. split => [[A B]x/predU1P[->//|]|A]. exact: B.
  split => [|x B]; apply: A; by rewrite ?mem_head // inE B orbT.
Qed.

(** First-order Quantification *)
(** Note that "first-order" variables are interpreted as one-element lists
rather than directly as numbers. Hence we need the lemmas [seq1P] and [sub1P] *)

Definition All1 s := All (single 0 --> s).

Lemma sat_all1 I s :
  I |= All1 s <-> (forall n, cons [:: n] I |= s).
Proof.
  rewrite sat_all; split.
  - move => H n. move: (H [:: n]) => {H} /=. apply. rewrite sat_singles. by exists n.
  - move => H N. rewrite sat_imp sat_singles => [[n Hn]].
    apply: weak_coincidence (H n). by case.
Qed.

Definition Ex1 s := Ex (single 0 :/\: s).

Lemma sat_ex1 I s :
  I |= Ex1 s <-> (exists n, cons [:: n] I |= s).
Proof.
  rewrite /Ex1; split.
  - case => N. rewrite -/satisfies => /sat_and [/sat_singles [n] /= B C]. exists n.
    apply: weak_coincidence C. by case.
  - case => n A. exists [:: n]. apply/sat_and;split => //.
    apply/sat_singles. by exists n.
Qed.

(* Successor relation and Zero Predicate *)

Lemma nat_succ x y : y = x.+1 <-> x < y /\ ~ exists k, x < k /\ k < y.
Proof.
  split.
  - move => ->. rewrite leqnn. split=>//.
    move => [k] [A B]. move:(leq_trans A B). by rewrite ltnn.
  - move => [A B]. apply/eqP. rewrite eqn_leq leqNgt A andbT.
    apply/negP. apply: impliesPn B. constructor.
    exists x.+1. by rewrite leqnn H.
Qed.

Definition succ X Y :=
  Less X Y :/\: Not (Ex1 (Less X.+1 0 :/\: Less 0 Y.+1)).

Lemma sat_succ I X x Y y : I X =i [:: x] -> I Y =i [:: y] ->
  I |= succ X Y <-> y = x.+1.
Proof.
  move => A B. rewrite sat_and sat_not sat_ex1 nat_succ.
  split => [[C D]|[C D]].
  - split; first apply C; rewrite ?A ?B ?mem_head //.
    apply: impliesPn D; constructor => [[k [k1 k2]]]. exists k.
    rewrite sat_and /=; split => ? ?; by rewrite ?A ?B => /seq1P-> /seq1P->.
  - split. move => ? ? ; by rewrite ?A ?B => /seq1P-> /seq1P->.
    apply: impliesPn D; constructor => [[k] /sat_and [k1 k2]]. exists k.
    split; [apply k1|apply k2]; by rewrite /= ?A ?B ?mem_head.
Qed.

Definition zero X := single X :/\: Not (Ex1 (succ 0 X.+1)).

Lemma sat_zero I X : I X =i [:: 0] <-> I |= zero X.
Proof.
  rewrite sat_and sat_singles sat_not sat_ex1.
  split.
  - move => A. split; first by exists 0.
    move => [n]. move/sat_succ. move/(_ 0 n) => /=. by case/(_ _ _)/Wrap.
  - move => [[n A] B] k. rewrite A !inE.
    suff S : n == 0. apply/idP/idP => /eqP->; by rewrite // eq_sym.
    destruct n as [|n] => //. exfalso. apply B.
    exists n. by rewrite (sat_succ (x := n) (y := n.+1)).
Qed.

Definition Leq X Y := All1 (succ Y.+1 0 --> Less X.+1 0).

Lemma sat_leq I X x Y y : I X =i [:: x] -> I Y =i [:: y] ->
  I |= Leq X Y <-> x <= y.
Proof.
  move => A B. rewrite sat_all1. split.
  - move/(_ y.+1). rewrite sat_imp. case/(_ _)/Wrap.
    + by rewrite (sat_succ (x := y) (y := y.+1)).
    + move/(_ x y.+1). rewrite /= A !inE ltnS. by apply.
  - move => C n. rewrite sat_imp. rewrite (sat_succ (x := y) (y := n)) // => ->.
    move => ? ? /=. rewrite A !inE => /eqP-> /eqP->. by rewrite ltnS.
Qed.

(** Iterated existential quantification *)

Definition cat (Ns: seq (seq nat)) I :=
  fun x => if x < size Ns then nth [::] Ns x else I (x - size Ns).

Lemma cat_prefix I n (Ns : n.-tuple (seq nat)) X : X < n -> cat Ns I X = nth [::] Ns X.
Proof. move => A. by rewrite /cat size_tuple A. Qed.

Lemma cat_beyond I n (Ns : n.-tuple (seq nat)) X : n <= X -> cat Ns I X = I (X - n).
Proof. move => A. by rewrite /cat size_tuple ltnNge A. Qed.

Lemma cat_size I n (Ns : n.-tuple (seq nat)) : cat Ns I n = I 0.
Proof. by rewrite cat_beyond ?subnn. Qed.

Definition exn n s := iter n Ex s.

Lemma sat_exn n s I :
  (I |= exn n s) <-> (exists Ns : n.-tuple (seq nat), cat Ns I |= s).
Proof.
  elim: n I => [|n IH] I.
  - split.
    + exists [tuple]. rewrite /cat /=. apply: weak_coincidence H => X. by rewrite subn0.
    + case => Ns. rewrite tuple0 /cat /=.
      apply: weak_coincidence => X. by rewrite subn0.
  - have agr Ns N X : cat (rcons Ns N) I X =i cat Ns (cons N I) X.
      { rewrite /cat /= !size_rcons ltnS.
        case: (ltngtP X (size Ns)) => B.
        (* use ? and try to preserve compatibility with mathcomp-1.6.x *)
        * by rewrite ?(ltnW B) nth_rcons B.
        * try rewrite leqNgt B /=.
          by rewrite -[X - size Ns]prednK ?subn_gt0 //= subnS.
        * by rewrite ?B ?leqnn ?subnn nth_rcons ltnn eqxx. }
    rewrite /=. split => [[N] /IH [Ns A]|].
    + exists [tuple of rcons Ns N]. apply: weak_coincidence A => X k. by rewrite agr.
    + case. case => Ns /=. elim/last_ind : Ns => // Ns N _.
      rewrite size_rcons eqSS =>  A B.
      exists N. apply/IH. exists (Tuple A) => /=.
      exact: weak_coincidence _ B.
Qed.

Section NFAtoMSO.
  Variables (T : finType) (A : nfa T).
  Let n := #|A|.
  Notation rank := enum_rank.
  Notation val := enum_val.

  Definition max :=
    All1 (Less 0 1 <--> \or_(a \in T) Incl 0 (rank a).+2).

  Lemma sat_max (w : word T)  m :
    cons [:: m] (I_of (vec_of w)) |= max <-> m = size w.
  Proof.
    split.
    - move/sat_all1 => B.
      apply/eqP. rewrite eqn_leq [_ <= m]leqNgt [m <= _]leqNgt.
      apply/andP; split; apply/negP => C.
      + case: m C B => // m C /(_ m). case/sat_and => [/sat_imp B _]. move: B.
        case/(_ _)/Wrap; first by move => ? ? /seq1P-> /seq1P->.
        case/sat_orE => a _ /= /sub1P /I_of_vev_max => D. rewrite ltnS in C.
        move: (leq_trans D C). by rewrite ltnn.
      + move/(_ m) : B. case/sat_and => _. move/sat_imp.
        case/(_ _)/Wrap.
        * set a := (tnth (in_tuple w) (Ordinal C)).
          apply: (sat_orI (x := a)); first by rewrite mem_enum.
          apply/sub1P => /=. by rewrite I_of_vecP // {2}/a (tnth_nth a).
        * move/(_ m m) => /=. rewrite !mem_head ltnn. by case/(_ _ _)/Wrap.
    - move->.
      rewrite sat_all1 => k.
      rewrite sat_and; split.
      + rewrite /= => H.
        move: H => /(_ k (size w) (mem_head _ _) (mem_head _ _)) => H.
        pose a0 := tnth (in_tuple w) (Ordinal H).
        apply (sat_orI (x := nth a0 w k)); first by rewrite mem_enum.
        rewrite /= => ? /seq1P->. by rewrite I_of_vecP ?(set_nth_default a0).
      + case/sat_orE => a _ /sub1P /=.
        rewrite /vec_of /I_of mem_filter => /andP [_].
        by rewrite mem_iota add0n size_map /= => H ? ? /seq1P-> /seq1P->.
  Qed.

  Definition part X :=
    All1 (Leq 0 X.+1 -->
          (\or_(q \in A) (Incl 0 (rank q).+1 :/\:
                        \and_(q' \in [pred x | q != x]) Not (Incl 0 (rank q').+1)))).

  Lemma sat_part X I k :
    I X =i [:: k] ->
    I |= part X <-> forall n, n <= k -> exists! q:A, n \in I (rank q).
  Proof.
    move => H0. split.
    - move => H1 m Hm. move/sat_all1 : H1 => /(_ m) /sat_imp. case/(_ _)/Wrap.
      + rewrite sat_leq ; first apply Hm; done.
      + case/sat_orE => q _ /sat_and [/= /sub1P q1 /sat_bigand q2].
        exists q; split => // q' B. apply/eqP. apply/negPn/negP => C.
        apply: (q2 q'); by [rewrite mem_enum inE|apply/sub1P].
    - move => H1.
      apply/sat_all1 => m. rewrite sat_imp => /sat_leq H2.
      have/H1 {H2} : m <= k by apply: H2.
      case => q [q1 q2]. apply: (sat_orI (x := q)); first by rewrite mem_enum.
      rewrite sat_and; split; first by move => ? /seq1P ->.
      apply/sat_bigand => q'. rewrite mem_enum inE => qq' /sub1P /q2 ?.
      subst. by rewrite eqxx in qq'.
  Qed.

  (* forall y x -> succ(x,y) -> x < max -> \or_( ... ) ... *)
  (*        1 0                                            *)
  Definition run X : form :=
    All1 (All1(succ 0 1 --> Less 0 X.+2 -->
               \or_(paq \in [pred x : A * T * A | nfa_trans x.1.1 x.1.2 x.2])
               let: (p,a,q) := paq in
                    Incl 0 ((rank a).+1 + X).+2 (* a at pos x *)
               :/\: Incl 0 (rank p).+2     (* state p active at time x *)
               :/\: Incl 1 (rank q).+2     (* state q is next state of run *)
         )).

  Lemma sat_run (Ns : n.-tuple (seq nat)) m I :
    cat Ns (cons [:: m] I) |= run n <->
    (forall k, k < m -> exists (p:A) (a:T) (q:A), nfa_trans p a q /\
                                       k \in I (rank a) /\
                                       k \in tnth Ns (rank p) /\
                                       k.+1 \in tnth Ns (rank q)).
  Proof.
    split.
    - move => H k lt_m. move/sat_all1/(_ k.+1) : H. move/sat_all1/(_ k).
      rewrite 2!sat_imp. case/(_ _ _)/Wrap.
      + by apply/(sat_succ (x := k) (y := k.+1)).
      + move => /= ? y /seq1P ->. rewrite cat_beyond // subnn /=.
        by move/seq1P->.
      + case/sat_orE => [[[p a] q]]. rewrite mem_enum inE /= => B.
        rewrite !sat_and. (do 2 case) => /= /sub1P C /sub1P D /sub1P E.
        exists p, a, q. repeat split => //.
        * by rewrite cat_beyond ?leq_addl -?addnBA // subnn addn0 in C.
        * by rewrite cat_prefix // -tnth_nth in D.
        * by rewrite cat_prefix // -tnth_nth in E.
    - move => H. apply/sat_all1 => k'. apply/sat_all1 => k. rewrite !sat_imp => B C.
      move/sat_succ : B => /(_ k' k). case/(_ _ _)/Wrap => // ?;subst.
      case: (H _ (C k m _ _)); rewrite /= ?cat_size /= ?mem_head //.
      move => p [a] [q] [paq [D [E F]]].
      apply: (sat_orI (x := (p,a,q))); first by rewrite mem_enum.
      rewrite !sat_and; repeat split.
      + apply/sub1P. rewrite /= cat_beyond ?leq_addl //.
        by rewrite -addnBA // subnn addn0.
      + apply/sub1P. by rewrite /= cat_prefix // -tnth_nth.
      + apply/sub1P. by rewrite /= cat_prefix // -tnth_nth.
  Qed.

  Definition init : form :=
    All1 (zero 0 --> \or_(q \in nfa_s A) Incl 0 (rank q).+1).

  Lemma sat_init (Ns : n.-tuple (seq nat)) I :
    cat Ns I |= init <-> exists2 q, q \in nfa_s A & 0 \in tnth Ns (rank q).
  Proof.
    split.
    - move/sat_all1/(_ 0)/sat_imp. case/(_ _)/Wrap; first exact/sat_zero.
      case/sat_orE => s. rewrite mem_enum /= => B /sub1P C. exists s => //.
      by rewrite cat_prefix // -tnth_nth in C.
    - case => q q1 q2. apply/sat_all1 => m. rewrite sat_imp. move/sat_zero => /= B.
      have -> : m = 0. move: (B 0). by rewrite !inE eqxx => /eqP.
      apply (sat_orI (x := q)); first by rewrite mem_enum.
      apply/sub1P. by rewrite /= cat_prefix -?tnth_nth.
  Qed.

  Definition accept X := \or_(q \in nfa_fin A) Incl X (rank q).

  Lemma sat_accept (Ns : n.-tuple (seq nat)) m I :
    cat Ns (cons [:: m] I) |= accept n <->
    exists2 q, q \in nfa_fin A & m \in tnth Ns (rank q).
  Proof.
    split.
    - case/sat_orE => q.
      rewrite mem_enum /= cat_size ?cat_prefix // -tnth_nth.
      move => B /sub1P C. by exists q.
    - case => q q1 q2. apply: (sat_orI (x := q)); first by rewrite mem_enum.
      rewrite /= cat_size ?cat_prefix // -tnth_nth. exact/sub1P.
  Qed.

  (** underneath of [exn], [#|A|] refers to the length of the word (i.e. "max") *)
  Definition form_of :=
    Ex1 (max :/\: exn #|A| (
      part #|A| :/\: init :/\: run #|A| :/\: accept #|A|)).

  Theorem form_ofP w : reflect (@mso_lang T form_of w) (w \in nfa_lang A).
  Proof.
    apply: (iffP nfaP).
    - move =>[s] [r] [r1 r2].
      rewrite /mso_lang /vec_lang sat_ex1. exists (size w).
      set I' := cons _ _.
      have Hmax : I' |= max by apply/sat_max.
      rewrite sat_and sat_exn. split => //.
      pose pos (i : 'I_#|A|) := [seq n <- iota 0 (size r).+1 | nth s (s::r) n == enum_val i].
      pose t := [tuple pos i | i < #|A|].
      exists t.
      have tP k N (i : 'I_#|A|) :
        k \in nth N t i = (k <= size r) && (nth s (s::r) k == val i).
      { by rewrite -tnth_nth tnth_mktuple mem_filter mem_iota /= add0n ltnS andbC. }
      rewrite !sat_and; repeat split.
      + apply/(sat_part (k := (size w))). by rewrite cat_size.
        move => k Hk. exists (nth s (s::r) k) ;split.
        * by rewrite cat_prefix // tP -(run_size r2) Hk enum_rankK eqxx.
        * move => q'. rewrite cat_prefix //.
          rewrite tP -(run_size r2) Hk enum_rankK. by move/eqP.
      + apply/sat_init. exists s => //. by rewrite tP /= enum_rankK.
      + apply/sat_run => k Hk. have Hk': k < size r by rewrite -(run_size r2).
        exists (nth s (s::r) k),
               (tnth (in_tuple w) (Ordinal Hk)),
               (nth s (s :: r) k.+1). repeat split.
        * exact: run_trans.
        * rewrite I_of_vecP //. set X := tnth _ _. by rewrite {2}/X (tnth_nth X).
        * by rewrite tP ltnW // enum_rankK eqxx.
        * by rewrite tP enum_rankK Hk' eqxx.
      + apply/sat_accept. exists (last s r); first exact: run_last r2.
        rewrite tP. by rewrite (run_size r2) leqnn enum_rankK nth_last /=.
    - rewrite /mso_lang /vec_lang sat_ex1 => [[m] /sat_and [/sat_max B /sat_exn [Ns]]].
      repeat case/sat_and. subst. set I' := cat _ _.
      move => /sat_part B /sat_init [s s1 s2] /sat_run D /sat_accept E.
      move: {B} (B (size w)).
      case/(_ _)/Wrap => [k|B]; first by rewrite /I' cat_size.
      have exP (i : 'I_(size w)) : exists q : A, i.+1 \in I' (rank q).
      { case: (B i.+1)=> // q [q1 q2]. by exists q. }
      exists s. pose r := [tuple xchoose (exP i) | i < size w]. exists r. split => //.
      have tP k p : k <= size w -> k \in tnth Ns (rank p) -> nth s (s::r) k = p.
      { case: k => [_|k lt_w] H /=.
        - case: (B 0 _) => // q' [q1 q2].
          by rewrite -[p]q2 -1?[s]q2 // /I' cat_prefix // -tnth_nth.
        - rewrite (nth_map (Ordinal lt_w)) ?size_enum_ord //.
          set m := nth _ _ _. move: (exP _) => F. move: (xchooseP F) => G.
          case: (B m.+1 _) => // q' [q1 q2].
          rewrite -[xchoose F]q2 -1?[p]q2 //.
          rewrite /I' cat_prefix // -tnth_nth.
          by rewrite /m nth_enum_ord.
      }
      apply: runI.
      + by rewrite size_tuple.
      + case: E => f f1 f2. rewrite (_ : last s r = f) //.
        by rewrite (last_nth s) size_tuple (tP _ _ _ f2).
      + move => i. move: (D _ (ltn_ord i)) => [p] [a] [q] [pq [Ha [Hp Hq]]].
        rewrite I_of_vecP // in Ha. rewrite (tnth_nth a) (eqP Ha) //.
        by rewrite (tP _ _ _ Hp) 1?ltnW // (tP _ _ _ Hq).
  Qed.

End NFAtoMSO.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.
Qed.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.

Qed.

Lemma qreva_nil : forall (x y : lst), qreva x y = append (qreva x Nil) y.
Proof.
   intro.
   induction x.
   - intros. simpl. rewrite IHx. rewrite (IHx (Cons n Nil)). rewrite append_assoc. reflexivity.
   - reflexivity.

Qed.

Lemma qreva_append : forall (x y : lst), qreva (append x y) Nil = append (qreva y Nil) (qreva x Nil).
Proof.
   intros.
   induction x.
   - simpl. lfind. Admitted.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith List Wellfounded Extraction.

Set Implicit Arguments.

Definition eqdec X := forall x y : X, { x = y } + { x <> y }.

Definition swap {X Y} (c : X * Y) := let (x,y) := c in (y,x).

Tactic Notation "eq" "goal" hyp(H) :=
  match goal with
    |- ?b => match type of H with ?t => replace b with t; auto end
  end.

Ltac eqgoal := let H := fresh in intro H; eq goal H; clear H.

Tactic Notation "spec" "in" hyp(H) :=
  let Q := fresh
  in match goal with G: ?h -> _ |- _ =>
       match G with
         | H => assert (h) as Q; [ | specialize (H Q); clear Q ]
       end
     end.

Ltac solve_list_eq := simpl; repeat progress (try rewrite app_ass; try rewrite <- app_nil_end; simpl; auto); auto.

Tactic Notation "solve" "list" "eq" := solve_list_eq.

Tactic Notation "solve_list_eq" "in" hyp(H) := generalize H; clear H; solve_list_eq; intro H.
(* Tactic Notation "solve" "list" "eq" "in" hyp(H) := generalize H; clear H; solve_list_eq; intro H. *)

Tactic Notation "solve" "list" "eq" "in" hyp(H) :=
   let Q := fresh in
   match goal with
     |- ?t => set (Q := t); generalize H; clear H; solve_list_eq; intro H; unfold Q; clear Q
   end.

Ltac msplit n :=
  match n with
    | 0    => idtac
    | S ?n => split; [ | msplit n ]
   end.

Ltac lsplit n :=
  match n with
    | 0    => idtac
    | S ?n => split; [ lsplit n | ]
   end.

Fact equal_equiv (P Q : Prop) : P = Q -> P <-> Q.
Proof. intros []; tauto. Qed.

Section forall_equiv.

  Variable (X : Type) (A P Q : X -> Prop) (HPQ : forall n, A n -> P n <-> Q n).

  Theorem forall_bound_equiv : (forall n, A n -> P n) <-> (forall n, A n -> Q n).
  Proof using HPQ.
    split; intros H n Hn; generalize (H _ Hn); apply HPQ; auto.
  Qed.

End forall_equiv.

Section exists_equiv.

  Variable (X : Type) (P Q : X -> Prop) (HPQ : forall n, P n <-> Q n).

  Theorem exists_equiv : (exists n, P n) <-> (exists n, Q n).
  Proof using HPQ.
    split; intros (n & Hn); exists n; revert Hn; apply HPQ; auto.
  Qed.

End exists_equiv.

Section measure_rect_123.

  Section measure_rect.

    Variable (X : Type) (m : X -> nat) (P : X -> Type).

    Hypothesis F : forall x, (forall y, m y < m x -> P y) -> P x.

    Definition measure_rect x : P x.
    Proof using F.
      cut (Acc (fun x y => m x < m y) x).
      + revert x.
        refine (fix loop x H := @F x (fun x' H' => loop x' _)).
        apply (Acc_inv H), H'.
      + apply wf_inverse_image with (f := m), lt_wf.
    Defined.

  End measure_rect.

  Section measure_rect2.

    Variable (X Y : Type) (m : X -> Y -> nat) (P : X -> Y -> Type).

    Hypothesis F : forall x y, (forall x' y', m x' y' < m x y -> P x' y') -> P x y.

    Let m' (c : X * Y) := match c with (x,y) => m x y end.
    Let R c d := m' c < m' d.

    Definition measure_rect2 x y : P x y.
    Proof using F R.
      cut (Acc R (x,y)).
      + revert x y.
        refine (fix loop x y H := @F x y (fun x' y' H' => loop x' y' _)).
        apply (Acc_inv H), H'.
      + apply wf_inverse_image with (f := m'), lt_wf.
    Defined.

  End measure_rect2.

  Section measure_rect3.

    Variable (X Y Z : Type) (m : X -> Y -> Z -> nat) (P : X -> Y -> Z -> Type).

    Hypothesis F : forall x y z, (forall x' y' z', m x' y' z' < m x y z -> P x' y' z') -> P x y z.

    Let m' (c : X * Y * Z) := match c with (x,y,z) => m x y z end.
    Let R c d := m' c < m' d.

    Definition measure_rect3 x y z : P x y z.
    Proof using F R.
      cut (Acc R (x,y,z)).
      + revert x y z.
        refine (fix loop x y z H := @F x y z (fun x' y' z' H' => loop x' y' z' _)).
        apply (Acc_inv H), H'.
      + apply wf_inverse_image with (f := m'), lt_wf.
    Defined.

  End measure_rect3.

End measure_rect_123.

Extraction Inline measure_rect measure_rect2 measure_rect3.

Tactic Notation "induction" "on" hyp(x) "as" ident(IH) "with" "measure" uconstr(f) :=
  pattern x; revert x; apply measure_rect with (m := fun x => f); intros x IH.

Tactic Notation "induction" "on" hyp(x) hyp(y) "as" ident(IH) "with" "measure" uconstr(f) :=
  pattern x, y; revert x y; apply measure_rect2 with (m := fun x y => f); intros x y IH.

Tactic Notation "induction" "on" hyp(x) hyp(y) hyp(z) "as" ident(IH) "with" "measure" uconstr(f) :=
  pattern x, y, z; revert x y z; apply measure_rect3 with (m := fun x y z => f); intros x y z IH.


From Coq Require Import
  Arith
  Bool
  List
  ZArith.

Class EqDec (A : Type) := { eq_dec (x y : A) : {x = y} + {x <> y}; }.

Definition eqb {A} `{EqDec A} (x y : A) : bool :=
  if eq_dec x y then true else false.

Module Import EqDecNotations.
  Infix "==" := eq_dec (at level 70).
  Infix "==?" := eqb (at level 70).
End EqDecNotations.

Fact eq_dec_true A `{EqDec} x y (T E : A) : x = y -> (if x == y then T else E) = T.
Proof. now destruct (_ == _). Qed.

Fact eq_dec_false A `{EqDec} x y (T E : A) : x <> y -> (if x == y then T else E) = E.
Proof. now destruct (_ == _). Qed.

Corollary eqb_true `{EqDec} x y : x = y -> x ==? y = true.
Proof. intros; unfold eqb; rewrite eq_dec_true; auto. Qed.

Corollary eqb_false `{EqDec} x y : x <> y -> x ==? y = false.
Proof. intros; unfold eqb; rewrite eq_dec_false; auto. Qed.

Ltac simplify_eq_dec :=
  repeat match goal with
         | H: context[_ == _] |- _ =>
           first [rewrite eq_dec_true in H by auto
                 | rewrite eq_dec_false in H by auto]
         | |- context[_ == _] =>
           first [rewrite eq_dec_true by auto
                 | rewrite eq_dec_false by auto]
         | H: context[_ ==? _] |- _ =>
           first [rewrite eqb_true in H by auto
                 | rewrite eqb_false in H by auto]
         | |- context[_ ==? _] =>
           first [rewrite eqb_true by auto
                 | rewrite eqb_false by auto]
         end.

#[export] Instance nat_eq_dec : EqDec nat := {| eq_dec := Nat.eq_dec |}.
#[export] Instance Z_eq_dec : EqDec Z := {| eq_dec := Z.eq_dec |}.
#[export] Instance bool_eq_dec : EqDec bool := {| eq_dec := bool_dec |}.
#[export] Instance list_eq_dec {A} `{eq : EqDec A} : EqDec (list A) := {|
  eq_dec := list_eq_dec eq_dec
|}.
#[refine, export] Instance option_eq_dec {A} `{eq : EqDec A} : EqDec (option A) := {|
  eq_dec := fun x y =>
    match x, y with
    | Some x, Some y => if eq_dec x y then left _ else right _
    | None, None => left eq_refl
    | _, _ => right _
    end
|}.
Proof. all: abstract congruence. Defined.


(* Adapt xp, variable and path of nats from the thesis in the TLC style. *)

Set Implicit Arguments.
Require Import TLC.LibTactics TLC.LibReflect TLC.LibBool TLC.LibOperation TLC.LibRelation TLC.LibOrder  TLC.LibNat TLC.LibVar.

Require Export LibPath.

(* ********************************************************************** *)

Definition varpath := (prod var path).

(* Inhabited and comparable *)

Instance varpath_inhab : Inhab varpath.
Proof using.
 intros.
 lets P: (var_fresh \{}).
 inversion P.
 apply (prove_Inhab (x, (cons 0 nil))).
Qed.

Fixpoint varpath_compare (x y : varpath) :=
  match x, y with
    | (x,xp), (y, yp) =>
      If x = y then
       (If xp = yp then true else false)
    else false
  end.

Instance varpath_comparable : Comparable varpath.
Proof using.
  applys (comparable_beq varpath_compare).
  induction x; destruct y; simpl; autos*; auto_false.
  destruct (classicT (a = v)); destruct (classicT (b = p)); split;
  intros; subst; try solve [auto | inversion H | congruence].
Qed.

(* Not in Theorems and Tactics. *)

(* ********************************************************************** *)
(** ** Tactics for notin *)

(* Can I and must I generalize x here? *)
(** For efficiency, we avoid rewrites by splitting equivalence. *)

(* BGM Turning off for debugging overlap.
Implicit Types x : varpath.

Lemma notin_singleton_r : forall x y,
  x \notin \{y} -> x <> y.
Proof using. intros. rewrite~ <- notin_singleton. Qed.

Lemma notin_singleton_l : forall x y,
  x <> y -> x \notin \{y}.
Proof using. intros. rewrite~ notin_singleton. Qed.

Lemma notin_singleton_swap : forall x y,
  x \notin \{y} -> y \notin \{x}.
Proof using.
  intros. apply notin_singleton_l.
  apply sym_not_eq. apply~ notin_singleton_r.
Qed.

Lemma notin_union_r : forall x E F,
  x \notin (E \u F) -> (x \notin E) /\ (x \notin F).
Proof using. intros. rewrite~ <- notin_union. Qed.

Lemma notin_union_r1 : forall x E F,
  x \notin (E \u F) -> (x \notin E).
Proof using. introv. rewrite* notin_union. Qed.

Lemma notin_union_r2 : forall x E F,
  x \notin (E \u F) -> (x \notin F).
Proof using. introv. rewrite* notin_union. Qed.

Lemma notin_union_l : forall x E F,
  x \notin E -> x \notin F -> x \notin (E \u F).
Proof using. intros. rewrite~ notin_union. Qed.

(* Bug.
Lemma notin_var_gen : forall E F,
  (forall x, x \notin E -> x \notin F) ->
  (var_gen E) \notin F.
Proof using. intros. autos~ var_gen_spec. Qed.
*)

Implicit Arguments notin_singleton_r    [x y].
Implicit Arguments notin_singleton_l    [x y].
Implicit Arguments notin_singleton_swap [x y].
Implicit Arguments notin_union_r  [x E F].
Implicit Arguments notin_union_r1 [x E F].
Implicit Arguments notin_union_r2 [x E F].
Implicit Arguments notin_union_l  [x E F].

(** Tactics to deal with notin.  *)

Ltac notin_solve_target_from x E H :=
  match type of H with
  | x \notin E => constr:(H)
  | x \notin (?F \u ?G) =>
     let H' :=
        match F with
        | context [E] => constr:(notin_union_r1 H)
        | _ => match G with
          | context [E] => constr:(notin_union_r2 H)
          | _ => fail 20
          end
        end in
     notin_solve_target_from x E H'
  end.

Ltac notin_solve_target x E :=
  match goal with
  | H: x \notin ?L |- _ =>
    match L with context[E] =>
      let F := notin_solve_target_from x E H in
      apply F
    end
  | H: x <> ?y |- _ =>
     match E with \{y} =>
       apply (notin_singleton_l H)
     end
  end.

Ltac notin_solve_one :=
  match goal with
  | |- ?x \notin \{?y} =>
     apply notin_singleton_swap;
     notin_solve_target y (\{x})
  | |- ?x \notin ?E =>
    notin_solve_target x E
  (* If x is an evar, tries to instantiate it.
     Problem: it might loop !
  | |- ?x \notin ?E =>
     match goal with y:var |- _ =>
       match y with
       | x => fail 1
       | _ =>
         let H := fresh in cuts H: (y \notin E);
         [ apply H | notin_solve_target y E ]
        end
     end
  *)
  end.

Ltac notin_simpl :=
  match goal with
  | |- _ \notin (_ \u _) => apply notin_union_l; notin_simpl
  | |- _ \notin (\{}) => apply notin_empty; notin_simpl
  | |- ?x <> ?y => apply notin_singleton_r; notin_simpl
  | |- _ => idtac
  end.

Ltac notin_solve_false :=
  match goal with
  | H: ?x \notin ?E |- _ =>
    match E with context[x] =>
      apply (@notin_same _ x);
      let F := notin_solve_target_from x (\{x}) H in
      apply F
    end
  | H: ?x <> ?x |- _ => apply H; reflexivity
  end.

Ltac notin_false :=
  match goal with
  | |- False => notin_solve_false
  | _ => intros_all; false; notin_solve_false
  end.

Ltac notin_from_fresh_in_context :=
  repeat (match goal with H: fresh _ _ _ |- _ =>
    progress (simpl in H; destructs H) end).

Ltac notin_solve :=
  notin_from_fresh_in_context;
  first [ notin_simpl; try notin_solve_one
        | notin_false ].

Hint Extern 1 (_ \notin _) => notin_solve.
Hint Extern 1 (_ <> _ :> var) => notin_solve.
Hint Extern 1 ((_ \notin _) /\ _) => splits.

*)


(* 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 colimits.
Require Export little_cat.
Require Export fc_limits.
Require Export cardinal.

Module Fiprod.
Export Finite_Cat.
Export Limit.
Export Vee_Cat.

Definition fiprod_hypothesis a u v y1 y2 :=
vee_hypothesis a u v &
mor a y1 & mor a y2
& source u = target y1 &
source v = target y2 &
source y1 = source y2 &
comp a u y1 = comp a v y2.

Definition fiprod_cone a u v y1 y2 :=
cone_create (source y1) (vee_nt a
(id a (source y1)) (id a (source y2)) u v y1
(comp a u y1) y2).

Lemma vertex_fiprod_cone : forall a u v y1 y2,
vertex (fiprod_cone a u v y1 y2) = source y1.
Proof.
ir. uf fiprod_cone.
rw vertex_cone_create. tv.
Qed.

Lemma edge_nt_fiprod_cone : forall a u v y1 y2,
edge_nt (fiprod_cone a u v y1 y2) =
(vee_nt a
(id a (source y1)) (id a (source y2)) u v
y1
(comp a u y1) y2).
Proof.
ir. uf fiprod_cone.
rw edge_nt_cone_create. tv.
Qed.

Lemma edge_fiprod_cone_R : forall a u v y1 y2 (x:obsy vee_data),
edge (fiprod_cone a u v y1 y2) (R x) =
match x with
o1 => y1 | o2 => (comp a u y1) | o3 => y2
end.
Proof.
ir.
uf edge.
rw edge_nt_fiprod_cone.
rw ntrans_vee_nt_R. tv.
Qed.

Lemma socle_fiprod_cone : forall a u v y1 y2,
socle (fiprod_cone a u v y1 y2) = vee_functor a u v.
Proof.
ir. uf socle.
rw edge_nt_fiprod_cone.
rw target_vee_nt. tv.
Qed.

Lemma cone_source_fiprod_cone : forall a u v y1 y2,
cone_source (fiprod_cone a u v y1 y2) = vee_cat.
Proof.
ir. uf cone_source.
rw socle_fiprod_cone. rww source_vee_functor.
Qed.

Lemma cone_target_fiprod_cone : forall a u v y1 y2,
cone_target (fiprod_cone a u v y1 y2) = a.
Proof.
ir. uf cone_target.
rw socle_fiprod_cone. rww target_vee_functor.
Qed.

Lemma fiprod_vee_nt_hypothesis : forall a u v y1 y2,
fiprod_hypothesis a u v y1 y2 ->
vee_nt_hypothesis a (id a (source y1))
(id a (source y2)) u v y1
  (comp a u y1) y2.
Proof.
ir. uh H; ee.
uh H; ee.
assert (ob a (source y1)). rww ob_source.
assert (ob a (target y1)). rww ob_target.
assert (ob a (source y2)). rww ob_source.
assert (ob a (target y2)). rww ob_target.

uhg; ee.

uh H; ee; am.
app mor_id.
app mor_id. am. am. am.
rww mor_comp. am. rww source_id. sy; am.
rww source_comp. rww target_id.
rww target_comp. rww source_id. sy; am.
rww H4. am.
rww assoc.
rww right_id. app mor_id.  rww target_id.

rww assoc. rww right_id. app mor_id.
rww target_id.
Qed.

Lemma is_cone_fiprod_cone : forall a u v y1 y2,
fiprod_hypothesis a u v y1 y2 ->
is_cone (fiprod_cone a u v y1 y2).
Proof.
ir. uhg; ee.
uf fiprod_cone.
ap cone_like_cone_create.
rw edge_nt_fiprod_cone.
ap vee_nt_axioms.
app fiprod_vee_nt_hypothesis.
rw cone_target_fiprod_cone.
rw vertex_fiprod_cone. uh H; ee. rww ob_source.

rw edge_nt_fiprod_cone.
rw source_vee_nt.
rw cone_source_fiprod_cone.
rw cone_target_fiprod_cone.
rw vertex_fiprod_cone. sy;
rw constant_functor_vee_functor.
uh H; ee. rww H4.
tv.
uh H; ee. rww ob_source.
Qed.

Definition fimap1 c := edge c (R o1').

Definition fimap2 c := edge c (R o3').

Lemma source_fimap1 : forall c,
is_cone c -> cone_source c = vee_cat ->
source (fimap1 c) =  vertex c.
Proof.
ir. uf fimap1.  rww source_edge.
rw H0. app ob_vee_cat.
Qed.

Lemma source_fimap2 : forall c,
is_cone c -> cone_source c = vee_cat ->
source (fimap2 c) =  vertex c.
Proof.
ir. uf fimap2. rww source_edge.
rw H0. app ob_vee_cat.
Qed.

Lemma fiprod_hypothesis_fimaps :
forall a u v c, vee_hypothesis a u v ->
is_cone c -> socle c = vee_functor a u v ->
fiprod_hypothesis a u v (fimap1 c) (fimap2 c).
Proof.
ir.
assert (a = cone_target c).
uf cone_target. rw H1. rw target_vee_functor.
tv.
assert (cone_source c = vee_cat).
uf cone_source. rw H1.
rww source_vee_functor.
uhg. ee. am.
uf fimap1.
rw H2. ap mor_edge.
rw H3. ap ob_vee_cat.
am.
uf fimap2.
rw H2. ap mor_edge.
rw H3. ap ob_vee_cat.
am.
uf fimap1. rw target_edge.
rw H1.
rw fob_vee_functor_R. tv. am.
rw H3. ap ob_vee_cat. am.
uf fimap2.  rw target_edge.
rw H1.
rw fob_vee_functor_R. tv. am.
rw H3. ap ob_vee_cat. am.

uf fimap1. uf fimap2.
rw source_edge. rw source_edge. tv.
rw H3. ap ob_vee_cat. am.
rw H3. ap ob_vee_cat. am.

set (k:= edge_nt c).
util (vee_nt_ntrans (u:=k)).
uf k. app edge_nt_axioms.
uf k. rww osource_edge_nt.
assert (otarget k = a).
uf k. rww otarget_edge_nt. sy; am.
assert
(fmor (source k) (catyd_arrow (d:=vee_data) a12') =
id a (vertex c)).
uf k.
rw source_edge_nt.
rw fmor_constant_functor. wr H2. tv.
rw H3. ap mor_vee_cat. am.

assert
(fmor (source k) (catyd_arrow (d:=vee_data) a32') =
id a (vertex c)).
uf k.
rw source_edge_nt.
rw fmor_constant_functor. wr H2. tv.
rw H3. ap mor_vee_cat. am.

assert
(fmor (target k) (catyd_arrow (d:=vee_data) a12') = u).
uf k.
rw target_edge_nt.
rw H1. rw fmor_vee_functor_catyd_arrow.
tv. am.

assert
(fmor (target k) (catyd_arrow (d:=vee_data) a32') = v).
uf k.
rw target_edge_nt.
rw H1. rw fmor_vee_functor_catyd_arrow.
tv. am.

util (vee_nt_hypothesis_ntrans (u:=k)).
uf k. app edge_nt_axioms. uf k.
rw osource_edge_nt. am. am.
rwi H6 H10.
rwi H5 H10. rwi H7 H10. rwi H8 H10.
rwi H9 H10.

assert (ntrans k (R o1') = (fimap1 c)).
uf fimap1. uf edge.
tv.

assert (ntrans k (R o3') = (fimap2 c)).
uf fimap2. uf edge.
tv.

rwi H11 H10.
set (m:= ntrans k (R o2')).
assert (m = ntrans k (R o2')). tv. rwi H12 H10.
wri H13 H10. uh H10; ee.
wr H29. wr H30.
reflexivity.
Qed.

Lemma fiprod_cone_eq : forall a u v c,
vee_hypothesis a u v ->
is_cone c -> socle c = vee_functor a u v ->
c = fiprod_cone a u v (fimap1 c) (fimap2 c).
Proof.
ir.
assert (a = cone_target c).
uf cone_target. rw H1. rw target_vee_functor.
tv.
assert (cone_source c = vee_cat).
uf cone_source. rw H1.
rww source_vee_functor.

set (k:= edge_nt c).
util (vee_nt_ntrans (u:=k)).
uf k. app edge_nt_axioms.
uf k. rww osource_edge_nt.
assert (otarget k = a).
uf k. rww otarget_edge_nt. sy; am.
assert
(fmor (source k) (catyd_arrow (d:=vee_data) a12') =
id a (vertex c)).
uf k.
rw source_edge_nt.
rw fmor_constant_functor. wr H2. tv.
rw H3. ap mor_vee_cat. am.

assert
(fmor (source k) (catyd_arrow (d:=vee_data) a32') =
id a (vertex c)).
uf k.
rw source_edge_nt.
rw fmor_constant_functor. wr H2. tv.
rw H3. ap mor_vee_cat. am.

assert
(fmor (target k) (catyd_arrow (d:=vee_data) a12') = u).
uf k.
rw target_edge_nt.
rw H1. rw fmor_vee_functor_catyd_arrow.
tv. am.

assert
(fmor (target k) (catyd_arrow (d:=vee_data) a32') = v).
uf k.
rw target_edge_nt.
rw H1. rw fmor_vee_functor_catyd_arrow.
tv. am.

rwi H5 H4. rwi H6 H4. rwi H7 H4. rwi H8 H4.
rwi H9 H4.

transitivity (cone_create (vertex c) k).
uh H0; ee. uh H0; ee.
sy; am.
uf fiprod_cone.
rw source_fimap1.
rw source_fimap2.
ap uneq. wr H4.

assert (lem1 : ntrans k (R o1') = (fimap1 c)).
uf fimap1. uf edge.
tv.
assert (lem2 : ntrans k (R o3') = (fimap2 c)).
uf fimap2. uf edge.
tv.
assert (ntrans k (R o2') = comp a u (fimap1 c)).
uf fimap1.

util (vee_nt_hypothesis_ntrans (u:=k)).
uf k. app edge_nt_axioms. uf k.
rw osource_edge_nt. am. am.
rwi H6 H10.
rwi H5 H10. rwi H7 H10. rwi H8 H10.
rwi H9 H10.

rwi lem1 H10. rwi lem2 H10.
set (m:= ntrans k (R o2')).
assert (m = ntrans k (R o2')). tv. wri H11 H10.
uh H10; ee. uf edge.
change (m=comp a u (ntrans k (R o1'))).
rw lem1. wr H27.
rw right_id. tv. rw H2. app ob_vertex.
am. rw H21. rw target_id. tv.
rw H2; app ob_vertex. tv.

rw lem1. rw lem2. rw H10. reflexivity. am.
am. am. am.
Qed.

Lemma fimap1_fiprod_cone : forall a u v y1 y2,
fimap1 (fiprod_cone a u v y1 y2) = y1.
Proof.
ir.
uf fimap1.
rw edge_fiprod_cone_R. tv.
Qed.

Lemma fimap2_fiprod_cone : forall a u v y1 y2,
fimap2 (fiprod_cone a u v y1 y2) = y2.
Proof.
ir.
uf fimap2.
rw edge_fiprod_cone_R. tv.
Qed.

Lemma fimap1_cone_compose : forall c z,
is_cone c -> cone_source c = vee_cat ->
cone_composable c z ->
fimap1 (cone_compose c z) =
(comp (cone_target c) (fimap1 c) z).
Proof.
ir.
uf fimap1.
rw edge_cone_compose. tv.
rw H0. ap ob_vee_cat. am.
Qed.

Lemma fimap2_cone_compose : forall c z,
is_cone c -> cone_source c = vee_cat ->
cone_composable c z ->
fimap2 (cone_compose c z) =
(comp (cone_target c) (fimap2 c) z).
Proof.
ir.
uf fimap2.
rw edge_cone_compose. tv.
rw H0. ap ob_vee_cat. am.
Qed.

Definition veefirst c :=
(fmor (socle c) (catyd_arrow (d:=vee_data) a12')).
Definition veesecond c :=
(fmor (socle c) (catyd_arrow (d:=vee_data) a32')).

Lemma fiprod_hypothesis_vee_fimaps : forall c,
is_cone c -> cone_source c = vee_cat ->
fiprod_hypothesis (cone_target c) (veefirst c) (veesecond c)
(fimap1 c) (fimap2 c).
Proof.
ir. util (fiprod_hypothesis_fimaps (a:= cone_target c)
(u:= veefirst c) (v:= veesecond c) (c:=c)).
uf veefirst. uf veesecond.
uf cone_target. ap functor_vee_hypothesis.
app socle_axioms. am. am.
uf cone_target.
uf veefirst. uf veesecond. ap functor_vee_eq.
app socle_axioms. am.
am.
Qed.

Lemma fiprod_cone_eq2 : forall c,
is_cone c -> cone_source c = vee_cat ->
c = fiprod_cone (cone_target c) (veefirst c) (veesecond c)
(fimap1 c) (fimap2 c).
Proof.
ir.
util (fiprod_cone_eq (a:= cone_target c)
(u:= veefirst c) (v:= veesecond c) (c:=c)).
uf veefirst. uf veesecond.
uf cone_target. ap functor_vee_hypothesis.
app socle_axioms. am. am.
uf cone_target.
uf veefirst. uf veesecond. ap functor_vee_eq.
app socle_axioms. am.
am.
Qed.

Lemma fimaps_extensionality : forall a b,
is_cone a -> is_cone b -> cone_source a = vee_cat
-> socle a = socle b -> fimap1 a = fimap1 b ->
fimap2 a = fimap2 b -> a = b.
Proof.
ir.
assert (cone_source b = vee_cat).
uf cone_source. wr H2. am.
util (fiprod_cone_eq2 (c:= a)).
am. am.
util (fiprod_cone_eq2 (c:= b)).
am. am. rw H6; rw H7.
assert (veefirst a = veefirst b).
uf veefirst. rww H2.
assert (veesecond a = veesecond b).
uf veesecond. rw H2. reflexivity.
rw H3; rw H8; rw H9.
assert (cone_target a = cone_target b).
uf cone_target. rww H2. rw H10. rw H4.
reflexivity.
Qed.

Lemma cone_compose_fiprod_cone : forall a u v y1 y2 z,
fiprod_hypothesis a u v y1 y2 ->
mor a z -> source y1 = target z ->
cone_compose (fiprod_cone a u v y1 y2) z =
fiprod_cone a u v (comp a y1 z) (comp a y2 z).
Proof.
ir.

assert (lem1: fiprod_hypothesis a u v
(comp a y1 z) (comp a y2 z)).
uh H; uhg; ee. am. rww mor_comp.
rww mor_comp. wrr H6. rww target_comp.
rww target_comp. wrr H6.
rww source_comp. rww source_comp. wrr H6.

wr assoc.
rw H7. rww assoc. uh H; ee; am. wrr H6.
uh H; ee; am. am. am. am. am. tv.

assert (lem2 : cone_composable (fiprod_cone a u v y1 y2) z).
uhg; ee.
app  is_cone_fiprod_cone.
rww cone_target_fiprod_cone.
rww vertex_fiprod_cone. sy; am.

ap fimaps_extensionality.
rww is_cone_cone_compose.
app is_cone_fiprod_cone.
rw cone_source_cone_compose. rww cone_source_fiprod_cone.
rw socle_cone_compose.
rww socle_fiprod_cone. rww socle_fiprod_cone.
rww fimap1_cone_compose.
rww cone_target_fiprod_cone.
rww fimap1_fiprod_cone.
rww fimap1_fiprod_cone.
app is_cone_fiprod_cone.
rww cone_source_fiprod_cone.
rww fimap2_cone_compose.
rww cone_target_fiprod_cone.
rww fimap2_fiprod_cone.
rww fimap2_fiprod_cone.
app is_cone_fiprod_cone.
rww cone_source_fiprod_cone.
Qed.

Lemma cone_composable_fiprod_cone : forall a u v y1 y2 z,
fiprod_hypothesis a u v y1 y2 -> mor a z ->
source y1 = target z ->
cone_composable (fiprod_cone a u v y1 y2) z.
Proof.
ir. uhg; ee. app is_cone_fiprod_cone.
rww cone_target_fiprod_cone.
rww vertex_fiprod_cone. sy; am.
Qed.

Lemma is_uni_fiprod_cone : forall a u v y1 y2,
fiprod_hypothesis a u v y1 y2 ->
is_uni (fiprod_cone a u v y1 y2) =
(forall z z', mor a z -> mor a z' ->
source y1 = target z -> source y1 = target z' ->
comp a y1 z = comp a y1 z' ->
comp a y2 z = comp a y2 z'-> z = z').
Proof.
ir. ap iff_eq; ir.
uh H0. ee. ap H7.
app cone_composable_fiprod_cone.
app cone_composable_fiprod_cone.
rw cone_compose_fiprod_cone.
sy; rw cone_compose_fiprod_cone.
sy. rw H5. rw H6. tv. am. am. am. am. am. am.

uhg. ee. app is_cone_fiprod_cone.
ir.
cp H1; cp H2. uh H4; uh H5; ee.
rwi cone_target_fiprod_cone H8.
rwi cone_target_fiprod_cone H6.
rwi vertex_fiprod_cone H9.
rwi vertex_fiprod_cone H7.

app H0. sy; am. sy; am.
rwi cone_compose_fiprod_cone H3.
tv.
transitivity
(fimap1 (fiprod_cone a u v (comp a y1 u0) (comp a y2 u0))).
rw fimap1_fiprod_cone. tv.
rw H3.
rw fimap1_cone_compose.
rw cone_target_fiprod_cone.
rw fimap1_fiprod_cone. tv.
am. rww cone_source_fiprod_cone.
am. am. am. sy; am.

transitivity
(fimap2 (cone_compose (fiprod_cone a u v y1 y2) u0)).
rw cone_compose_fiprod_cone.
rw fimap2_fiprod_cone. tv. am. am. sy; am.
rw H3.
rw fimap2_cone_compose.
rw cone_target_fiprod_cone.
rw fimap2_fiprod_cone. tv.
am. rww cone_source_fiprod_cone.
am.
Qed.

Lemma is_versal_fiprod_cone : forall a u v y1 y2,
fiprod_hypothesis a u v y1 y2 ->
is_versal (fiprod_cone a u v y1 y2) =
(forall z1 z2, fiprod_hypothesis a u v z1 z2 ->
(exists w, (mor a w & source y1 = target w &
comp a y1 w = z1 & comp a y2 w = z2))).
Proof.
ir. ap iff_eq; ir.
uh H0; ee.
util (H2 (fiprod_cone a u v z1 z2)).
app is_cone_fiprod_cone.
rww socle_fiprod_cone; sy;
rww socle_fiprod_cone.
nin H3. ee.
cp H3. uh H5; ee.
rwi cone_target_fiprod_cone H6.
rwi vertex_fiprod_cone H7.
rwi cone_compose_fiprod_cone H4.
sh x; ee. am. sy; am.
transitivity
(fimap1 (fiprod_cone a u v (comp a y1 x) (comp a y2 x))).
rw fimap1_fiprod_cone. tv.
rw H4. rw fimap1_fiprod_cone. tv.

transitivity
(fimap2 (fiprod_cone a u v (comp a y1 x) (comp a y2 x))).
rw fimap2_fiprod_cone. tv.
rw H4. rw fimap2_fiprod_cone. tv. am. am. sy; am.

assert (lem1: fiprod_hypothesis a u v y1 y2).
am.
uh H; uhg; ee; try am. app is_cone_fiprod_cone.
ir.
rwi socle_fiprod_cone H8.
cp (fiprod_cone_eq H H7 H8).
cp (fiprod_hypothesis_fimaps H H7 H8).

util (H0 (fimap1 b) (fimap2 b)). am.
nin H11. ee. sh x; ee.
app cone_composable_fiprod_cone.
rww cone_compose_fiprod_cone. rw H13.
rw H14. sy; am.
Qed.

Definition is_fiprod a u v y1 y2 :=
fiprod_hypothesis a u v y1 y2 &
is_limit (fiprod_cone a u v y1 y2).

Lemma show_is_fiprod : forall a u v y1 y2 ,
fiprod_hypothesis a u v y1 y2 ->
(forall z z', mor a z -> mor a z' ->
source y1 = target z -> source y1 = target z' ->
comp a y1 z = comp a y1 z' -> comp a y2 z = comp a y2 z'
-> z = z') ->
(forall z1 z2, fiprod_hypothesis a u v z1 z2 ->
(exists w, (mor a w & source y1 = target w &
comp a y1 w = z1 & comp a y2 w = z2))) ->
is_fiprod a u v y1 y2.
Proof.
ir. uhg; ee. am.
uhg. ee. rww is_uni_fiprod_cone.
rww is_versal_fiprod_cone.
Qed.

Definition has_fiprod a u v :=
vee_hypothesis a u v &
has_limit (vee_functor a u v).

Lemma has_fiprod_rw : forall a u v,
has_fiprod a u v = (exists y1, exists y2, is_fiprod a u v y1 y2).
Proof.
ir. ap iff_eq; ir.
uh H; ee. uh H0.
nin H0. uh H0; ee. sh (fimap1 x).
sh (fimap2 x). uhg; ee.
ap fiprod_hypothesis_fimaps. am.
app is_limit_is_cone. am.

assert (is_cone x).
app is_limit_is_cone.
util (fiprod_cone_eq (a:=a) (u:=u) (v:=v) (c:=x)).
am. am. am.
wr H3. am.

nin H. nin H. uhg; ee.
uh H; ee. uh H; ee; am.
uh H; ee.
uhg.
sh (fiprod_cone a u v x x0).
uhg; ee. am.
rww socle_fiprod_cone.
Qed.

Definition has_fiprods a :=
Category.axioms a &
(forall u v, vee_hypothesis a u v ->
has_fiprod a u v).

Definition fipr1 a u v :=
fimap1 (limit (vee_functor a u v)).

Definition fipr2 a u v :=
fimap2 (limit (vee_functor a u v)).

Lemma fiprod_hypothesis_fiprod : forall a u v,
has_fiprod a u v ->
fiprod_hypothesis a u v (fipr1 a u v) (fipr2 a u v).
Proof.
ir. uf fipr1; uf fipr2.
app fiprod_hypothesis_fimaps.
uh H; ee; am.
ap is_limit_is_cone. ap is_limit_limit.
uh H; ee; am.
rw socle_limit. tv. uh H; ee; am.
Qed.

Lemma fiprod_hypothesis_comp : forall a u v y1 y2 z,
fiprod_hypothesis a u v y1 y2 -> mor a z ->
source y1 = target z  ->
fiprod_hypothesis a u v (comp a y1  z) (comp a y2 z).
Proof.
ir. uh H; uhg; ee. am. rww mor_comp.
rww mor_comp. wrr H6. rww target_comp.
rww target_comp. wrr H6.
rww source_comp. rww source_comp. wrr H6.
wrr assoc. rw H7. rww assoc.
uh H; ee. am. wrr H6. uh H; ee; am.
Qed.

Lemma is_fiprod_fiprod : forall a u v,
has_fiprod a u v ->
is_fiprod a u v (fipr1 a u v) (fipr2 a u v).
Proof.
ir. uhg; ee.
app fiprod_hypothesis_fiprod.
uf fipr1; uf fipr2.
wr fiprod_cone_eq.
ap is_limit_limit. uh H; ee; am.
uh H; ee. am.
ap is_limit_is_cone. ap is_limit_limit. uh H; ee; am.
rw socle_limit. tv. uh H; ee; am.
Qed.

Lemma has_fiprods_has_fiprod : forall a u v,
has_fiprods a -> vee_hypothesis a u v->
has_fiprod a u v.
Proof.
ir. uh H; ee. ap H1. am.
Qed.

Lemma has_fiprods_has_limits_over : forall a,
Category.axioms a ->
has_fiprods a = has_limits_over vee_cat a.
Proof.
ir. ap iff_eq; ir.
uhg. ir. uh H0. ee.
util (H4 (fmor f (catyd_arrow a12')) (fmor f (catyd_arrow a32'))).
wr H3. ap functor_vee_hypothesis. am.
am.
uh H5. ee. wri H3 H6.
rww functor_vee_eq.

uh H0. uhg; ee. am.
ir. uhg; ee; try am.
ap H0.
app vee_functor_axioms.
rww source_vee_functor.
rww target_vee_functor.
Qed.

Lemma mor_fipr1 : forall a u v,
has_fiprod a u v ->
mor a (fipr1 a u v).
Proof.
ir. cp (is_fiprod_fiprod H).
uh H0; ee.
uh H0; ee. am.
Qed.

Lemma mor_fipr2 : forall a u v,
has_fiprod a u v ->
mor a (fipr2 a u v).
Proof.
ir. cp (is_fiprod_fiprod H).
uh H0; ee.
uh H0; ee. am.
Qed.

Lemma target_fipr1 : forall a u v,
has_fiprod a u v ->
target (fipr1 a u v) = source u.
Proof.
ir. cp (is_fiprod_fiprod H).
uh H0; ee.
uh H0; ee. sy; am.
Qed.

Lemma target_fipr2 : forall a u v,
has_fiprod a u v ->
target (fipr2 a u v) = source v.
Proof.
ir. cp (is_fiprod_fiprod H).
uh H0; ee.
uh H0; ee. sy; am.
Qed.

Lemma source_fipr2 : forall a u v,
has_fiprod a u v ->
source (fipr2 a u v) = source (fipr1 a u v).
Proof.
ir. cp (is_fiprod_fiprod H).
uh H0; ee.
uh H0; ee. sy; am.
Qed.

Lemma comp_fiprod_eq : forall a u v,
has_fiprod a u v ->
comp a u (fipr1 a u v) = comp a v (fipr2 a u v).
Proof.
ir. cp (is_fiprod_fiprod H).
uh H0; ee.
uh H0; ee. am.
Qed.

Definition fipr_dotted a u v y1 y2 :=
dotted (fiprod_cone a u v y1 y2).

Lemma fiprod_cone_fiprod : forall a u v,
has_fiprod a u v ->
fiprod_cone a u v (fipr1 a u v) (fipr2 a u v) =
limit (vee_functor a u v).
Proof.
ir.
uf fipr1; uf fipr2.
wr fiprod_cone_eq. tv. uh H; ee; am.
ap is_limit_is_cone. ap is_limit_limit.
uh H; ee; am.
rw socle_limit. tv. uh H; ee; am.
Qed.

Lemma cone_composable_fipr_dotted : forall a u v y1 y2,
has_fiprod a u v -> fiprod_hypothesis a u v y1 y2 ->
cone_composable (fiprod_cone a u v (fipr1 a u v) (fipr2 a u v))
(fipr_dotted a u v y1 y2).
Proof.
ir.
uf fipr_dotted.
rw fiprod_cone_fiprod.
assert (vee_functor a u v =
socle (fiprod_cone a u v y1 y2)).
rww socle_fiprod_cone. rw H1.
ap cone_composable_dotted.
app is_cone_fiprod_cone.
rw socle_fiprod_cone. uh H; ee; am.
am.
Qed.

Lemma cone_compose_fipr_dotted : forall a u v y1 y2,
has_fiprod a u v -> fiprod_hypothesis a u v y1 y2 ->
cone_compose (fiprod_cone a u v (fipr1 a u v) (fipr2 a u v))
(fipr_dotted a u v y1 y2) = fiprod_cone a u v y1 y2.
Proof.
ir.
uf fipr_dotted.
rw fiprod_cone_fiprod.
assert (vee_functor a u v =
socle (fiprod_cone a u v y1 y2)).
rww socle_fiprod_cone. rw H1.
ap cone_compose_dotted.
app is_cone_fiprod_cone.
rw socle_fiprod_cone. uh H; ee; am. am.
Qed.

Lemma fipr_dotted_uni : forall a u v y1 y2 r,
has_fiprod a u v -> fiprod_hypothesis a u v y1 y2 ->
cone_composable (fiprod_cone a u v (fipr1 a u v) (fipr2 a u v)) r ->
cone_compose (fiprod_cone a u v (fipr1 a u v) (fipr2 a u v)) r =
fiprod_cone a u v y1 y2 ->
fipr_dotted a u v y1 y2 = r.
Proof.
ir. uf fipr_dotted.
wr H2.
rw fiprod_cone_fiprod. ap dotted_unique.
ap vee_functor_axioms. uh H0; ee; am.
uh H; ee; am.
wr fiprod_cone_fiprod. am. am. am.
Qed.

Lemma mor_fipr_dotted : forall a u v y1 y2,
has_fiprod a u v -> fiprod_hypothesis a u v y1 y2 ->
mor a (fipr_dotted a u v y1 y2).
Proof.
ir.
cp (cone_composable_fipr_dotted H H0).
uh H1; ee. rwi cone_target_fiprod_cone H2. am.
Qed.

Lemma target_fipr_dotted : forall a u v y1 y2,
has_fiprod a u v -> fiprod_hypothesis a u v y1 y2 ->
target (fipr_dotted a u v y1 y2) = source (fipr1 a u v).
Proof.
ir.
cp (cone_composable_fipr_dotted H H0).
uh H1; ee. rwi vertex_fiprod_cone H3. am.
Qed.

Lemma comp_fipr1_fipr_dotted : forall a u v y1 y2,
has_fiprod a u v -> fiprod_hypothesis a u v y1 y2 ->
comp a (fipr1 a u v) (fipr_dotted a u v y1 y2) = y1.
Proof.
ir.
cp (cone_compose_fipr_dotted H H0).
transitivity (fimap1 (fiprod_cone a u v y1 y2)).
wr H1.
rw fimap1_cone_compose.
rw cone_target_fiprod_cone.
rw fimap1_fiprod_cone. tv.
ap is_cone_fiprod_cone.

ap fiprod_hypothesis_fiprod. am.
rww cone_source_fiprod_cone.
app cone_composable_fipr_dotted.
rww fimap1_fiprod_cone.
Qed.

Lemma comp_fipr2_fipr_dotted : forall a u v y1 y2,
has_fiprod a u v -> fiprod_hypothesis a u v y1 y2 ->
comp a (fipr2 a u v) (fipr_dotted a u v y1 y2) = y2.
Proof.
ir.
cp (cone_compose_fipr_dotted H H0).
transitivity (fimap2 (fiprod_cone a u v y1 y2)).
wr H1.
rw fimap2_cone_compose.
rw cone_target_fiprod_cone.
rw fimap2_fiprod_cone. tv.
ap is_cone_fiprod_cone.
app fiprod_hypothesis_fiprod.
rww cone_source_fiprod_cone.
app cone_composable_fipr_dotted.
rww fimap2_fiprod_cone.
Qed.

Lemma fipr_dotted_comp : forall a u v z,
has_fiprod a u v -> mor a z ->
source (fipr1 a u v) = target z ->
fipr_dotted a u v (comp a (fipr1 a u v) z)
(comp a (fipr2 a u v) z) = z.
Proof.
ir.
assert (fiprod_hypothesis a u v (fipr1 a u v) (fipr2 a u v)).
app fiprod_hypothesis_fiprod.
ap fipr_dotted_uni. am.
app fiprod_hypothesis_comp.
uhg; ee. app is_cone_fiprod_cone.
rww cone_target_fiprod_cone.
rww vertex_fiprod_cone. sy; am.
rw cone_compose_fiprod_cone. tv.
am. am. am.
Qed.

(*** now we apply the result of fc_limits to
the case of fiprods ***********************)

Lemma has_fiprods_functor_cat : forall a b,
Category.axioms a -> has_fiprods b ->
has_fiprods (functor_cat a b).
Proof.
ir. rw has_fiprods_has_limits_over.
cp H0.
uh H1; ee.
rwi has_fiprods_has_limits_over H0.
ap has_limits_functor_cat. am. am.
ap vee_cat_axioms. am. am.
ap functor_cat_axioms. am.
uh H0; ee; am.
Qed.

Lemma has_finite_limits_has_fiprods : forall a,
has_finite_limits a ->  has_fiprods a.
Proof.
ir. rw has_fiprods_has_limits_over.
uh H; ee. ap H0.
ap is_finite_vee_cat. uh H; ee; am.
Qed.

End Fiprod.

Export Fiprod.

(*** we should be able to more or less recopy fiprod to
get a module Fiprod for fiber products; then also
dualize to get cofiprods and cofiber products. The other
main type of limits and colimits we need to do are direct
products and coproducts ... *****************************)

Module Cofiprod.

(**** we do this module by dualizing the module
fiprod, rather than by relying on colimits *******)

Definition covee_hypothesis a u v :=
mor a u & mor a v &
source u = source v.

Definition cofiprod_hypothesis a u v y1 y2 :=
covee_hypothesis a u v &
mor a y1 & mor a y2 & source y1 = target u &
source y2 = target v &
comp a y1 u = comp a y2 v.

Lemma cofi_hyp_fi_hyp : forall a u v y1 y2,
Category.axioms a ->
cofiprod_hypothesis a u v y1 y2 =
fiprod_hypothesis (opp a) (flip u) (flip v) (flip y1) (flip y2).
Proof.
ir. ap iff_eq; ir.
uh H0; uhg; ee.
uh H0; uhg; ee.
rww mor_opp. rww flip_flip.
rww mor_opp. rww flip_flip.
rw target_flip. rw target_flip.
am. alike. alike.
rww mor_opp. rww flip_flip.
rw mor_opp; rww flip_flip.
rw target_flip; try alike.
rw source_flip; try alike. sy; am. uh H0; ee; alike.
rw target_flip; try alike.
rw source_flip; try alike. sy; am. uh H0; ee; alike.
rw source_flip; try alike.
rw source_flip; try alike.
transitivity (target (comp a y1 u)).
rw target_comp. tv. am. uh H0; ee; am. am.
rw H5. rww target_comp. uh H0; ee; am.

rw comp_opp.
rw comp_opp. rw flip_flip.
rw flip_flip. rw flip_flip. rw flip_flip. ap uneq. am.
rww mor_opp; rww flip_flip.
uh H0; ee; am.
rww mor_opp; rww flip_flip.
rww target_flip; try alike.
rww source_flip; try alike.
uh H0; ee. sy; am.
uh H0; ee; alike.
rww mor_opp; rww flip_flip.
uh H0; ee; am.
rww mor_opp; rww flip_flip.
rww target_flip; try alike.
rww source_flip; try alike.
sy; am. uh H0; ee; alike.

uh H0; ee. uh H0; ee.
uhg; dj. uhg; dj. rwi mor_opp H0.
rwi flip_flip H0. am.
rwi mor_opp H7.
rwi flip_flip H7. am.
wr target_flip; try alike.
rw H8. rw target_flip; try alike. tv.
rwi mor_opp H1. rwi flip_flip H1; am.
rwi mor_opp H2. rwi flip_flip H2; am.

wr source_flip; try alike. rw H3.
rww target_flip; try alike.
rwi mor_opp H0.
rwi flip_flip H0. alike.  wr target_flip; try alike.
wr H4. uh H9; ee.
rww source_flip; try alike.

rwi comp_opp H6. rwi flip_flip H6.
rwi flip_flip H6. ap flip_eq.
rw H6.
rw comp_opp. rw flip_flip. rw flip_flip. tv.
am. am. am. am. am. am.
Qed.

Definition is_cofiprod a u v y1 y2 :=
Category.axioms a &
is_fiprod (opp a) (flip u) (flip v) (flip y1) (flip y2).

Lemma show_is_cofiprod : forall a u v y1 y2,
Category.axioms a ->
cofiprod_hypothesis a u v y1 y2 ->
(forall z z', mor a z -> mor a z' ->
source z = target y1 -> source z' = target y1 ->
comp a z y1 = comp a z' y1  -> comp a z y2 = comp a z' y2
-> z = z') ->
(forall z1 z2, cofiprod_hypothesis a u v z1 z2 ->
(exists w, (mor a w & source w = target y1 &
comp a w y1 = z1 & comp a w y2 = z2))) ->
is_cofiprod a u v y1 y2.
Proof.
ir.
assert (lem1 : target y1 = target y2).
uh H0. ee. transitivity (target (comp a y1 u)).
rww target_comp. uh H0; ee; am.
rw H7. rww target_comp. uh H0; ee; am.

uhg; ee. am.
ap show_is_fiprod.
wr cofi_hyp_fi_hyp. am. am.
ir. set (z1:=flip z). set (z2 := flip z').
assert (z1 = z2). ap H1.
uf z1. rwi mor_opp H3. am.
rwi mor_opp H4. am.
uf z1. rw source_flip; try alike. wr H5.
rww source_flip; try alike. uh H0; ee.
alike.
uf z2. rw source_flip; try alike. wr H6.
rww source_flip; try alike. uh H0; ee.
alike. uf z1; uf z2.
rwi comp_opp H7.
rwi flip_flip H7.
rwi comp_opp H7. rwi flip_flip H7.
rwi comp_opp H8.
rwi flip_flip H8.
rwi comp_opp H8. rwi flip_flip H8.

ap flip_eq.
am.
rww mor_opp. rw flip_flip.
uh H0; ee; am.
am.
uh H0; ee.
rw source_flip.
wr lem1.
rwi source_flip H6. am. alike. alike.
rww mor_opp. rw flip_flip.
uh H0; ee; am. am.
rw source_flip; try alike. wr lem1.
rwi source_flip H5. am. uh H0; ee; alike.
uh H0; ee; alike.
rw mor_opp; rww flip_flip. uh H0; ee; am.
am. am. rw mor_opp; rw flip_flip; uh H0; ee; am.
am. am.

uf z1; uf z2.
rwi comp_opp H7.
rwi flip_flip H7.
rwi comp_opp H7. rwi flip_flip H7.
rwi comp_opp H8.
rwi flip_flip H8.
rwi comp_opp H8. rwi flip_flip H8.

ap flip_eq.
am.
rww mor_opp. rw flip_flip.
uh H0; ee; am.
am.
uh H0; ee.
rw source_flip.
wr lem1.
rwi source_flip H6. am. alike. alike.
rww mor_opp. rw flip_flip.
uh H0; ee; am. am.
rw source_flip; try alike. wr lem1.
rwi source_flip H5. am. uh H0; ee; alike.
uh H0; ee; alike.
rw mor_opp; rww flip_flip. uh H0; ee; am.
am. am. rw mor_opp; rw flip_flip; uh H0; ee; am.
am. am. ap flip_eq. am.

ir.
cp H3. set (z1' := flip z1).
assert (z1= flip z1').
uf z1'; rww flip_flip. rwi H5 H4.
set (z2' := flip z2).
assert (z2= flip z2').
uf z2'; rww flip_flip. rwi H6 H4.

wri cofi_hyp_fi_hyp H4.
nin (H2 z1' z2' H4). ee.
sh (flip x). ee. rww mor_opp.
rww flip_flip.
rw source_flip. rw target_flip.
sy; am. alike. uh H0; ee; alike.
rw comp_opp.
rw flip_flip. rw flip_flip. ap flip_eq.
rw flip_flip. exact H9.
rww mor_opp. rw flip_flip. uh H0; ee; am.
rww mor_opp. rww flip_flip.
rw source_flip. rw target_flip. sy; am.
alike. uh H0; ee; alike.
rw comp_opp. rw flip_flip. rw flip_flip.
ap flip_eq. rw flip_flip. exact H10.
rw mor_opp; rw flip_flip. uh H0; ee; am.
rw mor_opp; rww flip_flip.
rw source_flip. rw target_flip.
rww H8. sy; am. alike. uh H0; ee; alike.
am.
Qed.

Definition has_cofiprod a u v :=
covee_hypothesis a u v &
has_fiprod (opp a) (flip u) (flip v).

Lemma has_cofiprod_rw : forall a u v,
has_cofiprod a u v =
(exists y1, exists y2, is_cofiprod a u v y1 y2).
Proof.
ir. ap iff_eq; ir.
uh H; ee.
rwi has_fiprod_rw H0.
nin H0. nin H0. sh (flip x). sh (flip x0).

uhg; ee. uh H; ee. uh H; ee; am. rw flip_flip.
rw flip_flip. am.
nin H. nin H.
assert (cofiprod_hypothesis a u v x x0).
rw cofi_hyp_fi_hyp.
uh H; ee. uh H0; ee.
am. uh H; ee. am.

uhg; ee. uh H0; ee; am.
uh H; ee.
rw has_fiprod_rw. sh (flip x).
sh (flip x0). am.
Qed.

Definition has_cofiprods a :=
Category.axioms a &
(forall u v, covee_hypothesis a u v ->
has_cofiprod a u v).

Definition cofipr1 a u v :=
flip (fipr1 (opp a) (flip u) (flip v)).

Definition cofipr2 a u v :=
flip (fipr2 (opp a) (flip u) (flip v)).

Lemma cofiprod_hypothesis_cofiprod : forall a u v,
has_cofiprod a u v ->
cofiprod_hypothesis a u v (cofipr1 a u v) (cofipr2 a u v).
Proof.
ir. uf cofipr1; uf cofipr2.
rw cofi_hyp_fi_hyp. rw flip_flip.
rw flip_flip.
ap fiprod_hypothesis_fiprod.
uh H. ee; am. uh H; ee. uh H; ee. uh H; ee; am.
Qed.

Lemma cofiprod_hypothesis_comp : forall a u v y1 y2 z,
cofiprod_hypothesis a u v y1 y2 -> mor a z ->
source z = target y1  ->
cofiprod_hypothesis a u v (comp a z y1) (comp a z y2).
Proof.
ir.
rw cofi_hyp_fi_hyp.
rwi cofi_hyp_fi_hyp H.
assert (flip (comp a z y1) =
comp (opp a) (flip y1) (flip z)).
rw comp_opp.
rw flip_flip. rww flip_flip.
uh H; ee; am.
rww mor_opp.
rww flip_flip.

rw source_flip; try alike. rw target_flip.
sy; am. alike. uh H; ee.
rwi mor_opp H2. rwi flip_flip H2; alike.

assert (flip (comp a z y2) =
comp (opp a) (flip y2) (flip z)).
rw comp_opp.
rw flip_flip. rww flip_flip.
uh H; ee; am.
rww mor_opp.
rww flip_flip.

uh H; ee. wr H7.

rw source_flip; try alike. rw target_flip.
sy; am. alike.
rwi mor_opp H3. rwi flip_flip H3; alike.

rw H2; rw H3. ap fiprod_hypothesis_comp. am.
rww mor_opp. rww flip_flip.

rw source_flip; try alike. rw target_flip.
sy; am. alike. uh H; ee.
rwi mor_opp H4. rwi flip_flip H4; alike.
uh H0; ee; am. uh H0; ee; am.
Qed.

Lemma is_cofiprod_cofiprod : forall a u v,
has_cofiprod a u v ->
is_cofiprod a u v (cofipr1 a u v) (cofipr2 a u v).
Proof.
ir. assert (Category.axioms a).
uh H; ee. uh H; ee. uh H; ee; am.
uhg; ee; try am.
uf cofipr1; uf cofipr2. rw flip_flip.
rw flip_flip.
ap is_fiprod_fiprod. uh H; ee. am.
Qed.

Lemma has_cofiprods_has_cofiprod : forall a u v,
has_cofiprods a -> covee_hypothesis a u v->
has_cofiprod a u v.
Proof.
ir. uh H; ee. ap H1. am.
Qed.

Lemma covee_hypothesis_opp1 : forall a u v,
Category.axioms a ->
covee_hypothesis a u v ->
vee_hypothesis (opp a) (flip u) (flip v).
Proof.
ir. uh H0; ee. uhg; ee.
rww mor_opp. rww flip_flip.
rww mor_opp. rww flip_flip.
rw target_flip; try alike.
rw target_flip; try alike. am.
Qed.

Lemma covee_hypothesis_opp : forall a u v,
Category.axioms a ->
covee_hypothesis (opp a) u v =
vee_hypothesis a (flip u) (flip v).
Proof.
ir. ap iff_eq; ir.
uh H0; uhg; ee. rwi mor_opp H0. am.
wrr mor_opp.
rw target_flip; try alike. rw target_flip; try alike.
am.

uh H0; ee. uhg; ee.
rw mor_opp; am. rw mor_opp; am.
rwi target_flip H2; try alike. rwi target_flip H2; try alike.
am.
wri mor_opp H1; alike. wri mor_opp H0; alike.
Qed.

Lemma vee_hypothesis_opp_flip : forall a u v,
Category.axioms a ->
vee_hypothesis (opp a) (flip u) (flip v) =
covee_hypothesis a u v.
Proof.
ir.
transitivity (covee_hypothesis (opp (opp a))
u v).  rw covee_hypothesis_opp. tv.
app opp_axioms. rww opp_opp.
Qed.

Lemma has_cofipr_has_fipr : forall a u v,
Category.axioms a ->
has_cofiprod a u v = has_fiprod (opp a) (flip u) (flip v).
Proof.
ir. ap iff_eq; ir.
uh H0; ee. am. uhg; ee. uh H0; ee.
rwi vee_hypothesis_opp_flip H0.
am. am. am.
Qed.

Lemma has_fipr_has_cofipr : forall a u v,
Category.axioms a ->
has_fiprod a u v = has_cofiprod (opp a) (flip u) (flip v).
Proof.
ir.
rw has_cofipr_has_fipr. rw flip_flip. rw flip_flip.
rw opp_opp. tv. app opp_axioms.
Qed.

Lemma has_cofiprods_opp : forall a,
has_cofiprods (opp a) = has_fiprods a.
Proof.
ir. ap iff_eq; ir.
uh H; ee. uhg; ee. wrr axioms_opp.
ir. rw has_fipr_has_cofipr.
ap H0.
rw covee_hypothesis_opp. rw flip_flip.
rw flip_flip. am.
wrr axioms_opp. wrr axioms_opp.

uh H; ee. uhg; ee.
app opp_axioms. ir.
rw has_cofipr_has_fipr.
rw opp_opp. ap H0.
wr covee_hypothesis_opp. am. am. app opp_axioms.
Qed.

Lemma has_fiprods_opp : forall a,
has_fiprods (opp a) = has_cofiprods a.
Proof.
ir. wr has_cofiprods_opp.
rww opp_opp.
Qed.

Lemma has_cofiprods_has_colimits_over_opp : forall a,
Category.axioms a ->
has_cofiprods a = has_colimits_over (opp vee_cat) a.
Proof.
ir. ap iff_eq; ir. assert (a = opp (opp a)).
rww opp_opp. rw H1.
ap has_colimits_over_opp. app opp_axioms.
ap vee_cat_axioms.
wr  has_fiprods_has_limits_over.
rw has_fiprods_opp. am. app opp_axioms.

wr has_fiprods_opp. rw has_fiprods_has_limits_over.
assert (vee_cat = opp (opp vee_cat)).
rww opp_opp. rw H1.
ap has_limits_over_opp. am.
ap opp_axioms. ap vee_cat_axioms. am.
app opp_axioms.
Qed.

Lemma mor_cofipr1 : forall a u v,
has_cofiprod a u v ->
mor a (cofipr1 a u v).
Proof.
ir. cp (cofiprod_hypothesis_cofiprod H).
uh H0; ee. am.
Qed.

Lemma mor_cofipr2 : forall a u v,
has_cofiprod a u v ->
mor a (cofipr2 a u v).
Proof.
ir. cp (cofiprod_hypothesis_cofiprod H).
uh H0; ee. am.
Qed.

Lemma source_cofipr1 : forall a u v,
has_cofiprod a u v ->
source (cofipr1 a u v) = target u.
Proof.
ir. cp (cofiprod_hypothesis_cofiprod H).
uh H0; ee. am.
Qed.

Lemma source_cofipr2 : forall a u v,
has_cofiprod a u v ->
source (cofipr2 a u v) = target v.
Proof.
ir. cp (cofiprod_hypothesis_cofiprod H).
uh H0; ee. am.
Qed.

Lemma target_cofipr2 : forall a u v,
has_cofiprod a u v ->
target (cofipr2 a u v) = target (cofipr1 a u v).
Proof.
ir.  cp (cofiprod_hypothesis_cofiprod H).
uh H0; ee.

uh H0; ee.
transitivity (target (comp a (cofipr1 a u v) u)).
rw H5. rw target_comp. tv.
ap mor_cofipr2. am. am.
rw source_cofipr2. tv. am.
rw target_comp. tv.
app mor_cofipr1. am.
rww source_cofipr1.
Qed.

Lemma comp_cofiprod_eq : forall a u v,
has_cofiprod a u v ->
comp a (cofipr1 a u v) u = comp a (cofipr2 a u v) v.
Proof.
ir. cp (cofiprod_hypothesis_cofiprod H).
uh H0; ee. am.
Qed.

Definition cofipr_dotted a u v y1 y2 :=
flip (fipr_dotted (opp a) (flip u) (flip v) (flip y1) (flip y2)).

Lemma mor_cofipr_dotted : forall a u v y1 y2,
has_cofiprod a u v -> cofiprod_hypothesis a u v y1 y2 ->
mor a (cofipr_dotted a u v y1 y2).
Proof.
ir.
rwi has_cofipr_has_fipr H.
rwi cofi_hyp_fi_hyp H0.
uf cofipr_dotted.
wr mor_opp. app mor_fipr_dotted.
 uh H0; ee.
uh H1; ee; am.  uh H0; ee.
uh H1; ee; am.
Qed.

Lemma source_fipr_dotted : forall a u v y1 y2,
has_cofiprod a u v -> cofiprod_hypothesis a u v y1 y2 ->
source (cofipr_dotted a u v y1 y2) = target (cofipr1 a u v).
Proof.
ir.
rwi has_cofipr_has_fipr H.
rwi cofi_hyp_fi_hyp H0.
uf cofipr_dotted.
rw source_flip.
rw target_fipr_dotted.
uf cofipr1. rw target_flip.
tv.
apply mor_arrow_like with (opp a). app mor_fipr1.
am. am.
apply mor_arrow_like with (opp a).
app mor_fipr_dotted.
uh H0; ee.
uh H1; ee; am. uh H0; ee.
uh H1; ee; am.
Qed.

Lemma comp_cofipr1_cofipr_dotted : forall a u v y1 y2,
has_cofiprod a u v -> cofiprod_hypothesis a u v y1 y2 ->
comp a (cofipr_dotted a u v y1 y2) (cofipr1 a u v) = y1.
Proof.
ir.
rwi has_cofipr_has_fipr H.
rwi cofi_hyp_fi_hyp H0.

uf cofipr_dotted.
uf cofipr1. ap flip_eq. wr comp_opp.
ap comp_fipr1_fipr_dotted. am. am.
app mor_fipr1. app mor_fipr_dotted.
rw target_fipr_dotted. tv. am. am.
uh H0; ee. uh H1; ee; am.
uh H0; ee. uh H1; ee; am.
Qed.

Lemma comp_cofipr2_cofipr_dotted : forall a u v y1 y2,
has_cofiprod a u v -> cofiprod_hypothesis a u v y1 y2 ->
comp a (cofipr_dotted a u v y1 y2) (cofipr2 a u v) = y2.
Proof.
ir.
rwi has_cofipr_has_fipr H.
rwi cofi_hyp_fi_hyp H0.

uf cofipr_dotted.
uf cofipr2. ap flip_eq. wr comp_opp.
ap comp_fipr2_fipr_dotted. am. am.
app mor_fipr2. app mor_fipr_dotted.
rw target_fipr_dotted. tv.
rw source_fipr2. tv. am. am.
am.
uh H0; ee. uh H1; ee; am.
uh H0; ee. uh H1; ee; am.
Qed.

Lemma cofipr_dotted_comp : forall a u v z,
has_cofiprod a u v -> mor a z ->
source z = target (cofipr1 a u v)  ->
cofipr_dotted a u v (comp a z (cofipr1 a u v))
(comp a z (cofipr2 a u v)) = z.
Proof.
ir. cp H. rwi has_cofipr_has_fipr H.
assert (cofiprod_hypothesis a u v
(comp a z (cofipr1 a u v)) (comp a z (cofipr2 a u v))).
app cofiprod_hypothesis_comp.
app cofiprod_hypothesis_cofiprod.

rwi cofi_hyp_fi_hyp H3.
uf cofipr_dotted.
assert (flip (comp a z (cofipr1 a u v)) =
comp (opp a) (fipr1 (opp a) (flip u) (flip v)) (flip z)).
rw comp_opp. sy; rw flip_flip.
uf cofipr1. tv.
app mor_fipr1. rww mor_opp. rww flip_flip.
ufi cofipr1 H1.
rwi target_flip H1. wr H1. rww target_flip.
alike.
apply mor_arrow_like with (opp a).
app mor_fipr1.

assert (flip (comp a z (cofipr2 a u v)) =
comp (opp a) (fipr2 (opp a) (flip u) (flip v)) (flip z)).
rw comp_opp. sy; rw flip_flip.
uf cofipr2. tv.
app mor_fipr2. rww mor_opp. rww flip_flip.
assert (lem1 : source z = target (cofipr2 a u v)).
rw target_cofipr2. am. am.
ufi cofipr2 lem1.
rwi target_flip lem1. wr lem1. rww target_flip.
alike.
apply mor_arrow_like with (opp a).
app mor_fipr2.

rw H4. rw H5. rw fipr_dotted_comp. rww flip_flip. am.
rw mor_opp. rww flip_flip.
ufi cofipr1 H1.
rwi target_flip H1. wr H1. rww target_flip.
alike.
apply mor_arrow_like with (opp a).
app mor_fipr1.
uh H0; ee; am. uh H0; ee; am.
Qed.

(*** now we apply the result of fc_limits to
the case of cofiprods ***********************)

Lemma has_cofiprods_functor_cat : forall a b,
Category.axioms a -> has_cofiprods b ->
has_cofiprods (functor_cat a b).
Proof.
ir. rw has_cofiprods_has_colimits_over_opp.
cp H0.
uh H1; ee.
rwi has_cofiprods_has_colimits_over_opp H0.
ap has_colimits_functor_cat. am. am.
ap opp_axioms. ap vee_cat_axioms. am. am.
ap functor_cat_axioms. am.
uh H0; ee; am.
Qed.

Lemma has_finite_limits_has_cofiprods : forall a,
has_finite_colimits a ->  has_cofiprods a.
Proof.
ir. rw has_cofiprods_has_colimits_over_opp.
uh H; ee. ap H0.
ap is_finite_cat_opp.
ap is_finite_vee_cat. uh H; ee; am.
Qed.

End Cofiprod.

Export Cofiprod.