From mathcomp Require Import all_ssreflect.
Require Import ZArith.

Set Implicit Arguments.

(* Represent a + b sqrt(2) as a pair of integers *)
Definition K : Set := Z * Z.

(* Add a decidable equality structure to Z *)
Lemma Zeq_boolP : Equality.axiom Zeq_bool.
Proof.
move=> x y.
by apply: (iffP idP) => /Zeq_is_eq_bool.
Qed.

Definition Zeq_mixin := EqMixin Zeq_boolP.
Canonical Z_eqType := Eval hnf in EqType _ Zeq_mixin.

(* Addition and multiplication on K *)
Definition addK (a b : K) : K := (a.1 + b.1, a.2 + b.2)%Z.
Definition mulK (a b : K) : K :=
  (a.1 * b.1 + a.2 * b.2 * 2, a.1 * b.2 + a.2 * b.1)%Z.

(* 3-dimensional vectors *)
Definition K3 : Set := K * K * K.

Definition scalar (k1 k2 : K3) : K :=
  let '(x1,y1,z1) := k1 in
  let '(x2,y2,z2) := k2 in
  addK (mulK x1 x2) (addK (mulK y1 y2) (mulK z1 z2)).

Module Scalar.
(* Our encoding really corresponds to the scalar product in R3 *)
Require Import Reals Field.
Open Scope R_scope.

Definition IKR (a : K) := IZR a.1 + IZR a.2 * sqrt (IZR 2).

Lemma addKE (a b : K) : IKR (addK a b) = IKR a + IKR b.
Proof. rewrite /IKR /addK /= !plus_IZR. field. Qed.

Lemma mulKE (a b : K) : IKR (mulK a b) = IKR a * IKR b.
Proof.
rewrite /IKR /mulK !(plus_IZR,mult_IZR) -[in _ * IZR 2](sqrt_def (IZR 2)).
  field.
auto with real.
Qed.

Lemma scalarE (v w : K3) :
  let: (x1,y1,z1) := v in let: (x2,y2,z2) := w in
  IKR (scalar v w) = IKR x1 * IKR x2 + IKR y1 * IKR y2 + IKR z1 * IKR z2.
Proof.
case: v => [[x1 y1] z1].
case: w => [[x2 y2] z2].
rewrite /scalar !(addKE,mulKE).
field.
Qed.
End Scalar.

(* A finite type representation for our vectors *)
Definition K0 := option (bool * bool).
Definition K0toK (a : K0) : K :=
  match a with
  | None => (0, 0)
  | Some (s, v) =>
    let x := if s then 1 else -1 in
    if v then (x, 0) else (0, x)
  end%Z.

Definition vals := [:: (0,0); (1,0); (0,1); (-1,0); (0,-1)]%Z.

Lemma vals_ok : vals = map K0toK (enum [set: K0]).
Proof.
rewrite /vals enum_setT Finite.EnumDef.enumDef /=.
rewrite Finite.EnumDef.enumDef /=.
rewrite /prod_enum enumT.
by rewrite !Finite.EnumDef.enumDef.
Qed.

Section flat_map.
Variables A B : eqType.
Variable f : A -> seq B.
Definition flat_map l := flatten (map f l).

Lemma flat_map_cat l1 l2 : flat_map (l1 ++ l2) = flat_map l1 ++ flat_map l2.
Proof. by rewrite /flat_map map_cat flatten_cat. Qed.
End flat_map.
Arguments flat_map {A B}.
Notation "l >>= f" := (flat_map f l) (at level 49).

Definition vecs : seq K3 :=
  [seq (xy,z) | xy <- [seq (x,y) | x <- vals, y <- vals], z <- vals].

Lemma uniq_vals : uniq vals.
Proof. done. Qed.

Lemma uniq_vecs : uniq vecs.
Proof.
have uv := uniq_vals.
apply allpairs_uniq => //.
move=> [x y] [x' y'].
move=> /allpairsP [p] [] Hx Hy [] xp1 xp2; subst.
by move=> /allpairsP [p'] [] Hx' Hy' [] xp1 xp2; subst.
Qed.

Definition K03 : Set := K0 * K0 * K0.
Definition K0toK3 (v : K03) : K3 :=
  let: (x,y,z) := v in (K0toK x, K0toK y, K0toK z).

Lemma vecs_ok : vecs =i map K0toK3 (enum [set: K03]).
Proof.
move=> v.
rewrite /vecs vals_ok.
case: mapP.
  case => -[[x y] z] Hv -> {v}.
  apply/flattenP.
    exists [seq (K0toK x, K0toK y, z)|z <- [seq K0toK i | i <- enum [set: K0]]].
    apply/mapP.
    exists (K0toK x, K0toK y) => //.
    apply/allpairsP.
    exists (K0toK x, K0toK y) => //=.
    by do !split; apply map_f; rewrite mem_enum in_setT.
  apply/mapP.
  exists (K0toK z) => //.
  apply map_f.
  by rewrite mem_enum in_setT.
move=> Hv; apply/negP => Hv'.
elim: Hv.
case/flattenP: Hv' => s /mapP [] x /allpairsP [] xy [] /mapP [x0] _ ->.
case/mapP => y0 _ -> -> -> {x s} /mapP [z] /mapP [z0] _ -> -> {v z}.
exists (x0, y0, z0) => //.
by rewrite mem_enum in_setT.
Qed.

Lemma K0toK_inj : injective K0toK.
Proof. by move => [[[] []]|] [[[] []]|]. Qed.

Lemma K0toK3_inj : injective K0toK3.
Proof.
move=> [[x y] z] [[x' y'] z'] /= [] /K0toK_inj -> /K0toK_inj -> /K0toK_inj ->.
done.
Qed.

(* Prove that we are using the right set of vectors *)
Lemma vecs_ok' :
  behead vecs =i map K0toK3 (enum ([set: K03] :\ (None,None,None))).
Proof.
have -> : behead vecs = rem ((0,0),(0,0),(0,0))%Z vecs by [].
move=> v.
rewrite (mem_rem_uniq _ uniq_vecs).
rewrite inE /= vecs_ok.
case Hv: (v == _) => /=.
  symmetry; apply/mapP => -[v0].
  rewrite mem_enum inE inE => /andP [v0n] _ vv0.
  subst.
  elim: (negP v0n).
  apply/eqP/K0toK3_inj.
  by rewrite (eqP Hv).
case: mapP.
  move=> [v0] _ Hv'.
  apply/esym/mapP.
  exists v0 => //.
  rewrite mem_enum !inE andbT.
  apply/negP => /eqP Hv0.
  by rewrite Hv' (f_equal K0toK3 Hv0) eqxx in Hv.
move=> Hv'.
apply/esym/negP => /mapP [v0].
rewrite mem_enum !inE andbT => Hv0 Hv''.
elim: Hv'.
exists v0 => //.
by rewrite mem_enum in_setT.
Qed.

(* Reduce the number of vectors by removing parallel ones 124 -> 49 *)
Definition reducible (k : K3) :=
  match k with
  | ((0,_),(0,_),(0,_)) | ((-1,_),_,_)
  | ((0,_),(-1,_),_)    | ((0,_),(0,_),(-1,_)) => true
  | _ => false
  end%Z.
Definition vertices := [seq k <- behead vecs | ~~ reducible k]%Z.

Definition defK3 := ((1,0),(1,0),(1,0))%Z.
Definition getv n := nth defK3 vertices n.
Definition indices := iota 0 (size vertices).

(* Represent the orthogonality relation as a list of list of indices *)
Definition orthogonal k1 k2 :=
  scalar k1 k2 == (0,0)%Z.
Definition edges :=
  [seq [seq orthogonal (getv i) (getv j) | j <- indices] | i <- indices].
Definition edge k1 k2 := nth false (nth [::] edges k1) k2.

Lemma edgeE i j :
  i < size indices -> j < size indices ->
  edge i j = orthogonal (getv i) (getv j).
Proof.
rewrite /edge /edges => isz jsz.
rewrite (@nth_map _ 0) // (@nth_map _ 0) //.
by rewrite !nth_iota.
Qed.

Definition color := option bool.
Definition black : color := Some false.
Definition white : color := Some true.

(* Definition of a good coloring *)
Definition good_coloring (vectors : seq K3) (coloring : K3 -> color) :=
  (forall v, v \in vectors -> coloring v != None) /\
  (forall v w, v \in vectors -> w \in vectors -> orthogonal v w ->
     black \in map coloring [:: v; w]) /\
  (forall v w u, v \in vectors -> w \in vectors -> u \in vectors ->
     orthogonal v w -> orthogonal v u -> orthogonal w u ->
     white \in map coloring [:: v; w; u]).

Lemma vertices_sub (v : K3) : v \in vertices -> v \in behead vecs.
Proof. by rewrite mem_filter => /andP[_]. Qed.

Definition KtoK0 (x : K) : K0 :=
  match x with
  | (1,0) => Some (true, true)
  | (-1,0) => Some (false, true)
  | (0,1) => Some (true, false)
  | (0,-1) => Some (false, false)
  | _ => None
  end%Z.

Definition K3toK0 (v : K3) : K03 :=
  let: (x,y,z) := v in (KtoK0 x, KtoK0 y, KtoK0 z).

Lemma cancelKtoK0 : cancel K0toK KtoK0.
Proof. by case=> [[[] []]|]. Qed.

Definition scale (k : K3) :=
  match k with
  | ((0,x),(0,y),(0,z)) => ((x,0),(y,0),(z,0))
  | _ => k
  end%Z.

Definition negK (k : K) : K :=
  let: (x,y) := k in (-x,-y)%Z.

Definition negK3 (v : K3) : K3 :=
  let: (x,y,z) := v in (negK x, negK y, negK z).

Definition reduce (k : K3) :=
  let k := scale k in
  match k with
  | ((-1,_),_,_)
  | ((0,_),(-1,_),_)
  | ((0,_),(0,_),(-1,_)) => negK3 k
  | _ => k
  end%Z.

Lemma reduce_sub (v : K3) : v \in behead vecs -> (reduce v \in vertices).
Proof.
rewrite /vertices vecs_ok' => /mapP [v0].
rewrite mem_enum 3!inE andbT => Hv0 -> {v}.
rewrite mem_filter vecs_ok'.
apply/andP; split.
  by case: v0 Hv0 => -[] [[[] []]|] //= [[[] []]|] //= [[[] []]|].
apply/mapP.
exists (K3toK0 (reduce (K0toK3 v0))).
  rewrite mem_enum !inE andbT.
  by case: v0 Hv0 => -[] [[[] []]|] //= [[[] []]|] //= [[[] []]|].
by case: v0 Hv0 => -[] [[[] []]|] //= [[[] []]|] //= [[[] []]|].
Qed.

Lemma reduce_ortho_l v w : orthogonal v w -> orthogonal (reduce v) w.
Proof.
rewrite /reduce => Hvw.
have Hsvw: orthogonal (scale v) w.
  rewrite /scale.
  case: v Hvw => [[[[|x1|x1] x2] // [[|y1|y1] y2]] // [[|z1|z1] z2]] //.
  case: w => [[[x1' x2'] [y1' y2']] [z1' z2']].
  rewrite /orthogonal /scalar /addK /mulK /= => /eqP [] Ho1 Ho2.
  rewrite !Z.add_0_r Ho2.
  apply/eqP; congr pair.
  move: Ho1.
  by rewrite -!Z.mul_add_distr_r => /Z.mul_eq_0_l ->.
have : orthogonal (negK3 (scale v)) w.
  move: Hsvw.
  rewrite /negK3.
  case: (scale v) => -[[x1 x2] [y1 y2]] [z1 z2] /=.
  case: w {Hvw} => [[[x1' x2'] [y1' y2']] [z1' z2']].
  rewrite /orthogonal /scalar /addK /mulK /= => /eqP [] Ho1 Ho2.
  by rewrite !Z.mul_opp_l -!Z.opp_add_distr Ho1 Ho2.
move: Hsvw {Hvw}.
case: (scale v) => -[] [[|x1|x1] x2] //=.
  case=> -[|y1|y1] y2 //=.
    case=> -[|z1|z1] z2 //.
    by case: z1.
  by case: y1.
by case: x1.
Qed.

Lemma mulKC a b : mulK a b = mulK b a.
Proof.
case: a b => [a1 a2] [b1 b2].
rewrite /mulK /=.
by rewrite !(Z.mul_comm b1) !(Z.mul_comm b2) (Z.add_comm (a2 * b1)).
Qed.

Lemma orthogonalC v w : orthogonal v w = orthogonal w v.
Proof.
rewrite /orthogonal /scalar.
case: v => -[x1 y1] z1.
case: w => -[x2 y2] z2.
by rewrite (mulKC x2) (mulKC y2) (mulKC z2).
Qed.

Lemma reduce_ortho v w : orthogonal v w -> orthogonal (reduce v) (reduce w).
Proof.
move=> Hvw.
apply reduce_ortho_l.
rewrite orthogonalC.
apply reduce_ortho_l.
by rewrite orthogonalC.
Qed.

(* Proof that reduction does not change colorabillity *)
Lemma reduction_ok :
  (exists coloring, good_coloring (behead vecs) coloring) <->
  (exists coloring, good_coloring vertices coloring).
Proof.
split => -[coloring] []; rewrite -/K3 => ok1 [ok2 ok3].
- exists coloring.
  do !split; rewrite /= -/K3.
  + by move=> v /vertices_sub /ok1.
  + move=> v w /vertices_sub Hv /vertices_sub; exact: ok2.
  + move=> v w u /vertices_sub Hv /vertices_sub Hw /vertices_sub; exact: ok3.
- exists (coloring \o reduce).
  do !split.
  + by move=> v /reduce_sub /ok1.
  + move=> v w /reduce_sub Hv /reduce_sub Hw /reduce_ortho; exact: ok2.
  + move=> v w u /reduce_sub Hv /reduce_sub Hw /reduce_sub Hu.
    move/reduce_ortho => Hvw /reduce_ortho Hvu /reduce_ortho; exact: ok3.
Qed.

(* Algorithm searching for a good coloring *)

Definition check_triangles (v : nat) (coloring : seq color) :=
  let getc := nth None coloring in
  let c := getc v in
  let orth := [seq w <- indices | edge v w] in
  (c != None) &&
  if c == white then white \notin map getc orth else
  ~~ has (fun w => (getc w == c) &&
            has (fun t => edge w t && (getc t == c)) orth)
         orth.

Definition filterM {A} (f : A -> bool) (x : A) : seq A :=
  if f x then [:: x] else [::].

Definition set (coloring : seq color) := set_nth None coloring.

Definition uncolored : seq color := [::].

Fixpoint color_vertices rem coloring :=
  match rem with
  | nil => [:: coloring]
  | v :: rem =>
    [:: set coloring v black; set coloring v white]
    >>= filterM (check_triangles v)
    >>= color_vertices rem
  end.

(* Computation checking the absence of good colorings *)
Lemma no_coloring : color_vertices indices uncolored = [::].
Proof. by vm_compute. Qed.

(* Proof that the algorithm is correct *)

Lemma take_diff_index {A : eqType} v (v0 : A) (s : seq A) :
  v0 \in take v.+1 s -> v0 \notin take v s -> index v0 s = v.
Proof.
move=> Hv0 Hv0'.
move: (index_cat v0 (take v s) (drop v s)).
rewrite (negbTE Hv0') cat_take_drop => ->.
move: Hv0.
rewrite -addn1 takeD mem_cat (negbTE Hv0') size_take /=.
case: ifPn => Hsz.
  case: (drop _ _) => //= a l.
  rewrite take0 inE => /eqP ->.
  by rewrite eqxx addn0.
by rewrite drop_oversize // leqNgt.
Qed.

Lemma getv_index v : v \in vertices -> getv (index v vertices) = v.
Proof. move=> Hv; by rewrite /getv nth_index. Qed.

Lemma index_vertices v : v \in vertices -> index v vertices \in indices.
Proof. move=> Hv; by rewrite mem_iota leq0n add0n index_mem. Qed.

Lemma index_orthogonal v w :
  v \in vertices -> w \in vertices ->
  index w vertices \in filter (edge (index v vertices)) indices =
  orthogonal v w.
Proof.
move=> Hv Hw; rewrite mem_filter edgeE ?index_mem // !getv_index //.
by rewrite index_vertices // andbT.
Qed.

Lemma color_other {c : color} {b} : c != None -> c != Some b -> c = Some (~~ b).
Proof. by case: c b => -[] []. Qed.

Lemma getv_take v n :
  n < size vertices -> v < n.+1 -> getv v \in take n.+1 vertices.
Proof.
move=> Hn Hv.
by rewrite /getv -(nth_take defK3 (n0:=n.+1) (i:=v)) // mem_nth // size_takel.
Qed.

Lemma check_triangles_ok n (coloring : seq color) :
  let colorf k := nth None coloring (index k vertices) in
  good_coloring (take n vertices) colorf ->
  (forall i, i > n -> nth None coloring i = None) ->
  n < size vertices ->
  reflect (good_coloring (take n.+1 vertices) colorf)
          (check_triangles n coloring).
Proof.
move=> colorf [ok1 [ok2 ok3]] Hnone Hnsz.
case/boolP: (check_triangles n _) => Hch; constructor.
  case/andP: Hch => Hch1 Hch.
  do !split.
  - move=> v Hv.
    case/boolP: (v \in take n vertices) => Hv'.
      exact: ok1.
    by rewrite /colorf (take_diff_index n).
  - move=> v w Hv Hw.
    case/boolP: ((v \in take n vertices) && (w \in take n vertices)).
      case/andP=> Hv' Hw'.
      exact: ok2.
    rewrite negb_and.
    move: Hv Hw.
    wlog: v w / (v \notin take n vertices).
      move=> Hwl Hv Hw /orP [] Hnv Ho.
        apply Hwl => //.
        by rewrite Hnv.
      have: black \in [seq colorf i | i <- [:: w; v]].
        apply Hwl => //.
          by rewrite Hnv.
        by rewrite orthogonalC.
      by rewrite !inE orbC.
    move=> Hvn Hv Hw _ Ho.
    rewrite !inE.
    have Hi := take_diff_index _ _ _ Hv Hvn.
    move: (Hv) (Hw) Hch => /mem_take Hv' /mem_take Hw'.
    case: ifPn => Hwh.
      case/boolP: (black == colorf w) => Hcw.
        by rewrite orbT.
      move/mapP; elim.
      exists (index w vertices).
        rewrite mem_filter -Hi edgeE ?index_mem // !getv_index //.
        by rewrite Ho index_vertices.
      case/boolP: (w \in take n vertices) => Hwn.
        rewrite eq_sym in Hcw.
        by rewrite -/(colorf w) (color_other (ok1 w Hwn) Hcw).
      by rewrite (take_diff_index n) // (eqP Hwh).
    move=> _.
    by rewrite /colorf Hi (color_other Hch1 Hwh).
  - move=> v w u Hv Hw Hu.
    case/boolP: ((v \in take n vertices) && (w \in take n vertices)
                 && (u \in take n vertices)).
      case/andP => /andP[] Hv' Hw' Hu'.
      exact: ok3.
    rewrite !negb_and.
    move: Hv Hw Hu.
    wlog: v w u / (v \notin take n vertices).
      move=> Hwl Hv Hw Hu /orP [/orP []|] Hnv Hvw Hvu Hwu.
          apply Hwl => //.
          by rewrite Hnv.
        have: white \in [seq colorf i | i <- [:: w; v; u]].
          apply Hwl => //.
            by rewrite Hnv.
          by rewrite orthogonalC.
        by rewrite !inE !orbA (orbC (_ == colorf w)).
      have: white \in [seq colorf i | i <- [:: u; v; w]].
        apply Hwl => //; by rewrite (Hnv,orthogonalC).
      by rewrite !inE orbC !orbA.
    move=> Hvn Hv Hw Hu _ Hvw Hvu Hwu.
    rewrite !inE !(eq_sym white).
    have Hn := take_diff_index _ _ _ Hv Hvn.
    move: Hch.
    case: ifPn => Hwh.
      by rewrite /colorf Hn Hwh.
    rewrite /(colorf v) Hn (color_other Hch1 Hwh) [_ || _]/=.
    case/boolP: (colorf w == white) => Hcw //.
    case/boolP: (colorf u == white) => Hcu //.
    move/negP; elim.
    apply/hasP.
    move/mem_take in Hv.
    move/mem_take: (Hw) => Hw'.
    move/mem_take: (Hu) => Hu'.
    exists (index w vertices).
      by rewrite -Hn index_orthogonal.
    apply/andP; split.
      case/boolP: (w \in take n vertices) => Hwn.
        by rewrite -/(colorf w) (color_other (ok1 w Hwn) Hcw).
      by rewrite (take_diff_index n) // (color_other Hch1 Hwh).
    apply/hasP.
    exists (index u vertices).
      by rewrite -Hn index_orthogonal.
    rewrite edgeE ?index_mem // !getv_index // Hwu.
    case/boolP: (u \in take n vertices) => Hun.
      by rewrite -/(colorf u) (color_other (ok1 u Hun) Hcu).
    by rewrite (take_diff_index n) // (color_other Hch1 Hwh).
move=> Hgc.
move/negP: Hch; elim.
case: Hgc => {}ok1 [{}ok2 {}ok3].
rewrite /check_triangles.
case: ifPn => Hwh.
  rewrite (eqP Hwh) [~~ _]/=.
  apply/mapP => -[m] Hm Hcm.
  have Hmn1: m < n.+1.
    rewrite ltnNge; apply/negP => Hmn.
    by move: (Hnone _ Hmn); rewrite -Hcm.
  move: Hm; rewrite mem_filter => /andP[].
  have Hmsz : m < size indices.
    exact: (leq_trans Hmn1).
  rewrite edgeE // => /ok2.
  rewrite size_iota in Hmsz.
  rewrite !getv_take // 2!inE /colorf !index_uniq // => /(_ isT isT).
  by rewrite (eqP Hwh) -Hcm.
case/boolP: (nth None coloring n == black) => /eqP Hbk.
  rewrite Hbk andTb.
  apply/hasP => -[w] Hw' /andP[] /eqP Hcw /hasP [u] Hu' /andP[] Hwu /eqP Hcu.
  move: Hw' Hu'.
  rewrite !mem_filter => /andP[].
  have Hwn: w < n.+1.
    rewrite ltnNge; apply/negP => Hmn.
    by move: (Hnone _ Hmn); rewrite Hcw.
  have Hun: u < n.+1.
    rewrite ltnNge; apply/negP => Hmn.
    by move: (Hnone _ Hmn); rewrite Hcu.
  have Hwsz : w < size indices by exact: (leq_trans Hwn).
  have Husz : u < size indices by exact: (leq_trans Hun).
  rewrite !edgeE // => Hvw _ /andP[] Hvu _.
  rewrite edgeE // in Hwu.
  rewrite size_iota in Hwsz Husz.
  move/(ok3 _ _ (getv u)): Hvw.
  rewrite Hvu Hwu !getv_take // 3!inE; do !move/(_ isT).
  by rewrite /colorf !index_uniq // Hbk Hcw Hcu.
move: (ok1 (getv n)).
rewrite getv_take // => /(_ isT).
rewrite /colorf index_uniq // => Hn.
elim Hbk; by rewrite (color_other Hn Hwh).
Qed.

Definition le_coloring (col1 col2 : K3 -> color) :=
  forall v, col1 v = None \/ col1 v = col2 v.

Lemma flat_map_amb {A B : eqType} f (a1 a2 : A) (b : B) :
  b \in ([:: a1; a2] >>= f) = (b \in f a1) || (b \in f a2).
Proof.
apply/flattenP; case: ifP.
  case/orP => Hb ; [exists (f a1) | exists (f a2)];
    by rewrite // map_f // !inE eqxx // orbT.
move=> Hb [s].
rewrite !inE => /orP [] /eqP -> Hb'; by rewrite Hb' // orbT in Hb.
Qed.

Lemma flat_map_comp {A B C : eqType} (f1 : A -> seq B) (f2 : B -> seq C) s :
  (s >>= f1) >>= f2 = s >>= (flat_map f2 \o f1).
Proof.
rewrite /flat_map /comp.
elim: s => //= a s IH.
by rewrite map_cat flatten_cat IH.
Qed.

Lemma color_vertices_mono n (coloring coloring' : seq color) :
  n <= size vertices ->
  coloring' \in color_vertices (iota n (size vertices - n)) coloring ->
  forall i, i < n -> nth None coloring i = nth None coloring' i.
Proof.
move=> Hsz.
rewrite -{1 3}(subKn Hsz).
have : size vertices - n <= size vertices by rewrite leq_subr.
elim: (size vertices - n) {Hsz} coloring => [|{}n IH] coloring Hn /=.
  by rewrite inE => /eqP ->.
rewrite {2}/flat_map /= /filterM.
rewrite subnS (@ltn_predK 0); last by rewrite subn_gt0.
set set_coloring := set _ _.
have {}IH : forall b,
    coloring' \in color_vertices (iota (49 - n) n) (set_coloring b) ->
    forall i, i < (49 - n).-1 -> nth None coloring i = nth None coloring' i.
  move=> b Hcol i Hi.
  transitivity (nth None (set_coloring b) i).
    by rewrite nth_set_nth /= ltn_eqF.
  apply IH. exact: ltnW. exact: Hcol.
  apply: (leq_trans Hi).
  exact: leq_pred.
case: (check_triangles _ _); case: (check_triangles _ _); rewrite !cats0 /=.
      rewrite flat_map_amb => /orP[]; exact: IH.
    rewrite /flat_map /= cats0; exact: IH.
  rewrite /flat_map /= cats0; exact: IH.
done.
Qed.

Lemma good_coloring_eq vertices (coloring coloring' : K3 -> color) :
  {in vertices, coloring =1 coloring'} ->
  good_coloring vertices coloring -> good_coloring vertices coloring'.
Proof.
move=> Hcol [ok1] [ok2 ok3].
do! split.
- by move=> v Hv; rewrite -Hcol // ok1.
- move=> v w Hv Hw /(ok2 _ _ Hv Hw). by rewrite !inE !Hcol.
- move=> v w u Hv Hw Hu Hvw Hvu /(ok3 _ _ _ Hv Hw Hu).
  rewrite !inE !Hcol; exact.
Qed.

Lemma good_coloring_le n gc gc' :
  good_coloring vertices gc -> le_coloring gc' gc ->
  {in take n vertices, forall v, gc' v != None} ->
  good_coloring (take n vertices) gc'.
Proof.
case => ok1 [ok2 ok3] Hle Hnone.
do! split.
- by move=> v /Hnone.
- move=> v w Hv Hw.
  move/(ok2 _ _ (mem_take Hv) (mem_take Hw)).
  rewrite !inE.
  move/Hnone: Hv.
  move/Hnone: Hw.
  by case: (Hle v) (Hle w) => -> // [] ->.
- move=> v w u Hv Hw Hu Hvw Hvu.
  move/(ok3 _ _ _ (mem_take Hv) (mem_take Hw) (mem_take Hu) Hvw Hvu).
  rewrite !inE.
  move/Hnone: Hv.
  move/Hnone: Hw.
  move/Hnone: Hu.
  by case: (Hle v) (Hle w) (Hle u) => -> // [] -> // [] ->.
Qed.

Lemma color_vertices_ok n coloring gc :
  n <= size vertices ->
  let colorf k := nth None coloring (index k vertices) in
  good_coloring (take n vertices) colorf ->
  le_coloring colorf gc ->
  {in vertices, forall v, gc v != None} ->
  size coloring = n ->
  reflect (good_coloring vertices gc)
          (map gc vertices \in
              color_vertices (iota n (size vertices - n)) coloring).
Proof.
move Hvertices: vertices => vertices.
move Hm: (size vertices - n) => m Hszn.
have -> : n = size vertices - m by rewrite -Hm subKn.
have : m <= size vertices by rewrite -Hm leq_subr.
elim: m {n Hm Hszn} coloring => [|m IH] coloring Hszm colorf.
  rewrite subn0 take_size [color_vertices _ _]/=.
  case=> ok1 [ok2 ok3] Hle Hnone Hsz.
  have Hcol: {in vertices, colorf =1 gc}.
    move=> v Hv.
    move: (ok1 v).
    case: (Hle v) => // ->.
    by rewrite Hv eqxx => /(_ isT).
  have -> : map gc vertices = coloring.
    apply: (eq_from_nth (x0:=None)).
      by rewrite size_map.
    move=> i.
    rewrite size_map => Hi.
    rewrite -(proj1 (eq_in_map _ _ _) Hcol) /colorf.
    by rewrite (nth_map defK3) // /colorf /getv index_uniq // -Hvertices.
  rewrite inE eqxx.
  constructor.
  do! split.
  + move=> v Hc.
    rewrite -Hcol //.
    exact: ok1.
  + move=> v w Hv Hw.
    move: (ok2 v w Hv Hw).
    by rewrite !inE !Hcol.
  + move=> v w u Hv Hw Hu.
    move: (ok3 v w u Hv Hw Hu).
    by rewrite !inE !Hcol.
move=> Hgc Hle Hnone Hsz /=.
rewrite [in _.+1]subnS (@ltn_predK 0) ?subn_gt0 //.
rewrite {2}/flat_map /= cats0.
set n := size vertices - m.+1 in Hgc Hsz *.
set coloring' := set coloring n (gc (getv n)).
set colorf' := fun k => nth None coloring' (index k vertices).
have Hset : {in take n vertices,  colorf =1 colorf'}.
  move=> v Hv.
  rewrite /colorf /colorf' nth_set_nth /=.
  case: ifP => // /eqP.
  rewrite -{1}(cat_take_drop n vertices).
  rewrite index_cat Hv => Hv'.
  move: Hv.
  by rewrite -index_mem Hv' size_takel (ltnn,leq_subr).
rewrite /filterM flat_map_cat mem_cat.
have Htr : reflect (good_coloring (take n.+1 vertices) colorf')
                   (check_triangles n coloring').
  rewrite /colorf' -Hvertices.
  apply check_triangles_ok; rewrite ?Hvertices.
      by apply (good_coloring_eq Hset).
    move=> i Hi.
    rewrite nth_set_nth /= eq_sym ltn_eqF //.
    by rewrite nth_default // Hsz ltnW.
  by rewrite /n subnS prednK ?subn_gt0 // leq_subr.
have Hszn: n < size vertices.
  by rewrite /n ltn_subrL /= (leq_ltn_trans (leq0n m)).
have Hgcn : gc (getv n) \in [:: black; white].
  move: (Hnone (getv n)).
  rewrite !inE /getv Hvertices mem_nth // => /(_ isT).
  by case: (gc _) => // -[].
(* generalize colors *)
have: true = ~~false /\ gc (getv n) \in [:: black; white] by [].
rewrite /black /white.
generalize false true => blk wht.
wlog: blk wht / gc (getv n) = Some blk.
  case/boolP: (gc (getv n) == Some blk).
    move/eqP ->; exact.
  rewrite 2!inE => /negbTE -> /= H [].
  rewrite eq_sym orbC => Hbw /eqP Hgcn'.
  apply: H => //.
  rewrite !inE Hbw negbK -Hbw Hgcn' eqxx; by split.
move=> {}Hgcn [-> _] {wht}.
have Hszm': 0 < size vertices - m by rewrite ltn_subRL addn0.
rewrite orbC.
case/boolP: (_ \in _).
  case: ifP => Hch; last by rewrite in_nil.
  rewrite /flat_map /= cats0.
  rewrite -{2}(subKn (ltnW Hszm)) -{3}Hvertices => /color_vertices_mono.
  rewrite Hvertices leq_subr => /(_ isT n).
  rewrite /n subnS ltn_predL Hszm' nth_set_nth /= eqxx => /(_ isT).
  rewrite (nth_map defK3).
    rewrite -{1}Hvertices -subnS Hgcn; by destruct blk.
  by rewrite prednK ?leq_subr.
move=> _ /=.
have Hle': le_coloring colorf' gc.
  move=> v; rewrite /colorf' nth_set_nth /=.
  case: ifP => /eqP Hv; last by exact: Hle.
  move: Hgcn.
  rewrite -Hv -Hvertices getv_index.
    move ->; by right.
  by rewrite -index_mem Hvertices Hv.
case: ifP => Hch;
  rewrite /colorf' /coloring' Hgcn /n Hch [in _.+1]subnS prednK // in Htr.
  rewrite /flat_map /= cats0.
  apply IH => //.
        exact: ltnW.
      exact/Htr.
    by rewrite -Hgcn.
  rewrite size_set_nth /n subnS prednK //.
  apply/maxn_idPl.
  by rewrite Hsz /n subnS leq_pred.
rewrite in_nil.
constructor.
rewrite -Hvertices.
have Hnone': {in take (size vertices - m) vertices,
                 forall v, colorf' v != None}.
  move=> v Hv.
  rewrite /colorf' nth_set_nth /=.
  case: ifP => /eqP Hi.
    by rewrite Hgcn.
  apply: (proj1 Hgc).
  case/boolP: (_ \in _) => Hv' //.
  rewrite -(@prednK (_ - m)) // -subnS in Hv.
  by move: (take_diff_index _ _ _ Hv Hv') Hi => ->.
rewrite -{2}Hvertices in Hnone'.
move/(@good_coloring_le (size vertices - m) gc colorf') => /(_ Hle' Hnone').
by rewrite Hvertices /colorf' /coloring' Hgcn => /Htr.
Qed.

(* Answer to question 1 *)
Theorem no_vecs_coloring :
  ~ ex (good_coloring (behead vecs)).
Proof.
move/reduction_ok => [] gc Hgc.
apply/(@color_vertices_ok (locked 0) uncolored): (Hgc) => //.
- by rewrite -lock.
- rewrite -lock [take _ _]/=.
  do! split; move=> v; by rewrite in_nil.
- move=> v.
  rewrite nth_default //; by left.
- apply: (proj1 Hgc); by rewrite -lock.
- by rewrite -lock.
- by rewrite -lock subn0 no_coloring in_nil.
Qed.


(* ******************************************************************************* *)
(** * Internal adjunctions and adjoint equivalences
 ********************************************************************************* *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.

Local Open Scope bicategory_scope.
Local Open Scope cat.

Section Internal_Adjunction.
  Context {B : bicat}.

  (** ** Definitions of internal adjunctions *)

  (** *** Data & laws for left adjoints *)
  Definition left_adjoint_data
             {a b : B}
             (f : a --> b)
    : UU
    := ∑ (g : b --> a),
       identity a ==> f · g
       ×
       g · f ==> identity b.

  Definition left_adjoint_right_adjoint
             {a b : B}
             {f : a --> b}
             (αd : left_adjoint_data f)
    : b --> a
    := pr1 αd.

  Definition left_adjoint_unit
             {a b : B}
             {f : a --> b}
             (αd : left_adjoint_data f)
    : identity a ==> f · left_adjoint_right_adjoint αd
    := pr12 αd.

  Definition left_adjoint_counit
             {a b : B}
             {f : a --> b}
             (αd : left_adjoint_data f)
    : left_adjoint_right_adjoint αd · f ==> identity b
    := pr22 αd.

  Definition left_adjoint_axioms
             {a b : B}
             {f : a --> b}
             (αd : left_adjoint_data f)
    : UU
    := let g := left_adjoint_right_adjoint αd in
       let η := left_adjoint_unit αd in
       let ε := left_adjoint_counit αd in
       linvunitor f • (η ▹ f) • rassociator _ _ _ • (f ◃ ε) • runitor f = id2 f
       ×
       rinvunitor g • (g ◃ η) • lassociator _ _ _ • (ε ▹ g) • lunitor g = id2 g.

  Definition left_adjoint
             {a b : B}
             (f : a --> b)
    : UU
    := ∑ (αd : left_adjoint_data f), left_adjoint_axioms αd.

  Coercion data_of_left_adjoint
           {a b : B}
           {f : a --> b}
           (α : left_adjoint f)
    : left_adjoint_data f
    := pr1 α.

  Coercion axioms_of_left_adjoint
           {a b : B}
           {f : a --> b}
           (α : left_adjoint f)
    : left_adjoint_axioms α
    := pr2 α.

  (** Data and laws for right adjoints *)
  Definition internal_right_adj_data
             {a b : B}
             (g : b --> a)
    : UU
    := ∑ (f : a --> b),
       identity a ==> f · g
       ×
       g · f ==> identity b.

  Definition internal_right_adj_left_adjoint
             {a b : B}
             {g : b --> a}
             (αd : internal_right_adj_data g)
    : a --> b
    := pr1 αd.

  Definition internal_right_adj_unit
             {a b : B}
             {g : b --> a}
             (αd : internal_right_adj_data g)
    : identity a ==> internal_right_adj_left_adjoint αd · g
    := pr12 αd.

  Definition internal_right_adj_counit
             {a b : B}
             {g : b --> a}
             (αd : internal_right_adj_data g)
    : g · internal_right_adj_left_adjoint αd ==> identity b
    := pr22 αd.

  Definition internal_right_adj_axioms
             {a b : B}
             {g : b --> a}
             (αd : internal_right_adj_data g)
    : UU
    := let f := internal_right_adj_left_adjoint αd in
       let η := internal_right_adj_unit αd in
       let ε := internal_right_adj_counit αd in
       linvunitor f • (η ▹ f) • rassociator _ _ _ • (f ◃ ε) • runitor f = id2 f
       ×
       rinvunitor g • (g ◃ η) • lassociator _ _ _ • (ε ▹ g) • lunitor g = id2 g.

  Definition internal_right_adj
             {a b : B}
             (g : b --> a)
    : UU
    := ∑ (αd : internal_right_adj_data g), internal_right_adj_axioms αd.

  Coercion data_of_internal_right_adj
           {a b : B}
           {g : b --> a}
           (α : internal_right_adj g)
    : internal_right_adj_data g
    := pr1 α.

  Coercion axioms_of_internal_right_adj
           {a b : B}
           {g : b --> a}
           (α : internal_right_adj g)
    : internal_right_adj_axioms α
    := pr2 α.

  (** *** Laws for equivalences *)
  Definition left_equivalence_axioms
             {a b : B}
             {f : a --> b}
             (αd : left_adjoint_data f)
    : UU
    := is_invertible_2cell (left_adjoint_unit αd)
       ×
       is_invertible_2cell (left_adjoint_counit αd).

  Definition left_equivalence
             {a b : B}
             (f : a --> b)
    :UU
    := ∑ (αd : left_adjoint_data f),
       left_equivalence_axioms αd.

  Coercion data_of_left_equivalence
           {a b : B}
           {f : a --> b}
           (αe : left_equivalence f)
    : left_adjoint_data f
    := pr1 αe.

  Coercion axioms_of_left_equivalence
           {a b : B}
           {f : a --> b}
           (αe : left_equivalence f)
    : left_equivalence_axioms αe
    := pr2 αe.

  Definition left_adjoint_equivalence
             {a b : B}
             (f : a --> b)
    : UU
    := ∑ (αd : left_adjoint_data f),
       left_adjoint_axioms αd
       ×
       left_equivalence_axioms αd.

  (* the coercion to the axioms will be induced *)
  Coercion left_adjoint_of_left_adjoint_equivalence
           {a b : B}
           {f : a --> b}
           (αe : left_adjoint_equivalence f)
    : left_adjoint f
    := (pr1 αe,, pr12 αe).

  Coercion left_equivalence_of_left_adjoint_equivalence
           {a b : B}
           {f : a --> b}
           (αe : left_adjoint_equivalence f)
    : left_equivalence f
    := (pr1 αe,, pr22 αe).

  Definition left_equivalence_unit_iso
             {a b : B}
             {f : a --> b}
             (αe : left_equivalence f)
    : invertible_2cell (identity a) (f · left_adjoint_right_adjoint αe).
  Proof.
    refine (left_adjoint_unit αe,, _).
    apply αe.
  Defined.

  Definition left_equivalence_counit_iso
             {a b : B}
             {f : a --> b}
             (αe : left_equivalence f)
    : invertible_2cell (left_adjoint_right_adjoint αe · f) (identity b).
  Proof.
    refine (left_adjoint_counit αe,, _).
    apply αe.
  Defined.

  (** *** Packaged *)
  Definition adjunction (a b : B) : UU
    := ∑ (f : a --> b), left_adjoint f.

  Coercion arrow_of_adjunction
           {a b : B}
           (f : adjunction a b)
    : a --> b
    := pr1 f.

  Coercion left_adjoint_of_adjunction
           {a b : B}
           (f : adjunction a b)
    : left_adjoint f
    := pr2 f.

  Definition adjoint_equivalence
             (a b : B)
    : UU
    := ∑ (f : a --> b), left_adjoint_equivalence f.

  Coercion adjunction_of_adjoint_equivalence
           {a b : B}
           (f : adjoint_equivalence a b)
    : adjunction a b
    := (pr1 f,,left_adjoint_of_left_adjoint_equivalence (pr2 f)).

  Coercion left_adjoint_equivalence_of_adjoint_equivalence
           {a b : B}
           (f : adjoint_equivalence a b)
    : left_adjoint_equivalence f
    := pr2 f.

  Definition internal_right_adjoint
             {a b : B}
             (f : adjunction a b)
    : b --> a
    := left_adjoint_right_adjoint f.

  Definition internal_triangle1
             {a b : B}
             {f : a --> b}
             {adj : left_adjoint_data f}
             (L : left_adjoint_axioms adj)
    : linvunitor f
      • (left_adjoint_unit adj ▹ f)
      • rassociator _ _ _
      • (f ◃ left_adjoint_counit adj)
      • runitor f
      =
      id2 f
    := pr1 L.

  Definition internal_triangle2
             {a b : B}
             {f : a --> b}
             {adj : left_adjoint_data f}
             (L : left_adjoint_axioms adj)
             (g := left_adjoint_right_adjoint adj)
    : rinvunitor g
      • (g ◃ left_adjoint_unit adj)
      • lassociator _ _ _
      • (left_adjoint_counit adj ▹ g)
      • lunitor g
      =
      id2 g
    := pr2 L.

  Definition make_adjoint_equivalence
             {a b : B}
             (f : a --> b)
             (g : b --> a)
             (η : identity _ ==> g ∘ f)
             (ε : f ∘ g ==> identity _)
             (triangle1 : linvunitor f
                          • (η ▹ f)
                          • rassociator _ _ _
                          • (f ◃ ε)
                          • runitor f
                          =
                          id2 f)
             (triangle2 : rinvunitor g
                          • (g ◃ η)
                          • lassociator _ _ _
                          • (ε ▹ g)
                          • lunitor g
                          =
                          id2 g)
             (η_iso : is_invertible_2cell η)
             (ε_iso : is_invertible_2cell ε)
    : adjoint_equivalence a b
    := f ,, ((g ,, (η ,, ε)) ,, ((triangle1 ,, triangle2) ,, (η_iso ,, ε_iso))).
End Internal_Adjunction.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.Classical_Prop.

Class Monoid {M : Type}
        (mzero : M)
        (mplus : M -> M -> M)
            : Prop
    := Build_Monoid {
        mplus_assoc : forall (x y z : M), mplus (mplus x y) z = mplus x (mplus y z);
        mzero_left : forall (x : M), mplus x mzero = x;
        mzero_right : forall (x : M), mplus mzero x = x
    }.

Inductive Mon : Type :=
    cons_mon (M : Type) (mzero : M) (mplus : M -> M -> M) (mon : Monoid mzero mplus) : Mon.

Definition mplus_fn (A : Type) (f g : A -> A) : A -> A
    := compose f g.

Instance FunMonoid (A : Type) : Monoid (fun (x : A) => x) (mplus_fn A).
    split; reflexivity.
Qed.

Definition undertype_mon (M : Mon) : Type
   := match M with cons_mon m _ _ _ => m end.

Definition mzero_of (M : Mon) : undertype_mon M
    := match M with cons_mon _ z _ _ => z end.

Definition mplus_of (M : Mon) : undertype_mon M -> undertype_mon M -> undertype_mon M
    := match M with cons_mon _ _ p _ => p end.

Definition monoid_of (M : Mon) : Monoid (mzero_of M) (mplus_of M)
    := match M with cons_mon _ _ _ m => m end.

Definition Mon_Hom (M : Mon) (N : Mon)
            : Type :=
    {f : undertype_mon M -> undertype_mon N
        | f (mzero_of M) = mzero_of N
          /\ forall (x y : undertype_mon M), f (mplus_of M x y) = mplus_of N (f x) (f y) }.

Definition mon_hom_fn {M N : Mon} (h : Mon_Hom M N) : undertype_mon M -> undertype_mon N
    := match h with exist f _ => f end.

Theorem mon_hom_eq {M N : Mon} (f g : Mon_Hom M N) :
        mon_hom_fn f = mon_hom_fn g -> f = g.
Proof.
    destruct f as [f [fZ fP]].
    destruct g as [g [gZ gP]].
    simpl.
    intros fg.
    subst f.
    assert (zz : fZ = gZ) by (apply proof_irrelevance).
    rewrite zz.
    assert (pp : fP = gP) by (apply proof_irrelevance).
    rewrite pp.
    reflexivity.
Qed.


From Cat Require Import Imports Category Preorder Monoid Poset Isomorphism
Terminal Dual Initial Product CoProduct Exponential CCC IPL STLC Functor NaturalTransformation Adjunction.
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.
Require Import JMeq.
Set Universe Polymorphism.

Arguments fmap {_} {_} _ {_} {_} _.
Arguments fobj {_} {_} _ _.
Arguments Compose_Functors {_} {_} {_} _ _.
Arguments NaturalTransformation {_} {_} _ _.
Arguments trans {_} {_} {_} {_} _ _.
Arguments Compose_NaturalTransformations {_ _ _ _ _ } _ _.
Arguments Compose_NaturalTransformations_H {_ _ _ _ _ } _ _.

Class PKT (C: Category) (hp: hasProducts C): Type :=
{
  ktobj : @obj C -> @obj C;
  ktmap : forall X: @obj C, arrow (ktobj X) X;
  ktstar: forall {X Y Z: @obj C} (f: arrow (ktobj Z) (@pobj C hp X Y)), arrow (ktobj Z) (@pobj C hp X (ktobj Y));
  ktob1 : forall {X X' Y Z: @obj C} (f: arrow X' X) (g: arrow (ktobj Z) (@pobj C hp X' Y)),
          (ktstar (g o (fprod f (identity Y)))) = (ktstar g) o (fprod f (identity (ktobj Y)));
  ktob2 : forall {X Y Z: @obj C} (f: arrow (ktobj Z) (@pobj C hp X Y)),
          ktstar f o (fprod (identity X) (ktmap Y)) = f;
  ktob3 : forall {X Y Z W: @obj C} (f: arrow (ktobj Z) (@pobj C hp X Y)) (g: arrow (ktobj W) (@pobj C hp X Z)),
          ktstar (ktstar g o (@prod_f C X (ktobj Z) (@pobj C hp X (ktobj Z)) (@hasp C hp X (ktobj Z)) (pobj X Y)
                                      (@pi1 C X Y (@pobj C hp X Y) (@hasp C hp X Y))
                                      f)) =
          ktstar g o (@prod_f C X (ktobj Z) (@pobj C hp X (ktobj Z)) (@hasp C hp X (ktobj Z)) (pobj X (ktobj Y))
                              (@pi1 C X (ktobj Y) (@pobj C hp X (ktobj Y)) (@hasp C hp X (ktobj Y)))
                              (ktstar f))
}.

Definition fobjFs (s a : Set) := s -> (a * s).

Definition fmapFs (s A B: Set) (f: A -> B) (x : fobjFs s A) :=
  fun st =>
    match x st with
      | (a, st') => (f a, st')
    end.

Definition Fs: forall (s: @obj TypeCat), Functor TypeCat TypeCat.
Proof. intro s.
       unshelve econstructor.
       - intros a. exact (fobjFs s a).
       - intros a b f. exact (fmapFs s a b f).
       - repeat intro. now subst.
       - intros. cbn in *.
         extensionality X. compute.
         extensionality st. now destruct X.
       - intros. cbn in *.
         extensionality X. compute.
         extensionality st. now destruct X.
Defined.

Definition State (S: Set): PKT SetCat hasProductsSetCat.
Proof. specialize (hasProductsSetCat); intro hp.
       unshelve econstructor.
       - intro X.
         exact (S -> (X * S)).
       - simpl.
         intros X x s.
         exact (x, s).
       - simpl. intros X Y Z f (x, t) s.
         destruct (t s) as (y, s').
         exact (f (x, y) s').
       - simpl. intros X X' Y Z f g.
         apply functional_extensionality.
         intros (x, h).
         unfold fprod.
         simpl.
         reflexivity.
       - simpl. intros X Y Z f.
         apply functional_extensionality.
         intros (x, y).
         reflexivity.
       - simpl. intros X Y Z W f g.
         apply functional_extensionality.
         intros (x, h).
         simpl.
         apply functional_extensionality.
         intro s.
         destruct (h s) as (y, s').
         reflexivity.
Defined.

Definition Error: PKT SetCat hasProductsSetCat.
Proof. specialize (hasProductsSetCat); intro hp.
       unshelve econstructor.
       - intro X.
         exact (X + Datatypes.unit)%type.
       - simpl.
         intros X x.
         left. exact x.
       - simpl. intros X Y Z f (x, g).
         destruct g as [y | tt].
         + exact (f (x, y)).
         + right. exact tt.
       - simpl. intros X X' Y Z f g.
         apply functional_extensionality.
         intros (x, h).
         destruct h as [y | tt].
         + unfold fprod.
           simpl.
           reflexivity.
         + reflexivity.
       - simpl. intros X Y Z f.
         apply functional_extensionality.
         intros (x, g).
         reflexivity.
       - simpl. intros X Y Z W f g.
         apply functional_extensionality.
         intros (x, h).
         destruct h as [y | tt].
         + reflexivity.
         + reflexivity.
Defined.

Definition Continuation (R: Set): PKT SetCat hasProductsSetCat.
Proof. specialize (hasProductsSetCat); intro hp.
       unshelve econstructor.
       - intro X.
         exact ((X -> R) -> R).
       - simpl.
         intros X x f.
         exact (f x).
       - simpl. intros X Y Z f (x, r) g.
         apply r.
         intro y.
         exact (f (x, y) g).
       - simpl.
         intros X X' Y Z f g.
         apply functional_extensionality.
         intros (x, h).
         unfold fprod.
         simpl.
         reflexivity.
       - simpl. intros X Y Z f.
         apply functional_extensionality.
         intros (x, g).
         reflexivity.
       - simpl. intros X Y Z W f g.
         apply functional_extensionality.
         intros (x, h).
         reflexivity.
Defined.


Require Export Functor.Product FunctorCategory.
Require Import Common NaturalTransformation.Equality.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope natural_transformation_scope.

Section FunctorProduct_Functor.
  Context `{Funext}.

  Variable C : PreCategory.
  Variable D : PreCategory.
  Variable D' : PreCategory.

  Definition FunctorProduct_MorphismOf
             s d
             (m : Morphism ([C, D] * [C, D']) s d)
  : Morphism [_, _] (fst s * snd s)%functor (fst d * snd d)%functor
    := FunctorProductFunctorial (fst m) (snd m).

  Definition FunctorProduct_FCompositionOf
             s d d'
             (m1 : Morphism ([C, D] * [C, D']) s d)
             (m2 : Morphism ([C, D] * [C, D']) d d')
  : FunctorProduct_MorphismOf (m2 ∘ m1)
    = FunctorProduct_MorphismOf m2 ∘ FunctorProduct_MorphismOf m1.
  Proof.
    abstract (nt_eq; reflexivity).
  Qed.

  Definition FunctorProduct_FIdentityOf
             (x : Object ([C, D] * [C, D']))
  : FunctorProduct_MorphismOf (Identity x) = Identity _.
  Proof.
    abstract (nt_eq; reflexivity).
  Qed.

  Definition FunctorProduct_Functor
  : Object [[C, D] * [C, D'], [C, D * D']]
    := Build_Functor
          ([C, D] * [C, D']) [C, D * D']
          _
          FunctorProduct_MorphismOf
          FunctorProduct_FCompositionOf
          FunctorProduct_FIdentityOf.
End FunctorProduct_Functor.


(*
    Copyright (C) 2012  G. Gonthier, B. Ziliani, A. Nanevski, D. Dreyer

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 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 General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*)

Require Import ssreflect ssrfun ssrbool ssrnat seq path rels.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(****************************************************)
(* A theory of permutations over non-equality types *)
(****************************************************)

Section Permutations.
Variable A : Type.

Lemma in_split (x : A) (s : seq A) :
        x \In s -> exists s1, exists s2, s = s1 ++ x :: s2.
Proof.
elim:s=>[|y s IH] //=; rewrite InE.
case=>[<-|]; first by exists [::]; exists s.
by case/IH=>s1 [s2] ->; exists (y :: s1); exists s2.
Qed.

Inductive perm (s1 s2 : seq A) : Prop :=
| permutation_nil of s1 = [::] & s2 = [::]
| permutation_skip x t1 t2 of s1 = x :: t1 & s2 = x :: t2 & perm t1 t2
| permutation_swap x y t of s1 = x :: y :: t & s2 = y :: x :: t
| permutation_trans t of perm s1 t & perm t s2.

Lemma perm_nil (s : seq A) : perm [::] s <-> s = [::].
Proof.
split=>[H|]; last by move=>->; apply: permutation_nil.
move: {1 2}[::] s H (erefl (Nil A)).
apply: perm_ind=>[|s1 s2 x t1 t2 ->|s1 s2 x y t ->|s1 s2 t _ IH1 _ IH2] //.
by move/IH1; move/IH2.
Qed.

Lemma perm_refl (s : seq A) : perm s s.
Proof.
elim:s=>[|e s IH]; first by apply: permutation_nil.
by apply: (permutation_skip (x:=e)) IH.
Qed.

Hint Resolve perm_refl.

Lemma perm_sym s1 s2 : perm s1 s2 <-> perm s2 s1.
Proof.
suff L: forall s1 s2, perm s1 s2 -> perm s2 s1 by split; apply: L.
apply: perm_ind=>s1' s2'.
- by move=>->->; apply: permutation_nil.
- by move=>x t1 t2 -> -> H1; apply: permutation_skip.
- by move=>x y t -> ->; apply: permutation_swap.
by move=>t _ H1 _ H2; apply: permutation_trans H2 H1.
Qed.

Lemma perm_trans s2 s1 s3 : perm s1 s2 -> perm s2 s3 -> perm s1 s3.
Proof. by apply: permutation_trans. Qed.

Lemma perm_in s1 s2 x : perm s1 s2 -> x \In s1 -> x \In s2.
Proof.
move: s1 s2; apply: perm_ind=>s1 s2.
- by move=>->->.
- move=>y t1 t2 -> -> H; rewrite !InE; tauto.
- by move=>y z t -> ->; rewrite !InE; tauto.
by move=>t _ IH1 _ IH2; move/IH1; move/IH2.
Qed.

Lemma perm_cat2lL s s1 s2 : perm s1 s2 -> perm (s ++ s1) (s ++ s2).
Proof. by elim:s=>[|e s IH] //=; move/IH; apply: permutation_skip. Qed.

Lemma perm_cat2rL s s1 s2 : perm s1 s2 -> perm (s1 ++ s) (s2 ++ s).
Proof.
move=>H; move: s1 s2 H s; apply: perm_ind=>s1 s2.
- by move=>->->.
- by move=>x t1 t2 -> -> H IH s /=; apply: permutation_skip.
- by move=>x y t -> -> s /=; apply: permutation_swap.
by move=>t H1 IH1 H2 IH2 s; apply: permutation_trans (IH2 s).
Qed.

Lemma perm_catL s1 t1 s2 t2 :
        perm s1 s2 -> perm t1 t2 -> perm (s1 ++ t1) (s2 ++ t2).
Proof.
move=>H; move: s1 s2 H t1 t2; apply: perm_ind=>s1 s2.
- by move=>->->.
- move=>x t1 t2 -> -> H IH r1 r2.
  by move/IH; apply: permutation_skip.
- move=>x y t -> -> t1 t2 H.
  by apply: (permutation_trans (t:=[:: x, y & t] ++ t2));
     [apply: perm_cat2lL | simpl; apply: permutation_swap].
move=>t H1 IH1 H2 IH2 t1 t2 H.
by apply: permutation_trans (IH2 _ _ H); apply: IH1.
Qed.

Lemma perm_cat_consL s1 t1 s2 t2 x :
        perm s1 s2 -> perm t1 t2 -> perm (s1 ++ x :: t1) (s2 ++ x :: t2).
Proof.
by move=>H1 H2; apply: perm_catL H1 _; apply: permutation_skip H2.
Qed.

Lemma perm_catC s1 s2 : perm (s1 ++ s2) (s2 ++ s1).
Proof.
elim:s1 s2=>[|x s1 IH1] s2 /=; first by rewrite cats0.
apply: (@perm_trans (x::s2++s1)); first by apply: permutation_skip (IH1 s2).
elim: s2=>[|y s2 IH2] //=.
apply: (@perm_trans (y::x::s2++s1)); first by apply: permutation_swap.
by apply: permutation_skip IH2.
Qed.

Hint Resolve perm_catC.

Lemma perm_cons_catCA s1 s2 x : perm (x :: s1 ++ s2) (s1 ++ x :: s2).
Proof.
rewrite -cat_rcons -cats1 -cat_cons -cat1s.
by apply: perm_cat2rL; apply: perm_catC.
Qed.

Lemma perm_cons_catAC s1 s2 x : perm (s1 ++ x :: s2) (x :: s1 ++ s2).
Proof. by apply/perm_sym; apply: perm_cons_catCA. Qed.

Hint Resolve perm_cons_catCA perm_cons_catAC.

Lemma perm_cons_cat_consL s1 s2 s x :
        perm s (s1 ++ s2) -> perm (x :: s) (s1 ++ x :: s2).
Proof.
case: s1=>[|a s1] /= H; first by apply: permutation_skip.
apply: (@perm_trans (x::a::s1++s2)); first by apply: permutation_skip.
apply: (@perm_trans (a::x::s1++s2)); first by apply: permutation_swap.
by apply: permutation_skip=>//; apply: perm_catCA.
Qed.

(* a somewhat generalized induction principle *)
Lemma perm_ind2 (P : seq A -> seq A -> Prop) :
        P [::] [::] ->
        (forall x s1 s2, perm s1 s2 -> P s1 s2 ->
           P (x :: s1) (x :: s2)) ->
        (forall x y s1 s2, perm s1 s2 -> P s1 s2 ->
           P (y :: x :: s1) (x :: y :: s2)) ->
        (forall s2 s1 s3, perm s1 s2 -> P s1 s2 ->
           perm s2 s3 -> P s2 s3 -> P s1 s3) ->
        forall s1 s2, perm s1 s2 -> P s1 s2.
Proof.
move=>H1 H2 H3 H4; apply: perm_ind=>s1 s2; last 1 first.
- by move=>t; apply: H4.
- by move=>->->.
- by move=>x t1 t2 -> ->; apply: H2.
move=>x y t -> ->.
have R : forall t, P t t by elim=>[|e t1 IH] //; apply:  H2.
apply: (H4 (y :: x :: t))=>//; last by apply: H3.
by apply: permutation_swap.
Qed.

(* Now the hard part; the opposite implications *)
Lemma perm_cat_consR s1 t1 s2 t2 x :
        perm (s1 ++ x :: t1) (s2 ++ x :: t2) -> perm (s1 ++ t1) (s2 ++ t2).
Proof.
move: s1 t1 s2 t2 x.
suff H:
  forall r1 r2, perm r1 r2 -> forall x s1 t1 s2 t2,
    r1 = s1 ++ x :: t1 -> r2 = s2 ++ x :: t2 -> perm (s1 ++ t1) (s2 ++ t2).
- by move=>s1 t1 s2 t2 x; move/H; apply.
apply: perm_ind2; last 1 first.
- move=>s2 s1 s3 H1 IH1 H2 IH2 x r1 t1 r2 t2 E1 E2.
  case: (@in_split x s2).
  - apply: perm_in H1 _; rewrite E1; apply: (@perm_in (x::r1++t1))=>//.
  by rewrite InE; left.
  move=>s4 [s5] E; apply: (@perm_trans (s4++s5)); first by apply: IH1 E1 E.
  by apply: IH2 E E2.
- by move=>x [].
- move=>x t1 t2 H IH y s1 s2 p1 p2 E1 E2.
  case: s1 E1=>[|b s1] /=; case: p1 E2=>[|c p1] /= E1 E2.
  - by case: E1 E2=><- <- [<-].
  - apply: (@perm_trans (p1 ++ c :: p2))=>//.
    by case: E1 H=><- ->; case: E2=><- ->.
  - case: E1 E2 H=><- <- [<-] ->; apply: (@perm_trans (s1 ++ x:: s2)).
    by apply: perm_cons_cat_consL.
  case: E1 E2 H IH=><- -> [<-] -> H IH.
  by apply: permutation_skip=>//; apply: IH.
move=>x y p1 p2 H IH z s1 t1 s2 t2 E1 E2.
case: s1 E1 H IH=>[|b s1]; case: s2 E2=>[|c s2]=>/=.
- by case=><- <- [<-] <- H IH; apply: permutation_skip.
- case=><-; case: s2=>[|b s2] /=.
  - by case=><- <-; case=><- H IH; apply: permutation_skip H.
  case=><- -> [<-] <- H IH.
  by apply: permutation_skip=>//; apply: perm_trans H _.
- case=><- <- [<-]; case: s1=>[|a s1] /=.
  - by case=><- H IH; apply: permutation_skip.
  by case=><- -> H IH; apply: permutation_skip=>//; apply: perm_trans H.
case=><-; case: s2=>[|a s2] /=; case: s1=>[|d s1] /=.
- by case=><- <- [<-] <- <- H IH; apply: permutation_skip.
- case=><- <- [<-] <- -> H IH.
  apply: (@perm_trans (x::y::s1 ++ t1)); first by apply: permutation_swap.
  by apply: permutation_skip=>//; apply: perm_trans H.
- case=><- -> [<-] <- <- H IH.
  apply: (@perm_trans (y::x::s2++t2)); last by apply: permutation_swap.
  by apply: permutation_skip=>//; apply: perm_trans H _.
case=><- -> [<-] <- -> H IH.
apply: (@perm_trans (x::y::s1++t1)); first by apply: permutation_swap.
by apply: permutation_skip=>//; apply: permutation_skip=>//; apply: IH.
Qed.

Lemma perm_cons x s1 s2 : perm (x :: s1) (x :: s2) <-> perm s1 s2.
Proof.
split; last by apply: permutation_skip.
by move/(@perm_cat_consR [::] s1 [::] s2 x).
Qed.

Lemma perm_cons_cat_cons x s1 s2 s :
        perm (x :: s) (s1 ++ x :: s2) <-> perm s (s1 ++ s2).
Proof.
split=>[|H]; first by by move/(@perm_cat_consR [::] s s1 s2 x).
by apply: (@perm_trans (x :: s1++s2))=>//; apply: permutation_skip.
Qed.

Lemma perm_cat_cons x s1 s2 t1 t2 :
        perm (s1 ++ x :: t1) (s2 ++ x :: t2) <-> perm (s1 ++ t1) (s2 ++ t2).
Proof.
split=>[|H]; first by apply: perm_cat_consR.
apply: (@perm_trans (x::s1++t1))=>//; apply: (@perm_trans (x::s2++t2))=>//.
by apply/perm_cons.
Qed.

Lemma perm_cat2l s1 s2 s3: perm (s1 ++ s2) (s1 ++ s3) <-> perm s2 s3.
Proof.
split; last by apply: perm_cat2lL.
elim: s1 s2 s3=>[|x s1 IH] s2 s3 //= H.
by apply: IH; move/perm_cons: H.
Qed.

Lemma perm_cat2r s1 s2 s3 : perm (s2 ++ s1) (s3 ++ s1) <-> perm s2 s3.
Proof.
split; last by apply: perm_cat2rL.
elim: s1 s2 s3=>[|x s1 IH] s2 s3 /=; first by rewrite !cats0.
by move=>H; apply: IH; apply: perm_cat_consR H.
Qed.

Lemma perm_catAC s1 s2 s3 : perm ((s1 ++ s2) ++ s3) ((s1 ++ s3) ++ s2).
Proof. by move=>*; rewrite -!catA perm_cat2l. Qed.

Lemma perm_catCA s1 s2 s3 : perm (s1 ++ s2 ++ s3) (s2 ++ s1 ++ s3).
Proof. by move=>*; rewrite !catA perm_cat2r. Qed.

End Permutations.

Hint Resolve perm_refl perm_catC perm_cons_catCA
             perm_cons_catAC perm_catAC perm_catCA.


Theorem identity_fn_applied_twice : forall (f : bool -> bool), (forall (x : bool), f x = x) -> forall (b : bool), f (f b) = b.
Proof.
intros.
rewrite -> H.
rewrite -> H.
reflexivity.
Qed.

Theorem andb_eq_orb : forall (b c : bool),(andb b c = orb b c) -> b = c.
Proof.
intros.
destruct b.
destruct c.
reflexivity.
Lemma andb_true_false : andb true false = false.
simpl.
reflexivity.
Qed.
Lemma orb_true_false : orb true false = true.
simpl.
reflexivity.
Qed.
rewrite -> andb_true_false in H.
rewrite -> orb_true_false in H.
symmetry.
apply H.
destruct c.
Lemma andb_false_true : andb false true = false.
simpl.
reflexivity.
Qed.
Lemma orb_false_true : orb false true = true.
simpl.
reflexivity.
Qed.
rewrite -> andb_false_true in H.
rewrite -> orb_false_true in H.
apply H.
reflexivity.
Qed.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem and_true_elim : forall b c : bool, andb b c = true -> b = true.
Proof.
intros b c H.
destruct b.
Case "b = true".
reflexivity.
rewrite <- H.
reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
intros b c H.
destruct c.
Case "c = true".
reflexivity.
Case "c = false".
rewrite <- H.
destruct b.
simpl.
reflexivity.
simpl.
reflexivity.
Qed.

Theorem plus_zero : forall n :nat, n + 0 = n.
Proof.
intros n.
destruct n as [| n'].
Case "n = 0".
simpl.
reflexivity.
Case "S n != 0".
simpl.
Abort.

Theorem plus_zero' : forall n : nat, n + 0 = n.
Proof.
intros n.
induction n.
Case "n = 0".
simpl.
reflexivity.
Case "n != 0".
simpl.
rewrite -> IHn.
reflexivity.
Qed.

Theorem minus_diag : forall n : nat, n - n = 0.
Proof.
intros n.
induction n.
Case "n = 0".
simpl.
reflexivity.
Case "n != 0".
simpl.
apply IHn.
Qed.

Theorem mult_0_r : forall n : nat, n * 0 = 0.
Proof.
intros n.
induction n.
Case "n = 0".
simpl.
reflexivity.
simpl.
apply IHn.
Qed.

Theorem plus_n_Sm : forall n m : nat, S (n + m) = n + (S m).
Proof.
intros n m.
induction n.
simpl in |- *.
reflexivity.
auto.
Qed.

Theorem plus_comm : forall n m : nat, n + m = m + n.
Proof.
intros n m.
induction n.
induction m.
simpl.
reflexivity.
simpl.
rewrite <- IHm.
simpl.
reflexivity.
simpl.
rewrite IHn.
elim m.
simpl.
reflexivity.
intros m'.
intros IHm.
simpl.
rewrite IHm.
reflexivity.
Qed.

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
intros n m p.
induction n.
induction m.
induction p.
simpl.
reflexivity.
simpl.
reflexivity.
simpl.
reflexivity.
simpl.
rewrite IHn.
reflexivity.
Qed.

Fixpoint double (n:nat) :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

Theorem double_plus : forall n : nat, double n = n + n.
Proof.
intros n.
induction n.
reflexivity.
simpl.
rewrite -> IHn.
rewrite -> plus_n_Sm.
reflexivity.
Qed.

Theorem mult_0_plus : forall n m : nat, (0 + n) * m = n * m.
Proof.
intros n m.
assert (H : 0 + n = n).
simpl.
reflexivity.
rewrite -> H.
reflexivity.
Qed.

Theorem plus_rearrange : forall n m p q : nat, (n + m) + (p + q) = (m + n) + (p + q).
Proof.
intros n m p q.
assert (H : n + m = m + n).
rewrite -> plus_comm; reflexivity.
rewrite -> H.
reflexivity.
Qed.

Theorem plus_swap : forall n m p : nat, n + (m + p) = m + (n + p).
Proof.
intros n m p.
rewrite -> plus_comm.
rewrite -> plus_assoc.
induction n.
induction m.
induction p.
simpl.
reflexivity.
rewrite -> plus_zero'.
simpl.
reflexivity.
rewrite -> plus_zero'.
rewrite -> plus_zero'.
reflexivity.
rewrite <- plus_assoc.
rewrite <- plus_assoc.
assert (H : p + S n = S n + p).
rewrite -> plus_comm.
reflexivity.
rewrite -> H.
reflexivity.
Qed.

Theorem mult_comm : forall m n : nat, m * n = n * m.
Proof.
intros m n.
induction m.
rewrite -> mult_0_r.
simpl.
reflexivity.
induction n.
simpl.
rewrite -> mult_0_r.
reflexivity.
simpl.
rewrite -> IHm.
simpl.
rewrite -> plus_swap.
Lemma mult_1: forall n m : nat, n + n * m = n * S m.
intros n m.
induction n.
induction m.
simpl.
reflexivity.
reflexivity.
simpl.
rewrite <- IHn.
rewrite -> plus_assoc.
rewrite -> plus_assoc.
assert (H : n + m = m + n).
rewrite -> plus_comm.
reflexivity.
rewrite -> H.
reflexivity.
Qed.
rewrite -> mult_1.
reflexivity.
Qed.

Print plus_comm.

Fixpoint evenb (n:nat) : bool :=
  match n with
  | O        => true
  | S O      => false
  | S (S n') => evenb n'
  end.

Theorem evenb_n__oddb_Sn : forall n : nat, evenb n = negb (evenb (S n)).
Proof.
intros n.
induction n.
simpl.
reflexivity.
assert (evenb n = evenb (S (S n))) as H.
reflexivity.
rewrite <- H.
rewrite IHn.
Lemma negb_involutive : forall b, negb (negb b) = b.
Proof.
intros b.
destruct b.
simpl.
reflexivity.
simpl.
reflexivity.
Qed.
rewrite -> negb_involutive.
reflexivity.
Qed.

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => beq_nat n' m'
            end
  end.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Definition blt_nat (n m : nat) : bool :=
  if andb (ble_nat n m) (negb (beq_nat n m)) then true else false.

Theorem ble_nat_refl : forall n : nat, true = ble_nat n n.
Proof.
intros n.
induction n.
simpl.
reflexivity.
simpl.
rewrite -> IHn.
reflexivity.
Qed.

Theorem zero_nbeq_S : forall n : nat, beq_nat 0 (S n) = false.
Proof.
intros n.
induction n.
simpl.
reflexivity.
simpl.
reflexivity.
Qed.

Theorem andb_false_r : forall b : bool, andb b false = false.
Proof.
intros b.
destruct b.
simpl.
reflexivity.
simpl.
reflexivity.
Qed.

Theorem plus_ble_compat_l : forall n m p : nat, ble_nat n m = true -> ble_nat (p + n) (p + m) = true.
Proof.
intros n m p.
intros H.
simpl.
induction p.
simpl.
rewrite H.
reflexivity.
simpl.
rewrite IHp.
reflexivity.
Qed.

Theorem S_nbeq_0 : forall n : nat, beq_nat (S n) 0 = false.
Proof.
intros n.
reflexivity.
Qed.

Theorem mult_1_l : forall n : nat, 1 * n = n.
Proof.
intros n.
simpl.
rewrite -> plus_zero'.
reflexivity.
Qed.

Theorem all3_spec : forall b c : bool, orb (andb b c)(orb (negb b)(negb c)) = true.
Proof.
intros b c.
destruct b.
destruct c.
simpl.
reflexivity.
simpl.
reflexivity.
destruct c.
simpl.
reflexivity.
simpl.
reflexivity.
Qed.

Theorem mult_plus_distr_r : forall n m p : nat, (n + m) * p = (n * p) + (m * p).
Proof.
intros n m p.
induction n.
reflexivity.
simpl.
rewrite IHn.
rewrite plus_assoc.
reflexivity.
Qed.

Theorem mult_assoc : forall n m p : nat, n * (m * p) = (n * m) * p.
Proof.
intros n m p.
induction n.
reflexivity.
simpl.
rewrite IHn.
rewrite mult_plus_distr_r.
reflexivity.
Qed.


Welcome to Coq 8.4pl5 (October 2014)

Coq < Section FirstSteps001.

Coq < Require Import Bool Arith List.
[Loading ML file z_syntax_plugin.cmxs ... done]
[Loading ML file quote_plugin.cmxs ... done]
[Loading ML file newring_plugin.cmxs ... done]

Coq < Load CpdtTactics.

Coq < Set Implicit Arguments.

Coq < Set Asymmetric Patterns.

Coq < Inductive binop : Set := Plus | Times.
binop is defined
binop_rect is defined
binop_ind is defined
binop_rec is defined

Coq < Inductive exp : Set :=
| Const : nat -> exp
| Binop : binop -> exp -> exp -> exp.Coq < Coq <
exp is defined
exp_rect is defined
exp_ind is defined
exp_rec is defined

Coq < Definition binopDenote := fun b =>
  match b with
    | Plus => plus
    | Times => mult
  end.Coq < Coq < Coq < Coq <
binopDenote is defined

Coq < Fixpoint expDenote (e : exp) : nat :=
  match e with
    | Const n => n
    | Binop b e1 e2 => (binopDenote b) (expDenote e1) (expDenote e2)
  end.Coq < Coq < Coq < Coq <
expDenote is recursively defined (decreasing on 1st argument)

Coq < Eval simpl in expDenote (Const 42).
     = 42
     : nat

Coq < Eval simpl in expDenote (Binop Plus (Const 2) (Const 2)).
     = 4
     : nat

Coq < Eval simpl in expDenote (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7)).
     = 28
     : nat

Coq < Eval simpl in expDenote (Binop Times (Binop Plus (Const 3) (Const 3)) (Const 6)).
     = 36
     : nat

Coq <


(*|
###########################################################
How to prove that a number is prime using Znumtheory in Coq
###########################################################

:Link: https://stackoverflow.com/q/49282773
|*)

(*|
Question
********

I'm trying to prove that a number is prime using the Znumtheory
library.

In Znumtheory primes are defined in terms of relative primes:
|*)

Require Import ZArith Znumtheory. (* .none *)
Inductive prime (p : Z) : Prop :=
  prime_intro :
    1 < p -> (forall n : Z, 1 <= n < p -> rel_prime n p) -> prime p.

(*|
So to prove that ``3`` is prime I should apply ``prime_intro`` to the
goal. Here is my try:
|*)

Require Import Lia.
Theorem prime3 : prime 3.
Proof.
  apply prime_intro.
  - lia.
  - intros. unfold rel_prime. apply Zis_gcd_intro.
    + apply Z.divide_1_l.
    + apply Z.divide_1_l.
    + intros. Abort.

(*|
I don't know how to use the hypothesis ``H : 1 <= n < 3`` which says
that ``n`` is ``1`` or ``2``. I could destruct it, apply
``lt_eq_cases`` and destruct it again, but I would be stuck with a
useless ``1 < n`` in the first case.

I wasn't expecting to have a hard time with something that looks so
simple.
|*)

(*|
Answer (larsr)
**************

Here is a proof that I think is quite understandable as one steps
through it. It stays at the level of number theory and doesn't unfold
definitions that much. I put in some comments, don't know if it makes
it more or less readable. But try to step through it in the IDE, if
you care for it...
|*)

Reset Initial. (* .none *)
Require Import ZArith.
Require Import Znumtheory.

Inductive prime (p : Z) : Prop :=
  prime_intro :
    1 < p -> (forall n : Z, 1 <= n < p -> rel_prime n p) -> prime p.

Require Import Lia.

Theorem prime3 : prime 3.
Proof.
  constructor.
  - lia.                        (* prove 1 < 3 *)
  - intros. constructor.        (* prove rel_prime n 3 *)
    + exists n. lia.            (* prove (1 | n) *)
    + exists 3. lia.            (* prove (1 | 3) *)

      (* our goal is now (x | 1), and we know (x | n) and (x | 3) *)
    + assert (Hn : n = 1 \/ n = 2) by lia. clear H. (* because 1 <= n < 3 *)
      case Hn.                  (* consider cases n=1 and n=2 *)
      * intros. subst.
        (* case n = 1: proves (x | 1) because we know (x | n) *)
        trivial.
      * intros. subst.   (* case n = 2: we know (x | n) and (x | 3) *)
        assert (Hgcd: (x | Z.gcd 2 3)) by (apply Z.gcd_greatest; trivial).
        (* Z.gcd_greatest: (x | 2) -> x | 3) -> (x | Z.gcd 2 3) *)
        apply Hgcd.         (* prove (x | 1), because Z.gcd 2 3 = 1 *)
Qed.

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

The lemma you mentioned is actually proved in that library, under the
name ``prime_3``. You can look up its proof on `GitHub
<https://github.com/coq/coq/blob/master/theories/ZArith/Znumtheory.v>`__.

You mentioned how strange it is to have such a hard time to prove
something so simple. Indeed, the proof in the standard library is
quite complicated. Luckily, there are much better ways to work out
this result. The `Mathematical Components
<https://github.com/math-comp/math-comp>`__ library advocates for a
different style of development based on boolean properties. There,
``prime`` is not an inductively defined predicate, but a function
``nat -> bool`` that checks whether its argument is prime. Because of
this, we can prove such simple facts by computation:
|*)

Set Warnings "-notation-overridden". (* .none *)
From Coq Require Import ssreflect ssrbool.
From mathcomp Require Import ssrnat prime.

Lemma prime_3 : prime 3. Proof. reflexivity. Qed.

(*|
There is a bit of magic going on here: the library declares a coercion
``is_true : bool -> Prop`` that is automatically inserted whenever a
boolean is used in a place where a proposition is expected. It is
defined as follows:
|*)

Definition is_true (b : bool) : Prop := b = true.

(*|
Thus, what ``prime_3`` really is proving above is ``prime 3 = true``,
which is what makes that simple proof possible.

The library allows you to connect this boolean notion of what a prime
number is to a more conventional one via a *reflection lemma*:
|*)

From mathcomp Require Import div eqtype.
Close Scope Z_scope. (* .none *)

Lemma primeP p :
  reflect (p > 1 /\ forall d, d %| p -> xpred2 1 p d) (prime p).

(*|
Unpacking notations and definitions, what this statement says is that
``prime p`` equals ``true`` if and only if ``p > 1`` and every ``d``
that divides ``p`` is equal to ``1`` or ``p``. I am afraid it would be
a lengthy detour to explain how this reflection lemma works exactly,
but if you find this interesting I strongly encourage you to look up
more about Mathematical Components.
|*)

(*|
Answer (epoiner)
****************

I have a variant of @larsr's proof.
|*)

Reset Initial. (* .none *)
Require Import ZArith.
Require Import Znumtheory.
Require Import Lia.

Theorem prime3 : prime 3.
Proof.
  constructor.
  - lia.
  - intros. assert (n = 1 \/ n = 2) as Ha by lia.
    destruct Ha; subst n; apply Zgcd_is_gcd.
Qed.

(*|
Like @larsr's proof, we prove that ``1 < 3`` using ``lia`` and then
prove that either ``n = 1`` or ``n = 2`` using ``lia`` again.

To prove ``rel_prime 1 3`` and ``rel_prime 2 3`` which are defined in
terms of ``Zis_gcd``, we apply ``Zgcd_is_gcd``. This lemma states that
computing the ``gcd`` is enough. This is trivial on concrete inputs
like ``(1, 3)`` and ``(2, 3)``.

**EDIT:** We can generalize this result, using only Gallina. We define
a boolean function ``is_prime`` that we prove correct w.r.t. the
inductive specification ``prime``. I guess this can be done in a more
elegant way, but I am confused with all the lemmas related to ``Z``.
Moreover, some of the definitions are opaque and cannot be used (at
least directly) to define a computable function.
|*)

Require Import ZArith.
Require Import Znumtheory.
Require Import Lia.
Require Import Bool.
Require Import Recdef.

(** [for_all] checks that [f] is true for any integer between 1 and [n] *)
Function for_all (f : Z -> bool) n {measure Z.to_nat n} :=
  if n <=? 1 then true
  else f (n - 1) && for_all f (n - 1).
Proof.
  intros. apply Z.leb_nle in teq. apply Z2Nat.inj_lt; lia.
Defined.

Lemma for_all_spec : forall f n,
    for_all f n = true -> forall k, 1 <= k < n -> f k = true.
Proof.
  intros. assert (0 <= n) by lia. revert n H1 k H0 H.
  apply (natlike_ind
           (fun n => forall k : Z,
                1 <= k < n -> for_all f n = true -> f k = true)); intros.
  - lia.
  - rewrite for_all_equation in H2.
    destruct (Z.leb_spec0 (Z.succ x) 1).
    + lia.
    + replace (Z.succ x - 1) with x in H2 by lia. apply andb_true_iff in H2.
      assert (k < x \/ k = x) by lia. destruct H3.
      * apply H0; [lia | apply H2].
      * subst k. apply H2.
Qed.

Definition is_prime (p : Z) :=
  (1 <? p) && for_all (fun k => Z.gcd k p =? 1) p.

Theorem is_prime_correct : forall z, is_prime z = true -> prime z.
Proof.
  intros. unfold is_prime in H. apply andb_true_iff in H.
  destruct H as (H & H0). constructor.
  - apply Z.ltb_lt. assumption.
  - intros. apply for_all_spec with (k := n) in H0; try assumption.
    unfold rel_prime. apply Z.eqb_eq in H0. rewrite <- H0.
    apply Zgcd_is_gcd.
Qed.

(*| The proof becomes nearly as simple as @Arthur's one. |*)

Theorem prime113 : prime 113.
Proof.
  apply is_prime_correct; reflexivity.
Qed.

(*|
Answer (larsr)
**************

Fun fact: @epoiner's answer can be used together with Ltac in a proof
script for any prime number.

.. coq:: none
|*)

Reset Initial.
Require Import ZArith.
Require Import Znumtheory.
Require Import Lia.

(*||*)

Theorem prime113 : prime 113.
Proof.
  constructor.
  - lia.
  - intros n H;
      repeat match goal with
             | H : 1 <= ?n < ?a  |- _ =>
               assert (Hn: n = a - 1 \/ 1 <= n < a - 1) by lia;
                 clear H; destruct Hn as [Hn | H];
                   [subst n; apply Zgcd_is_gcd | simpl in H; try lia]
             end.
Qed.

(*|
However, the proof term gets unwieldy, and checking becomes slower and
slower. This is why it small scale reflection (ssreflect) where
computation is moved into the type checking probably is preferrable in
the long run. It's hard to beat @Arthur Azevedo De Amorim's proof:
``Proof. reflexivity. Qed.`` :-) Both in terms of computation time,
and memory-wise.
|*)


(* Exercise 28 *)

Require Import BenB.

Variable D : Set.
Variable R : D -> D -> Prop.

Theorem exercise_028 : (forall x:D, forall y:D, R x y) -> ~(exists x:D, ~ R x x).
Proof.
imp_i a1.
neg_i (exists x:D, ~R x x) a2.
exi_e (exists x:D, ~R x x) a a3.
hyp a2.
neg_i (R a a) a4.
hyp a3.
all_e (forall y:D, R a y) a.
all_e (forall x:D, forall y:D, R x y) a.
hyp a1.
hyp a2.
Qed.


Require Export ZF.
Require Import ZFstable.

(** ordered pairs *)

(** 1- untyped operations *)

Definition couple x y := pair (singl x) (pair x y).

Instance couple_morph : morph2 couple.
unfold couple; do 3 red; intros.
rewrite H; rewrite H0; reflexivity.
Qed.

Lemma union_couple_eq : forall a b, union (couple a b) == pair a b.
Proof.
intros; unfold couple in |- *; symmetry  in |- *.
apply union_ext; intros.
 elim pair_elim with (1 := H0); intro y_eq;  rewrite y_eq in H.
   rewrite (singl_elim _ _ H); auto.
  trivial.
 elim pair_elim with (1 := H); intro.
  exists (singl a); auto.
    apply singl_intro_eq; auto.
  exists (pair a b); auto.
Qed.

Lemma discr_mt_couple a b : ~ empty == couple a b.
apply discr_mt_pair.
Qed.

Definition fst p := union (subset (union p) (fun x => singl x ∈ p)).

Instance fst_morph : morph1 fst.
unfold fst; do 2 red; intros.
apply union_morph.
apply subset_morph; intros.
 apply union_morph; trivial.
 split; intro.
   rewrite <- H; trivial.
   rewrite H; trivial.
Qed.

Lemma fst_def : forall x y, fst (couple x y) == x.
Proof.
unfold fst, couple in |- *; intros.
transitivity (union (singl x)).
 apply union_morph.
   apply singl_ext; intros.
  apply subset_intro.
   apply union_intro with (singl x).
    apply singl_intro.
    auto.
   auto.
  elim subset_elim2 with (1 := H); intros.
    rewrite <- H0 in H1.
    clear H0 x0.
    elim pair_elim with (1 := H1); intros.
   apply singl_inj; trivial.
   assert (x ∈ singl z).
    rewrite H0; auto.
     rewrite (singl_elim _ _ H2); reflexivity.
 apply union_singl_eq.
Qed.

Lemma fst_mt : fst empty == empty.
unfold fst.
apply empty_ext; red; intros.
apply union_elim in H; destruct H.
apply subset_elim1 in H0.
apply union_elim in H0; destruct H0.
apply empty_ax in H1; trivial.
Qed.

Definition snd p :=
  union (subset (union p) (fun z => pair (fst p) z == union p)).

Instance snd_morph : morph1 snd.
Proof.
unfold snd; do 2 red; intros.
apply union_morph.
apply subset_morph; intros.
 apply union_morph; trivial.

 red; intros.
 rewrite H; reflexivity.
Qed.

Lemma snd_def : forall x y, snd (couple x y) == y.
Proof.
intros; unfold snd in |- *.
transitivity (union (singl y)).
 apply union_morph.
   apply singl_ext; intros.
  apply subset_intro.
    rewrite union_couple_eq.
     auto.
    rewrite fst_def.
     symmetry  in |- *.
     apply union_couple_eq.
  elim subset_elim2 with (1 := H); intros.
  rewrite H0.
  rewrite fst_def in H1.
  rewrite union_couple_eq in H1.
  apply pair_inv in H1; destruct H1.
   destruct H1; auto.

   destruct H1.
   rewrite H2; trivial.
 apply union_singl_eq.
Qed.

Lemma couple_injection : forall x y x' y',
  couple x y == couple x' y' -> x == x' /\ y == y'.
intros.
split.
 rewrite <- (fst_def x y);rewrite H; rewrite fst_def; reflexivity.
 rewrite <- (snd_def x y);rewrite H; rewrite snd_def; reflexivity.
Qed.

Lemma couple_mt_discr a b :
  ~ couple a b == empty.
intro.
apply empty_ax with (x:=singl a).
rewrite <- H; apply pair_intro1.
Qed.

(** 2- typing *)

Definition prodcart A B :=
  subset (power (power (A ∪ B)))
    (fun x => exists2 a, a ∈ A & exists2 b, b ∈ B & x == couple a b).

Instance prodcart_mono :
  Proper (incl_set ==> incl_set ==> incl_set) prodcart.
unfold prodcart; red; intros A A' H B B' H0 z H1.
specialize subset_elim1 with (1:=H1); intro.
elim subset_elim2 with (1:=H1); clear H1; intros.
destruct H3.
destruct H4.
apply subset_intro.
 apply power_mono with (2:=H2).
 apply power_mono.
 apply union2_mono; trivial.

 exists x0; auto.
 exists x1; auto.
 rewrite H1; trivial.
Qed.

Instance prodcart_morph : morph2 prodcart.
Proof.
unfold prodcart; do 3 red; intros.
apply subset_morph; intros.
 rewrite H;  rewrite H0; reflexivity.

 split; intros.
  destruct H2 as (a, inA, (b, inB, eqx)).
  exists a.
   rewrite <- H; trivial.

   exists b; trivial.
   rewrite <- H0; trivial.
  destruct H2 as (a, inA, (b, inB, eqx)).
  exists a.
   rewrite H; trivial.

   exists b; trivial.
   rewrite H0; trivial.
Qed.

Lemma couple_intro :
  forall x y A B, x ∈ A -> y ∈ B -> couple x y ∈ prodcart A B.
Proof.
intros.
unfold couple, prodcart in |- *.
apply subset_intro.
 apply power_intro; intros.
   apply power_intro; intros.
   elim pair_elim with (1 := H1); intros.
    rewrite H3 in H2.
      apply union2_intro1.
      rewrite (singl_elim _ _ H2); trivial.
    rewrite H3 in H2.
      elim pair_elim with (1:=H2); intro z0_eq; rewrite z0_eq.
      apply union2_intro1; trivial.
      apply union2_intro2; trivial.
 exists x; trivial.
 exists y; trivial.
 reflexivity.
Qed.

Lemma fst_typ : forall p A B, p ∈ prodcart A B -> fst p ∈ A.
Proof.
unfold prodcart in |- *; intros.
elim subset_elim2 with (1 := H); intros.
destruct H1 as (a, inA, (b, inB, eqp)).
 rewrite <- H0 in eqp.
 rewrite eqp.
 rewrite fst_def; trivial.
Qed.

Lemma snd_typ : forall p A B, p ∈ prodcart A B -> snd p ∈ B.
Proof.
unfold prodcart in |- *; intros.
elim subset_elim2 with (1 := H); intros.
destruct H1 as (a, inA, (b, inB, eqp)).
 rewrite <- H0 in eqp.
 rewrite eqp.
 rewrite snd_def; trivial.
Qed.

Lemma surj_pair :
  forall p A B, p ∈ prodcart A B -> p == couple (fst p) (snd p).
Proof.
intros.
unfold prodcart in H.
elim subset_elim2 with (1 := H); intros.
destruct H1 as (a, inA, (b, inB, eqp)).
 rewrite <- H0 in eqp.
 rewrite eqp.
 rewrite fst_def.
 rewrite snd_def; reflexivity.
Qed.

Lemma prodcart_stable_class : forall K F G,
  morph1 F ->
  morph1 G ->
  stable_class K F ->
  stable_class K G ->
  stable_class K (fun y => prodcart (F y) (G y)).
intros K F G Fm Gm Fs Gs.
red; red; intros X Xcls z zint.
destruct inter_wit with (2:=zint) as (w,winX).
 do 2 red; intros.
 rewrite H; reflexivity.
assert (zall : forall x, x ∈ X -> z ∈ prodcart (F x) (G x)).
 intros.
 apply inter_elim with (1:=zint).
 rewrite replf_ax.
  exists x; auto with *.

  red; red; intros.
  rewrite H1; reflexivity.
clear zint.
assert (z ∈ prodcart (F w) (G w)) by auto.
rewrite (surj_pair _ _ _ H).
apply couple_intro.
 apply Fs; trivial.
 apply inter_intro.
  intros.
  rewrite replf_ax in H0; trivial.
  2:red;red;auto.
  destruct H0.
  rewrite H1; apply zall in H0; apply fst_typ in H0; trivial.

  exists (F w); rewrite replf_ax; auto.
  eauto with *.

 apply Gs; trivial.
 apply inter_intro.
  intros.
  rewrite replf_ax in H0; auto.
  destruct H0.
  rewrite H1; apply zall in H0; apply snd_typ in H0; trivial.

  exists (G w); rewrite replf_ax; auto.
  eauto with *.
Qed.

(* dependent pairs *)

Definition sigma A B :=
  subset (prodcart A (sup A B)) (fun p => snd p ∈ B (fst p)).

Notation "'Σ'  x ∈ A , B" :=
   (sigma A (fun x => B)) (x ident, at level 200, right associativity).

Instance sigma_morph : Proper (eq_set ==> (eq_set ==> eq_set) ==> eq_set) sigma.
unfold sigma; do 3 red; intros.
apply subset_morph.
 apply prodcart_morph; trivial.
 apply sup_morph; trivial.
 red; intros; auto.

 red; intros.
 apply in_set_morph; auto with *.
Qed.

Lemma sigma_ext : forall A A' B B',
  A == A' ->
  (forall x x', x ∈ A -> x == x' -> B x == B' x') ->
  sigma A B == sigma A' B'.
unfold sigma; intros.
assert (peq : sup A B == sup A' B').
 apply union_morph.
 apply replf_morph; trivial.

apply subset_ext; intros.
 apply subset_intro.
  rewrite peq; rewrite H; trivial.

  rewrite (H0 (fst x) (fst x)); trivial.
  rewrite H; apply fst_typ with (1:=H1).
  reflexivity.

  specialize subset_elim1 with (1:=H1); intros.
   rewrite <- peq; rewrite <- H; trivial.

  elim subset_elim2 with (1:=H1); intros.
  exists x0; trivial.
  rewrite <- (H0 (fst x0) (fst x0)); trivial; try reflexivity.
  rewrite <- H2.
  specialize subset_elim1 with (1:=H1); intro.
  apply fst_typ with (1:=H4).
Qed.

Lemma sigma_nodep : forall A B,
  prodcart A B == Σ _∈A, B.
intros.
apply eq_intro; intros.
 generalize (fst_typ _ _ _ H); intro.
 generalize (snd_typ _ _ _ H); intro.
 apply subset_intro; trivial.
 rewrite (surj_pair _ _ _ H).
 apply couple_intro; trivial.
 apply union_intro with B; trivial.
 apply replf_intro with (fst z); auto with *.

 apply subset_elim1 in H.
 generalize (fst_typ _ _ _ H); intro.
 generalize (snd_typ _ _ _ H); intro.
 rewrite (surj_pair _ _ _ H).
 apply couple_intro; trivial.
 apply union_elim in H1; destruct H1.
 rewrite replf_ax in H2; auto with *.
 destruct H2.
 rewrite <- H3; trivial.
Qed.

Lemma couple_intro_sigma :
  forall x y A B,
  ext_fun A B ->
  x ∈ A -> y ∈ B x -> couple x y ∈ sigma A B.
intros; unfold sigma.
apply subset_intro.
 apply couple_intro; trivial.
 rewrite sup_ax; eauto.

 rewrite <- (H x (fst(couple x y))); trivial.
  rewrite snd_def; trivial.
  rewrite fst_def; reflexivity.
Qed.

Lemma fst_typ_sigma : forall p A B, p ∈ sigma A B -> fst p ∈ A.
Proof.
unfold sigma in |- *; intros.
specialize subset_elim1 with (1 := H); intros.
apply fst_typ with (1:=H0).
Qed.

Lemma snd_typ_sigma : forall p y A B,
  ext_fun A B ->
  p ∈ sigma A B -> y == fst p -> snd p ∈ B y.
intros.
unfold sigma in H0.
elim subset_elim2 with (1:=H0); intros.
rewrite H2.
rewrite (H y (fst x)); trivial.
 specialize subset_elim1 with (1 := H0); intros.
 rewrite H1; apply fst_typ with (1:=H4).

 rewrite H1; rewrite H2; reflexivity.
Qed.

Lemma sigma_mono : forall A A' B B',
  ext_fun A B ->
  ext_fun A' B' ->
  A ⊆ A' ->
  (forall x x', x ∈ A -> x == x' -> B x ⊆ B' x') ->
  sigma A B ⊆ sigma A' B'.
red; intros.
rewrite (surj_pair _ _ _ (subset_elim1 _ _ _ H3)).
apply couple_intro_sigma; trivial.
 apply fst_typ_sigma in H3; auto.

 apply (H2 (fst z)); auto with *.
  apply fst_typ_sigma in H3; auto.

  apply snd_typ_sigma with (2:=H3); auto with *.
Qed.

Lemma sigma_elim A B p :
  ext_fun A B ->
  p ∈ sigma A B ->
  p == couple (fst p) (snd p) /\
  fst p ∈ A /\
  snd p ∈ B (fst p).
intros.
split.
 apply subset_elim1 in H0.
 apply surj_pair in H0; trivial.

 split.
 apply fst_typ_sigma in H0; trivial.

 apply snd_typ_sigma with (2:=H0); auto with *.
Qed.

Definition sigma_case b c :=
  cond_set (c == couple (fst c) (snd c)) (b (fst c) (snd c)).

Instance sigma_case_morph :
  Proper ((eq_set==>eq_set==>eq_set)==>eq_set==>eq_set) sigma_case.
do 3 red; intros.
apply cond_set_morph.
 rewrite H0; reflexivity.

 apply H; rewrite H0; reflexivity.
Qed.

Lemma sigma_case_couple f a b c :
  morph2 f ->
  c == couple a b ->
  sigma_case f c == f a b.
intros.
unfold sigma_case.
rewrite cond_set_ok.
 rewrite H0; rewrite fst_def; rewrite snd_def; reflexivity.

 rewrite H0; rewrite fst_def; rewrite snd_def; reflexivity.
Qed.
(*
Lemma sigma_case_mt f c :
  c == empty ->
  sigma_case f c == empty.
intros.
unfold sigma_case.
apply empty_ext; red; intros.
rewrite cond_set_ax in H0.
destruct H0.
rewrite H1 in H.
assert (singl (fst c) ∈ couple (fst c) (snd c)).
 apply pair_intro1.
rewrite H in H2.
apply empty_ax in H2; trivial.
*)
(*Lemma fst_mt : fst empty == empty.
apply empty_ext; red; intros.
unfold fst in H.
apply union_elim in H; destruct H.
apply subset_elim1 in H0.
apply union_elim in H0; destruct H0.
apply empty_ax in H1; trivial.
Qed.
Lemma snd_mt : snd empty == empty.
apply empty_ext; red; intros.
unfold snd in H.
apply union_elim in H; destruct H.
apply subset_elim1 in H0.
apply union_elim in H0; destruct H0.
apply empty_ax in H1; trivial.
Qed.
*)

Lemma sigma2_stable_class K A F :
  (forall y y' x x', y == y' -> x ∈ A -> x == x' -> F y x == F y' x') ->
  (forall x, x ∈ A -> stable_class K (fun y => F y x)) ->
  stable_class K (fun y => sigma A (F y)).
intros Fm Fs.
assert (Hm : morph1 (fun y => sigma A (F y))).
 do 2 red; intros.
 apply subset_morph.
  apply prodcart_morph; auto with *.
  apply union_morph.
  apply replf_morph; auto with *.
  red; intros.
  apply Fm; trivial.

 red; intros.
 setoid_replace (F x (fst x0)) with (F y (fst x0)); auto with *.
 apply Fm; auto with *.
 apply fst_typ in H0; trivial.
red; red ;intros.
destruct inter_wit with (2:=H0) as (w,winX); trivial.
assert (forall x, x ∈ X -> z ∈ sigma A (F x)).
 intros.
 apply inter_elim with (1:=H0).
 rewrite replf_ax; auto.
 exists x; auto with *.
clear H0.
assert (z ∈ sigma A (F w)) by auto.
rewrite (surj_pair _ _ _ (subset_elim1 _ _ _ H0)).
apply couple_intro_sigma.
 red;red;intros;apply Fm; auto with *.

 apply fst_typ_sigma in H0; trivial.

 apply Fs; trivial.
  apply fst_typ_sigma in H0; trivial.
 apply inter_intro.
  intros.
  rewrite replf_ax in H2.
   destruct H2.
   rewrite H3; apply H1 in H2; apply snd_typ_sigma with (y:=fst z) in H2;
   auto with *.
   red; red; intros; apply Fm; auto with *.

   red; red; intros; apply Fm; auto with *.
   apply fst_typ_sigma in H0; trivial.

  exists (F w (fst z)); rewrite replf_ax.
   eauto with *.

   red;red;intros; apply Fm; auto with *.
   apply fst_typ_sigma in H0; trivial.
Qed.

Lemma sigma_stable_class (K:set->Prop) F G :
  morph1 F ->
  morph2 G ->
  stable_class K F ->
  (forall x, stable_class K (fun y => G y x)) ->
  stable_class K (fun y => sigma (F y) (G y)).
intros Fm Gm Fs Gs.
red; red; intros.
assert (Hm : morph1 (fun y => sigma (F y) (G y))).
 do 2 red; intros.
 apply subset_morph.
  apply prodcart_morph; auto with *.
  apply sup_morph; auto with *.
  red; intros; apply Gm; trivial.

  red; intros.
  apply in_set_morph; auto with *.
  apply Gm; auto with *.
destruct inter_wit with (2:=H0) as (w,winX); trivial.
assert (forall x, x ∈ X -> z ∈ sigma (F x) (G x)).
 intros.
 apply inter_elim with (1:=H0).
 rewrite replf_ax; auto.
 exists x; auto with *.
clear H0.
assert (z ∈ sigma (F w) (G w)) by auto.
rewrite (surj_pair _ _ _ (subset_elim1 _ _ _ H0)).
apply couple_intro_sigma.
 do 2 red;intros;apply Gm; auto with *.

 apply Fs; trivial.
 apply inter_intro.
  intros.
  rewrite replf_ax in H2; auto.
  destruct H2.
  rewrite H3; apply H1 in H2; apply fst_typ_sigma in H2; trivial.

  exists (F w); rewrite replf_ax; auto.
  eauto with *.

 apply Gs; trivial.
 apply inter_intro.
  intros.
  rewrite replf_ax in H2.
   destruct H2.
   rewrite H3; apply H1 in H2; apply snd_typ_sigma with (y:=fst z) in H2;
   auto with *.
   red; red; intros; apply Gm; auto with *.

   red; red; intros; apply Gm; auto with *.

  exists (G w (fst z)); rewrite replf_ax.
  2:red;red;intros; apply Gm; auto with *.
  eauto with *.
Qed.

Global Opaque couple fst snd prodcart sigma.


Require Import List.
Import ListNotations.

Require Import IFOL.Syntax.Signature.

Require Import IFOL.Examples.HA.Syntax.Sort.

Inductive HA_f_symbols : Type :=
  | Zero | Succ | Plus | Mult.

Definition Zero_arity : f_arity HA_sort := {|
  f_args := [];
  f_out := Nat
  |}.

Definition Succ_arity : f_arity HA_sort := {|
  f_args := [Nat];
  f_out := Nat
  |}.

Definition Plus_arity : f_arity HA_sort := {|
  f_args := [Nat; Nat];
  f_out := Nat
  |}.

Definition Mult_arity : f_arity HA_sort := {|
  f_args := [Nat; Nat];
  f_out := Nat
  |}.

Definition HA_f_sig : f_sig HA_sort := {|
  f_symbols := HA_f_symbols;
  f_arities := fun s =>
    match s with
    | Zero => Zero_arity
    | Succ => Succ_arity
    | Plus => Plus_arity
    | Mult => Mult_arity
    end
  |}.

Definition HA_r_sig : r_sig HA_sort := {|
  r_symbols := Empty_set;
  r_arities := fun s =>
    match s with
    end
  |}.

Definition HA_sig : sig HA_sort := {|
  func := HA_f_sig;
  rel := HA_r_sig
  |}.


From Undecidability.Shared.Libs.PSL Require Import Prelim.
From Undecidability.Shared.Libs.PSL Require Import EqDec.

(* ** Numbers **)

Lemma complete_induction (p : nat -> Prop) (x : nat) :
(forall x, (forall y, y<x -> p y) -> p x) -> p x.

Proof. intros A. apply A. induction x ; intros y B.
exfalso ; lia.
apply A. intros z C. apply IHx. lia. Qed.

Lemma size_induction X (f : X -> nat) (p : X -> Prop) :
  (forall x, (forall y, f y < f x -> p y) -> p x) ->
  forall x, p x.

Proof.
  intros IH x. apply IH.
  assert (G: forall n y, f y < n -> p y).
  { intros n. induction n.
    - intros y B. exfalso. lia.
    - intros y B. apply IH. intros z C. apply IHn. lia. }
  apply G.
Qed.

Lemma size_induction_dep L (X : L -> Type) (f : forall l, X l -> nat) (p : forall l, X l -> Type) :
  (forall l x, (forall l' y, f l' y < f l x -> p l' y) -> p l x) ->
  forall l x, p l x.
Proof.
  intros IH l x. apply IH. intros l'.
  assert (G: forall n l' y, f l' y < n -> p l' y).
  { intros n. induction n; intros l'' y.
    - intros B. exfalso. lia.
    - intros B. apply IH. intros ll z C. eapply IHn. lia. }
  apply G.
Qed.

#[global]
Instance nat_le_dec (x y : nat) : dec (x <= y) :=
  Compare_dec.le_dec x y.

Lemma size_recursion (X : Type) (sigma : X -> nat) (p : X -> Type) :
  (forall x, (forall y, sigma y < sigma x -> p y) -> p x) ->
  forall x, p x.
Proof.
  intros D x. apply D. revert x.
  enough (forall n y, sigma y < n -> p y) by eauto.
  intros n. induction n; intros y E.
  - exfalso; lia.
  - apply D. intros x F.  apply IHn. lia.
Qed.

Arguments size_recursion {X} sigma {p} _ _.

Section Iteration.
  Variables (X: Type) (f: X -> X).

  Fixpoint it (n : nat) (x : X) : X :=
    match n with
      | 0 => x
      | S n' => f (it n' x)
    end.

  Lemma it_ind (p : X -> Prop) x n :
    p x -> (forall z, p z -> p (f z)) -> p (it n x).
  Proof.
    intros A B. induction n; cbn; auto.
  Qed.

  Definition FP (x : X) : Prop := f x = x.

  Lemma it_fp (sigma : X -> nat) x :
    (forall n, FP (it n x) \/ sigma (it n x) > sigma (it (S n) x)) ->
    FP (it (sigma x) x).
  Proof.
    intros A.
    assert (B: forall n, FP (it n x) \/ sigma x >= n + sigma (it n x)).
    { intros n; induction n; cbn.
      - auto.
      - destruct IHn as [B|B].
        + left. now rewrite B.
        + destruct (A n) as [C|C].
          * left. now rewrite C.
          * right. cbn in C. lia. }
    destruct (A (sigma x)), (B (sigma x)); auto; exfalso; lia.
  Qed.
End Iteration.