(* 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 Equalizer.
Export Finite_Cat.
Export Limit.
Export Twoarrow_Cat.

Definition equalizer_hypothesis a u v y :=
twoarrow_hypothesis a u v &
mor a y & source u = target y &
comp a u y = comp a v y.

Definition equalizer_cone a u v y :=
cone_create (source y) (twoarrow_nt a
(id a (source y)) (id a (source y)) u v y (comp a u y)).

Lemma vertex_equalizer_cone : forall a u v y,
vertex (equalizer_cone a u v y) = source y.
Proof.
ir. uf equalizer_cone.
rw vertex_cone_create. tv.
Qed.

Lemma edge_nt_equalizer_cone : forall a u v y,
edge_nt (equalizer_cone a u v y) =
(twoarrow_nt a
(id a (source y)) (id a (source y)) u v y (comp a u y)).
Proof.
ir. uf equalizer_cone.
rw edge_nt_cone_create. tv.
Qed.

Lemma edge_equalizer_cone_R : forall a u v y (x:obsy twoarrow_data),
edge (equalizer_cone a u v y) (R x) =
match x with
o1 => y | o2 => (comp a u y)
end.
Proof.
ir.
uf edge.
rw edge_nt_equalizer_cone.
rw ntrans_twoarrow_nt_R. tv.
Qed.

Lemma socle_equalizer_cone : forall a u v y,
socle (equalizer_cone a u v y) = twoarrow_functor a u v.
Proof.
ir. uf socle.
rw edge_nt_equalizer_cone.
rw target_twoarrow_nt. tv.
Qed.

Lemma cone_source_equalizer_cone : forall a u v y,
cone_source (equalizer_cone a u v y) = twoarrow_cat.
Proof.
ir. uf cone_source.
rw socle_equalizer_cone. rww source_twoarrow_functor.
Qed.

Lemma cone_target_equalizer_cone : forall a u v y,
cone_target (equalizer_cone a u v y) = a.
Proof.
ir. uf cone_target.
rw socle_equalizer_cone. rww target_twoarrow_functor.
Qed.

Lemma equalizer_twoarrow_nt_hypothesis : forall a u v y,
equalizer_hypothesis a u v y ->
twoarrow_nt_hypothesis a (id a (source y)) (id a (source y)) u v y
  (comp a u y).
Proof.
ir. uh H; ee.
uh H; ee.
assert (ob a (source y)). rww ob_source.
assert (ob a (target y)). rww ob_target.

uhg; ee.

uh H0; ee; am. app mor_id.
app mor_id. am. am. am.
rww mor_comp. rww source_id. sy; am.
rww source_comp. rww target_id.
rww target_comp.
tv. tv. am. 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_equalizer_cone : forall a u v y,
equalizer_hypothesis a u v y ->
is_cone (equalizer_cone a u v y).
Proof.
ir. uhg; ee.
uf equalizer_cone.
ap cone_like_cone_create.
rw edge_nt_equalizer_cone.
ap twoarrow_nt_axioms.
app equalizer_twoarrow_nt_hypothesis.
rw cone_target_equalizer_cone.
rw vertex_equalizer_cone. uh H; ee. rww ob_source.

rw edge_nt_equalizer_cone.
rw source_twoarrow_nt.
rw cone_source_equalizer_cone.
rw cone_target_equalizer_cone.
rw vertex_equalizer_cone. sy;
rw constant_functor_twoarrow_functor. tv.
tv. uh H; ee. rww ob_source.
Qed.

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

Lemma source_eqzmap : forall c,
is_cone c -> cone_source c = twoarrow_cat ->
source (eqzmap c) =  vertex c.
Proof.
ir. uf eqzmap. rww source_edge.
rw H0. app ob_twoarrow_cat.
Qed.

Lemma equalizer_hypothesis_eqzmap :
forall a u v c, twoarrow_hypothesis a u v ->
is_cone c -> socle c = twoarrow_functor a u v ->
equalizer_hypothesis a u v (eqzmap c).
Proof.
ir.
assert (a = cone_target c).
uf cone_target. rw H1. rw target_twoarrow_functor.
tv.
assert (cone_source c = twoarrow_cat).
uf cone_source. rw H1.
rww source_twoarrow_functor.
uhg. ee. am.
uf eqzmap.
rw H2.
ap mor_edge.
rw H3. ap ob_twoarrow_cat.
am.
uf eqzmap. rw target_edge.
rw H1.
rw fob_twoarrow_functor_R. tv. am.
rw H3. ap ob_twoarrow_cat. am.

set (k:= edge_nt c).
util (twoarrow_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:=twoarrow_data) a0') =
id a (vertex c)).
uf k.
rw source_edge_nt.
rw fmor_constant_functor. wr H2. tv.
rw H3. ap mor_twoarrow_cat. am.

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

assert
(fmor (target k) (catyd_arrow (d:=twoarrow_data) a0') = u).
uf k.
rw target_edge_nt.
rw H1. rw fmor_twoarrow_functor_catyd_arrow.
tv. am.

assert
(fmor (target k) (catyd_arrow (d:=twoarrow_data) a1') = v).
uf k.
rw target_edge_nt.
rw H1. rw fmor_twoarrow_functor_catyd_arrow.
tv. am.

util (twoarrow_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') = eqzmap c).
uf eqzmap. uf edge.
tv. rwi H11 H10.
set (m:= ntrans k (R o2')).
assert (m = ntrans k (R o2')). tv. wri H12 H10.
uh H10; ee. wr H27. wr H28.
reflexivity.
Qed.

Lemma equalizer_cone_eq : forall a u v c,
twoarrow_hypothesis a u v ->
is_cone c -> socle c = twoarrow_functor a u v ->
c = equalizer_cone a u v (eqzmap c).
Proof.
ir.
assert (a = cone_target c).
uf cone_target. rw H1. rw target_twoarrow_functor.
tv.
assert (cone_source c = twoarrow_cat).
uf cone_source. rw H1.
rww source_twoarrow_functor.

set (k:= edge_nt c).
util (twoarrow_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:=twoarrow_data) a0') =
id a (vertex c)).
uf k.
rw source_edge_nt.
rw fmor_constant_functor. wr H2. tv.
rw H3. ap mor_twoarrow_cat. am.

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

assert
(fmor (target k) (catyd_arrow (d:=twoarrow_data) a0') = u).
uf k.
rw target_edge_nt.
rw H1. rw fmor_twoarrow_functor_catyd_arrow.
tv. am.

assert
(fmor (target k) (catyd_arrow (d:=twoarrow_data) a1') = v).
uf k.
rw target_edge_nt.
rw H1. rw fmor_twoarrow_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 equalizer_cone.
rw source_eqzmap.
ap uneq. wr H4. ap uneq.

util (twoarrow_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') = eqzmap c).
uf eqzmap. uf edge.
tv. rwi H11 H10.
set (m:= ntrans k (R o2')).
assert (m = ntrans k (R o2')). tv. wri H12 H10.
uh H10; ee. wr H27.
rw right_id. tv. rw H2. app ob_vertex.
am. rw H21. rw target_id. tv.
rw H2; app ob_vertex. tv. am. am.
Qed.

Lemma eqzmap_equalizer_cone : forall a u v y,
equalizer_hypothesis a u v y ->
eqzmap (equalizer_cone a u v y) = y.
Proof.
ir. uf eqzmap.
rw edge_equalizer_cone_R. tv.
Qed.

Lemma eqzmap_cone_compose : forall c z,
is_cone c -> cone_source c = twoarrow_cat ->
cone_composable c z ->
eqzmap (cone_compose c z) = comp (cone_target c) (eqzmap c) z.
Proof.
ir.
uf eqzmap.
rw edge_cone_compose. tv. rw H0; ap ob_twoarrow_cat.
am.
Qed.

Definition eqzfirst c :=
(fmor (socle c) (catyd_arrow (d:=twoarrow_data) a0')).
Definition eqzsecond c :=
(fmor (socle c) (catyd_arrow (d:=twoarrow_data) a1')).

Lemma equalizer_hypothesis_eqz : forall c,
is_cone c -> cone_source c = twoarrow_cat ->
equalizer_hypothesis (cone_target c) (eqzfirst c) (eqzsecond c)
(eqzmap c).
Proof.
ir. util (equalizer_hypothesis_eqzmap (a:= cone_target c)
(u:= eqzfirst c) (v:= eqzsecond c) (c:=c)).
uf eqzfirst. uf eqzsecond.
uf cone_target. ap functor_twoarrow_hypothesis.
app socle_axioms. am. am.
uf cone_target.
uf eqzfirst. uf eqzsecond. ap functor_twoarrow_eq.
app socle_axioms. am.
am.
Qed.

Lemma equalizer_cone_eq2 : forall c,
is_cone c -> cone_source c = twoarrow_cat ->
c = equalizer_cone (cone_target c) (eqzfirst c) (eqzsecond c)
(eqzmap c).
Proof.
ir.
util (equalizer_cone_eq (a:= cone_target c)
(u:= eqzfirst c) (v:= eqzsecond c) (c:=c)).
uf eqzfirst. uf eqzsecond.
uf cone_target. ap functor_twoarrow_hypothesis.
app socle_axioms. am. am.
uf cone_target.
uf eqzfirst. uf eqzsecond. ap functor_twoarrow_eq.
app socle_axioms. am.
am.
Qed.

Lemma eqzmap_extensionality : forall a b,
is_cone a -> is_cone b -> cone_source a = twoarrow_cat
-> socle a = socle b -> eqzmap a = eqzmap b -> a = b.
Proof.
ir.
assert (cone_source b = twoarrow_cat).
uf cone_source. wr H2. am.
util (equalizer_cone_eq2 (c:= a)).
am. am.
util (equalizer_cone_eq2 (c:= b)).
am. am. rw H5; rw H6.
assert (eqzfirst a = eqzfirst b).
uf eqzfirst. rww H2.
assert (eqzsecond a = eqzsecond b).
uf eqzsecond. rw H2. reflexivity.
rw H3; rw H7; rw H8.
assert (cone_target a = cone_target b).
uf cone_target. rww H2. rw H9.
reflexivity.
Qed.

Lemma cone_compose_equalizer_cone : forall a u v y z,
equalizer_hypothesis a u v y ->
mor a z -> source y = target z ->
cone_compose (equalizer_cone a u v y) z =
equalizer_cone a u v (comp a y z).
Proof.
ir.

assert (lem1: equalizer_hypothesis a u v (comp a y z)).
uh H; uhg; ee. am. rww mor_comp.
rww target_comp. wr assoc.
rw H4. rww assoc. uh H; ee; am.
uh H; ee. wr H6. am. uh H; ee; am. am.
am. am. am. tv.

assert (lem2 : cone_composable (equalizer_cone a u v y) z).
uhg; ee.
app  is_cone_equalizer_cone.
rww cone_target_equalizer_cone.
rww vertex_equalizer_cone. sy; am.

ap eqzmap_extensionality.
rww is_cone_cone_compose.
app is_cone_equalizer_cone.
rw cone_source_cone_compose. rww cone_source_equalizer_cone.
rw socle_cone_compose.
rww socle_equalizer_cone. rww socle_equalizer_cone.
rww eqzmap_cone_compose.
rww cone_target_equalizer_cone.
rww eqzmap_equalizer_cone.
rww eqzmap_equalizer_cone.
app is_cone_equalizer_cone.
rww cone_source_equalizer_cone.
Qed.

Lemma cone_composable_equalizer_cone : forall a u v y z,
equalizer_hypothesis a u v y -> mor a z ->
source y = target z ->
cone_composable (equalizer_cone a u v y) z.
Proof.
ir. uhg; ee. app is_cone_equalizer_cone.
rww cone_target_equalizer_cone.
rww vertex_equalizer_cone. sy; am.
Qed.

Lemma is_uni_equalizer_cone : forall a u v y,
equalizer_hypothesis a u v y ->
is_uni (equalizer_cone a u v y) =
(forall z z', mor a z -> mor a z' ->
source y = target z -> source y = target z' ->
comp a y z = comp a y z' -> z = z').
Proof.
ir. ap iff_eq; ir.
uh H0. ee. ap H6.
app cone_composable_equalizer_cone.
app cone_composable_equalizer_cone.
rw cone_compose_equalizer_cone.
sy; rw cone_compose_equalizer_cone.
rww H5. am. am. am. am. am. am.

uhg. ee. app is_cone_equalizer_cone.
ir.
cp H1; cp H2. uh H4; uh H5; ee.
rwi cone_target_equalizer_cone H8.
rwi cone_target_equalizer_cone H6.
rwi vertex_equalizer_cone H9.
rwi vertex_equalizer_cone H7.

app H0. sy; am. sy; am.
rwi cone_compose_equalizer_cone H3.
transitivity
(eqzmap (equalizer_cone a u v (comp a y u0))).
rw eqzmap_equalizer_cone. tv.
uh H; ee. uhg; ee; try am.
rww mor_comp. sy; am.
rww target_comp. sy; am.
wr assoc. rw H12. rww assoc.
uh H; ee; am. uh H; ee.
sy; wrr H14. sy; am.
uh H; ee; sy; am. uh H; ee; am. am.  am.
am. sy; am. tv.
rw H3.
rw cone_compose_equalizer_cone.
rw eqzmap_equalizer_cone. tv.
uh H; ee. uh H; ee.
uhg; ee; try am. uhg; ee; am.
rww mor_comp. sy; am.
rww target_comp. sy; am.
wr assoc. rw H12. rww assoc.
wr H14. am. sy; am.
am. am. am. am. sy; am.
tv. am. am. sy; am.
am. am. sy; am.
Qed.

Lemma is_versal_equalizer_cone : forall a u v y,
equalizer_hypothesis a u v y ->
is_versal (equalizer_cone a u v y) =
(forall z, equalizer_hypothesis a u v z ->
(exists w, (mor a w & source y = target w &
comp a y w = z))).
Proof.
ir. ap iff_eq; ir.
uh H0; ee.
util (H2 (equalizer_cone a u v z)).
app is_cone_equalizer_cone.
rww socle_equalizer_cone; sy;
rww socle_equalizer_cone.
nin H3. ee.
cp H3. uh H5; ee.
rwi cone_target_equalizer_cone H6.
rwi vertex_equalizer_cone H7.
rwi cone_compose_equalizer_cone H4.
sh x; ee. am. sy; am.
transitivity (eqzmap (equalizer_cone a u v (comp a y x))).
rw eqzmap_equalizer_cone. tv.
uh H; uhg; ee; try am. rww mor_comp. sy; am.
rww target_comp. sy; am.
uh H; ee.
wrr assoc. rw H10; rww assoc.
wr H12. am. sy; am. sy; am.
rw H4. rww eqzmap_equalizer_cone. am. am.
sy; am.

uhg; ee. app is_cone_equalizer_cone. ir.
rwi socle_equalizer_cone H2.
cp H.
uh H3. ee. cp (equalizer_cone_eq H3 H1 H2).
cp (equalizer_hypothesis_eqzmap H3 H1 H2).

util (H0 (eqzmap b)). am.
nin H9. ee. sh x; ee.
app cone_composable_equalizer_cone.
rww cone_compose_equalizer_cone. rw H11. sy; am.
Qed.

Definition is_equalizer a u v y :=
equalizer_hypothesis a u v y &
is_limit (equalizer_cone a u v y).

Lemma show_is_equalizer : forall a u v y ,
equalizer_hypothesis a u v y ->
(forall z z', mor a z -> mor a z' ->
source y = target z -> source y = target z' ->
comp a y z = comp a y z' -> z = z') ->
(forall z, equalizer_hypothesis a u v z ->
(exists w, (mor a w & source y = target w &
comp a y w = z))) ->
is_equalizer a u v y.
Proof.
ir. uhg; ee. am.
uhg. ee. rww is_uni_equalizer_cone.
rww is_versal_equalizer_cone.
Qed.

Definition has_equalizer a u v :=
twoarrow_hypothesis a u v &
has_limit (twoarrow_functor a u v).

Lemma has_equalizer_rw : forall a u v,
has_equalizer a u v = (exists y, is_equalizer a u v y).
Proof.
ir. ap iff_eq; ir.
uh H; ee. uh H0.
nin H0. uh H0; ee. sh (eqzmap x).
uhg; ee.
ap equalizer_hypothesis_eqzmap. am.
app is_limit_is_cone. am.

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

nin H. uhg; ee.
uh H; ee. uh H; ee; am.
uh H; ee.
uhg.
sh (equalizer_cone a u v x).
uhg; ee. am.
rww socle_equalizer_cone.
Qed.

Definition has_equalizers a :=
Category.axioms a &
(forall u v, twoarrow_hypothesis a u v ->
has_equalizer a u v).

Definition equalizer a u v :=
eqzmap (limit (twoarrow_functor a u v)).

Lemma equalizer_hypothesis_equalizer : forall a u v,
has_equalizer a u v ->
equalizer_hypothesis a u v (equalizer a u v).
Proof.
ir. uf equalizer.
app equalizer_hypothesis_eqzmap.
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 equalizer_hypothesis_comp : forall a u v y z,
equalizer_hypothesis a u v y -> mor a z ->
source y = target z  ->
equalizer_hypothesis a u v (comp a y z).
Proof.
ir. uh H; uhg; ee. am. rww mor_comp.
rww target_comp.
wrr assoc. rw H4. rww assoc.
uh H; ee. am. uh H; ee.
wrr H6. uh H; ee; am.
Qed.

Lemma is_equalizer_equalizer : forall a u v,
has_equalizer a u v ->
is_equalizer a u v (equalizer a u v).
Proof.
ir. uhg; ee.
app equalizer_hypothesis_equalizer.
uf equalizer.
wr equalizer_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_equalizers_has_equalizer : forall a u v,
has_equalizers a -> twoarrow_hypothesis a u v->
has_equalizer a u v.
Proof.
ir. uh H; ee. ap H1. am.
Qed.

Lemma has_equalizers_has_limits_over : forall a,
Category.axioms a ->
has_equalizers a = has_limits_over twoarrow_cat a.
Proof.
ir. ap iff_eq; ir.
uhg. ir. uh H0. ee.
util (H4 (fmor f (catyd_arrow a0')) (fmor f (catyd_arrow a1'))).
wr H3. ap functor_twoarrow_hypothesis. am.
am.
uh H5. ee. wri H3 H6.
rww functor_twoarrow_eq.

uh H0. uhg; ee. am.
ir. uhg; ee; try am.
ap H0.
app twoarrow_functor_axioms.
rww source_twoarrow_functor.
rww target_twoarrow_functor.
Qed.

Lemma mor_equalizer : forall a u v,
has_equalizer a u v ->
mor a (equalizer a u v).
Proof.
ir. cp (is_equalizer_equalizer H).
uh H0; ee.
uh H0; ee. am.
Qed.

Lemma target_equalizer : forall a u v,
has_equalizer a u v ->
target (equalizer a u v) = source u.
Proof.
ir. cp (is_equalizer_equalizer H).
uh H0; ee.
uh H0; ee. sy; am.
Qed.

Lemma comp_equalizer_eq : forall a u v,
has_equalizer a u v ->
comp a u (equalizer a u v) = comp a v (equalizer a u v).
Proof.
ir. cp (is_equalizer_equalizer H).
uh H0; ee.
uh H0; ee. am.
Qed.

Definition eqz_dotted a u v y :=
dotted (equalizer_cone a u v y).

Lemma equalizer_cone_equalizer : forall a u v,
has_equalizer a u v ->
equalizer_cone a u v (equalizer a u v) =
limit (twoarrow_functor a u v).
Proof.
ir.
uf equalizer.
wr equalizer_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_eqz_dotted : forall a u v y,
has_equalizer a u v -> equalizer_hypothesis a u v y ->
cone_composable (equalizer_cone a u v (equalizer a u v))
(eqz_dotted a u v y).
Proof.
ir.
uf eqz_dotted.
rw equalizer_cone_equalizer.
assert (twoarrow_functor a u v =
socle (equalizer_cone a u v y)).
rww socle_equalizer_cone. rw H1.
ap cone_composable_dotted.
app is_cone_equalizer_cone.
rw socle_equalizer_cone. uh H; ee; am.
am.
Qed.

Lemma cone_compose_eqz_dotted : forall a u v y,
has_equalizer a u v -> equalizer_hypothesis a u v y ->
cone_compose (equalizer_cone a u v (equalizer a u v))
(eqz_dotted a u v y) = equalizer_cone a u v y.
Proof.
ir.
uf eqz_dotted.
rw equalizer_cone_equalizer.
assert (twoarrow_functor a u v =
socle (equalizer_cone a u v y)).
rww socle_equalizer_cone. rw H1.
ap cone_compose_dotted.
app is_cone_equalizer_cone.
rw socle_equalizer_cone. uh H; ee; am. am.
Qed.

Lemma eqz_dotted_uni : forall a u v y r,
has_equalizer a u v -> equalizer_hypothesis a u v y ->
cone_composable (equalizer_cone a u v (equalizer a u v)) r ->
cone_compose (equalizer_cone a u v (equalizer a u v)) r =
equalizer_cone a u v y ->
eqz_dotted a u v y = r.
Proof.
ir. uf eqz_dotted.
wr H2.
rw equalizer_cone_equalizer. ap dotted_unique.
ap twoarrow_functor_axioms. uh H0; ee; am.
uh H; ee; am.
wr equalizer_cone_equalizer. am. am. am.
Qed.

Lemma mor_eqz_dotted : forall a u v y,
has_equalizer a u v -> equalizer_hypothesis a u v y ->
mor a (eqz_dotted a u v y).
Proof.
ir.
cp (cone_composable_eqz_dotted H H0).
uh H1; ee. rwi cone_target_equalizer_cone H2. am.
Qed.

Lemma target_eqz_dotted : forall a u v y,
has_equalizer a u v -> equalizer_hypothesis a u v y ->
target (eqz_dotted a u v y) = source (equalizer a u v).
Proof.
ir.
cp (cone_composable_eqz_dotted H H0).
uh H1; ee. rwi vertex_equalizer_cone H3. am.
Qed.

Lemma comp_equalizer_eqz_dotted : forall a u v y,
has_equalizer a u v -> equalizer_hypothesis a u v y ->
comp a (equalizer a u v) (eqz_dotted a u v y) = y.
Proof.
ir.
cp (cone_compose_eqz_dotted H H0).
transitivity (eqzmap (equalizer_cone a u v y)).
wr H1.
rw eqzmap_cone_compose.
rw cone_target_equalizer_cone.
rw eqzmap_equalizer_cone. tv.
ap equalizer_hypothesis_equalizer. am.
ap is_cone_equalizer_cone.
app equalizer_hypothesis_equalizer.
rww cone_source_equalizer_cone.
app cone_composable_eqz_dotted.
rww eqzmap_equalizer_cone.
Qed.

Lemma eqz_dotted_comp : forall a u v z,
has_equalizer a u v -> mor a z ->
source (equalizer a u v) = target z ->
eqz_dotted a u v (comp a (equalizer a u v) z) = z.
Proof.
ir.
assert (equalizer_hypothesis a u v (equalizer a u v)).
app equalizer_hypothesis_equalizer.
ap eqz_dotted_uni. am.
app equalizer_hypothesis_comp.
uhg; ee. app is_cone_equalizer_cone.
rww cone_target_equalizer_cone.
rww vertex_equalizer_cone. sy; am.
rw cone_compose_equalizer_cone. tv.
am. am. am.
Qed.

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

Lemma has_equalizers_functor_cat : forall a b,
Category.axioms a -> has_equalizers b ->
has_equalizers (functor_cat a b).
Proof.
ir. rw has_equalizers_has_limits_over.
cp H0.
uh H1; ee.
rwi has_equalizers_has_limits_over H0.
ap has_limits_functor_cat. am. am.
ap twoarrow_cat_axioms. am. am.
ap functor_cat_axioms. am.
uh H0; ee; am.
Qed.

Lemma has_finite_limits_has_equalizers : forall a,
has_finite_limits a ->  has_equalizers a.
Proof.
ir. rw has_equalizers_has_limits_over.
uh H; ee. ap H0.
ap is_finite_twoarrow_cat. uh H; ee; am.
Qed.

End Equalizer.

Export Equalizer.

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

Module Coequalizer.

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

Definition coequalizer_hypothesis a u v y :=
twoarrow_hypothesis a u v &
mor a y & source y = target u &
comp a y u = comp a y v.

Lemma coeq_hyp_eq_hyp : forall a u v y,
Category.axioms a ->
coequalizer_hypothesis a u v y =
equalizer_hypothesis (opp a) (flip u) (flip v) (flip y).
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 source_flip. rw source_flip.
am. alike. alike.
rw target_flip; try alike.
rww target_flip; try alike.
rww mor_opp; rww flip_flip.
rww target_flip; try alike.
rww source_flip; try alike. sy; am.
uh H0; ee; alike.
rw comp_opp.
rw comp_opp. 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. wr H6. 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 H4.
rwi flip_flip H4. am.
wr target_flip; try alike.
rw H6. rw target_flip; try alike. tv.
wr source_flip; try alike. rw H5.
rww source_flip; try alike.
rwi mor_opp H1.
rwi flip_flip H1. am.
uh H7; ee. wr target_flip; try alike.
wr H2. rw H5.
rww source_flip; try alike. sy; am.

rwi comp_opp H3. rwi flip_flip H3.
rwi flip_flip H3. transitivity (flip (flip (comp a y u))).
rww flip_flip. rw H3.
rw comp_opp. rw flip_flip. rw flip_flip. rw flip_flip.
tv.  am. am.
wr H5. am.
am. am. am.
Qed.

Definition is_coequalizer a u v y :=
Category.axioms a &
is_equalizer (opp a) (flip u) (flip v) (flip y).

Lemma show_is_coequalizer : forall a u v y ,
Category.axioms a ->
coequalizer_hypothesis a u v y ->
(forall z z', mor a z -> mor a z' ->
source z = target y -> source z' = target y ->
comp a z y = comp a z' y -> z = z') ->
(forall z, coequalizer_hypothesis a u v z ->
(exists w, (mor a w & source w = target y &
comp a w y = z))) ->
is_coequalizer a u v y.
Proof.
ir. uhg; ee. am.
ap show_is_equalizer.
wr coeq_hyp_eq_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.
rwi comp_opp H7.
rwi flip_flip H7.
rwi comp_opp H7. rwi flip_flip H7.
ap flip_eq. am.
rww mor_opp. rw flip_flip.
uh H0; ee; am.
am.
am. rww mor_opp. rw flip_flip.
uh H0; ee; am.
am.
am.
ap flip_eq. am.

ir.
cp H3. set (z1 := flip z).
assert (z= flip z1).
uf z1; rww flip_flip. rwi H5 H4.
wri coeq_hyp_eq_hyp H4.
nin (H2 z1 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. am.
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. am.
Qed.

Definition has_coequalizer a u v :=
twoarrow_hypothesis a u v &
has_equalizer (opp a) (flip u) (flip v).

Lemma has_coequalizer_rw : forall a u v,
has_coequalizer a u v = (exists y, is_coequalizer a u v y).
Proof.
ir. ap iff_eq; ir.
uh H; ee.
rwi has_equalizer_rw H0.
nin H0. sh (flip x).
uhg; ee. uh H; ee. uh H; ee; am. rww flip_flip.
nin H. uh H; ee.
uhg; ee.
uh H0; ee.
wri coeq_hyp_eq_hyp H0. uh H0. ee; am. am.
rw has_equalizer_rw. sh (flip x).
am.
Qed.

Definition has_coequalizers a :=
Category.axioms a &
(forall u v, twoarrow_hypothesis a u v ->
has_coequalizer a u v).

Definition coequalizer a u v :=
flip (equalizer (opp a) (flip u) (flip v)).

Lemma coequalizer_hypothesis_coequalizer : forall a u v,
has_coequalizer a u v ->
coequalizer_hypothesis a u v (coequalizer a u v).
Proof.
ir. uf coequalizer.
rw coeq_hyp_eq_hyp. rw flip_flip.
ap equalizer_hypothesis_equalizer.
uh H. ee; am. uh H; ee. uh H; ee. uh H; ee; am.
Qed.

Lemma coequalizer_hypothesis_comp : forall a u v y z,
coequalizer_hypothesis a u v y -> mor a z ->
source z = target y  ->
coequalizer_hypothesis a u v (comp a z y).
Proof.
ir.
rw coeq_hyp_eq_hyp.
rwi coeq_hyp_eq_hyp H.
assert (flip (comp a z y) =
comp (opp a) (flip y) (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.

rw H2. ap equalizer_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 H3. rwi flip_flip H3; alike.
uh H0; ee; am. uh H0; ee; am.
Qed.

Lemma is_coequalizer_coequalizer : forall a u v,
has_coequalizer a u v ->
is_coequalizer a u v (coequalizer a u v).
Proof.
ir. assert (Category.axioms a).
uh H; ee. uh H; ee. uh H; ee; am.
uhg; ee; try am.
uf coequalizer. rw flip_flip.
ap is_equalizer_equalizer. uh H; ee. am.
Qed.

Lemma has_coequalizers_has_coequalizer : forall a u v,
has_coequalizers a -> twoarrow_hypothesis a u v->
has_coequalizer a u v.
Proof.
ir. uh H; ee. ap H1. am.
Qed.

Lemma twoarrow_hypothesis_opp1 : forall a u v,
Category.axioms a ->
twoarrow_hypothesis a u v ->
twoarrow_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 source_flip; try alike.
rw source_flip; try alike. am.
rw target_flip; try alike.
rw target_flip; try alike. am.
Qed.

Lemma twoarrow_hypothesis_opp : forall a u v,
Category.axioms a ->
twoarrow_hypothesis (opp a) u v =
twoarrow_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 source_flip; try alike. rw source_flip; try alike.
am. rw target_flip; try alike. rw target_flip; try alike.
am.

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

Lemma twoarrow_hypothesis_opp_flip : forall a u v,
Category.axioms a ->
twoarrow_hypothesis (opp a) (flip u) (flip v) =
twoarrow_hypothesis a u v.
Proof.
ir.
rw twoarrow_hypothesis_opp.
rw flip_flip. rw flip_flip. tv. am.
Qed.

Lemma has_coeq_has_eq : forall a u v,
Category.axioms a ->
has_coequalizer a u v = has_equalizer (opp a) (flip u) (flip v).
Proof.
ir. ap iff_eq; ir.
uh H0; ee. am. uhg; ee. uh H0; ee.
rwi twoarrow_hypothesis_opp_flip H0.
am. am. am.
Qed.

Lemma has_eq_has_coeq : forall a u v,
Category.axioms a ->
has_equalizer a u v = has_coequalizer (opp a) (flip u) (flip v).
Proof.
ir.
rw has_coeq_has_eq. rw flip_flip. rw flip_flip.
rw opp_opp. tv. app opp_axioms.
Qed.

Lemma has_coequalizers_opp : forall a,
has_coequalizers (opp a) = has_equalizers a.
Proof.
ir. ap iff_eq; ir.
uh H; ee. uhg; ee. wrr axioms_opp.
ir. rw has_eq_has_coeq.
ap H0.
rw twoarrow_hypothesis_opp_flip. am.
wrr axioms_opp. wrr axioms_opp.

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

Lemma has_equalizers_opp : forall a,
has_equalizers (opp a) = has_coequalizers a.
Proof.
ir. wr has_coequalizers_opp.
rww opp_opp.
Qed.

Lemma has_coequalizers_has_colimits_over_opp : forall a,
Category.axioms a ->
has_coequalizers a = has_colimits_over (opp twoarrow_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 twoarrow_cat_axioms.
wr  has_equalizers_has_limits_over.
rw has_equalizers_opp. am. app opp_axioms.

wr has_equalizers_opp. rw has_equalizers_has_limits_over.
assert (twoarrow_cat = opp (opp twoarrow_cat)).
rww opp_opp. rw H1.
ap has_limits_over_opp. am.
ap opp_axioms. ap twoarrow_cat_axioms. am.
app opp_axioms.
Qed.

Lemma mor_coequalizer : forall a u v,
has_coequalizer a u v ->
mor a (coequalizer a u v).
Proof.
ir. cp (coequalizer_hypothesis_coequalizer H).
uh H0; ee. am.
Qed.

Lemma source_coequalizer : forall a u v,
has_coequalizer a u v ->
source (coequalizer a u v) = target u.
Proof.
ir. cp (coequalizer_hypothesis_coequalizer H).
uh H0; ee. am.
Qed.

Lemma comp_coequalizer_eq : forall a u v,
has_coequalizer a u v ->
comp a (coequalizer a u v) u = comp a (coequalizer a u v) v.
Proof.
ir. cp (coequalizer_hypothesis_coequalizer H).
uh H0; ee. am.
Qed.

Definition coeqz_dotted a u v y :=
flip (eqz_dotted (opp a) (flip u) (flip v) (flip y)).

Lemma mor_coeqz_dotted : forall a u v y,
has_coequalizer a u v -> coequalizer_hypothesis a u v y ->
mor a (coeqz_dotted a u v y).
Proof.
ir.
rwi has_coeq_has_eq H.
rwi coeq_hyp_eq_hyp H0.
uf coeqz_dotted.
wr mor_opp. app mor_eqz_dotted.
 uh H0; ee.
uh H1; ee; am.  uh H0; ee.
uh H1; ee; am.
Qed.

Lemma source_eqz_dotted : forall a u v y,
has_coequalizer a u v -> coequalizer_hypothesis a u v y ->
source (coeqz_dotted a u v y) = target (coequalizer a u v).
Proof.
ir.
rwi has_coeq_has_eq H.
rwi coeq_hyp_eq_hyp H0.
uf coeqz_dotted.
rw source_flip.
rw target_eqz_dotted.
uf coequalizer. rw target_flip.
tv.
apply mor_arrow_like with (opp a). app mor_equalizer.
am. am.
apply mor_arrow_like with (opp a).
app mor_eqz_dotted.
uh H0; ee.
uh H1; ee; am. uh H0; ee.
uh H1; ee; am.
Qed.

Lemma comp_coequalizer_coeqz_dotted : forall a u v y,
has_coequalizer a u v -> coequalizer_hypothesis a u v y ->
comp a (coeqz_dotted a u v y) (coequalizer a u v) = y.
Proof.
ir.
rwi has_coeq_has_eq H.
rwi coeq_hyp_eq_hyp H0.

uf coeqz_dotted.
uf coequalizer. ap flip_eq. wr comp_opp.
ap comp_equalizer_eqz_dotted. am. am.
app mor_equalizer. app mor_eqz_dotted.
rw target_eqz_dotted. tv. am. am.
uh H0; ee. uh H1; ee; am.
uh H0; ee. uh H1; ee; am.
Qed.

Lemma coeqz_dotted_comp : forall a u v z,
has_coequalizer a u v -> mor a z ->
source z = target (coequalizer a u v)  ->
coeqz_dotted a u v (comp a z (coequalizer a u v)) = z.
Proof.
ir. cp H. rwi has_coeq_has_eq H.
assert (coequalizer_hypothesis a u v (comp a z (coequalizer a u v))).
app coequalizer_hypothesis_comp.
app coequalizer_hypothesis_coequalizer.

rwi coeq_hyp_eq_hyp H3.
uf coeqz_dotted.
assert (flip (comp a z (coequalizer a u v)) =
comp (opp a) (equalizer (opp a) (flip u) (flip v)) (flip z)).
rw comp_opp. sy; rw flip_flip.
uf coequalizer. tv.
app mor_equalizer. rww mor_opp. rww flip_flip.
ufi coequalizer H1.
rwi target_flip H1. wr H1. rww target_flip.
alike.
apply mor_arrow_like with (opp a).
app mor_equalizer.

rw H4. rw eqz_dotted_comp. rww flip_flip. am.
rw mor_opp. rww flip_flip.
ufi coequalizer H1.
rwi target_flip H1. wr H1. rww target_flip.
alike.
apply mor_arrow_like with (opp a).
app mor_equalizer.
uh H0; ee; am. uh H0; ee; am.
Qed.

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

Lemma has_coequalizers_functor_cat : forall a b,
Category.axioms a -> has_coequalizers b ->
has_coequalizers (functor_cat a b).
Proof.
ir. rw has_coequalizers_has_colimits_over_opp.
cp H0.
uh H1; ee.
rwi has_coequalizers_has_colimits_over_opp H0.
ap has_colimits_functor_cat. am. am.
ap opp_axioms. ap twoarrow_cat_axioms. am. am.
ap functor_cat_axioms. am.
uh H0; ee; am.
Qed.

Lemma has_finite_limits_has_coequalizers : forall a,
has_finite_colimits a ->  has_coequalizers a.
Proof.
ir. rw has_coequalizers_has_colimits_over_opp.
uh H; ee. ap H0.
ap is_finite_cat_opp.
ap is_finite_twoarrow_cat. uh H; ee; am.
Qed.

End Coequalizer.

Export Coequalizer.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Language LibTactics.
Require Import Strings.String.
Require Import Program.Tactics.

Lemma ptype_determinism :
  forall (e : trm) (A B : typ),
    ptype e A -> ptype e B -> A = B.
Proof.
  intros. generalize dependent B.
  dependent induction H; eauto; intros * Hptyp.
  - dependent destruction Hptyp; eauto.
  - dependent destruction Hptyp; eauto.
    assert (A = A0); eauto.
    assert (B = B0); eauto.
    congruence.
Qed.

Hint Resolve ptype_determinism : core.

Ltac simpl_deter :=
  repeat
    match goal with
    | [H1: ptype ?v ?A1, H2: ptype ?v ?A2 |- _] => (eapply ptype_determinism in H1; eauto; subst)
    end.

Lemma typing_to_ptype :
  forall (A : typ) (v : trm),
    value v ->
    typing nil v A ->
    ptype v A.
Proof.
  introv Hv Htyp.
  generalize dependent A.
  dependent induction Hv; eauto; introv Htyp.
  - dependent destruction Htyp; eauto.
  - dependent destruction Htyp; eauto.
Qed.

Hint Resolve typing_to_ptype : core.


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export definition.

Lemma notin_fv_tt_open : forall X U T,
    X `notin` fv_tt T ->
    X \notin fv_tt U ->
    X `notin` fv_tt (open_tt T U).
Proof with auto.
  intros.
  simpl.
  unfold open_tt.
  unfold open_tt_rec.
  generalize 0.
  induction T;simpl in *;intros...
  destruct (n0==n)...
Qed.

Lemma notin_fl_tt_open : forall X U T,
    X `notin` fl_tt T ->
    X \notin fl_tt U ->
    X `notin` fl_tt (open_tt T U).
Proof with auto.
  intros.
  unfold open_tt.
  unfold open_tt_rec.
  generalize 0.
  induction T;simpl in *;intros...
  destruct (n0==n)...
Qed.

Lemma notin_union: forall X A B,
    X `notin` (union A B) <->
    X `notin` A /\ X `notin` B.
Proof with auto.
  split.
  intros;split...
  intros;destruct H...
Qed.

Lemma notin_fv_subst2: forall X A B Y,
    X \notin fv_tt A ->
    X \notin fv_tt B ->
    X <> Y ->
    X \notin fv_tt (subst_tt Y A B).
Proof with auto.
  intros.
  induction B...
  -
    simpl.
    destruct (a == Y)...
  -
    simpl in *.
    apply notin_union.
    apply notin_union in H0.
    destruct H0.
    split...
  -
    simpl in *.
    apply notin_union.
    apply notin_union in H0.
    destruct H0.
    split...
Qed.

Lemma notin_fv_subst: forall X A B,
    X \notin fv_tt A ->
    X \notin fv_tt B ->
    X \notin fv_tt (subst_tt X A B).
Proof with auto.
  intros.
  induction B...
  -
    simpl.
    destruct (a == X)...
  -
    simpl in *.
    apply notin_union.
    apply notin_union in H0.
    destruct H0.
    split...
  -
    simpl in *.
    apply notin_union.
    apply notin_union in H0.
    destruct H0.
    split...
Qed.

Lemma in_dec: forall T X,
    X \notin T \/ X \in T.
Proof.
  intros.
  apply notin_diff_1.
  assert (AtomSetImpl.diff T T [=] {}).
  apply AtomSetProperties.diff_subset_equal.
  apply KeySetProperties.subset_refl.
  rewrite H.
  auto.
Qed.

Ltac destruct_hypos :=
  repeat
    match goal with
    | [H : _ /\ _ |- _ ] => destruct H
    | [H : exists _,_ |- _ ] => destruct H
    end.

Ltac specialize_x_and_L X L :=
  repeat match goal with
         | [H : forall _, _ \notin L -> _, Q : X \notin L |- _ ] => specialize (H _ Q); clear Q
         | [H : forall _, _ \notin L -> _ |- _ ] => assert (X \notin L) by auto
         end.

Ltac add_nil :=
    match goal with
    | [ |- WFS ?E _ ] => rewrite_alist (nil ++ E)
    | [ |- Sub ?E _ _ ] => rewrite_alist (nil ++ E)
    end.

Lemma type_subst : forall A,
    forall X B, type B -> type (subst_tt X B A) -> type A.
Proof with auto.
  intros.
  dependent induction H0;try solve [destruct A; simpl in *; inversion x; eauto]...
    destruct A; simpl in *; inversion x; eauto.
    apply type_mu with (L := union L (singleton X)).
    intros.
    specialize_x_and_L X0 L.
    eapply (H0 B H X); eauto.
    subst.
    apply subst_tt_open_tt_var; eauto.
Defined.

Lemma WFS_type: forall E T,
    WFS E T -> type T.
Proof with auto.
  intros.
  induction H...
  apply type_mu with (L:=L)...
Qed.

Lemma subst_tt_rcd: forall  Y X A B,
    (typ_rcd X (subst_tt Y A B)) = subst_tt Y A (typ_rcd X B).
Proof with auto.
  intros...
Qed.

Lemma WFS_weakening: forall E1 E2 T E,
    WFS (E1 ++ E2) T ->
    WFS (E1 ++ E ++ E2) T.
Proof with auto.
  intros.
  generalize dependent E.
  dependent induction H;intros...
  -
    apply WFS_rec with (L:=L)...
    intros.
    rewrite_alist (([(X, bind_sub)] ++ E1) ++ E ++ E2).
    apply H0...
    intros.
    rewrite_alist (([(X, bind_sub)] ++ E1) ++ E ++ E2).
    apply H2...
Qed.

Lemma subst_tt_wfs: forall A B E X,
    WFS E A ->
    WFS E B ->
    WFS E (subst_tt X A B).
Proof with auto.
  intros.
  generalize dependent A.
  dependent induction H0;intros;simpl in *...
  -
    destruct (X0==X)...
  -
    assert (type A0).
    apply WFS_type in H3...
    apply WFS_rec with (L:=L \u {{X}} \u fv_tt A0).
    intros.
    rewrite  subst_tt_open_tt_var...
    rewrite  subst_tt_rcd.
    rewrite  <- subst_tt_open_tt...
    apply H0...
    rewrite_alist (nil ++ [(X0, bind_sub)] ++ E).
    apply WFS_weakening...
    intros.
    rewrite  subst_tt_open_tt_var...
    apply H2...
    rewrite_alist (nil ++ [(X0, bind_sub)] ++ E).
    apply WFS_weakening...
Qed.

Lemma subst_tt_wfs2: forall Y B E1 E2 X,
    WFS (E1 ++ (X ~ bind_sub) ++ E2) B ->
    WFS (E1 ++ (Y ~ bind_sub) ++ E2) (subst_tt X Y B).
Proof with auto.
  intros.
  dependent induction H;intros;simpl in *...
  -
    destruct (X0==X)...
    analyze_binds H...
  -
    apply WFS_rec with (L:=L \u {{X}} \u fv_tt A \u {{Y}});intros.
    rewrite  subst_tt_open_tt_var...
    rewrite  subst_tt_rcd.
    rewrite  <- subst_tt_open_tt...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ (Y, bind_sub) :: E2).
    apply H0...
    rewrite  subst_tt_open_tt_var...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ (Y, bind_sub) :: E2).
    apply H2...
Qed.

Lemma subst_tt_wfs3: forall  B E1 E2 X A,
    WFS (E1 ++ (X ~ bind_sub) ++ E2) B ->
    WFS (E1 ++ E2 ) A ->
    X \notin fv_tt A ->
    WFS (E1 ++ E2) (subst_tt X A B).
Proof with auto.
  intros.
  dependent induction H;intros;simpl in *...
  -
    destruct (X0==X)...
    analyze_binds H...
  -
    assert (type A).
    apply WFS_type in H3...
    apply WFS_rec with (L:=L \u {{X}} \u fv_tt A );intros.
    rewrite  subst_tt_open_tt_var...
    rewrite  subst_tt_rcd.
    rewrite  <- subst_tt_open_tt...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ E2).
    apply H0...
    rewrite_alist (nil ++ [(X0, bind_sub)] ++ (E1 ++ E2)).
    apply WFS_weakening...
    rewrite  subst_tt_open_tt_var...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ E2).
    apply H2...
    rewrite_alist (nil ++ [(X0, bind_sub)] ++ (E1 ++ E2)).
    apply WFS_weakening...
Qed.

Lemma sub_regular : forall E A B ,
    Sub E A B -> wf_env E /\ WFS E A /\ WFS E B.
Proof with auto.
  intros.
  dependent induction H;try solve [destruct_hypos;repeat split;auto]...
  -
    split.
    pick fresh X.
    specialize_x_and_L X L.
    destruct_hypos.
    dependent destruction H2...
    split;
      apply WFS_rec with (L:=L \u fv_tt A1 \u fv_tt A2);intros...
    eapply H2...
    eapply H2...
Qed.

Lemma open_subst_twice : forall A (X Y:atom),
    X \notin fv_tt A ->
    subst_tt X Y (open_tt A (open_tt A X)) = (open_tt A (open_tt A Y)).
Proof with auto.
  intros.
  remember (open_tt A X).
  rewrite subst_tt_open_tt...
  rewrite <- subst_tt_fresh...
  f_equal...
  subst.
  rewrite <- subst_tt_intro...
Qed.

Lemma and_inv : forall E A B C, Sub E A (typ_and B C) -> Sub E A B /\ Sub E A C.
Proof with auto.
  intros E A B C s.
  dependent induction s...
  -
    dependent destruction H0...
  -
    destruct (sub_regular s).
    dependent destruction H1.
    destruct IHs with (B0:=B) (C0:=C)...
  -
    destruct IHs with (B0:=B) (C0:=C)...
Qed.

(* =============================== *)
(* =============================== *)
(* =============================== *)
(* =============================== *)
(* =============================== *)
(* =============================== *)

Ltac get_well_form :=
    repeat match goal with
           | [ H : Sub _ _ _ |- _ ] => apply sub_regular in H;destruct_hypos
           end.

Ltac get_type :=
    repeat match goal with
           | [ H : Sub _ _ _ |- _ ] => get_well_form
           | [ H : WFS _ _ |- _ ] => apply WFS_type in H
           end.

Lemma Reflexivity : forall E A,
    wf_env E ->
    WFS E A ->
    Sub E A A.
Proof with auto.
  intros.
  induction H0...
  apply S_rec with (L:=L \u dom E);intros...
Qed.

Lemma WFS_strengthening: forall E1 E2 T X m,
    WFS (E1 ++ X ~ m ++ E2) T->
    X \notin fv_tt T ->
    WFS (E1 ++ E2) T.
Proof with auto.
  intros.
  dependent induction H;try solve [simpl in *;constructor;eauto]...
  -
    analyze_binds H...
    simpl.
    apply D.F.singleton_iff...
  -
    simpl in *.
    apply WFS_rec with (L:=L \u {{X}} \u fv_tt A).
    intros.
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ E2).
    apply H0 with (X1:=X) (m0:=m)...
    apply notin_fv_tt_open...
    simpl.
    apply notin_fv_tt_open...
    intros.
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ E2).
    apply H2 with (X1:=X) (m0:=m)...
    apply notin_fv_tt_open...
Qed.

Lemma trans_aux : forall E B,
    WFS E B ->
    forall A C,
      Sub E A B -> Sub E B C -> Sub E A C.
Proof with auto.
  intros E B H.
  dependent induction H;intros...
  - (* top *)
    dependent induction H...
    +
      constructor...
      get_well_form...
    +
      dependent induction H1...
  - (* bot *)
    dependent induction H...
  - (* nat *)
    dependent induction H...
    +
      constructor...
      get_well_form...
  - (* and *)
    dependent induction H0...
    +
      constructor...
      get_well_form...
    +
      apply S_andL...
      apply IHSub with (X0:=X)...
    +
      apply S_andR...
      apply IHSub with (X0:=X)...
  - (* arrow *)
    assert (WFS E A0).
    get_well_form...
    assert (WFS E C).
    get_well_form...
    dependent induction H3... (* induction A0 *)
    + (* top *)
      dependent destruction H1...
    + (* bot *)
      constructor...
      get_well_form...
    + (* nat *)
      dependent destruction H1.
    + (* var *)
      dependent destruction H1.
    + (* arrow *)
      dependent induction H4;try solve [dependent destruction H2;inversion H3]...
      * (* top *)
        constructor...
        get_well_form...
      * (* arrow *)
        clear IHWFS5 IHWFS3 IHWFS4 IHWFS6.
        dependent destruction H1.
        dependent destruction H2.
        constructor...
      * (* and *)
        destruct (and_inv H2).
        dependent destruction H1.
        --
          constructor.
          ++
            apply IHWFS5...
            intros.
            assert (Sub E A0 (typ_and A1 B1)).
            apply IHWFS3...
            destruct (and_inv H9)...
            intros.
            assert (Sub E B0 (typ_and A1 B1)).
            apply IHWFS4...
            destruct (and_inv H9)...
          ++
            apply IHWFS6...
            intros.
            assert (Sub E A0 (typ_and A1 B1)).
            apply IHWFS3...
            destruct (and_inv H9)...
            intros.
            assert (Sub E B0 (typ_and A1 B1)).
            apply IHWFS4...
            destruct (and_inv H9)...
    + (* and *)
      dependent induction H1...
    + (* rcd *)
      dependent induction H1...
    + (* rec *)
      dependent induction H1...
  - (* and *)
    destruct (and_inv H1).
    dependent induction H2...
    constructor.
    apply IHSub1 with (A1:=A) (B0:=B)...
    apply IHSub2 with (A1:=A) (B0:=B)...
  - (* rcd *)
    assert (WFS E A /\ WFS E C /\ wf_env E).
    get_well_form...
    destruct_hypos.
    dependent induction H2; try solve [inversion H0;dependent destruction H0;auto]...
    + (* rcd *)
      dependent induction H1...
      *
        assert (Sub E (typ_rcd l T) (typ_and B1 B2)) as qt.
        constructor...
        constructor...
        apply IHSub1 with (l1:=l) (T1:=T)...
        intros.
        specialize (IHWFS0 H1 IHWFS1 H5 qt H3 H4).
        apply and_inv in IHWFS0.
        destruct IHWFS0...
        inversion H3...
        apply IHSub2 with (l1:=l) (T1:=T)...
        intros.
        specialize (IHWFS0 H1 IHWFS1 H5 qt H3 H4).
        apply and_inv in IHWFS0.
        destruct IHWFS0...
        inversion H3...
      *
        inversion H0;subst.
        --
          dependent destruction H0...
  - (* rec *)
    dependent induction H3...
    + (* bot *)
      constructor...
      get_well_form...
    + (* andL *)
      apply S_andL...
      apply IHSub with (A0:=A)...
    + (* andR *)
      apply S_andR...
      apply IHSub with (A0:=A)...
    + (* rec *)
      clear H4 H6.
      dependent induction H7...
      * (* and *)
        constructor...
        eapply IHSub1...
        eapply IHSub2...
      * (* rec *)
        apply S_rec with (L:=L \u L0 \u L1)...
      *
        apply S_top...
        apply WFS_rec with (L:= L \u L0);intros.
        specialize_x_and_L X L0.
        get_well_form...
        specialize_x_and_L X L0.
        get_well_form...
Qed.

Lemma Transitivity : forall E B A C,
      Sub E A B -> Sub E B C -> Sub E A C.
Proof with auto.
  intros.
  assert (WFS E B).
  apply sub_regular in H0.
  apply H0.
  apply trans_aux with (B:=B)...
Qed.

Lemma Sub_weakening: forall E E1 E2 A B,
    Sub (E1++E2) A B ->
    wf_env (E1 ++ E ++ E2) ->
    Sub (E1++E++E2) A B.
Proof with auto.
  intros.
  generalize dependent E.
  dependent induction H;intros...
  -
    constructor...
    apply WFS_weakening...
  -
    constructor...
    apply WFS_weakening...
  -
    constructor...
    apply WFS_weakening...
  -
    apply S_andR...
    apply WFS_weakening...
  -
    apply S_rec with (L:=L \u dom (E1 ++ E ++ E2))...
    intros.
    rewrite_alist (([(X, bind_sub)] ++ E1) ++ E ++ E2).
    apply WFS_weakening...
    rewrite_alist ([(X, bind_sub)] ++ E1 ++ E2)...
    intros.
    rewrite_alist (([(X, bind_sub)] ++ E1) ++ E ++ E2).
    apply WFS_weakening...
    rewrite_alist ([(X, bind_sub)] ++ E1 ++ E2)...
    intros.
    rewrite_alist (([(X, bind_sub)] ++ E1) ++ E ++ E2).
    apply H2...
    rewrite_alist ([(X, bind_sub)] ++ E1 ++ E ++ E2)...
  -
    apply S_top...
    apply WFS_weakening...
Qed.

Lemma label_transform3: forall A (X X0 Y : atom),
    X <> X0 ->
    (subst_tt X Y (open_tt A (typ_rcd X0 (open_tt A X0)))) =
(open_tt (subst_tt X Y A) (typ_rcd X0 (open_tt (subst_tt X Y A) X0))).
Proof with auto.
  intros.
  rewrite  subst_tt_open_tt...
  f_equal...
  simpl.
  f_equal...
  rewrite  subst_tt_open_tt_var...
Qed.

Lemma WFS_replacing: forall E1 E2 T X Y,
    WFS (E1++ X ~ bind_sub ++E2) T ->
    X <> Y ->
    WFS (E1++ Y ~ bind_sub ++E2) (subst_tt X Y T).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros;simpl;try solve [rewrite_alist (E1 ++ Y ~ bind_sub ++ E2);constructor;auto]...
  -
    destruct (X0==X)...
    constructor.
    analyze_binds H.
  -
    apply WFS_rec with (L:=L \u {{X}});intros.
    rewrite <- label_transform3...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ Y ~ bind_sub ++ E2).
    apply H0...
    rewrite  subst_tt_open_tt_var...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ Y ~ bind_sub ++ E2).
    apply H2...
Qed.

Lemma Sub_replacing: forall E1 E2 A B X Y,
    Sub (E1++ X ~ bind_sub ++E2) A B ->
    X <> Y ->
    wf_env (E1 ++ Y ~ bind_sub ++ E2) ->
    Sub (E1++ Y ~ bind_sub ++E2) (subst_tt X Y A) (subst_tt X Y B).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros;simpl;try solve [rewrite_alist (E1 ++ [(Y, bind_sub)] ++ E2);constructor;auto;apply  WFS_replacing;auto]...
  -
    destruct (X0==X)...
    constructor...
    constructor...
    dependent destruction H0.
    analyze_binds H0.
  -
    apply S_rec with (L:=L  \u {{X}} \u dom (E1 ++ [(Y, bind_sub)] ++ E2) );intros...
    rewrite  subst_tt_open_tt_var...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ Y ~ bind_sub ++ E2).
    apply WFS_replacing...
    rewrite_alist ([(X0, bind_sub)] ++ E1 ++ [(X, bind_sub)] ++ E2)...
    rewrite  subst_tt_open_tt_var...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ Y ~ bind_sub ++ E2).
    apply WFS_replacing...
    rewrite_alist ([(X0, bind_sub)] ++ E1 ++ [(X, bind_sub)] ++ E2)...
    rewrite <- label_transform3...
    rewrite <- label_transform3...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ Y ~ bind_sub ++ E2).
    apply H2...
    rewrite_alist ([(X0, bind_sub)] ++ E1 ++ [(Y, bind_sub)] ++ E2).
    constructor...
Qed.

Fixpoint subst_tl (Z : atom) (U : atom) (T : typ) {struct T} : typ :=
  match T with
  | typ_top => typ_top
  | typ_bot => typ_bot
  | typ_nat => typ_nat
  | typ_bvar J => typ_bvar J
  | typ_fvar X => typ_fvar X
  | typ_arrow T1 T2 => typ_arrow (subst_tl Z U T1) (subst_tl Z U T2)
  | typ_and T1 T2 => typ_and (subst_tl Z U T1) (subst_tl Z U T2)
  | typ_mu T => typ_mu (subst_tl Z U T)
  | typ_rcd l T => if (l==Z) then typ_rcd U (subst_tl Z U T) else typ_rcd l (subst_tl Z U T)
  end.

Lemma subst_tl_open_tt_rec : forall Z  A (X Y : atom) k,
    subst_tl X Y (open_tt_rec k A Z) = open_tt_rec k (subst_tl X Y A) (subst_tl X Y Z).
Proof with auto.
  intros Z.
  induction Z;intros ; simpl in *; f_equal...
  -
    destruct (k==n)...
  -
    destruct (a==X);subst;simpl...
    f_equal...
    f_equal...
Qed.

Lemma subst_tl_open_tt : forall A Z (X Y : atom),
    subst_tl X Y (open_tt A Z) = open_tt (subst_tl X Y A) (subst_tl X Y Z).
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_tl_open_tt_rec...
Qed.

Lemma subst_tl_open_tt_var : forall A (X Y Z: atom),
    subst_tl X Y (open_tt A Z) = open_tt (subst_tl X Y A) Z.
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_tl_open_tt_rec...
Qed.

Lemma label_transform2: forall A (X X0 Y : atom),
    X <> X0 ->
    (subst_tl X Y (open_tt A (typ_rcd X0 (open_tt A X0)))) =
(open_tt (subst_tl X Y A) (typ_rcd X0 (open_tt (subst_tl X Y A) X0))).
Proof with auto.
  intros.
  rewrite  subst_tl_open_tt...
  f_equal...
  simpl.
  destruct (X0==X);subst...
  destruct H...
  f_equal...
  rewrite subst_tl_open_tt...
Qed.

Lemma WFS_replacing2: forall E T X Y,
    WFS E T ->
    X <> Y ->
    WFS E (subst_tl X Y T).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros;simpl;try solve [constructor;auto]...
  -
    destruct (l==X);subst...
  -
    apply WFS_rec with (L:=L \u {{X}});intros.
    rewrite <- label_transform2...
    rewrite <- subst_tl_open_tt_var...
Qed.

Lemma Sub_replacing2: forall E A B X Y,
    Sub E A B ->
    X <> Y ->
    Sub E (subst_tl X Y A) (subst_tl X Y B).
Proof with eauto using WFS_replacing2.
  intros.
  generalize dependent Y.
  dependent induction H;intros;simpl;try solve [constructor;auto]...
  -
    apply S_rec with (L:=L  \u {{X}} \u dom E );intros...
    rewrite <- subst_tl_open_tt_var...
    rewrite <- subst_tl_open_tt_var...
    rewrite <- label_transform2...
    rewrite <- label_transform2...
  -
    destruct (l==X);subst...
Qed.

Lemma label_transform1: forall (X Y:atom) A,
    X \notin fv_tt A ->
    (subst_tt X Y (open_tt A (typ_rcd X (open_tt A X)))) =
    (open_tt A (typ_rcd X (open_tt A Y))).
Proof with auto.
  intros.
  rewrite subst_tt_open_tt...
  simpl...
  rewrite <- subst_tt_intro...
  f_equal...
  rewrite <- subst_tt_fresh...
Qed.

Lemma subst_tl_fresh: forall A X Y,
    X `notin` fl_tt A ->
    subst_tl X Y A = A.
Proof with auto.
  induction A;intros;simpl in *;try solve [f_equal;auto]...
  destruct (a==X);subst...
  apply notin_union in H.
  destruct H.
  apply notin_singleton_1 in H...
  destruct H...
  f_equal...
Qed.

Lemma label_transform4: forall (X Y Z:atom) A,
    X \notin fl_tt A ->
    (subst_tl X Y (open_tt A (typ_rcd X (open_tt A Z)))) =
    (open_tt A (typ_rcd Y (open_tt A Z))).
Proof with auto.
  intros.
  rewrite subst_tl_open_tt...
  simpl...
  destruct (X==X)...
  f_equal...
  apply subst_tl_fresh...
  f_equal...
  apply subst_tl_fresh...
  apply notin_fl_tt_open...
  destruct n...
Qed.

Lemma Sub_replacing_open: forall E1 E2 A B X Y,
    Sub (E1++ X ~ bind_sub ++E2) (open_tt A (typ_rcd X (open_tt A X))) (open_tt B (typ_rcd X (open_tt B X)))  ->
    Y \notin {{X}} \u fv_tt A \u fv_tt B ->
    X \notin fv_tt A \u fv_tt B \u fl_tt A \u fl_tt B ->
    wf_env (E1 ++ [(Y, bind_sub)] ++ E2) ->
    Sub (E1++ Y ~ bind_sub ++E2) (open_tt A (typ_rcd Y (open_tt A Y))) (open_tt B (typ_rcd Y (open_tt B Y))).
Proof with auto.
  intros.
  apply Sub_replacing with (Y:=Y) in H...
  rewrite label_transform1 in H...
  rewrite label_transform1 in H...
  apply Sub_replacing2 with (X:=X) (Y:=Y) in H...
  rewrite label_transform4 in H...
  rewrite label_transform4 in H...
Qed.


(*
A4. Algorithms on Lists
=======================
*)

From graph_pebbling Require Import A1_misc A3_arith.

Notation lprod la lb := (foldr (λ a, ((a,.) <$> lb ++.)) [] la).
Notation summation := (foldr (+) 0).
Notation product := (foldr Nat.mul 1).
Notation concat := (foldr (++) []).

Lemma non_empty_length {A} (l : list A) : l ≠ [] ↔ length l ≠ 0.
Proof. destruct l; done. Qed.

Lemma non_empty_inv {A} (l : list A) : l ≠ [] -> ∃ a, a ∈ l.
Proof. destruct l; [done|eexists]; apply elem_of_list_here. Qed.

Lemma non_empty_elem {A} (a : A) l : a ∈ l -> l ≠ [].
Proof. destruct l; set_solver. Qed.

Lemma head_elem_of {A} (a : A) l : head l = Some a -> a ∈ l.
Proof. intros H; apply head_Some in H as (l' & ->); set_solver. Qed.

Lemma fmap_const {A B} (a : A) (l : list B) :
  const a <$> l = repeat a (length l).
Proof. induction l; cbn; congruence. Qed.

Lemma foldr_comm `{left_id : LeftId A (=) e f, assoc : Assoc A (=) f}
  (l l' : list A) : foldr f e (l ++ l') = f (foldr f e l) (foldr f e l').
Proof.
induction l; cbn; [symmetry; apply left_id|].
rewrite IHl; apply assoc.
Qed.

(*
Sublists and permutations
-------------------------
*)
Section Sublists.

Global Instance left_comm_cons_app {A} (a : A) :
  CondLeftComm (≡ₚ) (λ _, True) (cons a) (++).
Proof. repeat intro; done. Qed.

Lemma foldr_Permutation `{assoc : Assoc A (=) f, comm : Comm A A (=) f}
  a0 la1 la2 : la1 ≡ₚ la2 -> foldr f a0 la1 = foldr f a0 la2.
Proof. induction 1; cbn; congruence. Qed.

Lemma submseteq_fmap {A B} (f : A -> B) l l' :
  l' ⊆+ l -> f <$> l' ⊆+ f <$> l.
Proof. induction 1; econstructor; done. Qed.

Lemma submseteq_Forall {A} (P : A -> Prop) l l' :
  l' ⊆+ l -> Forall P l -> Forall P l'.
Proof. induction 1; inversion 1; subst; auto; inv H3; auto. Qed.

Lemma sublist_fmap_inv {A B} (f : A -> B) la lb :
  lb `sublist_of` f <$> la -> ∃ la', la' `sublist_of` la ∧ lb = f <$> la'.
Proof.
revert lb; induction la; cbn; intros ? H.
- apply sublist_nil_r in H as ->; exists []; done.
- assert (H' := H); apply sublist_cons_r in H as [H|(lb' & -> & H)];
  apply IHla in H as (la' & H & ->).
  + exists la'; split; [|done]; constructor; done.
  + exists (a :: la'); cbn; split; [|done]; constructor; done.
Qed.

Lemma sublist_concat {A} (l l' : list (list A)) :
  l' `sublist_of` l -> concat l' `sublist_of` concat l.
Proof.
revert l'; induction l; cbn; intros ? H.
- apply sublist_nil_r in H as ->; done.
- apply sublist_cons_r in H as [H|(l'' & -> & H)]; cbn.
  + apply sublist_app_r; exists []; eexists; cbn; repeat split.
    apply sublist_nil_l. apply IHl; done.
  + apply sublist_app; [done|].
    apply IHl; done.
Qed.

End Sublists.

(*
Ordered lists
-------------
*)
Section Ordered_Lists.

Context {A : Type}.
Variable R : relation A.

Inductive ordered : list A -> Prop :=
  | ordered_nil : ordered []
  | ordered_singleton a : ordered [a]
  | ordered_cons a0 a1 l : R a0 a1 ->
    ordered (a1 :: l) -> ordered (a0 :: a1 :: l).

Lemma ordered_cons_inv_hd `{refl : Reflexive _ R} a l :
  ordered (a :: l) -> R a (hd a l).
Proof. destruct l; cbn; inversion_clear 1; [apply refl|done]. Qed.

Lemma ordered_cons_inv_tl a l :
  ordered (a :: l) -> ordered l.
Proof. destruct l; inversion_clear 1; [constructor|done]. Qed.

End Ordered_Lists.

(*
Cartesian product of lists
--------------------------
*)
Section Cartesian_Product.

Context {A B : Type}.
Implicit Types la : list A.
Implicit Types lb : list B.

Lemma lprod_enum `{Finite A, Finite B} :
  enum (A * B) = lprod (enum A) (enum B).
Proof. done. Qed.

Lemma elem_of_lprod la lb a b :
  a ∈ la -> b ∈ lb -> (a, b) ∈ lprod la lb.
Proof. induction la; set_solver. Qed.

Lemma elem_of_lprod_inv la lb a b :
  (a, b) ∈ lprod la lb -> a ∈ la ∧ b ∈ lb.
Proof. induction la; set_solver. Qed.

Lemma lprod_app la1 la2 lb :
  lprod (la1 ++ la2) lb = lprod la1 lb ++ lprod la2 lb.
Proof. induction la1; cbn; [done|]. rewrite IHla1, (assoc app); done. Qed.

Lemma NoDup_lprod la lb :
  NoDup la -> NoDup lb -> NoDup (lprod la lb).
Proof.
induction la; cbn; intros. constructor.
inv H; apply NoDup_app; repeat split.
- apply NoDup_fmap; [|done]. repeat intro; congruence.
- intros [] H1 H2; apply elem_of_lprod_inv in H2; set_solver.
- apply IHla; done.
Qed.

End Cartesian_Product.

(*
Concatenation of lists
----------------------
*)
Section Concatenation.

Lemma elem_of_concat {A} (a : A) l ls :
  a ∈ l -> l ∈ ls -> a ∈ concat ls.
Proof. set_solver. Qed.

Lemma concat_repeat_nil {A} n :
  concat (@repeat (list A) [] n) = [].
Proof. induction n; cbn; done. Qed.

Lemma concat_fmap_singleton {A} (l : list A) :
  concat ((λ a, [a]) <$> l) = l.
Proof. induction l; cbn; congruence. Qed.

Lemma fmap_concat_comm {A B} (f : A -> B) l :
  f <$> concat l = concat (@fmap list _ _ _ f <$> l).
Proof.
induction l; cbn; [done|].
rewrite fmap_app, IHl; done.
Qed.

Lemma concat_lprod {A B} (f : A -> B -> nat) la lb :
  concat ((λ a, f a <$> lb) <$> la) = uncurry f <$> lprod la lb.
Proof.
induction la; cbn; [done|].
rewrite fmap_app, IHla, <-list_fmap_compose; done.
Qed.

Lemma sublist_concat_r {A} (l : list A) ls :
  l ∈ ls -> l `sublist_of` concat ls.
Proof.
induction ls; cbn; [set_solver|]; intros.
simpl_elem_of; apply sublist_app_r; [exists l, []|exists [], l].
- repeat split; [rewrite app_nil_r; done|done|apply sublist_nil_l].
- repeat split; [apply sublist_nil_l|apply IHls; done].
Qed.

End Concatenation.

(*
Altering a list
---------------
*)
Section Fold_FMap_Alter.

Lemma fmap_no_alter `{EqDecision A} {B} (l : list A) k (f : A -> B) g :
  k ∉ l -> alter g k f <$> l = f <$> l.
Proof.
induction l; cbn; intros Hk; [done|].
apply not_elem_of_cons in Hk as [].
simpl_alter; rewrite IHl; done.
Qed.

Context `{f_comm : Comm A A R f}.
Context `{l_domi : LeftDominant A P f}.
Context `{l_comm : CondLeftComm A R P g f}.
Context `{equiv_R : Equivalence A R}.
Context `{proper_P : Proper _ (R ==> iff) P}.
Context `{proper_g : Proper _ (R ==> R) g}.
Context `{proper_f : Proper _ (R ==> R ==> R) f}.

Lemma foldr_left_dominant a x l :
  x ∈ l -> P x -> P (foldr f a l).
Proof.
intros Hl Hx; induction l; cbn; simpl_elem_of.
- apply l_domi; done.
- rewrite f_comm; apply l_domi, IHl, Hl.
Qed.

Lemma foldr_alter `{EqDecision B} (l : list B) k a h :
  P (h k) -> k ∈ l -> NoDup l ->
  R (foldr f a (alter g k h <$> l)) (g (foldr f a (h <$> l))).
Proof.
intros Hh; induction l; cbn; intros Hk; simpl_elem_of; inversion_clear 1.
- simpl_alter; rewrite l_comm, fmap_no_alter; done.
- simpl_alter; [|congruence].
  rewrite IHl, f_comm, l_comm, f_comm; try done.
  apply foldr_left_dominant with (x:=h k); [|done].
  apply elem_of_list_fmap_1; done.
Qed.

End Fold_FMap_Alter.

(*
Summing a list of numbers
-------------------------
*)
Section Summation.

Global Instance summation_Permutation : Proper ((≡ₚ) ==> (=)) summation.
Proof. intros xs ys H; apply foldr_Permutation. done. Qed.

Lemma summation_fmap_const {A} (l : list A) k :
  summation (const k <$> l) = k * length l.
Proof. induction l; clia. Qed.

Lemma summation_forall_eq l k :
  Forall (eq k) l -> summation l = k * length l.
Proof. induction l; cbn; inversion_clear 1; lia. Qed.

Lemma summation_forall_le l k :
  Forall (λ i, i ≤ k) l -> summation l ≤ k * length l.
Proof. induction l; cbn; inversion_clear 1; lia. Qed.

Lemma summation_add {A} f g (l : list A) :
  summation (f .+ g <$> l) = summation (f <$> l) + summation (g <$> l).
Proof. induction l; clia. Qed.

Lemma summation_mul_const {A} n f (l : list A) :
  summation (const n .* f <$> l) = n * summation (f <$> l).
Proof. induction l; clia. Qed.

Lemma summation_app l1 l2 :
  summation (l1 ++ l2) = summation l1 + summation l2.
Proof.
induction l1; cbn; [done|].
rewrite IHl1, (assoc (+)); done.
Qed.

Lemma submseteq_summation l1 l2 :
  l1 ⊆+ l2 -> summation l1 ≤ summation l2.
Proof.
intros H; apply submseteq_Permutation in H as [lc ->].
rewrite summation_app; lia.
Qed.

Corollary elem_of_summation n l :
  n ∈ l -> n ≤ summation l.
Proof.
intros H; replace n with (summation [n]) by clia.
apply submseteq_summation, singleton_submseteq_l, H.
Qed.

Lemma summation_le {A} (f g : A -> nat) l :
  (∀ a, a ∈ l -> f a ≤ g a) ->
  summation (f <$> l) ≤ summation (g <$> l).
Proof.
induction l; cbn; intros. done.
apply Nat.add_le_mono. set_solver. apply IHl; set_solver.
Qed.

Lemma summation_lt {A} (f g : A -> nat) x l :
  (∀ a, a ∈ l -> f a ≤ g a) -> x ∈ l -> f x < g x ->
  summation (f <$> l) < summation (g <$> l).
Proof.
induction l; cbn; intros; simpl_elem_of.
- apply Nat.add_lt_le_mono. done. apply summation_le; set_solver.
- apply Nat.add_le_lt_mono. set_solver. apply IHl; set_solver.
Qed.

Lemma summation_sub {A} (f g : A -> nat) l :
  (∀ a, a ∈ l -> g a ≤ f a) ->
  summation (f .- g <$> l) = summation (f <$> l) - summation (g <$> l).
Proof.
induction l; cbn; intros; [done|].
assert (Hl : ∀ a, a ∈ l -> f a ≥ g a) by set_solver;
assert (Ha : a ∈ a :: l) by set_solver;
apply summation_le in Hl as H_le; apply H in Ha.
rewrite IHl; [lia|done].
Qed.

Lemma summation_concat {A} (f : A -> list nat) l :
  summation ((λ a, summation (f a)) <$> l) = summation (concat (f <$> l)).
Proof.
induction l; cbn; [done|].
rewrite summation_app; congruence.
Qed.

Lemma summation_lprod {A B} (f : A -> B -> nat) la lb :
  summation ((λ a, summation (f a <$> lb)) <$> la) =
  summation (uncurry f <$> lprod la lb).
Proof.
rewrite summation_concat, concat_lprod; done.
Qed.

Lemma summation_nonzero l :
  summation l > 0 -> ∃ n, n ∈ l ∧ n > 0.
Proof.
unfold size; induction l as [|n l]; cbn; intros; [lia|].
dec (0 < n); [exists n; set_solver|]; destruct IHl as (m & ? & ?); [lia|].
exists m; set_solver.
Qed.

End Summation.

(*
Filtering a list
----------------
*)
Section List_Filter.

Context {A : Type}.
Variable P : A -> Prop.
Context `{dec : ∀ a, Decision (P a)}.

Fixpoint dsig_filter (l : list A) : list (dsig P) :=
  match l with
  | [] => []
  | a :: l' =>
    let tl := dsig_filter l' in
    match decide (P a) with
    | left P => dexist a P :: tl
    | right _ => tl
    end
  end.

Lemma filter_app_Permutation (l : list A) :
  l ≡ₚ filter P l ++ filter (not ∘ P) l.
Proof.
induction l; cbn; [done|].
dec (P a); dec (¬ P a); try done; cbn;
rewrite <-?Permutation_middle, <-IHl; done.
Qed.

Lemma filter_NoDup_Permutation l l' :
  (∀ a, P a -> a ∈ l ↔ a ∈ l') ->
  (∀ a, a ∈ l' -> P a) ->
  NoDup l -> NoDup l' ->
  filter P l ≡ₚ l'.
Proof.
revert l'; induction l; cbn; intros l' H1 H2 H3 H4.
- destruct l'; set_solver.
- inv H3; dec (P a); [|apply IHl; set_solver].
  assert (H3 : a ∈ l') by set_solver.
  apply elem_of_Permutation in H3 as [l'' H3]; rewrite H3 in *; inv H4.
  apply Permutation_cons; [done|]; apply IHl; try done; intros b Hb.
  + apply H1 in Hb; rewrite H3 in Hb; set_solver.
  + intros; apply H2; rewrite H3; set_solver.
Qed.

Lemma elem_of_dsig_filter_inv a l :
  a ∈ dsig_filter l -> P (`a) ∧ `a ∈ l.
Proof.
induction l; cbn; [set_solver|].
destruct (decide _); set_solver.
Qed.

Lemma elem_of_dsig_filter a l :
  `a ∈ l -> a ∈ dsig_filter l.
Proof.
induction l; cbn; [set_solver|]; rewrite elem_of_cons; intros [<-|Hl].
- dec (P (`a)).
  + rewrite dexists_proj1; apply elem_of_list_here.
  + destruct a as [a H1]; apply bool_decide_unpack in H1 as H2; cbn in *; done.
- destruct (decide _); [apply elem_of_list_further|]; apply IHl; done.
Qed.

Lemma NoDup_dsig_filter l :
  NoDup l -> NoDup (dsig_filter l).
Proof.
induction l; cbn; [constructor|inversion_clear 1].
destruct (decide _); [constructor|]; try (apply IHl; done).
intros H; apply elem_of_dsig_filter_inv in H as [_ H]; done.
Qed.

End List_Filter.

(*
Searching a vector
------------------
*)
Section Vector_Find.

Context {A : Type}.
Variable P : A -> Prop.
Context `{∀ a : A, Decision (P a)}.

Fixpoint vec_find {n} (v : vec A n) : option (fin n) :=
  match v with
  | [#] => None
  | vcons a v' =>
    if decide (P a) then Some (0%fin)
    else FS <$> vec_find v'
  end.

Lemma vec_find_sound {n} (v : vec A n) i :
  vec_find v = Some i -> P (v !!! i).
Proof.
induction v; cbn; [done|].
dec (P h); [intros; simplify_eq; done|];
inv_fin i; destruct (vec_find v); cbn; try done.
intros; apply IHv; simplify_eq; done.
Qed.

Lemma vec_find_complete {n} (v : vec A n) i :
  P (v !!! i) -> vec_find v ≠ None.
Proof.
induction v; cbn; [inv_fin i|].
dec (P h); [done|]; inv_fin i; cbn; [done|]; intros i Hi.
apply IHv in Hi; destruct (vec_find v) eqn:E; done.
Qed.

End Vector_Find.

(*
Enumerating all vectors
-----------------------
*)
Section Vector_Enumeration.

Context `{fin : Finite A}.

Fixpoint vec_enum l n : list (vec A n) :=
  match n with
  | 0 => [[#]]
  | S m => a ← l; vcons a <$> vec_enum l m
  end.

Lemma NoDup_bind {B} (f : A -> list B) l :
  (∀ a a' b, b ∈ f a -> b ∈ f a' -> a = a') ->
  (∀ a, NoDup (f a)) -> NoDup l -> NoDup (l ≫= f).
Proof.
intros inj Hf Hl; induction l; cbn; [constructor|inv Hl].
apply NoDup_app; repeat split; auto. intros b H3 H4.
apply elem_of_list_bind in H4 as (a' & H5 & H6).
apply (inj a a') in H3; subst; done.
Qed.

Lemma NoDup_vec_enum l n :
  NoDup l -> NoDup (vec_enum l n).
Proof.
induction n; cbn; intros; [apply NoDup_singleton|apply NoDup_bind]; intros.
- apply elem_of_list_fmap in H0 as (v & -> & _), H1 as (v' & E & _); congruence.
- apply NoDup_fmap; auto; apply inj_vcons_tl.
- done.
Qed.

Global Program Instance vec_finite n : Finite (vec A n) :=
  {| enum := vec_enum (enum A) n |}.
Next Obligation.
intros; apply NoDup_vec_enum, NoDup_enum.
Qed.
Next Obligation.
induction x; cbn. set_solver.
apply elem_of_list_bind; exists h; split.
apply elem_of_list_fmap_1; done. apply elem_of_enum.
Qed.

End Vector_Enumeration.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e256m189_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e171m19_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Definition ignore (n:nat) := tt.
Lemma ignore_S x : ignore (S x) = ignore x. exact eq_refl. Qed.

Goal ignore 1 = tt. Time do 1000 rewrite ignore_S, <-ignore_S. exact eq_refl. Time Qed.
(* Finished transaction in 0.266 secs (0.265u,0.s) (successful) *)
(* Finished transaction in 0.047 secs (0.046u,0.s) (successful) *)
Goal ignore 1 = tt. Time do 2000 rewrite ignore_S, <-ignore_S. exact eq_refl. Time Qed.
(* Finished transaction in 0.512 secs (0.5u,0.009s) (successful) *)
(* Finished transaction in 0.096 secs (0.096u,0.s) (successful) *)
Goal ignore 1 = tt. Time do 4000 rewrite ignore_S, <-ignore_S. exact eq_refl. Time Qed.
(* Finished transaction in 1.017 secs (0.995u,0.016s) (successful) *)
(* Finished transaction in 0.178 secs (0.171u,0.006s) (successful) *)
Goal ignore 1 = tt. Time do 8000 rewrite ignore_S, <-ignore_S. exact eq_refl. Time Qed.
(* Finished transaction in 2.154 secs (2.139u,0.003s) (successful) *)
(* Finished transaction in 0.368 secs (0.366u,0.s) (successful) *)
Goal ignore 1 = tt. Time do 16000 rewrite ignore_S, <-ignore_S. exact eq_refl. Time Qed.
(* Finished transaction in 3.983 secs (3.963u,0.s) (successful) *)
(* Finished transaction in 0.738 secs (0.735u,0.s) (successful) *)
Goal ignore 1 = tt. Time do 32000 rewrite ignore_S, <-ignore_S. exact eq_refl. Time Qed.
(* Finished transaction in 7.956 secs (7.913u,0.003s) (successful) *)
(* Finished transaction in 1.475 secs (1.466u,0.003s) (successful) *)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e255m19_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e255m19_11limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e212m29_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e194m33_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e213m3_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e413m21_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e212m29_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.