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

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

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

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

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

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.
Lemma lem : forall (x : lst) (y : natural), eq (rev (append x (Cons y Nil))) (Cons y (rev x)).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst) (z : natural), eq (rev (append x (append y (Cons z Nil)))) (Cons z (rev (append x y))).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros.  simpl. lfind.
Admitted.


Require Coq.Lists.List.
Require Coq.Lists.SetoidList.

Theorem InA_In : forall (A : Type) (x : A) (xs : list A),
  SetoidList.InA (@eq _) x xs -> List.In x xs.
Proof.
  induction xs as [|y ys]. {
    intros H_in.
    inversion H_in.
  } {
    intros H_in.
    inversion H_in.
    subst; simpl in *; auto.
    subst; simpl in *; auto.
  }
Qed.

Lemma InMapPair : forall (A B : Type) (x : A) (y : B) es,
  List.In (x, y) es ->
    List.In x (List.map fst es) /\ List.In y (List.map snd es).
Proof.
  induction es as [|f fs]. {
    intros H_f0.
    inversion H_f0.
  } {
    intros H_in0.
    destruct H_in0 as [H_inL|H_inR]. {
      constructor; (left; destruct f as [f0 f1]; rewrite H_inL; reflexivity).
    } {
      constructor; (right; destruct (IHfs H_inR) as [H0 H1]; auto).
    }
  }
Qed.


(********************)
(********************)
(****            ****)
(****   Syntax   ****)
(****            ****)
(********************)
(********************)

Require Import Main.SystemF.Name.

Inductive term :=
| eFreeVar : name -> term
| eBoundVar : nat -> term
| eAbs : type -> term -> term
| eApp : term -> term -> term
| eTAbs : term -> term
| eTApp : term -> type -> term

with type :=
| tFreeVar : name -> type
| tBoundVar : nat -> type
| tArrow : type -> type -> type
| tForAll : type -> type.


(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import all_ssreflect ssralg finalg poly polydiv cyclic.
From mathcomp Require Import perm matrix mxpoly vector mxalgebra zmodp.
Require Import ssr_ext ssralg_ext poly_ext channel_code decoding linearcode.
Require Import hamming dft poly_decoding euclid grs cyclic_code.

(******************************************************************************)
(*                        Reed-Solomon codes                                  *)
(*                                                                            *)
(* The main result of this file is the proof that Reed-Solomon codes          *)
(* implement bounded-distance decoding (Lemma RS_repair_is_correct).          *)
(*                                                                            *)
(* Main references:                                                           *)
(* - Robert McEliece, The Theory of Information and Coding,  Cambridge        *)
(*   University Press, 2002                                                   *)
(* - Manabu Hagiwara, Coding Theory: Mathematics for Digital Communication,   *)
(*   Nippon Hyoron Sha, 2012 (in Japanese)                                    *)
(******************************************************************************)

(** OUTLINE
- Section reed_solomon_min_dist_errors.
- Module RS.
  + Section reed_solomon_def.
  + Section reed_solomon_prop.
- Section RS_generator_def.
- Section RS_is_GRS.
- Section reed_solomon_key_equation.
- Section RS_decoding_procedure.
- Section RS_generator_prop0.
- Section RS_generator_prop1.
- Section RS_generator_prop.
- Section RS_decoding_using_euclid0.
- Section RS_decoding_using_euclid.
- Module RS_encoder.
- Section RS_cyclic.
*)

Reserved Notation "'\RSsynp_(' a , y , t )" (at level 3).
Reserved Notation "'\RSomega_(' a , e )" (at level 3).
Reserved Notation "'\gen_(' a , d )" (at level 3).

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

Import GRing.Theory.
Local Open Scope ring_scope.
Local Open Scope dft_scope.

Module RS.

Local Notation "'\RSsynp_(' a , y , t )" := (syndromep a y t).
Local Notation "'\RSomega_(' a , e )" := (erreval a a e).

Local Open Scope vec_ext_scope.

Section reed_solomon_min_dist_errors.

Variables (t d n : nat).

Definition redundancy_ub := d < n. (* definition of RS *)
Definition errors_ub := t <= d./2. (* necessary condition to decode t errors *)

End reed_solomon_min_dist_errors.

Section reed_solomon_def.

Variables (F : finFieldType) (a : F) (n d : nat).

Definition PCM : 'M[F]_(d, n) := \matrix_(i, j) (a ^+ i.+1) ^+ j.

Definition code : {vspace _} := kernel PCM.

End reed_solomon_def.

Section reed_solomon_prop.

Variables (F : finFieldType) (a : F) (n' : nat).
Let n := n'.+1.
Variable d : nat.
Hypothesis dn : redundancy_ub d n.
Hypothesis a_neq0 : a != 0.
Hypothesis a_not_uroot_on : not_uroot_on a n.

Lemma uniq_roots_exp : uniq_roots [seq a ^+ i | i <- iota 1 d].
Proof.
rewrite uniq_rootsE map_inj_in_uniq; first by rewrite iota_uniq.
move=> i j.
rewrite !mem_iota addnC addn1 => H1.
move: H1 => // /andP[_ Hid] /andP [_ Hjd] /eqP aij.
apply/eqP.
by rewrite (val_eqE (Ordinal (leq_trans _ dn)) (Ordinal (leq_trans _ dn))) -(exp_inj a_neq0).
Qed.

Local Notation "v ^`_ i" := (v ^`_(rVexp a n, i)) (at level 9).

Definition codebook :=
  [set c : 'rV_n | [forall i : 'I_d.+1, (0 < i) ==> (c ^`_ (inord i) == 0)] ].

Lemma all_root_codeword c : c \in codebook ->
  all (root (rVpoly c)) [seq a ^+ i | i <- iota 1 d].
Proof.
rewrite inE => /forallP H.
apply/allP => x /mapP[i].
rewrite mem_iota addnC addn1 => H1.
move: H1 => // id ->.
apply/rootP.
case/andP : id => i0 id.
move: (H (Ordinal id)); rewrite i0 implyTb => /eqP.
by rewrite /fdcoor mxE inordK // (leq_trans id).
Qed.

Lemma deg_lb c : c \in codebook -> (c == 0) || (d.+1 <= size (rVpoly c)).
Proof.
move=> H.
case/boolP : (c == 0) => //=.
rewrite -rVpoly0 => c0.
move: (uniq_roots_exp); rewrite uniq_rootsE.
move/(max_poly_roots c0 (all_root_codeword H)).
by rewrite size_map size_iota -ltnS.
Qed.

Lemma O_in_codebook : 0 \in codebook.
Proof.
rewrite inE; apply/forallP => i; apply/implyP => i0; by rewrite fdcoor0.
Qed.

Lemma oppr_closed : oppr_closed codebook.
Proof.
move=> /= c; rewrite inE => /forallP H.
rewrite inE; apply/forallP => i; apply/implyP => i0.
rewrite fdcoorN eqr_oppLR oppr0; move: (H i); by rewrite i0 implyTb.
Qed.

Lemma addr_closed : addr_closed codebook.
Proof.
split; [exact: O_in_codebook | move=> x y].
have [xy|xy] := boolP (x + y == 0); first by rewrite /= (eqP xy) O_in_codebook.
rewrite inE => /forallP H1; rewrite inE => /forallP H2.
rewrite inE; apply/forallP => i; apply/implyP => i0.
rewrite fdcoorD.
move: (H1 i) (H2 i); by rewrite i0 2!implyTb => /eqP-> /eqP->; rewrite addr0.
Qed.

Lemma scaler_closed : GRing.scaler_closed codebook.
Proof.
move=> k x; rewrite !inE => /forallP xC.
apply/forallP => /= i; apply/implyP => i0.
rewrite tdcoorZ; move: (xC i); rewrite i0 implyTb => /eqP ->; by rewrite mulr0.
Qed.

Lemma submod_closed : submod_closed codebook.
Proof.
split=> [|k x y xC yCby]; first exact: O_in_codebook.
by rewrite (proj2 addr_closed) // scaler_closed.
Qed.

Lemma syndrome_syndromep y :
  syndrome (PCM a n d) y = poly_rV \RSsynp_(rVexp a n, y, d).
Proof.
apply/rowP => i; rewrite !mxE /syndromep poly_def coef_sum.
evar (tmp : 'I_d -> F); transitivity (\sum_j (tmp j)); last first.
  apply eq_bigr => /= j _.
  apply/esym; rewrite /fdcoor coefZ horner_poly big_distrl /= /tmp; reflexivity.
rewrite {}/tmp (exchange_big_dep xpredT) //=; apply eq_bigr => j _; rewrite !mxE.
have @i' :  'I_d.
  by apply (@Ordinal _ i); rewrite (leq_trans (ltn_ord i)).
rewrite (bigD1 i') //= coefXn insubT //= => Hj.
rewrite eqxx mulr1 (_ : Ordinal Hj = j); last by apply val_inj.
rewrite mxE inordK; last by rewrite ltnS (leq_trans (ltn_ord i)).
rewrite mulrC; apply/eqP.
rewrite addrC -subr_eq subrr; apply/eqP/esym.
rewrite big1 // => k ki'; rewrite coefXn (_ : (_ == _) = false) ?mulr0 //.
by apply: contraNF ki'; rewrite -val_eqE /= eq_sym.
Qed.

Lemma codebook_syndrome (c : 'rV_n) :
  (c \in codebook) = (syndrome (PCM a n d) c == 0).
Proof.
rewrite syndrome_syndromep inE; apply/idP/idP.
- move/forallP => H; apply/eqP/rowP => i; rewrite !mxE.
  rewrite /syndromep /poly_decoding.syndromep poly_def coef_sum.
  rewrite (eq_bigr (fun=> 0)) ?big_const ?iter_addr0 // => j _.
  rewrite coefZ; apply/eqP; rewrite mulf_eq0.
  have @j' : 'I_d.+1.
    by apply (@Ordinal _ j.+1); move: (ltn_ord j); rewrite -ltnS.
  move: (H j'); by rewrite lt0n /= => ->.
- move/eqP/rowP => H.
  apply/forallP => /= i; apply/implyP => i0.
  have @i' : 'I_d.
    apply (@Ordinal _ i.-1).
    by rewrite prednK // -ltnS.
  move: (H i'); rewrite !mxE.
  rewrite /syndromep /poly_decoding.syndromep.
  rewrite coef_poly ltn_ord => /eqP /=.
  by rewrite prednK.
Qed.

Lemma lcode0_codebook : [set cw in code a n d] = codebook.
Proof.
by apply/setP => /= x; rewrite inE mem_kernel_syndrome0 codebook_syndrome.
Qed.

Lemma RS_syndromep_codeword' t (tr : t < d.+1) (c : 'rV[F]_n) :
  c \in codebook -> \RSsynp_(rVexp a n, c, t) = 0.
Proof.
rewrite inE // => /forallP H.
rewrite /syndromep /poly_decoding.syndromep poly_def (eq_bigr \0) ?big1 //.
move=> i _.
have [:tmp] @j : 'I_d.+1.
  apply/(Sub i.+1)/(leq_ltn_trans (ltn_ord _)).
  abstract: tmp.
  exact tr.
by move: (H j) => /= /eqP ->; rewrite scale0r.
Qed.

Lemma RS_syndromep_codeword (c : 'rV[F]_n) :
  (\RSsynp_(rVexp a n, c, d) == 0) = (c \in codebook).
Proof.
apply/idP/idP => [/eqP | ]; last first.
  by move/(@RS_syndromep_codeword' d) => /(_ (ltnSn _)) ->.
rewrite codebook_syndrome syndrome_syndromep => /eqP ?.
by rewrite poly_rV_0.
Qed.

End reed_solomon_prop.
End RS.

Notation "'\RSsynp_(' a , e , t )" := (syndromep a e t).
Notation "'\RSomega_(' a , e )" := (erreval a a e).

Local Open Scope vec_ext_scope.

Section RS_generator_def.

Variables (F : finFieldType) (a : F) (d : nat).

Definition rs_gen := \prod_(1 <= i < d.+1) ('X - (a ^+ i)%:P).

End RS_generator_def.

Notation "'\gen_(' a , d )" := (rs_gen a d).

(** Reed-Solomon codes are an instance of GRS codes. Take a and b to
be \alpha^j to get conventional RS codes. *)
Section RS_is_GRS.

Variables (F : finFieldType) (n' : nat).
Let n := n'.+1.
Variables (a : F) (d : nat).

Let b : 'rV[F]_n := rVexp a n.

Lemma RS_GRS_PCM : GRS.PCM b b d = RS.PCM a n d.
Proof.
apply/matrixP => i j.
rewrite !mxE (bigD1 j) //= !mxE eqxx mulr1n -exprSr -exprM mulnC exprM.
rewrite (eq_bigr (fun=> 0)) ?big_const ?iter_addr0 ?addr0 // => k kj.
by rewrite !mxE (negbTE kj) mulr0n mulr0.
Qed.

Lemma fdcoor_GRS_syndrome_coor y l : l < n' -> l < d ->
  fdcoor b y (inord l.+1) = GRS.syndrome_coord b b l y.
Proof.
move=> ln id1.
rewrite /fdcoor /GRS.syndrome_coord horner_poly; apply/eq_bigr => /= j _.
rewrite insubT // => jn.
rewrite 2!mxE -mulrA; congr (y ord0 _ * _); first by apply val_inj.
by rewrite -exprS -exprM mulnC exprM inordK.
Qed.

Lemma RS_GRS_syndromep y : RS.redundancy_ub d n ->
  \RSsynp_(b, y, d) = (GRS.syndromep b b d) y.
Proof.
move=> dn; rewrite /GRS.syndromep /poly_decoding.syndromep.
apply/polyP => i.
rewrite 2!coef_poly; case: ifP => // id1.
by rewrite fdcoor_GRS_syndrome_coor // (leq_trans id1).
Qed.

End RS_is_GRS.

Section reed_solomon_key_equation.

Variables (F : finFieldType) (a : F) (n' : nat).
Let n := n'.+1.
Variable t : nat.

Hypothesis tn : t < n.

Definition RS_mod (y : 'rV[F]_n) t := - \sum_(i in supp y) y ``_ i *:
  (\prod_(j in supp y :\ i) (1 - a ^+ j *: 'X) * - (a ^+ (t.+1 * i))%:P).

Lemma RS_mod_is_GRS_mod y : RS_mod y t = - GRS_mod y (rVexp a n) (rVexp a n) t.
Proof.
rewrite /RS_mod /GRS_mod; congr (- _); apply/eq_bigr => /= i iy.
rewrite !mulrN scalerN; congr (- _).
rewrite -!scalerAl; congr (_ *: _ ).
rewrite -mulrA; congr (_ * _).
  apply eq_big.
    by move=> j; rewrite in_setD1 andbC.
  by move=> j; rewrite mxE.
by rewrite mxE -polyCM -exprSr -exprM mulnC.
Qed.

Lemma RS_key_equation y :
  \sigma_(rVexp a n, y) * \RSsynp_(rVexp a n, y, t) =
  \RSomega_(rVexp a n, y) + - RS_mod y t * 'X^t.
Proof.
move: (@RS_GRS_syndromep F n' a t y tn) => H0.
move: (GRS_key_equation y (rVexp a n) (rVexp a n) t).
rewrite -{}H0 => ->; by rewrite RS_mod_is_GRS_mod opprK.
Qed.

End reed_solomon_key_equation.

Section RS_decoding_procedure.

Variables (F : finFieldType) (a : F) (n' : nat).
Let n := n'.+1.
Variable d : nat.
Let t := d./2.
Hypothesis dn : RS.redundancy_ub d n.

Let td : t <= d. Proof. by rewrite /t -divn2 leq_div. Qed.

Local Notation "'v'" := (Euclid.v).
Local Notation "'r'" := (Euclid.r).

Definition RS_err y : {poly F} :=
  let r0 : {poly F} := 'X^d in
  let r1 := \RSsynp_(rVexp a n, y, d) in
  let vstop := v r0 r1 (stop (odd d + t) r0 r1) in
  let rstop := r r0 r1 (stop (odd d + t) r0 r1) in
  let s := vstop.[0]^-1 *: vstop in
  let w := vstop.[0]^-1 *: rstop in
  \poly_(i < n) (if s.[a^- i] == 0 then - w.[a ^- i] / s^`().[a ^- i] else 0).

Definition RS_repair : repairT F F n := [ffun y =>
  if \RSsynp_(rVexp a n, y, d) == 0 then
    Some y
  else
    let ret := y - poly_rV (RS_err y) in
    if \RSsynp_(rVexp a n, ret, d) == 0 then Some ret else None].

End RS_decoding_procedure.

(* TODO: move? *)
Lemma leqnmul2 k : k <= k.*2.
Proof. by rewrite -addnn leq_addr. Qed.

Section RS_generator_prop0.

Variables (F : finFieldType) (a : F) (n' : nat) (d : nat).
Let n := n'.+1.

Lemma size_rs_gen : size \gen_(a, d) = d.+1.
Proof. by rewrite size_prod_XsubC size_iota subn1 prednK. Qed.

Lemma wH_rs_gen : wH (poly_rV \gen_(a, d) : 'rV[F]_n) <= d.+1.
Proof.
by rewrite (leq_trans (wH_poly_rV _ _)) // size_rs_gen.
Qed.

Lemma gen_neq0 : \gen_(a, d) != 0.
Proof. by rewrite -size_poly_gt0 size_rs_gen. Qed.

Lemma fdcoor_codeword (n0 : 'I_d.+1) (Hn0 : 0 < n0 < n) (m : {poly F}) :
  size (m * \gen_(a, d)) <= n ->
  (poly_rV (m * \gen_(a, d)) : 'rV_n)^`_(rVexp a n, inord n0) == 0.
Proof.
move=> mn.
rewrite /fdcoor poly_rV_K // !hornerE.
rewrite mxE inordK; last first.
  by case/andP : Hn0.
case Hm : (m.[a ^+ n0] == 0); first by rewrite (eqP Hm) mul0r.
apply negbT in Hm.
rewrite mulrI_eq0; last by move : Hm => /lregP.
rewrite -rootE.
pose rs := [seq (a ^+ i) | i <- iota 1 d].
rewrite /rs_gen.
have -> : \prod_(1 <= n1 < d.+1) ('X - (a ^+ n1)%:P) = \prod_(a <- rs) ('X - a%:P)
  by rewrite /rs big_map /index_iota subn1.
rewrite root_prod_XsubC /rs.
apply/mapP; exists (val n0) => //.
rewrite mem_iota.
case/andP : Hn0 => -> _.
rewrite addnC addn1 /=; by apply ltn_ord.
Qed.

Hypothesis dn : RS.redundancy_ub d n.

Lemma mem_rs_gen_RS : poly_rV \gen_(a, d) \in RS.code a n d.
Proof.
rewrite mem_kernel_syndrome0 -RS.codebook_syndrome // inE.
apply/forallP => /= i; apply/implyP => i0.
rewrite -(mul1r \gen_(a, d)) fdcoor_codeword //.
  by rewrite i0 /= (leq_trans (ltn_ord i)) //.
rewrite mul1r size_rs_gen; exact: dn.
Qed.

Lemma RS_not_trivial : not_trivial (RS.code a n d).
Proof.
rewrite /not_trivial.
exists (poly_rV (rs_gen a d)); apply/andP; split.
- by rewrite mem_rs_gen_RS.
- apply/negP => /poly_rV_0_inv.
  rewrite size_rs_gen => /(_ dn).
  apply/negP; by rewrite gen_neq0.
Qed.

Lemma RS_message_size (p : 'rV_n) x : rVpoly p = x * \gen_(a, d) ->
  (size x).-1 <= n - d.+1.
Proof.
move=> Hx.
case/boolP : (x == 0) => [/eqP ->|x0]; first by rewrite size_poly0.
have : size (rVpoly p) <= n by rewrite size_poly.
rewrite Hx size_mul // ?gen_neq0 // => H.
rewrite -(leq_add2r d.+1) (subnK dn) (leq_trans _ H) //.
rewrite -subn1 addnC addnBA; last by rewrite lt0n size_poly_eq0.
by rewrite -subn1 addnC leq_sub2r // leq_add2l size_rs_gen.
Qed.

End RS_generator_prop0.

Section RS_generator_prop1.

Variables q m' : nat.
Hypothesis primeq : prime q.
Let F := GF m' primeq.
Variables (a : F) (n' : nat) (d : nat).
Let n := n'.+1.

Hypothesis dn : RS.redundancy_ub d n.
Hypothesis qn : ~~ (q %| n)%nat.

Lemma RS_Hchar : ([char F]^').-nat n.
Proof. by rewrite -natf_neq0 -(@dvdn_charf _ q) ?char_GFqm. Qed.

Lemma RS_min_dist1 c : n.-primitive_root a -> c != 0 ->
  c \in RS.code a n d -> d.+1 <= wH c.
Proof.
move=> an c0 Hc.
have a_neq0 := primitive_uroot_neq0 an.
rewrite -(wH_phase_shift a_neq0 _ d).
apply: (@BCH_argument_lemma _ _ (@GRing.idfun_rmorphism F) _ RS_Hchar _ an
  (phase_shift a c d.+1) _ dn).
  by rewrite -wH_eq0 wH_phase_shift // wH_eq0.
rewrite (_ : \row_i0 (GRing.idfun_rmorphism F) ((phase_shift a c d.+1) ``_ i0) =
  phase_shift a c d.+1); last by apply/rowP => i; rewrite !mxE.
apply (dft_shifting a_neq0 (prim_expr_order an) dn) => i /andP[ir1 ir2].
have {Hc} : c \in RS.codebook a n' d by rewrite -(RS.lcode0_codebook a dn) inE.
rewrite inE => /forallP/(_ (Ordinal ir2)) /=.
by rewrite ir1 implyTb !mxE => /eqP.
Qed.

Lemma RS_min_dist : n.-primitive_root a ->
  min_dist (RS_not_trivial a dn) = d.+1.
Proof.
move=> na.
apply min_distP; split; first by move=> *; apply RS_min_dist1.
exists (poly_rV \gen_(a, d)); split; first by rewrite mem_rs_gen_RS.
apply/andP; rewrite wH_rs_gen andbT.
apply: contra (gen_neq0 a d).
move/poly_rV_0_inv; apply; by rewrite size_rs_gen.
Qed.

Lemma PCM_lin1_mx :
  RS.PCM a n d = (lin1_mx (linfun (lin_syndrome (RS.PCM a n d))))^T.
Proof.
apply/matrixP => i j.
rewrite !(mxE,lfunE) (bigD1 j) //= !mxE !eqxx mulr1 (eq_bigr (fun=> 0)).
- by rewrite big_const iter_addr0 addr0.
- move=> k kj; by rewrite !mxE eqxx (negbTE kj) mulr0.
Qed.

Lemma dim_RS_code (a0 : a != 0) (auroot : not_uroot_on a n) :
  \dim (RS.code a n d) = (n - d)%N.
Proof.
apply dim_kernel; last by rewrite ltnW.
rewrite -RS_GRS_PCM rank_GRS_PCM //.
- by apply (@rVexp_inj _ _ _ a0 auroot).
- by rewrite ltnW.
- move=> i; by rewrite mxE expf_neq0.
Qed.

Lemma RS_MDS : n.-primitive_root a ->
  maximum_distance_separable (RS_not_trivial a dn).
Proof.
move=> an.
rewrite /maximum_distance_separable RS_min_dist // addn1 dim_RS_code //.
- by rewrite subKn // ltnW.
- exact: primitive_uroot_neq0 an.
- by apply prim_root_not_uroot_on.
Qed.

End RS_generator_prop1.

Section RS_generator_prop.

Variable (F : finFieldType) (a : F).
Variables (d : nat) (n' : nat).
Let n := n'.+1.
Hypothesis dn : RS.redundancy_ub d n.
Hypothesis a_neq0 : a != 0.
Hypothesis a_not_uroot_on : not_uroot_on a n.

Lemma rs_genP (c : 'rV[F]_n) : c \in RS.codebook a n' d
  <-> exists m : {poly F}, (size m).-1 <= n - d.+1 /\ rVpoly c = m * \gen_(a, d).
Proof.
split => [c_in_RS| [m [H0 H1]] ]; last first.
  rewrite /RS.codebook inE.
  apply/forallP => n0; apply/implyP => Hn0.
  rewrite -(rVpolyK c) H1 fdcoor_codeword //.
    rewrite Hn0 /= (leq_trans (ltn_ord n0)) //.
    by rewrite -H1 size_poly.
case/boolP : (c == 0) => [/eqP ->|Hc].
  exists 0; by rewrite size_poly0 -subn1 sub0n leq0n mul0r linear0.
have Hc' : 0 < size (rVpoly c) by rewrite size_poly_gt0 rVpoly0.
have H1 : forall i, 1 <= i < d.+1 -> (rVpoly c).[a ^+ i] = 0.
  move=> i /andP[i0 id].
  move: c_in_RS; rewrite inE => /forallP/(_ (Ordinal id)); rewrite i0 implyTb /fdcoor // => /eqP.
  by rewrite mxE /= inordK // (leq_trans id).
have H2 : forall n0, 1 <= n0 < d.+1 -> 'X - (a ^+ n0)%:P %| rVpoly c.
  move=> n0 /H1 /eqP /factor_theorem [x ->].
  by rewrite dvdp_mull.
pose rs := [seq (a ^+ i) | i <- iota 1 d].
have K1 : all (root (rVpoly c)) rs by apply RS.all_root_codeword.
have K2 : uniq_roots rs by apply: (@RS.uniq_roots_exp _ _ n').
case: (uniq_roots_prod_XsubC K1 K2) => m.
have -> : \prod_(z <- rs) ('X - z%:P) = \gen_(a, d).
  by rewrite /rs_gen /rs big_map /index_iota subn1.
have Hg := size_rs_gen a d.
have Hg' : 0 < size \gen_(a, d) by rewrite Hg.
have Hg'' := gen_neq0 a d.
move => Hm.
have Hm' : m != 0.
  move : Hm => /eqP.
  apply contraLR => /negPn/eqP ->; by rewrite mul0r rVpoly0.
have Hm'' : 0 < size m by rewrite size_poly_gt0.
exists m; split; [| by rewrite Hm].
have : size (rVpoly c) <= n by apply size_poly.
rewrite Hm.
move : (size_mul_leq m \gen_(a, d)) => Hmg.
rewrite size_mul // -!subn1 addnC -addnBA // addnC.
move /(leq_sub2r d.+1).
rewrite Hg.
by move : (addnK d.+1 (size m - 1)%N) => ->.
Qed.

Local Open Scope cyclic_code_scope.

Lemma rs_gen_is_pgen : \gen_(a, d) \in 'pgen[RS.codebook a n' d].
Proof.
apply/forallP => cw; apply/eqP; apply/idP/idP.
  case/rs_genP => x [sz_x ->]; by rewrite dvdp_mulIr.
rewrite dvdp_eq => /eqP H; apply/rs_genP.
exists (rVpoly cw %/ \gen_(a, d)); split => //.
rewrite size_divp ?gen_neq0 // size_rs_gen.
by rewrite -subnS /= leq_sub2r // size_poly.
Qed.

End RS_generator_prop.

Section RS_decoding_using_euclid0.

Variables (F : finFieldType) (a : F) (n' : nat).
Let n := n'.+1.
Variable d : nat.
Let t := d./2.

Hypothesis dn : RS.redundancy_ub d n.

Hypothesis a_neq0 : a != 0.
Hypothesis a_not_uroot_on : not_uroot_on a n.

Let tn : t.*2 < n.
Proof.
by rewrite /t (leq_trans _ dn) // ltnS -{2}(odd_double_half d) leq_addl.
Qed.

(* TODO: clean *)
Lemma td : RS.errors_ub t d.+1.
Proof.
by rewrite /RS.errors_ub /t half_leq.
Qed.

Lemma RS_err_is_correct l (e y : 'rV_n) :
  distinct_non_zero (rVexp a n) ->
  let r0 := 'X^d : {poly F} in
  let r1 := \RSsynp_(rVexp a n, y, d) in
  let vj := Euclid.v r0 r1 (stop (odd d + t) r0 r1) in
  let rj := Euclid.r r0 r1 (stop (odd d + t) r0 r1) in
  l <> 0 ->
  vj = l *: \sigma_(rVexp a n, e) ->
  rj = l *: \RSomega_(rVexp a n, e) ->
  e = poly_rV (RS_err a d y).
Proof.
move=> H1 r0 r1 vj rj /eqP l0 Hvj Hrj; apply/rowP => i.
rewrite mxE coef_poly ltn_ord -/r0 -/r1 -/vj -/rj; case: ifPn => H.
  apply: (@mulIf _ ((rVexp a n) ``_ i)).
    by rewrite mxE expf_eq0 negb_and a_neq0 orbT.
  rewrite (erreval_vecE H1 (rVexp a n)) //; last first.
    rewrite -(errloc_zero _ _ H1) mxE.
    move: H; rewrite Hvj !hornerZ !mulrA mulf_eq0 => /orP[|//].
    rewrite mulf_eq0 (negbTE l0) orbF invr_eq0 mulf_eq0 (negbTE l0) orFb.
    by rewrite horner_errloc_0 oner_eq0.
  rewrite 2![in RHS]mulNr -[in RHS]mulrN [in RHS]mulrC -mulrA; congr (_ * _).
  rewrite Hvj Hrj -/(\RSomega_(rVexp a n, e)) mxE !scalerA !(hornerZ,derivZ).
  set x := (_^-1 * _).
  rewrite -mulf_div divrr ?mul1r // unitfE mulf_neq0 //.
  by rewrite invr_neq0 // mulf_neq0 // horner_errloc_0 oner_neq0.
apply/eqP; apply: contraNT H.
rewrite -insupp -(errloc_zero _ _ H1) mxE Hvj !hornerZ => /eqP ->.
by rewrite !mulr0.
Qed.

End RS_decoding_using_euclid0.

Section RS_decoding_using_euclid.

Variables q m' : nat.
Hypothesis primeq : prime q.
Let F := GF m' primeq.
Variables (a : F) (n' : nat) (d : nat).
Let n := n'.+1.

Hypothesis dn : RS.redundancy_ub d n.
Hypothesis qn : ~~ (q %| n)%nat.

Let t := d./2.

Local Open Scope ecc_scope.

Lemma RS_repair_is_correct : n.-primitive_root a ->
  t.-BDD (RS.code a n d, RS_repair a n.-1 d).
Proof.
move=> an; rewrite /BD_decoding /=.
move=> c e.
set y := c + e.
set r0 : {poly F} := 'X^d.
set r1 := \RSsynp_(rVexp a n, y, d).
set vj := Euclid.v r0 r1 (stop (odd d + t) r0 r1).
set rj := Euclid.r r0 r1 (stop (odd d + t) r0 r1).
move=> Hc et.
set r_ : {poly F} := \RSomega_(rVexp a n, e).
rewrite /= /RS_repair.
have same_syndrome : \RSsynp_(rVexp a n, y, d) = \RSsynp_(rVexp a n, e, d).
  rewrite syndromepD.
  move: Hc => /=.
  rewrite mem_kernel_syndrome0 -RS.codebook_syndrome //.
  rewrite -RS.RS_syndromep_codeword // => /eqP ->; by rewrite add0r.
rewrite ffunE.
case: ifPn => syndrome0.
  suff e0 : e = 0 by rewrite /y e0 addr0.
  suff yc : y = c.
    move/eqP : yc; by rewrite -subr_eq0 /y addrAC subrr add0r => /eqP.
  apply/eqP/negPn/negP => abs.
  suff : dH y c < min_dist (RS_not_trivial a dn).
    apply/negP; rewrite -leqNgt min_dist_prop //.
    move: syndrome0; by rewrite RS.RS_syndromep_codeword // -RS.lcode0_codebook // inE.
  rewrite (RS_min_dist dn _ an) // dH_sym dH_wH (@leq_ltn_trans t) //.
  move: (td d).
  rewrite /RS.errors_ub ltnS => /leq_trans; apply.
  by rewrite -{2}(half_bit_double d true) add1n half_leq // ltnS -addnn leq_addr.
have H1 : distinct_non_zero (rVexp a n).
  apply distinct_non_zero_rVexp.
  by apply (primitive_uroot_neq0 an).
  by move/prim_root_not_uroot_on: an.
have H2 := rVexp_neq0 _ (primitive_uroot_neq0 an).
have r1_neq0 : \RSsynp_(rVexp a n, e, d) != 0.
  apply: contra syndrome0.
  rewrite syndromepD => /eqP ->.
  by rewrite addr0 RS.RS_syndromep_codeword // -RS.lcode0_codebook // inE.
have K1 : size r1 <= size ('X^d : {poly F}).
  by rewrite /r1 size_polyXn (leq_trans (size_syndromep _ _ _)).
have K2 : \RSsynp_(rVexp a n, y, d) != 0 by rewrite same_syndrome.
have K3 : \sigma_(rVexp a n, e) * r1 = r_ + - RS_mod a e d * 'X^d.
  by rewrite /r1 same_syndrome RS_key_equation.
have K4 : size \sigma_(rVexp a n, e) <= t.+1.
  rewrite (leq_trans (size_errloc _ _)) => //; by rewrite -wH_card_supp.
have K5 : size r_ <= odd d + t.
  rewrite wH_card_supp in et.
  by rewrite (leq_trans (size_erreval (rVexp a n) (Errvec et) _)) // leq_addl.
have K6 : (t.+1 + (odd d + t))%N = size ('X^d : {poly F}).
  rewrite size_polyXn addnCA addSn addnn addnS; congr S.
  by rewrite -[RHS](odd_double_half d).
move: (@solve_key_equation_coprimep F 'X^d r1 K1 \sigma_(rVexp a n, e) r_ _ (errloc_neq0 (rVexp a n) (supp e)) K2 t.+1 _ K3 K4 K5 K6 (coprime_errloc_erreval H1 (@H2 n) _)).
case=> l [l0 [Hvj Hrj]].
by rewrite -(@RS_err_is_correct _ _ _ _ (primitive_uroot_neq0 an) l e) // /y addrK ifT // RS.RS_syndromep_codeword // -RS.lcode0_codebook // inE.
Qed.

End RS_decoding_using_euclid.

Module RS_encoder.

Section RS_encoder_sect.

Variable (F : finFieldType) (a : F).
Variables (d : nat) (n' : nat).
Let n := n'.+1.
Hypothesis dn : RS.redundancy_ub d n.

Definition encoder : encT F [finType of 'rV[F]_(n - d.+1).+1] n :=
  let g := \gen_(a, d) in
 [ffun m => let mxd := rVpoly m * 'X^d in poly_rV (mxd - mxd %% g)].

(* TODO(rei) *)
Lemma tmp : (d + (n - d.+1).+1 = n)%nat.
Proof.
move: dn; rewrite /RS.redundancy_ub => ?.
rewrite subnS prednK //; last by rewrite subn_gt0.
by rewrite subnKC // ltnW.
Qed.

Definition RS_discard' (x : 'rV[F]_n) : 'rV[F]_(n - d.+1).+1 :=
  rsubmx (castmx (erefl, esym tmp) x).

Definition RS_discard (x : 'rV[F]_n) : 'rV[F]_(n - d.+1).+1 :=
  poly_rV ((rVpoly x) %/ 'X^d).

Definition decoder : decT F [finType of 'rV[F]_(n - d.+1).+1] n :=
  [ffun y => omap RS_discard (RS_repair a _ d y)].

Definition RS_code := mkCode encoder decoder.

(* NB: first part of lemma 10.60 *)
Lemma RS_enc_injective : injective (enc RS_code).
Proof.
move=> x1 x2 /=.
rewrite /encoder 2!ffunE => x1x2.
suff H : rVpoly x1 * 'X^d.+1 = rVpoly x2 * 'X^d.+1.
  rewrite -(rVpolyK x1) -(rVpolyK x2).
  have : (rVpoly x1 * 'X^d.+1) %/ 'X^d.+1 = (rVpoly x2 * 'X^d.+1) %/ 'X^d.+1 by rewrite H.
  rewrite mulpK; last by rewrite -size_poly_gt0 size_polyXn.
  rewrite mulpK; last by rewrite -size_poly_gt0 size_polyXn.
  by move=> ->.
apply/eqP.
rewrite -subr_eq0 -mulrBl.
suff : ((rVpoly x1 - rVpoly x2) == 0) &&
  ((rVpoly x2 * 'X^d) %% \gen_(a, d) -
   (rVpoly x1 * 'X^d) %% \gen_(a, d) == 0).
  case/andP => /eqP ->; by rewrite mul0r.
have H1 : size ((rVpoly x2 * 'X^d) %% \gen_(a, d)) < d.+1.
  by rewrite -[in X in _ < X](size_rs_gen a d) ltn_modp gen_neq0.
have H2 : size ((rVpoly x1 * 'X^d) %% \gen_(a, d)) < d.+1.
  by rewrite -[in X in _ < X](size_rs_gen a d) ltn_modp gen_neq0.
rewrite -(@rreg_div0 _ _ _ 'X^d).
- rewrite mulrBl -(opprB (_ %% _)).
  rewrite (_ : forall a b c d, a - b - (c - d) = (a - c) + (d - b)); last first.
    move=> *.
    rewrite -2!addrA; congr (_ + _).
    rewrite addrA addrC opprD; congr (_ - _).
    by rewrite opprK.
  rewrite addr_eq0 opprB -subr_eq0.
  move/eqP : x1x2.
  rewrite -[in X in X -> _]subr_eq0 -linearB /= => /poly_rV_0_inv; apply.
  rewrite (leq_trans (size_add _ _)) // size_opp geq_max.
  have H : forall x : 'rV[F]_(n - d.+1).+1, size (rVpoly x * 'X^d) <= n.
    move=> x.
    apply (leq_trans (size_mul_leq _ _)).
    rewrite size_polyXn addnS /=.
    rewrite (@leq_trans ((n - d.+1).+1 + d)) //.
      by rewrite leq_add2r size_poly.
    move: dn; rewrite /RS.redundancy_ub => ?.
    by rewrite subnS prednK // ?subn_gt0 // subnK // ltnW.
  apply/andP; split; rewrite (leq_trans (size_add _ _)) // geq_max size_opp H /=.
    by rewrite (leq_trans _ dn) // ltnW.
    by rewrite (leq_trans _ dn) // ltnW.
- rewrite lead_coefXn; exact: GRing.rreg1.
- rewrite size_polyXn ltnS (leq_trans (size_add _ _)) //.
  rewrite geq_max size_opp /=; apply/andP; split; by rewrite -ltnS.
Qed.

Hypothesis a_neq0 : a != 0.
Hypothesis a_not_uroot_on : not_uroot_on a n.

(* NB: corresponds to lemma 10.59? *)
Lemma RS_enc_img :
  (enc RS_code) @: [finType of 'rV[F]_(n - d.+1).+1] \subset RS.code a n d.
Proof.
apply/subsetP => /= c /imsetP[/= m _] ->{c}.
rewrite /encoder ffunE.
have Htmp : size (rVpoly m * 'X^d) <= n.
  eapply leq_trans; first by apply size_mul_leq.
  rewrite size_polyXn addnS /=.
  suff : size (rVpoly m) <= (n - d.+1).+1.
    rewrite -(leq_add2r d) => /leq_trans -> //.
    by rewrite subnS prednK ?subn_gt0 // subnK // ltnW.
  by apply size_poly.
suff : poly_rV (rVpoly m * 'X^d - (rVpoly m * 'X^d) %% \gen_(a, d))
    \in [set cw in RS.code a n d].
  by rewrite !inE.
rewrite (@RS.lcode0_codebook _ a n' d); last by exact dn.
apply/(rs_genP dn a_neq0 a_not_uroot_on).
exists ((rVpoly m * 'X^d) %/ \gen_(a, d)).
split.
  rewrite size_divp; last apply: gen_neq0.
  rewrite -subnS prednK; last by rewrite size_poly_gt0; exact: gen_neq0.
  apply (@leq_trans (n - size \gen_(a, d))).
  apply leq_sub => //.
  apply leq_sub2l => //.
  rewrite size_rs_gen //; exact: d_pos.
rewrite {1}(divp_eq (rVpoly m * 'X^d) \gen_(a, d)) addrK poly_rV_K //.
by eapply leq_trans; first by apply leq_trunc_divp.
Qed.

Lemma RS_repair_output_is_in_the_code (x y : 'rV_n) (an1 : a ^+ n = 1) :
  RS_repair a _ d x = Some y -> y \in RS.code a n d.
Proof.
rewrite /RS_repair ffunE.
case: ifPn => [|_].
  rewrite RS.RS_syndromep_codeword // -RS.lcode0_codebook // inE.
  by move=> ? [<-].
case: ifPn => [|//].
rewrite RS.RS_syndromep_codeword // -RS.lcode0_codebook // inE => ?.
by case=> <-.
Qed.

Lemma RS_repair_img (an1 : a ^+ n = 1) (Hchar : ([char F]^').-nat n'.+1) :
  oimg (RS_repair a _ d) \subset RS.code a n d.
Proof.
apply/subsetP => /= y.
rewrite inE => /existsP[/= x /eqP].
by apply RS_repair_output_is_in_the_code.
Qed.

Definition low (c : 'rV[F]_n) : 'rV[F]_d := poly_rV (rVpoly c %% 'X^d).
Definition high (c : 'rV[F]_n) : 'rV[F]_(n - d.+1).+1 := poly_rV (rVpoly c %/ 'X^d).

Lemma decomp_codeword (c : 'rV[F]_n) : rVpoly c = rVpoly (low c) + rVpoly (high c) * 'X^d.
Proof.
rewrite poly_rV_K; last first.
  move: (@ltn_modp _ (rVpoly c) 'X^d).
  by rewrite size_polyXn -size_poly_eq0 size_polyXn.
rewrite poly_rV_K; last first.
  rewrite size_divp; last by rewrite -size_poly_eq0 size_polyXn.
  rewrite size_polyXn /= -(subSn dn) (@leq_trans (n - d)) //.
  by rewrite leq_sub2r // size_poly.
by rewrite addrC -divp_eq.
Qed.

Lemma RS_enc_surjective (c : 'rV[F]_n) : c \in RS.codebook a n' d ->
  encoder (high c) = c.
Proof.
move=> c_RS; apply/eqP; rewrite -subr_eq0 -rVpoly0.
set m := high c.
suff H : size (rVpoly (encoder m - c)) <= d.
  have : encoder m - c \in RS.codebook a n' d.
    have Hencm : encoder m \in RS.codebook a n' d.
      move: RS_enc_img.
      rewrite -RS.lcode0_codebook //.
      move/subsetP/(_ (encoder m)) => K.
      have : encoder m \in [set encoder x | x : 'rV_(n - d.+1).+1].
        by apply/imsetP; exists m.
      move/K => {K}.
      by rewrite inE.
    case: (RS.addr_closed a n' d) => _.
    move/(_ _ (- c) Hencm); apply.
    by rewrite RS.oppr_closed.
  case/(@RS.deg_lb _ a _ _ dn a_neq0 a_not_uroot_on)/orP => [/eqP ->|].
    apply/eqP/polyP => i.
    rewrite coef_poly coef0.
    case: ifP => // _.
    by case: (insub i) => // ?; rewrite mxE.
  by move=> /leq_trans/(_ H); rewrite ltnn.
rewrite /encoder ffunE linearB /= poly_rV_K; last first.
  rewrite (leq_trans (size_add _ _)) // geq_max.
  apply/andP; split.
    rewrite (leq_trans (size_mul_leq _ _)) // size_polyXn addnS /=.
    apply (@leq_trans ((n - d.+1).+1 + d)).
      by rewrite leq_add2r size_poly.
    by rewrite subnS prednK ?subn_gt0 // subnK // ltnW.
  rewrite size_opp (@leq_trans d) //; last exact/ltnW.
  by rewrite -ltnS -[in X in _ <= X](size_rs_gen a d) ltn_modp gen_neq0.
pose c1 := low c.
rewrite (_ : _ - _ = - rVpoly c1 - (rVpoly m * 'X^d) %% \gen_(a, d)); last first.
  rewrite addrC addrA; congr (_ - _).
  by rewrite (decomp_codeword c) opprD subrK.
rewrite (leq_trans (size_add _ _)) // geq_max.
apply/andP; split.
  by rewrite size_opp /rVpoly size_poly.
by rewrite size_opp -ltnS -[in X in _ <= X](size_rs_gen a d) ltn_modp gen_neq0.
Qed.

Lemma RS_enc_discard_is_id : cancel_on (RS.code a n d) encoder RS_discard.
Proof.
move=> /= c Hc.
rewrite /RS_discard -/(high c); apply RS_enc_surjective.
by rewrite -RS.lcode0_codebook // ?inE.
Qed.

Definition RS_as_lcode (an1 : a ^+ n = 1) (Hchar : ([char F]^').-nat n) :
  Lcode.t _ _ _ [finType of 'rV_(n - d.+1).+1] :=
    @Lcode.mk _ _ _ _ _
      (Encoder.mk RS_enc_injective RS_enc_img)
      (Decoder.mk (RS_repair_img an1 Hchar) RS_discard)
      RS_enc_discard_is_id.

End RS_encoder_sect.

End RS_encoder.

Section RS_cyclic.

Variable (F : finFieldType) (a : F).
Variables (d : nat) (n' : nat).
Let n := n'.+1.
Hypothesis dn : RS.redundancy_ub d n.
Hypothesis an : n.-primitive_root a.
Let a0 : a != 0 := primitive_uroot_neq0 an.
Let an1 : a ^+ n = 1 := prim_expr_order an.

Lemma RS_cyclic : rcsP [set cw in RS.code a n d].
Proof.
rewrite (_ : [set cw in _] = [set cw in RS.codebook a n' d]); last first.
  apply/setP => i; by rewrite -RS.lcode0_codebook // inE 2![in RHS]inE.
move=> /= y.
rewrite !inE => /forallP x_RS.
apply/forallP => /= i; apply/implyP => i0; apply/eqP.
move: x_RS => /(_ i); rewrite i0 implyTb => /eqP x_RS.
move/(congr1 (fun x => a^+i * x)) : x_RS.
rewrite mulr0 => H.
apply fdcoor_rcs; first exact: prim_expr_order.
move/eqP: H.
by rewrite mulf_eq0 expf_eq0 i0 (negbTE a0) /= => /eqP.
Qed.

Local Open Scope cyclic_code_scope.

Lemma rs_gen_is_gen : poly_rV \gen_(a, d) \in 'cgen[Ccode.mk RS_cyclic].
Proof.
apply pgen_is_cgen => /=; first exact: RS_not_trivial.
apply/forallP => /= p; apply/eqP; apply/idP/idP.
  move=> Hp.
  move: (proj1 (rs_genP dn a0 (prim_root_not_uroot_on an) p)).
  rewrite RS.codebook_syndrome //.
  rewrite inE mem_kernel_syndrome0 /syndrome in Hp.
  rewrite Hp => /(_ erefl); case=> m [H1 H2].
  rewrite poly_rV_K // ?size_rs_gen //.
  by rewrite H2 dvdp_mull // modpp.
move=> Hp.
rewrite inE mem_kernel_syndrome0 /linearcode.syndrome.
rewrite -(@RS.codebook_syndrome _ a n' d) //.
apply: (proj2 (rs_genP dn a0 (prim_root_not_uroot_on an) p)).
rewrite poly_rV_K // ?size_rs_gen // in Hp.
case/dvdpP : Hp => x Hx.
by exists x; split => //; exact: RS_message_size Hx.
Qed.

End RS_cyclic.


(* Surjective Library *)
(* v0   Olivier Laurent *)

(** * Some properties of surjective functions *)

Require Import List.

Definition surjective {A B} (f : A -> B) := forall y, exists x, y = f x.

Definition surjective2 {A B C} (f : A -> B -> C) := forall z, exists x y, z = f x y.

(** * Basic properties of surjective functions *)

Lemma comp_surj {A B C} : forall (f : B -> C) (g : A -> B),
  surjective f -> surjective g -> surjective (fun x => f (g x)).
Proof.
intros f g Hf Hg z.
destruct (Hf z) as [y Heq] ; subst.
destruct (Hg y) as [x Heq] ; subst.
exists x ; reflexivity.
Qed.

Lemma retract_surj {A B} : forall (f : A -> B) g,
  (forall x, f (g x) = x) -> surjective f.
Proof.
intros f g Hret y.
exists (g y).
rewrite Hret.
reflexivity.
Qed.

Lemma map_surj {A B} : forall f : A -> B, surjective f -> surjective (map f).
Proof.
intros f Hf l1.
induction l1.
- exists nil.
  reflexivity.
- destruct (Hf a) as [b Heq] ; subst.
  destruct IHl1 as [l Heq] ; subst.
  exists (b :: l).
  reflexivity.
Qed.


Require Import HoTT.
Require Import Functors.

Open Scope list_scope.

Generalizable Variables A B X Y f g x y z w T F.

Section List_is_monad.
  Notation T := list.
  Local Fixpoint bind (A B: Type) (X: T A) (f: A -> list B): list B
    := match X with
       | nil => nil
       | x :: xs => (f x) ++ (bind A B xs f)
       end.

  Local Definition ret (A: Type) (X: A): T A := X :: nil.

  Local Definition ret_unit_left : forall (A B : Type) (k : A -> T B) (a : A),
                    bind A B (ret A a) k = k a.
    intros; unfold bind, ret.
    SearchAbout "++".

  Local Definition ret_unit_right : forall (A : Type) (m : T A),
                    bind A A m (ret A) = m.

  Local Definition bind_assoc : forall (A B C : Type) (m : T A) (k : A -> T B)
                   (h : B -> T C), bind A C m (fun x : A =>
                   bind B C (k x) h) = bind B C (bind A B m k) h.

  Global Instance list_is_monad : TMonad list
    := {|  |}

End List_is_monad.

Definition merge {X: Type} : list (list X) -> list X :=
  fix merge lists :=
  match lists with
  | nil => nil
  | xs :: lists => xs ++ (merge lists)
  end.

Fixpoint list_map {X Y: Type} (f: X -> Y) (xs: list X) : list Y :=
  match xs with
  | nil => nil
  | x :: xs' => (f x) :: (list_map f xs')
  end.

Section Assoc_Algebra.
  Notation Ends X := (list X -> X).

  Variable A : Type.

  Definition VirtualCompose (is_op : Ends A -> Type) :=
    let V := (exists f, is_op f) in
    forall (f g: V), exists (h: V), (g.1 o (list_map f.1) = h.1 o merge).

  Record Associative :=
  {
    is_op: Ends A -> Type;
    comp: VirtualCompose is_op;
    unique_operation: Contr (exists f, is_op f)
    }.

End Assoc_Algebra.

Arguments comp [_] _ _ _.
Arguments is_op [_] _ _.
Arguments unique_operation [_] _ .
Arguments VirtualCompose [A] _.

(* Note: we can reduce the structures in definition of A_00 algebras and
their maps from maps of type families to maps of elemets, i.e. a composition
in A_00 structure is a path p: m m = m concat, where m is some virtual
operation. A functor is a map f: X -> Y with p: f m_X = m_Y f and preserving
composition p. *)

Definition VirtualOp {X: Type} (A: Associative X) :=
  exists (f: list X -> X), A.(is_op) f.

Record Assoc_map {X Y: Type} (A: Associative X) (B: Associative Y) :=
  {
    base_map: X -> Y;
    operation_map: forall (f: VirtualOp A), exists (g: VirtualOp B),
                      g.1 o base_map = base_map o f.1;
    compose_map:
  (** Simplicial objects: to associate simplicial object to monoid M, consider Hom( F_n , M), where F_n is a free monoid on n generators. Free monoid form a simplicial object, thus Hom(..) is cosimplicial. **)
  (** Simplicial category maps to FinSet (forget the ordering) and FinSet maps to Monoid via free monoid functor. Thus free monoids are cosimplicial.**)


Require Export Coq.Bool.Bool CoqRecon.Util.ListLib.

Declare Scope set_scope.
Delimit Scope set_scope with set.

Reserved Notation "l ∪ r" (at level 45, left associativity).
Reserved Notation "l ∩ r" (at level 44, left associativity).
Reserved Notation "l ∖ r" (at level 43, left associativity).

Notation "e ∈ s"
  := (In e s)
       (at level 80, no associativity) : set_scope.

Notation "e ∉ s"
  := (~ In e s)
       (at level 80, no associativity) : set_scope.

(** [l ⊆ r] *)
Definition Subset {A : Set} (l r : list A) : Prop :=
  forall a, (a ∈ l -> a ∈ r)%set.

Notation "l ⊆ r"
  := (Subset l r)
       (at level 80, no associativity) : set_scope.

Definition set_equiv {A : Set} (l r : list A) : Prop :=
  (l ⊆ r /\ r ⊆ l)%set.

Notation "l ≡ r"
  := (set_equiv l r)
       (at level 80, no associativity) : set_scope.

Section SetEquiv.
  Open Scope set_scope.

  Context {A : Set}.

  Local Hint Unfold set_equiv : core.
  Local Hint Unfold Subset : core.
  Local Hint Unfold Reflexive : core.

  Lemma set_equiv_Reflexive :
    Reflexive (@set_equiv A).
  Proof.
    autounfold with core; auto.
  Qed.

  Local Hint Unfold Symmetric : core.

  Lemma set_equiv_Symmetric :
    Symmetric (@set_equiv A).
  Proof.
    autounfold with core; intuition.
  Qed.

  Local Hint Unfold Transitive : core.

  Lemma set_equiv_Transitive :
    Transitive (@set_equiv A).
  Proof.
    autounfold with core; intuition.
  Qed.

  Local Hint Resolve set_equiv_Reflexive : core.
  Local Hint Resolve set_equiv_Symmetric : core.
  Local Hint Resolve set_equiv_Transitive : core.
  Local Hint Constructors Equivalence : core.

  Global Instance SetEquiv : Equivalence (@set_equiv A).
  Proof.
    auto.
  Qed.
End SetEquiv.

Section SubsetPO.
  Context {A : Set}.

  Open Scope set_scope.

  Local Hint Unfold Subset : core.
  Local Hint Unfold Reflexive : core.

  Lemma Subset_reflexive : Reflexive (@Subset A).
  Proof.
    autounfold with *; auto.
  Qed.

  Local Hint Unfold Transitive : core.

  Lemma Subset_transitive : Transitive (@Subset A).
  Proof.
    autounfold with *; firstorder.
  Qed.

  Local Hint Unfold set_equiv : core.

  Lemma Subset_antisymmetric : forall l r : list A,
      l ⊆ r -> r ⊆ l -> l ≡ r.
  Proof.
    autounfold with *; firstorder.
  Qed.

  Lemma Subset_refl : forall l : list A, l ⊆ l.
  Proof.
    auto using Subset_reflexive.
  Qed.

  Lemma Subset_trans : forall l l' l'' : list A,
      l ⊆ l' -> l' ⊆ l'' -> l ⊆ l''.
  Proof.
    auto using Subset_transitive.
  Qed.

  Lemma Subset_nil : forall l : list A, [] ⊆ l.
  Proof.
    intuition.
  Qed.
End SubsetPO.

Section SetDefs.
  Context {A : Set}.

  Open Scope set_scope.

  Local Hint Unfold Subset : core.
  Local Hint Resolve Permutation_in : core.
  Local Hint Resolve Permutation_sym : core.

  Lemma Subset_perm_l : forall l l' : list A,
      Permutation l l' ->
      forall r, l ⊆ r -> l' ⊆ r.
  Proof. eauto. Qed.

  Lemma Subset_perm_r : forall r r' : list A,
      Permutation r r' ->
      forall l, l ⊆ r -> l ⊆ r'.
  Proof. eauto. Qed.

  Lemma Subset_perm : forall l l' r r' : list A,
      Permutation l l' -> Permutation r r' -> l ⊆ r -> l' ⊆ r'.
  Proof.
    intros l l' r r' Hl Hr; autounfold with *; eauto.
  Qed.

  (** [u] is the union of [l] & [r]. *)
  Definition Union (l r u : list A) : Prop :=
    forall a, a ∈ u <-> a ∈ l \/ a ∈ r.

  Local Hint Unfold Union : core.

  Lemma Union_Subset_l : forall l r u,
      Union l r u -> l ⊆ u.
  Proof. firstorder. Qed.

  Lemma Union_Subset_r : forall l r u,
      Union l r u -> r ⊆ u.
  Proof. firstorder. Qed.

  Lemma Union_perm_l : forall l l',
      Permutation l l' ->
      forall r u, Union l r u -> Union l' r u.
  Proof. firstorder eauto. Qed.

  Lemma Union_perm_r : forall r r',
      Permutation r r' ->
      forall l u, Union l r u -> Union l r' u.
  Proof. firstorder eauto. Qed.

  Lemma Union_perm_u : forall u u',
      Permutation u u' ->
      forall l r, Union l r u -> Union l r u'.
  Proof. firstorder eauto. Qed.

  (** [i] is the intersection of [l] & [r]. *)
  Definition Intersection (l r i : list A) : Prop :=
    forall a, a ∈ i <-> a ∈ l /\ a ∈ r.

  Definition Disjoint (l r : list A) : Prop := Intersection l r [].

  Local Hint Unfold Intersection : core.

  Lemma Inter_Subset_l : forall l r i,
      Intersection l r i -> i ⊆ l.
  Proof.
    firstorder.
  Qed.

  Lemma Inter_Subset_r : forall l r i,
      Intersection l r i -> i ⊆ r.
  Proof.
    firstorder.
  Qed.

  Lemma Inter_perm_l : forall l l',
      Permutation l l' ->
      forall r i, Intersection l r i -> Intersection l' r i.
  Proof. firstorder eauto. Qed.

  Lemma Inter_perm_r : forall r r',
      Permutation r r' ->
      forall l i, Intersection l r i -> Intersection l r' i.
  Proof. firstorder eauto. Qed.

  Lemma Intersection_perm_i : forall i i',
      Permutation i i' ->
      forall l r, Intersection l r i -> Intersection l r i'.
  Proof.
    autounfold with core.
    intros i i' HP l r H a;
      pose proof H a as [Hai  Halr];
      split; eauto.
  Qed.

  (** [d] is the diff of [l] & [r]. *)
  Definition Difference (l r d : list A) : Prop :=
    forall a, a ∈ d <-> a ∈ l /\ a ∉ r.

  Local Hint Unfold Difference : core.

  Lemma Diff_Subset : forall l r d,
      Difference l r d -> d ⊆ l.
  Proof.
    firstorder.
  Qed.

  Lemma Diff_perm_l : forall l l',
      Permutation l l' ->
      forall r d, Difference l r d -> Difference l' r d.
  Proof. firstorder eauto. Qed.

  Lemma Diff_perm_r : forall r r',
      Permutation r r' ->
      forall l d, Difference l r d -> Difference l r' d.
  Proof. firstorder eauto. Qed.

  Lemma Diff_perm_u : forall d d',
      Permutation d d' ->
      forall l r, Difference l r d -> Difference l r d'.
  Proof.
    autounfold with core.
    intros d d' HP l r HD a;
      pose proof HD a as [Had Halr]; split; eauto.
  Qed.

  Lemma Subset_Diff : forall l r,
      l ⊆ r ->
      Difference l r [].
  Proof.
    unfold Subset, Difference.
    intros l r Hs a; simpl; intuition.
  Qed.

  Lemma Subset_cons : forall l r : list A,
      l ⊆ r -> forall a : A, a :: l ⊆ a :: r.
  Proof.
    unfold Subset; intros;
      simpl in *; intuition.
  Qed.
End SetDefs.

Section ComputeSets.
  Context {A : Set} {HEA: EqDec A eq}.

  Fixpoint member (a : A) (l : list A) : bool :=
    match l with
    | []    => false
    | h :: t => if a == h then true else member a t
    end.

  Fixpoint intersect (l r : list A) : list A :=
    match l with
    | []    => []
    | h :: t =>
      (if member h r then [h] else []) ++ intersect t r
    end.

  Fixpoint difference (l r : list A) : list A :=
    match l with
    | []    => []
    | h :: t =>
      (if member h r then [] else [h]) ++ difference t r
    end.
End ComputeSets.

Notation "l ∪ r" := (l ++ r) : set_scope.
Notation "l ∩ r" := (intersect l r) : set_scope.
Notation "l ∖ r" := (difference l r) : set_scope.

Section Sets.
  Open Scope set_scope.

  Context {A : Set} {HEA: EqDec A eq}.

  Local Hint Unfold Subset : core.
  Local Hint Unfold Union : core.
  Local Hint Unfold Intersection : core.
  Local Hint Unfold Difference : core.

  Lemma append_Union : forall l r : list A, Union l r (l ∪ r).
  Proof.
    auto using in_app_iff.
  Qed.

  Lemma In_member : forall a l, a ∈ l -> member a l = true.
  Proof.
    intros a l; induction l as [| h t IHt];
      intro H; simpl in *;
        [ contradiction | destruct H as [H | H]]; subst;
          dispatch_eqdec; auto.
  Qed.

  Local Hint Resolve In_member : core.

  Lemma member_In : forall a l, member a l = true -> a ∈ l.
  Proof.
    intros a l; induction l as [| h t IHt];
      intro H; simpl in *; try discriminate;
        dispatch_eqdec; auto.
  Qed.

  Local Hint Resolve member_In : core.

  Lemma In_member_iff : forall a l,
      member a l = true <-> In a l.
  Proof.
    intuition.
  Qed.

  Lemma In_member_reflects : reflects (@In A) member.
  Proof.
    Local Hint Constructors reflect : core.
    unfold reflects.
    intros a l; destruct (member a l) eqn:Hmem; auto.
    constructor. intros H. apply In_member in H.
    rewrite H in Hmem. discriminate.
  Defined.

  Lemma Not_In_member_iff : forall a l,
      member a l = false <-> a ∉ l.
  Proof.
    intros a l.
    pose proof In_member_reflects a l as H.
    inv H; intuition.
  Qed.

  Lemma member_app_or : forall a l r,
      member a (l ∪ r) = member a l || member a r.
  Proof.
    intros a l r.
    pose proof In_member_reflects a l as Hal; inv Hal; simpl.
    - assert (HIn : In a (l ++ r)).
      { rewrite in_app_iff; auto. }
      auto using In_member.
    - pose proof In_member_reflects a r as Har; inv Har.
      + assert (HIn : In a (l ++ r)).
        { rewrite in_app_iff; auto. }
        auto using In_member.
      + rewrite Not_In_member_iff.
        rewrite in_app_iff. intuition.
  Qed.

  Lemma member_repeat : forall n a,
      member a (repeat a n) =
      match n with
      | O => false
      | S _ => true
      end.
  Proof.
    intros [| n] a; simpl; auto. dispatch_eqdec; auto.
  Qed.

  Lemma intersect_Intersection : forall l r,
      Intersection l r (l ∩ r).
  Proof.
    unfold Intersection; intro l;
      induction l as [| h t IHt];
      intros r a; simpl in *.
    - intuition.
    - split.
      + pose proof (In_member_reflects h r) as H; inv H; simpl.
        * intros [H | H]; subst; firstorder.
        * firstorder.
      + intros [[Hha | Hat] Har]; subst.
        * rewrite In_member by auto; simpl; auto.
        * rewrite in_app_iff. firstorder.
  Qed.

  Lemma difference_Difference : forall l r,
      Difference l r (l ∖ r).
  Proof.
    unfold Difference; intro l;
      induction l as [| h t IHt];
      intros r a; simpl in *.
    - intuition.
    - split.
      + pose proof In_member_reflects h r as H; inv H; simpl.
        * intros H; apply IHt in H as [IH IHr]. intuition.
        * intros [H | H]; subst; intuition;
            apply IHt in H; intuition.
      + intros [[Hha | Hat] Har]; subst.
        * assert (member a r = false).
          { pose proof In_member_reflects a r as H; inv H;
              auto; contradiction. }
          rewrite H. rewrite in_app_iff. intuition.
        * rewrite in_app_iff. right.
          apply IHt. intuition.
  Qed.

  Lemma diff_empty_r : forall l : list A,
      l ∖ [] = l.
  Proof.
    intro l; induction l as [| h l]; simpl; auto.
    rewrite IHl. reflexivity.
  Qed.

  Lemma remove_diff_cons : forall l r a,
      l ∖ (a :: r) = remove a (l ∖ r).
  Proof.
    intro l; induction l as [| h l IHl];
      intros r a; simpl; auto.
    destruct (member h r) eqn:Hmemhr;
      repeat dispatch_eqdec; try rewrite IHl; reflexivity.
  Qed.

  Lemma remove_diff : forall l r : list A,
      fold_right remove l r = l ∖ r.
  Proof.
    intro l; induction l as [| a l IHl];
      intro r; induction r as [| x r IHr]; simpl in *; auto.
    - rewrite IHr. reflexivity.
    - f_equal. rewrite diff_empty_r. reflexivity.
    - dispatch_eqdec.
      + rewrite IHr. rewrite remove_app.
        destruct (member x r); simpl.
        * rewrite remove_diff_cons. reflexivity.
        * dispatch_eqdec.
          rewrite remove_diff_cons. reflexivity.
      + destruct (member a r) eqn:Hmemar; simpl in *.
        * rewrite IHr. rewrite remove_diff_cons. reflexivity.
        * rewrite IHr; simpl.
          dispatch_eqdec; f_equal.
          rewrite remove_diff_cons. reflexivity.
  Qed.

  Lemma Subset_difference : forall l r,
      l ⊆ r -> l ∖ r = [].
  Proof.
    intros l r Hlr. apply Subset_Diff in Hlr.
    unfold Difference in Hlr.
    induction l as [| h l IHl]; simpl; auto.
    pose proof In_member_reflects h r as Hhr; inv Hhr; simpl; firstorder.
  Qed.

  Corollary difference_same : forall l : list A,
      l ∖ l = [].
  Proof.
    intros l. apply Subset_difference.
    intuition.
  Qed.

  Corollary uniques_app_diff : forall l r: list A,
      uniques (l ++ r) = uniques l ++ difference (uniques r) l.
  Proof.
    intros l r. rewrite uniques_app2.
    f_equal. rewrite remove_diff. reflexivity.
  Qed.

  Corollary uniques_app_same : forall l : list A,
      uniques (l ++ l) = uniques l.
  Proof.
    intros l. rewrite uniques_app_diff.
    rewrite Subset_difference by auto using uniques_sound.
    apply app_nil_r.
  Qed.

  Lemma difference_app_l : forall l1 l2 r : list A,
      difference (l1 ∪ l2) r = difference l1 r ∪ difference l2 r.
  Proof.
    intro l1; induction l1 as [| h1 l1 IHl1];
      intros l2 r; simpl; auto.
    rewrite IHl1. apply app_assoc.
  Qed.

  Lemma difference_app_r_comm : forall l r1 r2 : list A,
      difference l (r1 ∪ r2) = difference l (r2 ∪ r1).
  Proof.
    intro l; induction l as [| h l IHl]; intros r1 r2; simpl; auto.
    repeat rewrite member_app_or.
    rewrite orb_comm. rewrite IHl. reflexivity.
  Qed.

  Lemma difference_app_r_assoc : forall l r1 r2 : list A,
      l ∖ r1 ∖ r2 = l ∖ (r1 ∪ r2).
  Proof.
    intro l; induction l as [| h l IHl];
      intros r1 r2; simpl; auto.
    rewrite member_app_or.
    destruct (member h r1) eqn:Hmemhr1; simpl; auto.
    rewrite IHl. reflexivity.
  Qed.

  Lemma diff_uniques : forall l r : list A, l ∖ uniques r = l ∖ r.
  Proof.
    intro l; induction l as [| h l IHl];
      intro r; simpl in *; auto.
    pose proof In_member_reflects h r as Hhr;
      inversion Hhr as [Hin Hmem | Hin Hmem]; clear Hhr; simpl.
    - rewrite <- uniques_iff in Hin.
      rewrite <- In_member_iff in Hin.
      rewrite Hin; simpl; auto.
    - rewrite <- uniques_iff in Hin.
      rewrite <- Not_In_member_iff in Hin.
      rewrite Hin; simpl; f_equal; auto.
  Qed.

  Local Hint Resolve Permutation_app_comm : core.

  Lemma length_uniques_app : forall l r : list A,
      length (uniques (l ++ r)) = length (uniques (r ++ l)).
  Proof.
    intros l r.
    assert (Permutation (uniques (l ++ r)) (uniques (r ++ l)))
      by eauto using uniques_perm.
    auto using Permutation_length.
  Qed.

  Local Hint Resolve Union_Subset_l : core.
  Local Hint Resolve Union_Subset_r : core.
  Local Hint Resolve Inter_Subset_l : core.
  Local Hint Resolve Inter_Subset_r : core.
  Local Hint Resolve Diff_Subset : core.
  Local Hint Resolve append_Union : core.
  Local Hint Resolve intersect_Intersection : core.
  Local Hint Resolve difference_Difference : core.

  Lemma Subset_union_l : forall l r : list A, l ⊆ l ∪ r.
  Proof.
    eauto.
  Qed.

  Lemma Subset_union_r : forall l r : list A, r ⊆ l ∪ r.
  Proof.
    eauto.
  Qed.

  Lemma Subset_inter_l : forall l r, l ∩ r ⊆ l.
  Proof.
    eauto.
  Qed.

  Lemma Subset_inter_r : forall l r, l ∩ r ⊆ r.
  Proof.
    eauto.
  Qed.

  Lemma Subset_diff : forall l r, l ∖ r ⊆ l.
  Proof.
    eauto.
  Qed.

  Hint Rewrite in_app_iff : core.

  Lemma Subset_l_union : forall l r : list A,
      l ⊆ r -> forall s, l ⊆ r ∪ s.
  Proof.
    unfold Subset; intros.
    autorewrite with core in *; intuition.
  Qed.

  Lemma Subset_r_union : forall l r : list A,
      l ⊆ r -> forall s, l ⊆ s ∪ r.
  Proof.
    unfold Subset; intros.
    autorewrite with core in *; intuition.
  Qed.

  Lemma Subset_union_distr_l : forall l r : list A,
      l ⊆ r -> forall s, s ∪ l ⊆ s ∪ r.
  Proof.
    unfold Subset; intros.
    autorewrite with core in *; intuition.
  Qed.

  Lemma Subset_union_distr_r : forall l r : list A,
      l ⊆ r -> forall s, l ∪ s ⊆ r ∪ s.
  Proof.
    unfold Subset; intros.
    autorewrite with core in *; intuition.
  Qed.

  Lemma Subset_union : forall l1 l2 r1 r2 : list A,
      l1 ⊆ r1 -> l2 ⊆ r2 -> l1 ∪ l2 ⊆ r1 ∪ r2.
  Proof.
    unfold "⊆"; intros l1 l2 r1 r2 H1 H2 a.
    autorewrite with core; firstorder.
  Qed.

  Lemma Subset_extra_l : forall l r : list A,
      l ∪ l ⊆ r <-> l ⊆ r.
  Proof.
    unfold Subset; intros l r; split;
      intros H a; specialize H with a;
        autorewrite with core in *; firstorder.
  Qed.

  Lemma Subset_extra_r : forall l r : list A,
      l ⊆ r ∪ r <-> l ⊆ r.
  Proof.
    unfold Subset; intros l r; split;
      intros H a; specialize H with a;
        autorewrite with core in *; firstorder.
  Qed.

  Lemma union_perm : forall l r : list A,
      Permutation (l ∪ r) (r ∪ l).
  Proof.
    auto using Permutation_app_comm.
  Qed.

  Lemma Inter_nil : forall l r : list A,
      Intersection l r [] -> l ∩ r = [].
  Proof.
    unfold Intersection.
    intro l; induction l as [| a l IHl];
      intros r H; simpl in *; eauto.
    pose proof (In_member_reflects a r) as Har;
      inv Har; simpl in *; firstorder.
  Qed.

  Lemma inter_union_distr : forall l r s,
      l ∩ (r ∪ s) = l ∩ r ∪ l ∩ s.
  Proof.
    intros l;
      induction l as [| h l IHl];
      intros r s; simpl; auto.
    rewrite member_app_or.
    pose proof In_member_reflects h r as Hhr;
      pose proof In_member_reflects h s as Hhs;
      inv Hhr; inv Hhs; simpl; f_equal; auto.
  Abort.

  Lemma uniques_perm_app : forall l l' s,
      Permutation l (l' ++ s) ->
      forall r r',
        Permutation r (r' ++ s) ->
        Permutation (uniques (l ++ r)) (uniques (l' ++ r' ++ s)).
  Proof.
    intros l l' s Hll' r r' Hrr'.
    assert (Happ : Permutation (l ++ r) ((l' ++ s) ++ (r' ++ s)))
      by auto using Permutation_app.
    rewrite <- app_assoc in Happ.
    assert (Happ': Permutation (l ++ r) (l' ++ r' ++ s ++ s)).
    { apply perm_trans with (l' ++ s ++ r' ++ s); auto.
      apply Permutation_app_head.
      apply Permutation_app_swap_app. }
    apply uniques_perm in Happ'.
    rewrite (uniques_app l') in Happ'.
    rewrite (uniques_app r') in Happ'.
    rewrite uniques_app_same in Happ'.
    rewrite <- (uniques_app r') in Happ'.
    rewrite <- (uniques_app l') in Happ'.
    assumption.
  Qed.

  Lemma uniques_uniques_perm_app : forall l l' s,
      Permutation (uniques l) (uniques (l' ++ s)) ->
      forall r r',
        Permutation (uniques r) (uniques (r' ++ s)) ->
        Permutation (uniques (l ++ r)) (uniques (l' ++ r' ++ s)).
  Proof.
    intros l l' s Hll' r r' Hrr'.
    assert (Happ : Permutation
                     (uniques l ++ uniques r)
                     (uniques (l' ++ s) ++ uniques (r' ++ s)))
      by auto using Permutation_app.
    apply uniques_perm in Happ.
    repeat rewrite <- uniques_app in Happ.
    rewrite <- app_assoc in Happ.
    assert (Happ' : Permutation
                      (uniques (l ++ r))
                      (uniques (l' ++ r' ++ s ++ s))).
    { apply perm_trans with (uniques (l' ++ s ++ r' ++ s)); auto.
      apply uniques_perm. apply Permutation_app_head.
      apply Permutation_app_swap_app. }
    rewrite (uniques_app l') in Happ'.
    rewrite (uniques_app r') in Happ'.
    rewrite uniques_app_same in Happ'.
    rewrite <- (uniques_app r') in Happ'.
    rewrite <- (uniques_app l') in Happ'.
    assumption.
  Qed.

  Lemma uniques_uniques_perm_app3 : forall l l' m m' n n' o,
      Permutation (uniques l) (uniques (l' ++ o)) ->
      Permutation (uniques m) (uniques (m' ++ o)) ->
      Permutation (uniques n) (uniques (n' ++ o)) ->
      Permutation (uniques (l ++ m ++ n)) (uniques (l' ++ m' ++ n' ++ o)).
  Proof.
    intros l l' m m' n n' o Hl Hm Hn.
    pose proof uniques_uniques_perm_app _ _ _ Hm _ _ Hn  as Hmn.
    rewrite app_assoc in Hmn.
    pose proof uniques_uniques_perm_app _ _ _ Hl _ _ Hmn as Hml.
    repeat rewrite <- app_assoc in Hml.
    assumption.
  Qed.
End Sets.

Section NatSet.
  Open Scope set_scope.
  Local Hint Constructors Forall : core.

  Lemma list_max_ge : forall l : list nat,
      Forall (fun n => n <= list_max l) l.
  Proof.
    intro l; induction l as [| h t IHt];
      simpl; constructor; try lia.
    apply Forall_forall.
    intros n HIn.
    apply Forall_forall
      with (x:=n) in IHt; try assumption. lia.
  Qed.

  Lemma list_max_ge_in : forall l n,
      n ∈ l -> n <= list_max l.
  Proof.
    intro l. rewrite <- Forall_forall.
    exact (list_max_ge l).
  Qed.

  Lemma list_max_succ : forall l : list nat,
    Forall (fun n => n < 1 + list_max l) l.
  Proof.
    intros l. apply Forall_forall.
    pose proof list_max_ge l as H.
    intros n HIn.
    apply Forall_forall
      with (x:=n) in H; try assumption. lia.
  Qed.

  Lemma list_max_succ_not_in : forall l : list nat,
      1 + list_max l ∉ l.
  Proof.
    intros l HIn.
    pose proof list_max_succ l as H.
    pose proof Forall_forall
         (fun n => n < 1 + list_max l) l as [HFF _].
    pose proof HFF H as H'.
    apply H' in HIn. lia.
  Qed.

  Lemma Subset_list_max : forall l r,
      l ⊆ r -> list_max l <= list_max r.
  Proof.
    unfold "⊆".
    intro l; induction l as [| a l IHl];
      intros r HS; simpl in *; try lia.
    destruct (le_gt_dec a (list_max l)) as [Hal | Hal].
    - rewrite max_r by lia; eauto.
    - rewrite max_l by lia.
      assert (Har: In a r) by eauto.
      auto using list_max_ge_in.
  Qed.
End NatSet.


Require Import Spreadable.
Require Import Tuple.
Require Import Lia.

Open Scope list_scope.

(** * The specification for Linked Nested Data Types **)
Inductive LNDT (F : TT) (A : Type) : Type :=
 | empty : LNDT F A
 | nest : A -> LNDT F (F A) -> LNDT F A.

(** * Some examples *)

Eval compute in (LNDT list).

Lemma ex1 : LNDT list nat.
Proof.
apply (nest list nat 1).
apply (nest list (list nat) (cons 1 (cons 2 (cons 3 nil)))).
constructor.
Defined.

Definition nested1 : LNDT list nat :=
nest list nat 1
  (nest list (list nat)
     (1 :: 2 :: 3 :: nil)
     (empty list
        (list (list nat)))).
(* Proof.
apply (nest list nat 1).
apply
  (nest list (list nat)
     (1 :: 2 :: 3 :: nil)).
constructor.
Defined.
*)

Definition nested2 : LNDT list nat.
Proof.
apply (nest list nat 1).
apply
  (nest list (list nat)
     (1 :: 2 :: 3 :: nil)).
apply (nest list (list (list nat))
     ((1::2::nil)::(2::nil) :: nil)).
apply empty.
Defined.
(*
nest list nat 1
  (nesOpen Scope list_scope.t list (list nat)
     (1 :: 2 :: 3 :: nil)
     (nest list
        (list (list nat))
        ((1 :: 2 :: nil)
         :: (2 :: nil)
            :: nil)
        (empty list
           (list
              (list
                 (list nat))))))

ou plus lisiblement sans les infos de type
(nest 1
  (nest [1 ; 2; 3]
    (nest [[1;2] ; [2]]
      empty)))
*)

Definition nested3 : LNDT (Tuple 2) nat.
Proof.
apply (nest (Tuple 2) nat
      1).
apply
  (nest (Tuple 2) (Tuple 2 nat)
     (1, (2, 3))).
apply (nest (Tuple 2) (Tuple 2 (Tuple 2 nat))
     ( (1, (1, 1)), ( (2, (2, 2)), (3, (3, 3))))).
apply empty.
Defined.

Print nested3.

(** * Induction principle over nested data types *)
Check LNDT_ind.

(** * A very simple property on equality *)
Lemma eq_nest : forall {F : TT} {A : Type} {x y} {l m : LNDT F (F A)},
    x = y -> l = m -> (nest F A x l) = (nest F A y m).
Proof.
  intros F A x y l m Heq_A Heq_Nested.
  rewrite Heq_A, Heq_Nested. reflexivity.
Defined.

(** * All spread-able elements can indeed be spread from F to (LNDT F) *)

(** ** Map function *)
Fixpoint lndt_map {F : TT} (map : Map F) (A B : Type) (f : A -> B) (t : LNDT F A) : LNDT F B :=
 match t with
  |empty _ _     => empty _ _
  |nest  _ _ x e => nest F B (f x) (lndt_map map (F A) (F B) (map A B f) e)
 end.

Definition ff (n : nat) := match n with
  0 => false
| _ => true
end.

Lemma map_lndt_id : forall {F : TT} (map : Map F) (p : MapId map), MapId(lndt_map map).
Proof.
unfold MapId, Map. intros.
generalize dependent f. revert x.
induction x; simpl; intros; auto.
rewrite H. rewrite IHx with (f := map A A f).
+ reflexivity.
+ intros. rewrite p. reflexivity. exact H.
Qed.

(** ** Congruence function *)
Require Import FunInd.
Functional Scheme lndt_map_ind := Induction for lndt_map Sort Prop.

Lemma lndt_cng_map : forall {F : TT} {map : Map F}
  (cgMap : MapCongruence map), MapCongruence (lndt_map map).
Proof.
  unfold MapCongruence, Map. intros.
  functional induction (lndt_map map A B f x).
  + auto.
  + simpl; rewrite H. rewrite IHl with (g:= map A B g). reflexivity. intro ; apply cgMap; assumption.
Defined.

(** ** Composition function *)
Lemma lndt_cmp_map : forall {F : TT} {map : Map F} (cgMap : MapCongruence map)
  (cpMap : MapComposition map), MapComposition (lndt_map map).
Proof.
unfold MapComposition, MapCongruence.
intros until x. revert f g. revert B C. revert x.
induction x.
+ reflexivity.
+ intros; simpl.
  rewrite <- (IHx _ _ (map A B f) (map B C g)).
  rewrite lndt_cng_map with
    (f := (map A C (fun x0 : A => g (f x0))))
    (g:= (fun x0 => map B C g (map A B f x0))) ; auto.
Qed.

Definition lndt_mapable {F : TT} (mp : MapAble F) : MapAble (LNDT F) :=
  mkMap (LNDT F)
        (lndt_map (map F mp))
        (lndt_cng_map (map_congru F mp))
        (lndt_cmp_map (map_congru F mp) (map_compo F mp)).

(** ** Fold functions *)
Fixpoint lndt_foldr (F : TT) (foldr : Fold F) A B (f : B -> A -> B) (b0 : B) (t : LNDT F A) :=
match t with
 |empty _ _ => b0
 |nest _ _ x v  => f (lndt_foldr _ foldr _ _ (foldr _ _ f) b0 v) x
end.

Definition foldlist  : Fold list  := fun A B f b l => @List.fold_left B A f l b.

Eval compute in (lndt_foldr _ foldlist nat nat Nat.add 0 nested1).
(* = 7 : nat *)

Eval compute in (lndt_foldr _ foldlist nat nat Nat.add 0 nested2).
(* = 12 : nat *)

Eval compute in (lndt_foldr _ (tuple_foldr 2) nat nat Nat.add 0 nested3).
(* = 25 : nat *)

Definition lndt_sum F (foldr : Fold F) (t : LNDT F nat) :=
lndt_foldr _ foldr nat nat Nat.add 0 t.

Eval compute in (lndt_sum (Tuple 2) (tuple_foldr 2) nested3).
(* = 25 : nat *)

Fixpoint lndt_foldl {F : TT} (foldl : Fold F) A B (f : B -> A -> B) (b0 : B) (t : LNDT F A) :=
match t with
 |empty _ _     => b0
 |nest  _ _ x e => lndt_foldl foldl _ _ (foldl _ _ f) (f b0 x) e
end.

Definition lndt_foldable {F : TT} (fp : FoldAble F) : FoldAble (LNDT F) :=
  mkFold (LNDT F)
        (lndt_foldl (foldl F fp))
        (lndt_foldr F (foldr F fp)).

(** ** Size function *)
Definition lndt_size F fold A := lndt_foldr F fold A nat (fun x => fun y => S x) 0.

Eval compute in (lndt_size list foldlist nat nested2).
(* = 7 : nat *)

Eval compute in (lndt_size (Tuple 2) (tuple_foldr 2) nat nested3).
(* = 13 : nat *)

(** ** Any predicate transformer *)
Fixpoint lndt_any {F : TT} (T : TransPred F) A (P : A -> Prop) (t : LNDT F A) :=
match t with
 |empty _ _ => False
 |nest _ _ x e  => (P x) \/ (lndt_any T _ (T _ P) e)
end.

Lemma lndt_any_ex1 : lndt_any (tuple_any 2) nat (fun x => x > 2) nested3.
Proof. compute. lia. Qed.

Lemma lndt_any_ex2 : not(lndt_any (tuple_any 2) nat (fun x => x > 3) nested3).
Proof. compute. lia. Qed.

Lemma lndt_dec_any : forall {F : TT} (T : TransPred F),
    TransDec T -> TransDec (lndt_any T).
Proof.
unfold TransDec, Dec, TransPred. intros F T Hyp A P HdecA x.
induction x.
  + intuition.
  + simpl. specialize (Hyp A P).
    specialize (IHx (T A P) (Hyp HdecA)). destruct IHx.
     { tauto. }
     { destruct (HdecA a).
        - tauto.
        - right. intro Hfalse. destruct Hfalse; contradiction. }
Defined.

(** ** All predicate transformer *)
Fixpoint lndt_all {F : TT} (T : TransPred F) A (P : A -> Prop) (t : LNDT F A) :=
match t with
 |empty _ _ => True
 |nest _ _ x e  => (P x) /\ (lndt_all T _ (T _ P) e)
end.

Lemma lndt_all_ex1:
 not(lndt_all (tuple_all 2) nat (fun x => x > 2) nested3).
Proof. compute. lia. Qed.

Lemma lndt_all_ex2:
 lndt_any (tuple_any 2) nat (fun x => x < 4) nested3.
Proof. compute. lia. Qed.

Lemma lndt_dec_all : forall {F : TT} (T : TransPred F),
    TransDec T -> TransDec (lndt_all T).
Proof.
unfold TransDec, Dec, TransPred. intros F T Hyp A P HdecA x.
induction x.
  + simpl. tauto.
  + simpl. specialize (Hyp A P).
    specialize (IHx (T A P) (Hyp HdecA)). destruct IHx.
     { destruct (HdecA a).
        - tauto.
        - right. intro Hfalse. tauto. }
     { right. intro Hfalse. tauto.    }
Defined.

Definition lndt_any_all_able {F : TT} (aa : AnyAllAble F) : AnyAllAble (LNDT F) :=
  mkAnyAll (LNDT F)
           (lndt_any (any F aa))
           (lndt_dec_any _ (dec_any F aa))
           (lndt_all (all F aa))
           (lndt_dec_all _ (dec_all F aa)).

(** ** Decidability of equality *)
Lemma lndt_dec_eq {F : TT} : DecEq F -> DecEq (LNDT F).
Proof.
unfold DecEq, Decidable. intros Hyp A HdecA.
induction x ; destruct y.
 + intuition.
 + right ; intro H ; inversion H.
 + right ; intro H ; inversion H.
 + specialize (Hyp A HdecA).
   specialize (IHx Hyp).  elim (HdecA a a0) ; intro HypeqA.
    - subst.  elim (IHx y) ; intro Hypeqy.
       * left; subst; auto.
       * right ; intro Hpb. inversion Hpb; contradiction.
    - right; intro Hpb ; inversion Hpb; contradiction.
Defined.

Definition lndt_eq_able {F : TT} (eq : EqAble F) : EqAble (LNDT F) :=
  mkEq (LNDT F) (lndt_dec_eq (dec_eq F eq)).

(** * Nested is spreadable. *)
Definition lndt_spreadable {F : TT} (sp : SpreadAble F) : SpreadAble (LNDT F) :=
  mkSpread (LNDT F)
    (lndt_foldable (fold_able F sp))
    (lndt_mapable (map_able F sp))
    (lndt_any_all_able (any_all_able F sp))
    (lndt_eq_able (eq_able F sp)).

Definition size_lndt {F : TT} (sp : SpreadAble F) A : LNDT F A -> nat :=
 (lndt_foldr _ (foldr _ (fold_able _ sp)) A nat (fun (x : nat) (_ : A) => x + 1) 0).

Eval compute in (size_lndt (tuple_spreadable 2) _ nested3).
(* = 13 : nat *)

(* Random generation / PBT *)

From QuickChick Require Import QuickChick Tactics.

Module DoNotation.
Notation "'do!' X <- A ; B" :=
  (bindGen A (fun X => B))
    (at level 200, X ident, A at level 100, B at level 200).
End DoNotation.

Import DoNotation.

Fixpoint lndt_gen_sized {F : TT} (gen_F : Gensized F )
 ( A : Type) (g: nat -> G A) (size : nat) : G (LNDT F A):=
match size with
| 0 => returnGen (empty F _)
| S size' =>
 freq_ (returnGen (empty F _ ))
  ((1,returnGen (empty F _)) ::
   (1,do! p0 <- g size' ;
      do! p1 <- lndt_gen_sized gen_F (F A) (gen_F _  g) size';
      returnGen (nest _ _ p0 p1)):: nil)
 end.

Open Scope string.

Fixpoint lndt_print {F : TT} {show_F : Printable F}
{ A : Type} `{sh : Show A} ( t : LNDT F A):=
  match t with
    | empty _ _ => "empty"
    | nest _ _ x e => "(" ++ show x ++ ", " ++ (@lndt_print F show_F (F A) (show_F A sh)  e) ++ ")"
  end.


Require Import Setoid.
Require Import Morphisms.
Require Import Coq.Program.Basics.
Require Import NArith.
Require Import List.
Import ListNotations.
Open Scope list.
Require Import Lia.

Unset Printing Records.

From Ordinal Require Import Defs.
From Ordinal Require Import Operators.
From Ordinal Require Import Arith.
From Ordinal Require Import Cantor.
From Ordinal Require Import Fixpoints.
From Ordinal Require Import Reflection.
From Ordinal Require Import VeblenDefs.
From Ordinal Require Import VeblenCon.

Open Scope ord_scope.

Lemma onePlus_complete x : complete x -> complete (1 + x).
Proof.
  intros; apply addOrd_complete; auto.
  apply succ_complete; apply zero_complete.
Qed.

Lemma onePlus_normal : normal_function (addOrd 1).
Proof.
  constructor.
  - intros; apply addOrd_monotone; auto with ord.
  - intros; apply addOrd_increasing; auto.
  - red; intros; apply addOrd_continuous; auto.
  - intros; apply addOrd_complete; auto.
    apply succ_complete. apply zero_complete.
  - intros.
    rewrite <- addOrd_le1.
    apply succ_lt.
Qed.

Lemma veblen_onePlus_complete a x :
  complete a -> complete x -> complete (veblen (addOrd 1) a x).
Proof.
  intros; apply veblen_complete; auto.
  apply onePlus_normal.
  apply onePlus_complete.
Qed.

Lemma onePlus_nonzero : forall x, 0 < 1+x.
Proof.
  intros.
  rewrite <- addOrd_le1. apply succ_lt.
Qed.

Theorem onePlus_least f :
  (forall x y, x < y -> f x < f y) ->
  (forall x, 0 < f x) ->
  forall x, 1+x <= f x.
Proof.
  intros.
  induction x using ordinal_induction.
  rewrite addOrd_unfold.
  apply lub_least.
  apply succ_least; auto.
  apply sup_least. intro i.
  apply succ_least.
  rewrite (H1 (x i)).
  apply H; auto.
  apply index_lt.
  apply index_lt.
Qed.

Theorem onePlus_least_normal f :
    normal_function f ->
    forall x, complete x -> 1+x <= f x.
Proof.
  intros.
  induction x using ordinal_induction.
  rewrite addOrd_unfold.
  apply lub_least.
  apply succ_least.
  apply normal_nonzero; auto.
  apply sup_least. intro i.
  apply succ_least.
  rewrite (H1 (x i)).
  apply normal_increasing; auto.
  apply index_lt.
  apply index_lt.
  apply complete_subord. auto.
Qed.

Lemma onePlus_finite : forall n, natOrdSize n < 1 + natOrdSize n.
Proof.
  induction n; simpl.
  rewrite addOrd_zero_r.
  apply succ_lt.
  rewrite addOrd_succ.
  apply succ_trans.
  apply succ_least.
  auto.
Qed.

Lemma onePlus_veblen f x y :
  normal_function f ->
  x > 0 ->
  complete x ->
  complete y ->
  1 + veblen f x y ≈ veblen f x y.
Proof.
  split; intros.
  - rewrite <- (veblen_fixpoints f H 0 x y) at 2; auto.
    rewrite veblen_zero.
    apply onePlus_least_normal; auto.
    apply veblen_complete; auto.
    apply normal_complete; auto.
    apply zero_complete.
  - apply addOrd_le2.
Qed.

Lemma finite_veblen f x y n :
  normal_function f ->
  x > 0 ->
  complete x ->
  complete y ->
  natOrdSize n + veblen f x y ≈ veblen f x y.
Proof.
  intros. induction n; simpl.
  - rewrite addOrd_zero_l. reflexivity.
  - transitivity
      ((natOrdSize (1+n)%nat + veblen f x y)).
    rewrite natOrdSize_add.
    simpl.
    rewrite addOrd_succ. rewrite addOrd_zero_r.
    reflexivity.
    rewrite natOrdSize_add.
    rewrite <- addOrd_assoc.
    simpl.
    rewrite onePlus_veblen; auto.
Qed.

Lemma finite_veblen_lt f x y n :
  normal_function f ->
  x > 0 ->
  complete x ->
  complete y ->
  natOrdSize n < veblen f x y.
Proof.
  intros.
  apply ord_lt_le_trans with (natOrdSize n + 1).
  rewrite addOrd_succ.
  apply succ_trans. apply addOrd_zero_r.
  rewrite <- (finite_veblen f x y n); auto.
  apply addOrd_monotone; auto with ord.
  apply succ_least. apply veblen_nonzero; auto.
Qed.

Lemma finite_veblen_le f x y n :
  normal_function f ->
  x > 0 ->
  complete x ->
  complete y ->
  natOrdSize n <= veblen f x y.
Proof.
  intros.
  rewrite <- (finite_veblen f x y n); auto.
  apply addOrd_le1.
Qed.

Theorem veblen_onePlus :
  forall a x, complete a -> complete x -> veblen (addOrd 1) a x ≈ expOrd ω a + x.
Proof.
  induction a as [A f Ha]. induction x as [X g Hx].
  split.
  - rewrite veblen_unroll.
    apply lub_least.
    + apply addOrd_monotone; auto with ord.
      apply succ_least.
      apply expOrd_nonzero.
    + unfold boundedSup.
      apply sup_least; intro i.
      apply fixOrd_least.
      * intros; apply veblen_monotone; auto.
        intros; apply addOrd_monotone; auto with ord.
      * rewrite ord_le_unfold. simpl ordSize. intro a.
        simpl in a. rewrite Hx; auto.
        apply addOrd_increasing.
        apply (index_lt (ord X g) a).
        apply H0.
      * rewrite (Ha i).
        rewrite addOrd_assoc.
        apply addOrd_monotone; auto with ord.
        apply expOrd_add_collapse; auto.
        apply (index_lt (ord A f)).
        apply H.
        apply addOrd_complete; auto.
        apply expOrd_complete; auto.
        apply (index_lt _ 0%nat).
        apply omega_complete.

  - unfold addOrd at 1.
    rewrite foldOrd_unfold.
    apply lub_least.
    + rewrite expOrd_unfold.
      apply lub_least.
      { apply succ_least.
        apply veblen_nonzero.
        apply onePlus_normal. }
      apply sup_least; intro i.
      rewrite veblen_unroll.
      rewrite <- lub_le2.
      unfold boundedSup.
      rewrite <- (sup_le _ _ i).
      unfold fixOrd.
      rewrite mulOrd_unfold.
      apply sup_least; intro n.
      rewrite <- (sup_le _ _ (S n)).
      transitivity (expOrd ω (f i) * (S n : ω)).
      simpl.
      rewrite mulOrd_succ.
      reflexivity.
      generalize (S n). clear n.
      induction n.
      * simpl. rewrite mulOrd_zero_r. auto with ord.
      * simpl.
        rewrite mulOrd_succ.
        etransitivity.
        2: { apply veblen_monotone.
             intros; apply addOrd_monotone; auto with ord.
             apply IHn. }
        rewrite Ha.
        ** clear.
           unfold sz. simpl ordSize.
           induction n; simpl natOrdSize.
           rewrite mulOrd_zero_r.
           rewrite addOrd_zero_l.
           rewrite addOrd_zero_r.
           reflexivity.
           rewrite mulOrd_succ.
           rewrite addOrd_assoc.
           rewrite IHn.
           reflexivity.
        ** apply H.
        ** apply mulOrd_complete.
           apply expOrd_complete.
           apply (index_lt _ 0%nat).
           apply omega_complete.
           apply H.
           apply natOrdSize_complete.

    + apply sup_least; intro i. simpl ordSize.
      transitivity (succOrd (expOrd ω (ord A f) + g i)).
      reflexivity.
      rewrite <- Hx; auto.
      apply succ_least.
      destruct (complete_zeroDec (ord A f)); auto.
      * eapply ord_le_lt_trans.
        apply veblen_monotone_first.
        intros; apply addOrd_monotone; auto with ord.
        apply H1.
        eapply ord_lt_le_trans.
        apply veblen_increasing0.
        apply onePlus_normal. apply H0.
        apply (index_lt (ord X g) i).
        apply veblen_monotone_first; auto with ord.
        intros; apply addOrd_monotone; auto with ord.
      * apply veblen_increasing_nonzero; auto.
        apply onePlus_normal.
        apply (index_lt (ord X g) i).
      * apply H0.
Qed.

Lemma veblen_fixpoint_zero f a x :
  normal_function f ->
  0 < a ->
  complete a ->
  complete x ->
  f (veblen f a x) <= veblen f a x.
Proof.
  intros.
  transitivity (veblen f 0 (veblen f a x)).
  rewrite veblen_zero. reflexivity.
  apply veblen_fixpoints; auto.
  apply zero_complete.
Qed.

Lemma veblen_monotone_full f g a x b y :
  (forall x y, x <= y -> g x <= g y) ->
  (forall x, f x <= g x) ->
  a <= b ->
  x <= y ->
  veblen f a x <= veblen g b y.
Proof.
  revert y a x.
  induction b as [b Hb] using ordinal_induction.
  induction y as [y Hy] using ordinal_induction.

  intros.
  rewrite (veblen_unroll f a x).
  rewrite (veblen_unroll g b y).
  apply lub_least.
  - rewrite <- lub_le1.
    transitivity (g x); auto.
  - destruct a as [A r]. simpl.
    apply sup_least; intro ai.
    rewrite <- lub_le2.
    destruct b as [B s]; simpl.
    destruct (ord_le_subord (ord A r) (ord B s) H1 ai) as [bi ?].
    rewrite <- (sup_le _ _ bi).
    unfold fixOrd. apply sup_ord_le_morphism.
    intro m.
    induction m; simpl.
    + rewrite ord_le_unfold; simpl; intro xi.
      destruct (ord_le_subord x y H2 xi) as [yi ?].
      rewrite ord_lt_unfold. simpl. exists yi.
      apply Hy; auto with ord.
    + apply Hb; auto with ord.
Qed.

Lemma veblen_monotone_func f g :
  normal_function f ->
  normal_function g ->
  (forall i, complete i -> f i <= g i) ->
  forall a x, complete a -> complete x ->
    veblen f a x <= veblen g a x.
Proof.
  intros Hf Hg H.
  induction a as [A h Ha].
  induction x as [X k Hx].
  intros.
  do 2 rewrite veblen_unroll.
  apply lub_least.
  - rewrite <- lub_le1. apply H; auto.
  - simpl.
    apply sup_least; intro i.
    rewrite <- lub_le2.
    rewrite <- (sup_le _ _ i).
    unfold fixOrd.
    apply sup_least; intro n.
    rewrite <- (sup_le _ _ n).
    transitivity (iter_f (veblen g (h i)) (limOrd (fun x0 : X => veblen f (ord A h) (k x0))) n).
    { induction n; simpl iter_f.
      reflexivity.
      transitivity
        (veblen g (h i)
                (iter_f (veblen f (h i)) (limOrd (fun x : X => veblen f (ord A h) (k x))) n)).
      apply (Ha i). apply H0.
      apply iter_f_complete.
      apply lim_complete; auto.
      intros; apply veblen_complete; auto.
      apply normal_complete; auto.
      apply H1.
      { red; intros. destruct (complete_directed (ord X k) H1 a1 a2) as [a' [??]].
        exists a'; split.
        apply veblen_monotone; auto.
        apply normal_monotone; auto.
        apply veblen_monotone; auto.
        apply normal_monotone; auto. }
      apply H1.
      intros; apply veblen_complete; auto.
      apply normal_complete; auto.
      apply H0.
      apply veblen_monotone; auto.
      apply normal_monotone; auto. }

    apply iter_f_monotone.
    intros; apply veblen_monotone; auto.
    apply normal_monotone; auto.
    rewrite ord_le_unfold; intro q. simpl.
    rewrite ord_lt_unfold; exists q; simpl.
    apply Hx; auto.
    apply H1.
Qed.

Add Parametric Morphism : (veblen (addOrd 1))
    with signature ord_le ==> ord_le ==> ord_le
      as veblen_onePlus_le_mor.
Proof.
  intros.
  apply veblen_le_mor; auto.
  intros; apply addOrd_monotone; auto with ord.
Qed.

Add Parametric Morphism : (veblen (addOrd 1))
    with signature ord_eq ==> ord_eq ==> ord_eq
      as veblen_onePlus_eq_mor.
Proof.
  intros.
  apply veblen_eq_mor; auto.
  intros; apply addOrd_monotone; auto with ord.
Qed.

Add Parametric Morphism : (veblen (expOrd ω))
    with signature ord_le ==> ord_le ==> ord_le
      as veblen_expOmega_le_mor.
Proof.
  intros.
  apply veblen_le_mor; auto.
  apply expOrd_monotone; auto.
Qed.

Add Parametric Morphism : (veblen (expOrd ω))
    with signature ord_eq ==> ord_eq ==> ord_eq
      as veblen_expOmega_eq_mor.
Proof.
  intros.
  apply veblen_eq_mor; auto.
  apply expOrd_monotone; auto.
Qed.

Local Hint Unfold powOmega : core.
Local Hint Resolve veblen_complete
        onePlus_normal powOmega_normal expOrd_complete addOrd_complete
        omega_complete succ_complete zero_complete
        normal_monotone normal_complete omega_gt0 omega_gt1 : core.

Lemma veblen_additively_closed a b :
  complete a -> complete b ->
  additively_closed (veblen (expOrd ω) a b).
Proof.
  intros. red. intros x y Hx Hy.
  destruct (complete_zeroDec a) as [Ha|Ha]; auto.
  - assert (veblen (expOrd ω) a b ≈ expOrd ω b).
    { split.
      transitivity (veblen (expOrd ω) 0 b).
      apply veblen_monotone_first; auto.
      rewrite veblen_zero. reflexivity.
      rewrite veblen_unroll.
      apply lub_le1. }
    rewrite H1 in Hx, Hy.
    rewrite H1.
    apply expOmega_additively_closed; auto.
  - assert (veblen (expOrd ω) a b ≈ expOrd ω (veblen (expOrd ω) a b)).
    { rewrite <- (veblen_fixpoints _ powOmega_normal 0) at 1; auto.
      rewrite veblen_zero.  reflexivity. }
    rewrite H1 in Hx, Hy.
    rewrite H1.
    apply expOmega_additively_closed; auto.
Qed.

Lemma Γ_additively_closed a :
  complete a -> additively_closed (Γ a).
Proof.
  red; intros.
  rewrite Γ_fixpoints; auto.
  rewrite Γ_fixpoints in H0, H1; auto.
  apply veblen_additively_closed; auto.
  apply normal_complete; auto.
  apply Γ_normal.
Qed.

Lemma veblen_collapse f (Hf:normal_function f) :
  forall a b c,
    complete a ->
    complete b ->
    complete c ->
    a < c ->
    b <= c ->
    veblen f c 0 <= c ->
    veblen f a b <= c.
Proof.
  intros.
  transitivity (veblen f c 0); auto.
  rewrite <- (veblen_fixpoints f Hf a c 0); auto.
  apply veblen_monotone; auto.
  rewrite H3.
  apply (normal_inflationary (fun i => veblen f i 0)); auto.
  apply veblen_first_normal; auto.
Qed.

Lemma veblen_collapse' f (Hf:normal_function f) :
  forall a b c,
    complete a ->
    complete b ->
    complete c ->
    a < c ->
    b < c ->
    veblen f c 0 <= c ->
    veblen f a b < c.
Proof.
  intros.
  apply ord_lt_le_trans with (veblen f c 0); auto.
  rewrite <- (veblen_fixpoints f Hf a c 0); auto.
  apply veblen_increasing; auto.
  apply ord_lt_le_trans with c; auto.
  apply (normal_inflationary (fun i => veblen f i 0)); auto.
  apply veblen_first_normal; auto.
Qed.

Lemma veblen_subterm1 f (Hf:normal_function f) :
  forall a a' b,
    complete a ->
    complete a' ->
    complete b ->
    0 < b ->
    a <= a' ->
    a < veblen f a' b.
Proof.
  intros.
  apply ord_le_lt_trans with (veblen f a' 0).
  transitivity (veblen f a 0).
  apply (normal_inflationary (fun i => veblen f i 0)); auto.
  apply veblen_first_normal; auto.
  apply veblen_monotone_first; auto.
  apply veblen_increasing; auto.
Qed.

Lemma veblen_shrink_lemma f (Hf:normal_function f) :
  forall a b,
    complete a ->
    complete b ->
    a < veblen f a 0 ->
    b < veblen f b 0 ->
    veblen f a b < veblen f (veblen f a b) 0.
Proof.
  intros.
  apply ord_lt_le_trans with
      (veblen f a (veblen f (veblen f a b) 0)).
  - apply veblen_increasing; auto.
    apply ord_lt_le_trans with (veblen f b 0); auto.
    apply veblen_monotone_first; auto.
    apply veblen_inflationary; auto.
  - apply veblen_fixpoints; auto.
    apply ord_lt_le_trans with (veblen f a 0); auto.
    apply veblen_monotone; auto with ord.
Qed.

Lemma veblen_subterm_zero f (Hf:normal_function f) :
  forall a b c,
    complete a ->
    complete b ->
    complete c ->
    a < c ->
    b < veblen f c 0 ->
    veblen f a b < veblen f c 0.
Proof.
  intros.
  apply ord_lt_le_trans with (veblen f a (veblen f c 0)).
  apply veblen_increasing; auto.
  apply veblen_fixpoints; auto.
Qed.

Lemma veblen_subterm1_zero_nest f (Hf:normal_function f) :
  forall a b c,
    complete a ->
    complete b ->
    complete c ->
    a < c ->
    b < c ->
    veblen f a b < veblen f c 0.
Proof.
  intros.
  apply veblen_subterm_zero; auto.
  apply ord_lt_le_trans with c; auto.
  apply (normal_inflationary (fun i => veblen f i 0)); auto.
  apply veblen_first_normal; auto.
Qed.

Lemma veblen_increasing' f (Hf:normal_function f) :
  forall a b c d,
    complete a ->
    complete d ->
    a <= b ->
    c < d ->
    veblen f a c < veblen f b d.
Proof.
  intros.
  apply ord_lt_le_trans with (veblen f a d).
  apply veblen_increasing; auto.
  apply veblen_monotone_first; auto.
Qed.

Lemma ordering_correct_normal:
  forall f x y o,
    normal_function f ->
    complete x ->
    complete y ->
    ordering_correct o x y ->
    ordering_correct o (f x) (f y).
Proof.
  intros. destruct o; simpl in *.
  apply normal_increasing; auto.
  destruct H2; split; apply normal_monotone; auto with ord.
  apply normal_increasing; auto.
Qed.

Lemma veblen_compare_correct f (Hf:normal_function f) :
  forall oab oxy oxVby oVaxy a b x y,
    complete a ->
    complete b ->
    complete x ->
    complete y ->
    ordering_correct oab a b ->
    ordering_correct oxy x y ->
    ordering_correct oxVby x (veblen f b y) ->
    ordering_correct oVaxy (veblen f a x) y ->
    ordering_correct
      (match oab with
      | LT => oxVby
      | EQ => oxy
      | GT => oVaxy
      end) (veblen f a x) (veblen f b y) .
Proof.
  do 8 intro. intros Ha Hb Hx Hy Hoab Hoxy HoxVby HVaxy.
  destruct oab; simpl in *.
  - destruct oxVby; simpl in *.
    + apply ord_lt_le_trans with (veblen f a (veblen f b y)).
      apply veblen_increasing; auto.
      apply veblen_fixpoints; auto.
    + transitivity (veblen f a (veblen f b y)).
      { split; (apply veblen_monotone; [ intros; apply normal_monotone; auto with ord | apply HoxVby ]). }
      apply veblen_fixpoints; auto.
    + apply ord_lt_le_trans with x; auto.
      apply veblen_inflationary; auto.
  - destruct oxy; simpl in *.
    + apply ord_lt_le_trans with (veblen f a y).
      apply veblen_increasing; auto.
      apply veblen_monotone_first; auto.
      apply Hoab.
    + transitivity (veblen f a y).
      split; apply veblen_monotone; auto; apply Hoxy.
      split; apply veblen_monotone_first; auto; apply Hoab.
    + apply ord_le_lt_trans with (veblen f a y).
      apply veblen_monotone_first; auto. apply Hoab.
      apply veblen_increasing; auto.
  - destruct oVaxy; simpl in *.
    + apply ord_lt_le_trans with y; auto.
      apply veblen_inflationary; auto.
    + symmetry.
      transitivity (veblen f b (veblen f a x)).
      split; apply veblen_monotone; auto; apply HVaxy.
      apply veblen_fixpoints; auto.
    + apply ord_lt_le_trans with (veblen f b (veblen f a x)).
      apply veblen_increasing; auto.
      apply veblen_fixpoints; auto.
Qed.

Lemma compose_normal f g :
  normal_function f ->
  normal_function g ->
  normal_function (fun x => f (g x)).
Proof.
  intros. constructor.
  - intros; do 2 (apply normal_monotone; auto).
  - intros. apply normal_increasing; auto.
    apply normal_increasing; auto.
  - hnf; intros A h a Hd Hc.
    transitivity (f (supOrd (fun i => g (h i)))).
    apply normal_monotone; auto.
    apply normal_continuous; auto.
    apply normal_continuous; auto.
    hnf; intros.
    destruct (Hd a1 a2) as [a' [??]].
    exists a'.
    split; apply normal_monotone; auto.
  - intros. apply normal_complete; auto.
  - intros; apply normal_nonzero; auto.
Qed.

Lemma veblen_first_onePlus_normal f :
  normal_function f ->
  normal_function (fun i => veblen f (1+i) 0).
Proof.
  intros.
  apply (compose_normal (fun i => veblen f i 0) (fun i => 1+i)).
  apply veblen_first_normal; auto.
  apply onePlus_normal; auto.
Qed.

Lemma veblen_func_onePlus_lemma f :
  normal_function f ->
  forall a x b y,
    complete a ->
    complete x ->
    complete b ->
    complete y ->
    0 < b ->
    a <= b -> x <= y ->
    veblen (fun i => f (1+i)) a x <= veblen f b y.
Proof.
  intros Hf.
  induction a as [a Hind_a] using ordinal_induction.
  induction x as [x Hind_x] using ordinal_induction.
  intros b y Ha Hx Hb Hy Hb0 Hab Hxy.
  rewrite veblen_unroll at 1.
  apply lub_least.
  - rewrite <- (veblen_fixpoints _ Hf 0); auto.
    rewrite veblen_zero.
    apply normal_monotone; auto.
    rewrite <- onePlus_veblen; auto.
    apply addOrd_monotone; auto with ord.
    rewrite Hxy. apply veblen_inflationary; auto.
  - destruct a as [A fa]; simpl; apply sup_least; intros i.
    apply fixOrd_least; auto with ord.
    + intros; apply veblen_monotone; auto.
    + rewrite ord_le_unfold; simpl; intro ix.
      rewrite (Hind_x (x ix) (index_lt x ix) b (x ix)); auto with ord.
      apply veblen_increasing; auto.
      apply ord_lt_le_trans with x; auto with ord.
      apply complete_subord; auto.
      apply complete_subord; auto.
    + destruct (complete_zeroDec (fa i)); auto.
      * apply Ha.
      * transitivity (veblen (fun i0 : Ord => f (1 + i0)) 0 (veblen f b y)).
        apply veblen_monotone_first; auto with ord.
        rewrite <- (veblen_fixpoints _ Hf 0 b y) at 2; auto.
        rewrite veblen_zero.
        rewrite veblen_zero.
        apply normal_monotone; auto.
        apply onePlus_veblen; auto.
      * rewrite <- (veblen_fixpoints _ Hf (fa i) b y) at 2; auto.
        apply (Hind_a (fa i) (index_lt (ord A fa) i) (veblen f b y) (fa i) (veblen f b y)); auto with ord.
        apply Ha.
        apply Ha.
        apply Ha.
        apply ord_lt_le_trans with (ord A fa); auto with ord.
Qed.

Lemma veblen_func_onePlus f :
  normal_function f ->
  forall a x,
    complete a ->
    complete x ->
    0 < a ->
    veblen (fun i => f (1+i)) a x ≈ veblen f a x.
Proof.
  intros; split.
  apply veblen_func_onePlus_lemma; auto with ord.
  apply veblen_monotone_func; auto.
  apply (compose_normal f (fun i => 1+i)); auto.
  intros; apply normal_monotone; auto.
  apply addOrd_le2.
Qed.

Require Import ClassicalFacts.
From Ordinal Require Import Classical.

Lemma veblen_decompose (EM:excluded_middle) f (Hf:normal_function f) :
  forall x
    (Hlim : limitOrdinal x),
    x < veblen f x 0 ->
    f x ≤ x ->
    exists a b, x ≈ veblen f a b /\ 0 < a /\ a < x /\ b < x.
Proof.
  intros x Hlim Hx1 Hx2.

  set (P a := a > 0 /\ exists b, b < x /\ x <= veblen f a b).
  destruct (classical.ord_well_ordered EM P x) as [a [[Ha0 Ha] Hleast]]; auto.
  { red. split. rewrite <- Hx2. apply normal_nonzero; auto.
    exists 0. split; auto with ord. rewrite <- Hx2. apply normal_nonzero; auto. }
  destruct Ha as [b0 Hb0].

  set (Q b := b < x /\ x <= veblen f a b).
  destruct (classical.ord_well_ordered EM Q b0) as [b [[Hb Hab] Hbleast]]; auto.
  unfold P in *.
  unfold Q in *.

  assert (Hle : veblen f a b ≤ x).
  { rewrite veblen_unroll.
    apply lub_least.
    - rewrite <- Hx2.
      apply normal_monotone; auto with ord.
    - apply boundedSup_least. intros i Hi.
      apply normal_fix_least; auto.
      + apply veblen_normal; auto.
        apply classical.ord_complete; auto.
      + apply classical.ord_complete; auto.
      + rewrite ord_le_unfold; simpl; intros.
        destruct (classical.order_total EM x (veblen f a (b a0))) as [H|H]; auto.
        elim (ord_lt_irreflexive b).
        apply ord_le_lt_trans with (b a0); auto with ord.
        apply Hbleast; split; auto with ord.
        apply ord_lt_trans with b; auto with ord.
      + destruct (classical.order_total EM i 0) as [Hi0|Hi0].
        { apply ord_le_trans with (veblen f 0 x).
          apply veblen_monotone_first; auto.
          rewrite veblen_zero. auto. }
        transitivity (veblen f i (boundedSup x (fun i => i))).
        { apply veblen_monotone; auto.
          apply limit_boundedSup; auto. }
        transitivity (supOrd (fun q => veblen f i (x q))).
        { destruct x as [X g]; simpl.
          rewrite ord_lt_unfold in Hb. destruct Hb.
          apply veblen_continuous; auto.
          apply classical.ord_complete; auto.
          apply classical.ord_directed; auto.
          intros; apply classical.ord_complete; auto. }
        apply sup_least; intro q.
        destruct (classical.order_total EM (veblen f i (x q)) x) as [H|H]; auto.
        elim (ord_lt_irreflexive a).
        apply ord_le_lt_trans with i; auto.
        apply Hleast; split; eauto with ord.
  }

  assert (Hax : a < x).
  { destruct (classical.order_total EM x a); auto. exfalso.
    elim (ord_lt_irreflexive x).
    apply ord_lt_le_trans with (veblen f x 0); [ exact Hx1 | ].
    transitivity (veblen f a 0).
    apply veblen_monotone_first; auto.
    rewrite <- Hle.
    apply veblen_monotone; auto with ord.
  }

  exists a, b; intuition.
  split; auto.
Qed.


Require Import Coq.Sets.Partial_Order.
Require Import Coq.Sets.Cpo.
Require Import Coq.Logic.Classical_Prop.

Section Poset_Properties.

  Variable U : Type.
  Variable P : PO U.

  Eval compute in (Carrier_of U P).

  Definition C := @Carrier_of U P.
  Definition R := @Rel_of U P.

  Definition Above (A:Ensemble U) : Ensemble U := fun x:U => In _ C x /\ (forall y:U, In _ A y -> R y x).

  Definition Below (A:Ensemble U) : Ensemble U := fun x:U => In _ C x /\ (forall y:U, In _ A y -> R x y).

  Definition Upper_Bounded_Subset (A : Ensemble U) := Inhabited _ (Above A).

  Definition Lower_Bounded_Subset (A : Ensemble U) := Inhabited _ (Below A).

  Ltac crush_generic :=
    repeat match goal with
           | [ H : ?T |- ?T    ] => exact T
           | [ |- ?T = ?T ] => reflexivity
           | [ |- True         ] => constructor
           | [ |- _ /\ _       ] => constructor
           | [ |- _ /\ _ -> _  ] => intro
           | [ H : _ /\ _ |- _ ] => destruct H
           | [ |- nat -> _     ] => intro
           | [ H : Lower_Bounded_Subset _ |- _ ] => unfold Lower_Bounded_Subset in H
           | [ H : Upper_Bounded_Subset _ |- _ ] => unfold Upper_Bounded_Subset in H
           | [ H : In _ _ _ |- _ ] => unfold In in H
           | [ H : Included _ _ _ |- _ ] => unfold Included in H
           | _ => tauto
           end.

  Ltac unfold_all := try unfold Included;
                     try unfold Above;
                     try unfold Below;
                     try unfold In;
                     try unfold Lower_Bounded_Subset;
                     try unfold Upper_Bounded_Subset.

  Ltac crush :=
    repeat (crush_generic;
            unfold_all;
            match goal with
            | [ |- ?T -> False  ]  => assert T
            | _ => try trivial
            end).

  Lemma Below_In_Carrier : forall  (A : Ensemble U), Included _ A C -> Included _ (Below A) C.
  Proof.
    crush.
  Qed.

  Lemma Above_In_Carrier : forall  (A : Ensemble U), Included _ A C -> Included _ (Above A) C.
  Proof.
    crush.
  Qed.

  (** Lower Bound (Set) of a nonempty subset is Upper Bounded *)
  Lemma Bound_Invert : forall  (A : Ensemble U), Included _ A C /\ Inhabited _ A /\ Lower_Bounded_Subset A -> Upper_Bounded_Subset (Below A).
  Proof.
    crush.
    intros.

    crush. inversion H0. inversion H1.

    apply Inhabited_intro with (x := x).
    crush. apply H. tauto.

    intros. crush.
    specialize H6 with x. tauto.
  Qed.

  (** If every nonempty upper-bounded subset has a least upper bound, then
every nonempty lower-bounded subset has a greatest lower bound. *)
  Theorem Th : (forall A : Ensemble U, Included _ A C /\ Inhabited _ A /\ Upper_Bounded_Subset A -> exists lub, Lub _ P A lub) -> (forall B : Ensemble U, Included _ B C /\ Inhabited _ B /\ Lower_Bounded_Subset B -> exists glb, Glb _ P B glb).
  Proof.
    intros.
    specialize H with (Below B).
    pose proof Bound_Invert B H0 as R.

    crush.
    pose proof Below_In_Carrier B H0 as T.
    pose proof H (conj T (conj H2 R)) as S.
    destruct S.
    exists x.

    apply Glb_definition.

    inversion H3. apply Lower_Bound_definition.
    inversion H4. assumption.

    intros. specialize H5 with y. apply H5.
    apply Upper_Bound_definition.
    specialize H0 with y. tauto.

    intros. crush. unfold Below in H7.
    apply H7. tauto.

    intros. inversion H3. inversion H5.
    specialize H8 with y. apply H8.

    crush; inversion H4; assumption.
  Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_extension.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_layoff :
   forall A B C D,
   neq A B -> neq C D ->
   exists X, Out A B X /\ Cong A X C D.
Proof.
intros.
assert (~ eq B A).
 {
 intro.
 assert (eq A B) by (conclude lemma_equalitysymmetric).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists E, (BetS B A E /\ Cong A E C D)) by (conclude lemma_extension);destruct Tf as [E];spliter.
assert (BetS E A B) by (conclude axiom_betweennesssymmetry).
assert (neq E A) by (forward_using lemma_betweennotequal).
assert (BetS E A B) by (conclude axiom_betweennesssymmetry).
let Tf:=fresh in
assert (Tf:exists P, (BetS E A P /\ Cong A P C D)) by (conclude lemma_extension);destruct Tf as [P];spliter.
assert (Out A B P) by (conclude_def Out ).
close.
Qed.

End Euclid.