(* Fpolynomial.v *)

(* polynomials on a ring *)

Set Nested Proofs Allowed.
Require Import Utf8 Arith.
Import List ListNotations.

Require Import Misc Ring2 Rsummation.

(* definition of a polynomial *)

Definition rng_eqb {A} {rng : ring A} (a b : A) :=
  if rng_eq_dec a b then true else false.

(* (lap : list as polynomial) *)
Record poly A {rng : ring A} := mkpoly
  { lap : list A;
    lap_prop : rng_eqb (last lap 1%Rng) 0%Rng = false }.

Arguments lap {A} {rng}.

Theorem eq_poly_eq {A} {rng : ring A} : ∀ p1 p2, p1 = p2 ↔ lap p1 = lap p2.
Proof.
intros.
split; [ now intros; subst p1 | ].
intros Hll.
destruct p1 as (la, lapr).
destruct p2 as (lb, lbpr).
cbn in Hll; subst la; f_equal.
apply (Eqdep_dec.UIP_dec Bool.bool_dec).
Qed.

Theorem eq_poly_prop {A} {rng : ring A} : ∀ la,
  rng_eqb (last la 1%Rng) 0%Rng = false ↔ last la 1%Rng ≠ 0%Rng.
Proof.
intros.
unfold rng_eqb.
now destruct (rng_eq_dec (last la 1%Rng) 0%Rng).
Qed.

Arguments mkpoly {_} {_}.

Theorem lap_1_0_prop {A} {rng : ring A} :
  rng_eqb (last [] 1%Rng) 0%Rng = false.
Proof.
cbn.
unfold rng_eqb.
destruct (rng_eq_dec 1%Rng 0%Rng); [ | easy ].
now apply rng_1_neq_0 in e.
Qed.

Definition poly_zero {α} {r : ring α} := mkpoly [] lap_1_0_prop.
Definition poly_one {α} {r : ring α} := mkpoly [1%Rng] lap_1_0_prop.

(* normalization *)

Fixpoint strip_0s {A} {rng : ring A} la :=
  match la with
  | [] => []
  | a :: la' => if rng_eq_dec a 0%Rng then strip_0s la' else la
  end.

Lemma strip_0s_app {A} {rng : ring A} : ∀ la lb,
  strip_0s (la ++ lb) =
  match strip_0s la with
  | [] => strip_0s lb
  | lc => lc ++ lb
  end.
Proof.
intros.
revert lb.
induction la as [| a]; intros; [ easy | cbn ].
destruct (rng_eq_dec a 0%Rng) as [Haz| Haz]; [ apply IHla | easy ].
Qed.

Definition lap_norm {A} {rng : ring A} la := rev (strip_0s (rev la)).

Theorem poly_norm_prop {A} {rng : ring A} : ∀ la,
  last (lap_norm la) 1%Rng ≠ 0%Rng.
Proof.
intros.
unfold lap_norm.
induction la as [| a]; [ apply rng_1_neq_0 | cbn ].
rewrite strip_0s_app.
remember (strip_0s (rev la)) as lb eqn:Hlb; symmetry in Hlb.
destruct lb as [| b]; cbn. {
  destruct (rng_eq_dec a 0%Rng) as [Haz| Haz]; [ apply rng_1_neq_0 | easy ].
}
cbn in IHla.
rewrite List_last_app.
now rewrite List_last_app in IHla.
Qed.

Definition poly_norm {A} {rng : ring A} la :=
  mkpoly (lap_norm la) (proj2 (eq_poly_prop _) (poly_norm_prop la)).

(**)
Require Import ZArith.

Theorem Z_1_neq_0 : (1 ≠ 0)%Z.
Proof. easy. Qed.

Definition Z_ring : ring Z :=
  {| rng_zero := 0%Z;
     rng_one := 1%Z;
     rng_add := Z.add;
     rng_mul := Z.mul;
     rng_opp := Z.opp;
     rng_1_neq_0 := Z_1_neq_0;
     rng_eq_dec := Z.eq_dec;
     rng_add_comm := Z.add_comm;
     rng_add_assoc := Z.add_assoc;
     rng_add_0_l := Z.add_0_l;
     rng_add_opp_l := Z.add_opp_diag_l;
     rng_mul_comm := Z.mul_comm;
     rng_mul_assoc := Z.mul_assoc;
     rng_mul_1_l := Z.mul_1_l;
     rng_mul_add_distr_l := Z.mul_add_distr_l |}.

(* allows to use ring theorems on Z *)
Canonical Structure Z_ring.

(*
Compute (@lap_norm Z Z_ring [3; 4; 0; 5; 0; 0; 0]%Z).
*)
(**)

(* addition *)

Fixpoint lap_add {α} {r : ring α} al1 al2 :=
  match al1 with
  | [] => al2
  | a1 :: bl1 =>
      match al2 with
      | [] => al1
      | a2 :: bl2 => (a1 + a2)%Rng :: lap_add bl1 bl2
      end
  end.

Definition lap_opp {α} {r : ring α} la := List.map rng_opp la.
Definition lap_sub {A} {rng : ring A} la lb := lap_add la (lap_opp lb).

Definition poly_add {A} {rng : ring A} p1 p2 :=
  poly_norm (lap_add (lap p1) (lap p2)).

Definition poly_opp {α} {r : ring α} pol :=
  poly_norm (lap_opp (lap pol)).

Definition poly_sub {α} {r : ring α} p1 p2 :=
  poly_add p1 (poly_opp p2).

(*
Compute (@poly_add Z Z_ring (poly_norm [3;4;5]%Z) (poly_norm [2;3;-4;5]%Z)).
Compute (@poly_add Z Z_ring (poly_norm [3;4;5]%Z) (poly_norm [2;3;-5]%Z)).
*)

(* multiplication *)

Fixpoint lap_convol_mul {α} {r : ring α} al1 al2 i len :=
  match len with
  | O => []
  | S len1 =>
      (Σ (j = 0, i), List.nth j al1 0 * List.nth (i - j) al2 0)%Rng ::
      lap_convol_mul al1 al2 (S i) len1
  end.

Definition lap_mul {α} {R : ring α} la lb :=
  match la with
  | [] => []
  | _ =>
      match lb with
      | [] => []
      | _ => lap_convol_mul la lb 0 (length la + length lb - 1)
      end
  end.

Definition poly_mul {A} {rng : ring A} p1 p2 :=
  poly_norm (lap_mul (lap p1) (lap p2)).

(*
Compute (@lap_mul Z Z_ring [3;4;5]%Z [2;3;-4;5]%Z).
Compute (@poly_mul Z Z_ring (poly_norm [3;4;5]%Z) (poly_norm [2;3;-4;5]%Z)).
*)

(* power *)

Fixpoint lap_power {α} {r : ring α} la n :=
  match n with
  | O => [1%Rng]
  | S m => lap_mul la (lap_power la m)
  end.

Definition poly_power {A} {rng : ring A} pol n :=
  poly_norm (lap_power (lap pol) n).

(*
Compute (@poly_power Z Z_ring (poly_norm [1; -1]%Z) 4).
*)

(* composition *)

Definition lap_compose {α} {r : ring α} la lb :=
  List.fold_right (λ c accu, lap_add (lap_mul accu lb) [c]) [] la.

Definition lap_compose2 {α} {r : ring α} la lb :=
  List.fold_right
    (λ i accu,
     lap_add accu (lap_mul [List.nth i la 0] (lap_power lb i)))%Rng
    [] (List.seq 0 (length la)).

(* *)

Fixpoint list_pad {α} n (zero : α) rem :=
  match n with
  | O => rem
  | S n1 => zero :: list_pad n1 zero rem
  end.

Theorem xpow_norm {A} {rng : ring A} : ∀ i,
  rng_eqb (last (repeat 0%Rng i ++ [1%Rng]) 1%Rng) 0%Rng = false.
Proof.
intros.
rewrite List_last_app.
unfold rng_eqb.
destruct (rng_eq_dec 1 0) as [H| H]; [ | easy ].
now apply rng_1_neq_0 in H.
Qed.

Definition xpow {α} {r : ring α} i :=
  mkpoly (repeat 0%Rng i ++ [1%Rng]) (xpow_norm i).

Declare Scope lap_scope.
Delimit Scope lap_scope with lap.
Notation "1" := [1%Rng] : lap_scope.
Notation "- a" := (lap_opp a) : lap_scope.
Notation "a + b" := (lap_add a b) : lap_scope.
Notation "a - b" := (lap_sub a b) : lap_scope.
Notation "a * b" := (lap_mul a b) : lap_scope.
Notation "a ^ b" := (lap_power a b) : lap_scope.

Definition list_nth_def_0 {α} {R : ring α} n l := List.nth n l 0%Rng.

Declare Scope poly_scope.
Delimit Scope poly_scope with pol.
Notation "0" := poly_zero : poly_scope.
Notation "1" := poly_one : poly_scope.
Notation "- a" := (poly_opp a) : poly_scope.
Notation "a + b" := (poly_add a b) : poly_scope.
Notation "a - b" := (poly_sub a b) : poly_scope.
Notation "a * b" := (poly_mul a b) : poly_scope.
Notation "'ⓧ' ^ a" := (xpow a) (at level 30, format "'ⓧ' ^ a") : poly_scope.
Notation "'ⓧ'" := (xpow 1) (at level 30, format "'ⓧ'") : poly_scope.

(* *)

Theorem lap_convol_mul_comm : ∀ α (R : ring α) l1 l2 i len,
  lap_convol_mul l1 l2 i len = lap_convol_mul l2 l1 i len.
Proof.
intros α R l1 l2 i len.
revert i.
induction len; intros; [ reflexivity | simpl ].
rewrite IHlen; f_equal.
rewrite summation_rtl.
apply summation_compat; intros j (_, Hj).
rewrite Nat.add_0_r.
rewrite rng_mul_comm.
apply rng_mul_compat; [ idtac | reflexivity ].
rewrite Nat_sub_sub_distr; [ idtac | easy ].
rewrite Nat.sub_diag, Nat.add_0_l; reflexivity.
Qed.

Theorem lap_convol_mul_nil_l : ∀ α (R : ring α) l i len,
  lap_norm (lap_convol_mul [] l i len) = [].
Proof.
intros α R l i len.
unfold lap_norm.
revert i.
induction len; intros; [ reflexivity | ].
cbn - [ summation ].
rewrite all_0_summation_0. {
  rewrite strip_0s_app; cbn.
  specialize (IHlen (S i)).
  apply List_eq_rev_nil in IHlen.
  rewrite IHlen.
  now destruct (rng_eq_dec 0%Rng 0%Rng).
}
intros k (_, Hk).
now rewrite match_id, rng_mul_0_l.
Qed.

Theorem lap_convol_mul_nil_r : ∀ α (R : ring α) l i len,
  lap_norm (lap_convol_mul l [] i len) = [].
Proof.
intros α R l i len.
rewrite lap_convol_mul_comm.
apply lap_convol_mul_nil_l.
Qed.

Theorem list_nth_lap_eq : ∀ α (r : ring α) la lb,
  (∀ i, (List.nth i la 0 = List.nth i lb 0)%Rng)
  → lap_norm la = lap_norm lb.
Proof.
intros α r la lb Hi.
unfold lap_norm; f_equal.
revert lb Hi.
induction la as [| a]; intros. {
  induction lb as [| b]; [ reflexivity | ].
  specialize (Hi 0) as H; cbn in H.
  subst b; cbn.
  rewrite strip_0s_app; cbn.
  remember (strip_0s (rev lb)) as lc eqn:Hlc; symmetry in Hlc.
  destruct lc as [| c]; [ now destruct (rng_eq_dec _ _) | ].
  assert (H : lap_norm [] = lap_norm lb). {
    unfold lap_norm; cbn.
    cbn in IHlb.
    change (rev [] = rev (strip_0s (rev lb))).
    f_equal.
    rewrite Hlc.
    apply IHlb.
    intros i; cbn; rewrite match_id.
    now specialize (Hi (S i)); cbn in Hi.
  }
  cbn in H.
  unfold lap_norm in H.
  rewrite Hlc in H.
  symmetry in H.
  now apply List_eq_rev_nil in H.
} {
  cbn.
  rewrite strip_0s_app.
  remember (strip_0s (rev la)) as lc eqn:Hlc; symmetry in Hlc.
  destruct lc as [| c]. {
    assert (Hla : ∀ i, nth i la 0%Rng = 0%Rng). {
      intros i.
      clear - Hlc.
      revert i.
      induction la as [| a]; intros; [ now cbn; rewrite match_id | cbn ].
      destruct i. {
        cbn in Hlc.
        rewrite strip_0s_app in Hlc; cbn in Hlc.
        remember (strip_0s (rev la)) as lb eqn:Hlb; symmetry in Hlb.
        destruct lb as [| b]; [ now destruct (rng_eq_dec a 0%Rng) | easy ].
      }
      apply IHla.
      cbn in Hlc.
      rewrite strip_0s_app in Hlc; cbn in Hlc.
      remember (strip_0s (rev la)) as lb eqn:Hlb; symmetry in Hlb.
      destruct lb as [| b]; [ now destruct (rng_eq_dec a 0%Rng) | easy ].
    }
    cbn.
    destruct (rng_eq_dec a 0%Rng) as [Haz| Haz]. {
      assert (Hlb : ∀ i, nth i lb 0%Rng = 0%Rng). {
        intros.
        rewrite <- Hi; cbn.
        destruct i; [ easy | ].
        apply Hla.
      }
      clear - Hlb.
      induction lb as [| b]; [ easy | cbn ].
      specialize (Hlb 0) as H1; cbn in H1; subst b.
      rewrite strip_0s_app; cbn.
      rewrite <- IHlb; [ now destruct (rng_eq_dec 0%Rng 0%Rng) | ].
      intros i.
      now specialize (Hlb (S i)).
    }
    destruct lb as [| b]; [ now specialize (Hi 0); cbn in Hi | cbn ].
    rewrite strip_0s_app; cbn.
    remember (strip_0s (rev lb)) as ld eqn:Hld; symmetry in Hld.
    destruct ld as [| d]. {
      destruct (rng_eq_dec b 0%Rng) as [Hbz| Hbz]. {
        subst b.
        now specialize (Hi 0).
      }
      f_equal.
      now specialize (Hi 0).
    }
    specialize (IHla lb).
    assert (H : ∀ i : nat, nth i la 0%Rng = nth i lb 0%Rng). {
      intros i.
      now specialize (Hi (S i)); cbn in Hi.
    }
    specialize (IHla H); clear H.
    now rewrite Hld in IHla.
  }
  destruct lb as [| b]. {
    specialize (IHla []).
    assert (H : ∀ i : nat, nth i la 0%Rng = nth i [] 0%Rng). {
      intros i; cbn; rewrite match_id.
      now specialize (Hi (S i)).
    }
    now specialize (IHla H).
  }
  cbn.
  rewrite strip_0s_app; cbn.
  remember (strip_0s (rev lb)) as ld eqn:Hld; symmetry in Hld.
  destruct ld as [| d]. {
    destruct (rng_eq_dec b 0%Rng) as [Hbz| Hbz]. {
      subst b.
      specialize (IHla lb).
      assert (H : ∀ i : nat, nth i la 0%Rng = nth i lb 0%Rng). {
        intros i.
        now specialize (Hi (S i)); cbn in Hi.
      }
      specialize (IHla H); clear H.
      now rewrite Hld in IHla.
    }
    specialize (IHla lb).
    assert (H : ∀ i : nat, nth i la 0%Rng = nth i lb 0%Rng). {
      intros i.
      now specialize (Hi (S i)); cbn in Hi.
    }
    specialize (IHla H); clear H.
    now rewrite Hld in IHla.
  }
  specialize (Hi 0) as H1; cbn in H1; subst b.
  do 2 rewrite app_comm_cons; f_equal.
  rewrite <- Hld.
  apply IHla.
  now intros i; specialize (Hi (S i)).
}
Qed.

Theorem fold_lap_norm {A} {rng : ring A} :
  ∀ la, rev (strip_0s (rev la)) = lap_norm la.
Proof. easy. Qed.

Theorem lap_add_0_l {α} {r : ring α} : ∀ la, lap_add [] la = la.
Proof. easy. Qed.

Theorem lap_add_0_r {α} {r : ring α} : ∀ la, lap_add la [] = la.
Proof. intros; now destruct la. Qed.

Theorem poly_add_0_l {α} {r : ring α} : ∀ p, (0 + p)%pol = p.
Proof.
intros (la, lapr).
apply eq_poly_eq; cbn.
apply eq_poly_prop in lapr.
induction la as [| a]; [ easy | cbn ].
rewrite strip_0s_app.
rewrite <- (rev_involutive (strip_0s _)).
rewrite IHla; cbn. {
  remember (rev la) as lb eqn:Hlb; symmetry in Hlb.
  destruct lb as [| b]. {
    apply List_eq_rev_nil in Hlb; subst la.
    now destruct (rng_eq_dec a 0).
  }
  cbn.
  rewrite rev_app_distr; cbn; f_equal.
  now rewrite <- rev_involutive, Hlb.
} {
  destruct la as [| a2]; [ | easy ].
  apply rng_1_neq_0.
}
Qed.

Theorem lap_mul_0_l {α} {r : ring α} : ∀ la, lap_norm (lap_mul [] la) = [].
Proof. easy. Qed.

Theorem lap_mul_0_r {α} {r : ring α} : ∀ la, lap_norm (lap_mul la []) = [].
Proof. now intros; destruct la. Qed.

Section lap.

Context {α : Type}.
Context {r : ring α}.

Theorem strip_0s_idemp : ∀ la, strip_0s (strip_0s la) = strip_0s la.
Proof.
intros.
induction la as [| a]; [ easy | cbn ].
destruct (rng_eq_dec a 0%Rng) as [Haz| Haz]; [ easy | cbn ].
now destruct (rng_eq_dec a 0%Rng).
Qed.

Theorem lap_norm_idemp : ∀ la, lap_norm (lap_norm la) = lap_norm la.
Proof.
intros.
unfold lap_norm.
rewrite rev_involutive.
now rewrite strip_0s_idemp.
Qed.

Theorem eq_lap_convol_mul_nil : ∀ la lb i len,
  lap_convol_mul la lb i len = [] → len = 0.
Proof. now intros; induction len. Qed.

(* addition theorems *)

Theorem lap_add_comm : ∀ al1 al2,
  lap_add al1 al2 = lap_add al2 al1.
Proof.
intros al1 al2.
revert al2.
induction al1; intros; [ now destruct al2 | ].
destruct al2; [ easy | cbn ].
now rewrite rng_add_comm, IHal1.
Qed.

Theorem poly_add_comm : ∀ a b, (a + b)%pol = (b + a)%pol.
Proof.
intros.
unfold "+"%pol.
now rewrite lap_add_comm.
Qed.

Theorem lap_add_norm_idemp_l : ∀ la lb,
  lap_norm (lap_norm la + lb)%lap = lap_norm (la + lb)%lap.
Proof.
intros.
unfold lap_norm; f_equal.
revert la.
induction lb as [| b]; intros. {
  do 2 rewrite lap_add_0_r.
  now rewrite rev_involutive, strip_0s_idemp.
}
cbn.
destruct la as [| a]; [ easy | cbn ].
do 2 rewrite strip_0s_app; cbn.
rewrite <- IHlb.
remember (strip_0s (rev la)) as lc eqn:Hlc; symmetry in Hlc.
destruct lc as [| c]. {
  cbn.
  destruct (rng_eq_dec a 0) as [Haz| Haz]. {
    subst a; rewrite rng_add_0_l; cbn.
    now rewrite strip_0s_app.
  }
  cbn.
  now rewrite strip_0s_app.
}
cbn.
rewrite rev_app_distr; cbn.
now rewrite strip_0s_app.
Qed.

Theorem lap_add_norm_idemp_r : ∀ la lb,
  lap_norm (la + lap_norm lb)%lap = lap_norm (la + lb)%lap.
Proof.
intros.
rewrite lap_add_comm, lap_add_norm_idemp_l.
now rewrite lap_add_comm.
Qed.

Theorem lap_add_assoc : ∀ al1 al2 al3,
  lap_add al1 (lap_add al2 al3) = lap_add (lap_add al1 al2) al3.
Proof.
intros al1 al2 al3.
revert al2 al3.
induction al1; intros; [ easy | ].
destruct al2; [ easy | cbn ].
destruct al3; [ easy | cbn ].
rewrite rng_add_assoc.
now rewrite IHal1.
Qed.

Theorem lap_add_add_swap : ∀ la lb lc,
  lap_add (lap_add la lb) lc = lap_add (lap_add la lc) lb.
Proof.
intros la lb lc.
do 2 rewrite <- lap_add_assoc.
now rewrite (lap_add_comm lb).
Qed.

Theorem poly_add_assoc : ∀ pa pb pc,
  (pa + (pb + pc) = (pa + pb) + pc)%pol.
Proof.
intros (la, lapr) (lb, lbpr) (lc, lcpr).
apply eq_poly_eq.
cbn - [ lap_norm ].
rewrite lap_add_norm_idemp_l.
rewrite lap_add_norm_idemp_r.
now rewrite lap_add_assoc.
Qed.

(* multiplication theorems *)

Theorem lap_mul_comm : ∀ a b, lap_mul a b = lap_mul b a.
Proof.
intros la lb.
unfold lap_mul.
destruct la as [| a]; [ now destruct lb | cbn ].
rewrite <- Nat.add_succ_comm; cbn.
rewrite (Nat.add_comm (length lb)).
now rewrite lap_convol_mul_comm.
Qed.

Theorem poly_mul_comm : ∀ pa pb, (pa * pb)%pol = (pb * pa)%pol.
Proof.
intros.
apply eq_poly_eq; cbn.
now rewrite lap_mul_comm.
Qed.

Theorem list_nth_lap_convol_mul_aux : ∀ la lb n i len,
  List.length la + List.length lb - 1 = (i + len)%nat
  → (List.nth n (lap_convol_mul la lb i len) 0%Rng =
     Σ (j = 0, n + i),
     List.nth j la 0 * List.nth (n + i - j) lb 0)%Rng.
Proof.
intros la lb n i len Hlen.
revert la lb i n Hlen.
induction len; intros.
 simpl.
 rewrite Nat.add_0_r in Hlen.
 rewrite all_0_summation_0; [ destruct n; reflexivity | idtac ].
 intros j (_, Hj).
 destruct (le_dec (length la) j) as [H1| H1].
  rewrite List.nth_overflow; [ idtac | assumption ].
  rewrite rng_mul_0_l; reflexivity.

  destruct (le_dec (length lb) (n + i - j)) as [H2| H2].
   rewrite rng_mul_comm.
   rewrite List.nth_overflow; [ idtac | assumption ].
   rewrite rng_mul_0_l; reflexivity.

   exfalso; apply H2; clear Hj H2.
   apply Nat.nle_gt in H1; subst i.
   flia H1.

 simpl.
 destruct n; [ reflexivity | idtac ].
 rewrite Nat.add_succ_r, <- Nat.add_succ_l in Hlen.
 rewrite IHlen; [ idtac | assumption ].
 rewrite Nat.add_succ_r, <- Nat.add_succ_l; reflexivity.
Qed.

(* to be unified perhaps with list_nth_convol_mul below *)
Theorem list_nth_lap_convol_mul : ∀ la lb i len,
  len = length la + length lb - 1
  → (List.nth i (lap_convol_mul la lb 0 len) 0 =
     Σ (j = 0, i), List.nth j la 0 * List.nth (i - j) lb 0)%Rng.
Proof.
intros la lb i len Hlen.
symmetry in Hlen.
rewrite list_nth_lap_convol_mul_aux; [ idtac | assumption ].
rewrite Nat.add_0_r; reflexivity.
Qed.

Theorem summation_mul_list_nth_lap_convol_mul : ∀ la lb lc k,
  (Σ (i = 0, k),
     List.nth i la 0 *
     List.nth (k - i)
       (lap_convol_mul lb lc 0 (length lb + length lc - 1))
       0 =
   Σ (i = 0, k),
     List.nth i la 0 *
     Σ (j = 0, k - i),
       List.nth j lb 0 * List.nth (k - i - j) lc 0)%Rng.
Proof.
intros la lb lc k.
apply summation_compat; intros i (_, Hi).
f_equal.
rewrite list_nth_lap_convol_mul; reflexivity.
Qed.

Theorem summation_mul_list_nth_lap_convol_mul_2 : ∀ la lb lc k,
   (Σ (i = 0, k),
      List.nth i lc 0 *
      List.nth (k - i)
        (lap_convol_mul la lb 0 (length la + length lb - 1))  0 =
    Σ (i = 0, k),
      List.nth (k - i) lc 0 *
      Σ (j = 0, i),
        List.nth j la 0 * List.nth (i - j) lb 0)%Rng.
Proof.
intros la lb lc k.
rewrite summation_rtl.
apply summation_compat; intros i (_, Hi).
rewrite Nat.add_0_r.
f_equal.
rewrite Nat_sub_sub_distr; [ idtac | easy ].
rewrite Nat.sub_diag.
apply list_nth_lap_convol_mul; reflexivity.
Qed.

Lemma lap_norm_mul_assoc : ∀ la lb lc,
  lap_norm (la * (lb * lc))%lap = lap_norm (la * lb * lc)%lap.
Proof.
intros la lb lc.
symmetry; rewrite lap_mul_comm.
unfold lap_mul.
destruct lc as [| c]. {
  destruct la as [| a]; [ easy | now destruct lb ].
}
destruct la as [| a]; [ easy | ].
destruct lb as [| b]; [ easy | ].
move b before a; move c before b.
remember (a :: la) as la' eqn:Hla'.
remember (b :: lb) as lb' eqn:Hlb'.
remember (c :: lc) as lc' eqn:Hlc'.
apply list_nth_lap_eq; intros k.
remember (lap_convol_mul la' lb' 0 (length la' + length lb' - 1)) as ld
  eqn:Hld.
remember (lap_convol_mul lb' lc' 0 (length lb' + length lc' - 1)) as le
  eqn:Hle.
symmetry in Hld, Hle.
destruct ld as [| d]. {
  destruct le as [| e]; [ easy | cbn ].
  rewrite match_id.
  move e before c.
  apply eq_lap_convol_mul_nil in Hld.
  apply Nat.sub_0_le in Hld.
  remember (length la' + length lb') as len eqn:Hlen.
  symmetry in Hlen.
  destruct len. {
    apply Nat.eq_add_0 in Hlen.
    now subst la'.
  }
  destruct len; [ clear Hld | flia Hld ].
  apply Nat.eq_add_1 in Hlen.
  destruct Hlen as [Hlen| Hlen]; [ now rewrite Hlb' in Hlen | ].
  now rewrite Hla' in Hlen.
}
destruct le as [| e]. {
  cbn; rewrite match_id.
  move d before c.
  apply eq_lap_convol_mul_nil in Hle.
  apply Nat.sub_0_le in Hle.
  remember (length lb' + length lc') as len eqn:Hlen.
  symmetry in Hlen.
  destruct len. {
    apply Nat.eq_add_0 in Hlen.
    now subst lb'.
  }
  destruct len; [ clear Hle | flia Hle ].
  apply Nat.eq_add_1 in Hlen.
  destruct Hlen as [Hlen| Hlen]; [ now rewrite Hlc' in Hlen | ].
  now rewrite Hlb' in Hlen.
}
rewrite list_nth_lap_convol_mul; [ idtac | reflexivity ].
rewrite list_nth_lap_convol_mul; [ idtac | reflexivity ].
rewrite <- Hld, <- Hle.
rewrite summation_mul_list_nth_lap_convol_mul_2; symmetry.
rewrite summation_mul_list_nth_lap_convol_mul; symmetry.
rewrite <- summation_summation_mul_swap.
rewrite <- summation_summation_mul_swap.
rewrite summation_summation_exch.
rewrite summation_summation_shift.
apply summation_compat; intros i Hi.
apply summation_compat; intros j Hj.
rewrite rng_mul_comm, rng_mul_assoc.
rewrite Nat.add_comm, Nat.add_sub.
rewrite Nat.add_comm, Nat.sub_add_distr.
reflexivity.
Qed.

Theorem eq_lap_norm_eq_length : ∀ la lb,
  lap_norm la = lap_norm lb
  → length la = length lb
  → la = lb.
Proof.
intros * Hll Hlen.
unfold lap_norm in Hll.
apply (f_equal (@rev α)) in Hll.
do 2 rewrite rev_involutive in Hll.
setoid_rewrite <- rev_length in Hlen.
enough (H : rev la = rev lb). {
  apply (f_equal (@rev α)) in H.
  now do 2 rewrite rev_involutive in H.
}
remember (rev la) as l; clear la Heql; rename l into la.
remember (rev lb) as l; clear lb Heql; rename l into lb.
revert la Hll Hlen.
induction lb as [| b]; intros. {
  now apply length_zero_iff_nil in Hlen.
}
destruct la as [| a]; [ easy | ].
cbn in Hll, Hlen.
apply Nat.succ_inj in Hlen.
destruct (rng_eq_dec a 0%Rng) as [Haz| Haz]. {
  destruct (rng_eq_dec b 0%Rng) as [Hbz| Hbz]. {
    subst a b; f_equal.
    now apply IHlb.
  }
  exfalso; clear - Hbz Hll Hlen.
  assert (H : length la ≤ length lb) by flia Hlen.
  clear Hlen; rename H into Hlen.
  induction la as [| a]; [ easy | ].
  cbn in Hll.
  destruct (rng_eq_dec a 0%Rng) as [Haz| Haz]. {
    cbn in Hlen.
    clear a Haz.
    apply IHla; [ easy | flia Hlen ].
  }
  rewrite Hll in Hlen; cbn in Hlen.
  flia Hlen.
}
destruct (rng_eq_dec b 0%Rng) as [Hbz| Hbz]. {
  exfalso; clear b Hbz.
  clear - Haz Hll Hlen.
  assert (H : length lb ≤ length la) by flia Hlen.
  clear Hlen; rename H into Hlen.
  induction lb as [| b]; [ easy | ].
  cbn in Hll.
  destruct (rng_eq_dec b 0%Rng) as [Hbz| Hbz]. {
    cbn in Hlen.
    clear b Hbz.
    apply IHlb; [ easy | flia Hlen ].
  }
  rewrite <- Hll in Hlen; cbn in Hlen.
  flia Hlen.
}
easy.
Qed.

Theorem lap_convol_mul_length : ∀ la lb i len,
  length (lap_convol_mul la lb i len) = len.
Proof.
intros.
revert la lb i.
induction len; intros; [ easy | ].
cbn.
now rewrite IHlen.
Qed.

Theorem lap_mul_assoc : ∀ la lb lc,
  (la * (lb * lc))%lap = ((la * lb) * lc)%lap.
Proof.
intros.
apply eq_lap_norm_eq_length; [ apply lap_norm_mul_assoc | ].
unfold "*"%lap.
destruct la as [| a]; [ easy | ].
destruct lb as [| b]; [ easy | ].
destruct lc as [| c]. {
  now destruct (lap_convol_mul _ _ _ _).
}
cbn.
do 4 (rewrite Nat.add_succ_r; cbn); f_equal.
do 2 rewrite rng_add_0_r.
do 4 rewrite lap_convol_mul_length.
apply Nat.add_assoc.
Qed.

Theorem lap_convol_mul_0_l : ∀ la lb i len,
  (∀ i, nth i la 0%Rng = 0%Rng)
  → lap_norm (lap_convol_mul la lb i len) = [].
Proof.
intros * Ha.
revert i.
induction len; intros; [ easy | ].
cbn - [ summation ].
rewrite strip_0s_app.
remember (strip_0s (rev _)) as lc eqn:Hlc; symmetry in Hlc.
destruct lc as [| c]. {
  rewrite all_0_summation_0. 2: {
    intros j Hj.
    now rewrite Ha, rng_mul_0_l.
  }
  cbn.
  now destruct (rng_eq_dec 0%Rng 0%Rng).
}
unfold lap_norm in IHlen.
specialize (IHlen (S i)).
rewrite Hlc in IHlen.
now apply List_eq_rev_nil in IHlen.
Qed.

Theorem all_0_all_rev_0 : ∀ la,
  (∀ i, nth i la 0%Rng = 0%Rng)
  ↔ (∀ i, nth i (rev la) 0%Rng = 0%Rng).
Proof.
intros *.
split; intros H i. {
  destruct (lt_dec i (length la)) as [Hila| Hila]. {
    rewrite rev_nth; [ apply H | easy ].
  }
  apply nth_overflow; rewrite rev_length; flia Hila.
} {
  destruct (lt_dec i (length la)) as [Hila| Hila]. {
    rewrite <- (rev_involutive la).
    rewrite rev_nth; [ apply H | now rewrite rev_length ].
  }
  apply nth_overflow; flia Hila.
}
Qed.

Theorem eq_strip_0s_nil : ∀ la,
  strip_0s la = [] ↔ ∀ i, nth i la 0%Rng = 0%Rng.
Proof.
intros.
split. {
  intros Hla *.
  revert i.
  induction la as [| a]; intros; [ now destruct i | cbn ].
  cbn in Hla.
  destruct (rng_eq_dec a 0%Rng) as [Haz| Haz]; [ | easy ].
  destruct i; [ easy | ].
  now apply IHla.
} {
  intros Hla.
  induction la as [| a]; [ easy | cbn ].
  destruct (rng_eq_dec a 0%Rng) as [Haz| Haz]. {
    apply IHla.
    intros i.
    now specialize (Hla (S i)).
  }
  now specialize (Hla 0).
}
Qed.

Theorem eq_strip_0s_rev_nil : ∀ la,
  strip_0s (rev la) = [] ↔ ∀ i, nth i la 0%Rng = 0%Rng.
Proof.
intros.
split; intros Hla. {
  apply all_0_all_rev_0.
  now apply eq_strip_0s_nil.
} {
  apply eq_strip_0s_nil.
  apply all_0_all_rev_0.
  now rewrite rev_involutive.
}
Qed.

Lemma lap_convol_mul_cons_with_0_l : ∀ a la lb i len,
  (∀ i, nth i la 0%Rng = 0%Rng)
  → lap_convol_mul (a :: la) lb i len = lap_convol_mul [a] lb i len.
Proof.
intros * Hla.
revert i.
induction len; intros; [ easy | ].
cbn - [ summation ].
f_equal; [ | apply IHlen ].
apply summation_compat.
intros j Hj.
destruct j; [ easy | ].
rewrite match_id.
now rewrite Hla.
Qed.

Theorem lap_convol_mul_succ : ∀ la lb i len,
  lap_convol_mul la lb i (S len) =
  lap_convol_mul la lb i len ++
    [Σ (j = 0, i + len),
     List.nth j la 0 * List.nth (i + len - j) lb 0]%Rng.
Proof.
intros.
cbn - [ summation ].
revert i.
induction len; intros. {
  now rewrite Nat.add_0_r.
}
cbn - [ summation ].
f_equal.
specialize (IHlen (S i)).
cbn - [ summation ] in IHlen.
rewrite Nat.add_succ_r.
apply IHlen.
Qed.

Theorem lap_norm_app_0_r : ∀ la lb,
  (∀ i, nth i lb 0%Rng = 0%Rng)
  → lap_norm la = lap_norm (la ++ lb).
Proof.
intros * Hlb.
unfold lap_norm; f_equal.
induction la as [| a]. {
  cbn; symmetry.
  induction lb as [| b]; [ easy | cbn ].
  rewrite strip_0s_app.
  rewrite IHlb. 2: {
    intros i.
    now specialize (Hlb (S i)).
  }
  specialize (Hlb 0); cbn in Hlb; rewrite Hlb; cbn.
  now destruct (rng_eq_dec 0%Rng 0%Rng).
}
cbn.
do 2 rewrite strip_0s_app.
now rewrite IHla.
Qed.

Theorem lap_convol_mul_more : ∀ n la lb i len,
  length la + length lb - 1 ≤ i + len
  → lap_norm (lap_convol_mul la lb i len) =
    lap_norm (lap_convol_mul la lb i (len + n)).
Proof.
intros.
induction n; [ rewrite Nat.add_0_r; reflexivity | idtac ].
rewrite Nat.add_succ_r.
rewrite lap_convol_mul_succ.
rewrite IHn.
apply lap_norm_app_0_r.
intros j.
rewrite all_0_summation_0. {
  destruct j; [ easy | now destruct j ].
}
clear j.
intros j (_, Hj).
apply rng_mul_eq_0.
destruct (le_dec (length la) j) as [H1| H1]. {
  now left; rewrite List.nth_overflow.
} {
  apply Nat.nle_gt in H1.
  destruct (le_dec (length lb) (i + (len + n) - j)) as [H2| H2]. {
    now right; rewrite nth_overflow.
  } {
    exfalso; apply H2; clear H2.
    flia H H1.
  }
}
Qed.

Theorem all_0_lap_norm_nil : ∀ la,
  (∀ i, nth i la 0%Rng = 0%Rng)
  → lap_norm la = [].
Proof.
intros * Hla.
induction la as [| a]; [ easy | cbn ].
rewrite strip_0s_app.
remember (strip_0s (rev la)) as lb eqn:Hlb; symmetry in Hlb.
destruct lb as [| b]. {
  cbn.
  destruct (rng_eq_dec a 0%Rng) as [H1| H1]; [ easy | exfalso ].
  now specialize (Hla 0); cbn in Hla.
}
exfalso.
assert (H : strip_0s (rev la) = []). {
  clear - Hla.
  apply eq_strip_0s_nil.
  intros i.
  destruct (lt_dec i (length la)) as [Hila| Hila]. {
    rewrite rev_nth; [ | easy ].
    specialize (Hla (S (length la - S i))).
    now cbn in Hla.
  }
  apply Nat.nlt_ge in Hila.
  rewrite nth_overflow; [ easy | now rewrite rev_length ].
}
now rewrite Hlb in H.
Qed.

Theorem lap_norm_repeat_0 : ∀ la,
  la = lap_norm la ++ repeat 0%Rng (length la - length (lap_norm la)).
Proof.
intros.
induction la as [| a]; [ easy | ].
cbn.
rewrite strip_0s_app.
remember (strip_0s (rev la)) as lb eqn:Hlb; symmetry in Hlb.
destruct lb as [| b]. {
  cbn.
  destruct (rng_eq_dec a 0%Rng) as [Haz| Haz]. {
    cbn; subst a; f_equal.
    assert (H : lap_norm la = []). {
      apply all_0_lap_norm_nil.
      intros i.
      specialize (proj1 (eq_strip_0s_nil _) Hlb) as H1.
      destruct (lt_dec i (length la)) as [Hila| Hila]. {
        replace la with (rev (rev la)) by apply rev_involutive.
        rewrite rev_nth; rewrite rev_length; [ | easy ].
        apply H1.
      }
      apply Nat.nlt_ge in Hila.
      now rewrite nth_overflow.
    }
    rewrite H in IHla; cbn in IHla.
    now rewrite Nat.sub_0_r in IHla.
  } {
    cbn; f_equal.
    assert (H : lap_norm la = []). {
      apply all_0_lap_norm_nil.
      intros i.
      specialize (proj1 (eq_strip_0s_nil _) Hlb) as H1.
      destruct (lt_dec i (length la)) as [Hila| Hila]. {
        replace la with (rev (rev la)) by apply rev_involutive.
        rewrite rev_nth; rewrite rev_length; [ | easy ].
        apply H1.
      }
      apply Nat.nlt_ge in Hila.
      now rewrite nth_overflow.
    }
    now rewrite H in IHla; cbn in IHla.
  }
} {
  cbn.
  rewrite rev_app_distr; cbn; f_equal.
  replace (rev lb ++ [b]) with (rev (b :: lb)) by easy.
  rewrite <- Hlb.
  now rewrite fold_lap_norm.
}
Qed.

Theorem lap_convol_mul_app_rep_0_l : ∀ la lb i len n,
  lap_norm (lap_convol_mul (la ++ repeat 0%Rng n) lb i len) =
  lap_norm (lap_convol_mul la lb i len).
Proof.
intros.
revert la i len.
induction n; intros. {
  now cbn; rewrite app_nil_r.
}
cbn.
replace (0%Rng :: repeat 0%Rng n) with ([0%Rng] ++ repeat 0%Rng n) by easy.
rewrite app_assoc.
rewrite IHn; clear n IHn.
revert la i.
induction len; intros; [ easy | ].
cbn - [ summation ].
do 2 rewrite strip_0s_app.
rewrite <- (rev_involutive (strip_0s _)).
rewrite fold_lap_norm.
rewrite <- (rev_involutive (strip_0s (rev _))).
rewrite fold_lap_norm.
rewrite IHlen.
remember (rev (lap_norm _)) as lc eqn:Hlc; symmetry in Hlc.
f_equal.
destruct lc as [| c]. {
  apply List_eq_rev_nil in Hlc.
  f_equal; f_equal.
  apply summation_compat.
  intros j Hj.
  f_equal; clear.
  destruct (lt_dec j (length la)) as [Hjla| Hjla]. {
    now rewrite app_nth1.
  }
  apply Nat.nlt_ge in Hjla.
  rewrite (nth_overflow la); [ | easy ].
  rewrite app_nth2; [ | easy ].
  destruct (Nat.eq_dec j (length la)) as [Hjla2| Hjla2]. {
    now rewrite Hjla2, Nat.sub_diag.
  }
  rewrite nth_overflow; [ easy | cbn; flia Hjla Hjla2 ].
} {
  f_equal; f_equal.
  apply summation_compat.
  intros j Hj.
  f_equal; clear.
  destruct (lt_dec j (length la)) as [Hjla| Hjla]. {
    now rewrite app_nth1.
  }
  apply Nat.nlt_ge in Hjla.
  rewrite (nth_overflow la); [ | easy ].
  rewrite app_nth2; [ | easy ].
  destruct (Nat.eq_dec j (length la)) as [Hjla2| Hjla2]. {
    now rewrite Hjla2, Nat.sub_diag.
  }
  rewrite nth_overflow; [ easy | cbn; flia Hjla Hjla2 ].
}
Qed.

Theorem lap_norm_cons_norm : ∀ a la lb i len,
  length (a :: la) + length lb - 1 ≤ i + len
  → lap_norm (lap_convol_mul (a :: lap_norm la) lb i len) =
    lap_norm (lap_convol_mul (a :: la) lb i len).
Proof.
intros * Hlen.
rewrite (lap_norm_repeat_0 la) at 2.
rewrite app_comm_cons.
now rewrite lap_convol_mul_app_rep_0_l.
Qed.

Theorem lap_norm_length_le : ∀ la, length (lap_norm la) ≤ length la.
Proof.
intros.
rewrite (lap_norm_repeat_0 la) at 2.
rewrite app_length; flia.
Qed.

Theorem nth_lap_add : ∀ i la lb,
  nth i (la + lb)%lap 0%Rng = (nth i la 0 + nth i lb 0)%Rng.
Proof.
intros.
revert i lb.
induction la as [| a]; intros; cbn. {
  now rewrite match_id, rng_add_0_l.
}
destruct lb as [| b]; cbn. {
  now rewrite match_id, rng_add_0_r.
}
destruct i; [ easy | ].
apply IHla.
Qed.

Theorem lap_mul_norm_idemp_l : ∀ la lb,
  lap_norm (lap_norm la * lb)%lap = lap_norm (la * lb)%lap.
Proof.
intros.
unfold "*"%lap; cbn.
destruct la as [| a]; [ easy | cbn ].
rewrite strip_0s_app.
remember (strip_0s (rev la)) as lc eqn:Hlc; symmetry in Hlc.
destruct lc as [| c]. {
  cbn.
  destruct (rng_eq_dec a 0%Rng) as [Haz| Haz]. {
    cbn.
    destruct lb as [| b]; [ easy | cbn ].
    rewrite lap_convol_mul_0_l; [ easy | ].
    intros i; cbn.
    destruct i; [ easy | ].
    specialize (proj1 (eq_strip_0s_nil _) Hlc) as H1.
    destruct (lt_dec i (length la)) as [Hil| Hil]. {
      specialize (H1 (length la - S i)).
      rewrite <- rev_length in H1.
      rewrite <- rev_nth in H1. {
        now rewrite rev_involutive in H1.
      }
      now rewrite rev_length.
    }
    apply Nat.nlt_ge in Hil.
    now rewrite nth_overflow.
  }
  cbn.
  destruct lb as [| b]; [ easy | ].
  remember (b :: lb) as ld eqn:Hld; symmetry in Hld.
  do 2 rewrite Nat.sub_0_r.
  rewrite fold_lap_norm.
  rewrite (lap_convol_mul_cons_with_0_l _ la). 2: {
    intros i.
    specialize (proj1 (eq_strip_0s_nil _) Hlc) as H1.
    destruct (lt_dec i (length la)) as [Hil| Hil]. {
      specialize (H1 (length la - S i)).
      rewrite <- rev_length in H1.
      rewrite <- rev_nth in H1. {
        now rewrite rev_involutive in H1.
      }
      now rewrite rev_length.
    }
    apply Nat.nlt_ge in Hil.
    now rewrite nth_overflow.
  }
  rewrite Nat.add_comm.
  apply lap_convol_mul_more; cbn.
  now rewrite Nat.sub_0_r.
}
rewrite rev_app_distr; cbn.
rewrite fold_lap_norm.
destruct lb as [| b]; [ easy | ].
remember (b :: lb) as d eqn:Hd.
replace (rev lc ++ [c]) with (rev (c :: lc)) by easy.
rewrite <- Hlc.
rewrite fold_lap_norm.
do 2 rewrite Nat.sub_0_r.
clear c lc b lb Hlc Hd.
rename d into lb.
rewrite (lap_convol_mul_more (length la - length (lap_norm la))). 2: {
  now cbn; rewrite Nat.sub_0_r.
}
rewrite (Nat.add_comm _ (length lb)).
rewrite <- Nat.add_assoc.
rewrite Nat.add_sub_assoc; [ | apply lap_norm_length_le ].
rewrite (Nat.add_comm _ (length la)).
rewrite Nat.add_sub.
rewrite Nat.add_comm.
apply lap_norm_cons_norm.
now cbn; rewrite Nat.sub_0_r.
Qed.

Theorem lap_mul_norm_idemp_r : ∀ la lb,
  lap_norm (la * lap_norm lb)%lap = lap_norm (la * lb)%lap.
Proof.
intros.
setoid_rewrite lap_mul_comm.
apply lap_mul_norm_idemp_l.
Qed.

Theorem poly_mul_assoc : ∀ p1 p2 p3,
  (p1 * (p2 * p3))%pol = ((p1 * p2) * p3) %pol.
Proof.
intros.
unfold "*"%pol.
remember (lap p1) as la.
remember (lap p2) as lb.
remember (lap p3) as lc.
clear p1 Heqla.
clear p2 Heqlb.
clear p3 Heqlc.
unfold poly_norm at 1 3.
apply eq_poly_eq; cbn.
rewrite lap_mul_norm_idemp_l.
rewrite lap_mul_norm_idemp_r.
now rewrite lap_mul_assoc.
Qed.

Theorem lap_mul_mul_swap : ∀ la lb lc,
  lap_mul (lap_mul la lb) lc = lap_mul (lap_mul la lc) lb.
Proof.
intros la lb lc.
do 2 rewrite <- lap_mul_assoc.
now rewrite (lap_mul_comm lb).
Qed.

Fixpoint lap_convol_mul_add al1 al2 al3 i len :=
  match len with
  | O => []
  | S len1 =>
      (Σ (j = 0, i),
       List.nth j al1 0 *
       (List.nth (i - j) al2 0 + List.nth (i - j) al3 0))%Rng ::
       lap_convol_mul_add al1 al2 al3 (S i) len1
  end.

(* *)

Theorem list_nth_add : ∀ k la lb,
  (List.nth k (lap_add la lb) 0 =
   List.nth k la 0 + List.nth k lb 0)%Rng.
Proof.
intros k la lb.
revert la lb.
induction k; intros.
 destruct la as [| a]; simpl; [ rewrite rng_add_0_l; reflexivity | idtac ].
 destruct lb as [| b]; simpl; [ rewrite rng_add_0_r; reflexivity | idtac ].
 reflexivity.

 destruct la as [| a]; simpl; [ rewrite rng_add_0_l; reflexivity | idtac ].
 destruct lb as [| b]; simpl; [ rewrite rng_add_0_r; reflexivity | idtac ].
 apply IHk.
Qed.

Theorem lap_convol_mul_lap_add : ∀ la lb lc i len,
  eq
    (lap_convol_mul la (lap_add lb lc) i len)
    (lap_convol_mul_add la lb lc i len).
Proof.
intros la lb lc i len.
revert la lb lc i.
induction len; intros; [ reflexivity | simpl ].
rewrite IHlen; f_equal.
apply summation_compat; intros j (_, Hj).
f_equal.
rewrite list_nth_add; reflexivity.
Qed.

Theorem lap_add_lap_convol_mul : ∀ la lb lc i len,
  eq
     (lap_add
        (lap_convol_mul la lb i len)
        (lap_convol_mul la lc i len))
     (lap_convol_mul_add la lb lc i len).
Proof.
intros la lb lc i len.
revert la lb lc i.
induction len; intros; [ reflexivity | simpl ].
rewrite IHlen; f_equal.
rewrite <- summation_add_distr.
apply summation_compat; intros j (_, Hj).
rewrite rng_mul_add_distr_l; reflexivity.
Qed.

Lemma lap_norm_mul_add_distr_l : ∀ la lb lc,
  lap_norm (la * (lb + lc))%lap = lap_norm (la * lb + la * lc)%lap.
Proof.
intros la lb lc.
unfold lap_mul.
destruct la as [| a]; [ easy | ].
destruct lb as [| b]; [ easy | ].
destruct lc as [| c]; [ now cbn; rewrite lap_add_0_r | ].
move b before a; move c before b.
remember (a :: la) as la' eqn:Hla'.
remember (b :: lb) as lb' eqn:Hlb'.
remember (c :: lc) as lc' eqn:Hlc'.
remember (length la' + length (lap_add lb' lc') - 1) as labc.
remember (length la' + length lb' - 1) as lab.
remember (length la' + length lc' - 1) as lac.
rewrite Heqlabc.
remember (lb' + lc')%lap as lbc.
symmetry in Heqlbc.
destruct lbc as [| bc]. {
  cbn.
  now subst lb' lc'.
}
rewrite <- Heqlbc in Heqlabc |-*.
rewrite lap_convol_mul_more with (n := (lab + lac)%nat). 2: {
  subst; flia.
}
rewrite <- Heqlabc.
symmetry.
rewrite Heqlab.
rewrite <- lap_add_norm_idemp_l.
rewrite lap_convol_mul_more with (n := (labc + lac)%nat); [ | flia ].
rewrite <- Heqlab.
rewrite lap_add_norm_idemp_l.
rewrite lap_add_comm.
rewrite <- lap_add_norm_idemp_l.
rewrite Heqlac.
rewrite lap_convol_mul_more with (n := (labc + lab)%nat); [ | flia ].
rewrite lap_add_norm_idemp_l.
rewrite <- Heqlac.
rewrite Nat.add_comm.
rewrite lap_add_comm.
rewrite Nat.add_assoc, Nat.add_shuffle0, Nat.add_comm, Nat.add_assoc.
symmetry.
rewrite lap_convol_mul_lap_add.
rewrite lap_add_lap_convol_mul.
reflexivity.
Qed.

Theorem lap_add_length : ∀ la lb,
  length (la + lb)%lap = max (length la) (length lb).
Proof.
intros.
revert lb.
induction la as [| a]; intros; [ easy | ].
cbn.
destruct lb as [| b]; [ easy | cbn ].
now rewrite IHla.
Qed.

Lemma lap_mul_add_distr_l : ∀ la lb lc,
  (la * (lb + lc))%lap = (la * lb + la * lc)%lap.
Proof.
intros la lb lc.
apply eq_lap_norm_eq_length; [ apply lap_norm_mul_add_distr_l | ].
destruct la as [| a]; [ easy | ].
destruct lb as [| b]; [ easy | ].
destruct lc as [| c]. {
  now cbn; rewrite lap_add_0_r.
}
cbn.
do 3 (rewrite Nat.add_succ_r; cbn); f_equal.
rewrite lap_convol_mul_length.
do 2 rewrite lap_add_length; cbn.
do 2 rewrite lap_convol_mul_length.
now rewrite Nat.add_max_distr_l.
Qed.

Theorem poly_mul_add_distr_l : ∀ pa pb pc,
  (pa * (pb + pc))%pol = (pa * pb + pa * pc)%pol.
Proof.
intros.
apply eq_poly_eq; cbn.
rewrite fold_lap_norm.
rewrite lap_mul_norm_idemp_r.
rewrite lap_add_norm_idemp_l.
rewrite lap_add_norm_idemp_r.
now rewrite lap_mul_add_distr_l.
Qed.

Lemma lap_convol_mul_1_l : ∀ la i len,
  length la = i + len
  → lap_convol_mul [1%Rng] la i len = skipn i la.
Proof.
intros * Hlen.
revert i Hlen.
induction len; intros. {
  rewrite Nat.add_0_r in Hlen; rewrite <- Hlen.
  symmetry; apply skipn_all.
}
cbn - [ summation nth ].
rewrite summation_split_first; [ | flia ].
rewrite all_0_summation_0. 2: {
  intros j Hj.
  destruct j; [ flia Hj | cbn ].
  now rewrite match_id, rng_mul_0_l.
}
rewrite Nat.sub_0_r, rng_add_0_r; cbn.
rewrite rng_mul_1_l.
rewrite IHlen; [ | flia Hlen ].
clear - Hlen.
revert i Hlen.
induction la as [ | a]; intros. {
  cbn in Hlen; flia Hlen.
}
cbn.
destruct i; [ easy | ].
rewrite IHla; [ easy | ].
cbn in Hlen; flia Hlen.
Qed.

Theorem lap_mul_1_l : ∀ la, ([1%Rng] * la)%lap = la.
Proof.
intros la.
unfold lap_mul.
destruct la as [| a]; [ easy | cbn ].
rewrite rng_mul_1_l, rng_add_0_r; f_equal.
now rewrite lap_convol_mul_1_l.
Qed.

Theorem lap_mul_1_r : ∀ la, (la * [1%Rng])%lap = la.
Proof.
intros la.
rewrite lap_mul_comm.
apply lap_mul_1_l.
Qed.

Theorem poly_mul_1_l : ∀ p, (1 * p)%pol = p.
Proof.
intros (la, lapr).
unfold "*"%pol.
rewrite lap_mul_1_l; cbn.
apply eq_poly_eq; cbn.
unfold rng_eqb in lapr.
unfold lap_norm.
destruct (rng_eq_dec (last la 1%Rng) 0) as [Hlaz| Hlaz]; [ easy | ].
clear lapr.
induction la as [| a]; [ easy | cbn ].
rewrite strip_0s_app.
remember (strip_0s (rev la)) as lb eqn:Hlb; symmetry in Hlb.
destruct lb as [| b]. {
  specialize (proj1 (eq_strip_0s_rev_nil _) Hlb) as H1.
  cbn; clear Hlb.
  destruct (rng_eq_dec a 0) as [Haz| Haz]. {
    exfalso; subst a.
    cbn in IHla.
    destruct la as [| a]; [ easy | ].
    remember (a :: la) as lb; cbn in Hlaz; subst lb.
    now specialize (IHla Hlaz).
  }
  cbn in IHla |-*.
  rewrite <- IHla; [ easy | ].
  cbn in Hlaz.
  destruct la as [| a2]; [ | easy ].
  intros; apply rng_1_neq_0.
}
cbn.
rewrite rev_app_distr; cbn; f_equal.
apply IHla.
cbn in Hlaz.
now destruct la.
Qed.

End lap.

Lemma lap_add_opp_l {α} {r : ring α} : ∀ la, lap_norm (- la + la)%lap = [].
Proof.
intros.
unfold lap_norm.
apply List_eq_rev_nil.
rewrite rev_involutive.
induction la as [| a]; [ reflexivity | cbn ].
rewrite strip_0s_app.
remember (strip_0s _) as lb eqn:Hlb; symmetry in Hlb.
subst lb.
rewrite IHla; cbn.
rewrite rng_add_opp_l.
now destruct (rng_eq_dec 0 0).
Qed.

Theorem poly_add_opp_l {α} {r : ring α} : ∀ p, (- p + p)%pol = 0%pol.
Proof.
intros p.
unfold "+"%pol; cbn.
apply eq_poly_eq; cbn.
rewrite lap_add_norm_idemp_l.
apply lap_add_opp_l.
Qed.

Theorem poly_add_opp_r {α} {r : ring α} : ∀ p, (p - p)%pol = 0%pol.
Proof.
intros p.
unfold poly_sub.
rewrite poly_add_comm.
apply poly_add_opp_l.
Qed.

Theorem poly_1_neq_0 {A} {rng : ring A} : 1%pol ≠ 0%pol.
Proof. easy. Qed.

Fixpoint lap_eqb {A} {rng : ring A} la lb :=
  match la with
  | [] =>
      match lb with
      | [] => true
      | _ :: _ => false
      end
  | a :: la' =>
      match lb with
      | [] => false
      | b :: lb' => if rng_eq_dec a b then lap_eqb la' lb' else false
      end
  end.

Theorem lap_eqb_eq {A} {rng : ring A} : ∀ la lb,
  lap_eqb la lb = true ↔ la = lb.
Proof.
intros.
revert lb.
induction la as [| a]; intros; [ now destruct lb | ].
destruct lb as [| b]; [ easy | cbn ].
destruct (rng_eq_dec a b) as [Hab| Hab]. {
  subst b.
  split; intros Hll; [ now f_equal; apply IHla | ].
  injection Hll; clear Hll; intros; subst lb.
  now apply IHla.
} {
  split; intros Hll; [ easy | ].
  now injection Hll; intros.
}
Qed.

Theorem lap_eqb_neq {A} {rng : ring A} : ∀ la lb,
  lap_eqb la lb = false ↔ la ≠ lb.
Proof.
intros.
revert lb.
induction la as [| a]; intros; [ now destruct lb | ].
destruct lb as [| b]; [ easy | cbn ].
destruct (rng_eq_dec a b) as [Hab| Hab]. {
  subst b.
  split; intros Hll. {
    intros H.
    injection H; clear H; intros; subst lb.
    now apply IHla in Hll.
  } {
    apply IHla.
    intros H; apply Hll.
    now subst lb.
  }
} {
  split; intros Hll; [ | easy ].
  intros H; apply Hab.
  now injection H; intros.
}
Qed.

Lemma lap_eq_dec {A} {rng : ring A} : ∀ la lb : list A,
  {la = lb} + {la ≠ lb}.
Proof.
intros.
remember (lap_eqb la lb) as lab eqn:Hlab; symmetry in Hlab.
destruct lab. {
  now left; apply lap_eqb_eq.
} {
  now right; apply lap_eqb_neq.
}
Qed.

Theorem poly_eq_dec {A} {rng : ring A} : ∀ pa pb : poly _,
  {pa = pb} + {pa ≠ pb}.
Proof.
intros (la, lapr) (lb, lbpr).
destruct (lap_eq_dec la lb) as [Hll| Hll]. {
  left; subst lb.
  now apply eq_poly_eq.
} {
  right; intros H; apply Hll.
  now injection H.
}
Qed.

Definition polynomial_ring {α} {r : ring α} : ring (poly α) :=
  {| rng_zero := poly_zero;
     rng_one := poly_one;
     rng_add := poly_add;
     rng_mul := poly_mul;
     rng_opp := poly_opp;
     rng_1_neq_0 := poly_1_neq_0;
     rng_eq_dec := poly_eq_dec;
     rng_add_comm := poly_add_comm;
     rng_add_assoc := poly_add_assoc;
     rng_add_0_l := poly_add_0_l;
     rng_add_opp_l := poly_add_opp_l;
     rng_mul_comm := poly_mul_comm;
     rng_mul_assoc := poly_mul_assoc;
     rng_mul_1_l := poly_mul_1_l;
     rng_mul_add_distr_l := poly_mul_add_distr_l |}.

(* allows to use ring theorems on polynomials *)
Canonical Structure polynomial_ring.

(* *)

Definition eval_lap {α} {R : ring α} la x :=
  (List.fold_right (λ c accu, accu * x + c) 0 la)%Rng.

Definition eval_poly {α} {R : ring α} pol :=
  eval_lap (lap pol).


(**************************************************************************
* TLC: A library for Coq                                                  *
* Well-founded relations                                                  *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic
 LibProd LibSum LibRelation LibNat.

(* ********************************************************************** *)
(** * Compatibility *)

Definition wf := well_founded.

Hint Extern 1 (wf ?R) => unfold R : wf.

(** New tactic [splits_all] that does not loop on well-founded goals *)

Ltac splits_all_base ::=
  match goal with
  | |- wf _ => idtac
  | |- well_founded => idtac
  | _ => try (split; splits_all_base)
  end.

(* ********************************************************************** *)
(** * Properties of well-foundedness *)

(* ---------------------------------------------------------------------- *)
(** ** Inclusion and equivalence *)

(** Well-foundedness preserved by inclusion *)

Lemma incl_wf : forall A (R1 R2 : binary A),
  wf R1 -> incl R2 R1 -> wf R2.
Proof.
  introv W1 Inc. intros x.
  pattern x. apply (well_founded_ind W1). clear x.
  intros x IH. constructor. intros. apply IH. apply~ Inc.
Qed.

(** Well-foundedness modulo extensional equality *)

Lemma wf_iff : forall A (R1 R2:binary A),
  wf R1 -> (forall x y, R1 x y <-> R2 x y) -> wf R2.
Proof. introv W1 Ext. apply* incl_wf. introv H. rewrite~ Ext. Qed.

(************************************************************)
(* * Measures *)

(*-----------------------------------------------------*)
(** ** Measures as well-founded relations *)

Section Measure.
Variables (A : Type).

Definition measure (f : A -> nat) : binary A :=
  fun x1 x2 => f x1 < f x2.

Lemma measure_wf : forall f, wf (measure f).
Proof.
  intros f a. gen_eq n: (f a). gen a. pattern n.
  apply peano_induction. clear n. introv IH Eq.
  apply Acc_intro. introv H. unfolds in H.
  rewrite <- Eq in H. apply* IH.
Qed.

(* todo: measure_order *)
Lemma measure_trans : forall (f : A -> nat), trans (measure f).
Proof. intros. unfold measure, trans. intros. nat_math. Qed.

End Measure.

(* todo: should be next to measure_induction *)
Lemma measure_2_induction : forall A B (mu : A -> B -> nat) (P : A -> B -> Prop),
  (forall x1 x2, (forall y1 y2, mu y1 y2 < mu x1 x2 -> P y1 y2) -> P x1 x2) ->
  (forall x1 x2, P x1 x2).
Proof.
  introv H. intros x1 x2. gen_eq p: (x1,x2). gen x1 x2.
  induction_wf IH: (measure_wf (fun p => mu (fst p) (snd p))) p.
  introv E. destruct p. inverts E. apply H.
  introv L. apply* IH. simpl. auto.
Qed.

Hint Resolve measure_wf : wf.

(** The relation "less than" on natural numbers is well_founded. *)

Lemma lt_wf : wf lt.
Proof.
  intros x.
  induction x using peano_induction. apply~ Acc_intro.
Qed.

Hint Resolve lt_wf : wf.

(** Measures at arity 2 *)

Definition measure2 A1 A2 (f : A1 -> A2 -> nat) : binary (A1*A2) :=
  fun p1 p2 => let (x1,y1) := p1 in let (x2,y2) := p2 in f x1 y1 < f x2 y2.

Lemma measure2_wf : forall A1 A2 (f:A1->A2->nat), wf (measure2 f).
Proof.
  intros A1 A2 f [x1 x2]. apply (@measure_induction _ (uncurry2 f)). clear x1 x2.
  intros [x1 x2] H. apply Acc_intro. intros [y1 y2] Lt. apply~ H.
Qed.

Hint Resolve measure2_wf : wf.

(*-----------------------------------------------------*)
(** ** The relation "less than" on the set of
       integers greater than a fixed lower bound. *)

Require Import LibInt.

Definition downto (b : int) :=
  fun n m : int => (b <= n) /\ (n < m).

Lemma downto_def : forall b n m,
  downto b n m = (b <= n /\ n < m).
Proof. auto. Qed.

Lemma downto_intro : forall b n m,
  b <= n -> n < m -> downto b n m.
Proof. split~. Qed.

Lemma int_downto_wf : forall n, wf (downto n).
Proof.
  intros b n.
  induction_wf: (measure_wf (fun n => Zabs_nat (n-b))) n.
  apply Acc_intro. introv [H1 H2]. apply IH.
  unfolds. applys Zabs_nat_lt; math.
Qed.

Hint Resolve int_downto_wf : wf.

Hint Unfold downto.
Hint Extern 1 (downto _ _ _) => math : maths.
  (* todo:bin  apply downto_intro; math : maths. *)

(*-----------------------------------------------------*)
(** ** The relation "greater than" on the set of
       integers lower than a fixed upper bound. *)

Definition upto (b : int) :=
  fun n m : int => (n <= b) /\ (m < n).

Lemma upto_def : forall b n m,
  upto b n m = ((n <= b) /\ (m < n)).
Proof. auto. Qed.

Lemma upto_intro : forall b n m,
  n <= b -> m < n -> upto b n m.
Proof. split~. Qed.

Lemma int_upto_wf : forall n, wf (upto n).
Proof.
  intros b n.
  induction_wf: (measure_wf (fun n => Zabs_nat (b-n))) n.
  apply Acc_intro. introv [H1 H2]. apply IH.
  applys Zabs_nat_lt; math.
Qed.

Hint Resolve int_upto_wf : wf.

Hint Unfold upto.
Hint Extern 1 (upto _ _ _) => math : maths.

(* ********************************************************************** *)
(** * Empty relation *)

Lemma empty_wf : forall A, wf (@empty A).
Proof. intros_all. constructor. introv H. false. Qed.

Hint Resolve empty_wf : wf.

(* ********************************************************************** *)
(** * Inverse projections *)

Section UnprojWf.
Variables (A1 A2 A3 A4 : Type).

Lemma unproj21_wf : forall (f : binary A1),
  wf f ->
  wf (unproj21 A2 f).
Proof.
  intros f H [x1 x2]. gen x2.
  induction_wf IH: H x1. constructor. intros [y1 y2]. auto.
Qed.

Lemma unproj22_wf : forall (f : binary A2),
  wf f ->
  wf (unproj22 A1 f).
Proof.
  intros f H [x1 x2]. gen x1.
  induction_wf IH: H x2. constructor. intros [y1 y2]. auto.
Qed.

Lemma unproj31_wf : forall (f : binary A1),
  wf f ->
  wf (unproj31 A2 A3 f).
Proof.
  intros f H [[x1 x2] x3]. gen x2 x3.
  induction_wf IH: H x1. constructor. intros [[y1 y2] y3]. auto.
Qed.

Lemma unproj32_wf : forall (f : binary A2),
  wf f ->
  wf (unproj32 A1 A3 f).
Proof.
  intros f H [[x1 x2] x3]. gen x1 x3.
  induction_wf IH: H x2. constructor. intros [[y1 y2] y3]. auto.
Qed.

Lemma unproj33_wf : forall (f : binary A3),
  wf f ->
  wf (unproj33 A1 A2 f).
Proof.
  intros f H [[x1 x2] x3]. gen x1 x2.
  induction_wf IH: H x3. constructor. intros [[y1 y2] y3]. auto.
Qed.

Lemma unproj41_wf : forall (f : binary A1),
  wf f ->
  wf (unproj41 A2 A3 A4 f).
Proof.
  intros f H [[[x1 x2] x3] x4]. gen x2 x3 x4.
  induction_wf IH: H x1. constructor. intros [[[y1 y2] y3] y4]. auto.
Qed.

Lemma unproj42_wf : forall (f : binary A2),
  wf f ->
  wf (unproj42 A1 A3 A4 f).
Proof.
  intros f H [[[x1 x2] x3] x4]. gen x1 x3 x4.
  induction_wf IH: H x2. constructor. intros [[[y1 y2] y3] y4]. auto.
Qed.

Lemma unproj43_wf : forall (f : binary A3),
  wf f ->
  wf (unproj43 A1 A2 A4 f).
Proof.
  intros f H [[[x1 x2] x3] x4]. gen x1 x2 x4.
  induction_wf IH: H x3. constructor. intros [[[y1 y2] y3] y4]. auto.
Qed.

Lemma unproj44_wf : forall (f : binary A4),
  wf f ->
  wf (unproj44 A1 A2 A3 f).
Proof.
  intros f H [[[x1 x2] x3] x4]. gen x1 x2 x3.
  induction_wf IH: H x4. constructor. intros [[[y1 y2] y3] y4]. auto.
Qed.

End UnprojWf.

Hint Resolve
  unproj21_wf unproj22_wf
  unproj31_wf unproj32_wf unproj33_wf
  unproj41_wf unproj42_wf unproj43_wf unproj44_wf : wf.

(* ********************************************************************** *)
(** * Lexicographical product *)

Lemma lexico2_wf : forall {A1 A2}
 (R1:binary A1) (R2:binary A2),
  wf R1 -> wf R2 -> wf (lexico2 R1 R2).
Proof.
  introv W1 W2. intros [x1 x2]. gen x2.
  induction_wf IH1: W1 x1. intros.
  induction_wf IH2: W2 x2. constructor. intros [y1 y2] H.
  simpls. destruct H as [H1|[H1 H2]].
  apply~ IH1. rewrite H1. apply~ IH2.
Qed.

Lemma lexico3_wf : forall {A1 A2 A3}
 (R1:binary A1) (R2:binary A2) (R3:binary A3),
  wf R1 -> wf R2 -> wf R3 ->
  wf (lexico3 R1 R2 R3).
Proof.
  intros. apply~ @lexico2_wf. apply~ @lexico2_wf.
Qed.

Lemma lexico4_wf : forall {A1 A2 A3 A4}
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R1 -> wf R2 -> wf R3 -> wf R4 ->
  wf (lexico4 R1 R2 R3 R4).
Proof.
  intros. apply~ @lexico3_wf. apply~ @lexico2_wf.
Qed.

Implicit Arguments lexico2_wf [[A1] [A2] R1 R2].
Implicit Arguments lexico3_wf [[A1] [A2] [A3] R1 R2 R3].
Implicit Arguments lexico4_wf [[A1] [A2] [A3] [A4] R1 R2 R3 R4].

Hint Resolve @lexico2_wf @lexico3_wf @lexico4_wf : wf.

(* ********************************************************************** *)
(** * Symmetric product *)

Lemma prod2_wf_1 : forall (A1 A2:Type)
 (R1:binary A1) (R2:binary A2),
  wf R1 -> wf (prod2 R1 R2).
Proof.
  introv W1. intros [x1 x2].
  gen x2. induction_wf IH: W1 x1. intros.
  constructor. intros [y1 y2] [E1 E2]. apply~ IH.
Qed.

Lemma prod2_wf_2 : forall (A1 A2:Type)
 (R1:binary A1) (R2:binary A2),
  wf R2 -> wf (prod2 R1 R2).
Proof.
  introv W2. intros [x1 x2].
  gen x1. induction_wf IH: W2 x2. intros.
  constructor. intros [y1 y2] [E1 E2]. apply~ IH.
Qed.

Lemma prod3_wf_1 : forall (A1 A2 A3:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3),
  wf R1 -> wf (prod3 R1 R2 R3).
Proof. intros. apply prod2_wf_1. apply~ prod2_wf_1. Qed.

Lemma prod3_wf_2 : forall (A1 A2 A3:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3),
  wf R2 -> wf (prod3 R1 R2 R3).
Proof. intros. apply prod2_wf_1. apply~ prod2_wf_2. Qed.

Lemma prod3_wf_3 : forall (A1 A2 A3:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3),
  wf R3 -> wf (prod3 R1 R2 R3).
Proof. intros. apply~ prod2_wf_2. Qed.

Lemma prod4_wf_1 : forall (A1 A2 A3 A4:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R1 -> wf (prod4 R1 R2 R3 R4).
Proof. intros. apply prod2_wf_1. apply~ prod3_wf_1. Qed.

Lemma prod4_wf_2 : forall (A1 A2 A3 A4:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R2 -> wf (prod4 R1 R2 R3 R4).
Proof. intros. apply prod2_wf_1. apply~ prod3_wf_2. Qed.

Lemma prod4_wf_3 : forall (A1 A2 A3 A4:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R3 -> wf (prod4 R1 R2 R3 R4).
Proof. intros. apply prod2_wf_1. apply~ prod3_wf_3. Qed.

Lemma prod4_wf_4 : forall (A1 A2 A3 A4:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R4 -> wf (prod4 R1 R2 R3 R4).
Proof. intros. apply~ prod2_wf_2. Qed.

Hint Resolve
  prod2_wf_1 prod2_wf_2
  prod3_wf_1 prod3_wf_2 prod3_wf_3
  prod4_wf_1 prod4_wf_2 prod4_wf_3 prod4_wf_4 : wf.

(* todo: swapproduct? *)

(* ********************************************************************** *)
(** * Well-foundedness of a function image *)

Definition binary_map A B (f:A->B) (R:binary B) : binary A :=
  fun x y => R (f x) (f y).

Lemma binary_map_wf : forall A B (f:A->B) (R:binary B),
  wf R -> wf (binary_map f R).
Proof.
  introv W. intros x. gen_eq a: (f x). gen x.
  induction_wf: W a. introv E. constructors.
  intros y Hy. subst a. hnf in Hy. applys* IH.
Qed.

Hint Resolve binary_map_wf : wf.

(* ********************************************************************** *)
(** * Inverse image *)

Lemma inverse_image_wf : forall (A B : Type) (R : binary B) (f : A -> B),
  wf R -> wf (inverse_image R f).
Proof.
  introv W. intros x. gen_eq y: (f x). gen x.
  induction_wf IH: W y. intros u E. subst y.
  constructor. intros v I. applys~ IH (f v).
Qed.

(* todo: inverse image of relation ? *)

(* begin hide *)

(* ********************************************************************** *)
(** * Union *)

(* TODO..

Section WfUnion.
  Variable A : Type.
  Variables R1 R2 : binary A.

  Notation Union := (union A R1 R2).

  Remark strip_commut :
    commut A R1 R2 ->
    forall x y:A,
      clos_trans A R1 y x ->
      forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & clos_trans A R1 z y'.
  Proof.
    induction 2 as [x y| x y z H0 IH1 H1 IH2]; intros.
    elim H with y x z; auto with sets; intros x0 H2 H3.
    exists x0; auto with sets.

    elim IH1 with z0; auto with sets; intros.
    elim IH2 with x0; auto with sets; intros.
    exists x1; auto with sets.
    apply t_trans with x0; auto with sets.
  Qed.

  Lemma Acc_union :
    commut A R1 R2 ->
    (forall x:A, Acc R2 x -> Acc R1 x) -> forall a:A, Acc R2 a -> Acc Union a.
  Proof.
    induction 3 as [x H1 H2].
    apply Acc_intro; intros.
    elim H3; intros; auto with sets.
    cut (clos_trans A R1 y x); auto with sets.
    elimtype (Acc (clos_trans A R1) y); intros.
    apply Acc_intro; intros.
    elim H8; intros.
    apply H6; auto with sets.
    apply t_trans with x0; auto with sets.

    elim strip_commut with x x0 y0; auto with sets; intros.
    apply Acc_inv_trans with x1; auto with sets.
    unfold union in |- *.
    elim H11; auto with sets; intros.
    apply t_trans with y1; auto with sets.

    apply (Acc_clos_trans A).
    apply Acc_inv with x; auto with sets.
    apply H0.
    apply Acc_intro; auto with sets.
  Qed.

  Theorem wf_union :
    commut A R1 R2 -> well_founded R1 -> well_founded R2 -> well_founded Union.
  Proof.
    unfold well_founded in |- *.
    intros.
    apply Acc_union; auto with sets.
  Qed.

End WfUnion.

*)

(* TODO: Disjoint union, useful? *)

(* ********************************************************************** *)
(** * Transitive closure *)

(* TODO

Section Wf_Transitive_Closure.
  Variable A : Type.
  Variable R : relation A.

  Notation trans_clos := (clos_trans A R).

  Lemma incl_clos_trans : inclusion A R trans_clos.
    red in |- *; auto with sets.
  Qed.

  Lemma Acc_clos_trans : forall x:A, Acc R x -> Acc trans_clos x.
    induction 1 as [x0 _ H1].
    apply Acc_intro.
    intros y H2.
    induction H2; auto with sets.
    apply Acc_inv with y; auto with sets.
  Qed.

  Hint Resolve Acc_clos_trans.

  Lemma Acc_inv_trans : forall x y:A, trans_clos y x -> Acc R x -> Acc R y.
  Proof.
    induction 1 as [| x y]; auto with sets.
    intro; apply Acc_inv with y; assumption.
  Qed.

  Theorem wf_clos_trans : well_founded R -> well_founded trans_clos.
  Proof.
    unfold well_founded in |- *; auto with sets.
  Qed.

End Wf_Transitive_Closure.

*)

Axiom tclosure_wf : forall A (R:binary A),
  wf R -> wf (tclosure R).
(* need to copy proof from the standard library *)

(* end hide *)

(* ********************************************************************** *)
(** * Tactics *)

(** [prove_wf] is a tactic that tries and prove a goal of the
    form [wf R]. It is implemented using [auto]. *)

Tactic Notation "prove_wf" :=
  solve [ auto with wf ].

(** [unfold_wf] and [unfolds_wf] are shorthands for unfolding
    definitions related to well-foundedness. *)

Ltac unfold_wf_base :=
  unfold_unproj; unfold_uncurryp; unfold_lexico.

Ltac unfolds_wf_base :=
  unfolds_unproj; unfolds_uncurryp; unfolds_lexico.

Tactic Notation "unfold_wf" :=
  unfold_wf_base.
Tactic Notation "unfold_wf" "~" :=
  unfold_wf; auto_tilde.
Tactic Notation "unfold_wf" "*" :=
  unfold_wf; auto_star.

Tactic Notation "unfolds_wf" :=
  unfolds_wf_base.
Tactic Notation "unfolds_wf" "~" :=
  unfolds_wf; auto_tilde.
Tactic Notation "unfolds_wf" "*" :=
  unfolds_wf; auto_star.


(** * imp: a formalisation of the IMP programming language on top of KAT *)

(* We formalise the IMP language (whose programs are also known as
   "while programs"). We give a big step semantics as an inductive
   predicate, and using KAT, and we show that the two versions
   actually coincide.

   We then use the [kat] tactic to prove some simple program
   equivalences, and to derive all rules of corresponding Hoare logic
   for partial correctness. *)

From RelationAlgebra Require Import kat prop rel comparisons kat_tac.

Section s.
(** identifiers for memory locations  *)
Variable loc: Set.
(** abstract state (or memory) *)
Variable state: Set.
(** updating the state *)
Variable update: loc -> nat -> state -> state.

(** * Definition of the languague *)

(** programs *)

Inductive prog :=
| skp
| aff (x: loc) (e: state -> nat)
| seq (p q: prog)
| ite (t: dset state) (p q: prog)
| whl (t: dset state) (p: prog).

(** notations *)
Declare Scope imp_scope.
Bind Scope imp_scope with prog.
Delimit Scope imp_scope with imp.
Notation "x  <- y" := (aff x y) (at level 90): imp_scope.
Notation "p  ;; q" := (seq p%imp q%imp) (left associativity, at level 101): imp_scope.
Arguments ite _%ra _%imp _%imp.
Arguments whl _%ra _%imp.

(** * Big step semantics *)

(** corresponding functional relation *)
Notation upd x e := (frel (fun s => update x (e s) s)).

(** ** using KAT expressions in the model of relations

   the semantics can then be given by induction on the program, using
   a simple fixpoint *)

Fixpoint bstep (p: prog): hrel state state :=
  match p with
    | skp => 1
    | aff x e => upd x e
    | seq p q => bstep p ⋅ bstep q
    | ite b p q => [b] ⋅ bstep p + [!b] ⋅ bstep q
    | whl b p => ([b] ⋅ bstep p)^*  ⋅  [!b]
  end.

(** ** using an inductive predicate, as in standard textbooks *)

Inductive bstep': prog -> hrel state state :=
| s_skp: forall s, bstep' skp s s
| s_aff: forall x e s, bstep' (x <- e) s (update x (e s) s)
| s_seq: forall p q s s' s'', bstep' p s s' -> bstep' q s' s'' -> bstep' (p ;; q) s s''
| s_ite_ff: forall (b: dset state) p q s s', b s = false -> bstep' q s s' -> bstep' (ite b p q) s s'
| s_ite_tt: forall (b: dset state) p q s s', b s = true -> bstep' p s s' -> bstep' (ite b p q) s s'
| s_whl_ff: forall (b: dset state) p s, b s = false -> bstep' (whl b p) s s
| s_whl_tt: forall (b: dset state) p s s', b s = true -> bstep' (p ;; whl b p) s s' -> bstep' (whl b p) s s'.

(** ** equivalence between the two definitions *)

Lemma bstep_eq p: bstep' p ≡ bstep p.
Proof.
  apply antisym.
  - intros s s'. induction 1.
     reflexivity.
     reflexivity.
     eexists; eassumption.
     right. eexists. split. reflexivity. simpl; now rewrite H. assumption.
     left. eexists. split. reflexivity. assumption. assumption.
     exists s. apply (str_refl ([b] ⋅ bstep p)). reflexivity.
      simpl. unfold hrel_inj. simpl. now rewrite H.
     destruct IHbstep' as [t ? [t' ? ?]]. exists t'. 2: assumption.
     apply (str_cons ([b] ⋅ bstep p)). exists t. 2: assumption.
     eexists; eauto. now split.
  - induction p; unfold bstep; fold bstep.
     intros ? ? <-. constructor.
     intros ? ? ->. constructor.
     intros ? ? [? H1 H2]. econstructor. apply IHp1, H1. apply IHp2, H2.
     intros ? ? [[? [<- H] H']|[? [<- H] H']].
      apply s_ite_tt. assumption. apply IHp1, H'.
      apply s_ite_ff. now apply Bool.negb_true_iff. apply IHp2, H'.
     apply str_ind_l'.
      intros ? ? [<- H]. apply s_whl_ff. now apply Bool.negb_true_iff.
      rewrite <-dotA. intros s s'' [? [<- H] [s' H' H'']]. apply s_whl_tt. assumption.
      econstructor. apply IHp, H'. assumption.
Qed.

(** * Some program equivalences *)

(** two programs are said to be equivalent if they have the same semantics *)
Notation "p ~ q" := (bstep p ≡ bstep q) (at level 80).

(** ad-hoc simplification tactic *)
Ltac simp := unfold bstep; fold bstep.

(** ** denesting nested loops *)
Lemma two_loops b p:
  whl b (whl b p)  ~  whl b p.
Proof. simp. kat. Qed.

(** ** folding a loop *)
Lemma fold_loop b p:
  whl b (p ;; ite b p skp)  ~
  whl b p.
Proof. simp. kat. Qed.

(** ** eliminating deadcode *)
Lemma dead_code b p q r:
  (whl b p ;; ite b q r)  ~
  (whl b p ;; r).
Proof. simp. kat. Qed.

Lemma dead_code' a b p q r:
  (whl (a ⊔ b) p ;; ite b q r)  ~
  (whl (a ⊔ b) p ;; r).
Proof. simp. kat. Qed.

(** * Reasoning about assignations *)

(** (higher-order style) substitution in formulas and expressions *)
Definition subst x v (A: dset state): dset state :=
  fun s => A (update x (v s) s).
Definition esubst x v (e: state -> nat): state -> nat :=
  fun s => e (update x (v s) s).

(** is [x] fresh in the expression e *)
Definition fresh x (e: state -> nat) := forall v s, e (update x v s) = e s.

Hypothesis update_twice: forall x i j s, update x j (update x i s) = update x j s.
Hypothesis update_comm: forall x y i j s, x<>y -> update x i (update y j s) = update y j (update x i s).

(** ** stacking assignations *)

Lemma aff_stack x e f:
  (x <- e ;; x <- f)  ~
  (x <- esubst x e f).
Proof.
  simp. rewrite frel_comp.
  apply frel_weq; intro s.
  apply update_twice.
Qed.

(** ** removing duplicates *)

Lemma aff_idem x e: fresh x e -> (x <- e ;; x <- e)  ~  (x <- e).
Proof.
  intro. rewrite aff_stack.
  intros s s'. cbv. rewrite (H (e s)). tauto.
Qed.

(** ** commuting assignations *)

Lemma aff_comm x y e f: x<>y  -> fresh y e ->
  (x <- e ;; y <- f)  ~ (y <- esubst x e f ;; x <- e).
Proof.
  intros Hx Hy. simp. rewrite 2frel_comp. apply frel_weq; intro s.
  rewrite update_comm by congruence.
  now rewrite (Hy _).
Qed.

(** ** delaying choices *)

(** in the above example, we cannot exploit KAT since this is just
   about assignations. In the following example, we show how to
   perform a mixed proof: once we assert that the test [t] somehow
   commutes with the assignation [x<-e], [hkat] can make use of this
   assumption to close the goal *)

Lemma aff_ite x e t p q:
  (x <- e ;; ite t p q)
  ~
  (ite (subst x e t) (x <- e ;; p) (x <- e ;; q)).
Proof.
  simp.
  assert (H: upd x e ⋅ [t] ≡ [subst x e t] ⋅ upd x e)
   by (cbv; firstorder; subst; eauto).
  hkat.
Qed.

(** * Embedding Hoare logic for partial correctness *)

(** Hoare triples for partial correctness can be expressed really
   easily using KAT: *)
Notation Hoare A p B := ([A] ⋅ bstep p ⋅ [!B] ≦ 0).

(** ** correspondence w.r.t. the standard interpretation of Hoare triples  *)
Lemma Hoare_eq A p B:
  Hoare A p B <->
  forall s s', A s -> bstep p s s' -> B s'.
Proof.
  split.
  - intros H s s' HA Hp. case_eq (B s'). reflexivity. intro HB.
    destruct (H s s'). exists s'. exists s.
    now split. assumption. split. reflexivity. simpl. now rewrite HB.
  - intros H s s' [? [? [<- HA] Hp] [-> HB]]. simpl in HB.
    rewrite (H _ _ HA Hp) in HB. discriminate.
Qed.

(** ** deriving Hoare logic rules using the [hkat] tactic *)

(** Hoare triples are encoded as propositions of the shape [x ≦ 0] ;
   therefore, they can always be eliminated by [hkat], so that all
   rules of Hoare logic can be proved automatically (except for the
   assignation rule, of course)

   This idea come from the following paper:
   Dexter Kozen. On Hoare logic and Kleene algebra with tests.
   Trans. Computational Logic, 1(1):60-76, July 2000.

   The fact that we have an automatic tactic makes it trivial to
   formalise it. *)

Lemma weakening (A A' B B': dset state) p:
  A' ≦ A -> Hoare A p B -> B ≦ B' -> Hoare A' p B'.
Proof. hkat. Qed.

Lemma rule_skp A: Hoare A skp A.
Proof. simp. kat. Qed.

Lemma rule_seq A B C p q:
  Hoare A p B ->
  Hoare B q C ->
  Hoare A (p;;q) C.
Proof. simp. hkat. Qed.

Lemma rule_ite A B t p q:
  Hoare (A ⊓ t) p B ->
  Hoare (A ⊓ !t) q B ->
  Hoare A (ite t p q) B.
Proof. simp. hkat. Qed.

Lemma rule_whl A t p:
  Hoare (A ⊓ t) p A ->
  Hoare A (whl t p) (A ⊓ neg t).
Proof. simp. hkat. Qed.

Lemma rule_aff x v (A: dset state): Hoare (subst x v A) (x <- v) A.
Proof.
  rewrite Hoare_eq. intros s s' HA H.
  now inversion_clear H.
Qed.

Lemma wrong_rule_whl A t p:
  Hoare (A ⊓ !t) p A ->
  Hoare A (whl t p) (A ⊓ !t).
Proof. simp. Fail hkat. Abort.

Lemma rule_whl' (I A: dset state) t p:
  Hoare (I ⊓ t) p I ->
  I ⊓ !t ≦ A ->
  Hoare I (whl t p) A.
Proof. eauto 3 using weakening, rule_whl. Qed.

End s.


From Undecidability.L Require Import L.
From Undecidability.L.Datatypes Require Import Lists LNat.
From Complexity.Libs Require Export PSLCompat.
Require Import Lia.

(** * Shared Definitions for SAT and FSAT *)

Notation var := (nat) (only parsing).
Notation assgn := (list var).

Definition evalVar a v  := list_in_decb Nat.eqb a v.

Lemma evalVar_in_iff a v : evalVar a v = true <-> v el a.
Proof.
  unfold evalVar. rewrite list_in_decb_iff; [easy | symmetry; apply Nat.eqb_eq].
Qed.

Lemma evalVar_monotonic a a' v : a <<= a' -> evalVar a v = true -> evalVar a' v = true.
Proof.
  intros H1 H2. rewrite evalVar_in_iff in *. firstorder.
Qed.

Lemma evalVar_assgn_equiv a a' v : a === a' -> evalVar a v = evalVar a' v.
Proof.
  intros H. enough (evalVar a v = true <-> evalVar a' v = true).
  { destruct evalVar, evalVar; firstorder. }
  split; apply evalVar_monotonic; apply H.
Qed.


Set Implicit Arguments.
Require Import Arith.

Definition plus'(l r:nat) : nat :=
  nat_rec (fun _ => nat) r (fun _ => fun x => S x) l.

Definition pred_partial: forall (n : nat), n <> 0 ->  nat.
  intros n; case n.
  intros h; elim h; reflexivity.
  intros p h'; exact p.
Defined.

Theorem le_2_n_not_zero: forall (n : nat), 2 <= n ->  (n <> 0).
  intros n Hle; elim Hle; intros; discriminate.
Qed.

Scheme le_ind_max := Induction for le Sort Prop.

Theorem le_2_n_pred:
  forall (n : nat) (h : 2 <= n),  (pred_partial (le_2_n_not_zero h) <> 0).
  apply le_ind_max.
  intuition.
  simpl in *.
  inversion H.
  intuition.
  simpl in *.
  subst.
  inversion l.
Qed.

Require Import List.

Inductive lfactor (A:Set) : list A -> list A -> Prop :=
  lf1 : forall u:list A, lfactor nil u
| lf2 : forall (a:A) (u v:list A), lfactor u v ->
          lfactor (a :: u) (a :: v).

Fixpoint rfactor (A:Set) (u v:list A) { struct u } :
  lfactor u v -> {w : list A | v = u ++ w}.
  refine(
    match u,v with
    | nil, nil => _
    | nil, ev :: lv => _
    | eu :: lu, nil => _
    | eu :: lu, ev :: lv => _
    end);simpl in *.
  econstructor.
  reflexivity.
  econstructor.
  reflexivity.
  intros.
  econstructor.
  instantiate( 1 := nil).
  inversion H.
  intros.
  assert({w : list A | lv = lu ++ w}).
  apply rfactor.
  inversion H.
  trivial.
  destruct H0.
  subst.
  assert(eu=ev).
  inversion H.
  trivial.
  subst.
  econstructor.
  reflexivity.
Qed.

Section update_def.
  Variables (A : Set) (A_eq_dec : forall (x y : A),  ({ x = y }) + ({ x <> y })).
  Variables (B : A ->  Set) (a : A) (v : B a) (f : forall (x : A),  B x).
  Definition update (x : A) : B x :=
    match A_eq_dec a x with
    | left h => eq_rec a B v x h
    | right h' => f x
    end.
End update_def.

Require Import Eqdep.

Theorem update_eq:
 forall (A : Set) (eq_dec : forall (x y : A),  ({ x = y }) + ({ x <> y }))
        (B : A ->  Set) (a : A) (v : B a) (f : forall (x : A),  B x),
  update eq_dec B a v f a = v.
  unfold update.
  intros.
  case (eq_dec a a).
  intuition.
  rewrite <- eq_rect_eq.
  trivial.
  tauto.
Qed.

Inductive ltree (A:Set) : Set :=
  lnode : A -> list (ltree A)-> ltree A.

Section correct_ltree_ind.
  Variables
    (A : Set)(P : ltree A -> Prop)(Q : list (ltree A)-> Prop).
  Hypotheses
    (H : forall (a:A)(l:list (ltree A)), Q l -> P (@lnode A a l))
    (H0 : Q nil)
    (H1 : forall t:ltree A, P t ->
    forall l:list (ltree A), Q l -> Q (cons t l)).
  Fixpoint ltree_ind2 (t:ltree A) : P t :=
    match t as x return P x with
    | lnode a l =>
        @H
          a
          l
          (((fix l_ind (l':list (ltree A)) : Q l' :=
            match l' as x return Q x with
            | nil => H0
            | cons t1 tl => @H1 t1 (ltree_ind2 t1) tl (l_ind tl)
            end)) l)
          end.
  Fixpoint ltree_ind3 (l : list (ltree A)) : Q l.
    destruct l.
    trivial.
    apply H1.
    apply ltree_ind2.
    apply ltree_ind3.
  Defined.
End correct_ltree_ind.

Fixpoint lcount (A : Set)(t : ltree A){ struct t } : nat :=
  match t with
  | lnode n l =>
      S
      ((fix list_rec (l' : list (ltree A)) :=
        match l' with
        | nil => 0
        | l'_head :: l'_tail => (lcount l'_head) + (list_rec l'_tail)
        end) l)
  end.

Inductive ntree (A:Set) : Set :=
  nnode : A -> nforest A -> ntree A
with nforest (A:Set) : Set :=
  nnil : nforest A | ncons : ntree A -> nforest A -> nforest A.

Fixpoint ntree_to_ltree (A : Set)(t : ntree A) :=
  match t with
  | nnode n f => lnode n (nforest_to_lltree f)
  end
with nforest_to_lltree (A : Set)(n : nforest A) :=
  match n with
  | nnil => nil
  | ncons t f => (ntree_to_ltree t) :: (nforest_to_lltree f)
  end.

Fixpoint ltree_to_ntree (A : Set)(t : ltree A) :=
  match t with
  | lnode n l =>
      nnode
      n
      ((fix list_rec (l' : list (ltree A)) :=
        match l' with
        | nil => @nnil A
        | l'_head :: l'_tail => ncons (ltree_to_ntree l'_head) (list_rec l'_tail)
        end) l)
  end.

Fixpoint lltree_to_nforest (A : Set)(l : list (ltree A)) :=
  match l with
  | nil => @nnil A
  | l_head :: l_tail => ncons (ltree_to_ntree l_head) (lltree_to_nforest l_tail)
  end.

Scheme ntree_ind2 :=
  Induction for ntree Sort Prop
with nforest_ind2 :=
  Induction for nforest Sort Prop.

Goal forall A n, ltree_to_ntree (@ntree_to_ltree A n) = n.
  intros.
  einduction n using ntree_ind2.
  Focus 2.
  instantiate( 1 :=
    (fun n => (lltree_to_nforest (nforest_to_lltree n)) = n)).
  intuition.
  intuition.
  simpl.
  f_equal.
  rewrite <- IHn0 at 2.
  remember(nforest_to_lltree n0).
  generalize l.
  induction l0.
  trivial.
  simpl in *.
  f_equal.
  trivial.
  intuition.
  simpl in *.
  f_equal.
  trivial.
  trivial.
Qed.

Goal forall A n, ntree_to_ltree (@ltree_to_ntree A n) = n.
  intros.
  einduction n using ltree_ind2.
  Focus 2.
  instantiate( 1 :=
    (fun n => (nforest_to_lltree (lltree_to_nforest n)) = n)).
  intuition.
  intuition.
  simpl in *.
  f_equal.
  generalize l.
  einduction l0 using ltree_ind3.
  instantiate( 1 :=
    (fun n => (ntree_to_ltree (ltree_to_ntree n)) = n)).
  intuition.
  simpl in *.
  f_equal.
  trivial.
  trivial.
  intuition.
  simpl in *.
  f_equal.
  trivial.
  trivial.
  intuition.
  simpl in *.
  f_equal.
  trivial.
  trivial.
Qed.


(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

From Coq Require Import Omega List Relations RelationClasses.
Import ListNotations.

Local Obligation Tactic := intros.

(** A comparable type is equiped with a [compare] function, that define an order
   relation. **)
Class Comparable (A:Type) := {
  compare : A -> A -> comparison;
  compare_antisym : forall x y, CompOpp (compare x y) = compare y x;
  compare_trans :  forall x y z c,
    (compare x y) = c -> (compare y z) = c -> (compare x z) = c
}.

Theorem compare_refl {A:Type} (C: Comparable A) :
  forall x, compare x x = Eq.
Proof.
intros.
pose proof (compare_antisym x x).
destruct (compare x x); intuition; try discriminate.
Qed.

(** The corresponding order is a strict order. **)
Definition comparableLt {A:Type} (C: Comparable A) : relation A :=
  fun x y => compare x y = Lt.

Instance ComparableLtStrictOrder {A:Type} (C: Comparable A) :
  StrictOrder (comparableLt C).
Proof.
apply Build_StrictOrder.
unfold Irreflexive, Reflexive, complement, comparableLt.
intros.
pose proof H.
rewrite <- compare_antisym in H.
rewrite H0 in H.
discriminate H.
unfold Transitive, comparableLt.
intros x y z.
apply compare_trans.
Qed.

(** nat is comparable. **)
Program Instance natComparable : Comparable nat :=
  { compare := Nat.compare }.
Next Obligation.
symmetry.
destruct (Nat.compare x y)  as [] eqn:?.
rewrite Nat.compare_eq_iff in Heqc.
destruct Heqc.
rewrite Nat.compare_eq_iff.
trivial.
rewrite <- nat_compare_lt in *.
rewrite <- nat_compare_gt in *.
trivial.
rewrite <- nat_compare_lt in *.
rewrite <- nat_compare_gt in *.
trivial.
Qed.
Next Obligation.
destruct c.
rewrite Nat.compare_eq_iff in *; destruct H; assumption.
rewrite <- nat_compare_lt in *.
apply (Nat.lt_trans _ _ _ H H0).
rewrite <- nat_compare_gt in *.
apply (gt_trans _ _ _ H H0).
Qed.

(** A pair of comparable is comparable. **)
Program Instance PairComparable {A:Type} (CA:Comparable A) {B:Type} (CB:Comparable B) :
  Comparable (A*B) :=
  { compare := fun x y =>
      let (xa, xb) := x in let (ya, yb) := y in
      match compare xa ya return comparison with
        | Eq => compare xb yb
        | x => x
      end }.
Next Obligation.
destruct x, y.
rewrite <- (compare_antisym a a0).
rewrite <- (compare_antisym b b0).
destruct (compare a a0); intuition.
Qed.
Next Obligation.
destruct x, y, z.
destruct (compare a a0) as [] eqn:?, (compare a0 a1) as [] eqn:?;
try (rewrite <- H0 in H; discriminate);
try (destruct (compare a a1) as [] eqn:?;
  try (rewrite <- compare_antisym in Heqc0;
         rewrite CompOpp_iff in Heqc0;
         rewrite (compare_trans _ _ _  _ Heqc0 Heqc2) in Heqc1;
         discriminate);
  try (rewrite <- compare_antisym in Heqc1;
         rewrite CompOpp_iff in Heqc1;
         rewrite (compare_trans _ _ _ _ Heqc2 Heqc1) in Heqc0;
         discriminate);
  assumption);
rewrite (compare_trans _ _ _ _ Heqc0 Heqc1);
try assumption.
apply (compare_trans _ _ _ _ H H0).
Qed.

(** Special case of comparable, where equality is Leibniz equality. **)
Class ComparableLeibnizEq {A:Type} (C: Comparable A) :=
  compare_eq : forall x y, compare x y = Eq -> x = y.

(** Boolean equality for a [Comparable]. **)
Definition compare_eqb {A:Type} {C:Comparable A} (x y:A) :=
  match compare x y with
    | Eq => true
    | _ => false
  end.

Theorem compare_eqb_iff {A:Type} {C:Comparable A} {U:ComparableLeibnizEq C} :
  forall x y, compare_eqb x y = true <-> x = y.
Proof.
unfold compare_eqb.
intuition.
apply compare_eq.
destruct (compare x y); intuition; discriminate.
destruct H.
rewrite compare_refl; intuition.
Qed.

Instance NComparableLeibnizEq : ComparableLeibnizEq natComparable := Nat.compare_eq.

(** A pair of ComparableLeibnizEq is ComparableLeibnizEq **)
Instance PairComparableLeibnizEq
  {A:Type} {CA:Comparable A} (UA:ComparableLeibnizEq CA)
  {B:Type} {CB:Comparable B} (UB:ComparableLeibnizEq CB) :
    ComparableLeibnizEq (PairComparable CA CB).
Proof.
intros x y; destruct x, y; simpl.
pose proof (compare_eq a a0); pose proof (compare_eq b b0).
destruct (compare a a0); try discriminate.
intuition.
destruct H2, H0.
reflexivity.
Qed.

(** An [Finite] type is a type with the list of all elements. **)
Class Finite (A:Type) := {
  all_list : list A;
  all_list_forall : forall x:A, In x all_list
}.

(** An alphabet is both [ComparableLeibnizEq] and [Finite]. **)
Class Alphabet (A:Type) := {
  AlphabetComparable :> Comparable A;
  AlphabetComparableLeibnizEq :> ComparableLeibnizEq AlphabetComparable;
  AlphabetFinite :> Finite A
}.

(** The [Numbered] class provides a conveniant way to build [Alphabet] instances,
   with a good computationnal complexity. It is mainly a injection from it to
   [positive] **)
Class Numbered (A:Type) := {
  inj : A -> positive;
  surj : positive -> A;
  surj_inj_compat : forall x, surj (inj x) = x;
  inj_bound : positive;
  inj_bound_spec : forall x, (inj x < Pos.succ inj_bound)%positive
}.

Program Instance NumberedAlphabet {A:Type} (N:Numbered A) : Alphabet A :=
  { AlphabetComparable := {| compare := fun x y => Pos.compare (inj x) (inj y) |};
    AlphabetFinite :=
      {| all_list := fst (Pos.iter
                           (fun '(l, p) => (surj p::l, Pos.succ p))
                           ([], 1%positive) inj_bound) |} }.
Next Obligation. simpl. now rewrite <- Pos.compare_antisym. Qed.
Next Obligation.
  match goal with c : comparison |- _ => destruct c end.
  - rewrite Pos.compare_eq_iff in *. congruence.
  - rewrite Pos.compare_lt_iff in *. eauto using Pos.lt_trans.
  - rewrite Pos.compare_gt_iff in *. eauto using Pos.lt_trans.
Qed.
Next Obligation.
  intros x y. unfold compare. intros Hxy.
  assert (Hxy' : inj x = inj y).
  (* We do not use [Pos.compare_eq_iff] directly to make sure the
     proof is executable. *)
  { destruct (Pos.eq_dec (inj x) (inj y)) as [|[]]; [now auto|].
    now apply Pos.compare_eq_iff. }
  (* Using rewrite here leads to non-executable proofs. *)
  transitivity (surj (inj x)).
  { apply eq_sym, surj_inj_compat. }
  transitivity (surj (inj y)); cycle 1.
  { apply surj_inj_compat. }
  apply f_equal, Hxy'.
Defined.
Next Obligation.
  rewrite <-(surj_inj_compat x).
  generalize (inj_bound_spec x). generalize (inj x). clear x. intros x.
  match goal with |- ?Hx -> In ?s (fst ?p) =>
    assert ((Hx -> In s (fst p)) /\ snd p = Pos.succ inj_bound); [|now intuition] end.
  rewrite Pos.lt_succ_r.
  induction inj_bound as [|y [IH1 IH2]] using Pos.peano_ind;
    (split; [intros Hx|]); simpl.
  - rewrite (Pos.le_antisym _ _ Hx); auto using Pos.le_1_l.
  - auto.
  - rewrite Pos.iter_succ. destruct Pos.iter; simpl in *. subst.
    rewrite Pos.le_lteq in Hx. destruct Hx as [?%Pos.lt_succ_r| ->]; now auto.
  - rewrite Pos.iter_succ. destruct Pos.iter. simpl in IH2. subst. reflexivity.
Qed.

(** Definitions of [FSet]/[FMap] from [Comparable] **)
Require Import OrderedTypeAlt.
Require FSetAVL.
Require FMapAVL.
Import OrderedType.

Module Type ComparableM.
  Parameter t : Type.
  Declare Instance tComparable : Comparable t.
End ComparableM.

Module OrderedTypeAlt_from_ComparableM (C:ComparableM) <: OrderedTypeAlt.
  Definition t := C.t.
  Definition compare : t -> t -> comparison := compare.

  Infix "?=" := compare (at level 70, no associativity).

  Lemma compare_sym x y : (y?=x) = CompOpp (x?=y).
  Proof. exact (Logic.eq_sym (compare_antisym x y)). Qed.
  Lemma compare_trans c x y z :
    (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
  Proof.
  apply compare_trans.
  Qed.
End OrderedTypeAlt_from_ComparableM.

Module OrderedType_from_ComparableM (C:ComparableM) <: OrderedType.
  Module Alt := OrderedTypeAlt_from_ComparableM C.
  Include (OrderedType_from_Alt Alt).
End OrderedType_from_ComparableM.


Class Monad (m : Type -> Type): Type :=
{
  (* the two monadic operations *)
  return_: forall A, A -> m A;
  bind: forall A, m A -> forall B, (A -> m B) -> m B;

  (* equivalence relation -- for most Monads this is equality, for some
  it is going to be a slightly weaker relation (like point-wise
  functional equality) *)
  equiv : forall A (x y : m A), Prop;
  equiv_refl : forall A x, equiv A x x;
  equiv_sym : forall A x y, equiv A x y -> equiv A y x;
  equiv_trans : forall A x y z, equiv A x y -> equiv A y z -> equiv A x z;
  (* we could make a statement that equivalence is equality under functional
  extensionality:
  equiv_eq :
    (forall A (B : A -> Type) (f g : forall a, B a), (forall a, f a = g a) -> f = g) ->
    forall A x y, equiv A x y -> x = y; *)

  (* properties under equivalence relation *)
  right_unit: forall A (a : m A), equiv _ a (bind A a A (return_ A));
  left_unit: forall A (a : A) B (f: A -> m B),
             equiv _ (f a) (bind A (return_ A a) B f);
  associativity: forall A (ma : m A) B f C (g : B -> m C),
                 equiv _ (bind A ma C (fun x => bind B (f x) C g)) (bind B (bind A ma B f) C g)
}.

Notation "a >>= f" := (bind _ a _ f) (at level 50, left associativity).
Notation "a >> f" := (a >>= fun _ => f) (at level 50, left associativity).
Notation "'do' a <-- e ; c" := (e >>= (fun a => c)) (at level 60, right associativity).
Notation "'pass'" := (fun t => (tt, t)).

#[refine] Instance Maybe : Monad option :=
{|
  return_ := @Some;
  bind := fun A m B f => match m with None => None | Some a => f a end ;
  equiv := fun A x y => x = y
|}.
  (* equiv_refl *) auto.
  (* equiv_sym *) auto.
  (* equiv_trans *) intros ; congruence.
  (* unit_left *) intros A a ; case a ; split.
  (* unit_right *) split.
  (* associativity *) intros A m B f C g ; case m ; split.
Defined.

Require Import List.

Definition foo (x y z : list nat) (i : nat) : option nat :=
  do xi <-- nth_error x i ;
  do yi <-- nth_error y i ;
  do zi <-- nth_error z i ;
  return_ _ (xi + yi + zi).

Require Import Coq.extraction.ExtrOcamlString.
Require Import Coq.extraction.ExtrOcamlBasic.
Require Import Coq.extraction.ExtrOcamlNatInt.

Recursive Extraction foo.

Example q : foo (1 :: 2 :: nil) (2 :: 0 :: nil) (3 :: 4 :: nil) 1 = Some 6 := eq_refl.