Require Import Algebra.Functor Algebra.Applicative Algebra.SetoidCat Algebra.SetoidCat.ListUtils Algebra.SetoidCat.PairUtils Algebra.SetoidCat.MaybeUtils Algebra.SetoidUtils Algebra.Monad Algebra.SetoidCat.NatUtils Algebra.SetoidCat.BoolUtils Algebra.Monoid.PropUtils Tactics Utils Algebra.Pointed FoldableFunctor Monoid.

Require Import SetoidClass List Coq.Classes.RelationClasses Coq.Arith.PeanoNat Coq.Arith.Compare_dec Coq.Arith.Lt Coq.Arith.Le Basics.

Import ListNotations.

Instance length_Proper A (AS : Setoid A) : Proper (equiv ==> equiv) (@length A).
Proof.
  autounfold. intros. generalize H. clear H. apply list_ind_2 with (l1:=x) (l2:=y).
  reflexivity.
  intros. inversion H0.
  intros. inversion H0.
  intros. simpl. rewrite H. auto. inversion H0. auto.
Qed.

Instance nth_error_Proper A (AS : Setoid A) : Proper (equiv ==> equiv ==> equiv) (@nth_error A).
Proof.
  autounfold. intros. generalize H x0 y0 H0. clear H x0 y0 H0. apply list_ind_2 with (l1:=x) (l2:=y).
  intros. rewritesr.
  intros. inversion H0.
  intros. inversion H0.
  intros. inversion H0. simpl. simpl in H1.  rewrite H1. destruct y0. simpl. auto.
  simpl. apply H. auto. reflexivity.
Qed.

Fixpoint listS_update {f fS func} {app : @Applicative f fS func} {A} {AS : Setoid A} (n:nat) (l:list A)  (t:AS ~>  fS _ AS) {struct n} :  f (list A) _ :=
  match n, l with
    | 0,   old_v::rest => consS <$> t @ old_v <*> pure @ rest
    | S n, v'::rest    => consS <$> pure @ v' <*> listS_update n rest  t
    | _,   nil         => pure @ nil
  end.

Instance listS_update_Proper {f fS func} {app : @Applicative f fS func} A (AS : Setoid A): Proper (equiv ==> equiv ==> equiv ==> equiv) (listS_update).
Proof.
  autounfold. intros. rewrite H.  clear x H. generalize y H0. clear H0. apply list_ind_2 with (l1:=x0) (l2:=y0).
  intros. induction y2.
  simpl. evalproper.
  simpl. evalproper.
  intros. inversion H0.
  intros. inversion H0.
  intros. inversion H0. induction y2.
  simpl. evalproper. evalproper. rewritesr. evalproper. evalproper. arrequiv. auto.
  simpl. evalproper. evalproper. evalproper. evalproper. evalproper. evalproper. arrequiv. auto.
Qed.

Definition list_updateS {f fS func} {app : @Applicative f fS func} {A} {AS : Setoid A} := injF3 (@listS_update f fS func app A AS) _.

Fixpoint list_update' {A} {AS : Setoid A} (n:nat) (l:list A)  (a:A ) {struct n} :  list A :=
  match n, l with
    | 0,   old_v::rest => a :: rest
    | S n, v'::rest    => v' :: list_update' n rest  a
    | _,   nil         => nil
  end.

Instance list_update'_Proper A (AS : Setoid A): Proper (equiv ==> equiv ==> equiv ==> equiv) (list_update').
Proof.
  autounfold. intros. rewrite H.  clear x H. generalize y H0. clear H0. apply list_ind_2 with (l1:=x0) (l2:=y0).
  intros. induction y2.
  simpl.  reflexivity.
  simpl. reflexivity.
  intros. inversion H0.
  intros. inversion H0.
  intros. inversion H0. induction y2.
  simpl.  constructor.  auto. auto.
  simpl. constructor. auto. apply H. auto.
Qed.

Definition list_updateS' {A} {AS : Setoid A} := injF3 (@list_update' A AS) _.

Fixpoint list_zipWith {A : Type} {AS : Setoid A} {B : Type} {BS : Setoid B}{C : Type} {CS : Setoid C}(f : AS ~> BS ~~> CS) (l1 : list A) (l2 : list B)  :=
  match l1 , l2 with
    | nil , _ => nil
    | _, nil => nil
    | a1 :: as1 , a2 :: as2 => (f @ a1 @ a2) :: list_zipWith f as1 as2
  end
.

Instance list_zipWith_Proper {A : Type} {AS : Setoid A} {B : Type} {BS : Setoid B}{C : Type} {CS : Setoid C} : Proper (equiv ==> equiv ==> equiv ==> equiv) (@list_zipWith A _ B _ C _).
Proof.
  autounfold. intros. generalize H0 x1 y1 H1. clear H0 x1 y1 H1. apply list_ind_2 with (l1:=x0) (l2:=y0).
  intros. simpl. auto.
  intros. inversion H1.
  intros. inversion H1.
  intros. inversion H1. simpl. matchequiv.
  inversion H9.   constructor. auto. auto.
rewritesr.
  apply H0. auto. auto.
Qed.

Definition list_zipWithS {A : Type} {AS : Setoid A} {B : Type} {BS : Setoid B}{C : Type} {CS : Setoid C} := injF3 (@list_zipWith A _ B _ C _) _.

Fixpoint list_zipWith' {A : Type} {AS : Setoid A} {B : Type} {BS : Setoid B} (f : AS ~> BS ~~> AS) (l1 :list A) (l2 : list B)  :=
  match l1 , l2 with
    | nil , _ => nil
    | _, nil => l1
    | a1 :: as1 , a2 :: as2 => (f @ a1 @ a2) :: list_zipWith' f as1 as2
  end
.

Instance list_zipWith'_Proper {A : Type} {AS : Setoid A}{B : Type} {BS : Setoid B} : Proper (equiv ==> equiv ==> equiv ==> equiv) (@list_zipWith' A _ B _).
Proof.
  autounfold. intros. generalize H0 x1 y1 H1. clear H0 x1 y1 H1. apply list_ind_2 with (l1:=x0) (l2:=y0).
  intros. simpl. auto.
  intros. inversion H1.
  intros. inversion H1.
  intros. inversion H1. simpl. matchequiv.
  constructor. auto. auto.
  inversion H9. constructor. rewritesr.
  apply H0. auto. auto.
Qed.

Definition list_zipWithS' {A : Type} {AS : Setoid A} {B : Type} {BS : Setoid B} := injF3 (@list_zipWith' A _ B _) _.

Definition nth_errorS {A : Type} {AS : Setoid A} : listS AS ~> natS ~~> maybeS AS := injF2 (@nth_error A) _.

Definition nth_errorS' {A : Type} {AS : Setoid A} := flipS @ (@nth_errorS A AS).

Fixpoint list_maybe_filter {A : Type} {AS : Setoid A} (p : AS ~> boolS) (l : list (maybe A)) : list A :=
    match l with
      | nil => nil
      | None :: l' => list_maybe_filter p l'
      | Some a :: l' => if p @ a then a :: list_maybe_filter p l' else list_maybe_filter p l'
    end.

Instance list_maybe_filter_Proper A (AS : Setoid A) : Proper (equiv ==> equiv ==> equiv) (@list_maybe_filter A AS).
  Proof.
    autounfold. intros. generalize H0. clear H0. apply list_ind_2 with (l1:=x0) (l2:=y0).
    intros. reflexivity.
    intros. inversion H1.
    intros. inversion H1.
    intros. inversion H1. simpl. matchequiv. simpl in H8. rewrites. destruct (y @ a0). constructor. auto. apply H0.  auto. apply H0. auto. apply H0. auto.
  Qed.

Fixpoint list_maybe_filter_index {A : Type} {AS : Setoid A} n (p : AS ~> boolS) (l : list (maybe A)) : list nat :=
    match l with
      | nil => nil
      | None :: l' => list_maybe_filter_index (S n) p l'
      | Some a :: l' => if p @ a then n :: list_maybe_filter_index (S n) p l' else list_maybe_filter_index (S n) p l'
    end.

Instance list_maybe_filter_index_Proper A (AS : Setoid A) : Proper (equiv ==> equiv ==> equiv ==> equiv) (@list_maybe_filter_index A AS).
Proof.
    autounfold. intros. generalize H1 x y H . clear H x y H1. apply list_ind_2 with (l1:=x1) (l2:=y1).
    intros. reflexivity.
    intros. inversion H1.
    intros. inversion H1.
    intros. inversion H1. simpl. matchequiv. simpl in H9. rewrite H0, H9. destruct (y0 @ a0). constructor. auto. apply H.  auto. rewritesr. apply H. auto. rewritesr. apply H. auto. rewritesr.
Qed.

Fixpoint list_maybe_filter_index' {A : Type} {AS : Setoid A} n (p : AS ~> boolS) (l : list (maybe A)) : list (nat * A) :=
    match l with
      | nil => nil
      | None :: l' => list_maybe_filter_index' (S n) p l'
      | Some a :: l' => if p @ a then (n,a) :: list_maybe_filter_index' (S n) p l' else list_maybe_filter_index' (S n) p l'
    end.

Instance list_maybe_filter_index'_Proper A (AS : Setoid A) : Proper (equiv ==> equiv ==> equiv ==> equiv) (@list_maybe_filter_index' A AS).
Proof.
    autounfold. intros. generalize H1 x y H . clear H x y H1. apply list_ind_2 with (l1:=x1) (l2:=y1).
    intros. reflexivity.
    intros. inversion H1.
    intros. inversion H1.
    intros. inversion H1. simpl. matchequiv. simpl in H9. rewrite H0, H9. destruct (y0 @ a0). constructor. auto. apply H.  auto. rewritesr. apply H. auto. rewritesr. apply H. auto. rewritesr.
Qed.

Fixpoint duplicate {A} (n : nat) (a : A) : list A :=
  match n with
    | 0 => nil
    | S n => a :: duplicate n a
  end.

Lemma list_zipWith'_cons : forall {A : Type} {AS : Setoid A}{B : Type} {BS : Setoid B}(a : A) (la : list A) (b: B) (lb: list B)(f : AS ~> BS ~~> AS), list_zipWith' f (a::la)(b::lb) = (f @ a @ b) :: list_zipWith' f la lb.

Proof.
  intros. reflexivity.
Qed.

Lemma list_update_list_update: forall
  (A : Type)
  (AS : Setoid A)
  n
  a c
  (l : list A),  (list_update' n (list_update' n l a) c )  == list_update' n l c .
Proof.
  intros.  simpl. apply nat_list_ind_2 with (l1:=n) (l2:=l).
    - simpl. reflexivity.
    - intros. simpl in *. reflexivity.
    - intros. simpl in *. reflexivity.
    - intros. simpl in *. constructor ; [reflexivity | auto].

Qed.

Lemma list_update_list_nth: forall
  (A : Type)
  (AS : Setoid A)
  n a
  (l : list A),
                              nth_error l n == Some a ->
                              (list_update' n l a)  == l.
Proof.
  intros. generalize H. clear H.  apply nat_list_ind_2 with (l1:=n) (l2:=l).
  - simpl. reflexivity.
  - intros.  simpl. constructor. simpl in H0.  symmetry. auto. reflexivity.
  - intros. simpl in *. reflexivity.
  - intros. simpl in *. constructor. reflexivity. auto.
Qed.

Lemma list_nth_list_update: forall
  (A : Type)
  (AS : Setoid A)
  n a a'
  (l : list A),
                nth_error l n = Some a'
               ->
                              nth_error (list_update' n l a) n = Some a.
Proof.
  intros. generalize H. clear H.  apply nat_list_ind_2 with (l1:=n) (l2:=l).
  - simpl. intros. inversion H.
  - intros.  simpl.  reflexivity.
  - intros. simpl in *. inversion H0.
  - intros. simpl in *. apply H. auto.
Qed.

Lemma list_nth_list_update_diff_index: forall
  (A : Type)
  (AS : Setoid A)
  n n' a
  (l : list A),
  n <> n' ->nth_error (list_update' n l a) n' = nth_error l n'.
Proof.
  intros.  generalize H a. clear H. apply nat_list_ind_4 with (l1:=n) (l2:=n')(l3:=l).
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. destruct H0. auto.
  - intros. destruct H0. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - exact [].
Qed.

(* infinite list with finite nonrepeating prefix and an infinitely repeating element *)

Inductive lista A : Type := listaCons : list A -> @lista A.

Fixpoint list_all {A} {AS : Setoid A} {AP : Pointed A} (l : list A) :=
  match l with
    | nil => True
    | a' :: l' => a' == point /\ list_all l'
  end.

Fixpoint lista_equiv0 {A} {AS : Setoid A} {AP : Pointed A} (l1 l2 : list A) :=
  match l1, l2 with
    | nil, l2' => list_all l2'
    | a1' :: l1', nil =>
      a1' == point /\ lista_equiv0 l1' nil
    | a1' :: l1', a2' :: l2' =>
      a1' == a2' /\ lista_equiv0 l1' l2'
  end
.

Instance lista_equiv0_Reflexive A AS AP : Reflexive (@lista_equiv0 A AS AP).
Proof.
  autounfold. intro. induction x.
  reflexivity.
  split. reflexivity. auto.
Qed.

Definition lista_equiv {A} {AS : Setoid A} {AP : Pointed A} (l1 l2 : lista A) :=
  match l1, l2 with
    | listaCons _  ll1, listaCons _  ll2 => lista_equiv0  ll1 ll2
  end.

Instance lista_equiv_Equivalence {A} {AS : Setoid A} {AP : Pointed A} : Equivalence (@lista_equiv A AS AP).
Proof.
  split.
  autounfold. intros. destruct x. simpl. induction l.
  simpl. auto.
  simpl. split. reflexivity. auto.
  autounfold. intros. destruct x,y. simpl in *. generalize H. clear H. apply list_ind_2 with (l1:=l) (l2:=l0).
  intros.   simpl.  auto.
  intros.  simpl. simpl in H0. tauto.
  intros.  simpl. simpl in H0, H. tauto.
  intros. simpl. simpl in H0. split. symmetry. tauto. tauto.
  autounfold. intros. destruct x,y,z. simpl in *.  generalize H H0. clear H H0. apply list_ind_3 with (l1:=l) (l2:=l0) (l3:=l1).
  intros. simpl in *. auto.
  intros. auto.
  intros. reflexivity.
  intros. destruct H0, H1. split.  transitivity a. symmetry. auto. auto. apply H. auto. auto.
  intros. auto.
  intros. destruct H0, H1. split. transitivity point. auto. symmetry. auto. apply H. auto. auto.
  intros. destruct H0, H1. split. transitivity c. auto. auto. apply H. auto. auto.
  intros. destruct H0, H1. split. transitivity c. auto. auto. apply H. auto. auto.
Qed.

Instance listaS {A} (AS : Setoid A){AP : Pointed A} : Setoid (lista A) :=
  {
    equiv := lista_equiv
  }.

Fixpoint lista_update0 {A} {AS : Setoid A} {AP : Pointed A} (n:nat) (l:list A)  (a:A ) {struct n} :  list A :=
  match n, l with
    | 0, [] => [a]
    | 0, a'::l' => a ::l'
    | S n', [] => point  :: lista_update0 n'  [] a
    | S n', a'::l' => a':: lista_update0 n'  l' a
  end.

Instance lista_update0_Proper A (AS : Setoid A) (AP : Pointed A): Proper (equiv ==> equiv ==> equiv ==> equiv) (@lista_update0 A AS AP).
Proof.
  autounfold. intros. rewrite H.  clear x H. generalize y H0. clear y H0. apply list_ind_2 with (l1:=x0) (l2:=y0).
  intros. induction y.
  simpl.  constructor. auto. auto.
  simpl.  constructor. reflexivity. auto.
  intros.  inversion H0.
  intros. inversion H0.
  intros. inversion H0. induction y.
  simpl.  constructor.  auto. auto.
  simpl. constructor. auto. apply H. auto.
Qed.

Definition lista_update {A} {AS : Setoid A} {AP : Pointed A} (n:nat) (l:lista A)  (a:A )  :  lista A :=
  match l with
    | listaCons _  l => listaCons _  (lista_update0 n  l a)
  end.

Hint Unfold lista_update.

Instance lista_update_Proper A (AS : Setoid A) (AP : Pointed A): Proper (equiv ==> equiv ==> equiv ==> equiv) (@lista_update A AS AP).
Proof.
  autounfold. intros. destruct x0, y0.  rewrite H. clear x H. generalize y H0. clear y H0. apply list_ind_2 with (l1:=l) (l2:=l0).
  intros. induction y.
  simpl in *.   split. auto. auto.
  simpl in *.  split. reflexivity. auto.
  intros. destruct y.
  simpl in *. split. auto.  tauto.
  simpl. simpl in H0.  split.   symmetry. tauto. apply H.  simpl. tauto.
  intros. destruct y.
  simpl in *. split. auto.  tauto.
  simpl. simpl in H0. split. tauto. simpl in *. apply H. tauto.
  intros. destruct y.
  simpl in *. split. auto.  tauto.
  simpl in *. split. tauto. apply H. tauto.
Qed.

Definition lista_updateS {A} {AS : Setoid A} {AP : Pointed A} := injF3 (@lista_update A AS AP) _.

Instance listaCons_Proper A (AS : Setoid A) (AP : Pointed A): Proper (equiv ==> equiv) (@listaCons A).
Proof.
  autounfold. intros. simpl. generalize H. clear H. apply list_ind_2 with (l1:=x ) (l2:=y ).
  simpl. auto.
  intros. inversion H0.
  intros. inversion H0.
  intros. inversion H0. simpl. tauto.
Qed.

Definition listaConsS {A} {AS : Setoid A} {AP :Pointed A}:= injF  (@listaCons A) _.

Fixpoint lista_truncate0 {A} {AS : Setoid A} {AP : Pointed A} n   (l : list A) :=
  match n, l with
    | 0, _ => []
    | S n', [] => []
    | S n', a' :: l' => a' :: lista_truncate0 n' l'
  end
.

Definition lista_truncate {A} {AS : Setoid A} {AP : Pointed A} n (la : lista A) :=
  match la with
    | listaCons _  l => listaCons _  (lista_truncate0 n l)
  end
.

Instance lista_truncate_Proper A (AS : Setoid A) (AP : Pointed A) : Proper (equiv ==> equiv ==> equiv) (@lista_truncate A AS AP).
Proof.
  autounfold. intros. rewrite H. clear x H. destruct x0, y0. generalize y H0. clear y H0. apply list_ind_2 with (l1:=l) (l2:=l0).
  intros. simpl in H0. induction y.
  simpl. tauto.
  simpl. tauto.
  intros. destruct y.
  simpl in *.  auto.
  simpl in *. split. tauto.  specialize (H y). destruct y. simpl. auto.   apply H. tauto.
  intros. destruct y.
  simpl in *. auto.
  simpl in *. split. tauto.  specialize (H y). destruct y. simpl. auto . apply H. tauto.
  intros. destruct y.
  simpl in *. auto.
  simpl in *. split. tauto. apply H. tauto.
Qed.

Definition lista_truncateS {A} {AS : Setoid A} {AP : Pointed A} := injF2 (@lista_truncate A AS AP) _.

Lemma lista_truncate_lista_update  :
  forall {A} {AS : Setoid A}{AP :Pointed A} n (a0:A )(n0:nat) (l1 l2:lista A),
    lista_truncate n  l1 == lista_truncate n  l2 ->
    lista_truncate n  (lista_updateS @ n0 @ l1 @ a0) == lista_truncate n  (lista_updateS @ n0 @ l2 @ a0).
Proof.
  destruct l1, l2. generalize n n0. clear n n0. apply list_ind_2 with (l1:=l) (l2:=l0).
  intros. reflexivity.
  intros. destruct n.
  simpl. auto.
  destruct H0. destruct n0.
  simpl. split. reflexivity.  destruct n. simpl. auto. simpl.  destruct b. auto. auto.
  simpl. split. symmetry. auto. apply H. simpl. destruct n.  simpl. auto. destruct b. auto. auto.
  intros. destruct n.
  simpl. auto.
  destruct H0. destruct n0.
  simpl.  split. reflexivity.  destruct n. simpl. auto. simpl.  destruct b. auto. auto.
  simpl. split. auto. apply H. destruct n.  simpl. auto. destruct b. reflexivity.
  simpl. destruct H1.  auto .
  intros. destruct n.
  simpl. auto.
  destruct H0. destruct n0.
  simpl. split. reflexivity. auto.
  simpl. split. auto. apply H. auto.
Qed.

Fixpoint lista_zipWith0_right {A : Type} {AS : Setoid A} {AP : Pointed A} {B : Type} {BS : Setoid B} {BP : Pointed B} (f : AS ~> BS ~~> AS) {pointed: PointedFunction2 f} (lb : list B) :=
  match lb with
    | [] => []
    | b' :: lb' => (f @ point @ b') :: lista_zipWith0_right f lb'
  end
.

Fixpoint lista_zipWith0 {A : Type} {AS : Setoid A} {AP : Pointed A} {B : Type} {BS : Setoid B} {BP : Pointed B} (f : AS ~> BS ~~> AS) {pointed : PointedFunction2 f} (la : list A)  (lb : list B) :=
  match la, lb with
    | [] , _ => lista_zipWith0_right f lb
    | a' :: la', [] => (f @ a' @ point) :: lista_zipWith0 f la' []
    | a' :: la', b' :: lb' => (f @ a' @ b') :: lista_zipWith0 f la' lb'
  end
.
Definition lista_zipWith {A : Type} {AS : Setoid A} {AP : Pointed A} {B : Type} {BS : Setoid B} {BP : Pointed B} (f : AS ~> BS ~~> AS) {pointed : PointedFunction2 f} (la : lista A) (lb : lista B) :=
  match la, lb with
    | listaCons _ la' , listaCons _ lb' => listaCons _ (lista_zipWith0 f  la' lb')
  end
.

Instance lista_zipWith_Proper {A : Type} {AS : Setoid A} {AP :Pointed A} {B : Type} {BS : Setoid B}{BP : Pointed B}  (f : AS ~> BS ~~> AS) {pointed : PointedFunction2 f}  : Proper ( equiv ==> equiv ==> equiv) (@lista_zipWith A _ _ B _ _ f pointed).
Proof.
  autounfold. intros. destruct x,y,x0,y0. generalize  H  H0. clear H  H0. apply list_ind_4' with (l1:=l) (l2:=l0) (l3:=l1) (l4:=l2).

  - auto.
  - intros. simpl in *.  destruct H1. split.
    + rewrite H1.  rewrite pointed2. reflexivity.
    + auto.
  - intros. simpl in *.  destruct H1. split.
    + rewrite H1.  rewrite pointed2. reflexivity.
    + auto.
  - intros. simpl in *. destruct H1. split.
    + rewrite H1.  reflexivity.
    + auto.
  - intros. simpl in *. destruct H0. split.
    + rewrite H0.  rewrite pointed2. reflexivity.
    + auto.
  - intros. simpl in *. destruct H0, H1. split.
    + rewrite H0, H1.  rewrite pointed2. reflexivity.
    + auto.
  - intros. simpl in *. destruct H0, H1. split.
    + rewrite H0, H1.  reflexivity.
    + auto.
  - intros. simpl in *. destruct H0, H1. split.
    + rewrite H0, H1.  reflexivity.
    + auto.
  - intros. simpl in *. destruct H0. split.
    + rewrite H0.  rewrite pointed2. reflexivity.
    + auto.
  - intros. simpl in *.  destruct H0, H1. split.
    + rewrite H0, H1.  reflexivity.
    + auto.
  - intros. simpl in *.  destruct H0, H1. split.
    + rewrite H0, H1.  rewrite pointed2. reflexivity.
    + auto.
  - intros. simpl in *. destruct H0, H1. split.
    + rewrite H0, H1.  reflexivity.
    + auto.
  - intros. simpl in *. destruct H0. split.
    + rewrite H0.  reflexivity.
    + auto.
  - intros. simpl in *. destruct H0, H1. split.
    + rewrite H0, H1.  reflexivity.
    + auto.
  - intros. simpl in *. destruct H0, H1. split.
    + rewrite H0, H1.  reflexivity.
    + auto.
  - intros. simpl in *. destruct H0, H1. split.
    + rewrite H0, H1.  reflexivity.
    + auto.
Qed.

Definition lista_zipWithS {A : Type} {AS : Setoid A} {AP : Pointed A} {B : Type} {BS : Setoid B} {BP : Pointed B} f {poi} := injF2 (@lista_zipWith A _ _ B _ _ f poi) _.

Definition lista_map  {A : Type} {AS : Setoid A} {AP : Pointed A}{B : Type} {BS : Setoid B} {BP : Pointed B}(f : AS ~> BS) (poi : PointedFunction f) (la : lista A) :=
  match la with
    | listaCons _ la' => listaCons _ (mapS @ f @ la')
  end
.

Instance lista_map_Proper {A : Type} {AS : Setoid A} AP {B : Type} {BS : Setoid B} BP f poi : Proper (equiv ==> equiv) (@lista_map A _ AP B _ BP f poi) .
Proof.
  autounfold. intros. destruct x,y. unfold lista_map.   generalize H . clear H . apply list_ind_2 with (l1:=l) (l2:=l0).
  - intros. destruct H. rewritesr.
  - intros. destruct H0. split. rewrite H0. apply pointed.  simpl in H. auto.
  - intros. destruct H0. split. rewrite H0. apply pointed. simpl in H. auto.
  - intros. destruct H0. split. rewritesr. simpl in H. auto.
Qed.

Definition lista_mapS  {A : Type} {AS : Setoid A}{AP}{B : Type} {BS : Setoid B}{BP} f {poi}:= injF (@lista_map A AS AP B BS BP f poi) _.

Definition lista_nth {A : Type} {AS : Setoid A}{AP : Pointed A}  n (l : lista A) :=
  match l with
    | listaCons _ l' => nth n l' point
  end
.
Instance lista_nth_Proper {A : Type} {AS : Setoid A} AP : Proper (equiv ==> equiv ==> equiv) (@lista_nth A AS AP).
Proof.
  autounfold. intros. destruct x0, y0. simpl. rewrite H. clear x H. generalize y H0. clear y H0. apply list_ind_2 with (l1:=l) (l2:=l0).
  - simpl. destruct y. reflexivity. reflexivity.
  - intros.  destruct H0.  simpl. destruct y. rewritesr. rewrite <- H. simpl. destruct y. reflexivity. reflexivity. simpl. auto.
  - intros.  destruct H0. simpl. destruct y. rewritesr. rewrite H. simpl. destruct y. reflexivity. reflexivity. simpl. auto.
  - intros.  destruct H0. simpl. destruct y. rewritesr. apply H. simpl.  auto.
Qed.

Definition lista_nthS {A : Type} {AS : Setoid A} {AP} := injF2 (@lista_nth A AS AP) _.

Fixpoint list_findn {A : Type} {AS : Setoid A} {AP : Pointed A} (p : AS ~> boolS) (l : list A)  (n : nat) : maybe nat :=
  match l with
    | [] => if p @ point then Some n else None
    | a' :: l' => if p @ a' then Some n else list_findn p l' (S n)
  end
.

Definition lista_find {A : Type} {AS : Setoid A} {AP : Pointed A} (p : AS ~> boolS) (l : lista A) : maybe nat :=
  match l with
    | listaCons _ l' => list_findn p l' 0
  end
.

Instance lista_find_Proper {A : Type} {AS : Setoid A} AP: Proper (equiv ==> equiv ==> equiv ) (@lista_find A AS AP).
Proof.
  autounfold. intros. destruct x0, y0.  unfold lista_find. generalize 0 H0. clear H0. apply list_ind_2 with (l1:=l) (l2:=l0).
  - intros. destruct H0.  match goal with
      | |- ?a == ?b => simpl a; simpl b
    end. matchequiv.  inversion H0. inversion H0.
  - intros. destruct H1 as [? ?].
    match goal with
      | |- ?a == ?b => simpl a; simpl b
    end. rewrite H , H1. assert (y @ point = true \/ y @ point = false). destruct (y @ point). tauto. tauto. destruct H3. rewrite H3. reflexivity.  rewrite H3. rewrite <- H0. simpl. rewrite <- H in H3. rewrite H3. auto. simpl.   auto.
  - intros. destruct H1 as [? ?].
    match goal with
      | |- ?a == ?b => simpl a; simpl b
    end. rewrite H , H1. assert (y @ point = true \/ y @ point = false). destruct (y @ point). tauto. tauto. destruct H3. rewrite H3. reflexivity.  rewrite H3. rewrite H0. simpl. rewrite H3. reflexivity.   simpl.   auto.
  - intros. destruct H1 as [? ?].
    match goal with
      | |- ?a == ?b => simpl a; simpl b
    end. rewrite H , H1. assert (y @ c = true \/ y @ c = false). destruct (y @ c). tauto. tauto. destruct H3. rewrite H3. reflexivity.  rewrite H3. apply H0. auto.
Qed.

Definition lista_findS {A} {AS : Setoid A} {AP} :=
  injF2 (@lista_find A AS AP) _.

Fixpoint list_findan {A : Type} {AS : Setoid A} {AP : Pointed A} (d : forall a a' : A, {a==a'} + {~a==a'}) (l : list A)  (n : nat) :  nat :=
  match l with
    | [] =>  n
    | a' :: l' => if d point a' then  n else list_findan d l' (S n)
  end
.

Definition lista_finda {A : Type} {AS : Setoid A} {AP : Pointed A} (d : forall a a' : A, {a==a'} + {~a==a'}) (l : lista A) :  nat :=
  match l with
    | listaCons _ l' => list_findan d l' 0
  end
.

Instance lista_finda_Proper {A : Type} {AS : Setoid A} AP d: Proper (equiv ==> equiv ) (@lista_finda A AS AP d).
Proof.
  autounfold. intros. destruct x, y.  unfold lista_finda. generalize 0 H. clear H. apply list_ind_2 with (l1:=l) (l2:=l0).
  - intros. simpl. auto.
  - intros. destruct H0 as [? ?].
    simpl. destruct (d point a). reflexivity.  symmetry in H0. tauto.

  - intros. destruct H0 as [? ?].
    simpl. destruct (d point a). reflexivity. symmetry in H0. tauto.
  - intros. destruct H0 as [? ?].
    match goal with
      | |- ?a == ?b => simpl a; simpl b
    end.  destruct (d point a ), (d point c). reflexivity. rewrite <- H0 in n0. tauto. rewrite H0 in n0. tauto. apply H. auto.
Qed.

Definition lista_findaS {A} {AS : Setoid A} {AP} d :=
  injF (@lista_finda A AS AP d) _.

Definition lista_repeat {A : Type} {AS : Setoid A} {AP : Pointed A} := listaCons A [].

Fixpoint list_filter' {A : Type} {AS : Setoid A} (l : list (maybe A)) : list A :=
  match l with
    | [] => []
    | a' :: l' => match a' with
                    | Some n => n :: list_filter' l'
                    | None => list_filter' l'
                  end
  end
.

Instance list_filter'_Proper {A : Type} {AS : Setoid A} : Proper (equiv ==> equiv ) (@list_filter' A AS).
Proof.
  autounfold. intros. generalize H. clear H. apply list_ind_2 with (l1:=x) (l2:=y).
  - intros. reflexivity.
  - intros. inversion H0.
  - intros. inversion H0.
  - intros.
    simpl. inversion H0.  destruct a, c.
    + constructor. auto. apply H. auto.
    + inversion H4.
    + inversion H4.
    + apply H. auto.
Qed.

Definition lista_filter' {A : Type} {AS : Setoid A} (l : lista (maybe A)) : list A :=
  match l with
    | listaCons _ l' => list_filter' l'
  end
.

Instance lista_filter'_Proper {A : Type} {AS : Setoid A} : Proper (equiv ==> equiv ) (@lista_filter' A AS).
Proof.
  autounfold. intros. destruct x, y.  unfold lista_filter'. generalize H. clear H. apply list_ind_2 with (l1:=l) (l2:=l0).
  - intros. reflexivity.
  - intros. destruct H0 as [? ?].
    simpl. destruct a.
    + simpl in H0. inversion H0.
    + apply H. apply H1.
  - intros. destruct H0 as [? ?].
    destruct a.
    + inversion H0.
    + apply H. apply H1.
  - intros. destruct H0 as [? ?].
    simpl. destruct a, c.
    + constructor. auto. apply H. apply H1.
    + inversion H0.
    + inversion H0.
    + apply H. apply H1.
Qed.

Definition lista_filterS' {A} {AS : Setoid A}  :=
  injF (@lista_filter' A AS) _.

Fixpoint list_filter_index {A : Type} {AS : Setoid A} (p : AS ~> boolS) (l : list A) n : list nat :=
  match l with
    | [] => []
    | a' :: l' => if p @ a' then n :: list_filter_index p l' (S n) else list_filter_index p l' (S n)
  end
.

Definition lista_filter_index {A : Type} {AS : Setoid A} {AP : Pointed A} (p : AS ~> boolS) (l : lista A) : list nat :=
  match l with
    | listaCons _ l' => if (p @ point) then [] else list_filter_index p l' 0
  end
.

Instance lista_filter_index_Proper {A : Type} {AS : Setoid A} AP: Proper (equiv ==> equiv ==> equiv ) (@lista_filter_index A AS AP).
Proof.
  autounfold. intros. destruct x0, y0.  unfold lista_filter_index. generalize 0 H0. clear H0. apply list_ind_2 with (l1:=l) (l2:=l0).
  - intros. destruct H0. simpl. matchequiv.
  - intros. destruct H1 as [? ?].
    match goal with
      | |- ?a == ?b => simpl a; simpl b
    end. rewrite H , <- H1. assert (y @ a = true \/ y @ a = false). destruct (y @ a). tauto. tauto. destruct H3. rewrite H3. reflexivity.  rewrite H3. specialize (H0 (S n)). rewrite <- H1 in H0. rewrite H3 in H0. rewrite <- H in H3. rewrite H3 in H0. rewrite <- H0. simpl. auto.  simpl.   auto.
  - intros. destruct H1 as [? ?].
    match goal with
      | |- ?a == ?b => simpl a; simpl b
    end. rewrite H1.     assert (x @ point = true \/ x @ point = false). destruct (x @ point). tauto. tauto. destruct H3. rewrite H3. rewrite H3 in *.  rewrite H in H3. rewrite H3 in *. reflexivity.  rewrite H3 in *. rewrite  H in H3. rewrite H3 in *. apply H0. auto.
  - intros. destruct H1 as [? ?].
    match goal with
      | |- ?a == ?b => simpl a; simpl b
    end.  assert (x @ a = true \/ x @ a = false). destruct (x @ a). tauto. tauto. destruct H3. rewrite H, H1 in *. rewrite H3 in *. rewrite <- H in H3. rewrite H3 in *.  destruct (y @ point).
    reflexivity. constructor. reflexivity. apply H0. auto.  rewrite H3. rewrite H, H1 in H3. rewrite H3. rewrite H in *. destruct (y @ point).
    reflexivity. apply H0. auto.
Qed.

Definition lista_filter_indexS {A} {AS : Setoid A} {AP : Pointed A} :=
  injF2 (@lista_filter_index A AS AP) _.

Fixpoint list_filter_index' {A : Type} {AS : Setoid A}  (l : list (maybe A)) n : list (nat * A) :=
  match l with
    | [] => []
    | a' :: l' =>
      match a' with
        | Some a' => (n, a') :: list_filter_index'  l' (S n)
        | None => list_filter_index'  l' (S n)
      end
  end
.

Definition lista_filter_index' {A : Type} {AS : Setoid A}   (l : lista (maybe A)) : list (nat * A) :=
  match l with
    | listaCons _  l' => list_filter_index' l' 0
  end
.

Instance lista_filter_index'_Proper {A : Type} {AS : Setoid A}  : Proper (equiv ==> equiv ) (@lista_filter_index' A AS).
Proof.
  autounfold. intros. destruct x, y.  unfold lista_filter_index'. generalize 0 H. clear H. apply list_ind_2 with (l1:=l) (l2:=l0).
  - intros. destruct H. simpl. reflexivity.
  - intros. destruct H0 as [? ?].   destruct a. inversion H0. simpl. rewrite <- H. reflexivity. simpl.  auto.
  - intros. destruct H0.   destruct a.  inversion H0. simpl.  rewrite H. simpl. reflexivity.   simpl.   auto.
  - intros. destruct H0.    simpl. matchequiv. constructor. simpl in H2. rewritesr. apply H. auto. apply H. auto.
Qed.

Definition lista_filter_indexS' {A} {AS : Setoid A} :=
  injF (@lista_filter_index' A AS) _.

Lemma lista_equiv_nth :
    forall A (AS : Setoid A) (AP : Pointed A) (l1 l2 : lista A) ,
      (forall ci : nat,
         lista_nth ci l1 ==
         lista_nth ci l2) -> l1 == l2.
Proof.
    intros. destruct l1, l2. generalize H. clear H. apply list_ind_2 with (l1:=l) (l2:=l0).
    intros. reflexivity.
    intros. split. specialize (H0 0). simpl in H0. symmetry. auto. apply H. intros. specialize (H0 (S ci)). simpl in *. all_cases.
    intros. split. specialize (H0 0). simpl in H0. auto. apply H. intros. specialize (H0 (S ci)). simpl in *. all_cases.
    intros. split. specialize (H0 0). simpl in H0. auto. apply H. intros. specialize (H0 (S ci)). simpl in *. auto.
Qed.

Lemma equiv_nth :
    forall A (AS : Setoid A) (a : A) l1 a2 l2,
      (forall ci : nat,
         nth ci l1 a ==
         nth ci l2 a2) -> a == a2.
Proof.
    intros.  generalize H. clear H. apply list_ind_2 with (l1:=l1) (l2:=l2).
    intros. specialize (H 0). auto.
    intros. apply H. intros. specialize (H0 (S ci)). simpl in H0. simpl. all_cases.
    intros. apply H. intros. specialize (H0 (S ci)). simpl in H0. simpl. all_cases.
    intros. apply H. intros. specialize (H0 (S ci)). simpl in H0. auto.
Qed.

  Lemma listAll_nth :
    forall A (AS : Setoid A) (AP : Pointed A) l,
      (forall ci : nat,
         nth ci l point  == point) -> list_all l.
  Proof.
    intros.  generalize H. clear H. induction l.
    intros. simpl. auto.
    intros. split. specialize (H 0). simpl in H. auto. apply IHl. intros. specialize (H (S ci)). simpl in H. auto.
  Qed.

  Lemma equiv_lista :
    forall A (AS : Setoid A) (AP : Pointed A)  l1  l2,
      (forall ci : nat,
         nth ci l1 point ==
         nth ci l2 point) ->
      lista_equiv0 l1 l2.
  Proof.
    intros. generalize H. clear H. apply list_ind_2 with (l1:=l1) (l2:=l2).
    intros. specialize (H 0). simpl in H. simpl. auto.
    intros. split. specialize (H0 0).  simpl in H0. symmetry. auto. apply listAll_nth. intros.  specialize (H0 (S ci)).   simpl in H0. symmetry. auto.
    intros. split. specialize (H0 0).  simpl in H0. auto. apply H.  intros. specialize (H0 (S ci)). simpl in H0.  generalize H0. simpl.  all_cases.
    intros. split. specialize (H0 0).  simpl in H0. auto. apply H.  intros. specialize (H0 (S ci)). simpl in H0.  auto.
  Qed.

  Definition listOfLista {A} {AS : Setoid A} (l : lista A) :=
    match l with
      | listaCons _ l => l
    end.

  Lemma eq_lista_nth_lista_truncate_lt_lista_nth :
    forall A (AS : Setoid A) (AP : Pointed A) m n l,
      m < n ->
      lista_nth m (lista_truncate n  l) = lista_nth m l.
  Proof.
    intros. destruct l. generalize m n H. clear m n H. induction l.
    - double induction m n.
      + intros. inversion H.
      + intros. simpl. auto.
      + intros. inversion H0.
      + intros. simpl. destruct n1, n.
        * inversion H1. inversion H3.
        * simpl. auto.
        * inversion H1. inversion H3.
        * auto.
    - intros. destruct m, n.
      + inversion H.
      + simpl. auto.
      + inversion H.
      + simpl. apply IHl. apply lt_S_n. auto.
  Qed.

  Lemma lista_truncate_nil :
    forall n, lista_truncate0 n nil = nil.
  Proof.
    destruct n. auto. auto.
  Qed.

   Lemma lista_equiv_nil :
    forall A (AS : Setoid A) (AP : Pointed A) (l : list A), list_all l -> lista_equiv0 l [].
  Proof.
    induction l. auto. intros. destruct H. split. auto. auto.
  Qed.

  Lemma equiv_nth_equiv_lista_truncate :
    forall A (AS : Setoid A) n  l1 l2,
      (forall ci : nat, ci < n ->
         lista_nth ci l1 ==
         lista_nth ci l2) ->
      lista_truncate n l1 == lista_truncate n l2.
  Proof.
    intros. destruct l1, l2. generalize l l0 H. clear l l0 H. induction n.
    - intros. simpl. auto.
    - intros. generalize H. clear H.  apply list_ind_2 with (l1:=l) (l2:=l0).
      +  intros. reflexivity.
      + intros. split.
        * simpl.  specialize (H0 0). simpl in H0. symmetry. apply H0. apply lt_O_Sn.
        * specialize IHn with (l:=nil) (l0:=b).  simpl in IHn. rewrite lista_truncate_nil in IHn. simpl in IHn. apply IHn. intros.  specialize (H0 (S ci)). simpl in H0. rewrite <- H0.  all_cases.  auto using lt_n_S.
      + intros. split.
        * simpl.  specialize (H0 0). simpl in H0. apply H0. apply lt_O_Sn.
        * specialize IHn with (l:=b) (l0:=nil).  simpl in IHn. rewrite lista_truncate_nil in IHn. simpl in IHn.  apply IHn. intros.  specialize (H0 (S ci)). simpl in H0. rewrite  H0.  all_cases.  auto using lt_n_S.
      + intros. split.
        * simpl.  specialize (H0 0). simpl in H0. apply H0. apply lt_O_Sn.
        * specialize IHn with (l:=b) (l0:=d).   simpl in IHn. apply IHn. intros.  specialize (H0 (S ci)). simpl in H0. rewrite  H0.  auto.  auto using lt_n_S.
  Qed.

  Lemma equiv_lista_truncate_equiv_nth :
    forall A (AS : Setoid A) n l1 l2,
      lista_truncate n  l1 == lista_truncate n l2 ->
      (forall ci : nat, ci < n ->
         lista_nth ci l1 ==
         lista_nth ci l2).
  Proof.
    intros.  destruct l1, l2. generalize H0 H. clear H0 H.  apply nat_list_ind_4 with (l1:=ci) (l2:=n) (l3:=l) (l4:=l0).
    - intros. inversion H0.
    - intros. inversion H0.
    - intros. inversion H0.
    - intros. inversion H0.
    - intros. simpl.  destruct H1. auto.
    - intros. simpl.  destruct H1. auto.
    - intros. simpl.  destruct H1. auto.
    - intros. simpl.  destruct H1. auto.
    - intros. inversion H0.
    - intros. inversion H0.
    - intros. inversion H0.
    - intros. inversion H0.
    - intros. simpl. auto.
    - intros. simpl. destruct z.
      + apply H. apply lt_S_n. auto. destruct H1. simpl. rewrite lista_truncate_nil. auto.
      + apply H. apply lt_S_n. auto. destruct H1. simpl. rewrite lista_truncate_nil. auto.
    - intros. simpl. destruct z.
      + apply H. apply lt_S_n. auto. destruct H1. simpl.  rewrite lista_truncate_nil. auto.
      + apply H. apply lt_S_n. auto. destruct H1. simpl. rewrite lista_truncate_nil. auto.
    - intros. simpl. destruct z.
      + apply H. apply lt_S_n. auto. destruct H1. auto.
      + apply H. apply lt_S_n. auto. destruct H1. auto.
  Qed.

  Lemma lista_nth_ge_length :
    forall A(AS : Setoid A) (AP : Pointed A) n l,
      length l <= n ->
      lista_nth n (listaCons _ l) = point.
  Proof.
    intros. generalize dependent n. induction l.
    intros. destruct n.  auto. auto.
    intros. destruct n. simpl.  inversion H. simpl. apply IHl. auto using le_S_n.
  Qed.
  Lemma length_map : forall A B (l : list A) (f : A -> B), length (map f l) = length l.
  Proof.
    induction l.
    intros. auto. intros. simpl. f_equal. auto.
  Qed.

Lemma lista_truncate_equiv_equiv : forall A (AS : Setoid A) (AP :Pointed A) l1 l2 n,  l1 == l2 -> lista_truncate n l1 == lista_truncate n l2.
Proof.
  intros. generalize n H. clear n H . destruct l1, l2. apply list_ind_2 with (l1:=l) (l2:=l0).
  - simpl. intros. induction n.
    + simpl. auto.
    + simpl. tauto.
  - intros. destruct H0.   induction n.
    + simpl. auto.
    + simpl. split. auto. specialize (H n H1). simpl in H. destruct n. apply H. auto.
  - intros. destruct H0.  induction n.
    + simpl. auto.
    + simpl. split. auto. specialize (H n H1). simpl in H. destruct n. apply H. auto.
  - intros. destruct H0.  induction n.
    + simpl. auto.
    + simpl. split. auto. specialize (H n H1). simpl in H. destruct n. apply H. auto.
Qed.

Lemma truncate_idempotent:
  forall A (AS : Setoid A) (AP : Pointed A) n  (l : lista A),
    lista_truncate n  (lista_truncate n  l) == lista_truncate n  l.
Proof.
  intros. destruct l. apply nat_list_ind_2 with (l1:=n) (l2:=l).
  - reflexivity.
  - intros. simpl. auto.
  -    intros. simpl. auto.
  -    intros. split. reflexivity    . auto.
Qed.

Lemma lista_nth_lista_update: forall
  (A : Type)
  (AS : Setoid A)
  (AP : Pointed A)
  n
  (a : A)
  (l : lista A), lista_nth n (lista_update n l a)  = a.
Proof.
  intros. destruct l. simpl. apply nat_list_ind_2 with (l1:=n) (l2:=l).
  - simpl. reflexivity.
  - intros. simpl in *. reflexivity.
  - intros. simpl in *. auto.
  - intros. simpl in *. auto.
Qed.

Lemma lista_nth_lista_update_equiv: forall
  (A : Type)
  (AS : Setoid A)
  (AP : Pointed A)
  n
  (a : A)
  (l : lista A), lista_nth n (lista_update n l a)  == a.
Proof.
  intros. apply eq_equiv. apply lista_nth_lista_update.
Qed.

Lemma lista_update_lista_nth: forall
  (A : Type)
  (AS : Setoid A)
  (AP : Pointed A)
  n
  (l : lista A),  (lista_update n l (lista_nth n l))  == l.
Proof.
  intros.  destruct l.  apply nat_list_ind_2 with (l1:=n) (l2:=l).
  - simpl. split; [reflexivity  | reflexivity].
  - intros.  split. reflexivity. assert (listaCons _ b == listaCons _ b). reflexivity.   auto.
  - intros. simpl in *. split ; [reflexivity | ]. destruct b.
      * simpl in *. auto.
      * simpl in *. auto.
  - intros. simpl in *. split ; [reflexivity | auto].

Qed.

Lemma lista_update_lista_update: forall
  (A : Type)
  (AS : Setoid A)
  (AP : Pointed A)
  n
  a c
  (l : lista A),  (lista_update n (lista_update n l a) c )  == lista_update n l c .
Proof.
  intros. destruct l. simpl. apply nat_list_ind_2 with (l1:=n) (l2:=l).
    - simpl. split; [reflexivity | reflexivity].
    - intros. simpl in *. split; [reflexivity |]. destruct b.
      * simpl in *. tauto.
      * simpl in *. split ; [reflexivity | tauto].
    - intros. simpl in *. split ; [reflexivity | auto].
    - intros. simpl in *. split ; [reflexivity | auto].

Qed.

Lemma lista_nth_lista_update_diff_index: forall
  (A : Type)
  (AS : Setoid A)
  (AP : Pointed A)
  n n' a
  (l : lista A),
  n <> n' ->lista_nth n' (lista_update n l a) = lista_nth n' l.
Proof.
  intros.  destruct l. generalize H a. clear H. apply nat_list_ind_4 with (l1:=n) (l2:=n')(l3:=l).
  - intros. destruct H.  auto.
  - intros. destruct H0.  auto.
  - intros. destruct H0. auto.
  - intros. destruct H0. auto.
  - intros. simpl. all_cases.
  - intros. simpl. all_cases.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl in *. destruct b. apply H. auto. apply H. auto.
  - intros. simpl in *. destruct b. apply H. auto. apply H. auto.
  - intros. simpl in *. apply H. auto.
  - intros. simpl in *. apply H. auto.
  - exact [].
Qed.
Lemma lista_update_lista_update_diff_index: forall
  (A : Type)
  (AS : Setoid A)
  (AP : Pointed A)
  n n' a a'
  (l : lista A),
  n <> n' -> lista_update n' (lista_update n l a) a' = lista_update n (lista_update n' l a') a.
Proof.
  intros.  destruct l. generalize H a a'. clear H. apply nat_list_ind_4 with (l1:=n) (l2:=n')(l3:=l).
  - intros. destruct H.  auto.
  - intros. destruct H0.  auto.
  - intros. destruct H0. auto.
  - intros. destruct H0. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl in *. assert (z<>b); [auto|]. specialize (H H1 a0 a'0). inversion H. congruence.
  - intros. simpl in *. assert (z<>b); [auto|]. specialize (H H1 a0 a'0). inversion H. congruence.
  - intros. simpl in *. assert (z<>b); [auto|]. specialize (H H1 a0 a'0). inversion H. congruence.
  - intros. simpl in *. assert (z<>b); [auto|]. specialize (H H1 a0 a'0). inversion H. congruence.
  - exact [].
Qed.

Lemma list_update_list_update_diff_index: forall
  (A : Type)
  (AS : Setoid A)
  n n' a a'
  (l : list A),
  n <> n' -> list_update' n' (list_update' n l a) a' = list_update' n (list_update' n' l a') a.
Proof.
  intros.  generalize H a a'. clear H. apply nat_list_ind_4 with (l1:=n) (l2:=n')(l3:=l).
  - intros. destruct H.  auto.
  - intros. destruct H0.  auto.
  - intros. destruct H0. auto.
  - intros. destruct H0. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl. auto.
  - intros. simpl in *. assert (z<>b); [auto|]. specialize (H H1 a0 a'0). inversion H. congruence.
  - intros. simpl in *. assert (z<>b); [auto|]. specialize (H H1 a0 a'0). inversion H. congruence.
  - intros. simpl in *. assert (z<>b); [auto|]. specialize (H H1 a0 a'0). inversion H. congruence.
  - intros. simpl in *. assert (z<>b); [auto|]. specialize (H H1 a0 a'0). inversion H. congruence.
  - exact [].
Qed.

Require Import Coq.Arith.Le.

  Lemma list_findan_ge : forall A (AS : Setoid A )(AP : Pointed A) (l: list A) n
                            (equiv_dec: forall a a' : A, {a == a'} + {~ a == a'}),
                            list_findan equiv_dec l n >= n.
  Proof.
    intros. generalize n. induction l.
    simpl. apply le_n.
    simpl. destruct (equiv_dec point a).
    apply le_n.
    intros. apply le_trans with (m:=S n1).
    apply Nat.le_le_succ_r. apply le_n.
    apply IHl.
  Qed.
  Open Scope nat_scope.
  Lemma list_findan_plus : forall A (AS : Setoid A )(AP : Pointed A) (l: list A) m n
                            (equiv_dec: forall a a' : A, {a == a'} + {~ a == a'}),
                            list_findan equiv_dec l (m + n) = list_findan equiv_dec l m + n.
  Proof.
    intros. generalize m n. induction l.
    intros. simpl. reflexivity .
    intros. simpl. destruct (equiv_dec point a).
    auto.
    apply (IHl (S m0) n0).
  Qed.

  Lemma list_filter_index_plus : forall A (AS : Setoid A )(AP : Pointed A) (l: list A) q m n
                            ,
                            list_filter_index q l (m + n) = map (flip plus n) (list_filter_index q l m ).
  Proof.
    intros. generalize m n. induction l.
    intros. simpl. reflexivity .
    intros. simpl. destruct (q @ a).
    rewrite map_cons. f_equal. rewrite <- plus_Sn_m. apply IHl.
    rewrite <- plus_Sn_m. apply IHl.
  Qed.

  Lemma list_filter_index_plus' : forall A (AS : Setoid A) (l: list (maybe A))  m n
                            ,
                            list_filter_index'  l (m + n) = mapS @ (flipS @ plusS @ n *** idS) @ (list_filter_index'  l m ).
  Proof.
    intros. generalize m n. induction l.
    intros. simpl. reflexivity .
    intros. simpl. destruct a.
    rewrite map_cons. f_equal. rewrite <- plus_Sn_m. apply IHl.
    rewrite <- plus_Sn_m. apply IHl.
  Qed.

  Lemma lista_finda_lista_update:
  forall
  (A : Type)
  (AS : Setoid A)
  (AP : Pointed A)equiv_dec
  n  a
  (l : lista A),
    ~    lista_nth n l == point ->
    ~ a == point ->
    lista_finda equiv_dec
    (lista_update n l a) =
       lista_finda equiv_dec
                 l.
Proof.
  intros. destruct l. generalize H. clear H. apply nat_list_ind_2 with (l1:=n) (l2:=l).
  - intros. simpl in *. destruct H. reflexivity.
  - intros. simpl in *. destruct (equiv_dec point a), (equiv_dec point a0).  auto. symmetry in e.  tauto.  symmetry in e. tauto. auto.
  - intros. simpl in *. destruct H1. reflexivity.
  - intros. simpl in *. destruct (equiv_dec point c). auto. rewrite (list_findan_plus _ _ _ (lista_update0 b d a) 0 1 _). rewrite (list_findan_plus _ _ _ d 0 1 _). f_equal. auto.
Qed.

Lemma lista_update_lista_finda:

  forall
  (A : Type)
  (AS : Setoid A)
  (AP : Pointed A)equiv_dec
  (l : lista A),
    (lista_update (lista_finda equiv_dec l) l point) ==
                 l.
Proof.
  intros. destruct l. induction l.
  - intros. simpl in *. split.  reflexivity. auto.

  - intros. simpl in *.  destruct (equiv_dec point a).   simpl. split.  auto. fold (lista_equiv (listaCons _ l) (listaCons _ l)). reflexivity. rewrite (list_findan_plus _ _ _ l 0 1). rewrite <- plus_n_Sm.    simpl. split. reflexivity. rewrite <- plus_n_O.  auto.
Qed.

  Existing Instance list_Foldable.
  Existing Instance listFunctor.
Section And_Monoid.
  Existing Instance and_Monoid.
    Lemma filterTrue :
      forall A (AS : Setoid A)
             (p : maybeS AS ~> iff_setoid)
             (q : maybeS AS ~> boolS)
             (a : lista (maybe A)),
        (forall b : maybe A, q @ b == true -> p @ b) ->
        fold @ (mapS @ (p ∘ flipS @ lista_nthS @ a) @ (lista_filter_indexS @ q @ a)) == True.
    Proof.
      intros. destruct a. induction l.
      simpl.  destruct_bool (q @ None). tauto. tauto.
      split. auto. intros. simpl in *. destruct_bool (q @ None). auto. destruct_bool (q @ a).
      - split.
        + apply H. auto.
        + rewrite (list_filter_index_plus _ _ _ _ _ 0 1). rewrite map_map. unfold flip.  generalize IHl. clear IHl. induction l.
          * simpl. auto.
          * intros. simpl. destruct_bool (q @ a0).
            {
              split.
              {
                tauto.
              }
              {
                clear IHl. generalize IHl0. clear IHl0.
                induction (list_filter_index q l 1).
                {
                  auto.
                }
                {
                  intros. destruct IHl1. destruct H5. auto. destruct H6. split.
                  {
                    rewrite <- (plus_n_Sm a1 0). rewrite <- plus_n_O. auto.
                  }
                  {
                    apply IHl0. split.  auto. intro. auto.
                  }
                }
              }
            }
            {
                clear IHl. generalize IHl0. clear IHl0.
                induction (list_filter_index q l 1).
                {
                  auto.
                }
                {
                  intros. destruct IHl1. destruct H5. auto. split.
                  {
                    rewrite <- (plus_n_Sm a1 0). rewrite <- plus_n_O. auto.
                  }
                  {
                    apply IHl0. split.  auto. intro. auto.
                  }
                }
              }
      -  rewrite (list_filter_index_plus _ _ _ _ _ 0 1). rewrite map_map. unfold flip.  generalize IHl. clear IHl. induction l.
          * simpl. auto.
          * intros. simpl. destruct_bool (q @ a0).
            {
              split.
              {
                tauto.
              }
              {
                clear IHl. generalize IHl0. clear IHl0.
                induction (list_filter_index q l 1).
                {
                  auto.
                }
                {
                  intros. destruct IHl1. destruct H5. auto. destruct H6. split.
                  {
                    rewrite <- (plus_n_Sm a1 0). rewrite <- plus_n_O. auto.
                  }
                  {
                    apply IHl0. split.  auto. intro. auto.
                  }
                }
              }
            }
            {
                clear IHl. generalize IHl0. clear IHl0.
                induction (list_filter_index q l 1).
                {
                  auto.
                }
                {
                  intros. destruct IHl1. destruct H5. auto. split.
                  {
                    rewrite <- (plus_n_Sm a1 0). rewrite <- plus_n_O. auto.
                  }
                  {
                    apply IHl0. split.  auto. intro. auto.
                  }
                }
            }
    Qed.

    Lemma filterTrue' :
      forall A (AS : Setoid A)
             (a : lista (maybe A)),
        fold @ (mapS @ (uncurryS @ equivS ∘ (flipS @ lista_nthS @ a *** SomeS)) @ (lista_filter_indexS' @ a)) == True.
    Proof.
      intros. destruct a. induction l.
      simpl. reflexivity.
      split. auto. intros. simpl in *. destruct a.
      - simpl. split.
        + reflexivity.
        + rewrite (list_filter_index_plus' _ _ _ 0 1). unfold mapS. normalize. rewrite map_map. unfold flipS, flip.  normalize. generalize IHl. clear IHl. induction l.
          * simpl. auto.
          * intros. simpl in *. destruct a0.
            {
              split.
              {
                simpl. reflexivity.
              }
              {
                clear IHl. generalize IHl0. clear IHl0.
                induction (list_filter_index' l 1).
                {
                  auto.
                }
                {
                  intros. destruct IHl1. destruct H1. auto. destruct H2. split.
                  {
                    destruct a1. rewrite <- (plus_n_Sm n 0). rewrite <- plus_n_O. auto.
                  }
                  {
                    apply IHl0. split.  auto. intro. split. reflexivity. auto.
                  }
                }
              }
            }
            {
                clear IHl. generalize IHl0. clear IHl0.
                induction (list_filter_index' l 1).
                {
                  auto.
                }
                {
                  intros. destruct IHl1. destruct H1. auto. split.
                  {
                    destruct a0. rewrite <- (plus_n_Sm n 0). rewrite <- plus_n_O. auto.
                  }
                  {
                    apply IHl0. split.  auto. intro. auto.
                  }
                }
              }
      -  rewrite (list_filter_index_plus' _ _ _ 0 1). unfold mapS. normalize. rewrite map_map. unfold flipS, flip.  normalize. generalize IHl. clear IHl. induction l.
          * simpl. auto.
          * intros. simpl in *. destruct a.
            {
              split.
              {
                simpl. reflexivity.
              }
              {
                clear IHl. generalize IHl0. clear IHl0.
                induction (list_filter_index' l 1).
                {
                  auto.
                }
                {
                  intros. destruct IHl1. destruct H1. auto. destruct H2. split.
                  {
                    destruct a0. rewrite <- (plus_n_Sm n 0). rewrite <- plus_n_O. auto.
                  }
                  {
                    apply IHl0. split.  auto. intro. split. reflexivity. auto.
                  }
                }
              }
            }
            {
                clear IHl. generalize IHl0. clear IHl0.
                induction (list_filter_index' l 1).
                {
                  auto.
                }
                {
                  intros. destruct IHl1. destruct H1. auto. split.
                  {
                    destruct a. rewrite <- (plus_n_Sm n 0). rewrite <- plus_n_O. auto.
                  }
                  {
                    apply IHl0. split.  auto. intro. auto.
                  }
                }
            }
    Qed.
End And_Monoid.

    Definition SS : natS ~> natS := injF S _.
Section Or_Monoid.
  Existing Instance or_Monoid.
    Lemma filterTrue_one :
      forall A (AS : Setoid A) (AP : Pointed A)
             (p : natS ~> iff_setoid)
             (q : AS ~> boolS)
             (a : lista A),
        q @ point = false ->
        (exists b : nat, q @ (lista_nthS @ b @ a) == true /\ p @ b) ->
        fold @ (mapS @ p @ (lista_filter_indexS @ q @ a)) == True.
    Proof.
      intros. destruct a. generalize dependent p. induction l.
      intros. simpl. destruct H0. simpl in H0. destruct x. destruct H0. rewrite H in H0. inversion H0.  destruct H0. rewrite H in H0. inversion H0.
      split. auto. intros. simpl in *. rewrite H in *. destruct H0.  destruct x.
      - destruct H0. rewrite H0. simpl. left. auto.
      - destruct (q @ a).
        + simpl. right. rewrite (list_filter_index_plus _ _ _ _ _ 0 1). rewrite map_map. unfold flip. destruct (IHl (p ∘ SS)). exists x.   auto. clear H0 H1 H2. specialize (H3 I). generalize H3. clear H3. induction l.
          * simpl. auto.
          * intros. destruct_bool (q @ a0).
            {
              destruct H3.
              {
                tauto.
              }
              {
                generalize H1. clear H1.
                induction (list_filter_index q l 1).
                {
                  auto.
                }
                {
                  intros. destruct H1.  destruct a1. tauto. right. left. simpl. rewrite <- (plus_n_Sm a1 0). rewrite <- plus_n_O. auto. right. right. clear H H0 IHl IHl0 IHl1. induction l0.
                  {
                    simpl in *. auto.
                  }
                  {
                    simpl in *. destruct H1.
                    {
                      left.  rewrite <- plus_n_Sm. rewrite <- plus_n_O.  auto.
                    }
                    {
                      right. auto.
                    }
                  }
                }
              }
            }
            {
                clear IHl IHl0. generalize H3. clear H3.
                induction (list_filter_index q l 1).
                {
                  auto.
                }
                {
                  intros. simpl.  destruct H3. destruct a1.  simpl. tauto. simpl.  rewrite <- (plus_n_Sm a1 0). rewrite <- plus_n_O. tauto. right. apply IHl0. auto.
                }
            }
        + rewrite (list_filter_index_plus _ _ _ _ _ 0 1). rewrite map_map. unfold flip. destruct (IHl (p ∘ SS)). exists x.   auto. clear H0 H1 H2. specialize (H3 I). generalize H3. clear H3. induction l.
          * simpl. auto.
          * intros. destruct_bool (q @ a0).
            {
              destruct H3.
              {
                tauto.
              }
              {
                generalize H1. clear H1.
                induction (list_filter_index q l 1).
                {
                  auto.
                }
                {
                  intros. destruct H1.  destruct a1. tauto. right. left. simpl. rewrite <- (plus_n_Sm a1 0). rewrite <- plus_n_O. auto. right. right. clear H H0 IHl IHl0 IHl1. induction l0.
                  {
                    simpl in *. auto.
                  }
                  {
                    simpl in *. destruct H1.
                    {
                      left.  rewrite <- plus_n_Sm. rewrite <- plus_n_O.  auto.
                    }
                    {
                      right. auto.
                    }
                  }
                }
              }
            }
            {
                clear IHl IHl0. generalize H3. clear H3.
                induction (list_filter_index q l 1).
                {
                  auto.
                }
                {
                  intros. simpl.  destruct H3. destruct a1.  simpl. tauto. simpl.  rewrite <- (plus_n_Sm a1 0). rewrite <- plus_n_O. tauto. right. apply IHl0. auto.
                }
            }
    Qed.

    Lemma filterTrue_one' :
      forall A (AS : Setoid A)
             (p : natS ~*~ AS ~> iff_setoid)
             (a : lista (maybe A)),
        (exists (b : nat) c, lista_nthS @ b @ a == Some c /\ p @ (b, c)) ->
        fold @ (mapS @ p @ (lista_filter_indexS' @ a)) == True.
    Proof.
      intros. destruct a. generalize dependent p. induction l.
      intros. simpl. destruct H as [b [c H]]. simpl in H. destruct b. destruct H. inversion H.  destruct H.  inversion H.
      split. auto. intros. simpl in *. clear H0.  destruct H as [b [c H]].  destruct b.
      - destruct H. destruct a.
        + simpl in *. left. assert (p @ (0, a) == p @ (0, c)). evalproper.  split; [reflexivity | auto]. rewrite H1. auto.
        + simpl in *. tauto.
      - destruct a.
        + simpl. right. rewrite (list_filter_index_plus' _ _ _ 0 1). unfold mapS. normalize. rewrite map_map. destruct (IHl (p ∘ (SS *** idS))). clear IHl.  exists b.   exists c. auto. clear H H0. specialize (H1 I). generalize H1. clear H1. induction l.
          * simpl. auto.
          * intros. simpl. destruct a0.
            {
              simpl. destruct H1.
              {
                left. auto.
              }
              {
                clear IHl. right. generalize H. clear H.
                induction (list_filter_index' l 1).
                {
                  auto.
                }
                {
                  intros. destruct H.
                  {
                    destruct a1. simpl.
                    left.  rewrite <- (plus_n_Sm n 0). rewrite <- plus_n_O. destruct n.
                    auto. auto.
                  }
                  {
                    right. auto.
                  }
                }
              }
            }
            {
              simpl in H1. clear IHl.  generalize H1. clear H1.
                induction (list_filter_index' l 1).
                {
                  auto.
                }
                {
                  intros. destruct H1.
                  {
                    destruct a0. simpl.
                    left.  rewrite <- (plus_n_Sm n 0). rewrite <- plus_n_O. destruct n.
                    auto. auto.
                  }
                  {
                    right. auto.
                  }
                }
            }
        + rewrite (list_filter_index_plus' _ _ _ 0 1). unfold mapS. normalize. rewrite map_map. destruct (IHl (p ∘ (SS *** idS))). clear IHl.  exists b.   exists c. auto. clear H H0. specialize (H1 I). generalize H1. clear H1. induction l.
          * simpl. auto.
          * intros. simpl. destruct a.
            {
              simpl. destruct H1.
              {
                left. auto.
              }
              {
                clear IHl. right. generalize H. clear H.
                induction (list_filter_index' l 1).
                {
                  auto.
                }
                {
                  intros. destruct H.
                  {
                    destruct a0. simpl.
                    left.  rewrite <- (plus_n_Sm n 0). rewrite <- plus_n_O. destruct n.
                    auto. auto.
                  }
                  {
                    right. auto.
                  }
                }
              }
            }
            {
              simpl in H1. clear IHl.  generalize H1. clear H1.
                induction (list_filter_index' l 1).
                {
                  auto.
                }
                {
                  intros. destruct H1.
                  {
                    destruct a. simpl.
                    left.  rewrite <- (plus_n_Sm n 0). rewrite <- plus_n_O. destruct n.
                    auto. auto.
                  }
                  {
                    right. auto.
                  }
                }
            }
    Qed.

End Or_Monoid.

    Fixpoint list_filter_index_2 {A}  {AS : Setoid A} (p : AS ~> boolS)
             (l : list A)  :=
      match l with
        | nil => nil
        | a' :: l' =>
          if p @ a'
          then 0 :: map S (list_filter_index_2  p l')
          else map S (list_filter_index_2 p l')
      end.

    Definition lista_filter_index_2 {A}  {AS : Setoid A} {AP : Pointed A} (p : AS ~> boolS)
             (l : lista A) :=
      match l with
        | listaCons _ l' => if p @ point then nil else list_filter_index_2 p l'
      end.

    Lemma list_filter_index_eq : forall A (AS : Setoid A)  (p : AS ~> boolS) (l : list A) n,
                                     list_filter_index p l n = map (plus n) (list_filter_index_2 p l).
    Proof.
      intros. generalize n. induction l.
      simpl. auto.
      intros.       simpl. destruct (p @ a). rewrite map_cons. f_equal.  auto. rewrite map_map. rewrite IHl. clear IHl.  induction ((list_filter_index_2 p l)).    auto. simpl. f_equal. auto. auto. rewrite map_map. rewrite IHl. clear IHl.  induction ((list_filter_index_2 p l)).    auto. simpl. f_equal. auto. auto.
    Qed.

    Lemma lista_filter_index_eq : forall A (AS : Setoid A) (AP : Pointed A) (p : AS ~> boolS) (l : lista A),
            lista_filter_index p l  = lista_filter_index_2 p l.
    Proof.
      intros. destruct l. induction l.
      simpl. reflexivity.
      simpl. destruct (p @ point).
      auto.
      destruct (p @ a).  f_equal. rewrite list_filter_index_eq.  clear IHl. induction ((list_filter_index_2 p l)).  auto. simpl. f_equal. rewrite list_filter_index_eq.  clear IHl. induction ((list_filter_index_2 p l)).  auto. simpl. f_equal.
    Qed.

    Fixpoint list_zipWith_not_proper {A B C} (f : A -> B -> C) l1 l2 :=
      match l1, l2 with
        | nil, _ => nil
        | a :: l1', nil => nil
        | a :: l1', b :: l2' => f a b :: list_zipWith_not_proper f l1' l2'
      end
    .

(*  Fixpoint compact {A} {AS : Setoid A} (l1  : list (maybe A)) :=
    match l1 with
      | nil => nil
      | None :: l2' => compact l2'
      | Some a :: l2' => Some a :: compact l2'
    end.*)

  Fixpoint list_merge {A} {AS : Setoid A} (l1  : list (maybe A)) (l2 : list A) :=
    match l1, l2 with
      | nil, _ => map Some l2
      | None :: l1', nil => list_merge l1' nil
      | None :: l1', a :: l2' => Some a :: list_merge l1' l2'
      | Some a :: l1', _ => Some a :: list_merge l1' l2
    end
  .

(*  Instance list_merge_Proper A AS : Proper (equiv ==> equiv ==> equiv) (@list_merge A AS).
  Proof.
    autounfold. intros. generalize H x0 y0 H0. clear H x0 y0 H0. apply list_ind_2 with (l1:=x) (l2:=y).
    intros. unfold list_merge.  apply map_Proper. auto. auto.
    intros. inversion H0.
    intros. inversion H0.
    intros. inversion H0. unfold list_merge. fold list_merge.      matchequiv. constructor. auto. apply H. auto. auto. matchequiv. auto. inversion H9. constructor. auto. apply H. auto. auto.
  Qed.
  *)

  Definition lista_merge {A} {AS : Setoid A} (l1 : lista (maybe A)) (l2 : list A) :=
    match l1 with
      | listaCons _ l1 => listaCons _ (list_merge l1 l2)
    end
  .

  Instance lista_merge_Proper A AS : Proper (equiv ==> equiv ==> equiv) (@lista_merge A AS).
  Proof.
    autounfold. intros. destruct x,y. unfold lista_merge. simpl in H. generalize H x0 y0 H0. clear H x0 y0 H0. apply list_ind_2 with (l1:=l) (l2:=l0).
    -    intros. unfold list_merge.  rewritesr.
    - intros.  destruct a.
      + inversion H0. inversion H2.
      + rewrite H with (y0:=y0).
        * simpl. clear H H1. generalize b H0. clear b H0. induction y0.
          {
            reflexivity.
          }
          {
            intros. destruct b. reflexivity. destruct m.
            inversion H0. inversion H1. inversion H2.
            simpl. split. reflexivity. apply IHy0. simpl in H0. simpl. tauto.
          }
        * simpl in H0. tauto.
        * auto.
    - intros.  destruct a.
      + inversion H0. inversion H2.
      + rewrite <- H with (x0:=x0).
        * simpl. clear H H1. generalize b H0. clear b H0. induction x0.
          {
            reflexivity.
          }
          {
            intros. destruct b. reflexivity. destruct m.
            inversion H0. inversion H1. inversion H2.
            simpl. split. reflexivity. apply IHx0. simpl in H0. simpl. tauto.
          }
        * simpl in H0. tauto.
        * auto.
    - intros. inversion H0. simpl. destruct a, c.
      + split. auto. apply H. auto. auto.
      + inversion H2.
      + inversion H2.
      + inversion H2. destruct x0, y0.
        * apply H. auto. auto.
        * inversion H1.
        * inversion H1.
        * inversion H1. split. auto. apply H. auto. auto.
  Qed.

  Definition lista_mergeS {A} {AS : Setoid A} := injF2 (@lista_merge A AS) _.

Fixpoint list_delete {A : Type} {AS : Setoid A}  (n : nat) (l : list A) {struct l} : list A :=
  match l with
    | [] => []
    | a' :: l' =>
      match n with
        | O => l'
        | S n' => a' :: list_delete n' l'
      end
  end
.

Definition lista_delete {A : Type} {AS : Setoid A} {AP : Pointed A} (n : nat)  (l : lista A) : lista A :=
  match l with
    | listaCons _  l' => listaCons _ (list_delete n l')
  end
.

Instance lista_delete_Proper {A : Type} {AS : Setoid A} AP : Proper (equiv ==> equiv ==> equiv ) (@lista_delete A AS AP).
Proof.
  autounfold. intros. destruct x0, y0.  simpl. simpl in H. rewrite H. clear x H. generalize y H0. clear y H0. apply list_ind_2 with (l1:=l) (l2:=l0).
  - intros. reflexivity.
  - intros. destruct y.
    + simpl. simpl in H0. tauto.
    + simpl. destruct H0. split. auto. apply H. auto.
  - intros. destruct y.
    + simpl. simpl in H0. tauto.
    + simpl. destruct H0. split. auto. apply H. auto.
  - intros. destruct y.
    + simpl. simpl in H0. tauto.
    + simpl. destruct H0. split. auto. apply H. auto.
Qed.

Definition lista_deleteS {A} {AS : Setoid A} {AP : Pointed A} :=
  injF2 (@lista_delete A AS AP) _.

Lemma lista_equiv_dec : forall {A} {AS :Setoid A} {AP : Pointed A } (r1 r2 : lista A) (equiv_dec : forall a1 a2 : A, {a1 == a2} + {~a1 == a2}),  {r1 == r2} + {~r1 == r2}.
Proof.
  intros. destruct r1 as [l], r2 as [l0].

  apply list_rect_2 with (l1:=l) (l2:=l0).
      - left.  reflexivity.
      - intros. destruct H.
        + destruct (equiv_dec a point).
          * left. split. auto. auto.
          * right. simpl. tauto.
        + right. simpl. tauto.
      - intros. destruct H.
        + destruct (equiv_dec a point).
          * left. split. auto. simpl in e. auto.
          * right. simpl. tauto.
        + right. simpl in *. tauto.
      - intros. destruct H.
        + destruct (equiv_dec a c).
          * left. simpl. auto.
          * right. simpl. tauto.
        + right. simpl in *. tauto.
Defined.


(*
  (Alternative) Minsky Machine PACK, UNPACK routines
  PACK A X Y offset:
    X := (X+X+1)*(2^Y)
    Y := 0
    A := 0 (auxiliary)
  UNPACK A X Y offset:
    IF X = (n+n+1)*2^m THEN X := n, Y := m, A := 0 (auxiliary)

  Other subprograms:
    INC, DEC, JMP, JZ, ZERO, MOVE, MOVE2, HALF
*)

From Undecidability Require Import
  MinskyMachines.MM MinskyMachines.MMA.

From Undecidability.Shared.Libs.DLW
  Require Import Vec.pos Vec.vec Code.sss.

Require Import PeanoNat List Lia Wf_nat.
Import ListNotations.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

#[local] Arguments ltof /.

Section FixCounters.
Context {num_counters : nat}.
#[local] Notation counter := (pos num_counters).
#[local] Notation mm_instr := (mm_instr counter).
#[local] Notation mm_state := (mm_state num_counters).

#[local] Notation "P // s ->> t" := (sss_compute (@mma_sss num_counters) P s t).
#[local] Notation "P // s -+> t" := (sss_progress (@mma_sss num_counters) P s t).
#[local] Notation "e #> x" := (vec_pos e x).
#[local] Notation "e [ v / x ]" := (vec_change e x v).

(* simplify vec_change statements *)
Definition vec_norm {X Y: counter} (HXY : X <> Y) := (
  fun v n m => @vec_change_comm nat _ v X Y n m HXY,
  fun v n m => @vec_change_idem nat _ v X n m,
  fun v n m => @vec_change_idem nat _ v Y n m,
  fun v n => @vec_change_neq nat _ v X Y n HXY,
  fun v n => @vec_change_neq nat _ v Y X n (nesym HXY),
  fun v n => @vec_change_eq nat _ v X X n erefl,
  fun v n => @vec_change_eq nat _ v Y Y n erefl,
  fun v => @vec_change_same nat _ v X,
  fun v => @vec_change_same nat _ v Y).

Lemma vec_change_same' {X : Type} {n : nat} {v : vec X n} {p : pos n} {x : X} :
  vec_pos v p = x -> vec_change v p x = v.
Proof. move=> <-. by apply: vec_change_same. Qed.

(* compose MMA sub-procedures into one MMA procedure *)
Fixpoint compose (codes : list (nat -> list mm_instr)) (offset : nat) :=
  match codes with
  | nil => []
  | code :: codes => code offset ++ compose codes ((length (code offset))+offset)
  end.

Fact sss_compute_refl i P (st : mm_state) : (i, P) // st ->> st.
Proof.  exists 0. by apply: in_sss_steps_0. Qed.

Fact sss_compute_refl' i P (st1 st2 : mm_state) : st1 = st2 -> (i, P) // st1 ->> st2.
Proof. move=> ->. by apply: sss_compute_refl. Qed.

Lemma subcode_nth_compose i j codes offset :
  j = length (compose (firstn i codes) offset) ->
  subcode.subcode (j + offset, nth i codes (fun=> []) (j + offset)) (offset, compose codes offset).
Proof.
  move=> -> /=.
  elim: codes i offset => /=.
  { rewrite /compose. by move=> [|i] /=; exists nil, nil; rewrite /= Nat.add_0_r. }
  move=> code codes IH [|i] offset /=.
  - eexists nil, _. by rewrite /= Nat.add_0_r.
  - have [l [r [-> Hl]]] := IH i (length (code offset) + offset).
    eexists (code offset ++ l), _. rewrite !app_length. split; [|lia].
    rewrite -!app_assoc. do 3 congr app. congr (nth i codes). lia.
Qed.

(* uses uniform subproc compose structure *)
Lemma compose_sss_compute_trans {codes : list (nat -> list mm_instr)} {offset} (i : nat) {v st st'} :
  let j := length (compose (firstn i codes) offset) in
  (j + offset, (nth i codes (fun _ => [])) (j+offset)) // (j + offset, v) ->> st' ->
  (offset, compose codes offset) // st' ->> st ->
  (offset, compose codes offset) // (j + offset, v) ->> st.
Proof.
  move=> j H. apply: sss_compute_trans.
  move: H. apply: subcode_sss_compute. by apply: subcode_nth_compose.
Qed.

Lemma compose_sss_progress_trans {codes : list (nat -> list mm_instr)} {offset} (i : nat) {v st st'} :
  let j := length (compose (firstn i codes) offset) in
  (j + offset, (nth i codes (fun _ => [])) (j+offset)) // (j + offset, v) -+> st' ->
  (offset, compose codes offset) // st' ->> st ->
  (offset, compose codes offset) // (j + offset, v) -+> st.
Proof.
  move=> j H. apply: sss_progress_compute_trans.
  move: H. apply: subcode_sss_progress. by apply: subcode_nth_compose.
Qed.

Lemma compose_sss_compute_length_trans (i : nat) {codes : list (nat -> list mm_instr)} {lengths} {offset} {v st st'} :
  Forall2 (fun c l => forall j, length (c j) = l) codes lengths ->
  let j := list_sum (firstn i lengths) in
  (j + offset, (nth i codes (fun _ => [])) (j+offset)) // (j + offset, v) ->> st' ->
  (offset, compose codes offset) // st' ->> st ->
  (offset, compose codes offset) // (j + offset, v) ->> st.
Proof.
  move=> Hcl.
  suff -> : list_sum (firstn i lengths) = length (compose (firstn i codes) offset) by apply: compose_sss_compute_trans.
  elim: Hcl i offset. { by case. }
  move=> c l {}codes {}lengths Hcl _ IH [|i] offset. { done. }
  by rewrite /= app_length -IH Hcl.
Qed.

Lemma length_compose {codes lengths offset} :
  Forall2 (fun c l => forall i, length (c i) = l) codes lengths ->
  length (compose codes offset) = list_sum lengths.
Proof.
  move=> H. elim: H offset; [done|].
  move=> c l {}codes {}lengths Hcl _ IH offset.
  by rewrite /= app_length Hcl IH.
Qed.

Arguments compose : simpl never.
Arguments plus : simpl never.

Definition INC X (offset : nat) : list mm_instr := [INC X].

Definition INC_len := 1.

Lemma INC_spec X v offset :
  (offset, INC X offset) // (offset, v) ->>
    (1 + offset, vec_change v X (S (vec_pos v X))).
Proof.
  exists 1. apply: in_sss_steps_S; [|by apply: in_sss_steps_0].
  eexists offset, nil, _, nil, v. rewrite /= Nat.add_0_r.
  by split; [|split;[|constructor]].
Qed.

Definition DEC X p (offset : nat) : list mm_instr := [DEC X p].

Definition DEC_len := 1.

Lemma DEC_spec X p v offset :
  (offset, DEC X p offset) // (offset, v) ->>
    match vec_pos v X with
    | 0 => (1 + offset, v)
    | S x => (p, vec_change v X x)
    end.
Proof.
  exists 1. apply: in_sss_steps_S; [|by apply: in_sss_steps_0].
  eexists offset, nil, _, nil, v. rewrite /= Nat.add_0_r.
  split; [done|split;[done|]].
  case EX: (v#>X) => [|n]; by constructor.
Qed.

(* jump to address p; A is auxiliary *)
Definition JMP_codes (A : counter) (p : nat) (offset : nat) : list (nat -> list mm_instr) :=
  INC A ::
  DEC A p :: [].

Definition JMP A p (offset : nat) := compose (JMP_codes A p offset) offset.

Definition JMP_len := INC_len+DEC_len.

Lemma JMP_spec A p v offset :
  (offset, JMP A p offset) // (offset, v) ->> (p, v).
Proof.
  rewrite /=. apply: (compose_sss_compute_trans 0). { by apply: INC_spec. }
  rewrite /=. apply: (compose_sss_compute_trans 1). { by apply: DEC_spec. }
  rewrite /= (vec_change_eq _ _ erefl) vec_change_idem vec_change_same.
  by apply sss_compute_refl.
Qed.

(* IF X = 0 then GOTO p else continue *)
Definition JZ_codes (X: counter) (p: nat) (offset: nat) : list (nat -> list mm_instr) :=
  DEC X ((DEC_len+JMP_len)+offset) ::
  JMP X p ::
  INC X :: [].

Definition JZ (X: counter) (p: nat) (offset: nat) := compose (JZ_codes X p offset) offset.

Definition JZ_len := DEC_len+JMP_len+INC_len.

Lemma JZ_spec X p v offset :
  (offset, JZ X p offset) // (offset, v) ->> (if vec_pos v X is 0 then p else JZ_len+offset, v).
Proof.
  case EX: (vec_pos v X) => [|n].
  - apply: (compose_sss_compute_trans 0). { by apply: DEC_spec. }
    rewrite EX. apply: (compose_sss_compute_trans 1). { by apply: JMP_spec. }
    by apply: sss_compute_refl.
  - apply: (compose_sss_compute_trans 0). { by apply: DEC_spec. }
    rewrite EX. apply: (compose_sss_compute_trans 2). { by apply: INC_spec. }
    apply: sss_compute_refl'. congr pair.
    by rewrite vec_change_idem vec_change_eq // vec_change_same'.
Qed.

(* X := 0 *)
Definition ZERO_codes (X: counter) (offset: nat) : list (nat -> list mm_instr) :=
  DEC X (offset) :: [].

Definition ZERO (X: counter) (offset: nat) := compose (ZERO_codes X offset) offset.

Definition ZERO_len := DEC_len.

Lemma ZERO_spec X v offset :
  (offset, ZERO X offset) // (offset, v) ->>
  (ZERO_len+offset, vec_change v X 0).
Proof.
  elim /(induction_ltof1 _ (fun w => vec_pos w X)) : v => v IH.
  case EX: (vec_pos v X) => [|n].
  { apply: (compose_sss_compute_trans 0). { by apply: DEC_spec. }
    rewrite EX (vec_change_same' EX).
    by apply: sss_compute_refl. }
  apply: (compose_sss_compute_trans 0). { by apply: DEC_spec. }
  rewrite EX. apply: sss_compute_trans. { apply: IH. by rewrite /= EX vec_change_eq. }
  apply: sss_compute_refl'. by rewrite vec_change_idem.
Qed.

(* Y := X + Y; X := 0 *)
Definition MOVE_codes (X: counter) (Y : counter) (offset: nat) : list (nat -> list mm_instr) :=
    JMP X ((JMP_len + INC_len) + offset) ::
    INC Y ::
    DEC X (JMP_len+offset) :: [].

Definition MOVE (X: counter) (Y : counter) (offset: nat) := compose (MOVE_codes X Y offset) offset.

Definition MOVE_len := JMP_len+INC_len+DEC_len.

Lemma MOVE_spec X Y v offset :
  X <> Y ->
  (offset, MOVE X Y offset) // (offset, v) ->>
  (MOVE_len+offset, vec_change (vec_change v Y (vec_pos v Y + vec_pos v X)) X 0).
Proof.
  move=> HXY.
  apply: (compose_sss_compute_trans 0). { by apply: JMP_spec. }
  elim /(induction_ltof1 _ (fun w => vec_pos w X)) : v => v IH.
  case EX: (vec_pos v X) => [|n].
  { apply: (compose_sss_compute_trans 2). { by apply: DEC_spec. }
    rewrite EX Nat.add_0_r vec_change_same (vec_change_same' EX).
    by apply: sss_compute_refl. }
  apply: (compose_sss_compute_trans 2). { by apply: DEC_spec. }
  rewrite EX. apply: (compose_sss_compute_trans 1). { by apply: INC_spec. }
  apply: sss_compute_trans. { apply: IH. rewrite /= !(vec_norm HXY) EX. lia. }
  apply: sss_compute_refl'. by rewrite !(vec_norm HXY) Nat.add_succ_comm.
Qed.

(* Y := X + Y; Z := X + Z; X := 0 *)
Definition MOVE2_codes (X Y Z: counter) (offset: nat) : list (nat -> list mm_instr) :=
    JMP X ((JMP_len+INC_len+INC_len) + offset) ::
    INC Y ::
    INC Z ::
    DEC X (JMP_len+offset) :: [].

Definition MOVE2 (X Y Z: counter) (offset: nat) := compose (MOVE2_codes X Y Z offset) offset.

Definition MOVE2_len := JMP_len+INC_len+INC_len+DEC_len.

Lemma MOVE2_spec X Y Z v offset :
  X <> Y -> X <> Z ->
  (offset, MOVE2 X Y Z offset) // (offset, v) ->>
  (MOVE2_len+offset, vec_change (vec_change (vec_change v Z (vec_pos v Z + vec_pos v X)) Y (vec_pos ((vec_change v Z (vec_pos v Z + vec_pos v X))) Y + vec_pos v X)) X 0).
Proof.
  move=> HXY HXZ.
  apply: (compose_sss_compute_trans 0). { by apply: JMP_spec. }
  elim /(induction_ltof1 _ (fun w => vec_pos w X)) : v => v IH.
  case EX: (vec_pos v X) => [|n].
  { apply: (compose_sss_compute_trans 3). { by apply: DEC_spec. }
    rewrite EX !Nat.add_0_r !vec_change_same (vec_change_same' EX).
    by apply: sss_compute_refl. }
  apply: (compose_sss_compute_trans 3). { by apply: DEC_spec. }
  rewrite EX. apply: (compose_sss_compute_trans 1). { by apply: INC_spec. }
  apply: (compose_sss_compute_trans 2). { by apply: INC_spec. }
  apply: sss_compute_trans. { apply: IH. by rewrite /= !(vec_norm HXY) !(vec_norm HXZ) EX. }
  apply: sss_compute_refl'. congr pair.
  have [<-|HYZ] := pos_eq_dec Y Z.
  - by rewrite !(vec_norm HXY) -!Nat.add_succ_comm.
  - do 2 rewrite ?(vec_norm HXY) ?(vec_norm HXZ) ?(vec_norm HYZ).
    by rewrite -!Nat.add_succ_comm.
Qed.

(* X := (X+X+1)*(2^Y); A := 0; Y := 0
   A is auxiliary *)
Definition PACK_codes (A X Y : counter) (offset: nat) : list (nat -> list mm_instr) :=
  ZERO A ::
  MOVE2 X A A ::
  INC A ::
  MOVE A X ::
  JMP A ((ZERO_len+MOVE2_len+INC_len+MOVE_len+JMP_len+MOVE2_len+MOVE_len)+offset) ::
  MOVE2 X A A ::
  MOVE A X ::
  DEC Y ((ZERO_len+MOVE2_len+INC_len+MOVE_len+JMP_len)+offset) :: [].

Definition PACK (A X Y : counter) (offset: nat) := compose (PACK_codes A X Y offset) offset.

Definition PACK_len := ZERO_len+MOVE2_len+INC_len+MOVE_len+JMP_len+MOVE2_len+MOVE_len+DEC_len.

Lemma PACK_len_spec A X Y offset : length (PACK A X Y offset) = PACK_len.
Proof. done. Qed.

Lemma PACK_spec A X Y v offset :
  let x := vec_pos v X in
  let y := vec_pos v Y in
  A <> X -> A <> Y -> X <> Y ->
  (offset, PACK A X Y offset) // (offset, v) ->>
    (PACK_len+offset, vec_change (vec_change (vec_change v X ((x+x+1) * (2 ^ y))) Y 0) A 0).
Proof.
  move=> /= /[dup] HX /nesym H'X /[dup] HY /nesym H'Y HXY.
  apply: (compose_sss_compute_trans 0). { by apply: ZERO_spec. }
  apply: (compose_sss_compute_trans 1). { by apply: MOVE2_spec. }
  apply: (compose_sss_compute_trans 2). { by apply: INC_spec. }
  apply: (compose_sss_compute_trans 3). { by apply: MOVE_spec. }
  apply: (compose_sss_compute_trans 4). { by apply: JMP_spec. }
  rewrite !(vec_norm HX) !Nat.add_0_l.
  have -> : S ((v#>X) + (v#>X)) = (v#>X) + (v#>X) + 1 by lia.
  move: ((v#>X) + (v#>X) + 1).
  elim /(induction_ltof1 _ (fun w => vec_pos w Y)) : v => v IH x.
  case EY: (vec_pos v Y) => [|n].
  { apply: (compose_sss_compute_trans 7). { by apply: DEC_spec. }
    rewrite !(vec_norm HY) !(vec_norm HXY) EY.
    apply: sss_compute_refl'. congr pair.
    by rewrite (vec_change_same' EY) /= Nat.mul_1_r. }
  apply: (compose_sss_compute_trans 7). { by apply: DEC_spec. }
  rewrite !(vec_norm HY) !(vec_norm HXY) EY.
  apply: (compose_sss_compute_trans 5). { by apply: MOVE2_spec. }
  apply: (compose_sss_compute_trans 6). { by apply: MOVE_spec. }
  do 2 rewrite ?(vec_norm HX) ?(vec_norm HY) ?(vec_norm HXY).
  apply: sss_compute_trans. { apply: IH. by rewrite /= !(vec_norm HY) EY. }
  apply: sss_compute_refl'. congr pair.
  rewrite ?(vec_norm HX) ?(vec_norm HY) ?(vec_norm HXY).
  rewrite /=. do 2 congr vec_change. lia.
Qed.

(* X := X/2 if X even goto p else continue *)
Definition HALF_codes (A X: counter) (p: nat) (offset: nat) : list (nat -> list mm_instr) :=
  ZERO A ::
  MOVE X A ::
  JMP A ((ZERO_len+MOVE_len+JMP_len+INC_len)+offset) ::
  INC X ::
  DEC A ((ZERO_len+MOVE_len+JMP_len+INC_len+DEC_len+JMP_len)+offset) ::
  JMP A p ::
  DEC A ((ZERO_len+MOVE_len+JMP_len)+offset) :: [].

Definition HALF (A X : counter) (p: nat) (offset: nat) := compose (HALF_codes A X p offset) offset.

Definition HALF_len := ZERO_len+MOVE_len+JMP_len+INC_len+DEC_len+JMP_len+DEC_len.

(* second component is true iff n is even *)
Fixpoint half (n: nat) : (nat * bool) :=
  match n with
  | 0 => (0, true)
  | S n' =>
      match half n' with
      | (m, b) => if b then (m, false) else (S m, true)
      end
  end.

Lemma half_spec n :
  let '(m, b) := half n in n = (if b then 0 else 1) + m + m.
Proof. elim: n => [|n] /=; [done|case: (half n) => ? []; lia]. Qed.

Lemma half_spec_odd n : half ((n + n + 1) * 2 ^ 0) = (n, false).
Proof.
  have := half_spec ((n + n + 1) * 2 ^ 0).
  case: (half _) => m [] /= *; congr pair; lia.
Qed.

Lemma half_spec_even n m : half ((n + n + 1) * 2 ^ (S m)) = ((n + n + 1) * 2 ^ m, true).
Proof.
  have := half_spec ((n + n + 1) * 2 ^ (S m)).
  case: (half _) => k []; rewrite /= => ?; congr pair; lia.
Qed.

Lemma HALF_spec A X p v offset :
  let x := vec_pos v X in
  A <> X ->
  (offset, HALF A X p offset) // (offset, v) ->>
    let '(m, b) := half x in (if b then p else HALF_len + offset, vec_change (vec_change v X m) A 0).
Proof.
  move=> /= /[dup] HX /nesym  H'X.
  apply: (compose_sss_compute_trans 0). { by apply: ZERO_spec. }
  apply: (compose_sss_compute_trans 1). { by apply: MOVE_spec. }
  apply: (compose_sss_compute_trans 2). { by apply: JMP_spec. }
  rewrite !(vec_norm HX) Nat.add_0_l.
  suff: forall w, (offset, HALF A X p offset) //
    (ZERO_len+MOVE_len+JMP_len+INC_len+offset, w) ->>
    (let '(m, b) := half (vec_pos w A) in (if b then p else HALF_len + offset,
      vec_change (vec_change w X (vec_pos w X+m)) A 0)).
  { move=> H. apply: sss_compute_trans; [apply: H|].
    apply: sss_compute_refl'. rewrite !(vec_norm HX).
    case: (half _) => [? ?]. by rewrite !(vec_norm HX). }
  elim /(induction_ltof1 _ (fun w => vec_pos w A)) => {}v IH.
  case EA: (vec_pos v A) => [|[|n]].
  - apply: (compose_sss_compute_trans 4). { by apply: DEC_spec. }
    rewrite EA. apply: (compose_sss_compute_trans 5). { by apply: JMP_spec. }
    rewrite Nat.add_0_r !(vec_norm HX) (vec_change_same' EA).
    by apply: sss_compute_refl.
  - apply: (compose_sss_compute_trans 4). { by apply: DEC_spec. }
    rewrite EA. apply: (compose_sss_compute_trans 6). { by apply: DEC_spec. }
    rewrite Nat.add_0_r !(vec_norm HX).
    by apply: sss_compute_refl.
  - apply: (compose_sss_compute_trans 4). { by apply: DEC_spec. }
    rewrite EA. apply: (compose_sss_compute_trans 6). { by apply: DEC_spec. }
    rewrite vec_change_eq //. apply: (compose_sss_compute_trans 3). { by apply: INC_spec. }
    apply: sss_compute_trans. { apply: IH. rewrite /= !(vec_norm HX) EA. lia. }
    apply: sss_compute_refl'. rewrite !(vec_norm HX) /=.
    case: (half n) => [m []]; congr pair; by rewrite !(vec_norm HX) Nat.add_succ_comm.
Qed.

(* IF X = (n+n+1)*2^m THEN X := n AND Y := m
   A is auxiliary *)
Definition UNPACK_codes (A X Y: counter) (offset: nat) : list (nat -> list mm_instr) :=
  JZ X 0 ::
  ZERO Y ::
  JMP A ((JZ_len+ZERO_len+JMP_len+INC_len)+offset) ::
  INC Y ::
  HALF A X ((JZ_len+ZERO_len+JMP_len)+offset) :: [].

Definition UNPACK (A X Y: counter) (offset: nat) := compose (UNPACK_codes A X Y offset) offset.

Definition UNPACK_len := JZ_len+ZERO_len+JMP_len+INC_len+HALF_len.

Lemma UNPACK_spec {A X Y m n v offset} :
  let x := vec_pos v X in
  x = (n + n + 1) * (2 ^ m) ->
  A <> X -> A <> Y -> X <> Y ->
  (offset, UNPACK A X Y offset) // (offset, v) ->>
    (UNPACK_len + offset, vec_change (vec_change (vec_change v X n) Y m) A 0).
Proof.
  move=> /= H'X HX HY HXY.
  apply: (compose_sss_compute_trans 0). { by apply: JZ_spec. }
  have ->: vec_pos v X = S (vec_pos v X - 1).
  { rewrite H'X. have := Nat.pow_nonzero 2 m. lia. }
  apply: (compose_sss_compute_trans 1). { by apply: ZERO_spec. }
  apply: (compose_sss_compute_trans 2). { by apply: JMP_spec. }
  suff: forall w, vec_pos w X = (n + n + 1) * 2 ^ m ->
    (offset, UNPACK A X Y offset) //
    ((JZ_len+ZERO_len+JMP_len+INC_len) + offset, w) ->>
    (UNPACK_len + offset, vec_change (vec_change (vec_change w X n) Y (m+vec_pos w Y)) A 0).
  { move=> H. apply: sss_compute_trans. { apply: H. by rewrite !(vec_norm HXY). }
    apply: sss_compute_refl'. congr pair. by rewrite !(vec_norm HXY) Nat.add_0_r. }
  elim: m {H'X}.
  { move=> w H'X.
    apply: (compose_sss_compute_trans 4). { by apply: HALF_spec. }
    rewrite H'X half_spec_odd Nat.add_0_l !(vec_norm HXY).
    by apply: sss_compute_refl. }
  move=> m IH w H'X.
  apply: (compose_sss_compute_trans 4). { by apply: HALF_spec. }
  rewrite H'X half_spec_even.
  apply: (compose_sss_compute_trans 3). { by apply: INC_spec. }
  apply: sss_compute_trans. { apply: IH. by rewrite !(vec_norm HXY) !(vec_norm HX). }
  apply: sss_compute_refl'. congr pair.
  do ? rewrite ?(vec_norm HXY) ?(vec_norm HX) ?(vec_norm HY).
  by rewrite Nat.add_succ_comm.
Qed.

Lemma UNPACK0_spec {A X Y v offset} :
  vec_pos v X = 0 ->
  (offset, UNPACK A X Y offset) // (offset, v) ->> (0, v).
Proof.
  move=> H'X.
  apply: (compose_sss_compute_trans 0). { by apply: JZ_spec. }
  rewrite H'X. by apply: sss_compute_refl.
Qed.

End FixCounters.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(***********************************************************************
    Proof of Bertrand's conjecture: Product.v
                                         Laurent.Thery@inria.fr (2002)
  *********************************************************************)
Require Import ZArith.
Require ZArithRing.
Require Export Aux.
Require Export Iterator.
Require Export ZProgression.
(* *  	Iterated Product:
   (Zprod n m f) = f(n).f(n+1)...f(m)*)
Open Scope Z_scope.

Definition Zprod :=
   fun n m f =>
   if Zle_bool n m
     then iter 1 f Zmult (progression Zsucc n (Zabs_nat ((1 + m) - n)))
     else iter 1 f Zmult (progression Zpred n (Zabs_nat ((1 + n) - m))).
Hint Unfold Zprod .

Lemma Zprod_nn: forall (n : Z) (f : Z ->  Z),  Zprod n n f = f n.
intros n f; unfold Zprod; rewrite Zle_bool_refl.
replace ((1 + n) - n) with 1; auto with zarith.
simpl; ring.
Qed.

Theorem permutation_rev: forall (A:Set) (l : list A),  permutation (rev l) l.
intros a l; elim l; simpl; auto.
intros a1 l1 Hl1.
apply permutation_trans with (cons a1 (rev l1)); auto.
change (permutation (rev l1 ++ (a1 :: nil)) (app (cons a1 nil) (rev l1))); auto.
Qed.

Lemma Zprod_swap: forall (n m : Z) (f : Z ->  Z),  Zprod n m f = Zprod m n f.
intros n m f; unfold Zprod.
generalize (Zle_cases n m) (Zle_cases m n); case (Zle_bool n m);
 case (Zle_bool m n); auto with arith.
intros; replace n with m; auto with zarith.
3:intros H1 H2; contradict H2; auto with zarith.
intros H1 H2; apply iter_permutation; auto with zarith.
apply permutation_trans
     with (rev (progression Zsucc n (Zabs_nat ((1 + m) - n)))).
apply permutation_sym; apply permutation_rev.
rewrite Zprogression_opp; auto with zarith.
replace (n + Z_of_nat (pred (Zabs_nat ((1 + m) - n)))) with m; auto.
replace (Zabs_nat ((1 + m) - n)) with (S (Zabs_nat (m - n))); auto with zarith.
simpl.
rewrite Z_of_nat_Zabs_nat; auto with zarith.
replace ((1 + m) - n) with (1 + (m - n)); auto with zarith.
cut (0 <= m - n); auto with zarith; unfold Zabs_nat.
case (m - n); auto with zarith.
intros p; case p; simpl; auto with zarith.
intros p1 Hp1; rewrite nat_of_P_xO; rewrite nat_of_P_xI;
 rewrite nat_of_P_succ_morphism.
simpl; rewrite <- plus_n_Sm; auto.
intros p H3; contradict H3; auto with zarith.
intros H1 H2; apply iter_permutation; auto with zarith.
apply permutation_trans
     with (rev (progression Zsucc m (Zabs_nat ((1 + n) - m)))).
rewrite Zprogression_opp; auto with zarith.
replace (m + Z_of_nat (pred (Zabs_nat ((1 + n) - m)))) with n; auto.
replace (Zabs_nat ((1 + n) - m)) with (S (Zabs_nat (n - m))); auto with zarith.
simpl.
rewrite Z_of_nat_Zabs_nat; auto with zarith.
replace ((1 + n) - m) with (1 + (n - m)); auto with zarith.
cut (0 <= n - m); auto with zarith; unfold Zabs_nat.
case (n - m); auto with zarith.
intros p; case p; simpl; auto with zarith.
intros p1 Hp1; rewrite nat_of_P_xO; rewrite nat_of_P_xI;
 rewrite nat_of_P_succ_morphism.
simpl; rewrite <- plus_n_Sm; auto.
intros p H3; contradict H3; auto with zarith.
apply permutation_rev.
Qed.

Lemma Zprod_split_up:
 forall (n m p : Z) (f : Z ->  Z),
 ( n <= m < p ) ->  Zprod n p f = Zprod n m f * Zprod (m + 1) p f.
intros n m p f [H H0].
case (Zle_lt_or_eq _ _ H); clear H; intros H.
unfold Zprod; (repeat rewrite Zle_imp_le_bool); auto with zarith.
assert (H1: n < p).
apply Zlt_trans with ( 1 := H ); auto with zarith.
assert (H2: m < 1 + p).
apply Zlt_trans with ( 1 := H0 ); auto with zarith.
assert (H3: n < 1 + m).
apply Zlt_trans with ( 1 := H ); auto with zarith.
assert (H4: n < 1 + p).
apply Zlt_trans with ( 1 := H1 ); auto with zarith.
replace (Zabs_nat ((1 + p) - (m + 1)))
     with (minus (Zabs_nat ((1 + p) - n)) (Zabs_nat ((1 + m) - n))).
apply iter_progression_app; auto with zarith.
apply inj_le_inv.
(repeat rewrite Z_of_nat_Zabs_nat); auto with zarith.
rewrite next_n_Z; auto with zarith.
rewrite Z_of_nat_Zabs_nat; auto with zarith.
apply inj_eq_inv; auto with zarith.
rewrite inj_minus1; auto with zarith.
(repeat rewrite Z_of_nat_Zabs_nat); auto with zarith.
apply inj_le_inv.
(repeat rewrite Z_of_nat_Zabs_nat); auto with zarith.
subst m.
rewrite Zprod_nn; auto with zarith.
unfold Zprod; generalize (Zle_cases n p); generalize (Zle_cases (n + 1) p);
 case (Zle_bool n p); case (Zle_bool (n + 1) p); auto with zarith.
intros H1 H2.
replace (Zabs_nat ((1 + p) - n)) with (S (Zabs_nat (p - n))); auto with zarith.
replace (n + 1) with (Zsucc n); auto with zarith.
replace ((1 + p) - Zsucc n) with (p - n); auto with zarith.
apply inj_eq_inv; auto with zarith.
rewrite inj_S; (repeat rewrite Z_of_nat_Zabs_nat); auto with zarith.
Qed.

Lemma Zprod_S_left:
 forall (n m : Z) (f : Z ->  Z), n < m ->  Zprod n m f = f n * Zprod (n + 1) m f.
intros n m f H; rewrite (Zprod_split_up n n m f); auto with zarith.
rewrite Zprod_nn; auto with zarith.
Qed.

Lemma Zprod_S_right:
 forall (n m : Z) (f : Z ->  Z),
 n <= m ->  Zprod n (m + 1) f = Zprod n m f * f (m + 1).
intros n m f H; rewrite (Zprod_split_up n m (m + 1) f); auto with zarith.
rewrite Zprod_nn; auto with zarith.
Qed.

Lemma Zprod_split_down:
 forall (n m p : Z) (f : Z ->  Z),
 ( p < m <= n ) ->  Zprod n p f = Zprod n m f * Zprod (m - 1) p f.
intros n m p f [H H0].
case (Zle_lt_or_eq p (m - 1)); auto with zarith; intros H1.
pattern m at 1; replace m with ((m - 1) + 1); auto with zarith.
repeat rewrite (Zprod_swap n).
rewrite (Zprod_swap (m - 1)).
rewrite Zmult_comm.
apply Zprod_split_up; auto with zarith.
subst p.
repeat rewrite (Zprod_swap n).
rewrite Zprod_nn.
unfold Zprod; (repeat rewrite Zle_imp_le_bool); auto with zarith.
replace (Zabs_nat ((1 + n) - (m - 1))) with (S (Zabs_nat (n - (m - 1)))).
rewrite Zmult_comm.
replace (Zabs_nat ((1 + n) - m)) with (Zabs_nat (n - (m - 1))); auto with zarith.
pattern m at 4; replace m with (Zsucc (m - 1)); auto with zarith.
apply f_equal with ( f := Zabs_nat ); auto with zarith.
apply inj_eq_inv; auto with zarith.
rewrite inj_S.
(repeat rewrite Z_of_nat_Zabs_nat); auto with zarith.
Qed.

Lemma Zprod_ext:
 forall (n m : Z) (f g : Z ->  Z),
 n <= m ->
 (forall (x : Z), ( n <= x <= m ) ->  f x = g x) ->  Zprod n m f = Zprod n m g.
intros n m f g HH H.
unfold Zprod; auto.
unfold Zprod; (repeat rewrite Zle_imp_le_bool); auto with zarith.
apply iter_ext; auto with zarith.
intros a H1; apply H; auto; split.
apply Zprogression_le_init with ( 1 := H1 ).
cut (a < Zsucc m); auto with zarith.
replace (Zsucc m) with (n + Z_of_nat (Zabs_nat ((1 + m) - n))); auto with zarith.
apply Zprogression_le_end; auto with zarith.
rewrite Z_of_nat_Zabs_nat; auto with zarith.
Qed.

Lemma Zprod_mult:
 forall (n m : Z) (f g : Z ->  Z),
  Zprod n m f * Zprod n m g = Zprod n m (fun (i : Z) => f i * g i).
intros n m f g; unfold Zprod; case (Zle_bool n m); apply iter_comp;
 auto with zarith.
Qed.

Lemma inv_Zprod:
 forall (P : Z ->  Prop) (n m : Z) (f : Z ->  Z),
 n <= m ->
 P 1 ->
 (forall (a b : Z), P a -> P b ->  P (a * b)) ->
 (forall (x : Z), ( n <= x <= m ) ->  P (f x)) ->  P (Zprod n m f).
intros P n m f HH H H0 H1.
unfold Zprod; rewrite Zle_imp_le_bool; auto with zarith; apply iter_inv; auto.
intros x H3; apply H1; auto; split.
apply Zprogression_le_init with ( 1 := H3 ).
cut (x < Zsucc m); auto with zarith.
replace (Zsucc m) with (n + Z_of_nat (Zabs_nat ((1 + m) - n))); auto with zarith.
apply Zprogression_le_end; auto with zarith.
rewrite Z_of_nat_Zabs_nat; auto with zarith.
Qed.

Lemma Zprod_pred:
 forall (n m : Z) (f : Z ->  Z),
  Zprod n m f = Zprod (n + 1) (m + 1) (fun (i : Z) => f (Zpred i)).
intros n m f.
unfold Zprod.
generalize (Zle_cases n m); generalize (Zle_cases (n + 1) (m + 1));
 case (Zle_bool n m); case (Zle_bool (n + 1) (m + 1)); auto with zarith.
replace ((1 + (m + 1)) - (n + 1)) with ((1 + m) - n); auto with zarith.
intros H1 H2; cut (exists c , c = Zabs_nat ((1 + m) - n) ).
intros [c H3]; rewrite <- H3.
generalize n; elim c; auto with zarith; clear H1 H2 H3 c n.
intros c H n; simpl; (apply f_equal2 with ( f := Zmult ); auto with zarith).
apply f_equal with ( f := f ); unfold Zpred; auto with zarith.
replace (Zsucc (n + 1)) with (Zsucc n + 1); auto with zarith.
exists (Zabs_nat ((1 + m) - n)); auto.
replace ((1 + (n + 1)) - (m + 1)) with ((1 + n) - m); auto with zarith.
intros H1 H2; cut (exists c , c = Zabs_nat ((1 + n) - m) ).
intros [c H3]; rewrite <- H3.
generalize n; elim c; auto with zarith; clear H1 H2 H3 c n.
intros c H n; simpl; (apply f_equal2 with ( f := Zmult ); auto with zarith).
apply f_equal with ( f := f ); unfold Zpred; auto with zarith.
replace (Zpred (n + 1)) with (Zpred n + 1); auto with zarith.
unfold Zpred; auto with zarith.
exists (Zabs_nat ((1 + n) - m)); auto.
Qed.
Hint Unfold Zprod .

Theorem Zprod_c:
 forall (c p q : Z), p <= q ->  Zprod p q (fun x => c) = Zpower c ((1 + q) - p).
intros c p q Hq; unfold Zprod.
rewrite Zle_imp_le_bool; auto with zarith.
pattern ((1 + q) - p) at 2; rewrite <- Z_of_nat_Zabs_nat; auto with zarith.
cut (exists r , r = Zabs_nat ((1 + q) - p) );
 [intros [r H1]; rewrite <- H1 | exists (Zabs_nat ((1 + q) - p))]; auto.
generalize p; elim r; auto with zarith.
intros n H p0; replace (Z_of_nat (S n)) with (Z_of_nat n + 1); auto with zarith.
rewrite Zpower_exp; simpl; auto with zarith.
rewrite (Zmult_comm c).
apply f_equal2 with ( f := Zmult ); auto with zarith.
rewrite Zpower_pos_nat; simpl.
unfold nat_of_P; unfold Zpower_nat; simpl; auto with zarith.
rewrite inj_S; auto with zarith.
Qed.

Theorem Zprod_Zprod_f:
 forall (i j k l : Z) (f : Z -> Z ->  Z),
 i <= j ->
 k < l ->
  Zprod i j (fun x => Zprod k (l + 1) (fun y => f x y)) =
  Zprod i j (fun x => Zprod k l (fun y => f x y) * f x (l + 1)).
intros; apply Zprod_ext; intros; auto with zarith.
rewrite Zprod_S_right; auto with zarith.
Qed.

Theorem Zprod_com:
 forall (i j k l : Z) (f : Z -> Z ->  Z),
  Zprod i j (fun x => Zprod k l (fun y => f x y)) =
  Zprod k l (fun y => Zprod i j (fun x => f x y)).
intros; unfold Zprod; case (Zle_bool i j); case (Zle_bool k l); apply iter_com;
 auto with zarith.
Qed.

Theorem Zprod_le:
 forall (n m : Z) (f g : Z ->  Z),
 n <= m ->
 (forall (x : Z), ( n <= x <= m ) ->  ( 0 <= f x <= g x )) ->
  ( 0 <= Zprod n m f <= Zprod n m g ).
intros n m f g Hl H.
unfold Zprod; rewrite Zle_imp_le_bool; auto with zarith.
unfold Zprod;
 cut
  (forall x,
   In x (progression Zsucc n (Zabs_nat ((1 + m) - n))) ->  ( 0 <= f x <= g x )).
elim (progression Zsucc n (Zabs_nat ((1 + m) - n))); simpl; auto with zarith.
intros a l H0 H1; split; auto with zarith.
apply Zmult_le_0_compat; auto with zarith.
case (H1 a); auto with zarith.
case H0; auto with zarith.
apply Zmult_le_compat; auto with zarith.
case (H1 a); auto with zarith.
case H0; auto with zarith.
case (H1 a); auto with zarith.
case H0; auto with zarith.
intros x H1; apply H; split.
apply Zprogression_le_init with ( 1 := H1 ); auto.
cut (x < m + 1); auto with zarith.
replace (m + 1) with (n + Z_of_nat (Zabs_nat ((1 + m) - n))); auto with zarith.
apply Zprogression_le_end; auto with zarith.
rewrite Z_of_nat_Zabs_nat; auto with zarith.
Qed.