(* 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 poly polydiv fingroup perm.
From mathcomp Require Import finalg zmodp matrix mxalgebra mxpoly polydiv vector.
Require Import ssralg_ext poly_ext f2 hamming linearcode dft.

(******************************************************************************)
(*                               Cyclic codes                                 *)
(*                                                                            *)
(* Messages and codewords can be represented either as (row-)vectors or as    *)
(* polynomials. Cyclic codes are stable by right cyclic shift. We define it   *)
(* in several equivalent ways:                                                *)
(* - rcs_poly is defined using (pseudo-)division for polynomials              *)
(* - rcs is a definition for row-vectors using a permutation                  *)
(* - rcs' is a direct definition for row-vectors                              *)
(*                                                                            *)
(* Definition:                                                                *)
(*  rcsP == stability by right-cyclic-shift                                   *)
(*  'pgen[ C ] == the set of polynomial generators                            *)
(*  'cgen[ C ] == the set of cyclic generators                                *)
(*                                                                            *)
(* Lemmas:                                                                    *)
(*  rcs_rcs_poly   == Equivalence right-cyclic shift vectors <-> polynomials  *)
(*                    (see [McEliece 2002], Theorem 8.1)                      *)
(*  shift_codeword == see [McEliece 2002],  Theorem 8.2, Lemma 2(a)(b),       *)
(*                    Theorem 8.3(a)(b)                                       *)
(*                                                                            *)
(******************************************************************************)

(* OUTLINE:
- Section right_cyclic_shift
- Section fdcoor_cyclic
- Section polynomial_code_generator.
- Module Pcode : definition of polynomial codes
- Module Ccode : definition of cyclic codes
- Section cyclic_code_generator.
- Section cyclic_code_properties.
- Section polynomial_cyclic_equivalence_condition.
*)

Reserved Notation "'`[' P ']_' n" (at level 4).
Reserved Notation "''pgen[' C ]" (at level 8, format "''pgen[' C ]").
Reserved Notation "''cgen[' C ]" (at level 8, format "''cgen[' C ]").

Declare Scope cyclic_code_scope.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Import GRing.Theory.

Local Open Scope ring_scope.

Section right_cyclic_shift.

Definition rcs_perm_ffun n : {ffun 'I_n.+1 -> 'I_n.+1} :=
  [ffun x : 'I_n.+1 => if x == ord0 then ord_max else inord x.-1].

Lemma rcs_perm_ffun_injectiveb n : injectiveb (@rcs_perm_ffun n).
Proof.
apply/injectiveP => x y.
rewrite /rcs_perm_ffun 2!ffunE.
case: ifPn => [/eqP ->|x0].
  case: ifPn => [/eqP -> //|y0].
  move/eqP; rewrite -val_eqE /= => /eqP n0y.
  exfalso; move: (ltn_ord y).
  rewrite ltnNge => /negP; apply.
  rewrite [in X in X < _]n0y /= inordK //; first by rewrite prednK // lt0n.
  apply: ltn_trans (ltn_ord y); by rewrite prednK // lt0n.
case: ifPn => [/eqP -> //|y0 /eqP].
  move/eqP; rewrite -val_eqE /= => /eqP n0x.
  exfalso; move: (ltn_ord x).
  rewrite ltnNge => /negP; apply.
  rewrite -[in X in X < _]n0x /= inordK //; first by rewrite prednK // lt0n.
  apply: ltn_trans (ltn_ord x); by rewrite prednK // lt0n.
rewrite -val_eqE /= inordK; last first.
  apply: (ltn_trans _ (ltn_ord x)); by rewrite prednK // lt0n.
rewrite inordK; last first.
  apply: (ltn_trans _ (ltn_ord y)); by rewrite prednK // lt0n.
move/eqP/(congr1 S).
by rewrite prednK ?lt0n // prednK ?lt0n // => ?; apply val_inj.
Defined.

Definition rcs_perm n : {perm 'I_n} :=
  if n is n.+1 then Perm (rcs_perm_ffun_injectiveb n) else 1.

Definition rcs (R : idomainType) n (x : 'rV[R]_n) := col_perm (rcs_perm n) x.

Lemma size_rcs (R : idomainType) n (x : 'rV[R]_n.+1) :
  size (rVpoly (rcs x)) < size ('X^n.+1 - 1%:P : {poly R}).
Proof. by rewrite size_Xn_sub_1 // ltnS /rVpoly size_poly. Qed.

Lemma map_mx_rcs (R0 R1 : idomainType) n (x : 'rV[R0]_n.+1) (f : R0 -> R1) :
  map_mx f (rcs x) = rcs (map_mx f x).
Proof. by rewrite /rcs map_col_perm. Qed.

Definition rcs' (R : idomainType) n (x : 'rV[R]_n.+1) :=
  \row_(i < n.+1) (if i == ord0 then x ord0 (inord n) else x ord0 (inord i.-1)).

Lemma rcs'0 (R : idomainType) n (x : 'rV[R]_n.+1) : (rcs' x == 0) = (x == 0).
Proof.
apply/idP/idP => [|/eqP ->].
  move/eqP/rowP => H; apply/eqP/rowP => i; rewrite !mxE.
  have ni : i.+1 %% n.+1 < n.+1 by apply ltn_pmod.
  move: (H (Ordinal ni)); rewrite !mxE -val_eqE /=.
  case: ifPn => [in' Hx|in' Hx].
    have ? : n = i.
      case/dvdnP : in' => -[//|[|k abs]] /=; last first.
        exfalso; move: (ltn_ord i); rewrite ltnNge => /negP; apply.
        by rewrite -ltnS abs ltn_Pmull.
      by rewrite mul1n => /eqP; rewrite eqSS => /eqP.
    rewrite -[RHS]Hx; congr (x _ _); apply/val_inj => /=; by rewrite inordK.
  rewrite -[RHS]Hx modn_small /=; last first.
    rewrite ltnS ltn_neqAle -ltnS (ltn_ord i) andbT; apply/eqP => in''.
    by rewrite in'' modnn eqxx in in'.
  congr (x _ _); apply val_inj => /=; by rewrite inordK.
apply/eqP/rowP => i; rewrite !mxE; by case: ifPn.
Qed.

Lemma rcs'_rcs (R : idomainType) n (x : 'rV[R]_n.+1) : rcs' x = rcs x.
Proof.
rewrite /rcs' /rcs; apply/rowP => i; rewrite !mxE.
case: ifPn => [/eqP -> |i0].
  congr (x _ _); apply val_inj => /=.
  by rewrite PermDef.fun_of_permE ffunE /= inordK.
congr (x _ _); apply val_inj => /=.
rewrite PermDef.fun_of_permE ffunE /= inordK.
  by rewrite (negPf i0) inordK // (ltn_trans _ (ltn_ord i)) // prednK // lt0n.
by rewrite (ltn_trans _ (ltn_ord i)) // prednK // lt0n.
Qed.

Lemma sub_XrVpoly_rcs (R : idomainType) n (x : 'rV[R]_n.+1) :
  'X * rVpoly x - rVpoly (rcs x) = (x 0 (inord n))%:P * ('X^n.+1 - 1).
Proof.
apply/polyP => i.
rewrite coef_add_poly coefXM coefCM coef_add_poly coefXn 2!coef_opp_poly coefC.
case: ifPn => [/eqP ->|i0]; last rewrite subr0.
  rewrite 2!add0r mulrN1 coef_rVpoly /=.
  case: insubP => //= j _ j0.
  rewrite mxE PermDef.fun_of_permE ffunE /= -val_eqE j0 /= j0 eqxx; congr (- x _ _).
  by apply val_inj => /=; rewrite inordK.
case/boolP : (i == n.+1) => [/eqP ->|in0].
  rewrite mulr1 2!coef_rVpoly /=.
  case: insubP => /= [j _ j0|]; last by rewrite ltnS leqnn.
  case: insubP => /= [?|_]; first by rewrite ltnn.
  rewrite subr0; congr (x _ _); apply val_inj => /=; by rewrite j0 inordK.
rewrite mulr0 2!coef_rVpoly; case: insubP => /= [j|].
  rewrite ltnS => in0' ji; case: insubP => /= [k _ ki|].
    apply/eqP; rewrite subr_eq0; apply/eqP.
    rewrite mxE PermDef.fun_of_permE ffunE -val_eqE /= ki (negPf i0) -ji; congr (x _ _).
    apply/val_inj => /=; by rewrite inordK.
  rewrite ltnS -ltnNge => n0i; exfalso.
  rewrite -ltnS prednK // in in0'; last by rewrite lt0n.
  by move/negP : in0; apply; rewrite eq_sym eqn_leq {}n0i.
rewrite -leqNgt => n0i; case: insubP => /= [j|]; last by rewrite subrr.
rewrite ltnS => in0' ji; exfalso; move/negP : in0; apply.
by rewrite eqn_leq ltnW //= (leq_trans n0i (leq_pred i)).
Qed.

Definition rcs_poly (R : idomainType) (p : {poly R}) n := ('X * p) %% ('X^n - 1).

Lemma size_rcs_poly (R : idomainType) n (x : {poly R}) (xn : size x <= n) :
  0 < n -> size (rcs_poly x n) <= n.
Proof.
move=> n0.
rewrite /rcs_poly.
set xn1 := _ - _.
apply (@leq_trans (size xn1).-1); last by rewrite /xn1 size_Xn_sub_1.
rewrite -ltnS prednK; last by rewrite size_Xn_sub_1.
have : xn1 != 0 by apply/monic_neq0/monic_Xn_sub_1.
by move/ltn_modpN0; apply.
Qed.

(* TODO: not used? *)
Lemma size_rcs_poly_old (R : idomainType) n (x : 'rV[R]_n) : size (rcs_poly (rVpoly x) n) <= n.
Proof.
destruct n as [|n'].
  rewrite /rcs_poly subrr modp0.
  have -> : x = 0 by apply/matrixP => i [].
  by rewrite linear0 mulr0 size_poly0.
by rewrite size_rcs_poly // size_poly.
Qed.

Lemma rcs_rcs_poly (F : fieldType) n0 (x : 'rV[F]_n0) : rcs x = poly_rV (rcs_poly (rVpoly x) n0).
Proof.
destruct n0 as [|n0].
  rewrite /rcs_poly (_ : 'X^0 = 1); last first.
    by apply/polyP => i; rewrite coefXn.
  rewrite subrr modp0 (_ : rVpoly x = 0); last first.
    apply/polyP => i.
    rewrite coef_rVpoly.
    by case: insubP => //; rewrite coef0.
  rewrite mulr0 /rcs /= col_perm1.
  apply/rowP.
  case; by case.
rewrite -rcs'_rcs /rcs' /rcs_poly.
move/eqP: (sub_XrVpoly_rcs x); rewrite subr_eq => /eqP.
by case/divp_modpP/(_ (size_rcs _)) => _ <-; rewrite rVpolyK -rcs'_rcs.
Qed.

Lemma rcs_poly_rcs (F : fieldType) n0 (x : {poly F}) (xn0 : size x <= n0.+1) :
  rcs_poly x n0.+1 = rVpoly (@rcs _ n0.+1 (poly_rV x)).
Proof. rewrite rcs_rcs_poly poly_rV_K // poly_rV_K //; by apply size_rcs_poly. Qed.

Definition rcsP (F: finFieldType) n (C : {set 'rV[F]_n}) :=
  forall x, x \in C -> rcs x \in C.

End right_cyclic_shift.

Notation "'`[' P ']_' n" := (P %% ('X^n - 1)) : cyclic_code_scope.

Section fdcoor_cyclic.

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

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

Lemma fdcoor_rcs' (i : 'I_n) x : a ^+ n = 1 ->
  a ^+ i * x ^`_ i = 0 -> (rcs x) ^`_ i = 0.
Proof.
move=> an1.
rewrite /fdcoor (@horner_coef_wide _ n); last by rewrite /rVpoly size_poly.
rewrite big_distrr /=.
rewrite (eq_bigr (fun i1 : 'I_ _ => (rVpoly x)`_i1 * a ^+ i ^+ i1.+1)); last first.
  move=> i1 _; rewrite mulrC -mulrA; congr (_ * _).
  by rewrite mxE -!exprM -exprD mulnS addnC.
move=> x_RS.
rewrite (@horner_coef_wide _ n); last by move: (size_rcs x); rewrite size_Xn_sub_1.
rewrite -{}[RHS]x_RS rcs_rcs_poly; apply/esym.
rewrite (reindex_onto (@rcs_perm n) (perm_inv (@rcs_perm n))) /=; last first.
  move=> i1 _; by rewrite permKV.
rewrite (eq_bigl xpredT); last by move=> i1; rewrite permK eqxx.
apply eq_bigr => i1 _.
rewrite coef_rVpoly PermDef.fun_of_permE ffunE.
case: ifPn => [/eqP ->|].
  case: insubP => [j _ jn0|]; last by rewrite ltnS leqnn.
  rewrite /= in jn0.
  rewrite coef_rVpoly; case: insubP => // k _ k0.
  rewrite mxE rcs_poly_rcs ?rVpolyK; last by rewrite size_poly.
  rewrite coef_rVpoly_ord mxE PermDef.fun_of_permE ffunE -val_eqE k0 /= expr0 mulr1.
  by rewrite exprAC an1 expr1n mulr1; congr (x _ _); apply val_inj => /=.
case: insubP => /= [j|].
  rewrite ltnS => i1n0 ji1 i10; rewrite coef_rVpoly.
  case: insubP => /= [k|].
    rewrite ltnS => i1n0' ki1.
    rewrite mxE rcs_poly_rcs ?rVpolyK; last by rewrite size_poly.
    rewrite coef_rVpoly_ord mxE PermDef.fun_of_permE ffunE -val_eqE [val k]/= ki1 val_eqE (negPf i10).
    rewrite inordK; last by rewrite ltnW // ltnS prednK // lt0n.
    rewrite prednK // ?lt0n //; congr (x _ _ * _).
    by apply/val_inj.
    by rewrite mxE.
  rewrite ltnS => /negP abs; exfalso; apply: abs; by rewrite -ltnS.
move=> /negP abs i10; exfalso; apply abs; by rewrite ltnS inordK.
Qed.

Lemma fdcoor_rcs (i : 'I_n) x : a ^+ n = 1 ->
  x ^`_ i = 0 -> (rcs x) ^`_ i = 0.
Proof. move=> H1 H2; by rewrite (fdcoor_rcs' H1) // H2 mulr0. Qed.

Fixpoint loop (T : Type) (f : T -> T) (n : nat) (x : T) := if n is m.+1 then loop f m (f x) else x.

Lemma fdcoor_loop_rcs k (i : 'I_n) (x : 'rV_n) : a ^+ n = 1 ->
  x ^`_ i = 0 -> (loop (@rcs F n) k x) ^`_ i = 0.
Proof.
move: i x.
elim: k => // k IH i x an1 H /=.
by rewrite IH // fdcoor_rcs.
Qed.

End fdcoor_cyclic.

Section polynomial_code_generator.

Variable (F : finFieldType) (n : nat) (C : {set 'rV[F]_n}).

Definition is_pgen := [pred g | [forall x, (x \in C) == (g %| rVpoly x)]].

End polynomial_code_generator.

Notation "''pgen[' C ]" := (is_pgen C) : cyclic_code_scope.
Local Open Scope cyclic_code_scope.

Module Pcode.
Section polynomial_code.

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

Record t := mk {
  lcode0 :> Lcode0.t F n ;
  gen : {poly F} ;
  size_gen : size gen < n ;
  P : gen \in 'pgen[[set cw in lcode0]] }.

End polynomial_code.
End Pcode.

Coercion pcode_coercion (F : finFieldType) (n : nat) (c : Pcode.t F n) : {vspace 'rV[F]_n} :=
  let: Pcode.mk v _ _ _ := c in v.

Module Ccode.

Section cyclic_code_definition.

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

Record t := mk {
  lcode0 :> Lcode0.t F n ;
  P : rcsP [set cw in lcode0] }.

End cyclic_code_definition.

End Ccode.

Coercion ccode_coercion (F : finFieldType) (n : nat) (c : Ccode.t F n) : {vspace 'rV[F]_n} :=
 let: Ccode.mk v _ := c in v.

Section cyclic_code_generator.

Variable (F : finFieldType) (n : nat) (C : Ccode.t F n).
Hypothesis C_not_trivial : not_trivial C.

(* A nonzero polynomial of lowest degree in the code is called a generator
  polynomial: *)
Definition is_cgen := [pred x | non0_codeword_lowest_deg C x].

Local Notation "''cgen'" := (is_cgen).

Lemma is_cgenE g : g \in 'cgen = non0_codeword_lowest_deg C g.
Proof. by []. Qed.

Lemma size_is_cgen g : g \in 'cgen -> size (rVpoly g) <= n.
Proof. by rewrite size_poly. Qed.

Definition canonical_cgen : 'rV[F]_n := val (exists_non0_codeword_lowest_deg C_not_trivial).

Lemma canonical_cgenP : non0_codeword_lowest_deg C canonical_cgen.
Proof. rewrite /canonical_cgen; by case: exists_non0_codeword_lowest_deg. Qed.

Lemma size_canonical_cgen : size (rVpoly canonical_cgen) <= n.
Proof. by rewrite size_poly. Qed.

Lemma canonical_cgen_lowest_size : size (rVpoly canonical_cgen) = lowest_size C_not_trivial.
Proof. by []. Qed.

Definition parity_check : {poly F} := ('X^n - 1) %/ rVpoly canonical_cgen.

End cyclic_code_generator.

Notation "''cgen[' C ]" := (is_cgen C) : cyclic_code_scope.

Section cyclic_code_properties.

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

Lemma shift_codeword (c : {poly F}) (cn : size c <= n) : poly_rV c \in C ->
  forall k, poly_rV (`[ 'X^k * c ]_n) \in C.
Proof.
move=> gC; elim=> [| k ih] /=.
- by rewrite (_ : 'X^0 = 1) // mul1r modp_small // (leq_ltn_trans cn) // size_Xn_sub_1.
- have {}ih : poly_rV `[ 'X^k * c ]_ n \in [set cs in C] by rewrite inE.
  move: (Ccode.P ih); rewrite rcs_rcs_poly poly_rV_K; last first.
    rewrite -ltnS -(_ : size (('X^n : {poly F}) - 1) = n.+1); last by rewrite size_Xn_sub_1.
    by apply/ltn_modpN0/monic_neq0/monic_Xn_sub_1.
  rewrite /rcs_poly modp_mul mulrA exprS inE; by apply.
Qed.

Lemma shift_linearity_codeword (c : {poly F}) (cn : size c <= n) :
  poly_rV c \in C ->
  forall p, poly_rV (`[ p * c ]_ n) \in C.
Proof.
move=> /= cC p; rewrite -(coefK p).
have -> : \poly_(i < size p) p`_i * c = \sum_(i < size p) (p`_i *: ('X^i * c)).
  rewrite mulrC poly_def big_distrr /=.
  apply eq_bigr => k _; by rewrite mulrC scalerAl.
have -> : `[ \sum_(i < size p) (p`_i *: ('X^i * c)) ]_n  =
          \sum_(i < size p) `[ p`_i *: ('X^i * c) ]_n.
  by rewrite (big_morph (id1 := 0) _ (@morph_modp _ _)) // mod0p.
have -> : \sum_(i < size p) `[ p`_i *: ('X^i * c) ]_n  =
          \sum_(i < size p) (p`_i *: `[ 'X^i * c ]_ n ).
  apply eq_bigr => k _; by rewrite modpZl.
apply Lcode0.mem_poly_rV => j.
rewrite linearZ /= Lcode0.sclosed //; by apply shift_codeword.
Qed.

Lemma remainder_in_code (c : {poly F}) (cn : size c <= n) :
  poly_rV c \in C ->
  forall p r, p \in C ->
  rVpoly p = rVpoly p %/ c * c + r -> size r < size c ->
  poly_rV r \in C.
Proof.
move=> cC p /= r  p_in_C Hdivp_g Hsize_rem.
have -> : r = `[ r ]_n.
  symmetry; rewrite modp_small //.
  apply (@ltn_trans (size c)) => //.
  by rewrite size_Xn_sub_1 // ltnS.
rewrite (_ : r = rVpoly p - rVpoly p %/ c * c); last first.
  by rewrite {1}Hdivp_g addrAC subrr add0r.
rewrite modpD linearD /=.
have -> : `[ rVpoly p ]_n = rVpoly p.
  by rewrite modp_small // size_Xn_sub_1 // ltnS size_poly.
rewrite rVpolyK; apply Lcode0.aclosed => //.
by rewrite -mulNr shift_linearity_codeword.
Qed.

Lemma scale_cgen (g' : 'rV[F]_n) (HC : not_trivial C) :
  g' \in 'cgen[C] -> { k | (k != 0) && (g' == k *: canonical_cgen HC) }.
Proof.
move=> Hg'.
set g := canonical_cgen HC.
case/boolP : (g == g') => [/eqP ->|gg'].
  exists 1; by rewrite scale1r oner_neq0 eqxx.
have size_g := canonical_cgen_lowest_size HC.
rewrite -/g in size_g.
pose k := lead_coef (rVpoly g') / lead_coef (rVpoly g).
pose g'' : {poly F} := rVpoly g' - k *: rVpoly g.
have size_g' : size (rVpoly g') = size (rVpoly g) by rewrite size_g; apply size_lowest.
case/boolP : (k == 0) => k0.
  exfalso.
  move: k0.
  rewrite /k mulf_eq0 invr_eq0 2!lead_coef_eq0.
  case/orP; rewrite rVpoly0; apply/negP.
  by case/and3P : Hg'.
  by case/and3P : (canonical_cgenP HC).
have size_g'' : size g'' < size (rVpoly g).
  rewrite /g'' -size_g'; apply size_sub => //.
  apply/eqP; rewrite rVpoly0; by case/and3P : Hg'.
  rewrite lreg_size ?size_g' //; by apply/GRing.lregP.
  rewrite lead_coefZ /k -mulrA mulVr ?mulr1 // unitfE lead_coef_eq0 rVpoly0; by case/and3P : (canonical_cgenP HC).
have g''C : poly_rV g'' \in C.
  rewrite /g'' linearD /= linearN /= linearZ /= (proj2 (Lcode0.aclosed C)) // ?rVpolyK; first by case/and3P : Hg'.
  rewrite Lcode0.oclosed // Lcode0.sclosed //; by case/and3P : (canonical_cgenP HC).
have g''0 : g'' = 0.
  apply/eqP/negPn/negP => abs.
  case/and3P: (canonical_cgenP HC) => _ _ /forallP/(_ (poly_rV g'')).
  rewrite g''C /= -/g.
  have -> : poly_rV g'' != 0 :> 'rV_n.
    apply: contra abs => /poly_rV_0_inv; apply.
    rewrite /g'' ltnW //.
    have : size (rVpoly g') <= n by rewrite size_poly.
    apply/leq_trans/size_sub => //.
      apply/eqP; rewrite rVpoly0; by case/and3P : Hg'.
      rewrite lreg_size ?size_g' //; by apply/GRing.lregP.
    rewrite lead_coefZ /k -mulrA mulVr ?mulr1 // unitfE lead_coef_eq0 rVpoly0; by case/and3P : (canonical_cgenP HC).
  rewrite andbT poly_rV_K; last by rewrite ltnW // (leq_trans size_g'') // size_canonical_cgen.
  rewrite leq_eqVlt -(eq_sym (size g'')) ltn_eqF //=.
  apply/negP.
  rewrite negb_imply -leqNgt leq_eqVlt size_g'' orbT andbT.
  move: (size_g'').
  rewrite ltnNge; apply: contra => /eqP <-.
  rewrite poly_rV_K // ltnW //; apply: (leq_trans size_g''); by rewrite size_poly.
rewrite /g'' in g''0.
move/eqP : g''0; rewrite subr_eq add0r; move/eqP => g''0.
exists k.
by rewrite k0 -(rVpolyK g') g''0 linearZ /= rVpolyK.
Qed.

Lemma divide_codeword (p : {poly F}) : poly_rV (`[ p ]_n) \in C ->
  forall g, g \in 'cgen[C] -> rVpoly g %| p.
Proof.
move=> pC g Hg.
case/boolP : (p == 0) => [/eqP -> | p0].
  by rewrite dvdp0.
move/eqP: (divp_eq p (rVpoly g)); rewrite addrC -subr_eq => /eqP.
move/(congr1 (fun x => `[ x ]_n))/esym.
have size_rem : size (p %% rVpoly g) < size (rVpoly g).
  rewrite ltn_modpN0 //; case/and3P : Hg => _ ? _; by rewrite rVpoly0.
have rem_n : size (p %% rVpoly g) <= n.
  by rewrite ltnW //; apply/(leq_trans size_rem)/(size_is_cgen Hg).
rewrite modp_small; last by rewrite size_Xn_sub_1.
rewrite modpD modpN => pmodg.
have rem_in_C : poly_rV (p %% rVpoly g) \in C.
  rewrite pmodg linearD /= (proj2 (Lcode0.aclosed C)) // linearN /= Lcode0.oclosed //.
  apply/shift_linearity_codeword => //.
  by apply (size_is_cgen Hg).
  case/and3P : Hg => ? _ _; by rewrite rVpolyK.
have rem_0 : p %% rVpoly g = 0.
  apply/eqP/negPn/negP => abs.
   case/and3P : Hg => _ _ /forallP/(_ (poly_rV (p %% rVpoly g))).
   rewrite rem_in_C /= (_ : _ != 0 = true) ?andbT; last first.
     apply: contra abs; by apply poly_rV_0_inv.
   apply/negP.
   rewrite negb_imply -ltnNge poly_rV_K // size_rem andbT.
   move: size_rem.
   rewrite -{1}(poly_rV_K rem_n).
   by rewrite ltnNge; apply: contra => /eqP ->.
apply/dvdpP.
exists (p %/ rVpoly g).
by rewrite {1}(divp_eq p (rVpoly g)) rem_0 addr0.
Qed.

Lemma cgen_divides_Xn_sub_1 g : g \in 'cgen[C] -> rVpoly g %| 'X^n - 1.
Proof.
move=> Hg.
move: (@divide_codeword ('X^n - 1)).
have -> : `[ 'X^n - 1 ]_n = 0 :> {poly F} by rewrite modpp.
by rewrite linear0 (proj1 (Lcode0.aclosed C)) => /(_ erefl); apply.
Qed.

Lemma divides_lowest_size (HC : not_trivial C) (g : {poly F}) (gn : size g <= n) :
  g \in 'pgen[[set cw in C]] -> size g = lowest_size HC.
Proof.
move=> H.
rewrite -(poly_rV_K gn).
apply/size_lowest/and3P; split.
- move/forallP : H => /(_ (poly_rV g)).
  rewrite inE => /eqP ->.
  by rewrite poly_rV_K.
- apply/eqP => abs.
  have {}H : forall p, p \in [set cw in C] -> p = 0.
    move=> p Hp.
    move/forallP : H => /(_ p).
    rewrite Hp => /eqP/esym.
    by rewrite -(poly_rV_K gn) abs linear0 dvd0p rVpoly0 => /eqP.
  case: HC => x /andP [xC].
  apply/negP; rewrite negbK; apply/eqP/H; by rewrite inE.
- apply/forallP => /= x; apply/implyP => /and3P[H1 H2 H3].
  rewrite poly_rV_K //.
  move/forallP : H => /(_ x); rewrite inE H1 => /eqP/esym.
  apply: dvdp_leq; by rewrite rVpoly0.
Qed.

Lemma cgen_is_pgen g : g \in 'cgen[C] -> rVpoly g \in 'pgen[[set cw in C]].
Proof.
move=> Hg; apply/forallP => p; apply/eqP; apply/idP/idP => [p_in_C | g_generated].
- have H : poly_rV (`[ rVpoly p ]_n) = p.
    by rewrite modp_small // ?rVpolyK // size_Xn_sub_1 // ltnS size_poly.
  rewrite -{}H in p_in_C.
  apply divide_codeword => //; by rewrite inE in p_in_C.
- case/dvdpP: g_generated => /= i p_i_g.
  rewrite -(rVpolyK p).
  have <- : `[ rVpoly p ]_n = rVpoly p.
    rewrite modp_small // size_Xn_sub_1 // ltnS; by apply size_poly.
  rewrite p_i_g inE shift_linearity_codeword //.
  by apply (size_is_cgen Hg).
  by rewrite rVpolyK //; case/and3P : Hg.
Qed.

Lemma pgen_is_cgen (g : 'rV_n) (C_not_trivial : not_trivial C) :
  rVpoly g \in 'pgen[[set cw in C]] -> g \in 'cgen[C].
Proof.
move=> Hg.
rewrite is_cgenE; apply/and3P => [:H1]; split.
- abstract: H1.
  by move/forallP : Hg => /(_ g); rewrite inE => /eqP ->.
- apply/eqP => abs.
  have {}Hg : forall p, p \in [set cw in C] -> p = 0.
    move=> p Hp.
    move/forallP : Hg => /(_ p); rewrite Hp => /eqP/esym.
    by rewrite abs linear0 dvd0p rVpoly0 => /eqP.
  case: C_not_trivial => x /andP[] xC.
  move: (Hg x) => /=; rewrite inE => /(_ xC) ->; by rewrite eqxx.
- apply/forallP => /= x; apply/implyP => /and3P[K1 K2 K3].
  have gn : size (rVpoly g) <= n by rewrite size_poly.
  rewrite (divides_lowest_size C_not_trivial gn Hg).
  by apply size_lowestP.
Qed.

Lemma pgen_cgen (C_not_trivial : not_trivial C) (g : 'rV_n) :
  (rVpoly g \in 'pgen[[set cw in C]]) = (g \in 'cgen[C]).
 apply/idP/idP; [exact: pgen_is_cgen | exact: cgen_is_pgen]. Qed.

(* the dimension of C is n - deg g *)
Lemma cgen_dim (HC : not_trivial C) :
  let g := rVpoly (canonical_cgen HC) in
  \dim C = (n - (size g).-1)%nat.
Proof.
move=> g.
(* TODO *)
Abort.

Lemma divides_Xn_sub_1_is_linear (g : {poly F}) : g %| 'X^n - 1 ->
  submod_closed [set c : 'rV[F]_n | g %| rVpoly c]
  (* TODO: and the dimension of C is n - deg g *).
Proof.
case/dvdpP => /= i ig.
split.
  by rewrite inE linear0 dvdp0.
move=> k a b; rewrite !inE => ga gb.
case/boolP : (k == 0) => [/eqP ->|k0]; first by rewrite scale0r add0r.
by rewrite linearD linearZ /= dvdp_addr // dvdpZr.
Qed.

Lemma divides_Xn_sub_1_is_cyclic (g : {poly F}) : g %| 'X^n - 1 ->
  rcsP [set c : 'rV[F]_n | g %| rVpoly c].
Proof.
move=> gXn x.
rewrite !inE => /dvdpP[/= i xig].
rewrite rcs_rcs_poly poly_rV_K; last first.
  rewrite /rcs_poly -ltnS -(@size_Xn_sub_1 F n erefl).
  by rewrite ltn_modpN0 // -size_poly_eq0 size_Xn_sub_1.
by rewrite /rcs_poly -dvdp_mod // xig mulrA dvdp_mull // modpp.
Qed.

End cyclic_code_properties.

Section polynomial_cyclic_equivalence_condition.

Variables (F : finFieldType) (n' : nat).
Let n := n'.+1.
Variable C : Pcode.t F n.
Hypothesis C_not_trivial : not_trivial C.

Lemma polynomial_rcs : Pcode.gen C %| 'X^n - 1 <-> rcsP [set cw in C].
Proof.
split => [H|].
  rewrite /rcsP /= => cw; rewrite inE => cwC.
  rewrite inE rcs_rcs_poly.
  move/forallP: (Pcode.P C) => /(_ (poly_rV (rcs_poly (rVpoly cw) n))).
  rewrite inE => /eqP ->.
  rewrite poly_rV_K; last by apply size_rcs_poly_old.
  rewrite /rcs_poly -dvdp_mod // dvdp_mull //.
  by move/forallP: (Pcode.P C) => /(_ cw); rewrite inE cwC => /eqP/esym.
move=> H.
move: (@cgen_divides_Xn_sub_1 _ _ (@Ccode.mk _ _ (Pcode.lcode0 C) H) (poly_rV (Pcode.gen C))).
rewrite poly_rV_K; last by rewrite ltnW // (Pcode.size_gen C).
apply.
rewrite -pgen_cgen // poly_rV_K; last by rewrite ltnW // (Pcode.size_gen C).
exact: (Pcode.P C).
Qed.

End polynomial_cyclic_equivalence_condition.


Require Import CoqStock.List.

Require Import Brzozowski.Alphabet.
Require Import Brzozowski.Regex.
Require Import Brzozowski.Language.

(*
    **Definition 3.2.**
    Given any language $R$ we define $\nu(R)$ to be

    $$
    \begin{aligned}
    \nu(R) & = \epsilon\ \text{if}\ \epsilon \in R \\
              & = \emptyset\ \text{if}\ \epsilon \notin R \\
    \end{aligned}
    $$
*)

Inductive null: regex -> regex -> Prop :=
  | null_emptystr (r: regex):
    [] \in {{r}} ->
    null r emptystr
  | null_emptyset (r: regex):
    [] \notin {{r}} ->
    null r emptyset
    .

(*
null_and is only true when both regexes are true, where
true = emptystr
false = emptyset
*)
Definition null_and (p q: regex): regex :=
  match (p, q) with
  | (emptystr, emptystr) => emptystr
  | _ => emptyset
  end.

(*
null_nor is only true when both regexes are false, where
true = emptystr
false = emptyset
*)
Definition null_nor (p q: regex): regex :=
  match (p, q) with
  | (emptyset, emptyset) => emptystr
  | _ => emptyset
  end.

(*
  If $R = f(P, Q)$ it is also easy to determine $\nu(R)$. For example,

  $$
  \begin{aligned}
  \text{(3.1)}&\ \nu(P + Q)    &= \nu(P) + \nu(Q). \\
  \text{(3.2)}&\ \nu(P\ \&\ Q) &= \nu(P)\ \&\ \nu(Q). \\
  \text{(3.3)}&\ \nu(P')       &= \epsilon\ \text{if}\ \nu(P) = \emptyset \\
              &                   &= \emptyset\ \text{if}\ \nu(P) = \epsilon \\
  \end{aligned}
  $$

  where $\&$ and $+$ is defined for $\nu$ similar to
  $\epsilon$ being True and $\emptyset$ being False in a boolean equation.

  $$
  \begin{aligned}
  A\ \&\ B = \epsilon\ \text{if and only if}\ A = \epsilon\ \text{and}\ B = \epsilon \\
  A + B = \emptyset\ \text{if and only if}\ A = \emptyset\ \text{and}\ B = \emptyset
  \end{aligned}
  $$
*)

(*
null_or is only true when one of the regexes are true, where
true = emptystr
false = emptyset
*)
Definition null_or (p q: regex): regex :=
  match (p, q) with
  | (emptystr, _) => emptystr
  | (_, emptystr) => emptystr
  | _ => emptyset
  end.

(*
null_neg is only true if input is false and vice versa, where
true = emptystr
false = emptyset
*)
Definition null_neg (p: regex): regex :=
  match p with
  | emptystr => emptyset
  | _ => emptystr
  end.

Fixpoint null_def (r: regex): regex :=
  match r with
  | emptyset => emptyset
  | emptystr => emptystr
  | symbol _ => emptyset
  | or s t => null_or (null_def s) (null_def t)
  | neg s => null_neg (null_def s)
  | concat s t => null_and (null_def s) (null_def t)
  | star s => emptystr
end.


Require Import Reals List Bool.
Require Import Gappa_common.

Local Notation index := nat (only parsing).
Definition realmap := list R.
Definition get rm n := nth n rm R0.

Fixpoint index_eq x y :=
  match x, y with
  | O, O => true
  | S x, S y => index_eq x y
  | _, _ => false
  end.

Lemma index_eq_correct :
  forall x y, index_eq x y = true -> x = y.
Proof.
induction x.
now destruct y.
destruct y.
easy.
intro H.
now rewrite (IHx y).
Qed.

Inductive pos_atom :=
  | Abnd : index -> FF -> pos_atom
  | Aleq : index -> float2 -> pos_atom
  | Ageq : index -> float2 -> pos_atom
  | Aabs : index -> FF -> pos_atom
  | Arel : index -> index -> FF -> pos_atom
  | Afix : index -> Z -> pos_atom
  | Aflt : index -> positive -> pos_atom
  | Anzr : index -> pos_atom
  | Aeql : index -> index -> pos_atom.

Definition interp_pos_atom a rm :=
  match a with
  | Abnd x xi => BND (get rm x) xi
  | Aleq x xu => Rle (get rm x) xu
  | Ageq x xl => Rle xl (get rm x)
  | Aabs x xi => ABS (get rm x) xi
  | Arel x y xi => REL (get rm x) (get rm y) xi
  | Afix x xc => FIX (get rm x) xc
  | Aflt x xc => FLT (get rm x) xc
  | Anzr x => NZR (get rm x)
  | Aeql x y => get rm x = get rm y
  end.

Definition interp_atom a (pos : bool) rm :=
  let p := interp_pos_atom a rm in if pos then p else not p.

Inductive tree :=
  | Ttrue
  | Tfalse
  | Ttree : bool -> tree -> tree -> tree
  | Tatom : bool -> pos_atom -> tree.

Fixpoint interp_tree t rm :=
  match t with
  | Ttrue => True
  | Tfalse => False
  | Ttree cnj l r =>
    (if cnj then and else or) (interp_tree l rm) (interp_tree r rm)
  | Tatom pos a => interp_atom a pos rm
  end.

Inductive atom_relation :=
  | ARimply
  | ARcontradict
  | ARunknown.

Definition subset (xi yi : FF) :=
  if Fle2 (lower yi) (lower xi) then Fle2 (upper xi) (upper yi) else false.

Definition empty_inter (xi yi : FF) :=
  if Flt2 (upper xi) (lower yi) then true else Flt2 (upper yi) (lower xi).

Definition compare xi yi :=
  if subset xi yi then ARimply
  else if empty_inter xi yi then ARcontradict
  else ARunknown.

Lemma compare_correct :
  forall xi yi,
  forall x, BND x xi ->
  match compare xi yi with
  | ARimply => BND x yi
  | ARcontradict => not (BND x yi)
  | ARunknown => True
  end.
Proof.
intros (xl,xu) (yl,yu) x ; unfold compare, subset, empty_inter, BND ; simpl.
intros (Hx1,Hx2).
generalize (Fle2_correct yl xl) (Fle2_correct xu yu) (Flt2_correct xu yl) (Flt2_correct yu xl).
case Fle2.
case Fle2.
intros H1 H2 _ _.
split.
apply Rle_trans with (2 := Hx1).
now apply H1.
apply Rle_trans with (1 := Hx2).
now apply H2.
case Flt2.
intros H1 _ H2 _.
apply False_rec.
apply (Rlt_irrefl yl).
apply Rle_lt_trans with (1 := H1 eq_refl).
apply Rle_lt_trans with (1 := Hx1).
apply Rle_lt_trans with (1 := Hx2).
now apply H2.
case Flt2 ; try easy.
intros _ _ _ H.
intros (_,Hy).
apply (Rlt_irrefl x).
apply Rle_lt_trans with (1 := Hy).
apply Rlt_le_trans with (2 := Hx1).
now apply H.
case Flt2.
intros _ _ H _.
intros (Hy,_).
apply (Rlt_irrefl x).
apply Rle_lt_trans with (1 := Hx2).
apply Rlt_le_trans with (2 := Hy).
now apply H.
case Flt2 ; try easy.
intros _ _ _ H.
intros (_,Hy).
apply (Rlt_irrefl x).
apply Rle_lt_trans with (1 := Hy).
apply Rlt_le_trans with (2 := Hx1).
now apply H.
Qed.

Definition relate' (p : pos_atom) (q : pos_atom) : atom_relation :=
  match p, q with
  | Abnd px pi, Abnd qx qi =>
    if index_eq px qx then compare pi qi else ARunknown
  | Abnd px pi, Aleq qx qu =>
    if index_eq px qx then if Fle2 (upper pi) qu then ARimply else if Flt2 qu (lower pi) then ARcontradict else ARunknown else ARunknown
  | Abnd px pi, Ageq qx ql =>
    if index_eq px qx then if Fle2 ql (lower pi) then ARimply else if Flt2 (upper pi) ql then ARcontradict else ARunknown else ARunknown
  | Aabs px pi, Aabs qx qi =>
    if index_eq px qx then if Fpos0 (lower qi) then compare pi qi else ARunknown else ARunknown
  | Arel px py pi, Arel qx qy qi =>
    if index_eq px qx then if index_eq py qy then if subset pi qi then ARimply else ARunknown else ARunknown else ARunknown
  | Afix px pc, Afix qx qc =>
    if index_eq px qx then if Zle_bool qc pc then ARimply else ARunknown else ARunknown
  | Aflt px pc, Aflt qx qc =>
    if index_eq px qx then if Zle_bool (Zpos pc) (Zpos qc) then ARimply else ARunknown else ARunknown
  | Anzr px, Anzr qx =>
    if index_eq px qx then ARimply else ARunknown
  | Aeql px py, Aeql qx qy =>
    if index_eq px qx then if index_eq py qy then ARimply else ARunknown else ARunknown
  | Aleq px pu, Abnd qx qi =>
    if index_eq px qx then if Flt2 pu (lower qi) then ARcontradict else ARunknown else ARunknown
  | Aleq px pu, Aleq qx qu =>
    if index_eq px qx then if Fle2 pu qu then ARimply else ARunknown else ARunknown
  | Aleq px pu, Ageq qx ql =>
    if index_eq px qx then if Flt2 pu ql then ARcontradict else ARunknown else ARunknown
  | Ageq px pl, Abnd qx qi =>
    if index_eq px qx then if Flt2 (upper qi) pl then ARcontradict else ARunknown else ARunknown
  | Ageq px pl, Aleq qx qu =>
    if index_eq px qx then if Flt2 qu pl then ARcontradict else ARunknown else ARunknown
  | Ageq px pl, Ageq qx ql =>
    if index_eq px qx then if Fle2 ql pl then ARimply else ARunknown else ARunknown
  | _, _ => ARunknown
  end.

Theorem relate'_correct :
  forall p q rm,
  interp_pos_atom p rm ->
  match relate' p q with
  | ARimply => interp_pos_atom q rm
  | ARcontradict => not (interp_pos_atom q rm)
  | ARunknown => True
  end.
Proof.
intros [px pi|px pu|px pl|px pi|px py pi|px pc|px pc|px|px py] [qx qi|qx qu|qx ql|qx qi|qx qy qi|qx qc|qx qc|qx|qx qy] rm Hp ; try exact I ; simpl.
(* Abnd, Abnd *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (compare_correct pi qi _ Hp).
now case compare.
(* Abnd, Aleq *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Fle2_correct (upper pi) qu).
case Fle2.
intros H'.
apply Rle_trans with (1 := proj2 Hp).
now apply H'.
intros _.
generalize (Flt2_correct qu (lower pi)).
case Flt2 ; try easy.
intros H' H''.
apply Rlt_not_le with (1 := H' eq_refl).
now apply Rle_trans with (1 := proj1 Hp).
(* Abnd, Ageq *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Fle2_correct ql (lower pi)).
case Fle2.
intros H'.
apply Rle_trans with (2 := proj1 Hp).
now apply H'.
intros _.
generalize (Flt2_correct (upper pi) ql).
case Flt2 ; try easy.
intros H' H''.
apply Rlt_not_le with (1 := H' eq_refl).
now apply Rle_trans with (2 := proj2 Hp).
(* Aleq, Abnd *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Flt2_correct pu (lower qi)).
case Flt2 ; try easy.
intros H' H''.
apply (Rlt_not_le _ _ (H' eq_refl)).
apply Rle_trans with (2 := Hp).
apply H''.
(* Aleq, Aleq *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Fle2_correct pu qu).
case Fle2 ; try easy.
intros H'.
apply Rle_trans with (1 := Hp).
now apply H'.
(* Aleq, Ageq *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Flt2_correct pu ql).
case Flt2 ; try easy.
intros H'.
apply Rlt_not_le.
apply Rle_lt_trans with (1 := Hp).
now apply H'.
(* Ageq, Abnd *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Flt2_correct (upper qi) pl).
case Flt2 ; try easy.
intros H' H''.
apply (Rlt_not_le _ _ (H' eq_refl)).
apply Rle_trans with (1 := Hp).
apply H''.
(* Ageq, Aleq *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Flt2_correct qu pl).
case Flt2 ; try easy.
intros H'.
apply Rlt_not_le.
apply Rlt_le_trans with (2 := Hp).
now apply H'.
(* Ageq, Abnd *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Fle2_correct ql pl).
case Fle2 ; try easy.
intros H'.
apply Rle_trans with (2 := Hp).
now apply H'.
(* Aabs, Abs *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Fpos0_correct (lower qi)).
case Fpos0 ; try easy.
intros H'.
specialize (H' eq_refl).
generalize (compare_correct pi qi _ (proj2 Hp)).
case compare ; try easy.
try now split.
intros H''.
contradict H''.
apply H''.
(* Arel, Aerl *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
clear H.
generalize (index_eq_correct py qy).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
clear H.
unfold interp_pos_atom in Hp.
unfold subset.
generalize (Fle2_correct (lower qi) (lower pi)).
case Fle2 ; try easy.
intros Hl.
generalize (Fle2_correct (upper pi) (upper qi)).
case Fle2 ; try easy.
intros Hu.
destruct Hp as (e,(He,Hp)).
exists e.
split.
split.
now apply Rle_trans with (1 := Hl eq_refl).
now apply Rle_trans with (2 := Hu eq_refl).
exact Hp.
(* Afix, Afix *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
clear H.
generalize (Zle_cases qc pc).
case (Zle_bool qc pc) ; try easy.
intros H.
destruct Hp as ((m,e),(Hm,He)).
exists (Float2 m e).
split.
exact Hm.
now apply Z.le_trans with (1 := H).
(* Aflt, Aflt *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
clear H.
generalize (Zle_cases (Zpos pc) (Zpos qc)).
case Zle_bool ; try easy.
intros H.
destruct Hp as ((m,e),(Hm,He)).
exists (Float2 m e).
split.
exact Hm.
apply Z.lt_le_trans with (1 := He).
apply le_IZR.
change (IZR (Zpower radix2 (Zpos pc)) <= IZR (Zpower radix2 (Zpos qc)))%R.
apply IZR_le.
now apply Zpower_le.
(* Anzr, Anzr *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
now rewrite <- H.
(* Aeql, Aeql *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
clear H.
generalize (index_eq_correct py qy).
case index_eq ; try easy.
intros H.
now rewrite <- H.
Qed.

Definition relate (p : pos_atom) (q : pos_atom) (qpos : bool) : atom_relation :=
  if qpos then relate' p q
  else
    match relate' p q with
    | ARimply => ARcontradict
    | ARcontradict => ARimply
    | ARunknown => ARunknown
    end.

Theorem relate_correct :
  forall p q qpos rm,
  interp_pos_atom p rm ->
  match relate p q qpos with
  | ARimply => interp_atom q qpos rm
  | ARcontradict => not (interp_atom q qpos rm)
  | ARunknown => True
  end.
Proof.
intros p q qpos rm Hp.
unfold relate.
generalize (relate'_correct p q rm Hp).
now destruct relate' ; case qpos.
Qed.

Fixpoint simplify' t p :=
  match t with
  | Ttrue => Ttrue
  | Tfalse => Tfalse
  | Ttree cnj l r =>
    match simplify' l p, cnj, simplify' r p with
    | Ttrue, true, r => r
    | Ttrue, false, _ => Ttrue
    | Tfalse, true, _ => Tfalse
    | Tfalse, false, r => r
    | l, true, Ttrue => l
    | _, true, Tfalse => Tfalse
    | l, true, r => Ttree true l r
    | _, false, Ttrue => Ttrue
    | l, false, Tfalse => l
    | l, false, r => Ttree false l r
    end
  | Tatom pos a =>
    match relate p a pos with
    | ARimply => Ttrue
    | ARcontradict => Tfalse
    | ARunknown => t
    end
  end.

Lemma iff_True :
  forall P : Prop, P <-> (P <-> True).
Proof.
split.
now split.
intros (_,H).
now apply H.
Qed.

Lemma iff_False :
  forall P : Prop, not P <-> (P <-> False).
Proof.
split.
now split.
now intros (H,_).
Qed.

Theorem simplify'_correct :
  forall t p rm,
  interp_pos_atom p rm ->
  (interp_tree t rm <-> interp_tree (simplify' t p) rm).
Proof.
intros t p rm Hp.
induction t as [| |cnj l Hl r Hr|a pos] ; try easy.
simpl.
destruct (simplify' l p) as [| |cnj' l' r'|a' pos'].
simpl in Hl.
apply <- iff_True in Hl.
case cnj.
intuition.
apply -> iff_True.
now left.
apply <- iff_False in Hl.
case cnj.
apply -> iff_False.
now intros (H,_).
intuition.
destruct (simplify' r p) as [| |cnj'' l'' r''|a'' pos''].
apply <- iff_True in Hr.
case cnj.
intuition.
apply -> iff_True.
now right.
apply <- iff_False in Hr.
case cnj.
apply -> iff_False.
now intros (_,H).
intuition.
replace (interp_tree (if cnj
   then Ttree true (Ttree cnj' l' r') (Ttree cnj'' l'' r'')
   else Ttree false (Ttree cnj' l' r') (Ttree cnj'' l'' r'')) rm) with
  ((if cnj then and else or) (interp_tree (Ttree cnj' l' r') rm) (interp_tree (Ttree cnj'' l'' r'') rm))
  by now case cnj.
case cnj ; intuition.
replace (interp_tree (if cnj
   then Ttree true (Ttree cnj' l' r') (Tatom a'' pos'')
   else Ttree false (Ttree cnj' l' r') (Tatom a'' pos'')) rm) with
  ((if cnj then and else or) (interp_tree (Ttree cnj' l' r') rm) (interp_tree (Tatom a'' pos'') rm))
  by now case cnj.
case cnj ; intuition.
destruct (simplify' r p) as [| |cnj'' l'' r''|a'' pos''].
apply <- iff_True in Hr.
case cnj.
intuition.
apply -> iff_True.
now right.
apply <- iff_False in Hr.
case cnj.
apply -> iff_False.
now intros (_,H).
intuition.
replace (interp_tree (if cnj
   then Ttree true (Tatom a' pos') (Ttree cnj'' l'' r'')
   else Ttree false (Tatom a' pos') (Ttree cnj'' l'' r'')) rm) with
  ((if cnj then and else or) (interp_tree (Tatom a' pos') rm) (interp_tree (Ttree cnj'' l'' r'') rm))
  by now case cnj.
case cnj ; intuition.
replace (interp_tree (if cnj
   then Ttree true (Tatom a' pos') (Tatom a'' pos'')
   else Ttree false (Tatom a' pos') (Tatom a'' pos'')) rm) with
  ((if cnj then and else or) (interp_tree (Tatom a' pos') rm) (interp_tree (Tatom a'' pos'') rm))
  by now case cnj.
case cnj ; intuition.
(* *)
simpl.
generalize (relate_correct p pos a rm Hp).
case relate ; intros H.
now apply -> iff_True.
now apply -> iff_False.
easy.
Qed.

Scheme Equality for positive.
Scheme Equality for Z.
Scheme Equality for nat.
Scheme Equality for float2.
Scheme Equality for FF.
Scheme Equality for pos_atom.
Scheme Equality for tree.

Theorem simplify :
  forall t t' p rm,
  interp_pos_atom p rm ->
  interp_tree t rm ->
  tree_beq (simplify' t p) t' = true ->
  interp_tree t' rm.
Proof.
intros t t' p rm Hp Ht Hs.
rewrite <- (internal_tree_dec_bl _ _ Hs).
generalize (proj1 (simplify'_correct t p rm Hp)).
intuition.
Qed.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require int.ComputerDivision.
Require number.Parity.
Require number.Divisibility.

Import Znumtheory.

(* Why3 assumption *)
Definition prime (p:Z): Prop := (2%Z <= p)%Z /\ forall (n:Z), ((1%Z < n)%Z /\
  (n < p)%Z) -> ~ (number.Divisibility.divides n p).

Lemma prime_is_Zprime :
  forall p, prime p <-> Znumtheory.prime p.
Proof.
intros p.
apply iff_trans with (2 := prime_alt p).
unfold prime, prime'.
intuition.
Qed.

(* Why3 goal *)
Lemma not_prime_1 : ~ (prime 1%Z).
intros (H1,_).
now elim H1.
Qed.

(* Why3 goal *)
Lemma prime_2 : (prime 2%Z).
Proof.
apply <- prime_is_Zprime.
apply prime_2.
Qed.

(* Why3 goal *)
Lemma prime_3 : (prime 3%Z).
Proof.
apply <- prime_is_Zprime.
apply prime_3.
Qed.

(* Why3 goal *)
Lemma prime_divisors : forall (p:Z), (prime p) -> forall (d:Z),
  (number.Divisibility.divides d p) -> ((d = 1%Z) \/ ((d = (-1%Z)%Z) \/
  ((d = p) \/ (d = (-p)%Z)))).
Proof.
intros p Hp d Hd.
apply -> prime_is_Zprime in Hp.
destruct (prime_divisors p Hp d Hd) ; intuition.
Qed.

(* Why3 goal *)
Lemma small_divisors : forall (p:Z), (2%Z <= p)%Z -> ((forall (d:Z),
  (2%Z <= d)%Z -> ((prime d) -> (((1%Z < (d * d)%Z)%Z /\
  ((d * d)%Z <= p)%Z) -> ~ (number.Divisibility.divides d p)))) -> (prime
  p)).
Proof.
intros p Hp H.
apply <- prime_is_Zprime.
destruct (prime_dec p) as [Pp|Pp].
exact Pp.
elimtype False.
(* *)
assert (exists d, (2 <= d)%Z /\ (d * d <= p)%Z /\ prime d /\ Zdivide d p).
clear H.
assert (Hp' : (0 <= p)%Z) by omega.
revert p Hp' Hp Pp.
apply (Zlt_0_ind (fun p => 2 <= p -> ~ Znumtheory.prime p -> (exists d : Z, 2 <= d /\ d * d <= p /\ prime d /\ (d | p)))%Z).
intros p IH _ Hp Pp.
destruct (not_prime_divide p) as (x,(Hx1,Hx2)).
clear -Hp ; omega.
exact Pp.
destruct (Zle_or_lt (x * x) p) as [Hx|Hx].
destruct (prime_dec x) as [Px|Px].
exists x.
split.
clear -Hx1 ; omega.
split.
exact Hx.
split.
now apply <- prime_is_Zprime.
exact Hx2.
destruct (IH x) as (y&Hy1&Hy2&Hy3&Hy4).
clear -Hx1 ; omega.
clear -Hx1 ; omega.
exact Px.
exists y.
refine (conj Hy1 (conj _ (conj Hy3 _))).
apply Zle_trans with (1 := Hy2).
apply Zle_trans with (2 := Hx).
rewrite <- (Zmult_1_r x) at 1.
apply Zmult_le_compat_l.
now apply Zlt_le_weak.
clear -Hx1 ; omega.
now apply Zdivide_trans with x.
case Hx2.
intros q Hq1.
assert (Hq2 : (2 <= q)%Z).
apply (Zlt_le_succ 1).
apply Zmult_lt_reg_r with x.
clear -Hx1 ; omega.
now rewrite Zmult_1_l, <- Hq1.
destruct (prime_dec q) as [Pq|Pq].
exists q.
split.
exact Hq2.
split.
rewrite Hq1.
apply Zmult_le_compat_l.
apply Zlt_le_weak.
apply Zmult_lt_reg_r with x.
clear -Hx1 ; omega.
now rewrite <- Hq1.
clear -Hq2 ; omega.
split.
now apply <- prime_is_Zprime.
exists x.
now rewrite Zmult_comm.
destruct (IH q) as (y&Hy1&Hy2&Hy3&Hy4).
split.
clear -Hq2 ; omega.
rewrite <- (Zmult_1_r q), Hq1.
apply Zmult_lt_compat_l.
clear -Hq2 ; omega.
clear -Hx1 ; omega.
exact Hq2.
exact Pq.
exists y.
refine (conj Hy1 (conj _ (conj Hy3 _))).
apply Zle_trans with (1 := Hy2).
rewrite <- (Zmult_1_r q), Hq1.
apply Zmult_le_compat_l.
clear -Hx1 ; omega.
clear -Hq2 ; omega.
apply Zdivide_trans with (1 := Hy4).
exists x.
now rewrite Zmult_comm.
destruct H0 as (y&Hy1&Hy2&Hy3&Hy4).
apply (H y) ; try easy.
split.
apply Zlt_le_trans with (2 * 2)%Z.
easy.
now apply Zmult_le_compat.
exact Hy2.
Qed.

(* Why3 goal *)
Lemma even_prime : forall (p:Z), (prime p) -> ((number.Parity.even p) ->
  (p = 2%Z)).
Proof.
intros p Pp (q,Hq).
generalize (proj2 Pp q).
assert (Zdivide q p).
now exists 2%Z.
intros.
refine (_ (fun H1 => H0 H1 H) (proj1 Pp)).
(* ??? omega fails to solve this goal ??? *)
clear -Hq.
intros H Hp.
destruct (Zle_lt_or_eq 2 p Hp) as [Hp'|Hp'].
elim H.
omega.
easy.
Qed.

(* Why3 goal *)
Lemma odd_prime : forall (p:Z), (prime p) -> ((3%Z <= p)%Z ->
  (number.Parity.odd p)).
Proof.
intros p Pp Hp.
apply <- Divisibility.odd_divides.
apply proj2 in Pp.
apply Pp.
omega.
Qed.


Require Import Reals List Bool.
Require Import Gappa_common.

Notation index := nat.
Definition realmap := list R.
Definition get rm n := nth n rm R0.

Fixpoint index_eq x y :=
  match x, y with
  | O, O => true
  | S x, S y => index_eq x y
  | _, _ => false
  end.

Lemma index_eq_correct :
  forall x y, index_eq x y = true -> x = y.
Proof.
induction x.
now destruct y.
destruct y.
easy.
intro H.
now rewrite (IHx y).
Qed.

Inductive pos_atom :=
  | Abnd : index -> FF -> pos_atom
  | Aleq : index -> float2 -> pos_atom
  | Ageq : index -> float2 -> pos_atom
  | Aabs : index -> FF -> pos_atom
  | Arel : index -> index -> FF -> pos_atom
  | Afix : index -> Z -> pos_atom
  | Aflt : index -> positive -> pos_atom
  | Anzr : index -> pos_atom
  | Aeql : index -> index -> pos_atom.

Definition interp_pos_atom a rm :=
  match a with
  | Abnd x xi => BND (get rm x) xi
  | Aleq x xu => Rle (get rm x) xu
  | Ageq x xl => Rle xl (get rm x)
  | Aabs x xi => ABS (get rm x) xi
  | Arel x y xi => REL (get rm x) (get rm y) xi
  | Afix x xc => FIX (get rm x) xc
  | Aflt x xc => FLT (get rm x) xc
  | Anzr x => NZR (get rm x)
  | Aeql x y => get rm x = get rm y
  end.

Definition interp_atom a (pos : bool) rm :=
  let p := interp_pos_atom a rm in if pos then p else not p.

Inductive tree :=
  | Ttrue
  | Tfalse
  | Ttree : bool -> tree -> tree -> tree
  | Tatom : bool -> pos_atom -> tree.

Fixpoint interp_tree t rm :=
  match t with
  | Ttrue => True
  | Tfalse => False
  | Ttree cnj l r =>
    (if cnj then and else or) (interp_tree l rm) (interp_tree r rm)
  | Tatom pos a => interp_atom a pos rm
  end.

Inductive atom_relation :=
  | ARimply
  | ARcontradict
  | ARunknown.

Definition subset (xi yi : FF) :=
  if Fle2 (lower yi) (lower xi) then Fle2 (upper xi) (upper yi) else false.

Definition empty_inter (xi yi : FF) :=
  if Flt2 (upper xi) (lower yi) then true else Flt2 (upper yi) (lower xi).

Definition compare xi yi :=
  if subset xi yi then ARimply
  else if empty_inter xi yi then ARcontradict
  else ARunknown.

Lemma compare_correct :
  forall xi yi,
  forall x, BND x xi ->
  match compare xi yi with
  | ARimply => BND x yi
  | ARcontradict => not (BND x yi)
  | ARunknown => True
  end.
Proof.
intros (xl,xu) (yl,yu) x ; unfold compare, subset, empty_inter, BND ; simpl.
intros (Hx1,Hx2).
generalize (Fle2_correct yl xl) (Fle2_correct xu yu) (Flt2_correct xu yl) (Flt2_correct yu xl).
case Fle2.
case Fle2.
intros H1 H2 _ _.
split.
apply Rle_trans with (2 := Hx1).
now apply H1.
apply Rle_trans with (1 := Hx2).
now apply H2.
case Flt2.
intros H1 _ H2 _.
apply False_rec.
apply (Rlt_irrefl yl).
apply Rle_lt_trans with (1 := H1 eq_refl).
apply Rle_lt_trans with (1 := Hx1).
apply Rle_lt_trans with (1 := Hx2).
now apply H2.
case Flt2 ; try easy.
intros _ _ _ H.
intros (_,Hy).
apply (Rlt_irrefl x).
apply Rle_lt_trans with (1 := Hy).
apply Rlt_le_trans with (2 := Hx1).
now apply H.
case Flt2.
intros _ _ H _.
intros (Hy,_).
apply (Rlt_irrefl x).
apply Rle_lt_trans with (1 := Hx2).
apply Rlt_le_trans with (2 := Hy).
now apply H.
case Flt2 ; try easy.
intros _ _ _ H.
intros (_,Hy).
apply (Rlt_irrefl x).
apply Rle_lt_trans with (1 := Hy).
apply Rlt_le_trans with (2 := Hx1).
now apply H.
Qed.

Definition relate' (p : pos_atom) (q : pos_atom) : atom_relation :=
  match p, q with
  | Abnd px pi, Abnd qx qi =>
    if index_eq px qx then compare pi qi else ARunknown
  | Abnd px pi, Aleq qx qu =>
    if index_eq px qx then if Fle2 (upper pi) qu then ARimply else if Flt2 qu (lower pi) then ARcontradict else ARunknown else ARunknown
  | Abnd px pi, Ageq qx ql =>
    if index_eq px qx then if Fle2 ql (lower pi) then ARimply else if Flt2 (upper pi) ql then ARcontradict else ARunknown else ARunknown
  | Aabs px pi, Aabs qx qi =>
    if index_eq px qx then if Fpos0 (lower qi) then compare pi qi else ARunknown else ARunknown
  | Arel px py pi, Arel qx qy qi =>
    if index_eq px qx then if index_eq py qy then if subset pi qi then ARimply else ARunknown else ARunknown else ARunknown
  | Afix px pc, Afix qx qc =>
    if index_eq px qx then if Zle_bool qc pc then ARimply else ARunknown else ARunknown
  | Aflt px pc, Aflt qx qc =>
    if index_eq px qx then if Zle_bool (Zpos pc) (Zpos qc) then ARimply else ARunknown else ARunknown
  | Anzr px, Anzr qx =>
    if index_eq px qx then ARimply else ARunknown
  | Aeql px py, Aeql qx qy =>
    if index_eq px qx then if index_eq py qy then ARimply else ARunknown else ARunknown
  | Aleq px pu, Abnd qx qi =>
    if index_eq px qx then if Flt2 pu (lower qi) then ARcontradict else ARunknown else ARunknown
  | Aleq px pu, Aleq qx qu =>
    if index_eq px qx then if Fle2 pu qu then ARimply else ARunknown else ARunknown
  | Aleq px pu, Ageq qx ql =>
    if index_eq px qx then if Flt2 pu ql then ARcontradict else ARunknown else ARunknown
  | Ageq px pl, Abnd qx qi =>
    if index_eq px qx then if Flt2 (upper qi) pl then ARcontradict else ARunknown else ARunknown
  | Ageq px pl, Aleq qx qu =>
    if index_eq px qx then if Flt2 qu pl then ARcontradict else ARunknown else ARunknown
  | Ageq px pl, Ageq qx ql =>
    if index_eq px qx then if Fle2 ql pl then ARimply else ARunknown else ARunknown
  | _, _ => ARunknown
  end.

Theorem relate'_correct :
  forall p q rm,
  interp_pos_atom p rm ->
  match relate' p q with
  | ARimply => interp_pos_atom q rm
  | ARcontradict => not (interp_pos_atom q rm)
  | ARunknown => True
  end.
Proof.
intros [px pi|px pu|px pl|px pi|px py pi|px pc|px pc|px|px py] [qx qi|qx qu|qx ql|qx qi|qx qy qi|qx qc|qx qc|qx|qx qy] rm Hp ; try exact I ; simpl.
(* Abnd, Abnd *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (compare_correct pi qi _ Hp).
now case compare.
(* Abnd, Aleq *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Fle2_correct (upper pi) qu).
case Fle2.
intros H'.
apply Rle_trans with (1 := proj2 Hp).
now apply H'.
intros _.
generalize (Flt2_correct qu (lower pi)).
case Flt2 ; try easy.
intros H' H''.
apply Rlt_not_le with (1 := H' eq_refl).
now apply Rle_trans with (1 := proj1 Hp).
(* Abnd, Ageq *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Fle2_correct ql (lower pi)).
case Fle2.
intros H'.
apply Rle_trans with (2 := proj1 Hp).
now apply H'.
intros _.
generalize (Flt2_correct (upper pi) ql).
case Flt2 ; try easy.
intros H' H''.
apply Rlt_not_le with (1 := H' eq_refl).
now apply Rle_trans with (2 := proj2 Hp).
(* Aleq, Abnd *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Flt2_correct pu (lower qi)).
case Flt2 ; try easy.
intros H' H''.
apply (Rlt_not_le _ _ (H' eq_refl)).
apply Rle_trans with (2 := Hp).
apply H''.
(* Aleq, Aleq *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Fle2_correct pu qu).
case Fle2 ; try easy.
intros H'.
apply Rle_trans with (1 := Hp).
now apply H'.
(* Aleq, Ageq *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Flt2_correct pu ql).
case Flt2 ; try easy.
intros H'.
apply Rlt_not_le.
apply Rle_lt_trans with (1 := Hp).
now apply H'.
(* Ageq, Abnd *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Flt2_correct (upper qi) pl).
case Flt2 ; try easy.
intros H' H''.
apply (Rlt_not_le _ _ (H' eq_refl)).
apply Rle_trans with (1 := Hp).
apply H''.
(* Ageq, Aleq *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Flt2_correct qu pl).
case Flt2 ; try easy.
intros H'.
apply Rlt_not_le.
apply Rlt_le_trans with (2 := Hp).
now apply H'.
(* Ageq, Abnd *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Fle2_correct ql pl).
case Fle2 ; try easy.
intros H'.
apply Rle_trans with (2 := Hp).
now apply H'.
(* Aabs, Abs *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
generalize (Fpos0_correct (lower qi)).
case Fpos0 ; try easy.
intros H'.
specialize (H' eq_refl).
generalize (compare_correct pi qi _ (proj2 Hp)).
case compare ; try easy.
try now split.
intros H''.
contradict H''.
apply H''.
(* Arel, Aerl *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
clear H.
generalize (index_eq_correct py qy).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
clear H.
unfold interp_pos_atom in Hp.
unfold subset.
generalize (Fle2_correct (lower qi) (lower pi)).
case Fle2 ; try easy.
intros Hl.
generalize (Fle2_correct (upper pi) (upper qi)).
case Fle2 ; try easy.
intros Hu.
destruct Hp as (e,(He,Hp)).
exists e.
split.
split.
now apply Rle_trans with (1 := Hl eq_refl).
now apply Rle_trans with (2 := Hu eq_refl).
exact Hp.
(* Afix, Afix *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
clear H.
generalize (Zle_cases qc pc).
case (Zle_bool qc pc) ; try easy.
intros H.
destruct Hp as ((m,e),(Hm,He)).
exists (Float2 m e).
split.
exact Hm.
now apply Zle_trans with (1 := H).
(* Aflt, Aflt *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
clear H.
generalize (Zle_cases (Zpos pc) (Zpos qc)).
case Zle_bool ; try easy.
intros H.
destruct Hp as ((m,e),(Hm,He)).
exists (Float2 m e).
split.
exact Hm.
apply Zlt_le_trans with (1 := He).
apply le_Z2R.
change (Z2R (Zpower radix2 (Zpos pc)) <= Z2R (Zpower radix2 (Zpos qc)))%R.
apply Z2R_le.
now apply Zpower_le.
(* Anzr, Anzr *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
now rewrite <- H.
(* Aeql, Aeql *)
generalize (index_eq_correct px qx).
case index_eq ; try easy.
intros H.
rewrite H in Hp by easy.
clear H.
generalize (index_eq_correct py qy).
case index_eq ; try easy.
intros H.
now rewrite <- H.
Qed.

Definition relate (p : pos_atom) (q : pos_atom) (qpos : bool) : atom_relation :=
  if qpos then relate' p q
  else
    match relate' p q with
    | ARimply => ARcontradict
    | ARcontradict => ARimply
    | ARunknown => ARunknown
    end.

Theorem relate_correct :
  forall p q qpos rm,
  interp_pos_atom p rm ->
  match relate p q qpos with
  | ARimply => interp_atom q qpos rm
  | ARcontradict => not (interp_atom q qpos rm)
  | ARunknown => True
  end.
Proof.
intros p q qpos rm Hp.
unfold relate.
generalize (relate'_correct p q rm Hp).
now destruct relate' ; case qpos.
Qed.

Fixpoint simplify' t p :=
  match t with
  | Ttrue => Ttrue
  | Tfalse => Tfalse
  | Ttree cnj l r =>
    match simplify' l p, cnj, simplify' r p with
    | Ttrue, true, r => r
    | Ttrue, false, _ => Ttrue
    | Tfalse, true, _ => Tfalse
    | Tfalse, false, r => r
    | l, true, Ttrue => l
    | _, true, Tfalse => Tfalse
    | l, true, r => Ttree true l r
    | _, false, Ttrue => Ttrue
    | l, false, Tfalse => l
    | l, false, r => Ttree false l r
    end
  | Tatom pos a =>
    match relate p a pos with
    | ARimply => Ttrue
    | ARcontradict => Tfalse
    | ARunknown => t
    end
  end.

Lemma iff_True :
  forall P : Prop, P <-> (P <-> True).
Proof.
split.
now split.
intros (_,H).
now apply H.
Qed.

Lemma iff_False :
  forall P : Prop, not P <-> (P <-> False).
Proof.
split.
now split.
now intros (H,_).
Qed.

Theorem simplify'_correct :
  forall t p rm,
  interp_pos_atom p rm ->
  (interp_tree t rm <-> interp_tree (simplify' t p) rm).
Proof.
intros t p rm Hp.
induction t as [| |cnj l Hl r Hr|a pos] ; try easy.
simpl.
destruct (simplify' l p) as [| |cnj' l' r'|a' pos'].
simpl in Hl.
apply <- iff_True in Hl.
case cnj.
intuition.
apply -> iff_True.
now left.
apply <- iff_False in Hl.
case cnj.
apply -> iff_False.
now intros (H,_).
intuition.
destruct (simplify' r p) as [| |cnj'' l'' r''|a'' pos''].
apply <- iff_True in Hr.
case cnj.
intuition.
apply -> iff_True.
now right.
apply <- iff_False in Hr.
case cnj.
apply -> iff_False.
now intros (_,H).
intuition.
replace (interp_tree (if cnj
   then Ttree true (Ttree cnj' l' r') (Ttree cnj'' l'' r'')
   else Ttree false (Ttree cnj' l' r') (Ttree cnj'' l'' r'')) rm) with
  ((if cnj then and else or) (interp_tree (Ttree cnj' l' r') rm) (interp_tree (Ttree cnj'' l'' r'') rm))
  by now case cnj.
case cnj ; intuition.
replace (interp_tree (if cnj
   then Ttree true (Ttree cnj' l' r') (Tatom a'' pos'')
   else Ttree false (Ttree cnj' l' r') (Tatom a'' pos'')) rm) with
  ((if cnj then and else or) (interp_tree (Ttree cnj' l' r') rm) (interp_tree (Tatom a'' pos'') rm))
  by now case cnj.
case cnj ; intuition.
destruct (simplify' r p) as [| |cnj'' l'' r''|a'' pos''].
apply <- iff_True in Hr.
case cnj.
intuition.
apply -> iff_True.
now right.
apply <- iff_False in Hr.
case cnj.
apply -> iff_False.
now intros (_,H).
intuition.
replace (interp_tree (if cnj
   then Ttree true (Tatom a' pos') (Ttree cnj'' l'' r'')
   else Ttree false (Tatom a' pos') (Ttree cnj'' l'' r'')) rm) with
  ((if cnj then and else or) (interp_tree (Tatom a' pos') rm) (interp_tree (Ttree cnj'' l'' r'') rm))
  by now case cnj.
case cnj ; intuition.
replace (interp_tree (if cnj
   then Ttree true (Tatom a' pos') (Tatom a'' pos'')
   else Ttree false (Tatom a' pos') (Tatom a'' pos'')) rm) with
  ((if cnj then and else or) (interp_tree (Tatom a' pos') rm) (interp_tree (Tatom a'' pos'') rm))
  by now case cnj.
case cnj ; intuition.
(* *)
simpl.
generalize (relate_correct p pos a rm Hp).
case relate ; intros H.
now apply -> iff_True.
now apply -> iff_False.
easy.
Qed.

Scheme Equality for positive.
Scheme Equality for Z.
Scheme Equality for nat.
Scheme Equality for float2.
Scheme Equality for FF.
Scheme Equality for pos_atom.
Scheme Equality for tree.

Theorem simplify :
  forall t t' p rm,
  interp_pos_atom p rm ->
  interp_tree t rm ->
  tree_beq (simplify' t p) t' = true ->
  interp_tree t' rm.
Proof.
intros t t' p rm Hp Ht Hs.
rewrite <- (internal_tree_dec_bl _ _ Hs).
generalize (proj1 (simplify'_correct t p rm Hp)).
intuition.
Qed.


(*
 - More lemmas concerning invertible 2-cells
 - Invertibility tactic
From 'UniMath.Bicategories.Core.Invertible_2cells.v'
*)

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

Require Import Integers.WildCategories.WildCat.

Local Open Scope cat.

(** Invertible 2-cell lemmas **)
Lemma is_invertible_2cell_lunitor {C : wild_cat} {a b : C} (f : a --> b)
  : is_invertible_2cell (lunitor f).
Proof.
  exact (linvunitor f).
Defined.

Lemma is_invertible_2cell_linvunitor {C : wild_cat} {a b : C} (f : a --> b)
  : is_invertible_2cell (linvunitor f).
Proof.
  exact (lunitor f).
Defined.

Lemma is_invertible_2cell_runitor {C : wild_cat} {a b : C} (f : a --> b)
  : is_invertible_2cell (runitor f).
Proof.
  exact (rinvunitor f).
Defined.

Lemma is_invertible_2cell_rinvunitor {C : wild_cat} {a b : C} (f : a --> b)
  : is_invertible_2cell (rinvunitor f).
Proof.
  exact (runitor f).
Defined.

Lemma is_invertible_2cell_rassociator {C : wild_cat} {a b c d : C}
      (f : a --> b) (g : b --> c) (h : c --> d)
  : is_invertible_2cell (rassociator f g h).
Proof.
  exact (lassociator f g h).
Defined.

Lemma is_invertible_2cell_lassociator {C : wild_cat} {a b c d : C}
      (f : a --> b) (g : b --> c) (h : c --> d)
  : is_invertible_2cell (lassociator f g h).
Proof.
  exact (rassociator f g h).
Defined.

Lemma is_invertible_2cell_vcomp {C : wild_cat} {a b : C} {f g h: a --> b}
      {x : f ==> g} (inv_x : is_invertible_2cell x)
      {y : g ==> h} (inv_y : is_invertible_2cell y)
  : is_invertible_2cell (x • y).
Proof.
  exact (inv_y^-1 • inv_x^-1).
Defined.

Lemma is_invertible_2cell_lwhisker {C : wild_cat} {a b c : C}
      (f : a --> b) {g1 g2 : b --> c}
      {x : g1 ==> g2} (inv_x : is_invertible_2cell x)
  : is_invertible_2cell (f ◃ x).
Proof.
  exact (f ◃ inv_x^-1).
Defined.

Lemma is_invertible_2cell_rwhisker {C : wild_cat} {a b c : C} {f1 f2 : a --> b} (g : b --> c)
      {x : f1 ==> f2} (inv_x : is_invertible_2cell x)
  : is_invertible_2cell (x ▹ g).
Proof.
  exact (inv_x^-1 ▹ g).
Defined.

Definition is_invertible_2cell_hcomp
       {C : wild_cat}
       {a b c : C}
       {f₁ g₁ : b --> c} {f₂ g₂ : a --> b}
       (η₁ : f₁ ==> g₁) (η₂ : f₂ ==> g₂)
       (inv_η₁ : is_invertible_2cell η₁)
       (inv_η₂ : is_invertible_2cell η₂)
  : is_invertible_2cell (η₁ ⋆⋆ η₂).
Proof.
  exact (inv_η₁^-1 ⋆⋆ inv_η₂^-1).
Defined.

(** Invertibility tactic **)

Ltac is_iso :=
  match goal with
  | [ |- is_invertible_2cell (runitor _) ] => apply is_invertible_2cell_runitor
  | [ |- is_invertible_2cell (rinvunitor _) ] => apply is_invertible_2cell_rinvunitor
  | [ |- is_invertible_2cell (lunitor _) ] => apply is_invertible_2cell_lunitor
  | [ |- is_invertible_2cell (linvunitor _) ] => apply is_invertible_2cell_linvunitor
  | [ |- is_invertible_2cell (rassociator _ _ _)] => apply is_invertible_2cell_rassociator
  | [ |- is_invertible_2cell (lassociator _ _ _)] => apply is_invertible_2cell_lassociator
  | [ |- is_invertible_2cell (_ ^-1)] => apply is_invertible_2cell_inv ; is_iso
  | [ |- is_invertible_2cell (_ • _)] => apply is_invertible_2cell_vcomp ; is_iso
  | [ |- is_invertible_2cell (_ ◃ _)] => apply is_invertible_2cell_lwhisker ; is_iso
  | [ |- is_invertible_2cell (_ ▹ _)] => apply is_invertible_2cell_rwhisker ; is_iso
  | [ |- is_invertible_2cell (_ ⋆⋆ _)] => apply is_invertible_2cell_hcomp ; is_iso
  | [ |- is_invertible_2cell (_ ⋆ _)] => apply is_invertible_2cell_hcomp ; is_iso
  | [ |- is_invertible_2cell (id₂ _)] => apply is_invertible_2cell_id₂
  | _ => try assumption
  end.

(** Lemmas using the tactic **)

Definition inv_of_invertible_2cell
           {C : wild_cat}
           {X Y : C}
           {f g : X --> Y}
  : invertible_2cell f g → invertible_2cell g f.
Proof.
  intro θ.
  use make_invertible_2cell.
  - exact (θ^-1).
  - is_iso.
Defined.

Definition comp_of_invertible_2cell
           {C : wild_cat}
           {X Y : C}
           {f g h : X --> Y}
  : invertible_2cell f g → invertible_2cell g h → invertible_2cell f h.
Proof.
  intros θ γ.
  use make_invertible_2cell.
  - exact (θ • γ).
  - is_iso.
    + exact θ.
    + exact γ.
Defined.


(**
 Morphisms in op2 bicat

 Contents
 1. Faithful 1-cells
 2. Fully faithful 1-cells
 3. Conservative 1-cells
 4. Discrete 1-cells
 5. Adjunctions
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Core.Examples.OpCellBicat.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms.

Local Open Scope cat.

(**
 1. Faithful 1-cells
 *)
Definition faithful_op2_bicat
           {B : bicat}
           {x y : B}
           {f : x --> y}
           (Hf : faithful_1cell f)
  : @faithful_1cell (op2_bicat B) _ _ f.
Proof.
  intros z g₁ g₂ α β p.
  apply Hf.
  exact p.
Defined.

(**
 2. Fully faithful 1-cells
 *)
Definition fully_faithful_op2_bicat
           {B : bicat}
           {x y : B}
           {f : x --> y}
           (Hf : fully_faithful_1cell f)
  : @fully_faithful_1cell (op2_bicat B) _ _ f.
Proof.
  use make_fully_faithful.
  - apply faithful_op2_bicat.
    apply fully_faithful_1cell_faithful.
    exact Hf.
  - intros z g₁ g₂ αf.
    simple refine (_ ,, _).
    + exact (fully_faithful_1cell_inv_map Hf αf).
    + cbn.
      apply fully_faithful_1cell_inv_map_eq.
Defined.

(**
 3. Conservative 1-cells
 *)
Definition conservative_op2_bicat
           {B : bicat}
           {x y : B}
           {f : x --> y}
           (Hf : conservative_1cell f)
  : @conservative_1cell (op2_bicat B) _ _ f.
Proof.
  intros z g₁ g₂ α Hα.
  apply to_op2_is_invertible_2cell.
  apply Hf.
  apply from_op2_is_invertible_2cell.
  exact Hα.
Defined.

(**
 4. Discrete 1-cells
 *)
Definition discrete_op2_bicat
           {B : bicat}
           {x y : B}
           {f : x --> y}
           (Hf : discrete_1cell f)
  : @discrete_1cell (op2_bicat B) _ _ f.
Proof.
  split.
  - apply faithful_op2_bicat.
    apply Hf.
  - apply conservative_op2_bicat.
    apply Hf.
Defined.

(**
 5. Adjunctions
 *)
Definition op2_left_adjoint_right_adjoint_is_left_adjoint
           {B : bicat}
           {x y : B}
           {f : x --> y}
           (Hf : @left_adjoint (op2_bicat B) _ _ f)
  : @left_adjoint B _ _ (left_adjoint_right_adjoint Hf).
Proof.
  simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)).
  - exact f.
  - exact (left_adjoint_counit Hf).
  - exact (left_adjoint_unit Hf).
  - abstract
      (cbn ;
       rewrite !vassocl ;
       exact (internal_triangle2 Hf)).
  - abstract
      (cbn ;
       rewrite !vassocl ;
       exact (internal_triangle1 Hf)).
Defined.

Definition op2_left_adjoint_to_right_adjoint
           {B : bicat}
           {x y : B}
           {f : x --> y}
           (Hf : @left_adjoint (op2_bicat B) _ _ f)
  : @internal_right_adj B _ _ f.
Proof.
  simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)).
  - exact (left_adjoint_right_adjoint Hf).
  - exact (left_adjoint_counit Hf).
  - exact (left_adjoint_unit Hf).
  - abstract
      (cbn ;
       rewrite !vassocl ;
       exact (internal_triangle2 Hf)).
  - abstract
      (cbn ;
       rewrite !vassocl ;
       exact (internal_triangle1 Hf)).
Defined.

Definition right_adjoint_to_op2_left_adjoint
           {B : bicat}
           {x y : B}
           {f : x --> y}
           (Hf : @internal_right_adj B _ _ f)
  : @left_adjoint (op2_bicat B) _ _ f.
Proof.
  simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)).
  - exact (internal_right_adj_left_adjoint Hf).
  - exact (internal_right_adj_counit Hf).
  - exact (internal_right_adj_unit Hf).
  - abstract
      (cbn ;
       rewrite !vassocr ;
       exact (pr22 Hf)).
  - abstract
      (cbn ;
       rewrite !vassocr ;
       exact (pr12 Hf)).
Defined.

Definition op2_left_adjoint_weq_right_adjoint
           {B : bicat}
           {x y : B}
           (f : x --> y)
  : @left_adjoint (op2_bicat B) _ _ f ≃ @internal_right_adj B _ _ f.
Proof.
  use make_weq.
  - exact op2_left_adjoint_to_right_adjoint.
  - use isweq_iso.
    + exact right_adjoint_to_op2_left_adjoint.
    + abstract
        (intro Hf ;
         use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ;
         apply idpath).
    + abstract
        (intro Hf ;
         use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ;
         apply idpath).
Defined.