From mathcomp Require Import all_ssreflect.
Require Import bigmin extra.

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

Section tarjan.

Variable (V : finType) (successors : V -> seq V).
Notation infty := #|V|.+1.

(*************************************************************)
(*               Tarjan 72 algorithm,                        *)
(* rewritten in a functional style  with extra modifications *)
(*************************************************************)

Record env := Env {esccs : {set {set V}}; serial : nat; num : {ffun V -> nat}}.

Definition visit x e :=
  Env (esccs e) (serial e).+1 (finfun [eta num e with x |-> serial e]).
Definition store C e :=
  Env (C |: esccs e) (serial e) [ffun x => if x \in C then #|V| else num e x].

Definition dfs1 dfs x e :=
    let: (m1, C, e1) := dfs [set y in successors x] (visit x e) in
    let xC := x |: C in
    if m1 < serial e then (m1, xC, e1) else (#|V|, set0, store xC e1).

Definition dfs dfs1 dfs (roots : {set V}) e : nat * {set V} * env :=
  if [pick x in roots] isn't Some x then (#|V|, set0, e) else
  let: (m1, C1, e1) := if num e x != infty then (num e x, set0, e) else dfs1 x e in
  let: (m2, C2, e2) := dfs (roots :\ x) e1 in (minn m1 m2, C1 :|: C2, e2).

Fixpoint tarjan_rec n :=
  if n is n.+1 then dfs (dfs1 (tarjan_rec n)) (tarjan_rec n)
  else fun r e => (#|V|, set0, e).

Let N := #|V| * #|V|.+1 + #|V|.
Definition e0 := (Env set0 0 [ffun _ => infty]).
Definition tarjan := esccs (tarjan_rec N setT e0).2.

(*****************)
(* Abbreviations *)
(*****************)

Notation edge := (grel successors).
Notation gconnect := (connect edge).
Notation gsymconnect := (symconnect edge).
Notation gsccs := (sccs edge).
Notation gscc_of := (pblock gsccs).
Notation gconnected := (connected edge).

(*******************)
(* next, and nexts *)
(*******************)

Section Nexts.
Variable (D : {set V}).

Definition nexts (A : {set V}) :=
  \bigcup_(v in A) [set w in connect (relfrom (mem D) edge) v].

Lemma nexts0 : nexts set0 = set0.
Proof. by rewrite /nexts big_set0. Qed.

Lemma nexts1 x :
  nexts [set x] = x |: (if x \in D then nexts [set y in successors x] else set0).
Proof.
apply/setP=> y; rewrite /nexts big_set1 !inE.
have [->|neq_yx/=] := altP eqP; first by rewrite connect0.
apply/idP/idP=> [/connect1l[]// z/=/andP[/= xD xz zy]|].
  by rewrite xD; apply/bigcupP; exists z; rewrite !inE.
case: ifPn; rewrite ?inE// => xD /bigcupP[z]; rewrite !inE.
by move=> xz; apply/connect_trans/connect1; rewrite /= xD.
Qed.

Lemma nextsU A B : nexts (A :|: B) = nexts A :|: nexts B.
Proof. exact: bigcup_setU. Qed.

Lemma nextsS (A : {set V}) : A \subset nexts A.
Proof. by apply/subsetP=> a aA; apply/bigcupP; exists a; rewrite ?inE. Qed.

Lemma nextsT : nexts setT = setT.
Proof. by apply/eqP; rewrite eqEsubset nextsS subsetT. Qed.

Lemma nexts_id (A : {set V}) : nexts (nexts A) = nexts A.
Proof.
apply/eqP; rewrite eqEsubset nextsS andbT; apply/subsetP=> x.
move=> /bigcupP[y /bigcupP[z zA]]; rewrite !inE => /connect_trans yto /yto zx.
by apply/bigcupP; exists z; rewrite ?inE.
Qed.

Lemma in_nextsW A y : y \in nexts A -> exists2 x, x \in A & gconnect x y.
Proof.
move=>/bigcupP[x xA]; rewrite inE => xy; exists x => //.
by apply: connect_sub xy => u v /andP[_ /connect1].
Qed.

End Nexts.

Lemma sub_nexts (D D' A B : {set V}) :
  D \subset D' -> A \subset B -> nexts D A \subset nexts D' B.
Proof.
move=> /subsetP subD /subsetP subAB; apply/subsetP => v /bigcupP[a /subAB aB].
rewrite !inE => av; apply/bigcupP; exists a; rewrite ?inE //=.
by apply: connect_sub av => x y /andP[xD xy]; rewrite connect1//= subD.
Qed.

Lemma nextsUI A B C : nexts B A \subset A ->
  A :|: nexts (B :&: ~: A) C = A :|: nexts B C.
Proof.
move=> subA; apply/setP=> y; rewrite !inE; have [//|/= yNA] := boolP (y \in A).
apply/idP/idP; first by apply: subsetP; rewrite sub_nexts// subsetIl.
move=> /bigcupP[z zr zy]; apply/bigcupP; exists z; first by [].
rewrite !inE; apply: contraTT isT => Nzy; move: zy; rewrite !inE.
move=> /(connect_from (mem (~: A))) /= [t].
rewrite !inE => -[xtxy zt ty]; move: zt.
rewrite (@eq_connect _ _ (relfrom (mem (B :&: ~: A)) edge)); last first.
  by move=> u v /=; rewrite !inE andbCA andbA.
case: (altP eqP) xtxy => /= [<-|neq_yt]; first by rewrite (negPf Nzy).
rewrite implybF negbK => tA zt; rewrite -(negPf yNA) (subsetP subA)//.
by apply/bigcupP; exists t; rewrite // inE.
Qed.

Lemma nexts1_split (A : {set V}) x : x \in A ->
  nexts A [set x] = x |: nexts (A :\ x) [set y in successors x].
Proof.
move=> xA; apply/setP=> y; apply/idP/idP; last first.
  rewrite nexts1 !inE xA; case: (_ == _); rewrite //=.
  by apply: subsetP; rewrite sub_nexts// subsetDl.
move=> /bigcupP[z]; rewrite !inE => /eqP[{z}->].
move=> /connectP[p /shortenP[[_ _ _ /eqP->//|z q/=/andP[/andP[_ xz]]]]].
rewrite path_from => /andP[zq] /allP/= qA.
move=> /and3P[xNzq _ _] _ ->; apply/orP; right.
apply/bigcupP; exists z; rewrite !inE//.
apply/connectP; exists q; rewrite // path_from zq/=.
apply/allP=> t tq; rewrite !inE qA ?andbT//.
by apply: contraNneq xNzq=> <-; apply: mem_belast tq.
Qed.

(*******************)
(* Well formed env *)
(*******************)

Definition seen e := [set x | num e x < infty].
Notation sn e := #|seen e|.
Definition stack e := [set x | num e x < sn e].
Notation new_stack e1 e2 := (stack e2 :\: stack e1).

Lemma num_lt_infty e x : num e x < infty = (x \in seen e).
Proof. by rewrite inE. Qed.

Lemma sub_stack_seen e : stack e \subset seen e.
Proof.
apply/subsetP => x; rewrite !inE => /leq_trans; apply;
by rewrite leqW// max_card.
Qed.

Section wfenv.

Variable (e : env).

Record wf_env e := WfEnv {
  serialE : serial e = sn e;
  sub_gsccs : esccs e \subset gsccs;
  max_num : forall x, num e x <= infty;
  num_lt_V_is_stack : forall x, num e x < #|V| -> num e x < sn e;
  num_sccs : forall x, (num e x == #|V|) = (x \in cover (esccs e));
  le_connect : forall x y, num e x <= num e y < sn e -> gconnect x y;
}.

Variables (e_wf : wf_env e).

Lemma num_lt_sn x : num e x < sn e = (x \in stack e).
Proof. by rewrite inE. Qed.

Lemma seen_visit x : seen (visit x e) = x |: seen e.
Proof.
apply/setP=> y; rewrite !inE ffunE/= ?serialE//; case: (altP eqP);
by rewrite //= ltnS max_card.
Qed.

Lemma sub_new_stack_seen e1 e2: new_stack e1 e2 \subset seen e2.
Proof. by rewrite (subset_trans _ (sub_stack_seen _)) ?subsetDl. Qed.

Lemma notseen_num x : x \notin seen e -> num e x = infty.
Proof. by rewrite inE ltn_neqAle max_num// andbT negbK => /eqP. Qed.

Lemma num_lt_V x : (num e x < #|V|) = (num e x < sn e).
Proof.
apply/idP/idP => [/num_lt_V_is_stack//|]; first exact.
by move=> /leq_trans; apply; rewrite max_card.
Qed.

Lemma num_lt_card x (A : pred V) : seen e \subset A ->
  (num e x < #|A|) = (num e x < sn e).
Proof.
move=> subeA; apply/idP/idP => /leq_trans.
  by rewrite -num_lt_V; apply; rewrite max_card.
by apply; rewrite subset_leq_card.
Qed.

Lemma seenE : seen e = stack e :|: cover (esccs e).
Proof.
by apply/setP=> x; rewrite !inE ltnS leq_eqVlt -num_sccs// num_lt_V orbC.
Qed.

Lemma vs_disjoint : [disjoint stack e & cover (esccs e)].
Proof.
rewrite -setI_eq0; apply/eqP/setP=> x; rewrite !inE -num_sccs//.
by rewrite -num_lt_V; case: ltngtP.
Qed.

Lemma sub_sccs_seen : cover (esccs e) \subset seen e.
Proof. by apply/subsetP => x; rewrite !inE -num_sccs// => /eqP->. Qed.

Lemma stack_visit x : x \notin seen e -> stack (visit x e) = x |: stack e.
Proof.
move=> xNseen; apply/setP=> y; rewrite !inE/= ffunE/= ?serialE// seen_visit.
have [->|neq_yx]//= := altP eqP; first by rewrite cardsU1 xNseen ltnS ?leqnn.
by rewrite num_lt_card// subsetUr.
Qed.

End wfenv.

Lemma wf_visit e x : wf_env e ->
   (forall y, num e y < sn e -> gconnect y x) ->
   x \notin seen e -> wf_env (visit x e).
Proof.
move=> e_wf x_connected xNseen.
constructor=> [||y|y|y|] //=; rewrite ?inE ?ffunE/= ?serialE//.
- by rewrite seen_visit// cardsU1 xNseen.
- exact: sub_gsccs.
- by case: ifP; rewrite ?max_num// leqW ?max_card.
- rewrite seen_visit// cardsU1 xNseen; case: ifPn => // _.
  by rewrite num_lt_V// ltnS => /ltnW.
- have [->|] := altP (y =P x); last by rewrite num_sccs.
  rewrite -num_sccs// notseen_num// eq_sym !gtn_eqF//.
  by rewrite (@leq_trans #|x |: seen e|) ?max_card// cardsU1 xNseen.
move=> y z; rewrite !ffunE/=.
have sub_visit : seen e \subset seen (visit x e).
  by apply/subsetP => ?; rewrite seen_visit// !inE orbC => ->.
have [{y}->|neq_yx] := altP eqP; have [{z}->|neq_zx]//= := altP eqP.
+ by rewrite num_lt_card//; case: ltngtP.
+ move=> /andP[/leq_ltn_trans lt/lt].
  by rewrite num_lt_card//; apply: x_connected.
+ by rewrite num_lt_card//; apply: le_connect.
Qed.

Definition subenv e1 e2 := [&&
  esccs e1 \subset esccs e2,
  [forall x, (num e1 x < infty) ==> (num e2 x == num e1 x)] &
  [forall x, (num e2 x < sn e1) ==> (num e1 x < sn e1)]].

Lemma sub_sccs e1 e2 : subenv e1 e2 -> esccs e1 \subset esccs e2.
Proof. by move=> /and3P[]. Qed.

Lemma sub_snum e1 e2 : subenv e1 e2 -> forall x, num e1 x < infty -> num e2 x = num e1 x.
Proof. by move=> /and3P[_ /forall_inP /(_ _ _) /eqP]. Qed.

Lemma sub_vnum e1 e2 : subenv e1 e2 -> forall x, num e1 x < sn e1 -> num e2 x = num e1 x.
Proof.
move=> sube12 x num_lt; rewrite (sub_snum sube12)//.
by rewrite (leq_trans num_lt)// leqW// max_card.
Qed.

Lemma sub_num_lt e1 e2 : subenv e1 e2 ->
  forall x, (num e1 x < sn e1) = (num e2 x < sn e1).
Proof.
move=> /and3P[_ /forall_inP /(_ _ _)/eqP num_eq /forall_inP] num_lt x.
have nume1_lt := num_lt x; apply/idP/idP => // {nume1_lt}nume1_lt.
by rewrite num_eq ?inE// (leq_trans nume1_lt)// leqW// max_card.
Qed.

Lemma sub_seen e1 e2 : subenv e1 e2 -> seen e1 \subset seen e2.
Proof.
move=> sube12; apply/subsetP=> x; rewrite !inE => x_seen1.
by rewrite (sub_snum sube12)// inE.
Qed.

Lemma leq_sn e1 e2 : subenv e1 e2 -> sn e1 <= sn e2.
Proof. by move=> sube12; rewrite subset_leq_card// sub_seen. Qed.

Lemma sub_stack e1 e2 : subenv e1 e2 -> stack e1 \subset stack e2.
Proof.
move=> sube12; apply/subsetP=> x; rewrite !inE => x_stack.
by rewrite (sub_vnum sube12)// (leq_trans x_stack)// leq_sn.
Qed.

Lemma new_stackE e1 e2 : subenv e1 e2 ->
  new_stack e1 e2 = [set x | sn e1 <= num e2 x < sn e2].
Proof.
move=> sube12; apply/setP=> x; rewrite !inE.
have [x_e2|] := ltnP (num e2 x) (sn e2); rewrite ?andbT ?andbF//.
have [e1_after|e1_before] /= := leqP (sn e1) (num e1 x).
  by rewrite leqNgt -sub_num_lt// -leqNgt.
by rewrite leqNgt -sub_num_lt// e1_before.
Qed.

Notation new_seen e1 e2 := (seen e2 :\: seen e1).

Lemma new_seenE e1 e2 : wf_env e1 -> wf_env e2 -> subenv e1 e2 ->
(new_seen e1 e2) = (new_stack e1 e2) :|: cover (esccs e2) :\: cover (esccs e1).
Proof.
move=> e1_wf e2_wf sube12; rewrite !seenE//; apply/setP=> x.
rewrite !inE -!num_sccs -?num_lt_V//; do 2!case: ltngtP => //=.
  by rewrite num_lt_V// (sub_num_lt sube12)// => ->; rewrite ltnNge max_card.
by move=> xe2 xe1; move: xe2; rewrite (sub_snum sube12)// ?xe1// ltnn.
Qed.

Lemma sub_new_stack_new_seen e1 e2 : subenv e1 e2 -> wf_env e1 -> wf_env e2 ->
  (new_stack e1 e2) \subset (new_seen e1 e2).
Proof. by move=> e1_wf e2_wf sube12; rewrite (@new_seenE e1 e2)// subsetUl. Qed.

Lemma sub_refl e : subenv e e.
Proof. by rewrite /subenv !subxx /=; apply/andP; split; apply/forall_inP. Qed.
Hint Resolve sub_refl.

Lemma sub_trans : transitive subenv.
Proof.
move=> e2 e1 e3 sub12 sub23; rewrite /subenv.
rewrite (subset_trans (sub_sccs sub12))// ?sub_sccs//=.
apply/andP; split; apply/forall_inP=> x xP.
  by rewrite (sub_snum sub23) ?(sub_snum sub12)//.
have x2 : num e3 x < sn e2 by rewrite (leq_trans xP)// leq_sn.
by rewrite (sub_num_lt sub12)// -(sub_vnum sub23)// (sub_num_lt sub23).
Qed.

Lemma sub_visit e x : wf_env e -> x \notin seen e -> subenv e (visit x e).
Proof.
move=> e_wf xNseen; rewrite /subenv subxx/=; apply/andP; split; last first.
  by apply/forall_inP => y; rewrite !ffunE ?serialE//=; case: ifP; rewrite ?ltnn.
apply/forall_inP => y y_in; rewrite !ffunE/=.
by case: (altP (y =P x)) xNseen => // <-; rewrite inE y_in.
Qed.

Lemma stackE e : wf_env e -> stack e = seen e :\: cover (esccs e).
Proof.
move=> e_wf; apply/setP=> x; rewrite seenE// setDUl setDv setU0.
by rewrite !inE -num_sccs// -num_lt_V//; case: ltngtP.
Qed.

Lemma seen_store (A : {set V}) e : A \subset seen e -> seen (store A e) = seen e.
Proof.
move=> A_sub; apply/setP=> x; rewrite !inE/= ffunE.
by case: ifPn => // /(subsetP A_sub); rewrite inE leqnn => ->.
Qed.

Lemma stack_store (A : {set V}) e : A \subset seen e ->
  stack (store A e) = stack e :\: A.
Proof.
move=> A_sub; apply/setP => x; rewrite !inE seen_store//= ffunE.
by case: (x \in A); rewrite //= ltnNge max_card.
Qed.

(*********************)
(* DFS specification *)
(*********************)

Definition outenv (roots : {set V}) m scc (e e' : env) := [/\
  m = val (\min_(x in nexts (~:seen e) roots) @inord #|V| (num e' x)),
  scc = new_stack e e',
  {in new_stack e e' &, gconnected},
  {in new_stack e e', forall x, exists2 y, y \in stack e & gconnect x y} &
  seen e' = seen e :|: nexts (~: seen e) roots].

Variant dfs_spec_def (dfs : nat * {set V} * env) (roots : {set V}) e :
  (nat * {set V} * env) -> nat  -> {set V} -> env -> Type := DfsSpec me' m C e' of
    me' = (m, C, e') &
    wf_env e' & subenv e e' & outenv roots m C e e' :
  dfs_spec_def dfs roots e me' m C e'.
Notation dfs_spec dfs roots e := (dfs_spec_def dfs roots e dfs dfs.1.1 dfs.1.2 dfs.2).

Definition dfs_correct dfs (roots : {set V}) e := wf_env e ->
  {in stack e & roots, gconnected} -> dfs_spec (dfs roots e) roots e.
Definition dfs1_correct dfs1 x e := wf_env e -> x \notin seen e ->
  {in stack e & [set x], gconnected} -> dfs_spec (dfs1 x e) [set x] e.

(*****************)
(* Correctness *)
(*****************)

Lemma dfsP dfs1 dfsrec (roots : {set V}) e:
  (forall x, x \in roots -> dfs1_correct dfs1 x e) ->
  (forall x, x \in roots -> forall e1, subenv e e1 ->
     dfs_correct dfsrec (roots :\ x) e1) ->
  dfs_correct (dfs dfs1 dfsrec) roots e.
Proof.
rewrite /dfs => dfs1P dfsP e_wf roots_connected.
case: pickP => /= [x x_roots|]; last first.
  move=> r0; have {r0}r_eq0 : roots = set0 by apply/setP=> x; rewrite inE.
  do ?constructor=> //=;
    rewrite ?setDv ?r_eq0 ?nexts0 ?sub0set ?eqxx ?setU0 ?big_set0 //=;
    by move=> ?; rewrite inE.
have [numx_infty|numx_ninfty]/= := altP eqP; last first.
  have numx_lt : num e x < infty by rewrite ltn_neqAle numx_ninfty max_num.
  have x_seen : x \in seen e by rewrite inE.
  case: dfsP => //= [u v ve|??? e1 -> e1_wf subee1 [-> -> new1c new1old seen1E]].
    by rewrite inE => /andP[_ v_roots]; rewrite roots_connected.
  do !constructor=> //=; rewrite ?set0U ?serialE //=.
    rewrite -[in RHS](setD1K x_roots) nextsU nexts1 inE x_seen/= setU0.
    by rewrite bigmin_setU /= big_set1/= (@sub_snum e e1)// inordK//.
  rewrite -(setD1K x_roots) nextsU nexts1 inE x_seen/=.
  by rewrite setU0 setUCA setUA [x |: _](setUidPr _) ?sub1set.
case: dfs1P => //=; first by rewrite inE numx_infty ltnn.
  by move=> u v ue; rewrite inE => /eqP->; apply: roots_connected.
move=> _ _ _ e1 -> e1_wf subee1 [-> -> new1c new1old seen1E].
case: dfsP => //= [u v ue1|_ _ _ e2 -> e2_wf sube12 [-> ->new2c new2old seen2E]].
  rewrite inE => /andP[_ v_roots].
  have [ue|uNe] := boolP (u \in stack e); first by rewrite roots_connected.
  have [|w we] := new1old u; first by rewrite inE ue1 uNe.
  by move=> /connect_trans->//; rewrite roots_connected//.
have sube2 : subenv e e2 by exact: sub_trans sube12.
have nexts_split : nexts (~: seen e) roots =
      nexts (~: seen e) [set x] :|: nexts (~: seen e1) (roots :\ x).
  by rewrite -[in LHS](setD1K x_roots) nextsU seen1E setCU nextsUI// nexts_id.
do 2!constructor=> //=.
- rewrite (eq_bigr (fun x => inord (num e2 x))); last first.
    move=> y y_in; rewrite (@sub_snum e1 e2)// num_lt_infty.
      by rewrite seen1E setUC inE y_in.
  by rewrite -[LHS]/(val (ord_minn _ _)) -bigmin_setU /= -nexts_split.
- by rewrite setUC setUD ?sub_stack.
- rewrite -(@setUD _ (stack e1)) ?sub_stack//.
  apply: connectedU => // y z; last first.
    rewrite !new_stackE// ?inE => /andP[y_ge y_lt] /andP[z_ge z_lt].
    rewrite (@le_connect e2) // z_lt (leq_trans _ z_ge)//.
    by rewrite (sub_vnum sube12)// ltnW.
  rewrite !new_stackE// ?inE => /andP[y_ge y_lt] /andP[z_ge z_lt].
  have [|r] := new2old y; rewrite ?new_stackE ?inE ?y_ge//.
  move=> r_lt /connect_trans->//; have [rz|zr] := leqP (num e1 r) (num e1 z).
    by rewrite (@le_connect e1)// rz/=.
  by rewrite new1c ?new_stackE ?inE ?z_ge ?z_lt //= (leq_trans z_ge)// ltnW.
- move=> y; rewrite ?new_stackE ?inE// => /andP[y_ge y_lt].
  have [y_lt1|y_ge1] := ltnP (num e1 y) (sn e1).
    have [|r] := new1old y; last by exists r.
    by rewrite new_stackE ?inE// ?y_lt1 -(sub_vnum sube12) ?y_ge.
  have [|r r_lt1 yr] := new2old y; first by rewrite !inE -leqNgt y_ge1//.
  rewrite ?inE in r_lt1; have [r_lt|r_ge] := ltnP (num e r) (sn e).
    by exists r; rewrite ?inE.
  have [|r' r's rr'] := new1old r; first by rewrite ?inE -leqNgt r_ge r_lt1.
  by exists r'; rewrite // (connect_trans yr rr').
- by rewrite seen2E {1}seen1E nexts_split setUA.
Qed.

Lemma dfs1P dfs x e (A := [set y in successors x]):
  dfs_correct dfs A (visit x e) -> dfs1_correct (dfs1 dfs) x e.
Proof.
rewrite /dfs1 => dfsP e_wf xNseen x_connected.
have subexe: subenv e (visit x e) by exact: sub_visit.
have num0x : num e x = infty by apply: notseen_num.
have xNstack : x \notin stack e.
  by rewrite inE num0x ltnNge leqW// max_card.
have xe_wf : wf_env (visit x e).
  by apply: wf_visit => // y y_lt; rewrite x_connected ?inE.
have nexts1E : nexts (~: seen e) [set x] = x |: nexts (~: (x |: seen e)) A.
  by rewrite nexts1_split ?setDE ?setCU 1?setIC 1?inE.
case: dfsP => //=.
  rewrite stack_visit// => u v; rewrite in_setU1=> /predU1P[->|ue];
  rewrite inE => /(@connect1 _ edge)// /(connect_trans _)->//.
  by rewrite x_connected// set11.
move=> _ _ _ e1 -> e1_wf subxe1 [/= -> -> newc new_old seen1E].
have sube1 : subenv e e1 by apply: sub_trans subxe1.
have num1x : num e1 x = sn e.
  by rewrite (sub_snum subxe1)// ?inE ?ffunE ?serialE/= ?eqxx// ltnS max_card.
rewrite ?seen_visit ?serialE// in seen1E *.
have lt_sn_sn1 : sn e < sn e1.
  by rewrite (leq_trans _ (leq_sn subxe1))// seen_visit// cardsU1 xNseen.
have x_seen1 : x \in seen e1 by rewrite seen1E inE setU11.
have x_stack : x \in stack e1.
  by rewrite (subsetP (sub_stack subxe1))//= stack_visit// setU11.
have -> : (x |: new_stack (visit x e) e1) = new_stack e e1.
  by rewrite stack_visit// [_ |: stack e]setUC -setDDl setD1K// inE xNstack.
have [min_after|min_before] := leqP; last first.
  do 2!constructor => //=.
  - rewrite nexts1E bigmin_setU big_set1 /= inordK ?num1x ?ltnS ?max_card//.
    by rewrite (minn_idPr _)// ltnW.
  - move=> y z; have [-> _|neq_yx] := eqVneq y x.
      by rewrite new_stackE ?inE// -num1x; apply: le_connect.
    rewrite -(@setUD _ (stack (visit x e))) ?sub_stack//.
    rewrite [in X in _ :|: X]stack_visit// setDUl setDv setU0.
    rewrite [_ :\: stack e](setDidPl _) ?disjoint1s//.
    rewrite setUC !in_setU1 (negPf neq_yx)/=.
    move=> y_e1 /predU1P[->|]; last exact: newc y_e1.
    have [t] := new_old y y_e1; rewrite !inE => t_le /connect_trans->//.
    rewrite (@le_connect (visit x e))// andbC; move: t_le.
    rewrite seen_visit// !ffunE ?serialE//=.
    by rewrite eqxx cardsU1 xNseen add1n !ltnS leqnn.
  - move=> y; have [v ve xv] : exists2 v, v \in stack e & gconnect x v.
    have [|v] := @eq_bigmin_cond _ _ (mem (nexts (~: (x |: seen e)) A))
                               (@inord #|V| \o (num e1)).
      rewrite card_gt0; apply: contraTneq min_before => ->.
      by rewrite big_set0 -leqNgt max_card.
    rewrite !inE => v_in min_is_v; move: min_before; rewrite min_is_v/=.
    rewrite inordK; last by rewrite num_lt_infty seen1E inE v_in orbT.
    rewrite -sub_num_lt// => v_lt; exists v; rewrite ?inE//.
    move: v_in => /in_nextsW[z]; rewrite inE => /(@connect1 _ edge).
    by apply: connect_trans.
  - rewrite -(@setUD _ (stack (visit x e))) ?sub_stack//.
    rewrite [in X in _ :|: X]stack_visit// setDUl setDv setU0.
    rewrite [_ :\: stack e](setDidPl _) ?disjoint1s// setUC !in_setU1.
    move=> /predU1P[->|]; first by exists v.
    move=> /new_old[z]; rewrite stack_visit// in_setU1.
    move=> /predU1P[->|]; last by exists z.
    by move=> yx; exists v; rewrite // (connect_trans yx).
  - by rewrite nexts1E setUCA setUA seen1E.
have all_geq y : y \in nexts (~: seen e) [set x] ->
  (#|seen e| <= num e1 y) * (num e1 y < infty).
  have := min_after; have sn_inord : sn e = @inord #|V| (sn e).
    by rewrite inordK// ltnS max_card.
  rewrite {1}sn_inord; move/bigmin_geqP => /(_ y) y_ge.
  rewrite nexts1E !inE => /predU1P[->|yA]; rewrite ?num1x.
    by rewrite ltnS max_card leqnn.
  rewrite sn_inord (leq_trans (y_ge _))// ?inordK//;
  by rewrite num_lt_infty seen1E 2!inE yA orbT.
constructor=> //=.
- constructor=> //=; rewrite ?serialE ?seen_store ?sub_new_stack_seen//.
  + rewrite subUset sub_gsccs// andbT sub1set.
    suff -> : new_stack e e1 = gscc_of x by rewrite pblock_mem ?cover_sccs.
    apply/setP=> y; rewrite mem_scc /symconnect.
    have [->|neq_yx] := eqVneq y x.
      by rewrite connect0 !inE num0x -leqNgt leqW ?max_card//= num1x lt_sn_sn1.
    apply/idP/andP=> [|[xy yx]].
      move=> y_ee1; have y_xee1 : y \in new_stack (visit x e) e1.
        by rewrite inE stack_visit// in_setU1 (negPf neq_yx)/= -in_setD.
      split; last first.
        have [z] := new_old _ y_xee1.
        rewrite stack_visit// in_setU1 => /predU1P[->//|/x_connected].
        by move=> /(_ _ (set11 x))/(connect_trans _) xz /xz.
      have: y \in new_seen (visit x e) e1.
        by apply: subsetP y_xee1; rewrite sub_new_stack_new_seen.
      rewrite inE seen1E in_setU seen_visit//; case: (y \in _ |: _) => //=.
      move=> /in_nextsW[z]; rewrite inE=> /(@connect1 _ edge).
      exact: connect_trans.
    have /(connect_from (mem (~: seen e))) [z []] := xy; rewrite inE.
    move=> eq_yz xz zy; have /all_geq [] : z \in nexts (~: seen e) [set x].
      by apply/bigcupP; exists x; rewrite !inE.
    rewrite leqNgt -sub_num_lt// -num_lt_V// -leqNgt ltnS => zNstack.
    have zNcover e' : wf_env e' -> z \in cover (esccs e') ->
                      x \in cover (esccs e').
      move=> e'_wf /bigcupP[C] Ce zC; apply/bigcupP; exists C => //.
      have /def_scc: C \in gsccs by apply: subsetP Ce; apply: sub_gsccs.
      move=> /(_ _ zC)<-; rewrite mem_scc /= /symconnect (connect_trans zy)//=.
      by apply: connect_sub xz => ?? /andP[_ /connect1].
    rewrite leq_eqVlt num_sccs// num_lt_V// => /orP[|z_stack].
       move=> /zNcover; rewrite -num_sccs// num1x => /(_ _) /eqP eq_V.
       by rewrite eq_V// ltnNge max_card in lt_sn_sn1.
    have zNseen : z \notin seen e.
      rewrite inE -leqNgt ltn_neqAle eq_sym num_sccs// zNstack andbT.
      apply: contraTN isT => /(zNcover _ e_wf).
      by rewrite -num_sccs// num0x; elim: #|V|.
    move: eq_yz; rewrite zNseen /= => /andP[/eqP eq_yz _].
    rewrite -eq_yz in zNstack z_stack.
    by rewrite !inE -num_lt_V// -leqNgt zNstack.
  + by move=> v; rewrite ffunE/=; case: ifP; rewrite ?max_num //.
  + move=> v; rewrite ffunE/=; case: ifPn; rewrite ?ltnn// => vNe12.
    by rewrite num_lt_V// seen_store.
  + move=> v; rewrite ffunE /= cover1U [in RHS]inE.
    by case: ifPn; rewrite ?eqxx//= => vNe12; rewrite -num_sccs//.
  + move=> y z; rewrite !ffunE; case: ifPn => _.
      by move=> /andP[/leq_ltn_trans Vsmall/Vsmall]; rewrite ltnNge max_card.
    by case: ifPn => _; [by rewrite ltnNge max_card andbF|exact : le_connect].
- rewrite /subenv /= (subset_trans (sub_sccs sube1)) ?subsetUr//=.
  apply/andP; split; apply/forallP => v; apply/implyP;
  rewrite ffunE/= new_stackE// ?inE.
    move=> vs; rewrite (sub_snum sube1)// leqNgt -!num_lt_V// -leqNgt ifN//.
    by apply/negP => /andP[/leq_ltn_trans Vlt/Vlt]; rewrite ltnNge max_card.
  by case: ifPn; [move=> _; rewrite ltnNge max_card|rewrite -sub_num_lt].
- rewrite /outenv stack_store ?seen_store ?sub_new_stack_seen//.
  rewrite setDDr setDUl setDv set0D set0U setDIl !setDv setI0.
  split; do ?by [move=> ?; rewrite ?inE//=|]; last first.
    by rewrite seen1E -setUA setUCA -nexts1E.
  rewrite big1// => y xy; rewrite ffunE new_stackE ?inE//=.
  have y_seen1 : num e1 y < infty.
    by rewrite num_lt_infty seen1E -setUA setUCA -nexts1E inE xy orbT.
  apply/val_inj=> /=; case: ifPn; rewrite ?inordK//.
  rewrite all_geq//= -num_lt_V// -leqNgt; move: y_seen1; rewrite ltnS.
  by case: ltngtP.
Qed.

Theorem tarjan_rec_terminates n (roots : {set V}) e :
  n >= #|~: seen e| * #|V|.+1 + #|roots| ->
  dfs_correct (tarjan_rec n) roots e.
Proof.
move=> n_ge; elim: n => [|n IHn/=] in roots e n_ge *.
  move: n_ge; rewrite leqn0 addn_eq0 cards_eq0 => /andP[_ /eqP-> e_wf _]/=.
  constructor=> //=; rewrite /outenv ?nexts0 ?setDv ?big_set0// ?setU0.
  by split=> // ?; rewrite inE.
apply: dfsP=> x x_roots; last first.
  move=> e1 subee1; apply: IHn; rewrite -ltnS (leq_trans _ n_ge)//.
  rewrite (cardsD1 x roots) x_roots add1n -addSnnS ltn_add2r ltnS.
  by rewrite leq_mul2r //= subset_leq_card// setCS sub_seen.
move=> e_wf xNseen; apply: dfs1P => //; apply: IHn.
rewrite seen_visit// setCU setIC -setDE -ltnS (leq_trans _ n_ge)//.
rewrite (cardsD1 x (~: _)) inE xNseen add1n mulSnr -addnA ltn_add2l.
by rewrite ltn_addr// ltnS max_card.
Qed.

Lemma seen0 : seen e0 = set0.
Proof. by apply/setP=> y; rewrite !inE ffunE ltnn. Qed.

Lemma stack0 : stack e0 = set0.
Proof. by apply/setP=> y; rewrite !inE ffunE ltnNge leqW ?max_card. Qed.

Lemma tarjan_recP :
   tarjan_rec N setT e0 = (#|V|, set0, Env gsccs #|V| [ffun x => #|V|]).
Proof.
case: tarjan_rec_terminates; first by rewrite seen0 setC0 cardsT.
- constructor; rewrite /= ?serialE ?seen0 ?cards0 ?sub0set// => x; rewrite !ffunE//.
  + by rewrite ltnNge leqW//.
  + by rewrite gtn_eqF// /cover big_set0 inE.
  + by move=> y; rewrite !ffunE//= andbC ltnNge leqW// ?max_card.
  + by move=> y; rewrite !inE !ffunE/= ltnNge leqW// max_card.
move=> _ _ _ e -> e_wf _ [-> -> _]; rewrite stack0 setD0.
have [stacke _|[x xe]] := set_0Vmem (stack e); last first.
  by move=> /(_ _ xe)[?]; rewrite inE.
rewrite seen0 set0U setC0 nextsT => seene.
have numE x : num e x = #|V|.
  apply/eqP; have /setP/(_ x) := seene.
  by rewrite seenE// stacke set0U !inE -num_sccs.
have serialE : serial e = #|V| by rewrite serialE// seene cardsT.
have sccse : esccs e = gsccs.
  apply/eqP; rewrite eqEsubset sub_gsccs//=; apply/subsetP => _/imsetP[/=x _->].
  have: x \in cover (esccs e) by rewrite -num_sccs ?numE//.
  move=> /bigcupP [C Csccs /(def_scc (subsetP (sub_gsccs e_wf) _ Csccs))] eqC.
  rewrite -eqC (_ : [set _ in _ | _] = gscc_of x)// in Csccs *.
  by apply/setP => y; rewrite !inE mem_scc /=.
rewrite big1; last by move=> x _; apply: val_inj; rewrite /= inordK// ?numE.
congr (_, _, _) => //.
case: e {stacke seene e_wf} => /= sccs sn num in numE serialE sccse *.
by congr (Env _ _) => //; apply/ffunP=> x; rewrite ffunE.
Qed.

Theorem tarjan_correct : tarjan = gsccs.
Proof. by rewrite /tarjan; have [->] := tarjan_recP. Qed.

End tarjan.


Require Import Reals.
From ValidSDP Require Import validsdp posdef_check.
Require matrices.
Local Open Scope R_scope.

Test Default Proof Mode.
Require Import Ltac2.Ltac2. (* TODO: this will later be unnecessary *)
Test Default Proof Mode.
(* Set Default Proof Mode "Ltac2". (implied) *)

(* To enable debug mode: *)
(* Ltac2 Set deb := fun str => Message.print str. *)

Section Tests.

Let test1 x y : 0 < x -> 1 <= y -> x + y >= 0.
Proof.
Time validsdp.
Qed.

Let test2 x y : 2 / 3 * x ^ 2 + y ^ 2 >= 0.
Proof.
Time validsdp.
Qed.

Let test3 x y : 2 / 3 * x ^ 2 + y ^ 2 + 1 > 0.
Proof.
Time validsdp.
Qed.

Let p x y := 2 / 3 * x ^ 2 + y ^ 2.

Let test4 x y : p x y + 1 > 0.
Proof.
Time validsdp.
Qed.

Let test6 x : x >= 10 -> x <= 12 -> 0 <= 2 + x ^ 2.
Proof.
validsdp.
Qed.

End Tests.


From FA Require Import String.
From mathcomp Require Import all_ssreflect.

Record dfa: Type :=
    mkdfa
    {
       dfa_state     :> finType;
       dfa_start     : dfa_state;
       dfa_transition: dfa_state -> Sigma -> dfa_state;
       dfa_finals    : {set dfa_state}
    }.

Fixpoint dfa_multistep (d: dfa) (q: dfa_state d) (s: String): dfa_state d :=
  match s with
    | eps      => q
    | glue x y => dfa_transition d (dfa_multistep d q x) y
  end.

Lemma dfa_ms_ss: forall (d: dfa) (s: d) (c: Sigma),
  dfa_transition d s c = dfa_multistep d s (glue eps c).
Proof. intros. simpl. easy. Qed.

Definition dfa_acceptance (d: dfa) (st: @dfa_state d) (s: String): bool :=
  [exists y, (y == (dfa_multistep d st s)) && (y \in (@dfa_finals d))].

Definition dfa_language (d: dfa) := [pred w | dfa_acceptance d (@dfa_start d) w].


Require Import Arith.
Require Import Program.
Require Import Omega.
Parameters (var: Set)
           (sig: nat -> Set).

Axiom var_eq_dec: forall v1 v2: var, { v1 = v2 } + { v1 <> v2 }.

Inductive ilist (A: Set) : nat -> Set :=
| niln: ilist A 0
| consn: forall n, A -> ilist A n -> ilist A (S n)
.

Inductive fin : nat -> Set :=
| f0: fin 1
| fs: forall n, fin n -> fin (S n)
.

Definition dlist n (P: fin n -> Set): Set := forall (i: fin n), P i.

Fixpoint fin_to_nat n (m: fin n): nat.
  destruct m _eqn: Heq.
  exact 0.
  apply S.
  apply (fin_to_nat n f).
Defined.

Variable axiom: Set.

Inductive term: Set :=
  | tm_var: var -> term
  | tm_cong: forall n (s: sig n), (fin n -> term) -> term
.

Inductive deriv: term -> term -> Set :=
| drv_refl: forall s, deriv s s
| drv_sym: forall s t, deriv s t -> deriv t s
| drv_trans: forall s t u, deriv s t -> deriv t u -> deriv s u
| drv_cong: forall n (s: sig n) (ss ts: fin n -> term), dlist n (fun x => deriv (ss x) (ts x)) -> deriv (tm_cong n s ss) (tm_cong n s ts).

(* example: refl *)
Goal forall s, deriv s s.
      apply drv_refl.
Qed.

Fixpoint subst (s: term) (u: term) (x: var): term :=
  match s with
  | tm_var v =>
    if var_eq_dec v x then u else tm_var v
  | tm_cong n si t =>
    tm_cong n si (fun i : fin n => subst (t i) u x)
  end.

Section monoid_theory.
  Axiom mul_sig: sig 2.
  Definition mul: term -> term -> term :=
    fun a b : term =>
tm_cong 2 mul_sig
   (fun i0 : fin 2 =>
    match
      i0 in (fin n0) return (forall i1 : fin n0, i1 = i0 -> term)
    with
    | f0 => fun (i1 : fin 1) (_ : i1 = f0) => a
    | fs n0 f1 => fun (i1 : fin (S n0)) (_ : i1 = fs n0 f1) => b
    end i0 eq_refl).
  Print mul.
  Axiom e_sig: sig 0.
  Definition e: term.
                  apply (tm_cong 0 e_sig).
                  intro i.
                  inversion i.
  Defined.
  Axiom unit_law_l: forall s, deriv (mul e s) s.
  Axiom unit_law_r: forall s, deriv (mul s e) s.

  Theorem mul_well_defined: forall s1 s2 t1 t2, deriv s1 t1 -> deriv s2 t2 -> deriv (mul s1 s2) (mul t1 t2).
                                                  intros s1 s2 t1 t2 H H0.
                                                  apply drv_cong.
                                                  intro i.
                                                  destruct i _eqn:ieq.
                                                  exact H.
                                                  exact H0.
                                                  Qed.
End monoid_theory.

Section subst_closed.

End subst_closed.


From mathcomp.ssreflect
Require Import ssreflect ssrbool.

Set Implicit Arguments.

(* Example 4 from "Unifiers as Equivalences" *)

Inductive Im (A B : Type) (f : A -> B) (y : B) : Type :=
  image x of y = f x.

(* when would we need the following lemma?  Perhaps if the above image proofs are used inside the encoding of a different relation? *)
Lemma im_prop : forall (A B : Type) (f : A -> B) (x x' : A) (e : f x = f x'), eq_rect (f x) (fun y => Im f y) (image f x eq_refl) (f x') e = image f x' eq_refl -> x = x'.
Proof.
  move=> A B f x x' e eqims.
  (* cannot use e, cannot use eqims...*)
Admitted.


(**
Here we define the category of setoids.
The objects are setoids and the morphisms are setoid mophisms.
We also show it has sums, products, and exponentials.
We end by showing that the quotient from setoids to set is a left adjoint.
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.Combinatorics.FiniteSets.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences.
Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.exponentials.
Require Import UniMath.CategoryTheory.Adjunctions.Core.

Require Import setoids.base.

Open Scope cat.

(** The category of setoids *)
Definition setoid_cat_ob_mor
  : precategory_ob_mor.
Proof.
  use make_precategory_ob_mor.
  - exact setoid.
  - exact setoid_morphism.
Defined.

Definition id_setoid_morphism (X : setoid)
  : setoid_morphism X X.
Proof.
  use make_setoid_morphism.
  - exact (idfun X).
  - exact (λ x y, idfun (x ≡ y)).
Defined.

Definition comp_setoid_morphism
           {X₁ X₂ X₃ : setoid}
           (f₁ : setoid_morphism X₁ X₂)
           (f₂ : setoid_morphism X₂ X₃)
  : setoid_morphism X₁ X₃.
Proof.
  use make_setoid_morphism.
  - exact (λ z, f₂(f₁ z)).
  - exact (λ x y p, map_eq f₂(map_eq f₁ p)).
Defined.

Definition setoid_cat_data
  : precategory_data.
Proof.
  use make_precategory_data.
  - exact setoid_cat_ob_mor.
  - exact id_setoid_morphism.
  - exact @comp_setoid_morphism.
Defined.

Definition setoid_precat
  : precategory.
Proof.
  use make_precategory.
  - exact setoid_cat_data.
  - repeat (use tpair) ; cbn.
    + reflexivity.
    + reflexivity.
    + reflexivity.
    + reflexivity.
Defined.

Definition setoid_cat
  : category.
Proof.
  use make_category.
  - exact setoid_precat.
  - intros X₁ X₂ ; cbn.
    apply isaset_setoid_morphism.
Defined.

(** Sums in the category of setoids *)
Definition sum_rel
           {X Y : hSet}
           (R₁ : eqrel X)
           (R₂ : eqrel Y)
  : eqrel (setcoprod X Y)%set.
Proof.
  use make_eq_rel.
  - intros s₁ s₂.
    destruct s₁ as [x₁ | y₁], s₂ as [x₂ | y₂].
    + exact (R₁ x₁ x₂).
    + exact hfalse.
    + exact hfalse.
    + exact (R₂ y₁ y₂).
  - intros s.
    destruct s as [x | y].
    + exact (id x)%setoid.
    + exact (id y)%setoid.
  - intros s₁ s₂.
    destruct s₁ as [x₁ | y₁], s₂ as [x₂ | y₂].
    + exact (λ p , ! p)%setoid.
    + exact (idfun _).
    + exact (idfun _).
    + exact (λ p , ! p)%setoid.
  - intros s₁ s₂ s₃.
    destruct s₁ as [x₁ | y₁], s₂ as [x₂ | y₂].
    + destruct s₃ as [x₃ | y₃].
      * exact (λ p q , p @ q)%setoid.
      * exact (λ _, fromempty).
    + exact fromempty.
    + exact fromempty.
    + destruct s₃ as [x₃ | y₃].
      * exact (λ _, fromempty).
      * exact (λ p q , p @ q)%setoid.
Defined.

Definition sum_setoid (X Y : setoid_cat)
  : setoid_cat
  := make_setoid (sum_rel (carrier_eq X) (carrier_eq Y)).

Definition setoid_inl
           (X₁ X₂ : setoid_cat)
  : X₁ --> sum_setoid X₁ X₂.
Proof.
  use make_setoid_morphism.
  - exact (λ x, inl x).
  - exact (λ _ _ p, p).
Defined.

Definition setoid_inr
           (X₁ X₂ : setoid_cat)
  : X₂ --> sum_setoid X₁ X₂.
Proof.
  use make_setoid_morphism.
  - exact (λ x, inr x).
  - exact (λ _ _ p, p).
Defined.

Definition setoid_plus
           {X₁ X₂ Y : setoid_cat}
           (f : X₁ --> Y)
           (g : X₂ --> Y)
  : sum_setoid X₁ X₂ --> Y.
Proof.
  unshelve esplit.
  - intro z.
    destruct z as [x | x] ; cbn in *.
    + exact (f x).
    + exact (g x).
  - intros z₁ z₂ p.
    destruct z₁ as [x₁ | x₁ ], z₂ as [x₂ | x₂].
    + exact (map_eq f p).
    + exact (fromempty p).
    + exact (fromempty p).
    + exact (map_eq g p).
Defined.

Definition sum_setoid_is_bincoproduct
           (X₁ X₂ : setoid_cat)
  : isBinCoproduct
      setoid_cat X₁ X₂
      (sum_setoid X₁ X₂) (setoid_inl X₁ X₂) (setoid_inr X₁ X₂).
Proof.
  intros Y f g ; cbn.
  use tpair.
  - use tpair.
    + exact (setoid_plus f g).
    + split ; reflexivity.
  - intros h.
    use subtypePath.
    + intro.
      apply isapropdirprod ; apply setoid_cat.
    + use setoid_morphism_eq ; cbn.
      intro z.
      destruct z as [x | x].
      * induction (pr12 h).
        reflexivity.
      * induction (pr22 h).
        reflexivity.
Defined.

Definition setoid_cat_bincoproducts
  : BinCoproducts setoid_cat.
Proof.
  intros X₁ X₂.
  use tpair.
  - exact (sum_setoid X₁ X₂ ,, setoid_inl X₁ X₂ ,, setoid_inr X₁ X₂).
  - exact (sum_setoid_is_bincoproduct X₁ X₂).
Defined.

(** The category of setoids has binary products *)
Definition prod_rel
           {X Y : hSet}
           (R₁ : eqrel X)
           (R₂ : eqrel Y)
  : eqrel (X × Y)%set.
Proof.
  use make_eq_rel.
  - exact (λ z₁ z₂, (hconj (R₁ (pr1 z₁) (pr1 z₂)) (R₂ (pr2 z₁) (pr2 z₂)))).
  - exact (λ z, (id (pr1 z) ,, id (pr2 z)))%setoid.
  - exact (λ _ _ p, (! (pr1 p) ,, ! (pr2 p)))%setoid.
  - exact (λ _ _ _ p q, ((pr1 p @ pr1 q) ,, (pr2 p @ pr2 q)))%setoid.
Defined.

Definition prod_setoid (X Y : setoid_cat)
  : setoid_cat
  := make_setoid (prod_rel (carrier_eq X) (carrier_eq Y)).

Definition setoid_pr1
           (X₁ X₂ : setoid_cat)
  : prod_setoid X₁ X₂ --> X₁.
Proof.
  use make_setoid_morphism.
  - exact (λ z ,  pr1 z).
  - exact (λ _ _, pr1).
Defined.

Definition setoid_pr2
           (X₁ X₂ : setoid_cat)
  : prod_setoid X₁ X₂ --> X₂.
Proof.
  use make_setoid_morphism.
  - exact (λ z ,  pr2 z).
  - exact (λ _ _, pr2).
Defined.

Definition setoid_pair
           {X₁ X₂ Y : setoid_cat}
           (f : Y --> X₁)
           (g : Y --> X₂)
  : Y --> prod_setoid X₁ X₂.
Proof.
  use make_setoid_morphism ; cbn in *.
  - exact (λ y, (f y ,, g y)).
  - exact (λ _ _ p, (map_eq f p ,, map_eq g p)).
Defined.

Definition prod_setoid_is_binproduct
           (X₁ X₂ : setoid_cat)
  : isBinProduct
      setoid_cat X₁ X₂
      (prod_setoid X₁ X₂) (setoid_pr1 X₁ X₂) (setoid_pr2 X₁ X₂).
Proof.
  intros Y f g ; cbn.
  use tpair.
  - use tpair.
    + exact (setoid_pair f g).
    + split ; reflexivity.
  - intros h.
    use subtypePath.
    + intro.
      apply isapropdirprod ; apply setoid_cat.
    + use setoid_morphism_eq ; cbn.
      intro z.
      use dirprod_paths.
      * induction (pr12 h).
        reflexivity.
      * induction (pr22 h).
        reflexivity.
Defined.

Definition setoid_cat_binproducts
  : BinProducts setoid_cat.
Proof.
  intros X₁ X₂.
  use tpair.
  - exact (prod_setoid X₁ X₂ ,, setoid_pr1 X₁ X₂ ,, setoid_pr2 X₁ X₂).
  - exact (prod_setoid_is_binproduct X₁ X₂).
Defined.

(** Exponentials of setoids *)
Definition setoid_morphism_hSet (X₁ X₂ : setoid)
  : hSet.
Proof.
  use make_hSet.
  - exact (setoid_morphism X₁ X₂).
  - apply isaset_setoid_morphism.
Defined.

Definition fun_rel
           (X₁ X₂ : setoid)
  : eqrel (setoid_morphism_hSet X₁ X₂).
Proof.
  use make_eq_rel.
  - intros f g ; cbn in *.
    exact (∀ (x : X₁), f x ≡ g x).
  - exact (λ f x, id _ _)%setoid.
  - exact (λ f g p x, ! (p x))%setoid.
  - exact (λ f g h p₁ p₂ x, p₁ x @ p₂ x)%setoid.
Defined.

Definition setoid_exp
           (X₁ X₂ : setoid_cat)
  : setoid_cat
  := make_setoid (fun_rel X₁ X₂).

Definition setoid_exp_functor_data
           (X : setoid)
  : functor_data setoid_cat setoid_cat.
Proof.
  use make_functor_data.
  - exact (setoid_exp X).
  - intros Y₁ Y₂ f ; cbn in *.
    use make_setoid_morphism ; cbn.
    + exact (λ g, comp_setoid_morphism g f).
    + exact (λ g₁ g₂ p x, map_eq f (p x)).
Defined.

Definition setoid_exp_functor
           (X : setoid)
  : setoid_cat ⟶ setoid_cat.
Proof.
  use make_functor.
  - exact (setoid_exp_functor_data X).
  - split.
    + intros Y.
      use setoid_morphism_eq.
      reflexivity.
    + intros Y₁ Y₂ Y₃ f₁ f₂.
      use setoid_morphism_eq.
      reflexivity.
Defined.

Definition setoid_exp_unit
           (X : setoid)
  : (functor_identity setoid_precat)
      ⟹
      constprod_functor1 setoid_cat_binproducts X ∙ setoid_exp_functor X.
Proof.
  use make_nat_trans.
  - intros Y.
    use make_setoid_morphism.
    + intros y.
      use make_setoid_morphism.
      * exact (λ x, x ,, y).
      * exact (λ x₁ x₂ p , p ,, id _ _)%setoid.
    + exact (λ y₁ y₂ p x , id _ _ ,, p)%setoid.
  - intros Y₁ Y₂ f.
    abstract (
        use setoid_morphism_eq ;
        intro y ;
        use setoid_morphism_eq ;
        reflexivity).
Defined.

Definition setoid_exp_counit
           (X : setoid)
  : (setoid_exp_functor X ∙ constprod_functor1 setoid_cat_binproducts X)
      ⟹
      functor_identity setoid_precat.
Proof.
  use make_nat_trans.
  - intros Y.
    use make_setoid_morphism.
    + intro z ; cbn in *.
      exact (pr2 z (pr1 z)).
    + intros z₁ z₂ p ; cbn in *.
      exact (map_eq (pr2 z₁) (pr1 p) @ pr2 p (pr1 z₂))%setoid.
  - intros Y₁ Y₂ f.
    use setoid_morphism_eq.
    reflexivity.
Defined.

Definition setoid_cat_has_exponentials
  : Exponentials setoid_cat_binproducts.
Proof.
  intro X.
  use tpair.
  - exact (setoid_exp_functor X).
  - use make_are_adjoints.
    + exact (setoid_exp_unit X).
    + exact (setoid_exp_counit X).
    + split.
      * abstract(
            intros Y ;
            use setoid_morphism_eq ;
            reflexivity).
      * abstract
          (intros Y ;
           use setoid_morphism_eq ;
           intro ;
           use setoid_morphism_eq ;
           reflexivity).
Defined.

(** Functor from set to setoid *)
Definition path_rel
           (X : hSet)
  : eqrel X
  := make_eq_rel
       (λ x y, eqset x y)
       idpath
       (λ _ _ p, ! p)
       (λ _ _ _ p q, p @ q).

Definition path_setoid_data : functor_data SET setoid_cat.
Proof.
  use make_functor_data.
  - exact (λ X, make_setoid (path_rel X)).
  - intros X Y f.
    use make_setoid_morphism.
    + exact f.
    + exact (λ x y p, maponpaths f p).
Defined.

Definition path_setoid : SET ⟶ setoid_cat.
Proof.
  use make_functor.
  - exact path_setoid_data.
  - split.
    + intros X ; cbn.
      use setoid_morphism_eq.
      reflexivity.
    + intros X Y Z f g ; cbn.
      use setoid_morphism_eq.
      reflexivity.
Defined.

(** Functor fom setoid to set *)
Definition quotient_setoid_ob
           (X : setoid)
  : hSet.
Proof.
  use setquotinset.
  - exact X.
  - exact (carrier_eq X).
Defined.

Definition quotient_setoid_mor
           {X₁ X₂ : setoid}
           (f : setoid_morphism X₁ X₂)
  : quotient_setoid_ob X₁ → quotient_setoid_ob X₂.
Proof.
  use setquotuniv ; cbn.
  - exact (λ x, setquotpr _ (f x)).
  - exact (λ x y p, iscompsetquotpr _ (f x) (f y) (map_eq f p)).
Defined.

Definition quotient
  : setoid_cat ⟶ SET.
Proof.
  use make_functor.
  - use make_functor_data.
    + exact quotient_setoid_ob.
    + exact @quotient_setoid_mor.
  - split.
    + intros X ; cbn.
      use funextsec ; intro x.
      use (setquotunivprop' (λ z, _ z = z)).
      * intro.
        apply isasetsetquot.
      * intro y ; cbn.
        reflexivity.
    + intros X Y Z f g ; cbn.
      use funextsec ; intro x.
      use (setquotunivprop' (λ z, _ z = quotient_setoid_mor g (quotient_setoid_mor f z))).
      * intro.
        apply isasetsetquot.
      * intro y ; cbn.
        reflexivity.
Defined.

Definition quotient_unit
  : functor_identity setoid_cat ⟹ quotient ∙ path_setoid.
Proof.
  use make_nat_trans.
  - intro X ; cbn.
    use make_setoid_morphism.
    + exact (setquotpr _).
    + exact (iscompsetquotpr _).
  - abstract
      (intros X Y f ; cbn ;
       use setoid_morphism_eq ;
       intro x ;
       reflexivity).
Defined.

Definition quotient_counit
  : path_setoid ∙ quotient ⟹ functor_identity SET.
Proof.
  use make_nat_trans.
  - intro X ; cbn.
    use setquotuniv.
    + exact (idfun _).
    + exact (λ x y p, p).
  - abstract
      (intros X Y f ;
       use funextsec ;
       intro x ;
       revert x ;
       use setquotunivprop' ;
       [ intro ; apply Y | reflexivity ]).
Defined.

Definition quotient_counit_is_inverse
           (X : SET)
  : is_inverse_in_precat (quotient_counit X) (setquotpr (carrier_eq (path_setoid X))).
Proof.
  split.
  - use funextsec.
    use setquotunivprop'.
    { intro. apply isasetsetquot. }
    reflexivity.
  - use funextsec.
    intro.
    reflexivity.
Qed.

Definition quotient_counit_is_nat_iso
  : is_nat_iso quotient_counit.
Proof.
  intros X.
  use is_iso_qinv.
  - exact (setquotpr _).
  - exact (quotient_counit_is_inverse X).
Defined.

(** The quotient is a left adjoint *)
Definition quotient_adjunction
  : adjunction setoid_cat SET.
Proof.
  simple refine ((quotient ,, (path_setoid ,, (_ ,, _))) ,, _).
  - exact quotient_unit.
  - exact quotient_counit.
  - split.
    + abstract
        (intro X ;
         use funextsec ;
         intro x ; revert x ; cbn ;
         use setquotunivprop' ;
         [ intro ; apply isasetsetquot | reflexivity ]).
    + abstract
        (intro X ;
         use setoid_morphism_eq ;
         intro x ; cbn in * ;
         reflexivity).
Defined.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (lf2 : natural) (z : natural) (x : natural)
  : natural := plus Zero lf1.


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

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

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

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint qmult (qmult_arg0 : natural) (qmult_arg1 : natural) (qmult_arg2 : natural) : natural
           := match qmult_arg0, qmult_arg1, qmult_arg2 with
              | Zero, n, m => m
              | Succ n, m, p => qmult n m (plus p m)
              end.

Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
   intros.
   induction x.
   - rewrite plus_zero. reflexivity.
   - simpl. rewrite plus_succ. rewrite IHx. reflexivity.
Qed.

Lemma plus_qmult : forall (x y z a : natural), plus (qmult x y z) a = qmult x y (plus z a).
Proof.
   intro.
   induction x.
   - reflexivity.
   - intros. simpl. rewrite IHx. lfind. Admitted.


  From Autosubst Require Import Autosubst.

(* Formalisation de l'arithmétique de Peano                         *
 * Introduction des types inductifs corespondant aux entiers de     *
 * Peano (Pnat) et aux propriétés portant sur ces entiers (Pprop)   *)

Inductive Pnat : Set :=
  | PO : Pnat
  | PS : Pnat -> Pnat
  | plus : Pnat -> Pnat -> Pnat
  | times : Pnat -> Pnat -> Pnat
  | Pvar : var -> Pnat.

Inductive Pprop :=
  | Pfalse : Pprop
  | Ptrue : Pprop
  | Peq : Pnat -> Pnat -> Pprop
  | Pfa (_ : {bind Pnat in Pprop}) (* {bind Pnat in Pprop} -> Pprop *)
  | Pex (_ : {bind Pnat in Pprop})
  | Pim : Pprop -> Pprop -> Pprop
  | Pan : Pprop -> Pprop -> Pprop
  | Por : Pprop -> Pprop -> Pprop
  | dummy (_ : var). (* type var -> Pprop *)

Notation "'Pno' f" := (Pim f Pfalse) (at level 0).

(* Les déclarations suivantes proviennent du manuel d'autosubst et  *
 * permettent de faire fonctionner la substitution sur les          *
 * expressions de type Pnat et Pprop.                               *)

Instance Ids_Pnat : Ids Pnat. derive. Defined.
Instance Rename_Pnat : Rename Pnat. derive. Defined.
Instance Subst_Pnat : Subst Pnat. derive. Defined.

Instance SubstLemmas_Pnat : SubstLemmas Pnat. derive. Qed.

Instance Hsubst_Pprop : HSubst Pnat Pprop. derive. Defined.

Instance Ids_Pprop : Ids Pprop. derive. Defined.
Instance Rename_Pprop : Rename Pprop. derive. Defined.
Instance Subst_Pprop : Subst Pprop. derive. Defined.

Instance HSubstLemmas_Pprop : HSubstLemmas Pnat Pprop. derive. Qed.
Instance SubstHSubstComp_Pnat_Pprop : SubstHSubstComp Pnat Pprop. derive. Qed.
Instance SubstLemmas_Pprop : SubstLemmas Pprop. derive. Qed.

(* On teste la substitution sur des expressions de type Pnat        *)

Check ((Pvar 0).[PO/]).
Eval compute in ((Pvar 0).[PO/]).

(* On teste la substitution sur des expressions de type Pprop       *)

Check (Pfa (Peq (Pvar 0) (Pvar 0))).
Eval compute in (Pfalse.|[PO/]).
Eval compute in ((Peq (Pvar 0) (Pvar 0)).|[PO/]).
Eval compute in ((Peq (Pvar 0) (Pvar 1)).|[PO.:ids]).

(* On définit les 7 axiomes de Peano :                              *
 * 1. ∀x.¬S(x) = 0                                                  *
 * 2. ∀x.∃y.(¬x = 0 ⇒ S(y) = x)                                     *
 * 3. ∀x.∀y.(S(x) = S(y) ⇒ x = y)                                   *
 * 4. ∀x.x + 0 = x                                                  *
 * 5. ∀x.∀y.S(x) + y = S(x + y)                                     *
 * 6. ∀x.(0 ∗ x = 0)                                                *
 * 7. ∀x.∀y.S(x) ∗ y = (x ∗ y) + y                                  *)

Definition succ_is_non_zero : Pprop :=
  Pfa (Pno (Peq (PS (Pvar 0)) PO)).

Definition non_zero_has_succ : Pprop :=
  Pfa (Pex (Pim (Pno (Peq (Pvar 1) PO)) (Peq (PS (Pvar 0)) (Pvar 1)))).

Definition eq_succ_implies_eq : Pprop :=
  Pfa (Pfa (Pim (Peq (PS (Pvar 1)) (PS (Pvar 0))) (Peq (Pvar 1) (Pvar 0)) )).

Definition zero_is_neutral : Pprop :=
  Pfa (Peq (plus (Pvar 0) (PO)) (Pvar 0)).

Definition succ_can_extend : Pprop :=
  Pfa (Pfa (Peq (plus (PS (Pvar 1)) (Pvar 0)) (PS (plus (Pvar 1) (Pvar 0))))).

Definition zero_absorbs : Pprop :=
  Pfa (Peq (times (Pvar 0) PO) (PO)).

Definition times_distributes : Pprop :=
  Pfa (Pfa (Peq (times (Pvar 1) (PS (Pvar 0))) (plus (times (Pvar 1) (Pvar 0)) (Pvar 1)))).

(* On ajoute aussi le schéma de récurrence, paramétré par un objet  *
 * de type Pprop                                                    *)

Definition recurrence_scheme : Pprop -> Pprop :=
  fun (P : Pprop) => (Pim (P.|[PO/]) (Pim (Pfa (Pim (P.|[Pvar 0/]) (P.|[(PS (Pvar 0))/]))) (Pfa (P.|[Pvar 0/])))).

(* On traite également le tiers exclu comme un axiome, qui          *
 * permettra d'étendre l'arithmétique de Heyting en l'arithmétique  *
 * de Heyting.                                                      *)

Definition excluded_middle : Pprop -> Pprop :=
  fun (P : Pprop) => (Por P (Pno P)).

(* Enfin, on définit les propriétés habituelles de l’égalité        *
 * (reflexivité, élimination).                                      *)

Definition reflexivity : Pprop :=
  Pfa (Pfa (Pim (Peq (Pvar 0) (Pvar 1)) (Peq (Pvar 1) (Pvar 0)))).

Definition elimination : Pprop :=
  Pfa (Pfa (Pfa (Pim (Peq (plus (Pvar 0) (Pvar 1)) (plus (Pvar 0) (Pvar 2))) (Peq (Pvar 1) (Pvar 2))))).

(* Définition du contexte Γ utilisé dans la déduction naturelle:    *
 *   -- nilc est les contexte vide;                                 *
 *   -- intc signale une déclaration de variable;                   *
 *   -- assume ajoute une proposition (contenant éventuellement des *
 *      variables libres) à un contexte.                            *
 * Note : on suppose qu'un contexte bien formé est un contexte où   *
 * il n'existe pas de formule contenant de variable libre non liée  *
 * par un intc, càd que l'on ne pourra écrire Pvar k dans une       *
 * formule que si l'on a traversé au moins k+1 'binders' intc.      *)

Inductive Ctxt : Type :=
  | nilc : Ctxt
  | intc : Ctxt -> Ctxt
  | assume : Pprop -> Ctxt -> Ctxt.

(* On teste la définition du contexte sur le contexte               *
 * [x : nat; x = x; y : nat; y = 2]                                 *
 * Note : on choisit de placer les déclarations de variables en     *
 * amont des propositions qui les concernent, afin de faciliter la  *
 * réflection sur les contextes dans la suite.                      *)

Eval compute in (intc (assume (Peq (Pvar 0) (Pvar 0)) (intc (assume (Peq (Pvar 0) (PS (PS (PO)))) (nilc))))).

(* On définit ensuite un contexte formé par les axiomes qui         *
 * permettent de paramétrer la déduction naturelle, le problème     *
 * étant que le schéma d'induction et le tiers exclu (pour le cas   *
 * de la logique classique) ne peuvent être ajoutés à ce contexte   *)

Definition HAxioms : Ctxt :=
  assume succ_is_non_zero (assume non_zero_has_succ (assume eq_succ_implies_eq (assume zero_is_neutral (assume succ_can_extend (assume zero_absorbs (assume times_distributes (nilc))))))).

(* Dans cette section on définit la fonction de réflection.         *
 * Cette fonction est en fait divisée en trois :                    *
 *   -- une réflection pour les entiers de Peano de type Pnat;      *
 *   -- une réflection pour les proposition de Peano de type Pprop; *
 *   -- une réflection sur les contextes de type Ctxt.              *
 * On va également paramétrer la fonction de réflection par une     *
 * interprétation des variables (de type var), qui prend la forme   *
 * d'une liste de naturels (de type nat). La fonction var_to_nat    *
 * permet alors de retourner l'interprétation de la variable i en   *
 * tant que naturel.                                                *)

Fixpoint var_to_nat (x : var) (l : list nat) : nat :=
  match x, l  with
   | 0, (cons v _) => v
   | S y, (cons _ l)  => (var_to_nat y l)
   | _, _ => 0
  end.

Fixpoint refl_Pnat (x : Pnat) (l : list nat) : nat :=
  match x with
   | PO => O
   | PS x => S (refl_Pnat x l)
   | plus y z => (refl_Pnat y l) + (refl_Pnat z l)
   | times y z => (refl_Pnat y l) * (refl_Pnat z l)
   | Pvar y => var_to_nat y l
  end.

Fixpoint refl_Pprop (P : Pprop) (l : list nat) : Prop :=
  match P with
   | Pfalse => False
   | Ptrue => True
   | Peq x y => (refl_Pnat x l) = (refl_Pnat y l)
   | Pfa Q => forall (x : nat), refl_Pprop Q (cons x l)
   | Pex Q => exists (x : nat), refl_Pprop Q (cons x l)
   | Pim Q R => (refl_Pprop Q l) -> (refl_Pprop R l)
   | Pan Q R => (refl_Pprop Q l) /\ (refl_Pprop R l)
   | Por Q R => (refl_Pprop Q l) \/ (refl_Pprop R l)
   | dummy x => True
  end.

Fixpoint refl_Ctxt (C : Ctxt) (l : list nat) : Prop :=
  match C with
    | nilc => True
    | intc D => forall x, refl_Ctxt D (cons x l)
    | assume P D => (refl_Pprop P l)/\(refl_Ctxt D l)
  end.

(* On va tester si refl_Pprop (∀x.∃y.x = S(y) ∨ x = 0) se réduit    *
 * bien vers l’objet de type Prop forall x, exists y, x=(S y)\/x=O  *
 * comme cela devrait être le cas selon l'énoncé                    *)

Eval compute in (refl_Pprop (Pfa (Pex (Por (Peq (Pvar 1) (PS (Pvar 0))) (Peq (Pvar 1) (PO))))) nil).

Eval compute in (refl_Pprop (Pfa (Pfa (Pim (Peq (PS (Pvar 1)) (PS (Pvar 0))) (Peq (Pvar 1) (Pvar 0)) ))) nil).

(* On teste la réflection sur le contexte                           *
 * [x : nat; x = x; y : nat; y = x], qui devrait donner             *
 * forall x : nat, x = x /\ (forall y : nat, y = x /\ True)         *)

Eval compute in (refl_Ctxt (intc (assume (Peq (Pvar 0) (Pvar 0)) (intc (assume (Peq (Pvar 0) (Pvar 1)) (nilc))))) nil).

(* Dans cette section on définit les règles logiques de la          *
 * déduction naturelle adaptées aux objets de type Pprop et aux     *
 * contextes de type Ctxt. La définition est 'dédoublée' en une     *
 * définition 'intuitionniste' (sans règle em) et une définition    *
 * 'classique' (avec une règle em) : c'est un peu maladroit mais je *
 * n'ai pas réussi à faire mieux malheureusement.                   *)

Inductive ded_nat : Ctxt -> Pprop -> Prop :=

  | axiom G A : ded_nat (assume A G) A

  | weak G A B : ded_nat G A -> ded_nat (assume B G) A

  | impi G A B : ded_nat (assume A G) B -> ded_nat G (Pim A B)

  | impe G A B : ded_nat G (Pim A B) -> ded_nat G A -> ded_nat G B

  | andi G A B : ded_nat G A -> ded_nat G B -> ded_nat G (Pan A B)

  | andle G A B : ded_nat G (Pan A B) -> ded_nat G A

  | andre G A B : ded_nat G (Pan A B) -> ded_nat G B

  | orli G A B : ded_nat G A -> ded_nat G (Por A B)

  | orri G A B : ded_nat G B -> ded_nat G (Por A B)

  | ore G A B C : ded_nat G (Por A B) -> ded_nat (assume A G) C -> ded_nat (assume B G) C -> ded_nat G C

  | bote G A : ded_nat G Pfalse -> ded_nat G A

  | topi G : ded_nat G Ptrue

  | foralli G A : ded_nat (intc G) A -> ded_nat G (Pfa A)

  | foralle G A t : ded_nat G (Pfa A) -> ded_nat G (A.|[t.:ids])

  | existi G A t : ded_nat G (A.|[t.:ids]) -> ded_nat G (Pex A)

  | existe G A C : ded_nat G (Pex A) -> ded_nat (assume A (intc G)) (C.|[ren(+1)]) -> ded_nat G C.

Inductive ded_nat_em : Ctxt -> Pprop -> Prop :=

  | axiom_em G A : ded_nat_em (assume A G) A

  | weak_em G A B : ded_nat_em G A -> ded_nat_em (assume B G) A

  | impi_em G A B : ded_nat_em (assume A G) B -> ded_nat_em G (Pim A B)

  | impe_em G A B : ded_nat_em G (Pim A B) -> ded_nat_em G A -> ded_nat_em G B

  | andi_em G A B : ded_nat_em G A -> ded_nat_em G B -> ded_nat_em G (Pan A B)

  | andle_em G A B : ded_nat_em G (Pan A B) -> ded_nat_em G A

  | andre_em G A B : ded_nat_em G (Pan A B) -> ded_nat_em G B

  | orli_em G A B : ded_nat_em G A -> ded_nat_em G (Por A B)

  | orri_em G A B : ded_nat_em G B -> ded_nat_em G (Por A B)

  | ore_em G A B C : ded_nat_em G (Por A B) -> ded_nat_em (assume A G) C -> ded_nat_em (assume B G) C -> ded_nat_em G C

  | bote_em G A : ded_nat_em G Pfalse -> ded_nat_em G A

  | topi_em G : ded_nat_em G Ptrue

  | foralli_em G A : ded_nat_em (intc G) A -> ded_nat_em G (Pfa A)

  | foralle_em G A t : ded_nat_em G (Pfa A) -> ded_nat_em G (A.|[t.:ids])

  | existi_em G A t : ded_nat_em G (A.|[t.:ids]) -> ded_nat_em G (Pex A)

  | existe_em G A C : ded_nat_em G (Pex A) -> ded_nat_em (assume A (intc G)) (C.|[ren(+1)]) -> ded_nat_em G C

  | em G A : ded_nat_em G (Por A (Pno A)).

(* 4.2 Questions : implémentation                                   *
 * On demande, dans un premier temps d’écrire en Coq les fonctions  *
 * de réflection. Ensuite, de prouver que s’il existe une           *
 * dérivation dans l’arithmétique de Peano intuitionniste d’une     *
 * formule P dans un contexte Γ, alors, il existe un terme Coq de   *
 * type tr(Γ) → tr(P). C’est cette dernière étape qui constitue la  *
 * réflection proprement dite.                                      *)

(* On peut commencer par prouver que les axiomes de l'arithmétique  *
 * de Peano définis ci-dessus sont prouvables dans Coq.             *)

Theorem succ_is_non_zero_is_provable : refl_Pprop succ_is_non_zero nil.
Proof.
simpl refl_Pprop; apply PeanoNat.Nat.neq_succ_0.
Qed.

Theorem eq_succ_implies_eq_is_provable : refl_Pprop eq_succ_implies_eq nil.
Proof.
simpl refl_Pprop; apply PeanoNat.Nat.succ_inj.
Qed.

Theorem zero_is_neutral_is_provable : refl_Pprop zero_is_neutral nil.
Proof.
simpl refl_Pprop; apply PeanoNat.Nat.add_0_r.
Qed.

Theorem succ_can_extend_is_provable : refl_Pprop succ_can_extend nil.
Proof.
simpl refl_Pprop; trivial.
Qed.

Theorem zero_absorbs_is_provable : refl_Pprop zero_absorbs nil.
Proof.
simpl refl_Pprop; apply PeanoNat.Nat.mul_0_r.
Qed.

Theorem times_distributes_is_provable : refl_Pprop times_distributes nil.
Proof.
simpl refl_Pprop; apply PeanoNat.Nat.mul_succ_r.
Qed.

(*

Theorem recurrence_scheme_is_provable : forall P : Pprop, (refl_Pprop (recurrence_scheme P) nil).
Proof.
intros.
simpl refl_Pprop.
intros.
revert.

*)

Theorem reflection (G : Ctxt) (P : Pprop): ded_nat G P -> (refl_Ctxt G nil) -> (refl_Pprop P nil).
Proof.
induction 1.
- simpl; intros; destruct H; trivial.
- simpl; intros; destruct H0; apply IHded_nat; trivial.
- simpl; intros; apply IHded_nat; simpl; refine (conj _ _); trivial.
- intros; simpl refl_Pprop in IHded_nat1; apply IHded_nat1; trivial; apply IHded_nat2; trivial.
- simpl; intros; refine (conj _ _).
  -- apply IHded_nat1; trivial.
  -- apply IHded_nat2; trivial.
- intros; simpl refl_Pprop in IHded_nat; apply IHded_nat; trivial.
- intros; simpl refl_Pprop in IHded_nat; apply IHded_nat; trivial.
- simpl; intros; left; apply IHded_nat; trivial.
- simpl; intros; right; apply IHded_nat; trivial.
- intros; simpl refl_Pprop in IHded_nat1.
  simpl refl_Ctxt in IHded_nat2; simpl refl_Ctxt in IHded_nat3.
  pose (H3 := IHded_nat1 H2); case H3.
  -- intros; apply IHded_nat2; refine (conj _ _).
     --- trivial.
     --- trivial.
  -- intros; apply IHded_nat3; refine (conj _ _).
     --- trivial.
     --- trivial.
- intros; simpl refl_Pprop in IHded_nat; pose (H1 := IHded_nat H0); case H1.
- simpl; intros; exact I.
- simpl.
 intros; simpl refl_Ctxt in IHded_nat.

Admitted.

(* La preuve du théorème de reflection permettrait de montrer que   *
 * tout ce qui est prouvable dans notre formalisme intuitionniste   *
 * est aussi prouvable dans Coq, autrement dit que notre formalisme *
 * est consistant avec Coq.                                         *)

(* Dans cette section on définit la traduction de Friedman pour les *
 * propriétés et les contextes.                                     *)

Fixpoint Friedman (P : Pprop) (A : Pprop) : Pprop :=
  match P with
    | Pfalse => Por Pfalse A
    | Ptrue => Ptrue
    | Peq x y => Por (Peq x y) A
    | Pfa B => Pfa (Pim (Pim (Friedman B A) A) A)
    | Pex B => Pim (Pim (Pex (Friedman B A)) A) A
    | Pim B C => Pim (Pim (Pim (Friedman B A) A) A) (Pim (Pim (Friedman C A) A) A)
    | Pan B C => Pan (Pim (Pim (Friedman B A) A) A) (Pim (Pim (Friedman C A) A) A)
    | Por B C => Por (Pim (Pim (Friedman B A) A) A) (Pim (Pim (Friedman C A) A) A)
    | dummy x => Por (dummy x) A
  end.

Fixpoint Friedman_ctxt (C : Ctxt) (A : Pprop) :=
  match C with
    | nilc => nilc
    | intc D => Friedman_ctxt D A
    | assume P D => assume (Friedman P A) (Friedman_ctxt D A)
  end.

(* Lemme 1: On étend, de manière triviale, la transformée par double*
 * négation aux contextes. S’il existe une dérivation de Γ t P dans *
 * l’arithmétique de Peano, il existe une dérivation de             *
 * Γ^A t ¬^A ¬^A P^A dans l’arithmétique de Heyting.                *)

Lemma Peano_Heyting (P : Pprop) (C : Ctxt) (A : Pprop) : (ded_nat_em C P ) -> ded_nat (Friedman_ctxt C A) (Pim (Pim (Friedman P A) A) A).
Proof.
induction 1.
- simpl.
  apply (impi ((assume (Friedman A0 A) (Friedman_ctxt G A))) ((Pim (Friedman A0 A) A)) (A)).
  apply (impe (assume (Pim (Friedman A0 A) A) (assume (Friedman A0 A) (Friedman_ctxt G A))) (Friedman A0 A) A).
 -- apply (axiom (assume (Friedman A0 A) (Friedman_ctxt G A)) (Pim (Friedman A0 A) A)).
 -- apply (weak ((assume (Friedman A0 A) (Friedman_ctxt G A))) ((Friedman A0 A)) ((Pim (Friedman A0 A) A))).
    apply (axiom ((Friedman_ctxt G A)) ((Friedman A0 A))).
- simpl.
  apply (impi ((assume (Friedman B A) (Friedman_ctxt G A))) ((Pim (Friedman A0 A) A)) (A)).
  admit.
- simpl.
admit.
- simpl.
  apply (impi ((Friedman_ctxt G A)) (Pim (Friedman B A) A) A).
  apply (impe ((assume (Pim (Friedman B A) A) (Friedman_ctxt G A))) (Friedman B A) (A)).
  -- apply (axiom ( (Friedman_ctxt G A)) ((Pim (Friedman B A) A))).
  -- admit.
- apply (impi ((Friedman_ctxt G A)) ((Pim (Friedman (Pan A0 B) A) A)) (A)).
  apply (impe ((assume (Pim (Friedman (Pan A0 B) A) A)
     (Friedman_ctxt G A))) (Friedman (Pan A0 B) A) (A)).
  -- apply (axiom ( (Friedman_ctxt G A)) ((Pim (Friedman (Pan A0 B) A) A))).
  -- simpl Friedman.
     apply (andi ((assume (Pim (Pan (Pim (Pim (Friedman A0 A) A) A) (Pim (Pim (Friedman B A) A) A)) A) (Friedman_ctxt G A))) ((Pim (Pim (Friedman A0 A) A) A)) ((Pim (Pim (Friedman B A) A) A))).
     --- apply (impi ((assume (Pim (Pan (Pim (Pim (Friedman A0 A) A) A) (Pim (Pim (Friedman B A) A) A)) A) (Friedman_ctxt G A))) ((Pim (Friedman A0 A) A)) (A)).
         apply (impe ((assume (Pim (Friedman A0 A) A) (assume (Pim (Pan (Pim (Pim (Friedman A0 A) A) A) (Pim (Pim (Friedman B A) A) A)) A) (Friedman_ctxt G A)))) (A0) (A)).
         -----
(* Lemme 2 : Les formules sans quantificateurs sont décidables      *
 * (en particulier dans Coq).                                       *)

(* On définit d'abord une fonction qui détermine si une formule     *
 * contient ou non des quantifieurs :                               *)

Fixpoint not_quant (P : Pprop) : Prop :=
  match P with
    | Pfalse => True
    | Ptrue => True
    | Peq x y => True
    | Pfa B => False
    | Pex B => False
    | Pim B C => (not_quant B) /\ (not_quant C)
    | Pan B C => (not_quant B) /\ (not_quant C)
    | Por B C => (not_quant B) /\ (not_quant C)
    | dummy x => True
  end.

Lemma not_quant_decidable (P : Pprop) (A : Pprop) : not_quant P -> (refl_Pprop (Friedman P A) nil) \/ (refl_Pprop (Pno (Friedman P A)) nil).
Proof.
induction P, A; simpl refl_Pprop.
- right.
right.

(* Lemme 3 : Soit P une formule sans quantificateurs. On a, dans    *
 * Coq, P^A ⇐⇒ P ∨ A.                                               *)

Lemma Friedman_equiv_A_disj (P : Pprop) (A : Pprop) : (not_quant P) -> ((Friedman P A -> Por P A) /\ (Por P A -> Friedman P A)).


Set Implicit Arguments.

Require Import
        Discrete.DiscType
        Discrete.Filter
        Discrete.In
        Discrete.Inclusion
        Tactics.Tactics.

Section REM.
  Variable A : discType.
  Context {eq_A_dec : eq_dec A}.

  Definition rem (xs : list A) x :=
    filter (fun y => y <> x) xs.

  Lemma In_rem_iff x xs y :
    x el rem xs y <-> x el xs /\ x <> y.
  Proof.
    apply In_filter_iff.
  Qed.

  Lemma rem_not_in x y xs :
    x = y \/ ~ x el xs -> ~ x el rem xs y.
  Proof.
    intros D E. apply In_rem_iff in E. tauto.
  Qed.

  Lemma rem_incl xs x :
    rem xs x <<= xs.
  Proof.
    apply filter_incl.
  Qed.

  Lemma rem_mono xs ys x :
    xs <<= ys -> rem xs x <<= rem ys x.
  Proof.
    apply filter_mono.
  Qed.

  Lemma rem_cons xs ys x :
    xs <<= ys -> rem (x :: xs) x <<= ys.
  Proof.
    intros E y F. apply E. apply In_rem_iff in F.
    destruct F as [[|]]; congruence.
  Qed.

  Hint Resolve rem_cons.

  Lemma rem_cons' xs ys x y :
    x el ys -> rem xs y <<= ys -> rem (x :: xs) y <<= ys.
  Proof.
    intros E F u G.
    apply In_rem_iff in G. crush.
    apply F. apply In_rem_iff. splits*.
  Qed.

  Lemma rem_in x y xs :
    x el rem xs y -> x el xs.
  Proof.
    apply rem_incl.
  Qed.

  Lemma rem_neq x y xs :
    x <> y -> x el xs -> x el rem xs y.
  Proof.
    intros E F. apply In_rem_iff. auto.
  Qed.

  Hint Resolve rem_in rem_neq.

  Lemma rem_app x xs ys :
    x el xs -> ys <<= xs ++ rem ys x.
  Proof.
    intros E y F. decide (x=y) as [[]|] ;
      try apply In_app_iff ; crush.
  Qed.

  Lemma rem_app' x xs ys zs :
    rem xs x <<= zs -> rem ys x <<= zs -> rem (xs ++ ys) x <<= zs.
  Proof.
    unfold rem ; rewrite filter_app ; auto.
  Qed.

  Lemma rem_equi x xs :
    x :: xs === x :: rem xs x.
  Proof.
    split ; intros y;
    intros [[]|E] ; decide (x=y) as [[]|D] ; crush ; eauto.
  Qed.

  Lemma rem_comm xs x y :
    rem (rem xs x) y = rem (rem xs y) x.
  Proof.
    apply filter_comm.
  Qed.

  Lemma rem_fst x xs :
    rem (x :: xs) x = rem xs x.
  Proof.
    unfold rem. rewrite filter_fst'; auto.
  Qed.

  Lemma rem_fst' x y xs :
    x <> y -> rem (x :: xs) y = x :: rem xs y.
  Proof.
    intros E. unfold rem. rewrite filter_fst ; auto.
  Qed.

  Lemma rem_id x xs :
    ~ x el xs -> rem xs x = xs.
  Proof.
    intros D. apply filter_id.
    intros y E F. subst. auto.
  Qed.

  Lemma rem_reorder x xs :
    x el xs -> xs === x :: rem xs x.
  Proof.
    intros D. rewrite <- rem_equi. apply equiv_push, D.
  Qed.

  Lemma rem_inclr xs ys x :
    xs <<= ys -> ~ x el xs -> xs <<= rem ys x.
  Proof.
    intros D E y F. apply In_rem_iff.
    intuition; subst; auto.
  Qed.
End REM.

Arguments rem {A}{eq_A_dec} xs x.

Hint Resolve rem_not_in rem_incl rem_mono
     rem_cons rem_cons' rem_app rem_app' rem_in rem_neq rem_inclr.


Require Export Iron.DiscipleKernel.TyExp.
Require Export Iron.DiscipleKernel.TyWfT.

(*******************************************************************)
(* Lift type indices that are at least a certain depth. *)
Fixpoint liftTT (n: nat) (d: nat) (tt: ty) : ty :=
 match tt with
 |  TVar ix
 => if le_gt_dec d ix
     then TVar (ix + n)
     else tt

 |  TCon _      => tt
 |  TForall k t => TForall k (liftTT n (S d) t)
 |  TApp t1 t2  => TApp      (liftTT n d t1) (liftTT n d t2)
 |  TSum t1 t2  => TSum      (liftTT n d t1) (liftTT n d t2)
 |  TBot k      => TBot k
 end.
Hint Unfold liftTT.

(********************************************************************)
(* Lifting and well-formedness *)
Lemma liftTT_wfT
 :  forall kn t d
 ,  wfT kn t
 -> wfT (S kn) (liftTT 1 d t).
Proof.
 intros. gen kn d.
 lift_burn t; inverts H; try burn.

 Case "TVar".
  repeat (simpl; lift_cases).
   eapply WfT_TVar. burn.
   eapply WfT_TVar. burn.
Qed.
Hint Resolve liftTT_wfT.

(********************************************************************)
Lemma liftTT_zero
 :  forall d t
 ,  liftTT 0 d t = t.
Proof.
 intros. gen d. lift_burn t.
Qed.
Hint Rewrite liftTT_zero : global.

Lemma liftTT_comm
 :  forall n m d t
 ,  liftTT n d (liftTT m d t)
 =  liftTT m d (liftTT n d t).
Proof.
 intros. gen d. lift_burn t.
Qed.

Lemma liftTT_succ
 :  forall n m d t
 ,  liftTT (S n) d (liftTT m     d t)
 =  liftTT n     d (liftTT (S m) d t).
Proof.
 intros. gen d m n. lift_burn t.
Qed.
Hint Rewrite liftTT_succ : global.

Lemma liftTT_plus
 : forall n m d t
 , liftTT n d (liftTT m d t) = liftTT (n + m) d t.
Proof.
 intros. gen n d.
 induction m; intros.
 rewrite liftTT_zero; burn.

 rw (n + S m = S n + m).
  rewrite liftTT_comm.
  rewrite <- IHm.
  rewrite liftTT_comm.
  burn.
Qed.
Hint Rewrite <- liftTT_plus : global.

(******************************************************************************)
Lemma liftTT_wfT_1
 :  forall t n ix
 ,  wfT n t
 -> liftTT 1 (n + ix) t = t.
Proof.
 intros. gen n ix.
 induction t; intros; inverts H; simpl; auto.

  Case "TVar".
   lift_cases; burn.

  Case "TForall".
   f_equal. spec IHt H1.
   rw (S (n + ix) = S n + ix).
   burn.

  Case "TApp".
   rs. burn.

  Case "TSum".
   rs. burn.
Qed.
Hint Resolve liftTT_wfT_1.

Lemma liftTT_closedT_id_1
 :  forall t d
 ,  closedT t
 -> liftTT 1 d t = t.
Proof.
 intros.
 rw (d = d + 0). eauto.
Qed.
Hint Resolve liftTT_closedT_id_1.

Lemma liftTT_closedT_10
 :  forall t
 ,  closedT t
 -> closedT (liftTT 1 0 t).
Proof.
 intros. red.
 rw (0 = 0 + 0).
 rewrite liftTT_wfT_1; auto.
Qed.
Hint Resolve liftTT_closedT_10.

(********************************************************************)
(* Changing the order of lifting.
   We build this up in stages.
   Start out by only allow lifting by a single place for both
   applications. Then allow lifting by multiple places in the first
   application, then multiple places in both.
*)
Lemma liftTT_liftTT_11
 :  forall d d' t
 ,  liftTT 1 d              (liftTT 1 (d + d') t)
 =  liftTT 1 (1 + (d + d')) (liftTT 1 d t).
Proof.
 intros. gen d d'.
 induction t; intros; simpl; try burn.

 Case "TVar".
  repeat (lift_cases; unfold liftTT); burn.

 Case "TForall".
  rw (S (d + d') = (S d) + d').
  burn.
Qed.

Lemma liftTT_liftTT_1
 :  forall n1 m1 n2 t
 ,  liftTT m1   n1 (liftTT 1 (n2 + n1) t)
 =  liftTT 1 (m1 + n2 + n1) (liftTT m1 n1 t).
Proof.
 intros. gen n1 m1 n2 t.
 induction m1; intros; simpl.
  burn.

  rw (S m1 = 1 + m1).
  rewrite <- liftTT_plus.
  rs.
  rw (m1 + n2 + n1 = n1 + (m1 + n2)).
  rewrite liftTT_liftTT_11.
  burn.
Qed.

Lemma liftTT_liftTT
 :  forall m1 n1 m2 n2 t
 ,  liftTT m1 n1 (liftTT m2 (n2 + n1) t)
 =  liftTT m2 (m1 + n2 + n1) (liftTT m1 n1 t).
Proof.
 intros. gen n1 m1 n2 t.
 induction m2; intros.
  burn.

  rw (S m2 = 1 + m2).
  rewrite <- liftTT_plus.
  rewrite liftTT_liftTT_1.
  rewrite IHm2.
  burn.
Qed.
Hint Rewrite liftTT_liftTT : global.

Lemma liftTT_map_liftTT
 :  forall m1 n1 m2 n2 ts
 ,  map (liftTT m1 n1) (map (liftTT m2 (n2 + n1)) ts)
 =  map (liftTT m2 (m1 + n2 + n1)) (map (liftTT m1 n1) ts).
Proof.
 induction ts; simpl; burn.
Qed.


From Undecidability.Synthetic Require Import DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts.
From Undecidability.Shared Require Import Dec.

Require Import List.
Import ListNotations.

Lemma enumerable_enum {X} {p : X -> Prop} :
  enumerable p <-> list_enumerable p.
Proof.
  split. eapply enumerable_list_enumerable. eapply list_enumerable_enumerable.
Qed.

Lemma enumerable_disj X (p q : X -> Prop) :
  enumerable p -> enumerable q -> enumerable (fun x => p x \/ q x).
Proof.
  intros [Lp H] % enumerable_enum [Lq H0] % enumerable_enum.
  eapply enumerable_enum.
  exists (fix f n := match n with 0 => [] | S n => f n ++ (Lp n) ++ (Lq n) end).
  intros x. split.
  - intros [H1 | H1].
    * eapply H in H1 as [m]. exists (1 + m). cbn.
      apply in_or_app. right. apply in_or_app. now left.
    * eapply H0 in H1 as [m]. exists (1 + m). cbn.
      apply in_or_app. right. apply in_or_app. now right.
  - intros [m]. induction m.
    * inversion H1.
    * apply in_app_iff in H1.
      destruct H1 as [?|H1]; [now auto|].
      apply in_app_iff in H1.
      unfold list_enumerator in *; firstorder easy.
Qed.

Lemma enumerable_conj X (p q : X -> Prop) :
  discrete X -> enumerable p -> enumerable q -> enumerable (fun x => p x /\ q x).
Proof.
  intros [] % discrete_iff [Lp] % enumerable_enum [Lq] % enumerable_enum.
  eapply enumerable_enum.
  exists (fix f n := match n with 0 => [] | S n => f n ++ (filter (fun x => Dec (In x (cumul Lq n))) (cumul Lp n)) end).
  intros x. split.
  + intros []. eapply (list_enumerator_to_cumul H) in H1 as [m1].
    eapply (list_enumerator_to_cumul H0) in H2 as [m2].
    exists (1 + m1 + m2). cbn. apply in_or_app. right.
    apply filter_In. split.
    * eapply cum_ge'; eauto; lia.
    * eapply Dec_auto. eapply cum_ge'; eauto; lia.
  + intros [m]. induction m.
    * inversion H1.
    * apply in_app_iff in H1. destruct H1 as [?|H1]; [now auto|].
      apply filter_In in H1. destruct H1 as [? H1].
      split.
      ** eapply (list_enumerator_to_cumul H). eauto.
      ** destruct (Dec _) in H1; [|easy].
         eapply (list_enumerator_to_cumul H0). eauto.
Qed.

Lemma projection X Y (p : X * Y -> Prop) :
  enumerable p -> enumerable (fun x => exists y, p (x,y)).
Proof.
  intros [f].
  exists (fun n => match f n with Some (x, y) => Some x | None => None end).
  intros; split.
  - intros [y ?]. eapply H in H0 as [n]. exists n. now rewrite H0.
  - intros [n ?]. destruct (f n) as [ [] | ] eqn:E; inversion H0; subst.
    exists y. eapply H. eauto.
Qed.

Lemma projection' X Y (p : X * Y -> Prop) :
  enumerable p -> enumerable (fun y => exists x, p (x,y)).
Proof.
  intros [f].
  exists (fun n => match f n with Some (x, y) => Some y | None => None end).
  intros y; split.
  - intros [x ?]. eapply H in H0 as [n]. exists n. now rewrite H0.
  - intros [n ?]. destruct (f n) as [ [] | ] eqn:E; inversion H0; subst.
    exists x. eapply H. eauto.
Qed.


Require Import List Mergesort Setoid Permutation Sorted Orders Omega.

Set Implicit Arguments.

Fixpoint LinearSearch (A : Type)(l : list A)(f : A -> bool) : option nat :=
  match l with
  | nil => None
  | l_head :: l_tail =>
      match f l_head with
      | true => Some O
      | false =>
          match LinearSearch l_tail f with
          | None => None
          | Some n => Some (S n)
          end
      end
  end.

Theorem SearchNoneFalse : forall A (l : list A) f,
  LinearSearch l f = None ->
    (forall n d, f d = false -> f (nth n l d) = false).
  intros A l f H.
  induction l.
  simpl in *.
  destruct n.
  trivial.
  trivial.
  simpl in *.
  intros.
  remember (f a) as b.
  destruct b.
  inversion H.
  destruct n.
  auto.
  apply IHl.
  remember (LinearSearch l f) as R.
  destruct R.
  inversion H.
  trivial.
  trivial.
Qed.

Theorem FalseSearchNone : forall A (l : list A) f d,
  f d = false ->
  (forall n, f (nth n l d) = false) ->
    LinearSearch l f = None.
  intros.
  induction l.
  trivial.
  simpl.
  assert(LinearSearch l f = None) as HR.
  apply IHl.
  intros.
  remember (H0 (S n)).
  trivial.
  rewrite HR in *.
  remember(H0 0).
  simpl in *.
  rewrite e.
  trivial.
Qed.

Theorem TrueSearchSome : forall A d f (l : list A) m,
  f d = false ->
    f (nth m l d) = true ->
      (forall n, n < m -> f (nth n l d) = false) ->
        LinearSearch l f = Some m.
  induction l.
  intros.
  simpl in *.
  destruct m;
  rewrite H in H0;
  inversion H0.
  intros.
  simpl in *.
  destruct m.
  rewrite H0 in *.
  trivial.
  assert(f a = false).
  remember(H1 0).
  simpl in *.
  auto with *.
  rewrite H2 in *.
  assert(LinearSearch l f = Some m).
  apply IHl.
  trivial.
  trivial.
  intros.
  remember(H1 (S n)).
  simpl in *.
  apply e.
  subst.
  auto with *.
  rewrite H3.
  trivial.
Qed.

Theorem SomeTrueSearch : forall A d f (l : list A) m,
  LinearSearch l f = Some m ->
    f d = false ->
      f (nth m l d) = true ->
        (forall n, n < m -> f (nth n l d) = false).
  induction l.
  simpl in *.
  destruct n;
  trivial.
  intros.
  simpl in *.
  destruct m.
  omega.
  remember (f a) as b.
  destruct b.
  inversion H.
  destruct n.
  auto.
  remember (LinearSearch l f) as L.
  destruct L.
  assert(m = n0).
  inversion H.
  trivial.
  subst.
  eapply IHl.
  trivial.
  trivial.
  trivial.
  omega.
  inversion H.
Qed.


From mathcomp Require Import ssreflect seq ssrnat ssrbool eqtype ssrfun choice.
From mf Require Import all_mf.
Require Import Morphisms.

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

Notation "L '\is_sublist_of' K" := (List.incl L K) (at level 2).

Section sublists.
Context (T: Type).

Lemma subl_refl: Reflexive (@List.incl T).
Proof. by move => L t. Qed.

Lemma subl_trans: Transitive (@List.incl T).
Proof. by move => L K M subl subl' t lstn; apply/subl'/subl. Qed.

Lemma subl0 (L: seq T): L \is_sublist_of [::] -> L = [::].
Proof. by elim: L => // t L ih subl; have []:= subl t; left. Qed.

Lemma drop_subl (L : seq T) n: (drop n L) \is_sublist_of L.
Proof.
elim: n => [ | n ih]; first by rewrite drop0.
rewrite -add1n -drop_drop drop1 => t lstn.
by apply/ih; case: (drop n L) lstn => //; right.
Qed.

Lemma lstn_app (L K: seq T)t: List.In t (L ++ K) <-> List.In t L \/ List.In t K.
Proof.
split; last by have:= List.in_or_app L K t.
elim: L => [ | l L ihL /= [eq | lstn]]; [ | left; left | ] => //.
- by elim: K => // l K ihK /= [eq | lstn]; [right; left | right; right].
by case: (ihL lstn); [ left; right | right ].
Qed.
End sublists.

Lemma lstn_flatten T (Ln: seq (seq T)) t:
  List.In t (flatten Ln) <-> exists L, List.In t L /\ List.In L Ln.
Proof.
split.
- elim: Ln => [| L Ln ih /=]// /lstn_app [lstn | lstn]; first by exists L; split => //; left.
  by have [K []] := ih lstn; exists K; split => //; right.
elim: Ln => [[L []] | L Ln ih [K [lstn /=[-> | lstn']]]]//; apply/lstn_app; first by left.
by right; apply/ih; exists K.
Qed.

Lemma flatten_subl T (Ln Kn: seq (seq T)):
  Ln \is_sublist_of Kn -> (flatten Ln) \is_sublist_of (flatten Kn).
Proof.
move => subl t /lstn_flatten [L [lstn lstn']].
by rewrite lstn_flatten; exists L; split; last apply subl.
Qed.

Section initial_segments.
  Context (Q: Type) (cnt: nat -> Q).

  Fixpoint segment_rec n m {struct m} :=
    match m with
    | 0 => [::]
    | S m' => [:: cnt (n + m') & segment_rec n m']
    end.

  Lemma size_seg_rec n m: size (segment_rec n m) = m.
  Proof. by elim: m => // m /= ->. Qed.

  Definition segment n m := segment_rec n (m.+1-n).

  Lemma size_seg n m: size (segment n m) = m.+1-n.
  Proof. by rewrite /segment; apply size_seg_rec. Qed.

  Lemma seg_recr n m : n <= m.+1 ->
	               segment n m.+1 = segment m.+1 m.+1 ++ segment n m.
  Proof. by move => ineq; rewrite /segment (@subSn (m.+1)) // subSn// subnn /= addn0 subnKC. Qed.

  Lemma seg_recl n m: n <= m -> segment n m = segment n.+1 m ++ segment n n.
  Proof.
    move => ineq; rewrite /segment subnS subSn//= subSn // subnn/= addn0.
    by elim: (m - n) => [ | k ih]; [rewrite addn0 | rewrite /= ih addSn addnS].
  Qed.

  Lemma cat_seg n k m:
    segment (n + k).+1 ((n + k).+1 + m) ++ segment n (n + k)
    = segment n ((n + k).+1 + m).
  Proof.
    elim: k => [ | k /= ih].
    - rewrite !addn0 (@seg_recl n (n.+1 + m)) //.
      by rewrite addSn; apply /leqW/leq_addr.
      rewrite -addnS in ih; rewrite /=addSn (@seg_recr n (n + k.+1 + m)); last first.
    - by apply/leqW; rewrite -addnA; apply/leq_addr.
    rewrite -ih catA -(@seg_recr (n + k.+1) (n + k.+1 + m)); last first.
    - by apply/leqW/leq_addr.
    rewrite (@seg_recl (n + k.+1)); last by apply/leqW/leq_addr.
    by rewrite -catA addnS -(@seg_recr n)//; last by apply/leqW/leq_addr.
  Qed.

  Fixpoint iseg n:=
    match n with
    | 0 => nil
    | S n' => [:: cnt n' & iseg n']
    end.

  Lemma iseg_seg n: iseg n.+1 = segment 0 n.
  Proof. by rewrite /segment; elim: n => // n; rewrite /= !add0n => ->. Qed.

  Lemma iseg_cat_seg n k: n.+1 < k -> segment n.+1 k.-1 ++ iseg n.+1 = iseg k.
  Proof.
    case: k => //; case => //k ineq; rewrite iseg_seg.
    have:= cat_seg 0 n (k - n); rewrite !add0n.
    by rewrite addSn subnKC // iseg_seg.
  Qed.

  Lemma size_iseg n: size (iseg n) = n.
  Proof. by elim: n => // n /= ->. Qed.

  Lemma iseg_subl n m:
    n <= m -> (iseg n) \is_sublist_of (iseg m).
  Proof.
    elim: m => [ | m ih]; first by rewrite leqn0 => /eqP ->.
    by rewrite leq_eqVlt; case/orP => [/eqP -> | ] //=; right; apply/ih.
  Qed.

  Lemma iseg_ex a n: List.In a (iseg n) -> exists m, m < n /\ cnt m = a.
  Proof.
    elim: n => // n ih/=; case => [ | lstn]; first by exists n.
    by have [m []]:= ih lstn; exists m; split => //; rewrite leqW.
  Qed.

  Lemma drop_iseg k m: drop k (iseg m) = iseg (m - k).
  Proof.
    move: {2}k (leqnn k) => l.
    elim: l k m => [k m | n ih k m].
    - by rewrite leqn0 => /eqP ->; rewrite drop0 subn0.
    rewrite leq_eqVlt; case/orP => [/eqP ->| ]; last exact/ih.
    rewrite -addn1 addnC -drop_drop ih//.
    case: n ih => [ih | n ih]; last by rewrite ih // addSn add0n !subnS subn0.
    by rewrite subn0 addn0; elim: (m) => //m' ihm /=; rewrite drop0 subn1.
  Qed.

  Lemma nth_iseg n m: nth (cnt 0) (iseg m) n = cnt (m - n).-1.
  Proof. by rewrite -{1}(addn0 n) -nth_drop drop_iseg; elim: (m - n). Qed.

  Context (sec: Q -> nat).
  Fixpoint max_elt K :=
    match K with
    | nil => 0
    | cons q K' => maxn (sec (q: Q)).+1 (max_elt K')
    end.

  Lemma melt_app L K:
    max_elt (L ++ K) = maxn (max_elt L) (max_elt K).
  Proof. by elim: L K; [move => K; rewrite max0n | intros; rewrite /= (H K) maxnA]. Qed.

  Definition pickle_min:= forall n, max_elt (iseg n) <= n.

  Lemma lstn_melt K a: List.In a K -> sec a < max_elt K.
  Proof.
    elim: K a => // a K ih a'/=.
    by case => [<- | lstn]; apply/leq_trans; [|exact: leq_maxl|apply ih|exact: leq_maxr].
  Qed.

  Lemma melt_subl L K:
    L \is_sublist_of K -> max_elt L <= max_elt K.
  Proof.
    elim: L => //a L ih /=subl.
    case/orP: (leq_total (sec a).+1 (max_elt L)) => [/maxn_idPr -> | /maxn_idPl ->].
    - by apply/ih => q lstn; apply/subl; right.
    by apply/lstn_melt/subl; left.
  Qed.

  Lemma lstn_iseg_S a: cancel sec cnt -> List.In a (iseg (sec a).+1).
  Proof. by move => cncl; left. Qed.

  Lemma lstn_iseg q m:
    List.In q (iseg m) <-> exists n, n < m /\ cnt n = q.
  Proof.
    split => [ | [n []]]; first exact/iseg_ex; elim: m => // m ih.
    by rewrite leq_eqVlt; case/orP => [/eqP [<-]| ]; [left | right; apply/ih].
  Qed.

  Definition minimal_section Q (cnt: nat -> Q) (sec : Q -> nat) :=
    cancel sec cnt /\ forall s,(forall m, cnt m = s -> sec s <= m).

  Lemma iseg_base a n: minimal_section cnt sec -> List.In a (iseg n) -> sec a < n.
  Proof.
    move => [cncl min]; elim: n => // n ih/=.
    by case => [<- | lstn]; [apply/min | rewrite leqW//; apply/ih].
  Qed.

  Lemma melt_iseg n : minimal_section cnt sec -> max_elt (iseg n) <= n.
  Proof.
    move => [cncl min]; elim: n => // n ih /=.
    by rewrite geq_max; apply/andP; split; [apply/min | rewrite leqW].
  Qed.

  Lemma iseg_melt K: minimal_section cnt sec -> K \is_sublist_of (iseg (max_elt K)).
  Proof. by move => [cncl min] q lstn; apply/iseg_subl/lstn_iseg_S/cncl/lstn_melt. Qed.
End initial_segments.

Require Import Psatz.

Section naturals.
  Lemma seg_iota n k: segment id n (n + k) = rev (iota n k.+1).
  Proof.
    elim: k n => [n | k ih n]; first by rewrite addn0 /segment /= subSn // subnn /= addn0 /rev /=.
    rewrite seg_recl; last exact/leq_addr.
    have ->: rev (iota n k.+2) = rev (iota n.+1 k.+1) ++ [:: n] by rewrite /rev /= -catrev_catr /=.
    rewrite -ih addSn addnS; f_equal.
    by rewrite /segment subSn // subnn /= addn0.
  Qed.

  Lemma seg_map Q (cnt: nat -> Q) n k: segment cnt n (n + k) = map cnt (segment id n (n + k)).
  Proof.
    elim: k => [ | k].
    by rewrite /segment subSn addn0// subnn /=.
    rewrite addnS/segment => ih.
    rewrite subSn /=; first by f_equal; rewrite ih.
    rewrite -addnS.
    exact/leq_addr.
  Qed.

  Definition init_seg:= iseg id.

  Lemma iseg_iota n: init_seg n = rev (iota 0 n).
  Proof. by case: n => //n; rewrite /init_seg iseg_seg seg_iota. Qed.

  Lemma iseg_eq T (cnt cnt':nat -> T) n:
    iseg cnt n = iseg cnt' n <-> (forall i, i< n -> cnt i = cnt' i).
  Proof.
    split.
    elim: n => // n ih /= [eq eq'] i.
      by rewrite leq_eqVlt; case/orP => [/eqP [->] | ]; last exact/ih.
    elim: n => // n ih prp /=.
    rewrite ih => [ | i ineq]; first f_equal; apply/prp => //.
    exact/leqW.
  Qed.

  (* Most code from this section was provided by Vincent *)
  Context (p: nat -> bool).

  Let Fixpoint searchU m k : nat :=
    match k with
    | 0 => m
    | k'.+1 => let n := m - k in if p n then n else searchU m k'
    end.

  Lemma searchUS m k: k<= m ->
    searchU m.+1 k.+1 = if searchU m k != m then searchU m k else
                          if p m then m else m.+1.
  Proof.
    rewrite /= subSS.
    elim: k => [ | k ih klm]; first by rewrite /= subn0; have ->: m != m = false by apply/eqP.
    rewrite /=.
    case: ifP; first by case: ifP => // /eqP -> ->.
    rewrite subSS ih.
    case: ifP => //.
    by apply/leq_trans/klm.
  Qed.

  Let searchU_find m k: k <= m ->
    searchU m k = if has p (iota (m - k) k) then find p (iota (m - k) k) + (m - k) else m.
  Proof.
    elim: k => // k ih ineq.
    rewrite [LHS]/= ih; last exact/leq_trans/ineq.
    case: ifP => [pmk | ].
    - case: ifP => [_ | ]//; first by rewrite /= pmk add0n.
      rewrite /= => /orP neg.
      by exfalso; apply/neg; left.
    move => pmk.
    rewrite /= subnSK //.
    case: ifP => hs.
    - case: ifP => [_ | /orP neg]; last by exfalso; apply/neg; right.
      by rewrite pmk addSn -addnS subnSK//.
    by case: ifP => // /orP; first by rewrite pmk; case.
  Qed.

  Let searchU_correct m k :
    p m -> p (searchU m k).
  Proof.
    move => hm.
    by elim: k => // n ih /=; case: ifP.
  Qed.

  Let searchU_le m k :
    searchU m k <= m.
  Proof.
    elim: k => // n ih /=; case: ifP => // _.
    rewrite /subn /subn_rec; apply /leP; lia.
  Qed.

  Let searchU_minimal m k :
    (forall n, p n -> m - k <= n) -> forall n, p n -> searchU m k <= n.
  Proof.
    elim: k.
    - move => h n /=; rewrite -(subn0 m); exact: h.
      move => k ih h n /=; case: ifP.
    - move => _; exact: h.
      move => hk; apply: ih => i hi.
      case: (i =P m - k.+1).
      move => eq.
      rewrite -eq in hk.
      by rewrite hk in hi.
    move: (h i hi).
    by rewrite /subn /subn_rec => /leP prp cnd; apply/leP; lia.
  Qed.

  Let searchU_fail m k:
    (forall n, p n -> m < n) -> searchU m k = m.
  Proof.
    elim: k => //k ih prp /=.
    case: ifP => [pm | neg]; last exact/ih/prp.
    have:= prp (m-k.+1) pm.
    by rewrite ltn_subRL -{2}(add0n m) ltn_add2r.
  Qed.

  Definition search n := searchU n n.

  Lemma search_correct n: p n -> p (search n).
  Proof. exact: searchU_correct. Qed.

  Lemma search_le n: search n <= n.
  Proof. exact: searchU_le. Qed.

  Lemma search_min n m:	p m -> search n <= m.
  Proof.
    apply searchU_minimal => k pk.
    by rewrite /subn/subn_rec; apply/leP; lia.
  Qed.

  Lemma worder_nat:
    (exists n, p n) -> exists n, p n /\ forall m, p m -> n <= m.
  Proof.
    move => [m pm].
    exists (search m ).
    split; first exact: search_correct.
    exact: search_min.
  Qed.

  Lemma not_has_find T q (s: seq T): ~~ has q s -> find q s = size s.
  Proof.
    rewrite has_find => ass.
    suff /leP ineq: size s <= find q s by have /leP ineq':= find_size q s; lia.
    by rewrite leqNgt.
  Qed.

  Lemma search_find n: search n = find p (iota 0 n).
  Proof.
    rewrite /search searchU_find; last exact/leqnn.
    rewrite subnn addn0; case: ifP => //.
    elim: n => // n ih neg.
    by rewrite not_has_find; [rewrite size_iota | rewrite neg].
  Qed.

  Lemma search_fail n: (forall m, p m -> n < m) -> search n = n.
  Proof. exact/searchU_fail. Qed.

  Lemma searchS n :
    search n.+1 = if search n != n then search n else if p n then n  else n.+1.
  Proof. by rewrite /search searchUS. Qed.

  Lemma search_inc n m: n <= m -> search n <= search m.
  Proof.
    elim: m => [ | m ih].
    by rewrite leqn0 => /eqP ->.
    rewrite leq_eqVlt; case/orP => [ /eqP -> | ineq]//.
    apply/leq_trans; first exact/ih.
    rewrite searchS.
    case: ifP => // /eqP ->.
    by case: ifP.
  Qed.

  Lemma search_eq m n: p m -> (m <= n)%nat -> search m = search n.
  Proof.
    move => pm ineq; apply/eqP; rewrite eqn_leq; apply/andP.
    by split; [apply/search_inc | apply/search_min/search_correct].
  Qed.

End naturals.

Lemma search_ext (p p': pred nat) n:
  (forall k, (k < n)%nat -> p k = p' k) -> search p n = search p' n.
Proof.
  rewrite !search_find => ass.
  apply/eq_in_find => k.
  rewrite mem_iota add0n => /andP [_ ineq].
  exact/ass.
Qed.

Section countTypes.
  Context (Q: countType) (noq: Q) (noq_spec: pickle noq = 0).

  Definition inverse_pickle n:= match pickle_inv Q n with
	                        | Some q => q
	                        | None => noq
                                end.

  Lemma min_ip: minimal_section inverse_pickle pickle.
  Proof.
    rewrite /inverse_pickle; split => [q | q n <-]; first by rewrite pickleK_inv.
    case E: pickle_inv => [a  | ]; last by rewrite noq_spec.
    by have := pickle_invK Q n; rewrite /oapp E => <-.
Qed.
End countTypes.


Require Import QArith.
Require Import primitives.

(* AUXILIARY FUNCTIONS *)

Fixpoint bezier_curve_init (b : bezier_curve) : bezier_curve :=
  match b with
    | [P0] => [P0]
    | Pi :: [P0] => [Pi]
    | Pi :: b' => Pi :: (bezier_curve_init b')
  end.

Fixpoint bezier_curve_tail (b : bezier_curve) : bezier_curve :=
  match b with
    | [P0] => [P0]
    | Pi :: b' => b'
  end.

Fixpoint bezier_curve_length (b : bezier_curve) : nat :=
  match b with
    | [P0] => 1%nat
    | P0 :: b' =>  S (bezier_curve_length b')
  end.

Fixpoint bezier_curve_head (b : bezier_curve) : point :=
  match b with
    | [P0] => P0
    | P0 :: _ => P0
  end.

(*
  TODO: add some examples
*)

(*
  fact_pos : Given a natural n,
              returns n! as a positive

  This function is necessary due to Coq's
  recursive definition of a natural number,
  which easily causes a 'stack overflow'
  for larger computations.
*)
Fixpoint fact_pos (n : nat) : positive :=
  match n with
    | O => 1
    | S n' => (Pos.of_nat n) * (fact_pos n')
  end.

(*
  pow : Given a natural n and a rational q,
              returns q^n as a rational.
*)
Fixpoint pow (x : Q) (n : nat) : Q :=
  match n with
    | O => 1
    | S n' => Qmult x (pow x n')
  end.

(*
  minus_1_sgn : Given a natural exp,
              returns (-1)^exp.
*)
Definition minus_1_sgn (exp : nat) : Q :=
  match (Nat.even exp) with
    | true => 1
    | false => inject_Z (-1)
  end.

Fixpoint calc_binomial_pos (n p : nat) : positive :=
  match p with
  | O => 1%positive
  | S p' =>
      match Nat.eqb n p with
      | true => 1%positive
      | false =>
          match n with
          | S n' => (calc_binomial_pos n' p') + (calc_binomial_pos n' (S p'))
          | _ => 1%positive
          end
      end
  end.

Fixpoint app (l r : bezier_curve) : bezier_curve :=
  match l with
  | [h] => h :: r
  | h :: t => h :: app t r
  end.

Infix "++" := app (right associativity, at level 60).

Fixpoint rev (b : bezier_curve) : bezier_curve :=
  match b with
  | [h] => [h]
  | h :: t => (rev t) ++ [h]
  end.