Require Import List.

Import ListNotations.

Section RegExp.

Variable char : Type.

Definition c : Type := char.

Inductive r : Type :=
 | r_zero
 | r_unit
 | r_char (c5:c)
 | r_plus (r0:r) (r1:r)
 | r_times (r0:r) (r1:r)
 | r_star (r0:r).

Definition s : Type := list char.

Inductive s_in_regexp_lang : s -> r -> Prop :=
 | s_in_regexp_lang_unit :
     s_in_regexp_lang  []  r_unit
 | s_in_regexp_lang_char : forall (c5:c),
     s_in_regexp_lang  ( c5  :: [])  (r_char c5)
 | s_in_regexp_lang_plus_1 : forall (s5:s) (r1 r2:r),
     s_in_regexp_lang s5 r1 ->
     s_in_regexp_lang s5 (r_plus r1 r2)
 | s_in_regexp_lang_plus_2 : forall (s5:s) (r1 r2:r),
     s_in_regexp_lang s5 r2 ->
     s_in_regexp_lang s5 (r_plus r1 r2)
 | s_in_regexp_lang_times : forall (s5 s':s) (r1 r2:r),
     s_in_regexp_lang s5 r1 ->
     s_in_regexp_lang s' r2 ->
     s_in_regexp_lang  ( s5  ++  s' )  (r_times r1 r2)
 | s_in_regexp_lang_star_1 : forall (r:r),
     s_in_regexp_lang  []  (r_star r)
 | s_in_regexp_lang_star_2 : forall (s5 s':s) (r0:r),
     s_in_regexp_lang s5 r0 ->
     s_in_regexp_lang s' (r_star r0) ->
     s_in_regexp_lang  ( s5  ++  s' )  (r_star r0).

Inductive s_in_regexp_c_lang : s -> r -> c -> Prop :=
 | s_in_regexp_c_lang_cs : forall (s5:s) (r0:r) (c5:c),
     s_in_regexp_lang  (  ( c5  :: [])   ++  s5 )  r0 ->
     s_in_regexp_c_lang s5 r0 c5.

End RegExp.

Arguments r_zero [char].
Arguments r_unit [char].
Arguments r_char [char] _.
Arguments r_plus [char] _ _.
Arguments r_times [char] _ _.
Arguments r_star [char] _.


Require Export chapter08.

Theorem eight_is_beautiful'': beautiful 8.
Proof.
   Show Proof.
   apply b_sum with (n:=3) (m:=5).
   Show Proof.
   apply b_3.
   Show Proof.
   apply b_5.
   Show Proof.
Qed.

Theorem six_is_beautiful :
  beautiful 6.
Proof.
  apply b_sum with (n := 3) (m := 3).
  apply b_3. apply b_3.
Qed.

Definition six_is_beautiful' : beautiful 6 :=
  b_sum 3 3 b_3 b_3.

Theorem b_times2: forall n, beautiful n -> beautiful (2*n).
Proof.
  intros. simpl. apply b_sum. apply H. apply b_sum. apply H. apply b_0.
Qed.

Definition b_times2': forall n, beautiful n -> beautiful (2*n) :=
  fun (n : nat) => fun (e : beautiful n) => b_sum n (n + 0) e (b_sum n 0 e b_0).

Theorem and_example :
  (beautiful 0) /\ (beautiful 3).
Proof.
  apply conj.
   Case "left". apply b_0.
   Case "right". apply b_3. Qed.

Print and_example.

Definition conj_fact : forall P Q R, P /\ Q -> Q /\ R -> P /\ R :=
  fun (P Q R : Prop) (PAndQ : P /\ Q) (QAndR : Q /\ R) =>
    match PAndQ with
    | conj HP HQ1 => match QAndR with
                     | conj HQ2 HR => conj P R HP HR
                     end
    end.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor.
From Categories Require Import Cat.Cat.

Section NatTrans.
  Context {C C' : Category}.

(**
For categories C and C' and functors F : C -> C' and F' : C -> C', a natural
transformation N : F -> F' is a family of arrows 'Trans N' in the co-domain
category (here C') indexed by objects of the domain category (here C),
Trans N c : F _o c -> F' _o c.

In addition, for all arrows h : c → c' the following diagram must
commute (Trans_com):

#

             F _a h
F _o c ————————————————––> F _o c'
 |                          |
 |                          |
 |                          |
 | Trans N c                | Trans N c'
 |                          |
 |                          |
 ∨                          ∨
F' _o c ————————————————–> F' _o c'
            F' _a h

#
Trans_com_sym is the symmetric form of Trans_com.
*)
  Record NatTrans (F F' : (C –≻ C')%functor) :=
    {
      Trans (c : C) : ((F _o c) –≻ (F' _o c))%object%morphism;
      Trans_com {c c' : C} (h : (c –≻ c')%morphism) :
        ((Trans c') ∘ F _a h = F' _a h ∘ (Trans c))%morphism;
      Trans_com_sym {c c' : C} (h : (c –≻ c')%morphism) :
        (F' _a h ∘ (Trans c) = (Trans c') ∘ F _a h)%morphism
    }.

  Notation "F –≻ F'" := (NatTrans F F') : nattrans_scope.

  (** Two natural transformations are equal if their arrow families are.
      That is, commutative diagrams are assumed to be equal by
      proof irrelevance. *)
  Lemma NatTrans_eq_simplify {F F' : (C –≻ C')%functor}
        (N N' : (F –≻ F')%nattrans) : (@Trans _ _ N) = (@Trans _ _ N') -> N = N'.
  Proof.
    destruct N; destruct N'.
    basic_simpl.
    ElimEq.
    PIR; trivial.
  Qed.

End NatTrans.

Arguments Trans {_ _ _ _} _ _.
Arguments Trans_com {_ _ _ _} _ {_ _} _.
Arguments Trans_com_sym {_ _ _ _} _ {_ _} _.

Bind Scope nattrans_scope with NatTrans.

Notation "F –≻ F'" := (NatTrans F F') : nattrans_scope.

Local Open Scope nattrans_scope.

Section NatTrans_Compose.
  Context {C C' : Category}.

  (** Natural transformations are composable. The arrow family of the result is
      just the composition of corresponding components in each natural
      transformation. Graphically:
#

         F                            F
   C ———————————————–> D        C ———————————————–> D
           ||                           ||
           ||N                          ||
           ||                           ||
           \/                           ||
   C ———————————————–> D                || N' ∘ N
         G                              ||
           ||                           ||
           ||N'                         ||
           ||                           ||
           \/                           \/
   C ———————————————–> D        C ———————————————–> D
         H                            H

#

This kind of composition is sometimes also called vertical composition of
natural transformations.
*)
  Program Definition NatTrans_compose {F F' F'' : (C –≻ C')%functor}
          (tr : F –≻ F') (tr' : F' –≻ F'') : (F –≻ F'')%nattrans :=
    {|
      Trans := fun c : Obj => ((Trans tr' c) ∘ (Trans tr c)) % morphism
    |}.

  Next Obligation. (* Trans_com*)
  Proof.
    rewrite assoc.
    rewrite Trans_com.
    rewrite assoc_sym.
    rewrite Trans_com; auto.
  Qed.

  Next Obligation. (* Trans_com_sym *)
  Proof.
    symmetry.
    apply NatTrans_compose_obligation_1.
  Qed.

End NatTrans_Compose.

Notation "N ∘ N'" := (NatTrans_compose N' N) : nattrans_scope.

Section NatTrans_Props.
  Context {C C' : Category}.

  (** The composition of natural transformations is associative. *)
  Theorem NatTrans_compose_assoc {F G H I : (C –≻ C')%functor} (N : F –≻ G)
          (N' : G –≻ H) (N'' : H –≻ I)
    : ((N'' ∘ N') ∘ N = N'' ∘ (N' ∘ N))%nattrans
  .
  Proof.
    apply NatTrans_eq_simplify; cbn; auto.
  Qed.

  (** The identity natural transformation. The arrow family are just
      all identity arrows: *)
  Program Definition NatTrans_id (F : (C –≻ C')%functor) : F –≻ F :=
    {|
      Trans := fun x : Obj => id
    |}.

  Theorem NatTrans_id_unit_left {F G : (C –≻ C')%functor} (N : F –≻ G)
    : (NatTrans_id G) ∘ N = N.
  Proof.
    apply NatTrans_eq_simplify; cbn; auto.
  Qed.

  Theorem NatTrans_id_unit_right {F G : (C –≻ C')%functor} (N : F –≻ G)
    : N ∘ (NatTrans_id F) = N.
  Proof.
    apply NatTrans_eq_simplify; cbn; auto.
  Qed.

End NatTrans_Props.

Hint Resolve NatTrans_eq_simplify.


(* Software Foundations *)
(* Exercice 2 stars, override_same *)

Definition override {X: Type}(f: nat -> X) k v:=
  fun k' => if Nat.eqb k k' then v else f k'.

Lemma beq_nat_true: forall n m: nat, Nat.eqb n m = true -> n = m.
Admitted.

Theorem override_same : forall (X: Type) x1 k1 k2 (f: nat -> X ),
  f k1 = x1 -> (override f k1 x1) k2 = f k2.
Proof.
    intros. unfold override.
    destruct (Nat.eqb k1 k2) eqn: eqek1k2.
    apply beq_nat_true in eqek1k2. rewrite <- eqek1k2. rewrite H. reflexivity.
    reflexivity.
Qed.


Require Import ZArith ROmega.

(* Submitted by Xavier Urbain 18 Jan 2002 *)

Lemma lem1 :
 forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z.
Proof.
intros x y.
romega.
Qed.

(* Proposed by Pierre Crégut *)

Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z.
intro.
 romega.
Qed.

(* Proposed by Jean-Christophe Filliâtre *)

Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z.
Proof.
intros.
romega.
Qed.

(* Proposed by Jean-Christophe Filliâtre: confusion between an Omega *)
(* internal variable and a section variable (June 2001) *)

Section A.
Variable x y : Z.
Hypothesis H : (x > y)%Z.
Lemma lem4 : (x > y)%Z.
 romega.
Qed.
End A.

(* Proposed by Yves Bertot: because a section var, L was wrongly renamed L0 *)
(* May 2002 *)

Section B.
Variable R1 R2 S1 S2 H S : Z.
Hypothesis I : (R1 < 0)%Z -> R2 = (R1 + (2 * S1 - 1))%Z.
Hypothesis J : (R1 < 0)%Z -> S2 = (S1 - 1)%Z.
Hypothesis K : (R1 >= 0)%Z -> R2 = R1.
Hypothesis L : (R1 >= 0)%Z -> S2 = S1.
Hypothesis M : (H <= 2 * S)%Z.
Hypothesis N : (S < H)%Z.
Lemma lem5 : (H > 0)%Z.
 romega.
Qed.
End B.

(* From Nicolas Oury (BZ#180): handling -> on Set (fixed Oct 2002) *)
Lemma lem6 :
 forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z.
intros.
 romega.
Qed.

(* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *)
Require Import Omega.
Section C.
Parameter g : forall m : nat, m <> 0 -> Prop.
Parameter f : forall (m : nat) (H : m <> 0), g m H.
Variable n : nat.
Variable ap_n : n <> 0.
Let delta := f n ap_n.
Lemma lem7 : n = n.
 romega with nat.
Qed.
End C.

(* Problem of dependencies *)
Require Import Omega.
Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0.
intros.
romega with nat.
Qed.

(* Bug that what caused by the use of intro_using in Omega *)
Require Import Omega.
Lemma lem9 :
 forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p.
intros.
romega with nat.
Qed.

(* Check that the interpretation of mult on nat enforces its positivity *)
(* Submitted by Hubert Thierry (BZ#743) *)
(* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *)
Lemma lem10 : forall n m : nat, le n (plus n (mult n m)).
Proof.
intros; romega with nat.
Qed.


(* Author: Christian Doczkal *)
Require Import ssreflect ssrbool eqtype ssrnat seq.
Require Import ssrfun choice fintype finset path fingraph bigop.
Require Import Relations.
Require Import tactics.

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

(** * A least fixed point operator for finType *)

Lemma iter_fix T (F : T -> T) x k n :
  iter k F x = iter k.+1 F x -> k <= n -> iter n F x = iter n.+1 F x.
Proof.
  move => e. elim: n. rewrite leqn0. by move/eqP<-.
  move => n IH. rewrite leq_eqVlt; case/orP; first by move/eqP<-.
  move/IH => /= IHe. by rewrite -!IHe.
Qed.

Section FixPoint.
  Variable T :finType.
  Definition set_op := {set T} -> {set T}.
  Definition mono (F : set_op)  := forall p q : {set T} , p \subset q -> F p \subset F q.

  Variable F : {set T} -> {set T}.
  Hypothesis monoF : mono F.

  Definition lfp := iter #|T|.+1 F set0.

  Lemma lfp_ind (P : {set T} -> Type) : P set0 -> (forall s , P s -> P (F s)) -> P lfp.
  Proof.
    move => P0 Pn. rewrite /lfp. set n := #|T|.+1. elim: n => //= n. exact: Pn.
  Qed.

  Lemma iterFsub n : iter n F set0 \subset iter n.+1 F set0.
  Proof.
    elim: n => //=; first by rewrite sub0set.
    move => n IH /=. by apply: monoF.
  Qed.

  Lemma iterFsubn m n : m <= n -> iter m F set0 \subset iter n F set0.
  Proof.
    elim : n; first by rewrite leqn0 ; move/eqP->.
    move => n IH. rewrite leq_eqVlt; case/orP; first by move/eqP<-.
    move/IH => /= IHe. apply: subset_trans; first apply IHe. exact:iterFsub.
  Qed.

  Lemma lfpE : lfp = F lfp.
  Proof.
    have: ~~ [ forall m : 'I_#|T|.+1 , iter m F set0 \proper iter m.+1 F set0 ].
      apply/negP => /forallP H.
      have P : forall n : 'I_#|T|.+1 , exists x : T , x \in iter n.+1 F set0 :\: iter n F set0.
        move => n ; move : (H n). case/properP => _ [x x1 x2]. exists x. by rewrite in_setD x1 x2.
      pose i (o : 'I_#|T|.+1) : T := xchoose (P o).
      have inj_i : injective i.
        move => o o'. rewrite /i => e. move : (xchooseP (P o)) (xchooseP (P o')).
        rewrite e {e}. set x := xchoose _. move : o o' x => [n pn] [m pm] x.
        rewrite !in_setD /=. case/andP => Hn1 Hn2. case/andP => Hm1 Hm2.
        case (ltngtP n m); last by move/eqP => e'; apply/eqP.
        - move => /iterFsubn /subsetP /(_ x Hn2). by rewrite (negbTE Hm1).
        - move => /iterFsubn /subsetP /(_ x Hm2). by rewrite (negbTE Hn1).
      move : (max_card (fun x => x \in codom i)). by rewrite (card_codom inj_i) /= !card_ord ltnn.
    rewrite negb_forall. case/existsP => x H.
    have A : iter x F set0 = iter x.+1 F set0.
      apply/eqP. by rewrite eqEproper iterFsub /= H.
    apply : iter_fix; first apply A. by case:x {H A} => *; auto.
  Qed.
End FixPoint.


Load ListCost.

Inductive permutation {A} : list A -> list A -> Prop :=
  | permutation_nil : permutation [] []
  | permutation_insert a l1 l2 l3 :
    permutation (l1 ++ l2) l3 ->
    permutation (l1 ++ a :: l2) (a :: l3).

Inductive permutation_small {A} : list A -> list A -> Prop :=
  | permutation_small_empty : permutation_small [] []
  | permutation_small_cons a l1 l2 : permutation_small l1 l2 -> permutation_small (a :: l1) (a :: l2)
  | permutation_small_swap a b l : permutation_small (b :: a :: l) (a :: b :: l)
  | permutation_small_trans l1 l2 l3 :
    permutation_small l1 l2 ->
    permutation_small l2 l3 ->
    permutation_small l1 l3.

Section Example.

Theorem permutation_example : permutation [5; 3; 1; 2; 4] [1; 2; 3; 4; 5].
Proof.
  replace [5; 3; 1; 2; 4] with ([5; 3] ++ 1 :: [2; 4]) by auto; apply permutation_insert; simpl.
  replace [5; 3; 2; 4] with ([5; 3] ++ 2 :: [4]) by auto; apply permutation_insert; simpl.
  replace [5; 3; 4] with ([5] ++ 3 :: [4]) by auto; apply permutation_insert; simpl.
  replace [5; 4] with ([5] ++ 4 :: []) by auto; apply permutation_insert; simpl.
  replace [5] with ([] ++ 5 :: []) by auto; apply permutation_insert; simpl.
  apply permutation_nil.
Qed.

Theorem permutation_example_move : permutation [5; 3; 1; 2; 4] [3; 1; 2; 4; 5].
Proof.
  replace [5; 3; 1; 2; 4] with ([5] ++ 3 :: [1; 2; 4]) by auto; apply permutation_insert; simpl.
  replace [5; 1; 2; 4] with ([5] ++ 1 :: [2; 4]) by auto; apply permutation_insert; simpl.
  replace [5; 2; 4] with ([5] ++ 2 :: [4]) by auto; apply permutation_insert; simpl.
  replace [5; 4] with ([5] ++ 4 :: []) by auto; apply permutation_insert; simpl.
  replace [5] with ([] ++ 5 :: []) by auto; apply permutation_insert; simpl.
  apply permutation_nil.
Qed.

Theorem permutation_example_sym : permutation [1; 2; 3; 4; 5] [5; 3; 1; 2; 4].
Proof.
  replace [1; 2; 3; 4; 5] with ([1; 2; 3; 4] ++ 5 :: []) by auto; apply permutation_insert; simpl.
  replace [1; 2; 3; 4] with ([1; 2] ++ 3 :: [4]) by auto; apply permutation_insert; simpl.
  replace [1; 2; 4] with ([] ++ 1 :: [2; 4]) by auto; apply permutation_insert; simpl.
  replace [2; 4] with ([] ++ 2 :: [4]) by auto; apply permutation_insert; simpl.
  replace [4] with ([] ++ 4 :: []) by auto; apply permutation_insert; simpl.
  apply permutation_nil.
Qed.

Theorem permutation_small_example : permutation_small [5; 3; 1; 2; 4] [1; 2; 3; 4; 5].
Proof.
  apply permutation_small_trans with [5; 1; 3; 2; 4].
  apply permutation_small_cons.
  apply permutation_small_swap.
  apply permutation_small_trans with [1; 5; 3; 2; 4].
  apply permutation_small_swap.
  apply permutation_small_cons.
  apply permutation_small_trans with [5; 2; 3; 4].
  apply permutation_small_cons.
  apply permutation_small_swap.
  apply permutation_small_trans with [2; 5; 3; 4].
  apply permutation_small_swap.
  apply permutation_small_cons.
  apply permutation_small_trans with [3; 5; 4].
  apply permutation_small_swap.
  apply permutation_small_cons.
  apply permutation_small_swap.
Qed.

End Example.

Theorem permutation_small_refl : forall {A} (l : list A), permutation_small l l.
Proof.
  induction l.
  - apply permutation_small_empty.
  - apply permutation_small_cons. auto.
Qed.

Theorem permutation_refl : forall {A} (l : list A), permutation l l.
Proof.
  induction l.
  - apply permutation_nil.
  - replace (a :: l) with ([] ++ a :: l) by auto. apply permutation_insert. auto.
Qed.

Theorem permutation_refl_long : forall {A} (l1 l2 : list A), l1 = l2 -> permutation l1 l2.
Proof.
  intros ? ? ? ->. apply permutation_refl.
Qed.

Lemma app_insert_split :
  forall {A} a (l1 l2 l3 l4 : list A),
  l1 ++ l2 = l3 ++ a :: l4 ->
    (exists l5 : list A, l3 = l1 ++ l5 /\ l2 = l5 ++ a :: l4) \/
    (exists l5 : list A, l4 = l5 ++ l2 /\ l1 = l3 ++ a :: l5).
Proof.
  intros ? a l1. induction l1; intros l2 l3 l4 ?.
  - destruct l3.
    + simpl in H. subst l2. left. exists []. auto.
    + rename a0 into b. simpl in H. subst l2. left. exists (b :: l3). auto.
  - rename a0 into b. destruct l3.
    + injection H as -> <-. right. exists l1. auto.
    + rename a0 into c. injection H as -> ?. specialize (IHl1 _ _ _ H). clear H.
      destruct IHl1 as [(l5 & -> & ->) | (l5 & -> & ->)].
      * left. exists l5. auto.
      * right. exists l5. auto.
Qed.

Lemma permutation_split:
  forall {A} a (l1 l2 l3 : list A),
  permutation l1 (l2 ++ a :: l3) ->
  exists l4 l5, l1 = l4 ++ a :: l5 /\ permutation (l4 ++ l5) (l2 ++ l3).
Proof.
  intros ? a l1 l2 l3 ?. remember (l2 ++ a :: l3) as l4. generalize dependent l2. induction H; intros l2' Heql4.
  - destruct l2'; discriminate.
  - rename a0 into b. destruct l2'.
    + injection Heql4 as <- ->. exists l1, l2. auto.
    + injection Heql4 as <- ->.
      specialize (IHpermutation l2' eq_refl).  destruct IHpermutation as (l9 & l10 & ? & ?).
      apply app_insert_split in H0. destruct H0 as [(l6 & -> & ->) | (l6 & -> & ->)].
      * rewrite app_assoc in H1. exists (l1 ++ b :: l6), l10. simpl. split.
        -- rewrite app_assoc. auto.
        -- rewrite app_assoc. simpl. apply permutation_insert. auto.
      * rewrite app_assoc in H. exists l9, (l6 ++ b :: l2). simpl. split.
        -- rewrite app_assoc. auto.
        -- rewrite <- app_assoc. apply permutation_insert. rewrite app_assoc. auto.
Qed.

Lemma permutation_move :
  forall {A} a (l1 l2 l3 : list A),
  permutation l1 (l2 ++ a :: l3) ->
  permutation l1 (a :: l2 ++ l3).
Proof.
  intros A a l1 l2 l3 ?.
  apply permutation_split in H. destruct H as (l4 & l5 & -> & ?).
  apply permutation_insert. auto.
Qed.

Theorem permutation_trans :
  forall {A} (l1 l2 l3 : list A),
  permutation l1 l2 ->
  permutation l2 l3 ->
  permutation l1 l3.
Proof.
  intros ? l1 l2 l3 ? ?.
  generalize dependent l2. generalize dependent l1. induction l3; intros l1 l2 H1 H2.
  - inversion H2. subst l2. auto.
  - inversion H2. subst a0 l2 l5. clear H2.
    apply permutation_move in H1.
    inversion H1. subst a0 l1 l6. apply permutation_insert. apply IHl3 with (l0 ++ l4); auto.
Qed.

Theorem permutation_sym :
  forall {A} (l1 l2 : list A),
  permutation l1 l2 ->
  permutation l2 l1.
Proof.
  intros ? l1 l2 ?. generalize dependent l1. induction l2; intros l1 ?.
  - inversion H. apply permutation_nil.
  - inversion H. subst a0 l1 l4. clear H. apply IHl2 in H2. clear IHl2.
    generalize dependent l3. generalize dependent l2. induction l0; intros l2 l3 ?.
    + simpl. simpl in H2. replace (a :: l2) with ([] ++ a :: l2) by auto.
      apply permutation_insert. auto.
    + rename a0 into b. simpl in H2. inversion H2. subst a0 l2 l5. simpl.
      replace (a :: l1 ++ b :: l4) with ((a :: l1) ++ b :: l4) by auto.
      apply permutation_insert. simpl. auto.
Qed.

Lemma permutation_move_back :
  forall {A} a (l1 l2 l3 : list A),
  permutation l1 (a :: l2 ++ l3) ->
  permutation l1 (l2 ++ a :: l3).
Proof.
  intros ? ? ? ? ? ?. apply permutation_trans with (a :: l2 ++ l3).
  - auto.
  - apply permutation_sym. apply permutation_move. apply permutation_refl.
Qed.

Theorem permutation_cons :
  forall {A} a (l1 l2 : list A),
  permutation l1 l2 ->
  permutation (a :: l1) (a :: l2).
Proof.
  intros ? ? ? ? ?. replace (a :: l1) with ([] ++ a :: l1) by auto. apply permutation_insert. auto.
Qed.

Theorem permutation_swap :
  forall {A} a b (l1 l2 : list A),
  permutation l1 l2 ->
  permutation (b :: a :: l1) (a :: b :: l2).
Proof.
  intros ? ? ? ? ? ?.
  replace (b :: a :: l1) with ([b] ++ a :: l1) by auto. apply permutation_insert.
  apply permutation_cons. auto.
Qed.

Theorem permutation_small_permutation :
  forall {A} (l1 l2 : list A),
  permutation_small l1 l2 <-> permutation l1 l2.
Proof.
  intros ? l1 l2. split.
  - intros ?. induction H.
    + apply permutation_nil.
    + replace (a :: l1) with ([] ++ a :: l1) by auto. apply permutation_insert; auto.
    + cut (permutation (b :: [a] ++ l) (a :: [b] ++ l)).
      * auto.
      * apply permutation_move. apply permutation_refl.
    + clear H H0. apply permutation_trans with l2; auto.
  - intros ?. induction H.
    + apply permutation_small_empty.
    + apply permutation_small_trans with (a :: l1 ++ l2).
      * clear H IHpermutation l3. induction l1.
        -- simpl. apply permutation_small_refl.
        -- rename a0 into b. simpl. apply permutation_small_trans with (b :: a :: l1 ++ l2).
           ++ apply permutation_small_cons. auto.
           ++ apply permutation_small_swap.
      * apply permutation_small_cons. auto.
Qed.

Theorem permutation_length : forall {A} (l1 l2 : list A), permutation l1 l2 -> length l2 = length l1.
Proof.
  intros ? ? ? ?. induction H.
  - auto.
  - rewrite length_app. rewrite length_app in IHpermutation. simpl. lia.
Qed.

Theorem list_forall_permutation :
  forall {A} f (l1 l2 : list A),
  permutation l1 l2 ->
  list_forall f l1 -> list_forall f l2.
Proof.
  intros ? ? ? ? ?. induction H; intros ?.
  - auto.
  - simpl. apply list_forall_app in H0. simpl in H0.
    rewrite list_forall_app in IHpermutation. intuition auto.
Qed.

Definition predicate_xor {A} f1 f2 := forall (x : A), f1 x = true /\ f2 x = false \/ f1 x = false /\ f2 x = true.

Theorem permutation_filter :
  forall {A} (l : list A) f1 f2,
  predicate_xor f1 f2 ->
  permutation (filter f1 l ++ filter (fun x => f2 x) l) l.
Proof.
  intros ? ? ? ? ?. induction l.
  - simpl. apply permutation_nil.
  - simpl. unfold predicate_xor in H. specialize (H a). destruct (f1 a), (f2 a).
    + intuition auto; discriminate.
    + simpl. apply permutation_cons. auto.
    + simpl. apply permutation_insert. auto.
    + intuition auto; discriminate.
Qed.

Theorem permutation_same_head_inversion :
  forall {A} a (l1 l2 : list A),
  permutation (a :: l1) (a :: l2) ->
  permutation l1 l2.
Proof.
  intros ? ? ? ? ?. inversion H. subst a0 l4. destruct l0.
  - injection H0 as ->. auto.
  - injection H0 as -> <-. apply permutation_sym. apply permutation_move_back. apply permutation_sym. auto.
Qed.

Theorem permutation_app_inversion :
  forall {A} (l1 l2 l3 l4 : list A),
  permutation (l1 ++ l3) (l2 ++ l4) ->
  permutation l1 l2 ->
  permutation l3 l4.
Proof.
  intros ? ? ? ? ? ? ?. generalize dependent l4. generalize dependent l3. induction H0; intros l3_ l4_ ?.
  - auto.
  - rewrite app_assoc in H. simpl in H.
    apply permutation_sym in H. apply permutation_move in H. apply permutation_sym in H.
    apply permutation_same_head_inversion in H. apply IHpermutation. rewrite app_assoc. auto.
Qed.

Theorem permutation_nil_inversion :
  forall {A} (l : list A),
  permutation l [] ->
  l = [].
Proof.
  intros ? ? ?. inversion H. auto.
Qed.

Theorem permutation_single_inversion :
  forall {A} a (l : list A),
  permutation l [a] ->
  l = [a].
Proof.
  intros ? ? ? ?. inversion H. subst a0 l3. apply permutation_nil_inversion in H2.
  apply app_nil_inversion in H2. destruct H2 as (-> & ->). auto.
Qed.

Theorem permutation_single_inversion' :
  forall {A} (a b : A),
  permutation [a] [b] ->
  a = b.
Proof.
  intros ? ? ? ?. apply permutation_single_inversion in H. injection H as ->. auto.
Qed.

Theorem permutation_cons_inversion :
  forall {A} a b (l1 l2 : list A),
  permutation (a :: l1) (b :: l2) ->
  a = b \/ list_in a l2 /\ list_in b l1.
Proof.
  intros ? ? ? ? ? ?. inversion H. subst a0 l4. destruct l0.
  - injection H0 as -> ->. left. auto.
  - injection H0 as -> <-. right. split.
    + apply permutation_sym in H2. inversion H2. subst a0 l5. apply list_in_insert.
    + apply list_in_insert.
Qed.

Theorem permutation_app :
  forall {A} (l1 l2 l3 l4 : list A),
  permutation l1 l2 ->
  permutation l3 l4 ->
  permutation (l1 ++ l3) (l2 ++ l4).
Proof.
  intros ? ?. induction l1; intros ? ? ? ? ?.
  - apply permutation_sym in H. apply permutation_nil_inversion in H. subst l2. auto.
  - apply permutation_sym in H. inversion H; subst a0 l1 l2; clear H.
    apply permutation_sym. rewrite app_assoc. simpl. apply permutation_insert.
    apply permutation_sym. rewrite <- app_assoc. apply IHl1.
    + apply permutation_sym. auto.
    + auto.
Qed.

Theorem permutation_app_trans :
  forall {A} (l1 l2 l3 l4 l5 : list A),
  permutation (l1 ++ l2) l5 ->
  permutation l1 l3 ->
  permutation l2 l4 ->
  permutation (l3 ++ l4) l5.
Proof.
  intros ? ?. induction l1; intros ? ? ? ? ? ? ?.
  - apply permutation_sym in H0. apply permutation_nil_inversion in H0. subst l3.
    simpl. simpl in H. eauto using permutation_sym, permutation_trans.
  - apply permutation_sym in H. apply permutation_move_back in H.
    apply permutation_split in H. destruct H as (l6 & l7 & -> & ?).
    apply permutation_sym in H0. inversion H0; subst a0 l1 l3; clear H0.
    apply permutation_move_back. rewrite app_assoc. simpl. apply permutation_insert.
    apply permutation_trans with (l8 ++ l2).
    + clear H. rewrite <- app_assoc. apply IHl1 with l2.
      * apply permutation_refl.
      * apply permutation_sym. auto.
      * auto.
    + apply permutation_sym. auto.
Qed.


(*
  Introduction
*)
Theorem my_first_proof : (forall A : Prop, A -> A).
Proof.
  intros A.
  intros proof_of_A.
  exact proof_of_A.
Qed.

(*
  Proofs with ->
*)
Theorem forward_small : (forall A B : Prop, A -> (A->B) -> B).
Proof.
  intros A.
  intros B.
  intros proof_of_A.
  intros A_implies_B.
  pose (proof_of_B := A_implies_B proof_of_A).
  exact proof_of_B.
Qed.

Theorem backward_small : (forall A B : Prop, A -> (A->B)->B).
Proof.
  intros A B.
  intros proof_of_A A_implies_B.
  refine (A_implies_B _).
    exact proof_of_A.
Qed.

Theorem backward_large : (forall A B C : Prop, A -> (A->B) -> (B->C) -> C).
Proof.
  intros A B C.
  intros proof_of_A A_implies_B B_implies_C.
  refine (B_implies_C _).
    refine (A_implies_B _).
      exact proof_of_A.
Qed.

Theorem backward_huge : (forall A B C : Prop, A -> (A->B) -> (A->B->C) -> C).
Proof.
  intros A B C.
  intros proof_of_A A_implies_B A_imp_B_imp_C.
  refine (A_imp_B_imp_C _ _).
    exact proof_of_A.

    refine (A_implies_B _).
      exact proof_of_A.
Qed.

Theorem forward_huge : (forall A B C : Prop, A -> (A->B) -> (A->B->C) -> C).
Proof.
  intros A B C.
  intros proof_of_A A_implies_B A_imp_B_imp_C.
  pose (proof_of_B := A_implies_B proof_of_A).
  pose (proof_of_C := A_imp_B_imp_C proof_of_A proof_of_B).
  exact proof_of_C.
Show Proof.
Qed.

(*
  Boolean
*)

(*Inductive False : Prop := .

Inductive True : Prop :=
  | I : True.*)

(*Inductive bool : Set :=
  | true : bool
  | false : bool.*)

Theorem True_can_be_proven : True.
  exact I.
Qed.

Definition not (A : Prop) := A -> False.

Notation "~ x" := (not x) : type_scope.

Theorem False_cannot_be_proven : ~False.
Proof.
  unfold not.
  intros proof_of_False.
  exact proof_of_False.
Qed.

Theorem False_cannot_be_proven_again : ~False.
Proof.
  intros proof_of_false.
  case proof_of_false.
Qed.

Theorem thm_true_imp_true : True -> True.
Proof.
  intros proof_of_True.
  exact I.
Qed.

Theorem thm_false_imp_true : False -> True.
Proof.
  intros proof_of_false.
  exact I.
Qed.

Theorem thm_false_imp_false : False -> False.
Proof.
  intros proof_of_false.
  case proof_of_false.
Qed.

Theorem thm_true_imp_false : ~(True -> False).
Proof.
  intros T_imp_F.
  refine (T_imp_F _).
   exact I.
Qed.

Theorem absurd2 : forall A C : Prop, A -> ~ A -> C.
Proof.
  intros A C.
  intros proof_of_A proof_that_A_cannot_be_proven.
  unfold not in proof_that_A_cannot_be_proven.
  pose (proof_of_False := proof_that_A_cannot_be_proven proof_of_A).
  case proof_of_False.
Qed.

Require Import Bool.

Theorem true_is_True : Is_true true.
Proof.
  simpl.
  exact I.
Qed.

Theorem not_eqb_true_false : ~(Is_true (eqb true false)).
Proof.
  simpl.
  exact False_cannot_be_proven.
Qed.

Theorem eqb_a_a : (forall a : bool, Is_true (eqb a a)).
Proof.
  intros a.
  case a.
    (*Suppose a is true*)
    simpl.
    exact I.
    (*Suppose a is false*)
    simpl.
    exact I.
Qed.

Theorem thm_eqb_a_t : (forall a:bool, (Is_true (eqb a true)) -> (Is_true a)).
Proof.
  intros a.
  case a.
    (*Suppose a is true*)
    simpl.
    intros proof_of_true.
    exact I.
    (*Suppose a is false*)
    simpl.
    intros proof_of_false.
    case proof_of_false.
Qed.

(*
  AND and OR
*)
Theorem left_or : (forall A B : Prop, A -> A \/ B).
Proof.
  intros A B.
  intros proof_of_A.
  pose (proof_of_A_or_B := or_introl proof_of_A : A \/ B).
  exact proof_of_A_or_B.
Qed.

Theorem right_or : (forall A B : Prop, B -> A \/ B).
Proof.
  intros A B.
  intros proof_of_B.
  refine (or_intror _).
    exact proof_of_B.
Qed.

Theorem or_commutes : (forall A B : Prop, A \/ B -> B \/ A).
Proof.
  intros A B.
  intros A_or_B.
  case A_or_B.
    intros proof_of_A.
    refine (or_intror _).
      exact proof_of_A.

    intros proof_of_B.
    refine (or_introl _).
      exact proof_of_B.
Qed.

Theorem both_and : (forall A B : Prop, A -> B -> A /\ B).
Proof.
  intros A B.
  intros proof_of_A proof_of_B.
  refine (conj _ _).
    exact proof_of_A.

    exact proof_of_B.
Qed.

Theorem and_commutes : (forall A B, A /\ B -> B /\ A).
Proof.
  intros A B.
  intros A_and_B.
  destruct A_and_B as [ proof_of_A proof_of_B ].
  refine (conj _ _).
    exact proof_of_B.
    exact proof_of_A.
  (*case A_and_B.
    intros proof_of_A proof_of_B.
    refine (conj _ _).
      exact proof_of_B.

      exact proof_of_A.*)
Qed.

Theorem orb_is_or : (forall a b, Is_true (orb a b) <-> Is_true a \/ Is_true b).
Proof.
  intros a b.
  unfold iff.
  refine (conj _ _).
    intros H.
    case a, b.
      (*T T*)
      simpl.
      refine (or_introl _).
        exact I.
      (*T F*)
      exact (or_introl I).
      (*F T*)
      exact (or_intror I).
      (*F F*)
      simpl in H.
      case H.
  intros H.
  case a, b.
    (*T T*)
    simpl.
    exact I.
    (*T F*)
    exact I.
    (*F T*)
    exact I.
    (*F F*)
    case H.
      (*H is (or_introl A)*)
      intros A.
      simpl in A.
      case A.

      (*H is (or_intror B)*)
      intros B.
      simpl in B.
      case B.
Qed.

Theorem andb_is_and : (forall a b, Is_true (andb a b) <-> Is_true a /\ Is_true b).
Proof.
  intros a b.
  unfold iff.
  refine (conj _ _).
    intros H.
    case a, b.
      (*T T*)
      simpl.
      exact (conj I I).
      (*T F*)
      simpl in H.
      case H.
      (*F T*)
      simpl in H.
      case H.
      (*F F*)
      simpl in H.
      case H.
     intros H.
     case a, b.
      (*T T*)
      simpl.
      exact I.
      (*T F*)
      simpl in H.
      destruct H as [A B].
      case B.
      (*F T*)
      simpl in H.
      destruct H as [A B].
      case A.
      (*F F*)
      simpl in H.
      destruct H as [A B].
      case A.
Qed.

(*
  Existence and Equality
*)
Definition basic_predicate :=
  (fun a => Is_true (andb a true)).

Theorem thm_exists_basics : (ex basic_predicate).
Proof.
  pose (witness := true).
  refine (ex_intro basic_predicate witness _).
    unfold basic_predicate.
    simpl.
    exact I.
Qed.

Theorem thm_exists_basics_again : (exists a, Is_true (andb a true)).
Proof.
  pose (witness := true).
  refine (ex_intro _ witness _).
    simpl.
    exact I.
Qed.

Theorem thm_forall_exists : (forall b, (exists a, Is_true(eqb a b))).
Proof.
  intros b.
  case b.
    (*b is True*)
    pose (witness := true).
    refine (ex_intro _ witness _).
      simpl.
      exact I.
    (*b is False*)
    pose (witness := false).
    refine (ex_intro _ witness _).
      simpl.
      exact I.
Qed.

Theorem thm_forall_exists_again : (forall b, (exists a, Is_true(eqb a b))).
Proof.
  intros b.
  refine (ex_intro _ b _).
  exact (eqb_a_a b).
Qed.

Theorem forall_exists : (forall P : Set->Prop, (forall x, ~(P x)) -> ~(exists x, P x)).
Proof.
  intros P.
  intros forall_x_not_Px.
  unfold not.
  intros exists_x_Px.
  destruct exists_x_Px as [witness proof_of_Pwitness].
  pose (not_Pwitness := forall_x_not_Px witness).
  unfold not in not_Pwitness.
  pose (proof_of_False := not_Pwitness proof_of_Pwitness).
  case proof_of_False.
Qed.


Require Import XR_Rmax.
Require Import XR_Rle_dec.
Require Import XR_Rle_lt_trans.
Require Import XR_Rnot_le_lt.

Local Open Scope R_scope.

Lemma Rmax_Rlt : forall x y z, Rmax x y < z <-> x < z /\ y < z.
Proof.
  intros x y z.
  split.
  {
    intro h.
    unfold Rmax in h.
    destruct (Rle_dec x y) as [ hl | hr ].
    {
      split.
      {
        apply Rle_lt_trans with y.
        { exact hl. }
        { exact h. }
      }
      { exact h. }
    }
    {
      split.
      { exact h. }
      {
        apply Rle_lt_trans with x.
        {
          left.
          apply Rnot_le_lt.
          exact hr.
        }
        { exact h. }
      }
    }
  }
  {
    intros [ hx hy ].
    unfold Rmax.
    destruct (Rle_dec x y) as [ hl | hr ].
    { exact hy. }
    { exact hx. }
  }
Qed.


From mathcomp Require Import all_ssreflect all_algebra ssrnum.

(** ITERATIVE : Turning a recursive algo in an iterative one                  *)

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

Import GRing.Theory Num.Theory Order.POrderTheory Num.ExtraDef Num.

Section iterative.

Local Open Scope ring_scope.

(* Arbitrary ring *)
Variable R : ringType.

Implicit Type p : {poly R}.

Variable left : nat -> {poly R} -> {poly R}.
Variable right : nat -> {poly R} -> {poly R}.
Variable merge : nat -> {poly R} -> {poly R} -> {poly R}.

Hypothesis size_left :
  forall n p, (size p <= 2 ^ n.+1 -> size (left n p) <= 2 ^ n)%N.
Hypothesis size_right :
  forall n p, (size p <= 2 ^ n.+1 -> size (right n p) <= 2 ^ n)%N.
Hypothesis size_merge :
  forall n (p q : {poly R}), (size p <= 2 ^ n -> size q <= 2 ^ n ->
               size (merge n p q) <= 2 ^ n.+1)%N.
Hypothesis merge0 : forall n, merge n 0 0 = 0.

Fixpoint algo (n : nat) (p : {poly R}) :=
  if n is n1.+1 then
    merge n1 (algo n1 (left n1 p)) (algo n1 (right n1 p))
  else (p`_0)%:P.

Lemma size_algo n p : (size (algo n p) <= 2 ^ n)%N.
Proof.
elim: n p => /= [|n IH] p; first by rewrite size_polyC; case: eqP.
by apply: size_merge; apply: IH.
Qed.

Fixpoint bottom (n : nat) (p : {poly R}) :=
  if n is n1.+1 then
    bottom n1 (left n1 p) + 'X^(2 ^n1) * bottom n1 (right n1 p)
  else (p`_0)%:P.

Lemma size_bottom n p : (size (bottom n p) <= 2 ^ n)%N.
Proof.
elim: n p => /= [|n IH] p; first by apply: size_polyC_leq1.
apply: leq_trans (size_add _ _) _.
rewrite geq_max (leq_trans (IH _)) //=; last by rewrite leq_exp2l.
apply: leq_trans (size_mul_leq _ _) _.
by rewrite size_polyXn expnS mul2n -addnn leq_add.
Qed.

Definition left_poly m (p : {poly R}) := \poly_(i < m) p`_i.
Definition right_poly m (p : {poly R}) := \poly_(i < m) p`_(i + m).

Lemma coef_left_poly m p i :
  (left_poly m p)`_ i = if (i < m)%N then p`_ i else 0.
Proof. by rewrite coef_poly. Qed.

Lemma coef_right_poly m p i :
  (right_poly m p)`_ i = if (i < m)%N then p`_ (i + m) else 0.
Proof. by rewrite coef_poly. Qed.

Lemma left_poly_id m p : (size p <= m)%N -> left_poly m p = p.
Proof.
move=> Hs; apply/polyP => i.
rewrite coef_poly; case: leqP => // Hs1.
by apply/sym_equal/nth_default/(leq_trans Hs).
Qed.

Lemma left_polyMXn m p : left_poly m ('X^ m * p) = 0.
Proof.
apply/polyP => i.
rewrite -[_ * p]commr_polyXn coef_poly coefMXn coef0.
by case: leqP.
Qed.

Lemma left_poly_add m (p q : {poly R}) :
  left_poly m (p + q) = left_poly m p + left_poly m q.
Proof.
apply/polyP => i; rewrite !(coefD, coef_poly).
by case: leqP; rewrite ?add0r.
Qed.

Lemma left_poly0 m : left_poly m 0 = 0.
Proof. by apply/polyP => i; rewrite coef_poly coef0 if_same. Qed.

Lemma left_poly_sum m n (p : 'I_n -> {poly R}) :
  left_poly m (\sum_(i < n) p i) = \sum_(i < n) (left_poly m (p i)).
Proof.
have F (q : nat -> _) :
       left_poly m (\sum_(i < n) q i) = \sum_(i < n) (left_poly m (q i)).
  elim: n {p}q => [|n IH] q; first by rewrite !big_ord0 left_poly0.
  by rewrite !big_ord_recr /= left_poly_add IH.
case: n p F => [|n] p F; first by rewrite !big_ord0 left_poly0.
have := F (fun x => p (inord x)).
under eq_bigr do rewrite inord_val.
by under [X in _ = X -> _]eq_bigr do rewrite inord_val.
Qed.

Lemma right_poly_size_0 m p : (size p <= m)%N -> right_poly m p = 0.
Proof.
move=> Hs; apply/polyP => i.
rewrite coef_poly coef0; case: leqP => // Hs1.
apply: nth_default.
by apply: leq_trans Hs (leq_addl _ _).
Qed.

Lemma right_polyMXn m p : (size p <= m)%N -> right_poly m ('X^ m * p) = p.
Proof.
move=> Hs; apply/polyP => i.
rewrite -[_ * p]commr_polyXn coef_poly coefMXn addnK.
rewrite [(_ + _ < _)%N]ltnNge leq_addl /=.
case: leqP => // mLi.
by apply/sym_equal/nth_default/(leq_trans _ mLi).
Qed.

Lemma right_poly_add m (p q : {poly R}) :
  right_poly m (p + q) = right_poly m p + right_poly m q.
Proof.
apply/polyP => i; rewrite !(coefD, coef_poly).
by case: leqP; rewrite ?add0r.
Qed.

Lemma right_poly0 m : right_poly m 0 = 0.
Proof. by apply/polyP => i; rewrite coef_poly !coef0 if_same. Qed.

Lemma right_poly_sum m n (p : 'I_n -> {poly R}) :
  right_poly m (\sum_(i < n) p i) = \sum_(i < n) (right_poly m (p i)).
Proof.
have F (q : nat -> _) :
       right_poly m (\sum_(i < n) q i) = \sum_(i < n) (right_poly m (q i)).
  elim: n {p}q => [|n IH] q; first by rewrite !big_ord0 right_poly0.
  by rewrite !big_ord_recr /= right_poly_add IH.
case: n p F => [|n] p F; first by rewrite !big_ord0 right_poly0.
have := F (fun x => p (inord x)).
under eq_bigr do rewrite inord_val.
by under [X in _ = X -> _]eq_bigr do rewrite inord_val.
Qed.

Lemma left_right_polyE m p :
  (size p <= m.*2)%N -> p = left_poly m p + right_poly m p * 'X^m.
Proof.
move=> sL2m; apply/polyP => i.
rewrite coefD coefMXn !coef_poly.
case: leqP => HlP; last by rewrite addr0.
case: leqP => H1lP; last by rewrite subnK ?add0r.
rewrite add0r nth_default //.
apply: leq_trans sL2m _.
by rewrite -addnn -leq_subRL.
Qed.

Fixpoint invariant_algo m n p q :=
  if m is m1.+1 then
  invariant_algo m1 n (left (m1 + n) p) (left_poly (2 ^ (m1 + n)) q) /\
  invariant_algo m1 n (right (m1 + n) p) (right_poly (2 ^ (m1 + n)) q)
  else q = algo n p.

Lemma invariantS_algo m n p q :
  invariant_algo m.+1 n p q <->
  invariant_algo m n (left (m + n) p) (left_poly (2 ^ (m + n)) q) /\
  invariant_algo m n (right (m + n) p) (right_poly (2 ^ (m + n)) q).
Proof. by []. Qed.

Lemma invariant_algo_bottom p m :
  invariant_algo m 0 p (bottom m p).
Proof.
elim: m p => //= m IH p.
rewrite addn0 left_poly_add right_poly_add; split.
  rewrite left_polyMXn addr0 left_poly_id; first by by apply: IH.
  by apply: size_bottom.

rewrite (right_poly_size_0 (size_bottom _ _)) add0r.
rewrite right_polyMXn; last by apply: size_bottom.
by apply: IH.
Qed.

Definition step m n (p : {poly R}) :=
  \sum_(l < 2 ^ m)
  let le := \poly_(i < 2 ^ n) p`_(i + l * 2 ^ n.+1) in
  let ri := \poly_(i < 2 ^ n) p`_(i + l * 2 ^ n.+1 + 2 ^ n) in
    merge n le ri * 'X^(l * 2 ^ n.+1).

Lemma size_step m n p : (size (step m n p) <= (2 ^ (m + n).+1))%N.
Proof.
apply: leq_trans (size_sum _ _ _) _.
apply/bigmax_leqP_seq => i _ _.
apply: leq_trans (size_mul_leq _ _ ) _.
rewrite size_polyXn addnS /=.
apply: leq_trans (leq_add (size_merge (size_poly _ _) (size_poly _ _))
                          (leqnn _)) _.
by rewrite -mulSn -addnS expnD leq_mul2r ltn_ord orbT.
Qed.

Lemma left_step m n (p : {poly R}) :
  (size p <= 2 ^ (m + n).+2)%N ->
  left_poly (2 ^ (m + n).+1) (step m.+1 n p) =
  step m n (left_poly (2 ^ (m + n).+1) p).
Proof.
move=> pLmn.
apply/polyP=> i; rewrite coef_left_poly.
case: leqP => [mnLi|iLmn].
  rewrite nth_default //.
  by apply: leq_trans (size_step _ _ _) _.
rewrite !coef_sum expnS mul2n -addnn big_split_ord /=.
rewrite [X in _ + X = _]big1 ?addr0 => [|j _]; last first.
  by rewrite coefMXn ifT // (leq_trans iLmn) // mulnDl -expnD addnS leq_addr.
apply: eq_bigr => j _.
congr ((merge _ _ _ * _) `_ _).
  apply/polyP => k; rewrite !coef_poly.
  case: leqP => // kLn.
  rewrite ifT // -[in X in (_ < X)%N]addnS expnD.
  rewrite -[X in (_ < X * _)%N]prednK ?expn_gt0 // mulSn -addSn.
  apply: leq_add.
    by apply: leq_trans kLn _; rewrite leq_exp2l.
  by rewrite leq_mul2r -ltnS prednK ?expn_gt0 // ltn_ord orbT.
apply/polyP => k; rewrite !coef_poly.
case: leqP => // kLn.
rewrite ifT // -[in X in (_ < X)%N]addnS expnD addnAC.
rewrite -[X in (_ < X * _)%N]prednK ?expn_gt0 // mulSn -addSn.
apply: leq_add.
  by rewrite expnS mul2n -addnn ltn_add2r.
by rewrite leq_mul2r -ltnS prednK ?expn_gt0 // ltn_ord orbT.
Qed.

Lemma right_step m n (p : {poly R}) :
  (size p <= 2 ^ (m + n).+2)%N ->
  right_poly (2 ^ (m + n).+1) (step m.+1 n p) =
  step m n (right_poly (2 ^ (m + n).+1) p).
Proof.
move=> pLmn.
apply/polyP=> i; rewrite coef_right_poly.
case: leqP => [mnLi|iLmn].
  rewrite nth_default //.
  by apply: leq_trans (size_step _ _ _) _.
rewrite !coef_sum expnS mul2n -addnn big_split_ord /=.
rewrite [X in X + _ = _]big1 ?add0r => [|j _]; last first.
  rewrite coefMXn ifN; last first.
    rewrite -leqNgt (leq_trans _ (leq_addl _ _)) //.
    by rewrite -addnS expnD leq_mul2r // ltnW ?orbT.
  rewrite nth_default // (leq_trans (size_merge _ _)) // ?size_poly //.
  rewrite leq_subRL (leq_trans _ (leq_addl _ _)) //.
    by rewrite addnC -mulSn -addnS expnD leq_mul2r ltn_ord orbT.
  by rewrite -addnS expnD leq_mul2r ltnW ?orbT // ltn_ord.
apply: eq_bigr => j _.
rewrite !coefMXn addnC mulnDl -expnD addnS ltn_add2l.
case: leqP => // jLi; rewrite subnDl.
congr ((merge _ _ _) `_ _).
  apply/polyP => k; rewrite !coef_poly.
  case: leqP => // kLn.
  rewrite ifT; first by rewrite addnAC addnA.
  rewrite -[in X in (_ < X)%N]addnS expnD.
  rewrite -[X in (_ < X * _)%N]prednK ?expn_gt0 // mulSn -addSn.
  apply: leq_add.
    by apply: leq_trans kLn _; rewrite leq_exp2l.
  by rewrite leq_mul2r -ltnS prednK ?expn_gt0 // ltn_ord orbT.
apply/polyP => k; rewrite !coef_poly.
case: leqP => // kLn.
rewrite ifT.
  rewrite -!addnA.
  congr (_ `_ (_ + _)); first by rewrite addnC !addnA.
rewrite addnAC -[in X in (_ < X)%N]addnS expnD.
rewrite -[X in (_ < X * _)%N]prednK ?expn_gt0 // mulSn -addSn.
apply: leq_add.
  by rewrite expnS mul2n -addnn ltn_add2r.
by rewrite leq_mul2r -ltnS prednK ?expn_gt0 // ltn_ord orbT.
Qed.

Lemma invariant_algo_step m n p p1 :
  (size p <= 2 ^ (m + n).+1)%N ->
  (size p1 <= 2 ^ (m + n).+1)%N ->
  invariant_algo m.+1 n p p1 ->
  invariant_algo m n.+1 p (step m n p1).
Proof.
elim: m n p p1; last first.
  move=> m IH n p p1 Hsp Hsp1/invariantS_algo[H2 H3].
  apply/invariantS_algo; split.
    rewrite addnS left_step //.
    apply: IH => //.
      by apply: leq_trans (size_left _) _.
    by rewrite size_poly.
  rewrite addnS right_step //.
  apply: IH => //.
    by apply: leq_trans (size_right _) _.
  by rewrite size_poly.
move=> n p p1; rewrite add0n => Hp Hp1 [H1 H2].
rewrite /= -H1 -H2.
rewrite /step big_ord1 mul0n mulr1.
by congr (merge _ _ _); apply/polyP=> i; rewrite !coef_poly !add0n !addn0.
Qed.

Fixpoint istep_aux m n p :=
  if m is m1.+1 then  istep_aux m1 n.+1 (step m1 n p) else p.

Definition istep n p := istep_aux n 0 (bottom n p).

Lemma istep_algo n p : (size p <= 2 ^ n)%N -> istep n p = algo n p.
Proof.
move=> Hs.
suff /(_ n 0%N): forall m1 n1 (p1 q1 : {poly R}),
    (size p1 <= 2 ^ (m1 + n1))%N ->
    (size q1 <= 2 ^ (m1 + n1))%N ->
    invariant_algo m1 n1 p1 q1 ->
    invariant_algo 0 (m1 + n1) p1 (istep_aux m1 n1 q1).
  rewrite addn0; apply => //; first by apply: size_bottom.
  by apply: invariant_algo_bottom.
elim => [//| m1 IH] n1 p1 q1 Hs1 Hs2 H1.
rewrite /istep_aux -/istep_aux addSnnS.
apply: IH; first by rewrite addnS.
  rewrite addnS.
  by apply: leq_trans (size_step _ _ _) _.
by apply: invariant_algo_step.
Qed.

End iterative.


Inductive day : Type :=
  | monday : day
  | tuesday : day
  | wednesday : day
  | thursday : day
  | friday : day
  | saturday : day
  | sunday : day.

Definition next_weekday (d:day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday friday).
Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.

Proof.
  simpl.
  reflexivity.
Qed.

Inductive bool : Type :=
| true  : bool
| false : bool.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | fase => true
  end.

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.

Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Example test_orb5: false || false || true = true.
Proof. simpl. reflexivity. Qed.

(*

  1d star. nandb.
  The function should return true if either or both of its inputs are false.
 *)

Definition nandb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => negb b2
  | false => true
  end.

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  (b1 && b2 && b3).

Example test_and31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.

Example test_and32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.

Example test_and33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.

Example test_and34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Check true.
(* ===> true : bool *)
Check (negb true).
(* ===> negb true : bool *)
Check negb.
(* ===> negb : bool -> bool *)

Inductive rgb : Type :=
| red : rgb
| green : rgb
| blue : rgb.

Inductive color : Type :=
  | black : color
  | white : color
  | primary : rgb -> color.

Definition monochrome (c : color) : bool :=
  match c with
  | black => true
  | white => false
  | primary p => false
  end.

Definition isred (c : color) : bool :=
  match c with
  | black => false
  | white => false
  | primary red => true
  | primary _ => false
  end.


Require Import Omega.
Require Import prelims.
Require Import repeater.
Require Import increasing_expanding.
Require Import inverse.

(*
==================================================================================
***************************** SECTION 5: COUNTDOWN  *****************************
==================================================================================
 *)

(*
 * Earlier we explored how to compute inverse of a function's repeater
 * solely from the function's own inverse, without directly computing the
 * repeater itself. The first lemma addresses this.
 *
 * We base the definition of "contractions" and "countdown" on this observation.
 * We also give a computation for countdown and prove several useful results
 * about it.
 *
 * The inverse of (repeater_from a F) is the minimum number of applications
 * of (inverse F) to the input to get a result less than or equal to a.
 *  This serves as motivation to contractions and countdown
 *)
Lemma upp_inv_repeater :
  forall a f F f',
    upp_inv_rel f F ->
    upp_inv_rel f' (repeater_from F a) ->
    (forall n m, f' n <= m <-> repeat f m n <= a).
Proof.
  intros a f F f' HfF Hf'F n m.
  rewrite (Hf'F m n). rewrite repeater_from_repeat.
  symmetry. apply (upp_inv_repeat m f F HfF a n).
Qed.

(* ****** CONTRACTIONS ****** *)

(* Definition of non-strict contractions *)
Definition contracting (f : nat -> nat) : Prop :=
  forall n, f n <= n.

(* Definition of strict expansion *)
Definition contract_strict_above (a : nat) (f : nat -> nat) : Prop :=
  contracting f /\ (forall n, a < n -> f n < n).

(* Upper inverses of expansions are contractions *)
Theorem upp_inv_expand_contract :
    forall f F, expanding F -> upp_inv_rel f F -> contracting f.
Proof.
  intros f F HF HfF n. rewrite (HfF n n). apply HF.
Qed.

(* Upper inverses of "strict-from-a expansions" themselves contract above a *)
Theorem upp_inv_expand_contract_strict :
  forall a f F,
    expand_strict_from a F ->
      upp_inv_rel f F -> contract_strict_above a f.
Proof.
  intros a f F HF HfF. destruct HF as [HF HaF].
  split.
  1: apply (upp_inv_expand_contract _ F HF HfF).
  intro n. destruct n; [omega|]. repeat rewrite <- lt_S_le.
  rewrite (HfF n _). apply HaF.
Qed.

(* ****** PROPERTIES OF CONTRACTIONS *******)

(* Repeat of contractions make the result smaller *)
Lemma repeat_contract :
  forall f n k l,
    contracting f -> k <= l -> repeat f l n <= repeat f k n.
Proof.
  intros f n k l Hf Hkl. induction l; inversion Hkl; trivial.
  apply IHl in H0.
  apply (Nat.le_trans _ (repeat f l n) _); [apply Hf | apply H0].
Qed.

(* Stricter version of the above *)
Lemma repeat_contract_strict :
  forall a f n k,
    contract_strict_above a f ->
    S a <= repeat f k n -> (S k) + repeat f (S k) n <= n.
Proof.
  intros a f n k Hf Han. destruct Hf as [Hf Haf]. induction k.
  1: simpl in Han; simpl; apply Haf in Han; omega.
  apply (Nat.le_trans _ (S k + repeat f (S k) n) _).
  - apply Haf in Han. simpl in Han; simpl. omega.
  - assert (S a <= repeat f k n) as Han0.
    { apply (Nat.le_trans _ (repeat f (S k) n) _); [apply Han|].
      apply Haf in Han. simpl. apply Hf. }
    apply IHk in Han0. omega.
Qed.

(* ****** COUNTDOWN ****** *)

(* Repeats "f" "k" times over, or until we go below "a".
   Outputs "min(k, min{l : repeat f l n <= a})" *)
Fixpoint cdn_wkr (f : nat -> nat) (a : nat)  (n k : nat) : nat :=
  match k with
  | 0    => 0
  | S k' => if (n <=? a) then 0 else
             S (cdn_wkr f a (f n) k')
  end.

(* Actual defintion. We give the worker a budget of "n" steps, which
   guarantees that it reaches below "a" before terminating *)
Definition countdown_to f a n := cdn_wkr f a n n.

(* ****** COUNTDOWN CORRECTNESS THEOREMS ****** *)

(* INITIAL VALUE THEOREM
   Basically countdown returns 0 if "n" is already below "a" *)
Theorem countdown_init :
  forall a f n k, n <= a -> cdn_wkr f a n k = 0.
Proof.
  intros a f n k Hna.
  destruct k; trivial.
  rewrite <- Nat.leb_le in Hna.
  unfold cdn_wkr. rewrite Hna; trivial.
Qed.

(* EXISTENCE OF COUNTDOWN VALUE LEMMA *)
(* Basically the existence of the countdown value for strict contractions
   It asserts there is a minimum "l" for which repeating "f" "l" times from "n"
   will give a result less than or equal to "a" *)
Lemma repeat_contract_strict_threshold :
  forall a f n,
    contract_strict_above a f -> a < n ->
    exists l, (S l) <= n /\ repeat f (S l) n <= a < repeat f l n.
Proof.
  intros a f n Hf Han. destruct Hf as [Hf Haf].
  remember (n - a) as m.
  destruct m; [omega|].
  assert (forall b, (a <= b) -> f (S b) <= b) as Ha
      by (intros b Hab; rewrite le_S_n_m; apply Haf; omega).
  generalize dependent a.
  induction m.
  - intros. exists 0.
    simpl. split; [|split];
    [|replace n with (S a) by omega; apply Ha|]; omega.
  - intros. destruct (IHm (S a)); try omega.
    + intros p Hp. apply Haf. omega.
    + intros b Hab. apply Ha. omega.
    + destruct H as [H0 H1]. destruct H1 as [Hl Hr]. inversion Hl.
      2: exists x; split; [apply H0 | omega].
      exists (S x). simpl. rewrite H1. split.
      2: split; [apply Ha|]; omega.
      apply (Nat.le_trans _ (S x + (repeat f (S x) n)) _);
                  [simpl; rewrite H1; omega|].
      apply (repeat_contract_strict a f n x);
      [split; assumption | omega].
Qed.

(* INTERMEDIATE STATE LEMMA
   Similar to the general recursion formula for "countdown_recurse_rel" *)
Theorem countdown_intermediate :
  forall a f n k i,
    contracting f ->
    S i <= k ->
    a < repeat f i n ->
    cdn_wkr f a n k =
    (S i) + cdn_wkr f a (repeat f (S i) n) (k - (S i)).
Proof.
  assert (forall a f n k,
             contracting f -> 1 <= k -> a < n ->
             cdn_wkr f a n k =
             1 + cdn_wkr f a (f n) (k - 1) ) as case_0.
  { simpl. intros a f n k Hf Hk Ha. destruct k; [omega|].
    replace (S k - 1) with k by omega. unfold cdn_wkr.
    rewrite Nat.lt_nge, <- Nat.leb_nle in Ha. rewrite Ha. trivial.
  }
  intros a f n k i Hf Hik Hai.
  induction i; [simpl; apply case_0; trivial|].
  rewrite IHi; [|omega|].
  2: apply (Nat.le_trans _ (repeat f (S i) n) _);
     [trivial | apply Hf].
  simpl. remember (f (repeat f i n)) as m. remember (k - S i) as l.
  replace (k - S(S i)) with (l - 1) by omega.
  rewrite case_0; [omega | trivial | omega|].
  simpl in Hai. rewrite Heqm. trivial.
Qed.

(* COUNTDOWN VS REPEAT THEOREM
   Correctness theorem for this countdown defintion *)
Theorem countdown_repeat :
  forall a f n k,
    contract_strict_above a f ->
      countdown_to f a n <= k <-> repeat f k n <= a.
Proof.
  intros a f n k Haf. inversion Haf as [Hf _].
  unfold countdown_to; split.
  - intro. rewrite not_lt. intro.
    rewrite (countdown_intermediate a f n n k Hf) in H;
      [omega | trivial..].
    apply (Nat.le_trans _ (S k + (repeat f (S k) n)) _); [omega|].
    apply (repeat_contract_strict a f n k Haf H0).
  - intro. destruct k.
    1: simpl in H; rewrite (countdown_init a f n); omega; apply H.
    remember (n - a) as m.
    destruct m; [rewrite countdown_init; omega|].
    destruct (repeat_contract_strict_threshold a f n Haf); [omega|].
    destruct H0 as [Hx0 [Hxl Hxr]].
    assert (cdn_wkr f a n n = S x) as Hx.
    { rewrite (countdown_intermediate a f n n x); trivial.
      rewrite countdown_init; [omega | trivial].
    }
    rewrite Hx. apply not_le. intro.
    apply (repeat_contract f n (S k) x) in H0; [omega | apply Hf].
Qed.

(* RECURSION FOR CONTRACTORS THEOREM *)
Theorem countdown_recursion :
  forall a f n,
    contract_strict_above a f ->
    (n <= a -> countdown_to f a n = 0) /\
    (a < n -> countdown_to f a n = S (countdown_to f a (f n))).
Proof.
  intros a f n Hf. split.
  1: intro Han; unfold countdown_to; apply countdown_init; apply Han.
  intro Han.
  assert (countdown_to f a n <= S (countdown_to f a (f n))) as G1.
  { rewrite countdown_repeat by apply Hf.
    rewrite repeat_S_comm.
    rewrite <- countdown_repeat by apply Hf.
    trivial. }
  assert (1 <= countdown_to f a n) as G0.
  { rewrite le_lt_S. rewrite <- not_le.
    rewrite countdown_repeat by apply Hf.
    simpl. omega. }
  assert (countdown_to f a (f n) <= countdown_to f a n - 1).
  { rewrite countdown_repeat by apply Hf.
    rewrite <- repeat_S_comm.
    replace (S (countdown_to f a n - 1)) with
              (countdown_to f a n) by omega.
    rewrite <- countdown_repeat by apply Hf. trivial. }
  omega.
Qed.

Corollary countdown_antirecursion :
  forall a f n,
    contract_strict_above a f ->
      countdown_to f a (f n) = countdown_to f a n - 1.
Proof.
  intros a f n Haf.
  assert (H := Haf).
  destruct (Nat.lt_ge_cases a n) as [Han | Han];
    apply (countdown_recursion a f n) in H.
  1: apply H in Han; omega.
  assert (f n <= a) as Hafn
      by (apply (Nat.le_trans _ n _); [apply Haf | apply Han]).
  apply (countdown_recursion a f (f n)) in Haf.
  apply Haf in Hafn. apply H in Han. omega.
Qed.

(* STRICT CONTRACTIVENESS PRESERVATION THEOREM *)
Theorem countdown_contract_strict :
  forall a f t,
    1 <= a ->
    contract_strict_above a f ->
    contract_strict_above t (countdown_to f a).
Proof.
  intros a f t Ha Haf. split.
  - intro n. rewrite countdown_repeat by apply Haf.
    rewrite not_lt. intro.
    apply repeat_contract_strict in H; [omega | apply Haf..].
  - intros n Hn. destruct n; [omega|]. rewrite <- lt_S_le.
    rewrite countdown_repeat by apply Haf. destruct n;  trivial.
    remember (repeat f n (S (S n)) - a) as m. destruct m.
    1: apply (Nat.le_trans _ (repeat f n (S (S n))) _);
       [apply Haf | omega].
    assert (S n + repeat f (S n) (S (S n)) <= (S n) + a)
      by (apply (Nat.le_trans _ (S (S n)) _);
          [apply (repeat_contract_strict a _ _ _ Haf)|]; omega).
    omega.
Qed.

(* ****** COUNTDOWN - REPEATER - INVERSE PRESERVATION **************** *)

(*
 * This theorem is important.
 * It says that countdown and repeater will preserve the
 * upper inverse relation on their respective results.
 * We need this to prove the correctness of inverse hyperoperations and
 *  inverse Ackermann towers built with countdown later on
 *)
Theorem countdown_repeater_upp_inverse :
  forall a f F,
    expand_strict_from a F ->
    upp_inv_rel f F ->
    upp_inv_rel (countdown_to f a) (repeater_from F a).
Proof.
  intros a f F HaF HfF n N.
  apply (upp_inv_expand_contract_strict a f F) in HaF; [|trivial].
  rewrite repeater_from_repeat. apply (upp_inv_repeat n _ _) in HfF.
  rewrite <- (HfF a N). apply countdown_repeat. trivial.
Qed.


Require Import Tree List Omega.

Set Implicit Arguments.

Inductive BaseTree := B: list BaseTree -> BaseTree.

Section ListProp.
  Variable A: Type.
  Variable def: A.
  Theorem appLastNth: forall l i a, i = length l -> nth i (l ++ (a :: nil)) def = a.
  Proof.
    intros l.
    induction l.
    intros i a i_len.
    simpl in *.
    rewrite i_len.
    auto.
    intros i a0 i_len.
    unfold length in i_len.
    fold (length l) in i_len.
    rewrite i_len.
    unfold app.
    fold (app l (a0 :: nil)).
    simpl.
    specialize (IHl (length l) a0).
    assert (length l = length l) by auto.
    specialize (IHl H).
    assumption.
  Qed.

  Theorem appNotLastNth: forall l i a, i < length l -> nth i (l ++ (a :: nil)) def = nth i l def.
  Proof.
    intros l.
    induction l.
    intros i a i_len.
    simpl in *.
    omega.
    intros i a0 i_len.
    unfold app.
    fold (app l (a0::nil)).
    destruct i.
    simpl.
    auto.
    simpl.
    simpl in i_len.
    assert (i < length l) by omega.
    specialize (IHl i a0 H).
    assumption.
  Qed.

  Theorem appLen: forall (l: list A) a, length (l ++ a :: nil) = S (length l).
  Proof.
    intros l a.
    induction l.
    simpl.
    auto.
    unfold app.
    fold (app l (a :: nil)).
    simpl.
    omega.
  Qed.

  Theorem revLen: forall (l: list A), length l = length (rev l).
  Proof.
    intros l.
    induction l.
    simpl.
    auto.
    simpl.
    pose proof (appLen (rev l) a).
    rewrite H; clear H.
    omega.
  Qed.

  Theorem revProp: forall l i, i < length l -> nth i l def = nth (length l - S i) (rev l) def.
  Proof.
    intros l.
    induction l.
    intros i i_lt_len.
    simpl in *.
    omega.
    intros i i_lt_len.
    unfold rev.
    fold (rev l).
    unfold length.
    fold (length l).
    assert (S (length l) - S i = (length l) - i) by omega.
    rewrite H.
    clear H.
    destruct i.
    simpl.
    assert (length l - 0 = length l) by omega.
    rewrite H; clear H.
    pose proof (revLen l) as H.
    rewrite H; clear H.
    assert (length (rev l) = length (rev l)) by reflexivity.
    pose proof (appLastNth _ a H).
    rewrite H0.
    auto.
    simpl in i_lt_len.
    pose proof (revLen l) as H.
    assert (length l - S i < length (rev l)) by omega.
    pose proof (appNotLastNth _ a H0).
    rewrite H1.
    simpl.
    assert (i < length l) by omega.
    specialize (IHl i H2).
    assumption.
  Qed.

  Section EqLen.
    Context (l: list A).
    Context {B: Type}.
    Context (f: A -> list A -> B).
    Fixpoint trans ls :=
      match ls with
        | nil => nil
        | x :: xs => f x xs :: trans xs
      end.
    Theorem eqLen: length (trans l) = length l.
    Proof.
      induction l.
      simpl.
      reflexivity.
      simpl.
      f_equal.
      assumption.
    Qed.
  End EqLen.
End ListProp.

Section Strange.
  Variable (nm: list nat).

  Fixpoint mkNameList ls :=
    match ls with
      | nil => nil
      | x :: xs => (C (length xs :: nm) x) :: mkNameList xs
    end.

  Theorem mkNameListLength ls: length (mkNameList ls) = length ls.
  Proof.
    induction ls.
    simpl.
    auto.
    simpl.
    f_equal.
    auto.
  Qed.

  Theorem posValue: forall ls i, i < length ls -> match nth i (mkNameList ls) (C nil nil) with
                                                      | C x _ => x = (length ls - S i) :: nm
                                                    end.
  Proof.
    intros ls.
    induction ls.
    intros i i_lt_l.
    simpl in i_lt_l.
    omega.
    intros i i_lt_l.
    simpl in i_lt_l.
    unfold mkNameList.
    fold mkNameList.
    destruct i.
    simpl.
    assert (H: length ls - 0 = length ls) by omega.
    rewrite H; clear H.
    auto.
    simpl.
    assert (H: i < length ls) by omega.
    apply (IHls i H).
  Qed.

  Theorem posValueRev': forall ls i, i < length ls ->
                                       match nth (length ls - S i) (rev (mkNameList ls)) (C nil nil) with
                                         | C x _ => x = (length ls - S i) :: nm
                                       end.
  Proof.
    intros ls i i_lt_n.
    pose proof (posValue _ i_lt_n) as gdOne.
    pose proof (mkNameListLength ls) as t1.
    rewrite <- t1 in i_lt_n.
    pose proof (revProp (C nil nil) _ i_lt_n) as bdOne.
    rewrite t1 in bdOne.
    rewrite bdOne in gdOne.
    auto.
  Qed.

  Theorem posValueRev: forall ls i, i < length ls ->
                                      match nth i (rev (mkNameList ls)) (C nil nil) with
                                        | C x _ => x = i :: nm
                                      end.
  Proof.
    intros ls i i_lt_n.
    assert (sth: length ls - S i < length ls) by omega.
    pose proof (posValueRev' _ sth) as sth2.
    assert (H: length ls - S (length ls - S i) = i) by omega.
    rewrite H in sth2.
    assumption.
  Qed.
End Strange.

Fixpoint getCs nm b :=
  match b with
    | B bs => rev (mkNameList nm
                              ((fix addC bs :=
                                  match bs with
                                    | nil => nil
                                    | b' :: bs' => getCs (length bs' :: nm) b' :: addC bs'
                                  end) bs))
  end.

Definition getC nm b := C nm (getCs nm b).

Theorem parentTreeName c p np bp: parent c p ->
                                  p = getC np bp ->
                                  exists nc bc, c = getC nc bc.
Proof.
  intros c_p pEq.
  unfold parent in *; unfold getC in *.
  destruct p.
  injection pEq as lEqNp l0Eq.
  rewrite lEqNp in *; rewrite l0Eq in *; clear lEqNp l0Eq.
  clear pEq.
  destruct bp.
  simpl in c_p.
  pose proof @In_rev as sth.
  assert (In_rev: forall A l (x: A), In x (rev l) -> In x l) by
         (generalize sth; clear;
          intros sth A l x inl; specialize (sth A l x);
          destruct sth;
          intuition); clear sth.
  pose proof (In_rev _ _ _ c_p) as inp; clear In_rev c_p l0 l.
  induction l1.
  simpl in *.
  intuition.
  simpl in inp.
  pose proof (eqLen l1 (fun x y => getCs (length y :: np) x)) as sth.
  unfold trans in sth.
  rewrite sth in inp.
  destruct inp.
  exists (length l1 :: np); exists a; auto.
  specialize (IHl1 H).
  assumption.
Qed.

Theorem treeNameHelp nm b:
  match getC nm b with
    | C x ls => treeNthName x ls
  end.
Proof.
  unfold treeNthName.
  unfold getC.
  destruct b.
  simpl.
  intros n n_lt_len.
  apply posValueRev.
  remember  ((fix addC (bs : list BaseTree) : list (list Tree) :=
         match bs with
         | nil => nil
         | b' :: bs' => getCs (length bs' :: nm) b' :: addC bs'
         end) l) as sth.
  clear Heqsth.
  pose proof (mkNameListLength nm sth) as H.
  pose proof (revLen (mkNameList nm sth)) as H0.
  rewrite H in H0.
  rewrite <- H0 in n_lt_len.
  assumption.
Qed.

Theorem descImpGetc p c: descendent c p ->
                         (exists np bp, p = getC np bp) ->
                         exists nc bc, c = getC nc bc.
Proof.
  intros desc.
  induction desc.
  intros [np [bp pEq]].
  apply (parentTreeName _ H pEq).
  intros [np [bp pEq]].
  exists np; exists bp; intuition.
  intros use.
  specialize (IHdesc2 use).
  specialize (IHdesc1 IHdesc2).
  assumption.
Qed.


(** Binary trees the nodes of which are labelled with type A *)

Section Some_type_A.
Variable A: Type.

Inductive tree  : Type :=
  | leaf
  | node (label: A)(left_son right_son : tree).

Inductive subtree  (t:tree) : tree -> Prop :=
  | subtree1 : forall t'  (x:A), subtree  t (node  x t t')
  | subtree2 : forall (t':tree) (x:A), subtree  t (node  x t' t).

Theorem well_founded_subtree :  well_founded subtree.
Proof.
 intros t; induction  t as [ | x t1 IHt1 t2 IHt2].
 - split; inversion 1.
 - split; intros y Hsub; inversion_clear Hsub; assumption.
Qed.

(** Alternate arithmetic proof

   Using several lemmas in library Wellfounded, we use tree size
  as a measure for proving well_foundedness

*)

Require Import Omega
               Inverse_Image Wellfounded.Inclusion Wf_nat.

Fixpoint size (t:tree) : nat :=
match t with leaf => 1
           | node _ t1 t2 => 1 + size t1 + size t2
end.

Lemma subtree_smaller : forall (t t': tree), subtree t t' -> size t < size t'.
Proof.
 inversion 1;simpl;omega.
Qed.

Lemma well_founded_subtree' : well_founded subtree.
Proof.
 apply wf_incl with (fun t t' => size t < size t').
 intros x y Hxy; now  apply subtree_smaller.
 apply wf_inverse_image; apply lt_wf.
Qed.

End Some_type_A.


Require Import Coq.Classes.Morphisms.
Require Import Crypto.Algebra.Hierarchy Crypto.Algebra.Monoid.

Module Import ModuloCoq8485.
  Import NPeano Nat.
  Infix "mod" := modulo.
End ModuloCoq8485.

Section ScalarMultProperties.
  Context {G eq add zero} `{monoidG:@monoid G eq add zero}.
  Context {mul:nat->G->G}.
  Local Infix "=" := eq : type_scope. Local Infix "=" := eq.
  Local Infix "+" := add. Local Infix "*" := mul.
  Class is_scalarmult :=
    {
      scalarmult_0_l : forall P, 0 * P = zero;
      scalarmult_S_l : forall n P, S n * P = P + n * P;

      scalarmult_Proper : Proper (Logic.eq==>eq==>eq) mul
    }.
  Global Existing Instance scalarmult_Proper.
  Context `{mul_is_scalarmult:is_scalarmult}.

  Fixpoint scalarmult_ref (n:nat) (P:G) {struct n} :=
    match n with
    | O => zero
    | S n' => add P (scalarmult_ref n' P)
    end.

  Global Instance Proper_scalarmult_ref : Proper (Logic.eq==>eq==>eq) scalarmult_ref.
  Proof using monoidG.
    repeat intro; subst.
    match goal with [n:nat |- _ ] => induction n; simpl @scalarmult_ref; [reflexivity|] end.
    repeat match goal with [H:_ |- _ ] => rewrite H end; reflexivity.
  Qed.

  Lemma scalarmult_ext : forall n P, mul n P = scalarmult_ref n P.
  Proof using Type*.

    induction n; simpl @scalarmult_ref; intros; rewrite <-?IHn; (apply scalarmult_0_l || apply scalarmult_S_l).
  Qed.

  Lemma scalarmult_1_l : forall P, 1*P = P.
  Proof using Type*. intros. rewrite scalarmult_S_l, scalarmult_0_l, right_identity; reflexivity. Qed.

  Lemma scalarmult_add_l : forall (n m:nat) (P:G), ((n + m)%nat * P = n * P + m * P).
  Proof using Type*.
    induction n; intros;
      rewrite ?scalarmult_0_l, ?scalarmult_S_l, ?plus_Sn_m, ?plus_O_n, ?scalarmult_S_l, ?left_identity, <-?associative, <-?IHn; reflexivity.
  Qed.

  Lemma scalarmult_zero_r : forall m, m * zero = zero.
  Proof using Type*. induction m; rewrite ?scalarmult_S_l, ?scalarmult_0_l, ?left_identity, ?IHm; try reflexivity. Qed.

  Lemma scalarmult_assoc : forall (n m : nat) P, n * (m * P) = (m * n)%nat * P.
  Proof using Type*.
    induction n; intros.
    { rewrite <-mult_n_O, !scalarmult_0_l. reflexivity. }
    { rewrite scalarmult_S_l, <-mult_n_Sm, <-Plus.plus_comm, scalarmult_add_l.
      rewrite IHn. reflexivity. }
  Qed.

  Lemma scalarmult_times_order : forall l B, l*B = zero -> forall n, (l * n) * B = zero.
  Proof using Type*. intros ? ? Hl ?. rewrite <-scalarmult_assoc, Hl, scalarmult_zero_r. reflexivity. Qed.

  Lemma scalarmult_mod_order : forall l B, l <> 0%nat -> l*B = zero -> forall n, n mod l * B = n * B.
  Proof using Type*.
    intros ? ? Hnz Hmod ?.
    rewrite (NPeano.Nat.div_mod n l Hnz) at 2.
    rewrite scalarmult_add_l, scalarmult_times_order, left_identity by auto. reflexivity.
  Qed.
End ScalarMultProperties.

Section ScalarMultHomomorphism.
  Context {G EQ ADD ZERO} {monoidG:@monoid G EQ ADD ZERO}.
  Context {H eq add zero} {monoidH:@monoid H eq add zero}.
  Local Infix "=" := eq : type_scope. Local Infix "=" := eq : eq_scope.
  Context {MUL} {MUL_is_scalarmult:@is_scalarmult G EQ ADD ZERO MUL }.
  Context {mul} {mul_is_scalarmult:@is_scalarmult H eq add zero mul }.
  Context {phi} {homom:@Monoid.is_homomorphism G EQ ADD H eq add phi}.
  Context (phi_ZERO:phi ZERO = zero).

  Lemma homomorphism_scalarmult : forall n P, phi (MUL n P) = mul n (phi P).
  Proof using Type*.
    setoid_rewrite scalarmult_ext.
    induction n; intros; simpl; rewrite ?Monoid.homomorphism, ?IHn; easy.
  Qed.
End ScalarMultHomomorphism.

Global Instance scalarmult_ref_is_scalarmult {G eq add zero} `{@monoid G eq add zero}
  : @is_scalarmult G eq add zero (@scalarmult_ref G add zero).
Proof. split; try exact _; intros; reflexivity. Qed.


Require Export prosa.util.tactics prosa.util.notation.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

(** In this section, we introduce useful lemmas about the concatenation operation performed
    over an arbitrary range of sequences. *)
Section BigCatLemmas.

  (** Consider any type supporting equality comparisons... *)
  Variable T: eqType.

  (** ...and a function that, given an index, yields a sequence. *)
  Variable f: nat -> list T.

  (** In this section, we prove that the concatenation over sequences works as expected:
      no element is lost during the concatenation, and no new element is introduced. *)
  Section BigCatElements.

    (** First, we show that the concatenation comprises all the elements of each sequence;
        i.e. any element contained in one of the sequences will also be an element of the
        result of the concatenation. *)
    Lemma mem_bigcat_nat:
      forall x m n j,
        m <= j < n ->
        x \in f j ->
        x \in \cat_(m <= i < n) (f i).
    Proof.
      intros x m n j LE IN; move: LE => /andP [LE LE0].
      rewrite -> big_cat_nat with (n := j); simpl; [| by ins | by apply ltnW].
      rewrite mem_cat; apply/orP; right.
      destruct n; first by rewrite ltn0 in LE0.
      rewrite big_nat_recl; last by ins.
        by rewrite mem_cat; apply/orP; left.
    Qed.

    (** Conversely, we prove that any element belonging to a concatenation of sequences
        must come from one of the sequences. *)
    Lemma mem_bigcat_nat_exists :
      forall x m n,
        x \in \cat_(m <= i < n) (f i) ->
        exists i,
          x \in f i /\ m <= i < n.
    Proof.
      intros x m n IN.
      induction n; first by rewrite big_geq // in IN.
      destruct (leqP m n); last by rewrite big_geq ?in_nil // ltnW in IN.
      rewrite big_nat_recr // /= mem_cat in IN.
      move: IN => /orP [HEAD | TAIL].
      {
        apply IHn in HEAD; destruct HEAD; exists x0.  move: H => [H /andP [H0 H1]].
        split; first by done.
          by apply/andP; split; [by done | by apply ltnW]. }
      {
        exists n; split; first by done.
        apply/andP; split; [by done | by apply ltnSn]. }
    Qed.

  End BigCatElements.

  (** In this section, we show how we can preserve uniqueness of the elements
      (i.e. the absence of a duplicate) over a concatenation of sequences. *)
  Section BigCatDistinctElements.

    (** Assume that there are no duplicates in each of the possible
        sequences to concatenate... *)
    Hypothesis H_uniq_seq: forall i, uniq (f i).

    (** ...and that there are no elements in common between the sequences. *)
    Hypothesis H_no_elements_in_common:
      forall x i1 i2, x \in f i1 -> x \in f i2 -> i1 = i2.

    (** We prove that the concatenation will yield a sequence with unique elements. *)
    Lemma bigcat_nat_uniq :
      forall n1 n2,
        uniq (\cat_(n1 <= i < n2) (f i)).
    Proof.
      intros n1 n2.
      case (leqP n1 n2) => [LE | GT]; last by rewrite big_geq // ltnW.
      rewrite -[n2](addKn n1).
      rewrite -addnBA //; set delta := n2 - n1.
      induction delta; first by rewrite addn0 big_geq.
      rewrite addnS big_nat_recr /=; last by apply leq_addr.
      rewrite cat_uniq; apply/andP; split; first by apply IHdelta.
      apply /andP; split; last by apply H_uniq_seq.
      rewrite -all_predC; apply/allP; intros x INx.
      simpl; apply/negP; unfold not; intro BUG.
      apply mem_bigcat_nat_exists in BUG.
      move: BUG => [i [IN /andP [_ LTi]]].
      apply H_no_elements_in_common with (i1 := i) in INx; last by done.
      by rewrite INx ltnn in LTi.
    Qed.

  End BigCatDistinctElements.

End BigCatLemmas.


Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export Omega.
Require Export Zwf.
Require Export Relations.
Require Export Inverse_Image.
Require Export Transitive_Closure.
Require Export Zdiv.

Open Scope nat_scope.

Theorem verif_divide :
    forall m p:nat, 0 < m -> 0 < p ->
    (exists q:nat, m = q*p)->(Z_of_nat m mod Z_of_nat p = 0)%Z.
Proof.
 intros m p Hltm Hltp (q, Heq); rewrite Heq.
 rewrite inj_mult.
 replace (Z_of_nat q * Z_of_nat p)%Z with (0 + Z_of_nat q * Z_of_nat p)%Z;
    try ring.
 rewrite Z_mod_plus; auto.
 omega.
Qed.

Theorem divisor_smaller :
    forall m p:nat, 0 < m -> forall q:nat, m = q*p -> q <= m.
Proof.
 intros m p Hlt; case p.
 -  intros q Heq; rewrite Heq in Hlt; rewrite mult_comm in Hlt.
    elim (lt_irrefl 0);exact Hlt.
 -  intros p' q; case q.
    +  intros Heq; rewrite Heq in Hlt.
       elim (lt_irrefl 0);exact Hlt.
    +  intros q' Heq; rewrite Heq.
       rewrite mult_comm; simpl; auto with arith.
Qed.

Fixpoint check_range (v:Z)(r:nat)(sr:Z){struct r} : bool :=
  match r with
    O => true
  | S r' =>
    match (v mod sr)%Z with
      Z0 => false
    | _ => check_range v r' (Z.pred sr)
    end
  end.

Definition check_primality (n:nat) :=
  check_range (Z_of_nat n)(pred (pred n))(Z_of_nat (pred n)).

(** Tests :

Compute check_primality 2333.

Compute check_primality 2330.
*)

Fixpoint check_range' (v:Z)(r:nat){struct r} : bool :=
  match r with
    0 => true | 1 => true
  | S r' =>
      match (v mod Z_of_nat r)%Z with
      | 0%Z => false
      | _ => check_range' v r'
      end
  end.

Definition check_primality' (n:nat) :=
  check_range' (Zpos (P_of_succ_nat (pred n)))(pred (pred n)).

Theorem Zabs_nat_0 : forall x:Z, Z.abs_nat x = 0 -> (x = 0)%Z.
Proof.
 intros x; case x.
 -  simpl; auto.
 -  intros p Heq; elim (lt_irrefl 0).
    pattern 0 at 2; rewrite <- Heq.
    simpl; apply lt_O_nat_of_P.
 -  intros p Heq; elim (lt_irrefl 0).
    pattern 0 at 2; rewrite <- Heq.
    simpl; apply lt_O_nat_of_P.
Qed.

Theorem Z_to_nat_and_back :
 forall x:Z, (0 <= x)%Z -> (Z.of_nat (Z.abs_nat x))=x.
Proof.
 intros x; case x.
 -  auto.
 -  intros p Hd; elim p.
    +  unfold Z.abs_nat; intros p' Hrec; rewrite nat_of_P_xI.
       rewrite inj_S.
       rewrite inj_mult.
       rewrite Zpos_xI.
       unfold Z.succ.
       rewrite Hrec.
       simpl; auto.
    +  unfold Z.abs_nat.
       intros p' Hrec; rewrite nat_of_P_xO.
       rewrite inj_mult.
       rewrite Zpos_xO.
       unfold Z.succ.
       rewrite Hrec.
       simpl; auto.
    +  simpl; auto.
 - intros p' Hd; elim Hd;auto.
Qed.

Theorem check_range_correct :
  forall (v:Z)(r:nat)(rz:Z),
  (0 < v)%Z ->
  Z_of_nat (S r) = rz -> check_range v r rz = true ->
  ~ (exists k:nat, k <= (S r) /\ k <> 1 /\
                       (exists q:nat, Z.abs_nat v = q*k)).
Proof.
 intros v r; elim r.
 -  intros rz Hlt H1 H2 Hex; case Hex; intros k; case k.
   +  intros (Hle, (Hne1, (q, Heq))).
      rewrite mult_comm in Heq; simpl in Heq.
      rewrite (Zabs_nat_0 _ Heq) in Hlt.
      elim (Z.lt_irrefl 0); assumption.
   +  intros k' (Hle, (Hne1, (q, Heq))).
      inversion Hle.
      assert (H':k'=0).
      * assumption.
      * rewrite H' in Hne1; elim Hne1;auto.
      * assert (H': S k' <= 0) by  assumption.
        inversion H'.
-  intros r' Hrec rz Hlt H1 H2 Hex; case Hex; intros k; case k.
   +  intros (Hle, (Hne1, (q, Heq))).
      rewrite mult_comm in Heq; simpl in Heq.
      rewrite (Zabs_nat_0 _ Heq) in Hlt.
      elim (Z.lt_irrefl 0); assumption.
   +  intros k' (Hle, (Hne1, (q, Heq))).
      inversion Hle.
      rewrite <- H1 in H2.
      rewrite <- (Z_to_nat_and_back v) in H2.
      assert (Hmod:(Z_of_nat (Z.abs_nat v) mod Z.of_nat (S (S r')) = 0)%Z).
      *  apply verif_divide.
         replace 0 with (Z.abs_nat 0%Z).
         apply Zabs_nat_lt.
         omega.
         simpl; auto.
         auto with arith.
         exists q.
         assert (H': k' = S r') by assumption.
         rewrite <- H';auto.
      *   unfold check_range in H2.
         rewrite Hmod in H2; discriminate H2.
      *  omega.
      *  unfold check_range in H2; fold check_range in H2.
         case_eq ((v mod rz)%Z).
         intros Heqmod.
         rewrite Heqmod in H2.
         discriminate H2.
         intros pmod Heqmod; rewrite Heqmod in H2.
         elim (Hrec (Z.pred rz) Hlt).
         rewrite <- H1.
         rewrite inj_S.
         rewrite inj_S.
         rewrite inj_S.
         rewrite <- Zpred_succ.
         auto.
         assumption.
         exists (S k').
         repeat split;auto.
         exists q; assumption.
         intros p Hmod.
         elim (Z_mod_lt v rz).
         rewrite Hmod.
         unfold Z.le; simpl; intros Hle'; elim Hle';auto.
         rewrite <- H1.
         rewrite inj_S.
         unfold Z.succ.
         generalize (Zle_0_nat (S r')).
         intros; omega.
Qed.

Theorem nat_of_P_Psucc :
 forall p:positive, nat_of_P (Pos.succ p) = S (nat_of_P p).
Proof.
 intros p; elim p.
 -  simpl; intros p'; rewrite nat_of_P_xO.
    intros Heq; rewrite Heq; rewrite nat_of_P_xI; ring.
 - intros p' Heq; simpl.
   rewrite nat_of_P_xI.
   rewrite nat_of_P_xO;auto.
 -  auto.
Qed.

Theorem nat_to_Z_and_back:
 forall n:nat, Z.abs_nat (Z.of_nat n) = n.
Proof.
 intros n; elim n.
 -  auto.
 - intros n'; simpl; case n'.
  + simpl; auto.
  +  intros n''; simpl; rewrite nat_of_P_Psucc.
     intros Heq; rewrite Heq; auto.
Qed.

Theorem check_correct :
  forall p:nat, 0 < p -> check_primality p = true ->
  ~(exists k:nat, k <> 1 /\ k <> p /\ (exists q:nat, p = q*k)).
Proof.
 unfold lt; intros p Hle; elim Hle.
 -  intros Hcp (k, (Hne1, (Hne1bis, (q, Heq))));
   rewrite mult_comm in Heq.
    assert (Hle' : k < 1).
   +  elim (le_lt_or_eq k 1); try(intuition; fail).
      apply divisor_smaller with (2:= Heq); auto.
   + case_eq k.
     intros Heq'; rewrite Heq' in Heq; simpl in Heq; discriminate Heq.
     intros; omega.
 -  intros p' Hlep' Hrec; unfold check_primality.
    assert (H':(exists p'':nat, p' = (S p''))).
    +  inversion Hlep'.
       exists 0; auto.
       eapply ex_intro;eauto.
    +  elim H'; intros p'' Hp''; rewrite Hp''.
       repeat rewrite <- pred_Sn.
       intros Hcr Hex.
       elim check_range_correct with (3:= Hcr).
       rewrite inj_S; generalize (Zle_0_nat (S p'')).
       intros; omega.
       auto.
       elim Hex; intros k (Hne1, (HneSSp'', (q, Heq))); exists k.
       split.
       assert (HkleSSp'': k <= S (S p'')).
       * apply (divisor_smaller (S (S p'')) q).
         auto with arith.
         rewrite mult_comm.
         assumption.
       *  omega.
       * split.
         assumption.
         exists q; now rewrite nat_to_Z_and_back.
Qed.

Theorem prime_2333 :
 ~(exists k:nat, k <> 1 /\ k <> 2333 /\ (exists q:nat, 2333 = q*k)).
Proof.
 Time apply check_correct; auto with arith.
(**Finished transaction in 132. secs (131.01u,0.62s)*)
Time Qed.

Theorem reflection_test :
 forall x y z t u:nat, x+(y+z+(t+u)) = x+y+(z+(t+u)).
Proof.
 intros; repeat rewrite plus_assoc; auto.
Qed.

Inductive bin : Set := node : bin->bin->bin | leaf : nat->bin.

Fixpoint flatten_aux (t fin:bin){struct t} : bin :=
  match t with
  | node t1 t2 => flatten_aux t1 (flatten_aux t2 fin)
  | x => node x fin
  end.

Fixpoint flatten (t:bin) : bin :=
  match t with
  | node t1 t2 => flatten_aux t1 (flatten t2)
  | x => x
  end.

Compute
  flatten
     (node (leaf 1) (node (node (leaf 2)(leaf 3)) (leaf 4))).

Fixpoint bin_nat (t:bin) : nat :=
  match t with
  | node t1 t2 => bin_nat t1 + bin_nat t2
  | leaf n => n
  end.

Eval lazy beta iota delta [bin_nat] in
 (bin_nat
   (node (leaf 1) (node (node (leaf 2) (leaf 3)) (leaf 4)))).

Theorem flatten_aux_valid :
 forall t t':bin, bin_nat t + bin_nat t' = bin_nat (flatten_aux t t').
Proof.
 intros t; elim t; simpl; auto.
 intros t1 IHt1 t2 IHt2 t'; rewrite <- IHt1; rewrite <- IHt2.
 rewrite plus_assoc; trivial.
Qed.

Theorem flatten_valid : forall t:bin, bin_nat t = bin_nat (flatten t).
Proof.
 intros t; elim t; simpl; auto.
 intros t1 IHt1 t2 IHt2; rewrite <- flatten_aux_valid; rewrite <- IHt2.
 trivial.
Qed.

Theorem flatten_valid_2 :
  forall t t':bin, bin_nat (flatten t) = bin_nat (flatten t')->
  bin_nat t = bin_nat t'.
Proof.
 intros; rewrite (flatten_valid t); rewrite (flatten_valid t');
 auto.
Qed.

Theorem reflection_test' :
 forall x y z t u:nat, x+(y+z+(t+u))=x+y+(z+(t+u)).
Proof.
 intros.
 change
   (bin_nat
      (node (leaf x)
         (node (node (leaf y) (leaf z))
               (node (leaf t)(leaf u)))) =
    bin_nat
      (node (node (leaf x)(leaf y))
         (node (leaf z)
               (node (leaf t)(leaf u))))).
 apply flatten_valid_2; auto.
Qed.

Ltac model v :=
  match v with
  | (?X1 + ?X2) =>
    let r1 := model X1
              with r2 := model X2 in constr:(node r1 r2)
  | ?X1 => constr:(leaf X1)
  end.

Ltac assoc_eq_nat :=
  match goal with
  | [ |- (?X1 = ?X2 :>nat) ] =>
   let term1 := model X1 with term2 := model X2 in
   (change (bin_nat term1 = bin_nat term2);
    apply flatten_valid_2;
    lazy beta iota zeta delta [flatten flatten_aux bin_nat];
    auto)
  end.

Theorem reflection_test'' :
 forall x y z t u:nat, x+(y+z+(t+u)) = x+y+(z+(t+u)).
Proof.
 intros; assoc_eq_nat.
Qed.

Section assoc_eq.
Variables (A : Type)(f : A->A->A)
  (assoc : forall x y z:A, f x (f y z) = f (f x y) z).

Fixpoint bin_A (l:list A)(def:A)(t:bin){struct t} : A :=
  match t with
  | node t1 t2 => f (bin_A l def t1)(bin_A l def t2)
  | leaf n => nth n l def
  end.

Theorem flatten_aux_valid_A :
 forall (l:list A)(def:A)(t t':bin),
 f (bin_A l def t)(bin_A l def t') = bin_A l def (flatten_aux t t').
Proof.
 intros l def t; elim t; simpl; auto.
 intros t1 IHt1 t2 IHt2 t';  rewrite <- IHt1; rewrite <- IHt2.
 symmetry; apply assoc.
Qed.

Theorem flatten_valid_A :
 forall (l:list A)(def:A)(t:bin),
   bin_A l def t = bin_A l def (flatten t).
Proof.
 intros l def t; elim t; simpl; trivial.
 intros t1 IHt1 t2 IHt2; rewrite <- flatten_aux_valid_A; now rewrite <- IHt2.
Qed.

Theorem flatten_valid_A_2 :
 forall (t t':bin)(l:list A)(def:A),
   bin_A l def (flatten t) = bin_A l def (flatten t')->
   bin_A l def t = bin_A l def t'.
Proof.
 intros t t' l def Heq.
 rewrite (flatten_valid_A l def t); now rewrite (flatten_valid_A l def t').
Qed.

End assoc_eq.

Ltac term_list f l v :=
  match v with
  | (f ?X1 ?X2) =>
    let l1 := term_list f l X2 in term_list f l1 X1
  | ?X1 => constr:(cons X1 l)
  end.

Ltac compute_rank l n v :=
  match l with
  | (cons ?X1 ?X2) =>
    let tl := constr:(X2) in
    match constr:(X1 = v) with
    | (?X1 = ?X1) => n
    | _ => compute_rank tl (S n) v
    end
  end.

Ltac model_aux l f v :=
  match v with
  | (f ?X1 ?X2) =>
    let r1 := model_aux l f X1 with r2 := model_aux l f X2 in
      constr:(node r1 r2)
  | ?X1 => let n := compute_rank l 0 X1 in constr:(leaf n)
  | _ => constr:(leaf 0)
  end.

Ltac model_A A f def v :=
  let l := term_list f (nil (A:=A)) v in
  let t := model_aux l f v in
  constr:(bin_A A f l def t).

Ltac assoc_eq A f assoc_thm :=
  match goal with
  | [ |- (@eq A ?X1 ?X2) ] =>
  let term1 := model_A A f X1 X1
  with term2 := model_A A f X1 X2 in
  (change (term1 = term2);
   apply flatten_valid_A_2 with (1 := assoc_thm); auto)
  end.

Theorem reflection_test3 :
 forall x y z t u:Z, (x*(y*z*(t*u)) = x*y*(z*(t*u)))%Z.
Proof.
 intros; assoc_eq Z Zmult Zmult_assoc.
Qed.

Fixpoint nat_le_bool (n m:nat){struct m} : bool :=
  match n, m with
  | O, _ => true
  | S _, O => false
  | S n, S m => nat_le_bool n m
  end.

Fixpoint insert_bin (n:nat)(t:bin){struct t} : bin :=
  match t with
  | leaf m => match nat_le_bool n m with
              | true => node (leaf n)(leaf m)
              | false => node (leaf m)(leaf n)
              end
  | node (leaf m) t' => match nat_le_bool n m with
                        | true => node (leaf n) t
                        | false =>
                            node (leaf m)(insert_bin n t')
                        end
  | t => node (leaf n) t
  end.

Fixpoint sort_bin (t:bin) : bin :=
  match t with
  | node (leaf n) t' => insert_bin n (sort_bin t')
  | t => t
  end.

Section commut_eq.
(** this section contains some primed versions of previous constructions
   (for avoiding Reset commands)

*)

 Variables (A : Type)(f : A->A->A).
 Hypothesis comm : forall x y:A, f x y = f y x.
 Hypothesis assoc : forall x y z:A, f x (f y z) = f (f x y) z.

 Fixpoint bin_A' (l:list A)(def:A)(t:bin){struct t} : A :=
   match t with
   | node t1 t2 => f (bin_A' l def t1)(bin_A' l def t2)
   | leaf n => nth n l def
   end.

 Theorem flatten_aux_valid_A' :
  forall (l:list A)(def:A)(t t':bin),
   f (bin_A' l def t)(bin_A' l def t') = bin_A' l def (flatten_aux t t').
 Proof.
  intros l def t; elim t; simpl; auto.
  intros t1 IHt1 t2 IHt2 t';  rewrite <- IHt1; rewrite <- IHt2.
  symmetry; apply assoc.
 Qed.

 Theorem flatten_valid_A' :
  forall (l:list A)(def:A)(t:bin),
    bin_A' l def t = bin_A' l def (flatten t).
 Proof.
  intros l def t; elim t; simpl; trivial.
  intros t1 IHt1 t2 IHt2; rewrite <- flatten_aux_valid_A'; rewrite <- IHt2.
  trivial.
 Qed.

Theorem flatten_valid_A_2' :
 forall (t t':bin)(l:list A)(def:A),
   bin_A' l def (flatten t) = bin_A' l def (flatten t')->
   bin_A' l def t = bin_A' l def t'.
Proof.
 intros t t' l def Heq.
 rewrite (flatten_valid_A' l def t); rewrite (flatten_valid_A' l def t').
 trivial.
Qed.

Theorem insert_is_f : forall (l:list A)(def:A)(n:nat)(t:bin),
   bin_A' l def (insert_bin n t) =
   f (nth n l def) (bin_A' l def t).
Proof.
 intros l def n t; elim t.
 intros t1; case t1.
 intros t1' t1'' IHt1 t2 IHt2.
 simpl.
 auto.
 intros n0 IHt1 t2 IHt2.
 simpl.
 case (nat_le_bool n n0).
 simpl.
 auto.
 simpl.
 rewrite IHt2.
 repeat rewrite assoc; rewrite (comm (nth n l def)); auto.
 simpl.
 intros n0; case (nat_le_bool n n0); auto.
 rewrite comm; auto.
Qed.

Theorem sort_eq : forall (l:list A)(def:A)(t:bin),
    bin_A' l def (sort_bin t) = bin_A' l def t.
Proof.
 intros l def t; elim t.
 intros t1 IHt1; case t1.
 auto.
 intros n t2 IHt2; simpl; rewrite insert_is_f.
 rewrite IHt2; auto.
 auto.
Qed.

Theorem sort_eq_2 :
 forall (l:list A)(def:A)(t1 t2:bin),
   bin_A' l def (sort_bin t1) = bin_A' l def (sort_bin t2)->
   bin_A' l def t1 = bin_A' l def t2.
Proof.
 intros l def t1 t2.
 rewrite <- (sort_eq l def t1); rewrite <- (sort_eq l def t2).
 trivial.
Qed.

End commut_eq.

Ltac term_list' f l v :=
  match v with
  | (f ?X1 ?X2) =>
    let l1 := term_list' f l X2 in term_list' f l1 X1
  | ?X1 => constr:(cons X1 l)
  end.

Ltac compute_rank' l n v :=
  match l with
  | (cons ?X1 ?X2) =>
    let tl := constr:(X2) in
    match constr:(X1 = v) with
    | (?X1 = ?X1) => n
    | _ => compute_rank' tl (S n) v
    end
  end.

Ltac model_aux' l f v :=
  match v with
  | (f ?X1 ?X2) =>
    let r1 := model_aux' l f X1 with r2 := model_aux' l f X2 in
      constr:(node r1 r2)
  | ?X1 => let n := compute_rank' l 0 X1 in constr:(leaf n)
  | _ => constr:(leaf 0)
  end.

Ltac comm_eq' A f assoc_thm comm_thm :=
  match goal with
  | [ |- (?X1 = ?X2 :>A) ] =>
    let l := term_list' f (nil (A:=A)) X1 in
    let term1 := model_aux' l f X1
    with term2 := model_aux' l f X2 in
    (change (bin_A' A f l X1 term1 = bin_A' A f l X1 term2);
      apply flatten_valid_A_2' with (1 := assoc_thm);
      apply sort_eq_2 with (1 := comm_thm)(2 := assoc_thm);
      auto)
  end.

Theorem reflection_test4 : forall x y z:Z, (x+(y+z) = (z+x)+y)%Z.
Proof.
 intros x y z. comm_eq' Z Zplus Zplus_assoc Zplus_comm.
Qed.


Require Import Nat List Bool PeanoNat Orders.
Require Import Coq.Structures.OrdersFacts.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Sorting.Sorted.
Require Import Coq.Sorting.Permutation.
Require Import Sorticoq.SortedList.
Require Import Sorticoq.BinaryTree.
Import ListNotations.

Module TreeSort (Import O: UsualOrderedTypeFull').
(*
Module Bdefs := UsualOrderedTypeFull'_to_BinaryTree O.
Import Bdefs.
*)
Include (BinaryTree_over_OrderedType O).

Fixpoint makeBST (l: list A) : BinaryTree :=
  match l with
  | nil => BT_nil
  | h::t => BST_Insert (makeBST t) h
  end.

Lemma makeBST_ok: forall x (l: list A),
  In_tree x (makeBST l) <-> In x l.
Proof.
  split; intros; induction l; simpl in *;
    [inversion H |  idtac | inversion H | idtac ].
  - apply In_tree_insert in H; intuition.
  - apply In_insert_cond; intuition.
Qed.

Definition Treesort (l: list A) : list A :=
  BT_get_list (makeBST l).

Lemma Treesort_is_LocallySorted: forall l,
  LocallySorted lte (Treesort l).
Proof.
  intros. apply BST_is_LocallySorted.
  induction l; simpl; auto.
  apply Insert_not_change_BSTSP. assumption.
Qed.

Lemma Treesort_Permutation: forall l,
  Permutation l (Treesort l).
Proof.
  induction l; simpl; auto.
  unfold Treesort in *. simpl.
  remember (BST_Insert _ a) as Tr. symmetry in HeqTr.
  apply BST_Insert_emplace in HeqTr. destruct HeqTr as [e1 [e2 [H' H'']]].
  rewrite <- H'. rewrite <- H'' in IHl.
  simpl. apply Permutation_cons_app. auto.
Qed.

Theorem Treesort_is_sorting_algo:
  is_sorting_algo lte Treesort.
Proof.
  unfold is_sorting_algo. split.
  - apply Treesort_Permutation.
  - apply Sorted_LocallySorted_iff. apply Treesort_is_LocallySorted.
Qed.

End TreeSort.