Require Omega.
Require Export Bool.
Require Export List.
Export ListNotations.
Require Export Arith.
Require Export Arith.EqNat.

Inductive tree : Set :=
  leaf : tree
| node : forall (n : nat) (left right : tree), tree.

Inductive lt_tree : nat -> tree -> Prop :=
  lt_leaf : forall (n   : nat), lt_tree n leaf
| lt_node : forall (n m : nat) (l r : tree),
   m < n -> lt_tree n l -> lt_tree n r -> lt_tree n (node m l r).

Inductive gt_tree : nat -> tree -> Prop :=
  gt_leaf : forall (n   : nat), gt_tree n leaf
| gt_node : forall (n m : nat) (l r : tree),
   m > n -> gt_tree n l -> gt_tree n r -> gt_tree n (node m l r).

Inductive is_search_tree : tree -> Prop :=
  st_leaf : is_search_tree leaf
| st_node : forall (n : nat) (l r : tree),
   lt_tree n l -> gt_tree n r -> is_search_tree l -> is_search_tree r ->
   is_search_tree (node n l r).

Inductive contains : nat -> tree -> Prop :=
  root_contains : forall (n : nat) (l r : tree), contains n (node n l r)
| left_contains : forall (n m : nat) (l r : tree),
   contains n l -> contains n (node m l r)
| right_contains : forall (n m : nat) (l r : tree),
   contains n r -> contains n (node m l r).

Hint Constructors lt_tree gt_tree is_search_tree contains.

Lemma rt_contains: forall (n m : nat), contains m (node n leaf leaf) -> m = n.
Proof. intros. inversion H; try omega; inversion H2. Qed.

Lemma gt_contains : forall (t : tree) (n : nat),
  (forall m, contains m t -> m > n) -> gt_tree n t.
Proof. intros. induction t; auto. Qed.

Lemma lt_contains : forall (t : tree) (n : nat),
  (forall m, contains m t -> m < n) -> lt_tree n t.
Proof. intros. induction t; auto. Qed.

Lemma left_lt : forall (n m : nat) (l r : tree),
  is_search_tree (node n l r) -> contains m l -> m < n.
Proof.
  intros. induction l. inversion H0.
    inversion H. inversion H0. inversion H4. omega.
      apply IHl1. apply st_node.
       inversion H4. assumption. assumption.
       inversion H6. assumption. assumption. assumption.
      apply IHl2. apply st_node.
       inversion H4. assumption. assumption.
       inversion H6. assumption. assumption. assumption.
Qed.

Lemma right_gt : forall (n m : nat) (l r : tree),
  is_search_tree (node n l r) -> contains m r -> m > n.
Proof.
  intros. induction r. inversion H0.
    inversion H. inversion H0. inversion H5. omega.
      apply IHr1. apply st_node. assumption.
       inversion H5. assumption. assumption.
       inversion H7. assumption. assumption.
      apply IHr2. apply st_node. assumption.
       inversion H5. assumption. assumption.
       inversion H7. assumption. assumption.
Qed.

Definition add_in_search_tree : forall (t : tree) (n : nat),
  is_search_tree t ->
  {t' | is_search_tree t' &
        (forall (m : nat), contains m t' <-> m = n \/ contains m t)
  }.
Proof.
  intros. induction t.
    exists (node n leaf leaf).
       auto. intros. split. intros. left.
       apply rt_contains in H0. assumption.
       intros. inversion H0. rewrite H1. auto. inversion H1.
    assert (L: is_search_tree t1). inversion H. auto.
    assert (LT: lt_tree n0 t1). inversion H. auto.
    assert (R: is_search_tree t2). inversion H. auto.
    assert (GT: gt_tree n0 t2). inversion H. auto.
    remember (lt_eq_lt_dec n n0) as B.
      inversion B. inversion H0.
        apply IHt1 in L. inversion L.
          exists (node n0 x t2).
            apply st_node. apply lt_contains. intros. apply H3 in H4.
                inversion H4. omega. apply (left_lt n0 m t1 t2); assumption.
              assumption. assumption. assumption.
            intros. split. intros.
              inversion H4. right. auto.
                apply H3 in H7. inversion H7. left. assumption. right. auto. right. auto.
            intros. inversion H4. rewrite H5.
              apply left_contains. apply H3. left. reflexivity.
              inversion H5. auto. apply left_contains. apply H3. right. assumption.
                apply right_contains. assumption.
        exists (node n0 t1 t2). assumption.
          intros. split. intros. right. assumption. intros. inversion H2.
            rewrite <- H1. rewrite H3. auto. assumption.
        apply IHt2 in R. inversion R.
          exists (node n0 t1 x).
            apply st_node. assumption. apply gt_contains. intros. apply H2 in H3.
                inversion H3. omega. apply (right_gt n0 m t1 t2); assumption.
              assumption. assumption.
            intros. split. intros.
              inversion H3. right. auto.
                right. apply left_contains. assumption.
                apply H2 in H6. inversion H6. left. assumption. right.
                apply right_contains. assumption.
            intros. inversion H3. apply right_contains. apply H2. left. assumption.
                inversion H4. auto. apply left_contains. assumption.
                apply right_contains. apply H2. right. assumption.
Qed.

Lemma contains_in_lt n t : lt_tree n t -> forall x, contains x t -> n > x.
Proof. intros H; induction H; intros x Hi; inversion Hi; auto. Qed.

Lemma lt_insert x n (t : tree) (t' : tree) :
     n < x -> lt_tree x t ->
     (forall m, contains m t' -> m = n \/ contains m t) ->
     is_search_tree t' -> lt_tree x t'.
Proof.
  intros. apply lt_contains. intros.
    apply H1 in H3; destruct H3.
      rewrite H3; auto.
        apply (contains_in_lt x t); auto.
Qed.

Lemma contains_in_gt n t : gt_tree n t -> forall x, contains x t -> n < x.
Proof. intros H; induction H; intros x Hi; inversion Hi; auto. Qed.

Lemma gt_insert x n (t : tree) (t' : tree) :
     n > x -> gt_tree x t ->
     (forall m, contains m t' -> m = n \/ contains m t) ->
     is_search_tree t' -> gt_tree x t'.
Proof.
  intros. apply gt_contains. intros.
    apply H1 in H3; destruct H3.
      rewrite H3; auto.
        apply (contains_in_gt x t); auto.
Qed.

Program Fixpoint add_in_search_tree_prog (t : tree) (n : nat) :
    is_search_tree t ->
    {t' | is_search_tree t' /\
          (forall (m : nat), contains m t' <-> m = n \/ contains m t)
    } := fun H =>
  match t with
  | leaf       => node n leaf leaf
  | node x l r => match (lt_eq_lt_dec n x) with
                  | inleft LE =>
                    if LE
                    then let: nl := add_in_search_tree_prog l n _ in
                         node x nl r
                    else t
                  | inright GT =>
                         let: nr := add_in_search_tree_prog r n _ in
                         node x l nr
                  end
  end.
Next Obligation.
split; auto.
  intros m; clear H.
    split; intros H; inversion H; auto.
      rewrite H0; auto.
Qed.
Next Obligation. inversion H; auto. Qed.
Next Obligation.
  clear LE Heq_anonymous.
    split.
      apply st_node; inversion H; auto.
        apply (lt_insert x n l x0); auto.
          apply i0.
      intros m; split.
        intros X; inversion X; auto.
          apply (proj1 (i0 m)) in H3.
            inversion H3; auto.
        intros X; destruct X.
          assert (m = n \/ contains m l) as H2; auto.
            apply (i0 m) in H2; auto.
          inversion H1; auto.
            apply left_contains.
              apply i0; auto.
Defined.
Next Obligation.
clear LE Heq_anonymous.
  split; auto.
    intros m; split; intros X; inversion X; auto.
      rewrite H0; auto.
Qed.
Next Obligation. inversion H; auto. Qed.
Next Obligation.
  clear Heq_anonymous.
    split.
      apply st_node; inversion H; auto.
        apply (gt_insert x n r x0); auto.
          apply i0.
      intros m; split.
        intros X; inversion X; auto.
          apply (proj1 (i0 m)) in H2.
            inversion H2; auto.
        intros X; destruct X.
          assert (m = n \/ contains m r) as H2; auto.
            apply (i0 m) in H2; auto.
          inversion H0; auto.
            apply right_contains.
              apply i0; auto.
Defined.

Fixpoint height (t: tree) : nat :=
  match t with
  | leaf => 0
  | node _ l r => 1 + max (height l) (height r)
  end.

Fixpoint add_in_search_tree_fun t n :=
  match t with
  | leaf       => node n leaf leaf
  | node x l r => match (lt_eq_lt_dec n x) with
                  | inleft LE =>
                    if LE
                    then let: nl := add_in_search_tree_fun l n in
                         node x nl r
                    else t
                  | inright _ =>
                         let: nr := add_in_search_tree_fun r n in
                         node x l nr
                  end
  end.

Lemma add_fun_contains : forall t m x,
  contains m (add_in_search_tree_fun t x) <-> m = x \/ contains m t.
Proof.
induction t.
  intros m x; split; intros H; simpl in H; simpl.
    left. inversion H; auto; inversion H2.
    destruct H. rewrite H; auto.
      inversion H.
  intros m x; unfold add_in_search_tree_fun; split; destruct (lt_eq_lt_dec x n); intros H.
    destruct s; fold add_in_search_tree_fun in H; auto.
      inversion H. right; auto.
        apply IHt1 in H2. destruct H2. left; auto.
          right. constructor; auto.
        right; apply right_contains; auto.
    fold add_in_search_tree_fun in H.
      inversion H. right; auto.
        right; constructor; auto.
        apply IHt2 in H2; destruct H2; auto.
    destruct s; fold add_in_search_tree_fun; destruct H; auto;
        specialize (IHt1 m x); destruct IHt1; auto.
      inversion H; auto. rewrite <- e, H; auto.
    fold add_in_search_tree_fun; destruct H.
      apply right_contains; apply IHt2; auto.
      inversion H; auto.
        apply right_contains; apply IHt2; auto.
Qed.

Theorem add_in_search_tree_fun_correct : forall (t : tree) (n : nat),
  is_search_tree t ->
  is_search_tree (add_in_search_tree_fun t n) /\
  (forall (m : nat), contains m (add_in_search_tree_fun t n) <-> m = n \/ contains m t).
Proof.
induction t.
  intros n _; split. constructor; auto.
    intros m; split. apply add_fun_contains.
      intros H; destruct H; simpl. rewrite H; auto.
        inversion H; auto.
  intros x H; split.
    unfold add_in_search_tree_fun. destruct (lt_eq_lt_dec x n).
      destruct s; fold add_in_search_tree_fun; auto. constructor; inversion H; auto.
        apply lt_contains. intros m HcontM.
          apply add_fun_contains in HcontM. destruct HcontM.
            rewrite H7; auto.
            apply (left_lt _ _ _ _ H H7).
        apply (IHt1 x) in H5. destruct H5; auto.
      fold add_in_search_tree_fun. constructor; inversion H; auto.
        apply gt_contains. intros m HcontM.
            apply add_fun_contains in HcontM. destruct HcontM.
              rewrite H7; auto.
              apply (right_gt _ _ _ _ H H7).
          apply (IHt2 x) in H6. destruct H6; auto.
    intros m. apply add_fun_contains.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (z : natural) (x : natural) : natural := plus (mult x z) z.


Variable A B C : Prop.

Theorem syll : (A -> B) -> (B -> C) -> A -> C.
Proof.
  intros.
  apply H0.
  apply H.
  assumption.
Qed.

Axiom classic : forall P : Prop, (P \/ ~P).

Theorem doubleng : ~~A -> A.
Proof.
  intro.
  elim (classic A).
  intro. assumption.
  intro.
  contradict H.
  assumption.
Qed.

Theorem ex4: forall A : Prop, A -> ~ ~ A.
Proof.
  intro.
  intro.
  contradict H.
  assumption.
Qed.

Theorem ex7: forall (a b : Type) (p : Type -> Prop), p a \/ p b -> exists x : Type, p x.
Proof.
  intro.
  intro.
  intro.
  intro.
  elim H.
  intro.
  exists a. assumption.
  intro.
  exists b. assumption.
Qed.

Theorem ex3: forall A B C D: Prop, (A -> C) /\ (B -> D) -> A /\ B -> C /\ D.
Proof.
  intros.
  elim H.
  elim H0.
  intros.
  split.
  apply H3.
  exact H1.
  apply H4.
  exact H2.
Qed.

Theorem ex8: forall (A : Set) (R : A -> A -> Prop),
    (forall x y z : A, R x y /\ R y z -> R x z) ->
    (forall x y : A, R x y -> R y x) -> forall x : A, (exists y : A, R x y) -> R x x.
Proof.
  intros.
  elim H1. intros.
  apply H0.
  apply H with x0.
  split.
  exact H2.
  apply H0.
  exact H2.
Qed.

Print ex8.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (x : natural) (lf1 : natural) : natural :=
  mult (Succ x) (Succ y).


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (lf2 : natural) (x : natural) : natural :=
  mult (Succ y) (Succ x).


(*
    This file covers definitions and
    proofs regarding boolean values
*)

Inductive bool : Type :=
| true
| false.

Definition eqb (b_1 b_2 : bool) : bool :=
    match b_1 with
    | true => match b_2 with
        | true => true
        | false => false
        end
    | false => match b_2 with
        | true => false
        | false => true
        end
    end.

Example eqb_f_f: eqb false false = true.
Proof. reflexivity. Qed.
Example eqb_t_f: eqb true false = false.
Proof. reflexivity. Qed.
Example eqb_f_t: eqb false true = false.
Proof. reflexivity. Qed.
Example eqb_t_t: eqb true true = true.
Proof. reflexivity. Qed.

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

Example notb_f: notb false = true.
Proof. reflexivity. Qed.
Example notb_t: notb true = false.
Proof. reflexivity. Qed.

Definition andb (b_1 b_2 : bool) : bool :=
    match b_1 with
    | true => match b_2 with
        | true => true
        | false => false
        end
    | false => false
    end.

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

Example andb_f_f: andb false false = false.
Proof. reflexivity. Qed.
Example andb_t_f: andb true false = false.
Proof. reflexivity. Qed.
Example andb_f_t: andb false true = false.
Proof. reflexivity. Qed.
Example andb_t_t: andb true true = true.
Proof. reflexivity. Qed.

Theorem b_and_b_is_b : forall (b : bool),
    b && b = b.
Proof.
    intros b. destruct b.
    - reflexivity.
    - reflexivity.
Qed.

Definition orb (b_1 b_2 : bool) : bool :=
    match b_1 with
    | true => true
    | false => b_2
    end.

Example orb_f_f: orb false false = false.
Proof. reflexivity. Qed.
Example orb_t_f: orb true false = true.
Proof. reflexivity. Qed.
Example orb_f_t: orb false true = true.
Proof. reflexivity. Qed.
Example orb_t_t: orb true true = true.
Proof. reflexivity. Qed.

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

Definition xorb (b_1 b_2 : bool) : bool :=
    match b_1 with
    | true => match b_2 with
        | true => false
        | false => true
        end
    | false => match b_2 with
        | true => true
        | false => false
        end
    end.

Example xorb_f_f: xorb false false = false.
Proof. reflexivity. Qed.
Example xorb_t_f: xorb true false = true.
Proof. reflexivity. Qed.
Example xorb_f_t: xorb false true = true.
Proof. reflexivity. Qed.
Example xorb_t_t: xorb true true = false.
Proof. reflexivity. Qed.

Theorem A_implies_A : forall A : Prop,
    A -> A.
Proof.
    intros A. intros H. exact H.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Category.Composable_Chain.
Require Import Functor.Functor.

(** The image of a functor is not simply the image of its object and arrow maps as
those may not form a category. Consider the following example.

  category C:
#

             f
       x1 ——————–> y1

       x2 ——————–> y2
             g

#
   category D:
#

             h1        h2
       x ——————–> y ————————> z

       u ——————–> v
            m

#
    functor F where:
#

       F _o x1 = x
       F _o y1 = y
       F _o x2 = y
       F _o y2 = z

       F _a f = h1
       F _a g = h2

#

Here we have not drawn identity arrows and compositions of arrows in categories and
their mappings by the functor as these are trivial details.

In this case, the simple image of arrow map of F has only h1 and h2 but not their
composition and is hence not a category.

We define the image of a functor to be a sum category of the codomain category with
objects the image of object map of the functor and as morphisms image of the arrow
map of the functor closed under composition. That is, each morphism in the image
category is a morphism that corresponds to a composable chain of morohisms in the
image of the arrow map of the functor.

*)
Section Functor_Image.
  Context {C D : Category}
          (F : (C –≻ D)%functor).

  Local Open Scope morphism_scope.

  Program Definition Functor_Image :=
    SubCategory D
                (fun a => ∃ x, (F _o x)%object = a)
                (
                  fun a b f =>
                    ∃ (ch : Composable_Chain D a b),
                      (Compose_of ch) = f
                      ∧
                      Forall_Links ch (
                                     fun x y g =>
                                     ∃ (c d : Obj) (h : c –≻ d)
                                       (Fca : (F _o c)%object = x)
                                       (Fdb : (F _o d)%object = y),
                                       match Fca in (_ = Z) return Z –≻ _ with
                                         eq_refl =>
                                         match Fdb in (_ = Y) return _ –≻ Y with
                                           eq_refl => (F _a h)%morphism
                                         end
                                       end = g)
                )
                _ _.

  Ltac destr_exists :=
    progress
    (repeat
       match goal with
         [H : ∃ x, _ |- _] =>
         let x := fresh "x" in
         let Hx := fresh "H" x in
         destruct H as [x Hx]
       end).

  Next Obligation. (* Hom_Cri_id *)
  Proof.
    destr_exists.
    ElimEq.
    exists (Single (F _a id)); simpl; split; auto.
    do 3 eexists; do 2 exists eq_refl; reflexivity.
  Qed.

  Next Obligation. (* Hom_Cri_compose *)
  Proof.
    destr_exists.
    intuition.
    ElimEq.
    match goal with
        [ch1 : Composable_Chain _ ?a ?b, ch2 : Composable_Chain _ ?b ?c|- _] =>
        exists (Chain_Compose ch1 ch2); split
    end.
    rewrite <- Compose_of_Chain_Compose; trivial.
    apply Forall_Links_Chain_Compose; auto.
  Qed.

End Functor_Image.


Require Import HoTT.Basics HoTT.Types UnivalenceImpliesFunext.
Require Import Truncations.
Require Import HIT.Coeq.
Require Import Algebra.Group.
Require Import Algebra.Subgroup.
Require Import Cubical.
Import TrM.

Local Open Scope mc_mult_scope.

(** * Abelian groups *)

(** Definition of an abelian group *)

Class AbGroup := {
  abgroup_type : Type;
  abgroup_sgop :> SgOp abgroup_type;
  abgroup_unit :> MonUnit abgroup_type;
  abgroup_inverse :> Negate abgroup_type;
  abgroup_isabgroup :> IsAbGroup abgroup_type;
}.

(** We want abelian groups to be coerced to the underlying type. *)
Coercion abgroup_type : AbGroup >-> Sortclass.

(** The underlying group of an abelian group. *)
Definition group_abgroup : AbGroup -> Group.
Proof.
  intros [G ? ? ? [l ?]].
  ntc_rapply (Build_Group G _ _ _ l).
Defined.

(** We also want abelian groups to be coerced to the underlying group. *)
Coercion group_abgroup : AbGroup >-> Group.

(** Definition of Abelianization.

  Given a map F that turns any group into an abelian group, and a unit homomorphism eta_X : X -> F X. This data is considered an Abelianization if and only if for all maps X -> A, there exists a unique g such that h == g o eta X. *)
Definition IsAbelianization {G : Group} (G_ab : AbGroup)
  (eta : GroupHomomorphism G G_ab)
  := forall (A : AbGroup) (h : GroupHomomorphism G A),
    Contr (exists (g : GroupHomomorphism G_ab A), h == g o eta).

Existing Class IsAbelianization.

(** Here we define abelianization as a HIT. Specifically as a set-coequalizer of the following to maps: (a, b, c) |-> a (b c) and (a, b, c) |-> a (c b).

From this we can show that Abel G is an abelian group.

In fact this models the following HIT:

HIT Abel (G : Group) :=
 | ab : G -> Abel G
 | ab_comm : forall x y z, ab (x * (y * z)) = ab (x * (z * y)).

We also derive ab and ab_comm from our coequalizer definition, and even prove the induction and computation rules for this HIT.

This HIT was suggested by Dan Christensen.
*)

Section Abel.

  (** Let G be a group. *)
  Context (G : Group).

  (** We locally define a map uncurry2 that lets us uncurry A * B * C -> D twice. *)
  Local Definition uncurry2 {A B C D : Type}
    : (A -> B -> C -> D) -> A * B * C -> D.
  Proof.
    intros f [[a b] c].
    by apply f.
  Defined.

  (** The type Abel is defined to be the set coequalizer of the following maps G^3 -> G. *)
  Definition Abel
    := Tr 0 (Coeq
      (uncurry2 (fun a b c => a * (b * c)))
      (uncurry2 (fun a b c => a * (c * b)))).

  (** We have a natural map from G to Abel G *)
  Definition ab : G -> Abel.
  Proof.
    intro g.
    apply tr, coeq, g.
  Defined.

  (** This map has to satisfy the condition ab_comm *)
  Definition ab_comm a b c
    : ab (a * (b * c)) = ab (a * (c * b)).
  Proof.
    apply (ap tr).
    exact (cglue (a, b, c)).
  Defined.

  (** It is clear that Abel is a set. *)
  Global Instance istrunc_abel : IsHSet Abel := _.

  (** We can derive the induction principle from the ones for truncation and the coequalizer. *)
  Definition Abel_ind (P : Abel -> Type) `{forall x, IsHSet (P x)}
    (a : forall x, P (ab x)) (c : forall x y z, DPath P (ab_comm x y z)
      (a (x * (y * z))) (a (x * (z * y))))
    : forall (x : Abel), P x.
  Proof.
    serapply Trunc_ind.
    serapply Coeq_ind.
    1: apply a.
    intros [[x y] z].
    refine (transport_compose _ _ _ _ @ _).
    serapply dp_path_transport^-1.
    apply c.
  Defined.

  (** The computation rule can also be prove. *)
  Definition Abel_ind_beta_ab_comm (P : Abel -> Type)
    `{forall x, IsHSet (P x)}(a : forall x, P (ab x))
    (c : forall x y z, DPath P (ab_comm x y z)
      (a (x * (y * z))) (a (x * (z * y))))
    (x y z : G) : dp_apD (Abel_ind P a c) (ab_comm x y z) = c x y z.
  Proof.
    unfold ab_comm.
    apply dp_apD_path_transport.
    rewrite (apD_compose' tr).
    rewrite (Coeq_ind_beta_cglue _ _ _ (x, y, z)).
    unfold Abel_ind.
    refine (_ @ concat_1p _).
    refine (concat_p_pp _ _ _ @ _).
    apply whiskerR.
    apply concat_Vp.
  Defined.

  (** We also have a recursion princple. *)
  Definition Abel_rec (P : Type) `{IsHSet P} (a : G -> P)
    (c : forall x y z, a (x * (y * z)) = a (x * (z * y)))
    : Abel -> P.
  Proof.
    apply (Abel_ind _ a).
    intros; apply dp_const, c.
  Defined.

  (** Here is a simpler version of Abel_ind when our target is a HProp. This lets us discard all the higher paths. *)
  Definition Abel_ind_hprop (P : Abel -> Type) `{forall x, IsHProp (P x)}
    (a : forall x, P (ab x)) : forall (x : Abel), P x.
  Proof.
    serapply (Abel_ind _ a).
    intros; apply dp_path_transport.
    apply path_ishprop.
  Defined.

  (** And its recursion version. *)
  Definition Abel_rec_hprop (P : Type) `{IsHProp P}
    (a : G -> P) : Abel -> P.
  Proof.
    apply (Abel_rec _ a).
    intros; apply path_ishprop.
  Defined.

End Abel.

(** We make sure that G is implicit in the arguments of ab and ab_comm. *)
Arguments ab {_}.
Arguments ab_comm {_}.

(** Now we can show that Abel G is infact an abelian group. *)

Section AbelGroup.

  Context `{Funext} (G : Group).

  (** Firstly we derive the operation on Abel G. This is defined as follows:
        ab x + ab y := ab (x y)
      But we need to also check that it preserves ab_comm in the appropriate way. *)
  Global Instance abel_sgop : SgOp (Abel G).
  Proof.
    serapply Abel_rec.
    { intro a.
      serapply Abel_rec.
      { intro b.
        exact (ab (a * b)). }
      intros b c d; cbn.
      refine (ab_comm _ _ _ @ _).
      refine (ap _ _ @ _).
      { refine (ap _ (associativity _ _ _)^ @ _).
        refine (associativity _ _ _). }
      refine (ab_comm _ _ _ @ _).
      refine (ap _ (associativity _ _ _)^ @ _).
      refine (ab_comm _ _ _ @ _).
      refine (ap _ (ap _ (associativity _ _ _)^)). }
    intros a b c.
    apply path_forall.
    serapply Abel_ind_hprop.
    cbn; intro d.
    refine (ap _ (associativity _ _ _)^ @ _).
    refine (ap _ (ap _ (associativity _ _ _)^) @ _).
    refine (ab_comm _ _ _ @ _).
    refine (ap _ (ap _ (associativity _ _ _)^) @ _).
    refine (ap _ (associativity _ _ _) @ _).
    refine (ab_comm _ _ _ @ _).
    refine (ap _ (associativity _ _ _)^ @ _).
    refine (ap _ (ap _ (associativity _ _ _)) @ _).
    refine (ap _ (associativity _ _ _)).
  Defined.

  (** We can now easily show that this operation is associative by associativity in G and the fact that being associative is a proposition. *)
  Global Instance abel_sgop_associative : Associative abel_sgop.
  Proof.
    serapply Abel_ind_hprop; intro x.
    serapply Abel_ind_hprop; intro y.
    serapply Abel_ind_hprop; intro z.
    cbn; apply ap, associativity.
  Defined.

  (** From this we know that Abel G is a semigroup. *)
  Global Instance abel_issemigroup : IsSemiGroup (Abel G) := {}.

  (** We define the unit as ab of the unit of G *)
  Global Instance abel_mon_unit : MonUnit (Abel G) := ab mon_unit.

  (** By using Abel_ind_hprop we can prove the left and right identity laws. *)
  Global Instance abel_leftidentity : LeftIdentity abel_sgop abel_mon_unit.
  Proof.
    serapply Abel_ind_hprop; intro x.
    cbn; apply ap, left_identity.
  Defined.

  Global Instance abel_rightidentity : RightIdentity abel_sgop abel_mon_unit.
  Proof.
    serapply Abel_ind_hprop; intro x.
    cbn; apply ap, right_identity.
  Defined.

  (** Hence Abel G is a monoid *)
  Global Instance ismonoid_abel : IsMonoid (Abel G) := {}.

  (** We can also prove that the operation is commutative! This will come in handy later. *)
  Global Instance abel_commutative : Commutative abel_sgop.
  Proof.
    serapply Abel_ind_hprop; intro x.
    serapply Abel_ind_hprop; intro y.
    cbn.
    rewrite <- (left_identity (x * y)).
    rewrite <- (left_identity (y * x)).
    apply ab_comm.
  Defined.

  (** Now we can define the negation. This is just
        - (ab g) := (ab (g^-1)
      However when checking that it respects ab_comm we have to show the following:
        ab (- z * - y * - x) = ab (- y * - z * - x)
      there is no obvious way to do this, but we note that ab (x * y) is exactly the definition of ab x + ab y! Hence by commutativity we can show this. *)
  Global Instance abel_negate : Negate (Abel G).
  Proof.
    serapply Abel_rec.
    { intro g.
      exact (ab (-g)). }
    intros x y z; cbn.
    rewrite ?negate_sg_op.
    change (ab(- z) * ab(- y) * ab (- x) = ab (- y) * ab (- z) * ab(- x)).
    by rewrite (commutativity (ab (-z)) (ab (-y))).
  Defined.

  (** Again by Abel_ind_hprop and the corresponding laws for G we can prove the left and right inverse laws. *)
  Global Instance abel_leftinverse : LeftInverse abel_sgop abel_negate abel_mon_unit.
  Proof.
    serapply Abel_ind_hprop; intro x.
    cbn; apply ap; apply left_inverse.
  Defined.

  Instance abel_rightinverse : RightInverse abel_sgop abel_negate abel_mon_unit.
  Proof.
    serapply Abel_ind_hprop; intro x.
    cbn; apply ap; apply right_inverse.
  Defined.

  (** Thus Abel G is a group *)
  Global Instance isgroup_abel : IsGroup (Abel G) := {}.

  (** And since the operation is commutative and abelian group. *)
  Global Instance isabgroup_abel : IsAbGroup (Abel G) := {}.

  (** By definition, the map ab is also a group homomorphism. *)
  Global Instance issemigrouppreserving_ab : IsSemiGroupPreserving ab.
  Proof.
    by unfold IsSemiGroupPreserving.
  Defined.

End AbelGroup.

(** We can easily prove that ab is a surjection. *)
Global Instance issurj_ab `{Funext} {G : Group} : IsSurjection ab.
Proof.
  serapply Abel_ind_hprop.
  intro x; cbn.
  exists (tr (x; @idpath _ (ab x))).
  apply path_ishprop.
Defined.

(** Now we finally check that our definition of abelianization satisfies the universal property of being an abelianization. *)
Section Abelianization.

  Context `{Funext}.

  (** We define abel to be the abelianization of a group. This is a map from Group to AbGroup. *)
  Definition abel : Group -> AbGroup.
  Proof.
    intro G.
    serapply (Build_AbGroup (Abel G)).
  Defined.

  (** The unit of this map is the map ab which typeclasses can pick up to be a homomorphism. We write it out explicitly here. *)
  Definition abel_unit (X : Group)
    : GroupHomomorphism X (abel X).
  Proof.
    simple notypeclasses refine (Build_GroupHomomorphism _).
    + exact ab.
    + exact _.
  Defined.

  (** Finally we can prove that our construction abel is an abelianization. *)
  Global Instance isabelianization_abel {G : Group}
    : IsAbelianization (abel G) (abel_unit G).
  Proof.
    intros A h.
    serapply Build_Contr.
    { srefine (_;_).
      { simple notypeclasses refine (Build_GroupHomomorphism _).
        { serapply (Abel_rec _ _ h).
          intros x y z.
          refine (grp_homo_op _ _ _ @ _ @ (grp_homo_op _ _ _)^).
          apply (ap (_ *.)).
          refine (grp_homo_op _ _ _ @ _ @ (grp_homo_op _ _ _)^).
          apply commutativity. }
        serapply Abel_ind_hprop; intro x.
        serapply Abel_ind_hprop; intro y.
        apply grp_homo_op. }
      cbn; reflexivity. }
    intros [g p].
    apply path_sigma_hprop; cbn.
    apply equiv_path_grouphomomorphism.
    serapply Abel_ind_hprop.
    exact p.
  Defined.

End Abelianization.

Theorem groupiso_isabelianization {G : Group}
  (A B : AbGroup)
  (eta1 : GroupHomomorphism G A)
  (eta2 : GroupHomomorphism G B)
  {x : IsAbelianization A eta1}
  {y : IsAbelianization B eta2}
  : GroupIsomorphism A B.
Proof.
  unfold IsAbelianization in x, y.
  destruct (x B eta2) as [[a ah] ac].
  destruct (y A eta1) as [[b bh] bc].
  destruct (x A eta1) as [[c ch] cc].
  destruct (y B eta2) as [[d dh] dc].
  serapply (Build_GroupIsomorphism _ _ a).
  serapply (isequiv_adjointify _ b).
  { apply ap10.
    change (@grp_homo_map _ _ (grp_homo_compose a b)
      = @grp_homo_map _ _ grp_homo_id).
    refine (ap (@grp_homo_map _ _) _).
    refine (ap pr1 ((dc (_; _))^ @ dc (grp_homo_id; _))).
    1: exact (fun i => ah i @ ap a (bh i)).
    reflexivity. }
  { apply ap10.
    change (@grp_homo_map _ _ (grp_homo_compose b a)
      = @grp_homo_map _ _ grp_homo_id).
    refine (ap (@grp_homo_map _ _) _).
    refine (ap pr1 ((cc (_; _))^ @ cc (grp_homo_id; _))).
    1: exact (fun i => bh i @ ap b (ah i)).
    reflexivity. }
Defined.

Theorem homotopic_isabelianization {G : Group} (A B : AbGroup)
  (eta1 : GroupHomomorphism G A) (eta2 : GroupHomomorphism G B)
  {x : IsAbelianization A eta1} {y : IsAbelianization B eta2}
  : eta2 == grp_homo_compose (groupiso_isabelianization A B eta1 eta2) eta1.
Proof.
  unfold IsAbelianization in x, y.
  destruct (x B eta2) as [[a ah] ac].
  destruct (y A eta1) as [[b bh] bc].
  refine (transport (fun e : GroupHomomorphism A B
    => _ == (fun x : G => e (eta1 x))) (ap pr1 (ac _)) ah).
Defined.

(** Hence any abelianization is surjective. *)
Global Instance issurj_isabelianization `{Funext} {G : Group}
  (A : AbGroup) (eta : GroupHomomorphism G A)
  : IsAbelianization A eta -> IsSurjection eta.
Proof.
  intros k.
  pose (homotopic_isabelianization A (abel G) eta (abel_unit G)) as p.
  refine (@cancelR_isequiv_conn_map _ _ _ _ _ _ _
    (conn_map_homotopic _ _ _ p _)).
Qed.

Global Instance isequiv_abgroup_abelianization `{U : Univalence}
  (A B : AbGroup) (eta : GroupHomomorphism A B) {H : IsAbelianization B eta}
  : IsEquiv eta.
Proof.
  destruct (H A grp_homo_id) as [[a ah] ac].
  serapply (isequiv_adjointify eta a).
  + simpl.
    Require HIT.epi.
    apply ap10.
    pose (epi.issurj_isepi eta _) as i.
    refine (i _ _ idmap _).
    apply path_forall.
    intro x.
    apply ap.
    symmetry.
    apply ah.
  + change (a o eta == idmap); symmetry.
    apply ah.
Defined.


(********************************************************************************)
(* Quicksort *)

From sortalgs Require Import sorted.

Open Scope list_scope.
Import List.ListNotations.

Require Import Recdef.

Lemma lem_partition `{DecTotalOrder} :
  forall x l1 l2, Sorted l1 -> Sorted l2 -> GeLst x l1 -> LeLst x l2 ->
                        Sorted (l1 ++ x :: l2).
Proof.
  induction l1.
  - inversion 4; sauto lq: on.
  - inversion 1; inversion 2; hauto use: lem_sorted_tail ctrs: Sorted.
Qed.

Function partition {A} {dto : DecTotalOrder A} (x : A) (l : list A)
  {measure length l} : list A * list A :=
  match l with
  | [] => ([], [])
  | h :: t =>
    match partition x t with
    | (t1, t2) =>
      if leb h x then
        (h :: t1, t2)
      else
        (t1, h :: t2)
    end
  end.
Proof.
  sauto.
Defined.

Arguments partition {_ _}.

Lemma lem_partition_perm `{DecTotalOrder} :
  forall l l1 l2 x, partition x l = (l1, l2) -> Permutation l (l1 ++ l2).
Proof.
  induction l.
  - sauto.
  - intros *.
    rewrite partition_equation.
    hauto use: Permutation_middle, @leb_total.
Qed.

Lemma lem_partition_parted `{DecTotalOrder} :
  forall l l1 l2 x, partition x l = (l1, l2) -> GeLst x l1 /\ LeLst x l2.
Proof.
  induction l.
  - sauto.
  - intros *.
    rewrite partition_equation.
    hauto use: lem_neg_leb.
Qed.

Function qsort {A} {dto : DecTotalOrder A} (l : list A) {measure length l}
  : list A :=
  match l with
  | [] => []
  | h :: t =>
    match partition h t with
    | (t1, t2) => qsort t1 ++ [h] ++ qsort t2
    end
  end.
Proof.
  all: intros; hauto use: lem_partition_perm, Permutation_length db: list.
Defined.

Arguments qsort {_ _}.

Lemma lem_qsort_perm `{DecTotalOrder} :
  forall l, Permutation l (qsort l).
Proof.
  intro l.
  functional induction (qsort l).
  - sauto.
  - hauto lq: on use: lem_partition_perm, perm_trans, perm_skip, Permutation_middle, Permutation_app.
Qed.

Lemma lem_qsort_sorted `{DecTotalOrder} :
  forall l, Sorted (qsort l).
Proof.
  intro l.
  functional induction (qsort l).
  - sauto.
  - hauto lq: on use: lem_partition_parted, lem_qsort_perm, lem_gelst_perm, lem_lelst_perm, lem_partition.
Qed.


(*Require Import notations.
Require Import option.
Require Import String.*)

Require Import String.
Require Import List.
Import ListNotations.
Require Import Datatypes.
Require Import Ascii.

Local Open Scope list_scope.

Section list_prob.
(* Variable A:Type.  a changer / modifier *)

(* 1.01 Find the last element of a list. *)
Fixpoint last {A:Type}(l:list A): option A :=
    match l with
    | nil => None
    | x :: nil => Some x
    | _ :: y => last y
    end.

Local Open Scope string_scope.
Example test_last: last ["a";"b";"c";"d"] = Some "d".
Proof. reflexivity. Qed.
Close Scope string_scope.

Theorem last_append {A:Type}: forall (x:A) (l:list A), last(l++[x]) = Some x.
Proof.
    intros x l.
    induction l.
    - reflexivity.
    - simpl. rewrite IHl. destruct (l++[x]).
        * (* last [] = Some x impossible *) inversion IHl.
        * reflexivity.
Qed.

Theorem last_rev {A:Type}: forall (x:A) (l:list A), last (List.rev (x::l)) = Some x .
Proof.
    intros x l.
    simpl. apply last_append.
Qed.

(* 1.02 Find the last but one element of a list. *)
Fixpoint last_but_one {A:Type}(l:list A): option A :=
    match l with
    | nil => None
    | x :: y :: nil => Some x
    | _ :: y => last_but_one y
    end.

Local Open Scope string_scope.
Example test_last_but_one: last_but_one ["a";"b";"c";"d"] = Some "c".
Proof. reflexivity. Qed.
Close Scope string_scope.

Theorem last_but_one_append {A:Type}: forall (l:list A) (x:A) (y:A),
    last_but_one (l ++ [x;y]) = Some x.
  Proof.
    intros l x y.
    induction l.
    - reflexivity.
    - simpl. destruct (l ++ [x;y]).
        * (* last_but_one [] = Some x impossible *) inversion IHl.
        * rewrite IHl. destruct l0.
            ** (* Some a = Some x impossible *) inversion IHl.
            ** reflexivity.
  Qed.

(* 1.03 Find the K'th element of a list. *)
(* en commencant la notation à 0 *)
Fixpoint element_at {A:Type}(l:list A)(n: nat): option A :=
    match n, l with
    | _, nil => None
    | O, x :: _ => Some x
    | S n', _ :: y => element_at y n'
    end.

(* en commencant la notation à 1 *)
Fixpoint element_at_bis {A:Type}(l:list A)(n: nat): option A :=
    match n, l with
    | _, nil => None
    | O, _ => None
    | S O, x :: _ => Some x
    | S n', _ :: y => element_at_bis y n'
    end.

Local Open Scope string_scope.
Example test_element_at: element_at ["a";"b";"c";"d"] 3 = Some "d".
Proof. reflexivity. Qed.

Example test_element_at_bis: element_at_bis ["a";"b";"c";"d"] 3 = Some "c".
Proof. reflexivity. Qed.
Close Scope string_scope.

Theorem element_at_bis_0 {A:Type}: forall (l:list A), element_at_bis l 0 = None.
Proof.
    intro l.
    case l.
    - reflexivity.
    - intros x l'. reflexivity.
Qed.

Theorem element_at_bis_append {A:Type}: forall (l:list A) (x:A),
    element_at_bis (l ++ [x]) (length l + 1) = Some x.
  Proof.
    intros l x.
    induction l.
    - reflexivity.
    - simpl. destruct (length l + 1).
        * rewrite element_at_bis_0 in IHl. (* None = Some x impossible *) inversion IHl.
        * apply IHl.
  Qed.

(* 1.04 Find the number of elements of a list. *)
Fixpoint length2 {A:Type}(l:list A): nat :=
    match l with
    | nil => O
    | _ :: y => S (length2 y)
    end.

Local Open Scope string_scope.
Example test_length2: length2 ["a";"b";"c";"d"] = 4.
Proof. reflexivity. Qed.
Close Scope string_scope.

Theorem length2_append {A:Type}: forall (l1 l2:list A),
    length2 l1 + length2 l2 = length2 (l1 ++ l2).
  Proof.
    intros l1 l2.
    induction l1.
    - (* length l2 = length l2 *) reflexivity.
    - simpl. rewrite IHl1. reflexivity.
  Qed.

Theorem length2_eq_length {A:Type}: forall (l:list A),
  length2 l = length l.
Proof.
  intro l.
  induction l.
  - (* 0=0 *) reflexivity.
  - simpl. rewrite IHl. reflexivity.
Qed.

(* 1.05 Reverse a list. *)
Fixpoint rev_list {A:Type}(l:list A): list A :=
    match l with
    | nil => nil
    | x :: y =>  rev_list y ++ [ x ]
    end.

(* sans utiliser ++ *)
Fixpoint rev_list_bis {A:Type}(l:list A): list A :=
    (fix sub(l l':list A): list A :=
    match l with
    | nil => l'
    | x :: y =>  sub y (x :: l')
    end) l nil.

Local Open Scope string_scope.
Example test_rev_list: rev_list ["a";"b";"c";"d"] = ["d";"c";"b";"a"].
Proof. reflexivity. Qed.

Example test_rev_list_bis: rev_list_bis ["a";"b";"c";"d"] = ["d";"c";"b";"a"].
Proof. reflexivity. Qed.
Close Scope string_scope.

Theorem rev_list_append {A:Type}: forall (l:list A)(x:A),
rev_list (l++[x]) = x::(rev_list l).
Proof.
    intros l x.
    induction l.
    - reflexivity.
    - simpl. rewrite IHl. reflexivity.
Qed.

Theorem rev_cons {A:Type}: forall (l:list A)(x:A),
rev_list (x::l) = (rev_list l)++[x].
Proof.
    intros l x.
    case l.
    - reflexivity.
    - simpl. reflexivity.
Qed.

Theorem rev_list_involutive {A:Type}: forall (l:list A),
    rev_list (rev_list l) = l.
Proof.
    intro l.
    induction l.
    - reflexivity.
    - simpl. rewrite rev_list_append. rewrite IHl. reflexivity.
Qed.

Theorem rev_eq_rev_list {A:Type}: forall (l:list A),
    rev_list l = rev l.
Proof.
    intro l.
    induction l.
    - reflexivity.
    - simpl. rewrite IHl. reflexivity.
Qed.

(* 1.06 Find out whether a list is a palindrome. *)
Section pal_A_dec.
Variable A:Type. (* on crée une variable pour pouvoir indiquer que A doit être décidable *)
Hypothesis A_dec : forall x y:A, {x = y} + {x <> y}.

Theorem not_x_x: forall (x:A), x <> x -> false = true.
Proof.
    intros. pose (Bool.absurd_eq_true) as X. apply X. apply H. apply (eq_refl x).
Qed.

Theorem not_x_x_bis: forall (x:A)(P:Prop), x <> x -> P.
Proof.
    intros.
    apply not_x_x in H. discriminate.
Qed.

Fixpoint equal_lists (l l':list A): bool :=
match l, l' with
| nil, nil => true
| x :: y, x' :: y' => match A_dec x x' with
                      | left _ => equal_lists y y'
                      | right _ => false
                      end
| _, _ => false
end.

(* en utilisant list_eq_dec *)
Fixpoint equal_lists_bis (l l':list A): bool :=
match list_eq_dec A_dec l l' with
| left _ => true
| right _ => false
end.

Theorem equal_lists_l_l: forall (l:list A), equal_lists l l = true .
Proof.
    intro l. induction l.
    - reflexivity.
    - simpl. case (A_dec a a).
        * intro h. apply IHl.
        * apply not_x_x.
Qed.

Definition is_palindrome (l:list A): bool :=
    equal_lists l (rev_list l).

(* Alternativement on peut définir un type inductif *)
Inductive palindrome : list A -> Prop :=
|Empty : palindrome nil
|Single : forall n, palindrome [n]
|Rcons : forall (n : A)(l : list A), palindrome l -> palindrome (n :: l ++ [n]).
Print is_palindrome.

Theorem is_palindrome_nil: is_palindrome [] = true.
Proof.
    unfold is_palindrome.
    simpl. reflexivity.
Qed.

Theorem equal_lists_cons: forall (x:A)(l l':list A),
    equal_lists (x::l) (x::l') = equal_lists l l'.
Proof.
    intros. destruct (A_dec x x).
    - simpl. destruct (A_dec x x).
        * reflexivity.
        * absurd (x=x). apply n. apply e.
    -  pose (Bool.absurd_eq_bool) as X. apply X. apply n. apply (eq_refl x).
Qed.

Lemma nil_cons (x:A)(l:list A)
: not (nil=cons x l).
intro.
discriminate.
Qed.

Lemma nil_app (x:A)(l:list A)
: not (nil= l++[x]).
destruct l. simpl. discriminate.
discriminate.
Qed.

Theorem palindrome_self_rev : forall (l: list A),
  palindrome (l ++ rev l).
Proof.
  intros. induction l.
  - simpl. apply Empty.
  - simpl. rewrite app_assoc. apply Rcons. apply IHl.
Qed.

Theorem palindrome_rev: forall (l:list A), palindrome l -> l = rev l.
  intros. induction H.
  - reflexivity.
  - reflexivity.
  - simpl. rewrite rev_unit. rewrite <- IHpalindrome. reflexivity.
Qed.

(* ############ Demo l = rev l -> palindrome l ############## *)

Lemma fib_ind :
 forall P:nat -> Prop,
   P 0 ->
   P 1 ->
  (forall n:nat, P n -> P (S n) -> P (S (S n))) ->
  forall n:nat, P n.
Proof.
 intros P H0 H1 HSSn n. cut (P n /\ P (S n)).
 - intro H. inversion H. apply H2.
 - induction n.
    * split.
        ** apply H0.
        ** apply H1.
    * split.
        ** inversion IHn. apply H2.
        ** apply HSSn.
            *** inversion IHn. apply H.
            *** inversion IHn. apply H2.
Qed.

Definition lfirst {X} (l: list X) : list X :=
  match l with
  | [] => []
  | x :: l => [x]
end.

Definition init {X} (l: list X) : list X := rev (tail (rev l)).

Definition llast {X} (l: list X) : list X := rev (lfirst (rev l)).

Theorem app_r_nil : forall X (l: list X),
  l ++ [] = l.
Proof. intros. induction l. reflexivity. simpl. rewrite IHl. reflexivity.
Qed.

Lemma rev_app_rev : forall X (a b:list X),
  rev a ++ rev b = rev (b ++ a).
Proof. intros X a. induction a; intros.
  rewrite app_r_nil. reflexivity.
  simpl. rewrite <- app_assoc.
  remember ([a] ++ rev b) as xrb.
  rewrite <- rev_involutive with X xrb. rewrite IHa.
  simpl in Heqxrb. rewrite Heqxrb. simpl.
  rewrite rev_involutive. rewrite <- app_assoc. simpl. reflexivity.
Qed.

Theorem rev_bij : forall X (l1 l2: list X),
  l1 = l2 <-> rev l1 = rev l2.
Proof. intros. split. intro H. rewrite H. reflexivity.
  intro H. rewrite <- rev_involutive. rewrite <- rev_involutive at 1.
  rewrite H. rewrite ? rev_involutive. reflexivity.
Qed.

Theorem first_app_tail : forall X (l: list X),
  l = lfirst l ++ tail l.
Proof. intros.
  destruct l. reflexivity.
  simpl. reflexivity.
Qed.

Theorem init_app_last : forall X (l: list X),
  l = init l ++ llast l.
Proof. intros.
  unfold init. unfold llast. rewrite rev_app_rev.
  rewrite <- rev_involutive at 1. rewrite <- rev_bij.
  apply first_app_tail.
Qed.

Theorem snoc_tail_almost_comm : forall X (x: X) (l: list X),
  l <> [] -> tail (l ++ [x]) = (tail l) ++ [x].
Proof. intros. destruct l.
    - exfalso. apply H. reflexivity.
    - reflexivity.
Qed.

Lemma lfirst_almost_init_inv : forall X (x y: X) (l: list X),
  lfirst (init (x::y::l)) = lfirst (x::y::l).
Proof. intros. unfold init. remember (y::l) as yl. simpl.
  rewrite snoc_tail_almost_comm.
  rewrite rev_unit. reflexivity.
  rewrite Heqyl. rewrite rev_bij. rewrite rev_involutive. simpl.
  discriminate.
Qed.

Theorem split_ends : forall X (l: list X) (x y: X),
 (x::y::l) = lfirst (x::y::l) ++ tail (init (x::y::l)) ++ llast (x::y::l).
Proof. intros.
  rewrite init_app_last at 1.
  rewrite first_app_tail with (l := init (x::y::l)) at 1.
  rewrite lfirst_almost_init_inv. reflexivity.
Qed.

Theorem first_single : forall X (x y:X) (l: list X), l <> [] -> exists k, lfirst (l) = [k].
Proof. intros. induction l. unfold not in H. exfalso. apply H. reflexivity.
  exists a. reflexivity.
Qed.

Theorem last_single : forall X (x y:X) (l: list X), l <> [] -> exists k, llast (l) = [k].
Proof. intros. induction l. unfold not in H.  exfalso. apply H. reflexivity.
unfold llast. assert (exists z, lfirst (rev (a :: l)) =  [z]).
  apply first_single. assumption. assumption. rewrite rev_bij. rewrite rev_involutive. simpl. discriminate.
  inversion H0. rewrite H1. exists x0. reflexivity.
Qed.

Lemma length_app :
 forall X (l l':list X), length (l ++ l') = length l + length l'.
Proof.
  intros X l; elim l; simpl; auto.
Qed.

Require Import Arith.

Theorem list_induction : forall X (P : list X -> Prop),
       P [] ->
       (forall (x : X), P [x]) ->
       (forall (x y : X) (l : list X), P l -> P (x :: l ++ [y])) ->
       forall l : list X, P l.
Proof.
 intros.
 cut (forall (n:nat) (l:list X), length l = n -> P l).
 - (* Case "Proof of assertion" *) intros. eapply H2. reflexivity.
 - intro n. pattern n. apply fib_ind.
    * (* Case "length is 0". *) intros. apply length_zero_iff_nil in H2. rewrite H2. apply H.
    * (* Case "length is 1". *) intros. destruct l0.
        ** simpl in H2. inversion H2.
        ** simpl in H2. inversion H2. apply length_zero_iff_nil in H4. rewrite H4. apply H0.
    * (*  Case "length is S S n". *) intros. destruct l0.
        ** simpl in H4. inversion H4.
        ** destruct l0.
            *** simpl in H4. inversion H4.
            *** rewrite split_ends. simpl. rewrite split_ends in H4. simpl in H4. inversion H4.
                assert(x::x0::l0 <> []).
                + unfold not. intro contra. inversion contra.
                + apply last_single in H5.
                    ++ inversion H5. rewrite H7.  apply H1. apply H2. rewrite H7 in H6.
                       rewrite length_app in H6. simpl in H6. rewrite plus_comm in H6.
                      inversion H6. reflexivity.
                    ++ assumption.
                    ++ assumption.
Qed.

Theorem app_l_eq : forall X (l1 l2 m: list X), m ++ l1 = m ++ l2 -> l1 = l2.
Proof. intros. induction m. simpl in H. apply H.
 inversion H. apply IHm in H1. apply H1.
Qed.

Theorem app_r_eq : forall X (l1 l2 m: list X), l1 ++ m = l2 ++ m -> l1 = l2.
Proof. intros. rewrite rev_bij in H. rewrite <- 2? rev_app_rev in H.
 apply app_l_eq in H. rewrite <- rev_bij in H. apply H.
Qed.

Theorem rev_pal : forall (l: list A),
  l = rev l -> palindrome l.
intros l. pattern l. apply list_induction; intros. Print palindrome.
 apply Empty.  apply Single. simpl in H0.
 rewrite rev_unit in H0.
 simpl in H0. inversion H0.
 apply Rcons.
 apply H.
 apply app_r_eq in H3. apply H3.
Qed.

(* ############ Fin Demo l = rev l -> palindrome l ############## *)

(*Lemma palindromic_rev : forall l:list A, palindrome l -> rev_list l = l.
Proof.
    intros l H.
    induction l. reflexivity.
    simpl. generalize IHl. inversion H. simpl. reflexivity.
    simpl. intros. rewrite rev_list_append. simpl.
    elim H. destruct l. discriminate.
    elim H. reflexivity.
    reflexivity.
    intros. simpl. rewrite rev_list_append. simpl.

intros l H. elim H. simpl. auto with datatypes.
intros a l0 m H0 H1 H2.
generalize H1; inversion_clear H2.
simpl; auto.
rewrite (remove_last_inv H3).
simpl.
repeat (rewrite rev_app; simpl).
intro eg; rewrite eg.
simpl; auto.
Qed. *)

Theorem equal_lists_append: forall (x:A)(l1 l2:list A),
    equal_lists (l1 ++ [x]) (l2 ++ [x]) = equal_lists l1 l2.
Proof.
    intros.
    Admitted.

Theorem is_palindrome_append: forall (l:list A)(x:A),
    is_palindrome l = is_palindrome (x :: (l ++ [x])).
Proof.
    intros l x.
    unfold is_palindrome.
    rewrite rev_cons. rewrite rev_list_append. rewrite <- app_comm_cons.
    rewrite (equal_lists_cons x). rewrite (equal_lists_append x). reflexivity.
Qed.

Theorem palindrome_nil: forall (l:list A), l=[] -> palindrome l.
Proof.
    intros.
    subst.
    constructor.
Qed.

Theorem cons_app_pal: forall (l:list A)(a:A),
    is_palindrome l = true -> is_palindrome (a :: l ++ [a]) = true.
Proof.
    intros.
    induction l.
    - simpl. unfold is_palindrome. simpl. case (A_dec a a).
        * reflexivity.
        * apply not_x_x.
    - simpl. unfold is_palindrome in *. Admitted.

Theorem pal_self_rev : forall (l: list A),
  is_palindrome (l ++ rev l) = true.
intros. induction l.
    - reflexivity.
    - simpl. assert (P: a :: (l ++ rev l) ++ [a] = a :: l ++ rev l ++ [a]).
        * rewrite app_assoc. reflexivity.
        * rewrite <- P. apply (cons_app_pal (l ++ rev l) a). apply IHl.
Qed.
End pal_A_dec.

Example test_palindrome: is_palindrome nat PeanoNat.Nat.eq_dec [2;3;3;2] = true.
Proof. reflexivity. Qed.

(* Theorem rev_eq_pal_length: forall (n: nat) (l: list A),
    length l <= n -> l = rev l -> palindrome l.
Proof.
(* by induction on [n], not [l] *)
    intros.
    induction n.
    - destruct l as [|a l'].
        * constructor.
        * simpl in H. inversion H.
    - destruct l as [|a l'].
        * constructor.
        * inversion H0. destruct (rev l').
            ** simpl in H2. inversion H2. constructor.
            ** rewrite H2. induction l.
                *** simpl. simpl in H2. inversion H2. subst. assert (P:[a0;a0]=a0::[]++[a0]). reflexivity. rewrite P. constructor.
                *** inversion H2. subst.
             subst. simpl in H. inversion H. subst. simpl in IHn.
Qed. *)

(*    simpl.
    destruct l.
    - simpl. case (A_dec x x).
        * reflexivity.
        * intro n. pose (Bool.absurd_eq_true) as X. apply eq_sym. apply X. apply n. apply (eq_refl x).
    - apply f_equal. simpl.

    - intro. destruct l. simpl. apply e. reflexivity.

    rewrite <- (equal_lists_eq l (rev_list l)). case (A_dec x x).
    intro n.

    induction l.
    - unfold is_palindrome. simpl. case (A_dec x x).
        * reflexivity.
        * unfold not. intro n. pose (Bool.absurd_eq_true) as X. apply eq_sym. apply X. apply n. apply (eq_refl x).
    - unfold is_palindrome. rewrite rev_cons. inversion IHl.
     simpl. case rev_list l ++ [a].

        apply (not(eq_refl x)). intro t. Print eq_refl. apply (eq_refl x) in t. intro test. rewrite test in t. Print absurd. rewrite test. intro t.
        simpl.  Locate "<>". inversion n.   *)

(*

Variable B : Type.
Variable F : B -> Type.

Inductive hlist : list B -> Type :=
| Hnil : hlist nil
| Hcons : forall (x:B)(ls:list B), F x -> hlist ls -> hlist (x::ls).

(* DefinBion hlist_hd {T Ts} (h : hlist (T :: Ts)) : F T :=
  match h wBh
  | Hcons x _ => x
  | Hnil => tt
  end. *)

Variable elm: B.

Inductive member : list B -> Type :=
| HFirst : forall ls, member (elm :: ls)
| HNext : forall x ls, member ls -> member (x :: ls).
Print Hnil.
Implicit Arguments Hnil [B F].
Implicit Arguments Hcons [ B F x ls ].

Eval compute in Hcons 2 (Hcons [3,4] (Hnil)).

TODO: implementer les listes heterogenes *)

(* 1.07 Flatten a nested list structure. *)

(* probleme pour le cas [1;[1;2];3] => concatenation de listes mais pas d'imbrication *)
Inductive nlist (A:Type): Type :=
| n0 : nlist A
| ucons : A -> nlist A -> nlist A
| lcons : nlist A -> nlist A -> nlist A.

Implicit Arguments n0 [A].
Implicit Arguments ucons [A].
Implicit Arguments lcons [A].

(*
Notation "x :: l" := (ucons x l)(at level 60, right associativity) : nlist_scope.
Notation "[ ]" := n0 : nlist_scope.
Notation "[ x ]" := (ucons x n0) : nlist_scope.
Notation "[ x ; .. ; y ]" := (ucons x .. (ucons y n0) ..) : nlist_scope.
Notation "[ x , .. , y , z ]" := (lcons x .. (lcons y z) ..) : nlist_scope.
Local Open Scope nlist_scope. *)

Eval compute in lcons (ucons 1 n0) (ucons 1 (ucons 1 n0)).
Eval compute in ucons 1 (ucons  2 n0).
Eval compute in lcons (ucons 1  (ucons 2 (ucons 3 n0))) (ucons 1 (ucons 2 n0)).
 (* Eval compute in lcons [ 1 ; 2 ; 3 ] [1;2].
Eval compute in lcons [ 1 ; 2 ; 3 ] (lcons [1;2] [1;2;3;4]) . *)

Fixpoint nlength {A:Type} (l:nlist A): nat :=
match l with
| n0 => 0
| ucons h t => S (nlength t)
| lcons l1 l2 => 2
end.

Fixpoint my_flatten {A:Type} (l:nlist A): list A :=
match l with
| n0 => nil
| ucons h t => h :: my_flatten t
| lcons l1 l2 => my_flatten l1 ++ my_flatten l2
end.

Example test_my_flatten:
my_flatten (lcons (ucons 1  (ucons 2 (ucons 3 n0))) (ucons 1 (ucons 2 n0))) = [1;2;3;1;2].
Proof. reflexivity. Qed.

(* Eval compute in my_flatten (lcons [ 1 ; 2 ; 3 ] (lcons [1;2] [1;2;3;4])).
Local Close Scope nlist_scope.
Local Open Scope list_scope. *)

(* 1.08 Eliminate consecutive duplicates of list elements. *)
Section compress_A_dec.
Variable A:Type.
Hypothesis A_dec : forall x y:A, {x = y} + {x <> y}.

Fixpoint compress (l:list A): list A :=
match l with
| nil => nil
| h :: t => match t with
            | h' :: t' => match A_dec h h' with
                          | left _ => compress t
                          | right _ => h :: compress t
                          end
            | nil => l
            end
end.

Fixpoint compress_bis (l:list A): list A :=
match l with
|nil => nil
| h :: t => h :: (fix sub (l:list A) (last:A): list A :=
                match l with
                |nil => nil
                | h :: t => match A_dec h last with
                            | left _ => sub t last
                            | right _ => h :: (sub t h)
                            end
                end) l h
end.

Theorem compress_append: forall (x:A)(l:list A),
    compress ([x;x] ++ l) = compress (x::l) .
Proof.
    intros. simpl. case (A_dec x x).
    - intro. destruct l.
        * reflexivity.
        * reflexivity.
    - simpl. apply not_x_x_bis.
Qed.

Theorem compress_cons: forall (x:A)(l:list A),
    compress (x::l) = x::(compress l) \/ compress (x::l) = compress l.
Proof.
    intros x l. destruct l.
    - simpl. left. reflexivity.
    - simpl. case (A_dec x a).
        * right. reflexivity.
        * left. reflexivity.
Qed.
End compress_A_dec.

Example test_compress:
compress nat PeanoNat.Nat.eq_dec [2;3;3;2;2;1;1;1] = [2;3;2;1].
Proof. reflexivity. Qed.

Example test_compress_bis:
compress_bis nat PeanoNat.Nat.eq_dec [2;3;3;2;2;1;1;1] = [2;3;2;1].
Proof. reflexivity. Qed.

(* 1.09 Pack consecutive duplicates of list elements into sublists. *)
Section pack_A_dec.
Variable A:Type.
Hypothesis A_dec : forall x y:A, {x = y} + {x <> y}.

Fixpoint pack (l:list A): list (list A) :=
match l with
| nil => nil
| h :: t =>
    (fix sub (l:list A) (last:A) (current:list A): list (list A) :=
        match l with
        | nil => [current]
        | h :: t => match A_dec h last with
                    | left _ => sub t h (h :: current)
                    | right _ => [current] ++ (sub t h [h])
                    end
        end) t h [h]
end.

End pack_A_dec.

Example test_pack:
pack nat Nat.eq_dec [1;1;1;2;2;2;3;4;4;4] = [[1;1;1];[2;2;2];[3];[4;4;4]].
Proof. reflexivity. Qed.

(* Fixpoint pack (l:list A): nlist A :=
match l with
| nil => n0
| h :: t => lcons (
    (fix sub (l:list A) (last:A) (current:nlist A): nlist A :=
        match l with
        | nil => n0
        | h :: t => match A_dec h last with
                    | left _ => sub t h (ucons h current)
                    | right _ => lcons current (sub t h n0)
                    end
        end) l h (ucons h n0)) n0
end. *)

(* 1.10 Run-length encoding of a list. *)
Section encode_A_dec.
Variable A:Type.
Hypothesis A_dec : forall x y:A, {x = y} + {x <> y}.

Print hd.
(* Avec option *)
Fixpoint encode (l:list A): list (nat * option A) :=
let lpack:=pack A A_dec l in (
    (fix sub (l:list (list A)): list (nat * option A) :=
        match l with
        | nil => nil
        | l1 :: l2 => (length l1, hd_error l1) :: (sub l2)
        end )) lpack.

(* Sans option *)
Fixpoint encode_bis (l:list A): list (nat * A) :=
let lpack:=pack A A_dec l in (
    (fix sub (l:list (list A)): list (nat * A) :=
        match l with
        | nil => nil
        | l1 :: l2 => match l1 with
                           | nil => (sub l2)
                           | h :: t => (length l1, h) :: (sub l2)
                           end
        end )) lpack.

End encode_A_dec.

Eval compute in pack nat Nat.eq_dec ([1;1;1;2;2;4;5;5;4]).

Example test_encode:
encode nat Nat.eq_dec ([1;1;1;2;2;4;5;5;4]) = [(3, Some 1); (2, Some 2); (1, Some 4); (2, Some 5); (1, Some 4)].
Proof. reflexivity. Qed.

Example test_encode_bis:
encode_bis nat Nat.eq_dec ([1;1;1;2;2;4;5;5;4]) = [(3, 1); (2, 2); (1, 4); (2, 5); (1, 4)].
Proof. reflexivity. Qed.

(* 1.11 Modified run-length encoding. *)
(* Implementer une liste heterogene *)
Section hlist.
Variable iT : Type.
Variable F : iT -> Type.

Inductive hlist : list iT -> Type :=
| Hnil : hlist nil
| Hcons : forall {T Ts}, F T -> hlist Ts -> hlist (T :: Ts).

Definition hlist_hd {T Ts} (h : hlist (T :: Ts)) : F T :=
match h with
  | Hcons x _ => x
  | Hnil => tt
end.

Definition hlist_tl {T Ts} (h : hlist (T :: Ts)) : hlist Ts :=
match h with
  | Hcons _ t => t
  | Hnil => tt
end.

Print hlist_tl.
End hlist.

Section encode2_A_dec.
Variable A:Type.
Hypothesis A_dec : forall x y:A, {x = y} + {x <> y}.

Inductive dlist (A:Type): Type :=
| Dn0 : dlist A
| Dcons : A -> dlist A -> dlist A
| DLcons : (nat*A) -> dlist A -> dlist A.

Implicit Arguments Dn0 [A].
Implicit Arguments Dcons [A].
Implicit Arguments DLcons [A].

Check Dn0.
Check (Dcons 1 (Dcons 2 Dn0)).
Check DLcons (2,1) (Dcons 1 (Dcons 2 Dn0)).

(* Notation "x :: l" := (Dcons x l)(at level 60, right associativity) : dlist_scope.
Notation "[ ]" := Dn0 : dlist_scope.
Notation "[ x ]" := (Dcons x n0) : dlist_scope.
Notation "[ x ; .. ; y ]" := (Dcons x .. (Dcons y Dn0) ..) : dlist_scope.
Notation "[ x , .. , y , z ]" := (DLcons x .. (DLcons y z) ..) : dlist_scope.
Local Open Scope dlist_scope. *)

Fixpoint encode_modified (l:list A): dlist A :=
match l with
| nil => Dn0
| h :: t =>
    (fix sub (l:list A) (last:A) (count:nat): dlist A :=
        match l with
        | nil => if count =? 1 then
                    Dcons last Dn0
                else
                    DLcons (count, last) Dn0
        | h :: t => match A_dec h last with
                    | left _ => sub t h (S count)
                    | right _ => if count =? 1 then
                                    Dcons last (sub t h 1)
                                 else
                                    DLcons (count, last) (sub t h 1)
                    end
        end) t h 1
end.

(* 1.12 Decode a run-length encoded list. *)
Fixpoint decode {A:Type} (l:list (nat * A)): list A :=
match l with
| nil => nil
| (l,r) :: t => (fix dup (x:A)(n:nat): list A :=
                match n with
                | O => nil
                | S n' => x :: dup x n'
                end) r l ++ decode t
end.

(* 1.13 Run-length encoding of a list (direct solution). *)
Fixpoint encode_direct (l:list A): list (nat * A) :=
match l with
| nil => nil
| h :: t =>
    (fix sub (l:list A) (last:A) (count:nat): list (nat * A) :=
        match l with
        | nil => (count, last) :: nil
        | h :: t => match A_dec h last with
                    | left _ => sub t h (S count)
                    | right _ => (count, last) :: (sub t h 1)
                    end
        end) t h 1
end.

Theorem decode_inv_encode: forall(l:list A), decode (encode_direct l) = l.
Proof.
    Admitted.

End encode2_A_dec.

Eval compute in encode nat Nat.eq_dec [1;1;1;2;2;4;5;5;4].

Example test_encode_modified:
encode_modified nat Nat.eq_dec ([1;1;1;2;3;3;4]) =
DLcons nat (3, 1) (Dcons nat 2 (DLcons nat (2, 3) (Dcons nat 4 (Dn0 nat)))).
Proof. reflexivity. Qed.

Example test_decode:
decode [(3,1); (2,2); (1,4); (2,5); (1,4)] =
[1; 1; 1; 2; 2; 4; 5; 5; 4].
Proof. reflexivity. Qed.

(* Theorem compress_cons2: forall (a:A)(l:list A), exists (l':list A), compress (a::l) = a::l'.
Proof.
    Admitted.

Theorem list_neq_cons: forall (a:A)(l:list A), a::l <> l.
Proof.
    intros. Admitted.

Theorem compress_cons_not: forall (x a:A)(l:list A),
    x::compress(a::l) <> compress(a::l).
Proof.
    intros. apply list_neq_cons.
Qed.

Theorem compress_cons_right: forall (x:A)(l:list A),
    compress (x::l) = compress l -> exists (a:A)(l':list A), l = a::l' /\ a = x.
Proof.
    intros x l.
    simpl.
    destruct l as [| a l2].
    - discriminate.
    - case (A_dec x a).
        * intros. exists a. exists l2. split. reflexivity. apply eq_sym in e. apply e.
        * intros e. simpl. destruct l2.
            ** discriminate.
            ** simpl. Admitted. *)

(* Fixpoint pack (l:list A):list A. implementer listlist... *)

(* 1.14 Duplicate the elements of a list. *)
Fixpoint dupli {A:Type}(l:list A): list A :=
match l with
| nil => nil
| h :: t => h :: h :: dupli t
end.

Eval compute in dupli ["a";"b";"b";"c";"d"]%string.

Local Open Scope string_scope.
Example test_dupli:
dupli ["a";"b";"b";"c";"d"] = ["a";"a";"b";"b";"b";"b";"c";"c";"d";"d"].
Proof. reflexivity. Qed.
Close Scope string_scope.

Theorem dupli_cons {A:Type}: forall (x:A)(l:list A), dupli (x::l) = [x;x] ++ dupli l.
Proof.
    intros x l.
    eauto.
Qed.

(*
Theorem dupli_compress {A:Type}: forall(l:list A), compress (dupli l) = compress l.
Proof.
    intro l. induction l.
    - reflexivity.
    - rewrite dupli_cons. rewrite compress_append. pose compress_cons as C.
        elim (C a l). intro H. rewrite <- IHl in H. rewrite H.
        elim (C a (dupli l)). trivial.
        intros. rewrite H0. rewrite IHl in H.
        pose (list_neq_cons a (compress (dupli l))) as X. unfold not in X. elim X.
Admitted. *)
  (*    destruct (C a (dupli l)). rewrite H. rewrite IHl. apply eq_sym. destruct (C a l).
      rewrite H0. reflexivity.
      simpl.
      rewrite H0. simpl.
      simpl. destruct l. discriminate.
        simpl.
      rewrite <- H0 in IHl. rewrite IHl in H. rewrite H0 in H.

      rewrite H. rewrite H0. rewrite IHl. reflexivity.
      rewrite H0. rewrite IHl. rewrite H.
      rewrite H. rewrite H0. rewrite IHl.
       split. rewrite (C a l).
Qed. *)

(* 1.15 Duplicate the elements of a list a given number of times. *)
Fixpoint dupli_elm {A:Type}(x:A)(n:nat) : list A :=
match n with
| O => nil
| S n' => x :: dupli_elm x n'
end.

Fixpoint dupli_nth {A:Type}(l:list A)(n:nat) : list A :=
match l with
| nil => nil
| h :: t => (dupli_elm h n) ++ (dupli_nth t n)
end.

Local Open Scope string_scope.
Example test_dupli_nth:
dupli_nth ["a";"b";"c"] 3 = ["a"; "a"; "a"; "b"; "b"; "b"; "c"; "c"; "c"].
Proof. reflexivity. Qed.
Close Scope string_scope.

(* 1.16 Drop every N'th element from a list. *)
Fixpoint scroll_drop_list {A:Type}(l:list A)(n:nat) : list A :=
match n, l with
| _, nil => nil
| O, h :: t => t
| S n', h :: t => h :: scroll_drop_list t n'
end.

(* En commencant à O *)
Fixpoint drop {A:Type}(l:list A)(n:nat) : list A :=
(fix sub (l:list A)(n cpt:nat) : list A :=
match l, cpt with
| nil, _ => nil
| h :: t, O => sub t n n
| h :: t, S n' => h :: sub t n n'
end) l n n.

(* En commencant à 1 *)
Fixpoint drop_bis {A:Type}(l:list A)(n:nat) : list A :=
let pn := pred n in
(fix sub (l:list A)(n cpt:nat) : list A :=
match l, cpt with
| nil, _ => nil
| h :: t, O => sub t n n
| h :: t, S n' => h :: sub t n n'
end) l pn pn.

Local Open Scope string_scope.
Example test_drop:
drop ["a";"b";"c";"a";"b";"c";"a";"b";"c"] 3 =
["a"; "b"; "c"; "b"; "c"; "a"; "c"].
Proof. reflexivity. Qed.

Example test_drop_bis:
drop_bis ["a";"b";"c";"a";"b";"c";"a";"b";"c"] 3 =
["a"; "b"; "a"; "b"; "a"; "b"].
Proof. reflexivity. Qed.
Close Scope string_scope.

(*
Fixpoint drop {A:Type}(l:list A)(n:nat) : list A :=
match l with
| nil => nil
| h :: t => drop (scroll_drop_list l n) n
end.

Fixpoint drop_bis {A:Type}(l:list A)(n:nat) : list A :=
(fix sub (l:list A)(n cpt:nat) : list A :=
match

) l n n

*)
(* 1.17 Split a list into two parts; the length of the first part is given. *)
Locate split.

Fixpoint split {A : Type} (l : list A) (n : nat) : (list A) * (list A) :=
match l, n with
    | [], _ => ([], [])
    | h::t, S n' => let (l1, l2) := split t n' in (h::l1, l2)
    | _, O => (nil, l)
end.

Example test_split:
split [1;2;3;4;5;6;7;8;9;10] 4 = ([1;2;3;4],[5;6;7;8;9;10]).
Proof. reflexivity. Qed.

(* 1.18 Extract a slice from a list. *)
(* en partant de 0 *)
Fixpoint slice {A:Type}(l:list A)(m n:nat) : list A :=
match l, m, n with
| nil, _, _ => nil
| h::t, _, O => h :: nil
| h::t, O, S n' => h :: slice t m n'
| h::t, S m', S n' => slice t m' n'
end.

(* en partant de 1 *)
Fixpoint slice_bis {A:Type}(l:list A)(m n:nat) : list A :=
match l, m, n with
| nil, _, _ => nil
| _, _, O => nil
| h::t, O, S n' => h :: slice_bis t m n'
| h::t, S O, S n' => h :: slice_bis t O n'
| h::t, S m', S n' => slice_bis t m' n'
end.

Local Open Scope string_scope.
Example test_slice:
slice ["a";"b";"c";"d"; "e"; "f"] 3 5 = ["d"; "e"; "f"].
Proof. reflexivity. Qed.

Example test_slice_bis:
slice_bis ["a";"b";"c";"d"; "e"; "f"] 3 5 = ["c"; "d"; "e"].
Proof. reflexivity. Qed.
Close Scope string_scope.

(* 1.19 Rotate a list N places to the left. *)
Fixpoint rotate {A:Type}(l:list A)(n:nat) : list A :=
let lth := List.length l in
let modn := Nat.modulo n lth in
let (l1, l2) := split l modn in
l2 ++ l1.

(* sans split *)
Fixpoint rotate_bis {A:Type}(l:list A)(n:nat) : list A :=
let lth := List.length l in
let modn := Nat.modulo n lth in
(fix sub (l s:list A)(n:nat) : list A :=
match l, n with
| nil, _ => nil
| _, O => l ++ s
| h::t, S n' => sub t (s ++ [h]) n'
end) l nil modn.

Local Open Scope string_scope.
Example test_rotate:
rotate ["a";"b";"c";"d"; "e"; "f"] 4 = ["e"; "f"; "a"; "b"; "c"; "d"].
Proof. reflexivity. Qed.

Example test_rotate_bis:
rotate_bis ["a";"b";"c";"d"; "e"; "f"] 4 = ["e"; "f"; "a"; "b"; "c"; "d"].
Proof. reflexivity. Qed.
Close Scope string_scope.

(* 1.20 Remove the K'th element from a list. *)
(* en renvoyant un couple et en partant de 1 *)
Fixpoint remove_kth {A:Type}(l:list A)(n:nat) : (option A) * (list A) :=
match l, n with
| nil, _ => (None, nil)
| h::t, O => (Some h, t)
| h::t, S O => (Some h, t)
| h::t, S n' => let (elm, ls) := remove_kth t n' in (elm, h :: ls)
end.

(* en renvoyant seulement la liste et en partant de 1 *)
Fixpoint remove_kth_bis {A:Type}(l:list A)(n:nat) : list A :=
match l, n with
| nil, _ => nil
| h::t, O => t
| h::t, S O => t
| h::t, S n' => h :: remove_kth_bis t n'
end.

Local Open Scope string_scope.
Example test_remove_kth:
remove_kth ["a";"b";"c";"d"; "e"; "f"] 2 = (Some "b", ["a"; "c"; "d"; "e"; "f"]).
Proof. reflexivity. Qed.

Example test_remove_kth_bis:
remove_kth_bis ["a";"b";"c";"d"; "e"; "f"] 2 = ["a"; "c"; "d"; "e"; "f"].
Proof. reflexivity. Qed.
Close Scope string_scope.

(* 1.21 Insert an element at a given position into a list. *)
(* en partant de 1 *)
Fixpoint insert_at {A:Type}(e:A)(l:list A)(n:nat) : list A :=
match l, n with
| nil, _ | _, O | _, S O => e :: l
| h::t, S n' => h :: insert_at e t n'
end.

Local Open Scope string_scope.
Example test_insert_at:
insert_at "c" ["a";"b";"d"] 2 = ["a"; "c"; "b"; "d"].
Proof. reflexivity. Qed.
Close Scope string_scope.

(* 1.22 Create a list containing all integers within a given range. *)
Fixpoint range (a b:nat) : list nat :=
let diff := b - a in
    (fix sub (b diff:nat) : list nat :=
    match diff with
    | O => [b]
    | S d' => (b-diff) :: sub b d'
    end) b diff.

(* En utilisant le_lt_dec := {n <= m} + {m < n} *)
Fixpoint range_bis (a b:nat) : list nat :=
if Arith.Compare_dec.le_lt_dec a b then
    match b with
    | O => [O]
    | S b' => (range a b') ++ [b]
    end
else nil.

Example test_range:
range 5 8 = [5; 6; 7; 8].
Proof. reflexivity. Qed.

Example test_range_bis:
range_bis 5 8 = [5; 6; 7; 8].
Proof. reflexivity. Qed.

(* 1.23 Extract a given number of randomly selected elements from a list. *)
(* utiliser seed pour générer des nombres aléatoires ? *)
Require Import Streams.
CoFixpoint rand (seed n1 n2 : nat) : Stream nat :=
    let seed' := Nat.modulo seed n2 in Cons seed' (rand (seed' * n1) n1 n2).

(* 1.24 Lotto: Draw N different random numbers from the set 1..M. *)

(* 1.25 Generate a random permutation of the elements of a list. *)

(* 1.26 Generate the combinations of K distinct objects chosen from the N elements of a list *)
Fixpoint combination {A:Type} (n:nat) (l:list A) : list (list A) :=
(fix sub (n:nat) (l rem:list A): list (list A) :=
match n, l with
| O, _ => [rem]
| _, nil => [nil]
| S n', h::t => if n <=? length t  then
                    (sub n' t (h::rem)) ++ (sub n t rem)
                else
                    (sub n' t (h::rem))
end) n l nil.

Example test_combination:
combination 2 [1;2;3;4] = [[2; 1]; [3; 1]; [4; 1]; [3; 2]; [4; 2]; [4; 3]].
Proof. reflexivity. Qed.

Example test_combination2:
combination 3 [1;2;3;4] = [[3; 2; 1]; [4; 2; 1]; [4; 3; 1]; [4; 3; 2]].
Proof. reflexivity. Qed.

Theorem card_combination {A:Type}: forall (l:list A)(n:nat), let cardl := length l in
    (length (combination n l) = fact cardl / (fact n * fact (cardl - n))).
Proof.
    Admitted.
Print prod.
(* 1.27 Group the elements of a set into disjoint subsets. *)
(* renvoie egalement la liste restant pour chaque combinaison *)
Fixpoint comb_bis {A:Type} (n:nat) (l:list A) : list (list A * list A) :=
(fix sub (n:nat) (l rem remL:list A): list (list A * list A) :=
match n, l with
| O, _ => [(rem, remL++l)]
| _, nil => [(nil, remL)]
| S n', h::t => if n <=? length t  then
                    (sub n' t (h::rem) remL) ++ (sub n t rem (h::remL))
                else
                    (sub n' t (h::rem) remL)
end) n l nil nil.

Eval compute in comb_bis 3 [1;2;3;4;5].

(* ####### *)

(* Fixpoint group3 {A:Type} (n m p:nat) (l:list A) : list (list A * list A * list A) :=
let comb1 := comb_bis n l in (
    match comb1 with
    | nil => nil
    | (cn, reml1)::t => let comb2 := comb_bis m reml1 in (
                        match comb2 with
                        | nil => nil
                        | (cm, reml2) => let comb3 := comb_bis p reml2 in (
                                            match comb2 with
                                            | nil => nil
                                            | (cp, _) => (cn, cm, cp))
    )
 )
(fix sub (n m p:nat) (l remL remM remP:list A): list (list A * list A * list A) :=
match n, l with
| O, _ =>  match
| _, nil => [(remL, remM, remP)]
| S n', h::t => if (n+m+p) <=? length t  then
                    (sub n' t (h::remL)) ++ (sub n t remL)
                else
                    (sub n' t (h::remL))
end) n m p l nil nil nil. *)

(* ############ *)
(* 1.28 Sorting a list of lists according to length of sublists  *)
Print Arith.Compare_dec.le_lt_dec.
(* insertion d'une liste de taille lenL dans une liste de listes de taille variable *)
Fixpoint sub_lsort {A:Type} (l:list A)(m:list (list A))(lenL:nat) : list (list A) :=
match m with
| nil => [l]
| l1::l2 => if Arith.Compare_dec.le_lt_dec lenL (length l1) then
                [l] ++ m
            else [l1] ++ (sub_lsort l l2 lenL)
end.

(* insertion de [1;2;2] dans [[1];[1;2;3;4]] *)
Example test_sub_lsort:
sub_lsort [1;2;2] [[1];[1;2;3;4]] 3 = [[1]; [1; 2; 2]; [1; 2; 3; 4]].
Proof. reflexivity. Qed.

Fixpoint lsort {A:Type}(l:list (list A)) : list (list A) :=
match l with
| nil => nil
| h::t => sub_lsort h (lsort t) (length h)
end.

Fixpoint lsort_bis {A:Type}(l:list (list A)) : list (list A) :=
(fix sub (m res:list (list A)) : list (list A) :=
match m with
| nil => res
| h::t => sub t (sub_lsort h res (length h))
end) l nil.

Eval compute in lsort [[1];[1;2;3;4];[1;2];[1;4;5]].
Eval compute in lsort_bis [[1];[1;2;3;4];[1;2];[1;4;5]].

Example test_lsort:
lsort [[1];[1;2;3;4];[1;2];[1;4;5]] = [[1]; [1; 2]; [1; 4; 5]; [1; 2; 3; 4]].
Proof. reflexivity. Qed.

Example test_lsort_bis:
lsort_bis [[1];[1;2;3;4];[1;2];[1;4;5]] = [[1]; [1; 2]; [1; 4; 5]; [1; 2; 3; 4]].
Proof. reflexivity. Qed.

End list_prob.


(*|
########################
Rewrite under ``exists``
########################

:Link: https://stackoverflow.com/q/47635697
|*)

(*|
Question
********

Say I have the following relation:
|*)

Inductive my_relation: nat -> Prop :=
  constr n : my_relation n.

(*| and I want to prove the following: |*)

Lemma example:
  (forall n, my_relation n -> my_relation (S n)) ->
  (exists n, my_relation n) -> exists n, my_relation (S n).
Proof.
  intros.

(*| After introducing, I have the following environment: |*)

  Show. (* .unfold .messages *)

(*|
My question is: is there a possibility to rewrite ``H`` under the
``exists`` quantifier? If not, is there a strategy to solve this kind
of problem (this particular one is not really relevant, but problems
where you have to prove an ``exists`` using another ``exists``, and
where, informally, you can "deduce" a way to rewrite the ``exists`` in
the hypothesis into the ``exists`` in the goal)?

For instance, if I try ``rewrite H in H0.`` I have, an error
|*)

  Fail rewrite H in H0. (* .unfold .messages *)

(*|
Answer (eponier)
****************

The standard way to manipulate an existential quantification in an
hypothesis is to get a witness of the property using ``inversion`` or,
better and simpler, ``destruct``.

You can give a name to the variable using one of the following
syntaxes:
|*)

  destruct H0 as (n, H0). Undo 1. (* .none *)

  destruct H0 as [n H0]. Undo 1. (* .none *)

  destruct H0 as (n & H0).

(*|
Note that you can also destruct an hypothesis using `intro-patterns
<https://coq.inria.fr/refman/tactics.html#sec364>`__.
|*)

  Restart. (* .none *)
  intros H (n & H0).

(*| And you can even directly apply ``H`` in ``H0``. |*)

  Restart. (* .none *)
  intros H (n & H0%H). exists n. assumption.

(*|
`Software Foundations
<https://softwarefoundations.cis.upenn.edu/lf-current/Logic.html#lab175>`__
explains this in a clear way.
|*)

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

I found a way, I post it here for any similar questions in the future.

It is possible to inverse the ``exists`` hypothesis, in order to
"instantiate" the quantified variable, for instance, here, the proof
can be finished by:
|*)

  Restart. (* .none *) intros. (* .none *)
  inversion H0. apply H in H1.
  exists x. apply H1.

(*| After ``inversion H0``, we have in the environment: |*)

  Restart. (* .none *) intros. (* .none *) inversion H0. (* .none *)
  Show. (* .unfold .messages *)

(*| and we can now work with ``x``. |*)


Require Import List.
Require Import ZArith.
Require Import Classical.
Require Import FinFun.

From mathcomp
Require Import ssreflect.

Import ListNotations.

Section Utility.
  Open Scope Z_scope.
  Open Scope list_scope.

  Definition succ (i : Z) : Z :=
    (i + 1) mod 5.

  Definition pred (i : Z) : Z :=
    (i - 1) mod 5.

  Definition Mat2 := list (list Z).

  Definition mat_mul (m : Mat2) (p : Z * Z) : (Z * Z) :=
    let row0 := nth 0 m [] in
    let row1 := nth 1 m [] in
    let (a, b) := (nth 0 row0 0, nth 1 row0 0) in
    let (c, d) := (nth 0 row1 0, nth 1 row1 0) in
    (a * (fst p) + b * (snd p), (c * (fst p) + d * (snd p))).

  Notation "m * p" := (mat_mul m p).

  Definition mat2_pi_over_2 : Mat2 := [ [ 0; 1 ]; [ -1; 0 ] ].

  Definition mat2_pi_over_2' : Mat2 := [ [ 0; -1 ]; [ 1; 0 ] ].

  Lemma lt_imply_false (x : Z) : (x < 0 -> False) -> 0 <= x.
  Proof. omega. Qed.

  Lemma gt_imply_false (x : Z) : (0 < x -> False) -> x <= 0.
  Proof. omega. Qed.

  Lemma abs_eq_gt (x : Z) : 0 < x -> Z.abs x = x.
  Proof.
    have x_gt_imply_ge: 0 < x -> 0 <= x. omega.
    move /x_gt_imply_ge.
    apply: Z.abs_eq.
  Qed.

  Lemma abs_eq_lt (x : Z) : x < 0 -> Z.abs x = -x.
  Proof.
    have x_lt_imply_le: x < 0 -> x <= 0. omega.
    move /x_lt_imply_le.
    apply Z.abs_neq.
  Qed.

  Lemma pair_eq_and (a b c d : Z) : (a, b) = (c, d) <-> a = c /\ b = d.
  Proof.
    split.
    -move=> s0.
      inversion s0.
      split.
      +by [].
      +by [].
    -move=> s0.
      case: s0 => s0 s1.
      by rewrite s0 s1.
  Qed.

  Lemma eqp_neq (a b c d : Z) :
    (a, b) <> (c, d) <-> a =? c = false \/ b =? d = false.
  Proof.
    split.
    -move=> s0.
      unfold not in s0.
      move /pair_eq_and in s0.
      apply not_and_or in s0.
      case: s0 => s0.
      +left. by apply Z.eqb_neq.
      +right. by apply Z.eqb_neq.
    -move=> s0.
      move=> s1.
      inversion s1.
      case: s0 => s0.
      +by apply Z.eqb_neq in s0.
      +by apply Z.eqb_neq in s0.
  Qed.

  Close Scope list_scope.
  Close Scope Z_scope.

End Utility.


Require Export D.

(** **** Problem #19 : 2 stars (beq_nat_true)  *)
Theorem beq_nat_true : forall n m,
    beq_nat n m = true -> n = m.
Proof.
  intros n. induction n. intros. destruct m. reflexivity.
  inversion H.
  intros.
  destruct m. inversion H.
  Lemma nm_SnSm_eq : forall (n m:nat),
    n=m -> S n=S m.
  Proof. intros.  rewrite ->H. reflexivity. Qed.
  apply nm_SnSm_eq. apply IHn. inversion H. reflexivity.
Qed.


From Coq Require Import Arith ZArith micromega.Lia.

Lemma strong_induction P : (forall n, (forall m, (m < n) -> P m) -> P n) -> forall k, P k.
Proof.
  intros; generalize (Nat.le_refl k); generalize k at -2.
  induction k; intros. apply X. lia. destruct k0. apply X. lia. apply X. intros. apply IHk. lia. Qed.

Lemma induction2 P : P 0%nat -> P 1%nat -> (forall n, P n -> P (S n) -> P (S (S n))) -> forall k, P k.
Proof.
  intros; induction k using strong_induction; [destruct k as [|k]; [assumption|destruct k]; [assumption|]].
  apply X1; apply X2; lia. Qed.

Lemma induction_at n (P : nat -> Prop) : P n -> (forall m, (n <= m)%nat -> (P m -> P (S m))) -> (forall m, (n <= m)%nat -> P m).
Proof.
  intros; induction m.
  - apply le_n_0_eq in H1; subst; assumption.
  - destruct (Nat.eq_dec (S m) n).
    + subst; assumption.
    + apply H0; [|apply IHm]; lia. Qed.

Lemma rev_1_ind m (P : nat -> Prop) : P m -> (forall k, (0 < k <= m)%nat -> P k -> P (Nat.pred k)) -> forall k, (k <= m)%nat -> P k.
Proof.
  intros.
  assert { l : nat | (m - k)%nat = l }. eexists. reflexivity. destruct H2. generalize dependent k.
  induction x; intros.
  replace k with m by lia. assumption.
  destruct (S k =? m)%nat eqn:E2. apply Nat.eqb_eq in E2. replace k with (Nat.pred m) by lia. apply H0. lia. assumption.
  apply Nat.eqb_neq in E2.
  replace k with (Nat.pred (S k)) by lia. apply H0. lia.
  apply IHx. lia. lia. Qed.

Lemma rev_2_ind P m : P (S m) -> P m -> (forall k, (0 < k <= S m)%nat -> P k -> P (Nat.pred k) -> P (Nat.pred (Nat.pred k))) -> (forall k, (k <= (S m))%nat -> P k).
Proof.
  intros.

  assert { l : nat | ((S m) - k)%nat = l }. eexists. reflexivity. destruct H0. generalize dependent k.
  induction x using induction2; intros.
  - assert (k = S m) by lia. congruence.
  - assert (k = m) by lia. congruence.
  - destruct (Nat.eq_dec (S (S k)) (S m)).
    replace k with (Nat.pred (Nat.pred (S (S k)))) by lia. rewrite e0. apply X1. lia.
    assumption. assumption.

    replace k with (Nat.pred (Nat.pred (S (S k)))) by lia.
    apply X1. lia. apply IHx. lia. lia. apply IHx0. lia. lia. Qed.

Local Open Scope Z.

Lemma strong_natlike_ind (P : Z -> Prop) : (forall x, (forall y, 0 <= y < x -> P y) -> P x) -> forall x : Z, 0 <= x -> P x.
Proof.
  intros Hind x. remember (Z.abs_nat x). revert x Heqn Hind.
  induction n using strong_induction; intros.
  apply Hind. intros; apply H with (m := Z.abs_nat y); try assumption; lia. Qed.

Lemma rev_1_natlike_ind (P : Z -> Prop) x : P x -> (forall y, (0 < y <= x) -> P y -> P (Z.pred y)) -> (forall y, (0 <= y) -> (y <= x) -> P y).
Proof.
  intros Px Hind y. remember (Z.abs_nat (x - y)). revert y x Heqn Hind Px.
  induction n; intros.
  - assert (x = y) by lia; subst; assumption.
  - destruct (Z.eq_dec x y); [subst; assumption|].
    replace y with (Z.pred (Z.succ y)) by lia.
    apply Hind; [lia|]; apply IHn with (x:=x); try assumption; lia. Qed.


Require Import Program Omega Ring ArithRing List.

Program Fixpoint sum_to (n: nat): {r: nat | 2 * r = n * (n+1) } :=
  match n with
  | 0 => 0
  | S n' => n + sum_to n'
  end.

Check sum_to_obligation_1.
Obligation 2 of sum_to.
  simpl.
  assert (S (n' + x + S (n' + x + 0)) = n' + (x + (x + 0)) + n' + 2) by omega.
  rewrite H. clear H.
  rewrite e. clear e.
  ring.
Defined sum_to.

Locate "|".
Check sig.
Print sig.
(* Look here https://coq.inria.fr/library/Coq.Init.Specif.html *)
Check exist.
Check existT.

Program Fixpoint my_reverse (A: Type) (l: list A): {l': list A | length l = length l'} :=
  match l with
  | nil => nil
  | cons head tail => (my_reverse A tail) ++ [head]
  end.
Obligation 2 of my_reverse.
  Search (length (_ ++ _) = length _ + length _).
  rewrite app_length.
  simpl.
  omega.
Defined my_reverse.


(* Code for Coq'Art, Chapter 3: Propositions and Proofs. *)

Section PropositionsAndProofs.

Variable P Q R S T : Prop.

(* Examples *)
Section Examples.

Section MinimalPropositionalLogic.

Theorem imp_trans_theorem : (P -> Q) -> (Q -> R) -> P -> R.
(* Detailed proof *)
Proof.
  intros h1 h2 h3.
  apply h2.
  apply h1.
  apply h3. (* assumption. *)
Qed.
Print imp_trans_theorem.

Theorem imp_trans' : (P -> Q) -> (Q -> R) -> P -> R.
(* Auto Proof. *)
Proof.
  auto.
Qed.
Print imp_trans'.

Hypothesis hypo1 : P -> Q -> R.

Lemma l1 : P -> Q -> R.
Proof.
  apply hypo1.
Qed.
Print l1.

Theorem delta : (P -> P -> Q) -> P -> Q.
Proof.
  (* detailed proof:
    intros h1 h2.
    apply h1.
    apply h2.
    apply h2. *)
  exact (fun (h1 : P -> P -> Q)(h2 : P) => h1 h2 h2).
Qed.
Print delta.

(* Theorem delta : (P -> P -> Q) -> P -> Q.
Proof (fun (h1 : P -> P -> Q)(h2 : P) => h1 h2 h2).
Print delta. *)

Theorem apply_example : (Q -> R -> T) -> (P -> Q) -> P -> R -> T.
Proof.
  intros h1 h2 h3.
  apply h1.
  apply h2.
  apply h3.
Qed.
Print apply_example.

Theorem imp_dist : (P -> Q -> R) -> (P -> Q) -> (P -> R).
Proof.
  intros h1 h2 h3.
  apply h1.
  apply h3.
  apply h2.
  apply h3.
Qed.
Print imp_dist.

Theorem k : P -> Q -> P.
Proof.
  intros h1 h2.
  apply h1.
Qed.
Print k.

Section ProofOfTripleImpl.

Hypothesis hypo2 : P.
Hypothesis hypo3 : ((P -> Q) -> Q) -> Q.

Lemma l2 : (P -> Q) -> Q.
Proof (fun (h1 : P -> Q) => h1 hypo2).

Theorem triple_impl : Q.
Proof (hypo3 l2).

End ProofOfTripleImpl.

Print triple_impl.
Print l2.

Theorem then_example : P -> Q -> (P -> Q -> R) -> R.
Proof.
  intros h1 h2 h3.
  apply h3; assumption.
Qed.

Theorem triple_impl_one_shot : (((P -> Q) -> Q) -> Q) -> P -> Q.
Proof.
  intros h1 h2.
  apply h1; intro h3; apply h3; apply h2.
Qed.

Theorem compose_example : (P -> Q -> R) -> (P -> Q) -> (P -> R).
Proof.
  intros h1 h2 h3.
  apply h1; [assumption | apply h2; assumption].
Qed.

Theorem orelse_example : (P -> Q) -> R -> ((P -> Q) -> R -> (T -> Q) -> T) -> T.
Proof.
  intros h1 h2 h3.
  apply h3; (assumption || intros h4).
Abort. (* can't be proved. *)

Lemma idtac_example : (P -> Q) -> (P -> R) -> (P -> Q -> R -> T) -> P -> T.
Proof.
  intros h1 h2 h3 h4.
  apply h3; [idtac | apply h1 | apply h2]; assumption.
Qed.

Lemma then_fail_example : (P -> Q) -> (P -> Q).
Proof.
  intros h1; apply h1; fail.
Qed.

Lemma try_example : (P -> Q -> R -> T) -> (P -> Q) -> (P -> R -> T).
Proof.
  intros h1 h2 h3 h4.
  apply h1; try assumption.
  apply h2; assumption.
Qed.

Section CutTacticExample.

(* cut tactic: for goal Q, impose these two subgoals:
  + P
  + P -> Q
  base on MP(Modus Ponens) rules, the goal can be proved by these two subgoals. *)

Hypothesis
  (h1 : P -> Q)
  (h2 : Q -> R)
  (h3 : (P -> R) -> T -> Q)
  (h4 : (P -> R) -> T).

Theorem cut_example : Q.
Proof.
  cut (P -> R).
  intros h5.
  apply h3;
    [ apply h5
    | apply h4; apply h5
    ].
  intros h6; apply h2; apply h1; apply h6.
Qed.
Print cut_example.

End CutTacticExample.

End MinimalPropositionalLogic.

End Examples.

(* Exercises. *)
Section Exercises.

(* Exercise 3.1 *)
Check ((P -> Q) -> (Q -> R) -> P -> R).

(* Exercise 3.2 and 3.3 *)
Lemma id_P : P -> P.
Proof.
  intros h1.
  apply h1.
Qed.
Print id_P.

Lemma id_PP : (P -> P) -> (P -> P).
Proof.
  intro h1.
  apply h1.
Qed.

Lemma imp_trans : (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros h1 h2 h3.
  apply h2.
  apply h1.
  apply h3.
Qed.

Lemma imp_perm : (P -> Q -> R) -> (Q -> P -> R).
Proof.
  intros h1.
  intros h2 h3.
  apply h1.
  apply h3.
  apply h2.
Qed.

Lemma ignore_Q : (P -> R) -> P -> Q -> R.
Proof.
  intros h1 h2 h3.
  apply h1.
  apply h2.
Qed.

Lemma delta_imp : (P -> P -> Q) -> P -> Q.
Proof.
  intros h1 h2.
  apply h1.
  apply h2.
  apply h2.
Qed.

Lemma delta_impR : (P -> Q) -> (P -> P -> Q).
Proof.
  intros h1 h2.
  apply h1.
Qed.

Lemma diamond : (P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T.
Proof.
  intros h1 h2 h3 h4.
  apply h3.
  apply h1.
  apply h4.
  apply h2.
  apply h4.
Qed.
Print diamond.

Lemma weak_peirce : ((((P -> Q) -> P) -> P) -> Q) -> Q.
(* Perice formula: ((P -> Q) -> P) -> P. can't be proved by Coq (Calculus of
  Constructions), it uses normalization properties in typed lambda-calculi. *)
Proof.
  intros h1.
  apply h1.
  intros h2.
  apply h2.
  intros h3.
  apply h1.
  intros h4.
  apply h3.
Qed.
Print weak_peirce.

(* Exercise 3.4 *)

(** Typing rules used in minimum propositional logic is: Prod, Lam, App* and Var.
  for a formula q:
  + if q is a variable, it can be solved by assumption tactic.
  + if q is an abstraction, it can be simplified by intro tactic.
  + if q is an application, it can be solved by apply tactic. **)

(* Exercise 3.5 *)

Section Example_3_5.

Hypothesis
  (h1 : P -> Q)
  (h2 : Q -> R)
  (h3 : (P -> R) -> T -> Q)
  (h4 : (P -> R) -> T).

Lemma cut_example' : Q.
Proof.
  apply h3.
  intros h5.
  apply h2; apply h1; apply h5.
  apply h4.
  intros h6.
  apply h2; apply h1; apply h6.
Qed.
End Example_3_5.
Print cut_example.
Print cut_example'.

(* Exercise 3.6 *)

Section AutoExample.

(** Pattern: according to law of transfer, it's easy to construct a theorem/lemma
  need to be proved at least arbitrary n steps. **)

Variables P0 P1 P2 P3 P4 P5 : Prop.
Lemma auto_example :
  (P0 -> P1) ->
  (P1 -> P2) ->
  (P2 -> P3) ->
  (P3 -> P4) ->
  (P4 -> P5) ->
  P0 -> P5.
Proof.
  auto 6.
Qed.
Print auto_example.

End AutoExample.

End Exercises.

End PropositionsAndProofs.

(* Abstraction (with universal quatification). *)
Print imp_dist.


Theorem rewrite_example_1: forall (a b c d : nat),
  a = b + c -> b = c + d -> d = 1 -> c = 2 -> a = 5.
Proof.
  intros a b c d H0 H1 H2 H3.
  rewrite H0.
  rewrite H1.
  rewrite H2.
  rewrite H3.
  reflexivity.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (lf1 : natural) (y : natural) (x : natural)
  : natural := plus y (plus x Zero).


Require Export A_3_5.

Module A4_1.

(* 4.1 连续性的概念 *)
(* 定义1：函数在一点的连续性 *)
Definition Continuous (f : Fun) (x0 : R) :=
  x0 ∈ dom[f] /\ limit f x0 f[x0].

(* 左连续 *)
Definition ContinuousLeft (f : Fun) (x0 : R) :=
  x0 ∈ dom[f] /\ limit_neg f x0 f[x0].

(* 右连续 *)
Definition ContinuousRight (f : Fun) (x0 : R) :=
  x0 ∈ dom[f] /\ limit_pos f x0 f[x0].

(* 定义：函数在开区间上的连续 *)
Definition ContinuousOpen (f : Fun) (a b : R) :=
  ∀ x, a < x < b -> Continuous f x.

(* 定义：函数在闭区间上的连续 *)
Definition ContinuousClose (f : Fun) (a b : R) :=
  ContinuousOpen f a b /\ ContinuousRight f a
  /\ ContinuousLeft f b.

End A4_1.

Export A4_1.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (z : natural) (y : natural) (lf2 : natural) : natural :=
  plus lf2 (mult z (Succ y)).


(*
        #####################################################
        ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
        #####################################################
*)
Require Turing.Util.
Require Import Coq.Lists.List.
Import ListNotations.

(* ---------------------------------------------------------------------------*)

(**

Study the definition of [Turing.Util.pow] and [Turing.Util.pow1]
and then show that [Turing.Util.pow1] can be formulated in terms of
[Turing.Util.pow].
Material: https://gitlab.com/umb-svl/turing/blob/main/src/Util.v

 *)
Theorem ex1:
  forall (A:Type) (x:A) n, Util.pow [x] n = Util.pow1 x n.
Proof.
  intros.
  induction n as [|n' IH].
  - simpl. reflexivity.
  - simpl.
    rewrite IH.
    reflexivity.
Qed.

(**

Study recursive definition of [List.In] and the inductive definition of
[List.Exists]. Then show that [List.In] can be formulated in terms
of [List.Exists].

Material: https://coq.inria.fr/library/Coq.Lists.List.html

 *)
Theorem ex2:
  forall (A:Type) (x:A) l, List.Exists (eq x) l <-> List.In x l.
Proof.
  intros.
  split.

  * intros.
    induction l.
    - simpl.
      inversion H.
    - inversion H.
      simpl.
      left.
      subst.
      reflexivity.
      simpl.
      right.
      apply IHl in H1.
      assumption.
  * intros H.
    induction l as [|y l' IH].
    - inversion H.
    - simpl.
      destruct H as [H|H].
      subst.
      left.
      reflexivity.
      right.
      apply IH.
      assumption.
Qed.

(**

Create an inductive relation that holds if, and only if, element 'x'
appears before element 'y' in the given list.
We can define `succ` inductively as follows:

                                (x, y) succ l
-----------------------R1     ------------------R2
(x, y) succ x :: y :: l       (x, y) succ z :: l

Rule R1 says that x succeeds y in the list that starts with [x, y].

Rule R2 says that if x succeeds y in list l then x succeeds y in a list
the list that results from adding z to list l.

 *)

Inductive succ {X : Type} (x : X) (y : X) : list X -> Prop :=
  | r1 : forall (l: list X), succ x y (x :: y :: l)
  | r2 : forall (z: X) (l: list X), succ x y l -> succ x y (z :: l).

Theorem succ1:
    (* Only one of the following propositions is provable.
       Replace 'False' by the only provable proposition and then prove it:
     1) succ 2 3 [1;2;3;4]
     2) ~ succ 2 3 [1;2;3;4]
     *)
    succ 2 3 [1;2;3;4].
Proof.
  apply r2.
  apply r1.
Qed.

Theorem succ2:
    (* Only one of the following propositions is provable.
       Replace 'False' by the only provable proposition and then prove it:
     1) succ 2 3 []
     2) ~ succ 2 3 []
     *)
    ~ succ 2 3 [].
Proof.
  intros h1.
  inversion h1.
Qed.

Theorem succ3:
    (* Only one of the following propositions is provable.
       Replace 'False' by the only provable proposition and then prove it:
     1) succ 2 4 [1;2;3;4]
     2) ~ succ 2 4 [1;2;3;4]
     *)
    ~ succ 2 4 [1;2;3;4].
Proof.
  intros h1.
  inversion h1.
  inversion H0.
  inversion H3.
  inversion H6.
  inversion H9.
Qed.

Theorem succ4:
  forall (X:Type) (x y : Type), succ x y [x;y].
Proof.
  intros.
  apply r1.
Qed.

Theorem ex3:
  forall (X:Type) (l1 l2:list X) (x y:X), succ x y (l1 ++ (x :: y :: l2)).
Proof.
  intros.
  induction l1, l2.
  - simpl.
    apply r1.
  - simpl.
    apply r1.
  - simpl.
    inversion IHl1.
    apply r2.
    apply r1.
    apply r2.
    apply r2.
    assumption.
  - simpl.
    inversion IHl1.
    apply r2.
    apply r1.
    apply r2.
    apply r2.
    assumption.
Qed.

Theorem ex4:
  forall (X:Type) (x y:X) (l:list X), succ x y l -> exists l1 l2, l1 ++ (x:: y:: l2) = l.
Proof.

Admitted.


Require Import Rbase Reals ZArith QArith micromega.Lia micromega.Lqa micromega.Lra Qreals.

From BY Require Import Rlemmas IZR.

Local Open Scope Z.
Local Open Scope R.
Local Coercion IZR : Z >-> R.

Definition floor a := ((up a) - 1)%Z.

Ltac lira :=
  lra +
  (autorewrite with push_izr; try apply lt_IZR; lra) +
  (autorewrite with push_izr; try apply le_IZR; lra) +
  (autorewrite with pull_izr;
       match goal with
       | [ |- IZR _ < IZR _ ] => try apply IZR_lt
       | [ |- IZR _ <= IZR _ ] => try apply IZR_le
       end; lia).

Lemma floor_upper_bound a b : a <= b -> IZR (floor a) <= b.
Proof. unfold floor; pose proof archimed a; rewrite minus_IZR; lra. Qed.

Lemma floor_lower_bound a b : b <= a - 1 -> b < IZR (floor a).
Proof. unfold floor; pose proof archimed a; rewrite minus_IZR; lra. Qed.

Lemma floor_spec a : IZR (floor a) <= a /\ (a - 1 < IZR (floor a)).
Proof. split; [apply floor_upper_bound| apply floor_lower_bound]; reflexivity. Qed.

Lemma up0 : up 0 = 1%Z.
Proof. symmetry; apply tech_up; lra. Qed.

Lemma floor0 : floor 0 = 0%Z.
Proof. unfold floor; rewrite up0; lia. Qed.

Lemma floor_eq (r : R) (z : Z) : z <= r -> r < z + 1 -> z = floor r.
Proof. intros. unfold floor. epose proof tech_up r (z + 1) _ _; lia.
       Unshelve. rewrite plus_IZR; lra. rewrite plus_IZR; lra. Qed.

Lemma floor_inc a b : a <= b -> (floor a <= floor b)%Z.
Proof.
  intros; pose proof floor_spec a as [? ?]; pose proof floor_spec b as [? ?].
  apply le_IZR; destruct (Rlt_dec b (floor a + 1)).
  - assert (eq : floor a = floor b) by (apply floor_eq; lra); rewrite eq; lra.
  - lra. Qed.

Lemma floor_inv_inc a b : floor a <= floor b -> a < b + 1.
Proof. pose proof floor_spec a as [? ?]; pose proof floor_spec b as [? ?]; lra. Qed.

Lemma floor_pos a : 0 <= a -> (0 <= floor a)%Z.
Proof. replace 0%Z with (floor 0) at 2 by apply floor0; apply floor_inc. Qed.

Lemma floor_div a b : floor (IZR a / IZR b)%R = (a / b)%Z.
Proof.
  destruct (Z.eq_dec b 0); [subst; rewrite div_0_r, Zdiv.Zdiv_0_r; apply floor0|].
  assert (IZR b <> 0) by (apply IZR_neq; assumption).

  destruct (Znumtheory.Zdivide_dec b a).
  - symmetry; apply floor_eq; rewrite div_IZR; try lra; assumption.
  - unfold floor. enough (((a / b) + 1)%Z = up (a / b)) by lia.
    apply tech_up.
    + apply Rlt_le_trans with (r2 := (a / b) + ((b - a mod b) / b)).
      assert (0 < ((b - a mod b) / b)).
      { destruct (Z_le_dec 0 b).
        { pose proof Z.mod_pos_bound a b ltac:(lia) as [].
          apply div_pos_nonneg; lira. }
        { pose proof Z.mod_neg_bound a b ltac:(lia) as [].
          apply div_neg_nonneg; lira. } }
      lra.
      rewrite <- Rdiv_plus_distr.
      autorewrite with pull_izr. rewrite <- div_IZR.
      rewrite Zdiv.Zmod_eq_full by lia.
      replace (a + (b - (a - a / b * b)))%Z with (b + a / b * b)%Z by lia.
      rewrite Z.div_add, Zdiv.Z_div_same_full by lia. lira.

      rewrite Zdiv.Zmod_eq_full.
      replace (a + (b - (a - a / b * b)))%Z with (b * (1 + a / b))%Z by lia. apply Z.divide_factor_l. lia.
    + pose proof Rdiv_div a b. lira. Qed.