(** * Rel: Properties of Relations *)

(** This short (and optional) chapter develops some basic definitions
    and a few theorems about binary relations in Coq.  The key
    definitions are repeated where they are actually used (in the
    \CHAPV2{Smallstep} chapter of _Programming Language Foundations_),
    so readers who are already comfortable with these ideas can safely
    skim or skip this chapter.  However, relations are also a good
    source of exercises for developing facility with Coq's basic
    reasoning facilities, so it may be useful to look at this material
    just after the [IndProp] chapter. *)

Require Export IndProp.

(* ################################################################# *)
(** * Relations *)

(** A binary _relation_ on a set [X] is a family of propositions
    parameterized by two elements of [X] -- i.e., a proposition about
    pairs of elements of [X].  *)

Definition relation (X: Type) := X -> X -> Prop.

(** Confusingly, the Coq standard library hijacks the generic term
    "relation" for this specific instance of the idea. To maintain
    consistency with the library, we will do the same.  So, henceforth
    the Coq identifier [relation] will always refer to a binary
    relation between some set and itself, whereas the English word
    "relation" can refer either to the specific Coq concept or the
    more general concept of a relation between any number of possibly
    different sets.  The context of the discussion should always make
    clear which is meant. *)

(** An example relation on [nat] is [le], the less-than-or-equal-to
    relation, which we usually write [n1 <= n2]. *)

Print le.
(* ====> Inductive le (n : nat) : nat -> Prop :=
             le_n : n <= n
           | le_S : forall m : nat, n <= m -> n <= S m *)
Check le : nat -> nat -> Prop.
Check le : relation nat.
(** (Why did we write it this way instead of starting with [Inductive
    le : relation nat...]?  Because we wanted to put the first [nat]
    to the left of the [:], which makes Coq generate a somewhat nicer
    induction principle for reasoning about [<=].) *)

(* ################################################################# *)
(** * Basic Properties *)

(** As anyone knows who has taken an undergraduate discrete math
    course, there is a lot to be said about relations in general,
    including ways of classifying relations (as reflexive, transitive,
    etc.), theorems that can be proved generically about certain sorts
    of relations, constructions that build one relation from another,
    etc.  For example... *)

(* ----------------------------------------------------------------- *)
(** *** Partial Functions *)

(** A relation [R] on a set [X] is a _partial function_ if, for every
    [x], there is at most one [y] such that [R x y] -- i.e., [R x y1]
    and [R x y2] together imply [y1 = y2]. *)

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

(** For example, the [next_nat] relation defined earlier is a partial
    function. *)

Print next_nat.
(* ====> Inductive next_nat (n : nat) : nat -> Prop :=
           nn : next_nat n (S n) *)
Check next_nat : relation nat.

Theorem next_nat_partial_function :
   partial_function next_nat.
Proof.
  unfold partial_function.
  intros x y1 y2 H1 H2.
  inversion H1. inversion H2.
  reflexivity.  Qed.

(** However, the [<=] relation on numbers is not a partial
    function.  (Assume, for a contradiction, that [<=] is a partial
    function.  But then, since [0 <= 0] and [0 <= 1], it follows that
    [0 = 1].  This is nonsense, so our assumption was
    contradictory.) *)

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense. {
    apply Hc with (x := 0).
    - apply le_n.
    - apply le_S. apply le_n. }
  inversion Nonsense.   Qed.

(** **** Exercise: 2 stars, optional (total_relation_not_partial)  *)
(** Show that the [total_relation] defined in earlier is not a partial
    function. *)

Theorem total_relation_not_partial : ~ (partial_function total_relation).
Proof. unfold partial_function. intros H.
  assert (0 = 1) as Nonsense. {
    apply H with (x := 0).
    - apply te.
    - apply te. }
  inversion Nonsense. Qed.

(** [] *)

(** **** Exercise: 2 stars, optional (empty_relation_partial)  *)
(** Show that the [empty_relation] that we defined earlier is a
    partial function. *)
Theorem empty_relation_partial : partial_function empty_relation.
Proof. unfold partial_function. intros x y1 y2 H. inversion H. Qed.

(* FILL IN HERE *)
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Reflexive Relations *)

(** A _reflexive_ relation on a set [X] is one for which every element
    of [X] is related to itself. *)

Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.

Theorem le_reflexive :
  reflexive le.
Proof.
  unfold reflexive. intros n. apply le_n.  Qed.

(* ----------------------------------------------------------------- *)
(** *** Transitive Relations *)

(** A relation [R] is _transitive_ if [R a c] holds whenever [R a b]
    and [R b c] do. *)

Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  - (* le_n *) apply Hnm.
  - (* le_S *) apply le_S. apply IHHmo.  Qed.

Theorem lt_trans:
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  apply le_S in Hnm.
  apply le_trans with (a := (S n)) (b := (S m)) (c := o).
  apply Hnm.
  apply Hmo. Qed.

(** **** Exercise: 2 stars, optional (le_trans_hard_way)  *)
(** We can also prove [lt_trans] more laboriously by induction,
    without using [le_trans].  Do this.*)

Theorem lt_trans' :
  transitive lt.
Proof.
  (* Prove this by induction on evidence that [m] is less than [o]. *)
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [| m' IH].
  - constructor. apply Hnm.
  - constructor. apply IHIH. Qed.

(** [] *)

(** **** Exercise: 2 stars, optional (lt_trans'')  *)
(** Prove the same thing again by induction on [o]. *)

Theorem lt_trans'' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o H1 H2.
  induction o as [| o'].
  - inversion H2.
  - apply le_trans with (b:=(S m)).
    + constructor. apply H1.
    + apply H2.
Qed.

(** [] *)

(** The transitivity of [le], in turn, can be used to prove some facts
    that will be useful later (e.g., for the proof of antisymmetry
    below)... *)

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof.
  intros n m H. apply le_trans with (S n).
  - apply le_S. apply le_n.
  - apply H.
Qed.

(** **** Exercise: 1 star, optional (le_S_n)  *)
Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof. intros n m H. inversion H.
  - constructor.
  - apply le_trans with (S n).
    + constructor. constructor.
    + apply H1.
Qed.

(** [] *)

(** **** Exercise: 2 stars, optional (le_Sn_n_inf)  *)
(** Provide an informal proof of the following theorem:

    Theorem: For every [n], [~ (S n <= n)]

    A formal proof of this is an optional exercise below, but try
    writing an informal proof without doing the formal proof first.

    Proof: *)
    (* FILL IN HERE *)
(** [] *)

(** **** Exercise: 1 star, optional (le_Sn_n)  *)
Theorem le_Sn_n : forall n,
  ~ (S n <= n).
Proof. intros n H. induction n as [|n IH].
  - inversion H.
  - apply IH. apply le_S_n. apply H. Qed.

(** [] *)

(** Reflexivity and transitivity are the main concepts we'll need for
    later chapters, but, for a bit of additional practice working with
    relations in Coq, let's look at a few other common ones... *)

(* ----------------------------------------------------------------- *)
(** *** Symmetric and Antisymmetric Relations *)

(** A relation [R] is _symmetric_ if [R a b] implies [R b a]. *)

Definition symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

(** **** Exercise: 2 stars, optional (le_not_symmetric)  *)
Theorem le_not_symmetric :
  ~ (symmetric le).
Proof. unfold symmetric. intros H.
  assert (1 <= 0) as Nonsense.
    apply H. constructor. constructor.
  inversion Nonsense. Qed.

(** [] *)

(** A relation [R] is _antisymmetric_ if [R a b] and [R b a] together
    imply [a = b] -- that is, if the only "cycles" in [R] are trivial
    ones. *)

Definition antisymmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

Check le_ind.
(** **** Exercise: 2 stars, optional (le_antisymmetric)  *)
Theorem le_antisymmetric :
  antisymmetric le.
Proof. intros n m H1 H2.
  inversion H1.
  - reflexivity.
  - apply n_le_m__Sn_le_Sm in H. rewrite H0 in H.
    exfalso. apply (le_Sn_n n). apply le_trans with m.
    apply H. apply H2. Qed.

(** [] *)

(** **** Exercise: 2 stars, optional (le_step)  *)
Theorem le_step : forall n m p,
  n < m ->
  m <= S p ->
  n <= p.
Proof. intros. apply le_S_n. apply le_trans with m.
  apply H. apply H0. Qed.

(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Equivalence Relations *)

(** A relation is an _equivalence_ if it's reflexive, symmetric, and
    transitive.  *)

Definition equivalence {X:Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

(* ----------------------------------------------------------------- *)
(** *** Partial Orders and Preorders *)

(** A relation is a _partial order_ when it's reflexive,
    _anti_-symmetric, and transitive.  In the Coq standard library
    it's called just "order" for short. *)

Definition order {X:Type} (R: relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).

(** A preorder is almost like a partial order, but doesn't have to be
    antisymmetric. *)

Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order :
  order le.
Proof.
  unfold order. split.
    - (* refl *) apply le_reflexive.
    - split.
      + (* antisym *) apply le_antisymmetric.
      + (* transitive. *) apply le_trans.  Qed.

(* ################################################################# *)
(** * Reflexive, Transitive Closure *)

(** The _reflexive, transitive closure_ of a relation [R] is the
    smallest relation that contains [R] and that is both reflexive and
    transitive.  Formally, it is defined like this in the Relations
    module of the Coq standard library: *)

Inductive clos_refl_trans {A: Type} (R: relation A) : relation A :=
    | rt_step : forall x y, R x y -> clos_refl_trans R x y
    | rt_refl : forall x, clos_refl_trans R x x
    | rt_trans : forall x y z,
          clos_refl_trans R x y ->
          clos_refl_trans R y z ->
          clos_refl_trans R x z.

(** For example, the reflexive and transitive closure of the
    [next_nat] relation coincides with the [le] relation. *)

Theorem next_nat_closure_is_le : forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
  intros n m. split.
  - (* -> *)
    intro H. induction H.
    + (* le_n *) apply rt_refl.
    + (* le_S *)
      apply rt_trans with m. apply IHle. apply rt_step.
      apply nn.
  - (* <- *)
    intro H. induction H.
    + (* rt_step *) inversion H. apply le_S. apply le_n.
    + (* rt_refl *) apply le_n.
    + (* rt_trans *)
      apply le_trans with y.
      apply IHclos_refl_trans1.
      apply IHclos_refl_trans2. Qed.

(** The above definition of reflexive, transitive closure is natural:
    it says, explicitly, that the reflexive and transitive closure of
    [R] is the least relation that includes [R] and that is closed
    under rules of reflexivity and transitivity.  But it turns out
    that this definition is not very convenient for doing proofs,
    since the "nondeterminism" of the [rt_trans] rule can sometimes
    lead to tricky inductions.  Here is a more useful definition: *)

Inductive clos_refl_trans_1n {A : Type}
                             (R : relation A) (x : A)
                             : A -> Prop :=
  | rt1n_refl : clos_refl_trans_1n R x x
  | rt1n_trans (y z : A) :
      R x y -> clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.

(** Our new definition of reflexive, transitive closure "bundles"
    the [rt_step] and [rt_trans] rules into the single rule step.
    The left-hand premise of this step is a single use of [R],
    leading to a much simpler induction principle.

    Before we go on, we should check that the two definitions do
    indeed define the same relation...

    First, we prove two lemmas showing that [clos_refl_trans_1n] mimics
    the behavior of the two "missing" [clos_refl_trans]
    constructors.  *)

Lemma rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> clos_refl_trans_1n R x y.
Proof.
  intros X R x y H.
  apply rt1n_trans with y. apply H. apply rt1n_refl.   Qed.

(** **** Exercise: 2 stars, optional (rsc_trans)  *)
Lemma rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      clos_refl_trans_1n R x y  ->
      clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.
Proof. intros. induction H as [|x y'].
  - apply H0.
  - apply rt1n_trans with y'.
    + apply H.
    + apply IHclos_refl_trans_1n. apply H0. Qed.

(** [] *)

(** Then we use these facts to prove that the two definitions of
    reflexive, transitive closure do indeed define the same
    relation. *)

(** **** Exercise: 3 stars, optional (rtc_rsc_coincide)  *)
Theorem rtc_rsc_coincide :
         forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
Proof. intros X R x y. split.
  - intros H. induction H.
    + apply rsc_R. apply H.
    + constructor.
    + apply rsc_trans with y.
      * apply IHclos_refl_trans1.
      * apply IHclos_refl_trans2.
  - intros H. induction H.
    + apply rt_refl.
    + apply rt_trans with y.
      * constructor. apply H.
      * apply IHclos_refl_trans_1n.
Qed.

(** [] *)


Require Import Datatypes.
From MyCoq.Lib Require Export Bool.

Inductive nat : Type :=
  | O
  | S (n : nat).

Fixpoint N (n : Datatypes.nat) : nat :=
  match n with
  | 0 => O
  | Datatypes.S m => S (N m)
  end.

Definition pred (n : nat) : nat :=
  match n with
  | O => O
  | S n' => n'
  end.

Fixpoint evenb (n : nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => evenb n'
  end.

Definition oddb (n : nat) : bool :=
  negb (evenb n).

Fixpoint eqb (n m : nat) : bool :=
  match n with
  | O => match m with
          | O => true
          | _ => false
          end
  | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
  end.

Fixpoint ltb (n m : nat) : bool :=
  match n with
  | O => match m with
          | O => false
          | _ => true
          end
  | S n' => match m with
            | O => false
            | S m' => ltb n' m'
            end
  end.

Fixpoint leb (n m : nat) : bool :=
  match n with
  | O => true
  | S n' => match m with
            | O => false
            | S m' => leb n' m'
            end
  end.

Fixpoint plus (n : nat) (m : nat) : nat :=
  match n with
  | O => m
  | S n' => S (plus n' m)
  end.

Fixpoint minus (n m : nat) : nat :=
  match n, m with
  | O, _ => O
  | _, O => n
  | S n', S m' => minus n' m'
  end.

Fixpoint mult (n m : nat) : nat :=
  match n, m with
  | O, _ => O
  | S n', m => plus m (mult n' m)
  end.

Fixpoint exp (base power : nat) : nat :=
  match power with
  | O => S O
  | S power' => mult base (exp base power')
  end.

Notation "x =? y" := (eqb x y) (at level 70, no associativity).

Notation "x <? y" := (ltb x y) (at level 70, no associativity).

Notation "x <=? y" := (leb x y) (at level 70, no associativity).

Notation "x + y" := (plus x y) (at level 50, left associativity).

Notation "x - y" := (minus x y) (at level 50, left associativity).

Notation "x * y" := (mult x y) (at level 40, left associativity).

Theorem plus_O_n: forall n : nat,
  O + n = n.
Proof.
  reflexivity.
Qed.

Theorem plus_n_O: forall n : nat,
  n + O = n.
Proof.
  induction n as [| n' IHn'].
  - reflexivity.
  - simpl.
    rewrite IHn'.
    reflexivity.
Qed.

Theorem plus_n_Sm: forall n m : nat,
  n + S m = S (n + m) .
Proof.
  intros n m.
  induction n as [| n' IHn'].
  - reflexivity.
  (* + 的定义 *)
  - simpl.
    rewrite IHn'.
    reflexivity.
Qed.

(* 加法交换律 *)
Theorem plus_comm: forall n m : nat,
  n + m = m + n.
Proof.
  intros n m.
  induction n as [| n' IHn'].
  - rewrite plus_O_n.
    rewrite plus_n_O.
    reflexivity.
  - simpl.
    rewrite plus_n_Sm.
    rewrite IHn'.
    reflexivity.
Qed.

(* 加法结合律 *)
Theorem plus_assoc: forall a b c : nat,
  a + b + c = a + (b + c).
Proof.
  intros a b c.
  induction a as [| a' IHa'].
  - reflexivity.
  (* 两次应用 + 的定义 *)
  - simpl.
    rewrite IHa'.
    reflexivity.
Qed.

Theorem mult_O_n: forall n : nat,
  O * n = O.
Proof.
  reflexivity.
Qed.

Theorem mult_n_O: forall n : nat,
  n * O = O.
Proof.
  intros n.
  induction n as [| n' IHn'].
  - reflexivity.
  - simpl.
    rewrite IHn'.
    reflexivity.
Qed.

Theorem mult_n_Sm: forall n m : nat,
  n * m + n = n * S m.
Proof.
  intros n m.
  induction n as [| n' IHn'].
  - reflexivity.
  (* * 的定义以及 + 的定义 *)
  - simpl.
    rewrite <- IHn'.
    rewrite -> plus_n_Sm.
    rewrite <- plus_assoc.
    reflexivity.
Qed.

(* 乘法交换律 *)
Theorem mult_comm : forall m n : nat,
  m * n = n * m.
Proof.
  intros n m.
  induction m as [| m' IHm'].
  - rewrite mult_n_O.
    reflexivity.
  - rewrite <- mult_n_Sm.
    simpl.
    rewrite IHm'.
    rewrite plus_comm.
    reflexivity.
Qed.

Inductive bin : Type :=
  | Z
  | A (n : bin)
  | B (n : bin).

Fixpoint incr (n : bin) : bin :=
  match n with
  | Z => B Z
  | A n' => B n'
  | B n' => A (incr n')
  end.

Fixpoint bin_to_nat (n : bin) : nat :=
  match n with
  | Z => O
  | A n' => (N 2) * (bin_to_nat n')
  | B n' => (N 1) + (N 2) * (bin_to_nat n')
  end.

Fixpoint nat_to_bin (n : nat) : bin :=
  match n with
  | O => Z
  | S n' => incr (nat_to_bin n')
  end.

Theorem self_eq: forall n : nat,
  n =? n = true.
Proof.
  induction n as [| n'].
  - reflexivity.
  - simpl.
    rewrite IHn'.
    reflexivity.
Qed.

Definition minustwo (n : nat) : nat :=
  match n with
  | O => O
  | S O => O
  | S (S n') => n'
  end.

Fixpoint double (n : nat) :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

Theorem mult_plus_distr_r: forall n m p : nat,
  (n + m) * p = (n * p) + (m * p).
Proof.
  intros n m p.
  induction n as [| n IHn'].
  - induction p as [| p IHp'].
    + reflexivity.
    + reflexivity.
  - simpl.
    assert (H: p + n * p + m * p = p + (n * p + m * p)).
    {
      rewrite -> plus_assoc.
      reflexivity.
    }
    rewrite -> H.
    rewrite <- IHn'.
    reflexivity.
Qed.

Theorem mult_assoc: forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof.
  intros n m p.
  induction n as [| n' IHn'].
  - reflexivity.
  - simpl.
    rewrite -> mult_plus_distr_r.
    rewrite IHn'.
    reflexivity.
Qed.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Strings.String.  (* for manual grading *)
From Coq Require Export Bool.Bool.
From Coq Require Export Arith.Arith.
From Coq Require Export Arith.EqNat.
From Coq Require Export Lia.
From Coq Require Export Lists.List.
Export ListNotations.
From Coq Require Export Permutation.

Fixpoint insert (i : nat) (l : list nat) :=
  match l with
  | []      => [i]
  | h :: t  => if i <=? h then i :: h :: t else h :: insert i t
  end.

Fixpoint sort (l : list nat) : list nat :=
  match l with
  | []      => []
  | h :: t  => insert h (sort t)
  end.

Example sort_pi :
  sort [3;1;4;1;5;9;2;6;5;3;5]  = [1;1;2;3;3;4;5;5;5;6;9].
Proof. simpl. reflexivity. Qed.

Inductive sorted : list nat -> Prop :=
| sorted_nil  : sorted []
| sorted_1    : forall x, sorted [x]
| sorted_cons : forall x y l,
    x <= y -> sorted (y :: l) -> sorted (x :: y :: l).

Definition sorted'' (al : list nat) := forall i j,
    i < j < length al ->
    nth i al 0 <= nth j al 0.

Definition sorted' (al : list nat) := forall i j iv jv,
    i < j ->
    nth_error al i = Some iv ->
    nth_error al j = Some jv ->
    iv <= jv.

Definition is_a_sorting_algorithm (f: list nat -> list nat) := forall al,
    Permutation al (f al) /\ sorted (f al).

Notation  "a >=? b" := (Nat.leb b a)
                          (at level 70) : nat_scope.
Notation  "a >? b"  := (Nat.ltb b a)
                         (at level 70) : nat_scope.

Lemma eqb_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.eqb_eq.
Qed.
Lemma ltb_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.ltb_lt.
Qed.
Lemma leb_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.leb_le.
Qed.

Hint Resolve ltb_reflect leb_reflect eqb_reflect : bdestruct.
Ltac bdestruct X :=
  let H := fresh     in
  let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
       [ | try first [apply not_lt in H | apply not_le in H]]].

Lemma insert_sorted:
  forall a l, sorted l -> sorted (insert a l).
Proof.
  intros a l S.
  induction S; simpl.
  - constructor.
  - bdestruct (a <=? x).
    + apply sorted_cons.
        assumption.
        constructor.
    + apply sorted_cons.
        lia.
        constructor.
  - bdestruct (x >=? a).
    + apply sorted_cons; try lia.
      apply sorted_cons; try lia.
      assumption.
    + simpl in IHS.
      bdestruct (y >=? a).
      * apply sorted_cons; try lia.
        assumption.
      * apply sorted_cons; try lia.
        assumption.
Qed.

Theorem sort_sorted: forall l, sorted (sort l).
Proof.
  intro l.
  induction l; simpl.
  - constructor.
  - apply insert_sorted.
    assumption.
Qed.

Print Permutation.
Search Permutation.

Lemma insert_perm: forall x l,
    Permutation (x :: l) (insert x l).
Proof.
  intros x l.
  induction l; simpl.
  - constructor. constructor.
  - bdestruct (a >=? x).
    + apply Permutation_refl.
    + apply perm_trans with (a :: x :: l).
      * apply perm_swap.
      * constructor.
        assumption.
Qed.

Theorem sort_perm: forall l, Permutation l (sort l).
Proof.
  intro l.
  induction l; simpl.
  - constructor.
  - apply perm_trans with (a :: sort l).
    + constructor. assumption.
    + apply insert_perm.
Qed.

Theorem insertion_sort_correct:
    is_a_sorting_algorithm sort.
Proof.
  split.
  - apply sort_perm.
  - apply sort_sorted.
Qed.

Lemma less_than_all_sorted: forall x y l,
  x <= y -> sorted' (y :: l) ->
  forall i iv, nth_error (y :: l) i = Some iv -> x <= iv.
Proof.
  intros x y l Hxy Hsorted.
  unfold sorted' in Hsorted.
  intro i.
  induction i.
  - simpl. intros iv H'. injection H' as H'.
    subst. assumption.
  - simpl. intros iv H'.
    assert (y <= iv). {
      apply (Hsorted 0 (S i) y iv).
      + lia.
      + reflexivity.
      + simpl. apply H'.
    }
    lia.
Qed.

Lemma sorted_sorted': forall al, sorted al -> sorted' al.
Proof.
  intros al.
  induction al; simpl; intro Hsorted.
  - intros i j iv jv Hind H1 H2.
    destruct i; simpl in H1; discriminate H1.
  - inversion Hsorted; subst.
    + intros i j iv jv Hind H1 H2.
      destruct i; inversion Hind; subst.
      -- discriminate H2.
      -- simpl in H2.
         destruct m; simpl in H2; discriminate H2.
      -- discriminate H2.
      -- simpl in H2.
         destruct m; simpl in H2; discriminate H2.
    + intros i j iv jv Hind H1' H2'.
      destruct i; destruct j.
      * lia.
      * apply IHal in H2. clear IHal.
        simpl in H1', H2'.
        injection H1' as H1'; subst.
        induction j.
        -- simpl in H2'. injection H2' as H2'; subst.
           assumption.
        -- apply (less_than_all_sorted _ _ _ H1 H2  (S j) jv H2').
      * lia.
      * simpl in H1', H2'.
        apply (IHal H2 i j iv jv).
        -- lia.
        -- apply H1'.
        -- apply H2'.
Qed.

Lemma sorted_tail:
  forall a l, sorted' (a :: l) -> sorted' l.
Proof.
  intros a l H i j iv jv Hilj Hiv Hjv.
  apply (H (S i) (S j) iv jv).
  - lia.
  - simpl. apply Hiv.
  - simpl. apply Hjv.
Qed.

Lemma sorted'_sorted : forall al, sorted' al -> sorted al.
Proof.
  intro al.
  induction al.
  - intro H. constructor.
  - intro H.
    destruct al as [ | alh alt].
    + constructor.
    + apply sorted_cons.
      * unfold sorted' in H.
        apply (H 0 1).
          lia.
          reflexivity.
          reflexivity.
      * apply IHal.
        apply sorted_tail with a.
        apply H.
Qed.

Lemma nth_error_insert : forall l a i iv,
    nth_error (insert a l) i = Some iv ->
    a = iv \/ exists i', nth_error l i' = Some iv.
Proof.
  intro l.
  induction l; simpl; intros a' i iv H.
  - destruct i; try (destruct i; discriminate H).
    simpl in H. injection H as H.
    left.
    assumption.
  - bdestruct (a >=? a').
    + destruct i.
      * simpl in H. injection H as H.
        left.
        assumption.
      * simpl in H.
        right. exists i. apply H.
    + destruct i.
      * simpl in H. injection H as H. subst.
        right.
        exists 0. reflexivity.
      * simpl in H.
        assert (G: a' = iv \/ (exists i' : nat, nth_error l i' = Some iv)). {
          eapply IHl.
          apply H.
        }
        destruct G as [Gl | [gi Gr]].
        -- left. assumption.
        -- right. exists (S gi). simpl. assumption.
Qed.

Lemma less_than_all_sorted': forall x y l,
  x < y -> sorted' (y :: l) ->
  forall i iv, nth_error (y :: l) i = Some iv -> x < iv.
Proof.
  intros x y l Hxy Hsorted.
  unfold sorted' in Hsorted.
  intro i.
  induction i.
  - simpl. intros iv H'. injection H' as H'.
    subst. assumption.
  - simpl. intros iv H'.
    assert (y <= iv). {
      apply (Hsorted 0 (S i) y iv).
      + lia.
      + reflexivity.
      + simpl. apply H'.
    }
    lia.
Qed.

Lemma remove_second_in_sorted: forall v v' l, sorted' (v :: v' :: l) -> sorted' (v :: l).
Proof.
  intros v v' l Hsorted i j vi vj Lij Hi Hj.
  destruct i; destruct j.
  - lia.
  - simpl in *.
    injection Hi as Hi; subst.
    apply (Hsorted 0 (S (S j)) vi vj).
    + lia.
    + reflexivity.
    + simpl. apply Hj.
  - lia.
  - simpl in *.
    apply (Hsorted (S (S i)) (S (S j)) vi vj).
    + lia.
    + simpl. apply Hi.
    + simpl. apply Hj.
Qed.

Lemma less_than_insert_to_tail: forall l v a,
  sorted' (v :: l) ->
  a > v ->
  forall i v', nth_error (insert a l) i = Some v' -> (v <= v').
Proof.
  intro l.
  induction l; simpl; intros v a' Hsorted La'v i v' H.
  - destruct i; simpl in H.
    + injection H as H; subst. lia.
    + destruct i; discriminate H.
  - bdestruct (a >=? a').
    + destruct i; simpl in H.
      * injection H as H; subst. lia.
      * apply (less_than_all_sorted v a l) with i.
        -- lia.
        -- apply sorted_tail with v. apply Hsorted.
        -- apply H.
    + destruct i; simpl in H.
      * injection H as H; subst.
        apply (Hsorted 0 1 v v').
        -- lia.
        -- reflexivity.
        -- reflexivity.
      * apply (IHl v a') with i.
        -- apply (remove_second_in_sorted _ _ _ Hsorted).
        -- assumption.
        -- apply H.
Qed.

Lemma insert_sorted':
  forall a l, sorted' l -> sorted' (insert a l).
Proof.
  intros a l H.
  induction l.
  - simpl.
    unfold sorted'.
    intros i j iv jv Lij Hiv Hvj.
    destruct i; destruct j.
    + lia.
    + simpl in *. destruct j; discriminate Hvj.
    + lia.
    + simpl in *. destruct j; discriminate Hvj.
  - simpl.
    bdestruct (a0 >=? a).
    + unfold sorted'.
      intros i j iv jv Lij Hiv Hvj.
      destruct i; destruct j; try lia.
      * simpl in *.
        injection Hiv as Hiv; subst.
        apply (less_than_all_sorted iv a0 l H0 H j).
        assumption.
      * simpl in *.
        apply (H i j iv jv).
        -- lia.
        -- apply Hiv.
        -- apply Hvj.
    + intros i j iv jv Lij Hiv Hvj.
      destruct i; destruct j; try lia.
      * simpl in *.
        injection Hiv as Hiv; subst.
        apply (less_than_insert_to_tail _ _ _ H H0 j jv Hvj).
      * simpl in *.
        apply sorted_tail in H.
        apply IHl in H.
        apply (H i j iv jv).
        -- lia.
        -- apply Hiv.
        -- apply Hvj.
Qed.

Ltac inv H := inversion H; clear H; subst.

Theorem sort_sorted': forall l, sorted' (sort l).
Proof.
  induction l.
  - unfold sorted'. intros. destruct i; inv H0.
  - simpl. apply insert_sorted'. auto.
Qed.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                   Solange Coupet-Grimal & Line Jakubiec                  *)
(*                                                                          *)
(*                                                                          *)
(*              Laboratoire d'Informatique de Marseille                     *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lim.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              May 30th 1996                               *)
(*                                                                          *)
(****************************************************************************)
(*                               Lib_Mult.v                                 *)
(****************************************************************************)

Require Export Lib_Plus.

Lemma plus_mult : forall n : nat, n + n = 2 * n.
intros n; simpl in |- *; elim plus_n_O; auto with arith.
Qed.
Hint Resolve plus_mult.

Lemma lt_mult_lt_O : forall n m : nat, 0 < n * m -> 0 < m -> 0 < n.
simple induction n; auto with arith.
Qed.

Lemma le_mult_cst : forall x y a : nat, x <= y -> a * x <= a * y.
auto with arith.
Qed.

Lemma le_mult_csts : forall a b c d : nat, a <= b -> c <= d -> a * c <= b * d.
intros.
apply le_trans with (a * d).
apply le_mult_cst; assumption.
elim mult_comm; elim mult_comm with d b.
apply le_mult_cst; assumption.
Qed.
Hint Resolve le_mult_csts.

Lemma lt_mult_n_Sn : forall n m : nat, 0 < m -> n * m < S n * m.
simple induction n; simple induction m; auto with arith.
intros; simpl in |- *.
elim plus_n_O; auto with arith.
intro.
elim mult_n_O; elim mult_n_O; auto with arith.
intros; simpl in |- *; apply lt_n_S; auto with arith.
Qed.
Hint Resolve lt_mult_n_Sn.

Lemma lt_mult_cst : forall x y a : nat, x < y -> 0 < a -> a * x < a * y.
intros.
elim H.
elim mult_comm; elim mult_comm with (S x) a.
apply lt_mult_n_Sn; assumption.
intros.
apply lt_trans with (a * m).
assumption.
elim mult_comm; elim mult_comm with (S m) a.
apply lt_mult_n_Sn; assumption.
Qed.
Hint Resolve lt_mult_cst.

Lemma lt_mult_csts : forall a b c d : nat, a < b -> c < d -> a * c < b * d.
intros.
apply le_lt_trans with (a * d).
apply le_mult_cst.
apply lt_le_weak; assumption.
elim mult_comm; elim mult_comm with d b.
apply lt_mult_cst.
assumption.
apply lt_O with c; auto with arith.
Qed.
Hint Resolve lt_mult_csts.

Lemma pred_mult : forall n m : nat, 0 < n -> n * m = pred n * m + m.
intros.
elim H; simpl in |- *; auto with arith.
Qed.
Hint Resolve pred_mult.

Lemma le_lt_plus_mult :
 forall n m p n' p' : nat, n <= n' -> p < p' -> n * m + p < n' * m + p'.
intros; apply le_lt_plus; auto with arith.
Qed.

Lemma le_mult_l : forall n m : nat, 0 < m -> n <= m * n.
intros.
rewrite (S_pred m 0); trivial with arith.
simpl in |- *; auto with arith.
Qed.
Hint Resolve le_mult_l.

Lemma le_mult_r : forall n m : nat, 0 < m -> n <= n * m.
intros n m; elim (mult_comm m n); auto with arith.
Qed.
Hint Resolve le_mult_r.

Lemma lt_mult : forall n m : nat, 1 < m -> 0 < n -> n < n * m.
intros.
pattern n at 1 in |- *.
elim mult_1_r.
apply lt_mult_cst; auto with arith.
Qed.
Hint Resolve lt_mult.

Lemma lt_SO_mult : forall n m : nat, 1 < n -> 0 < m -> 1 < n * m.
intros.
apply lt_le_trans with (1 * n).
auto with arith.
simpl in |- *.
elim plus_n_O.
apply le_mult_r; auto with arith.
Qed.

Lemma plus_m_mult_n_m : forall n m : nat, m + n * m = S n * m.
simple induction n; simple induction m; simpl in |- *; auto with arith.
Qed.

Lemma y_eq_multxy : forall x y : nat, x = 1 \/ y = 0 -> y = x * y.
intros x y H; elim H; clear H; intros H; rewrite H; simpl in |- *;
 auto with arith.
Qed.

Lemma mult_plus_distr_left : forall n m p : nat, p * (n + m) = p * n + p * m.
intros; elim mult_comm.
elim (mult_comm n p).
elim (mult_comm m p).
auto with arith.
Qed.
Hint Resolve mult_plus_distr_left.

Lemma mult_minus_distr_left : forall n m p : nat, p * (n - m) = p * n - p * m.
intros.
rewrite (mult_comm p (n - m)); rewrite (mult_comm p n);
 rewrite (mult_comm p m); auto with arith.
Qed.
Hint Resolve mult_minus_distr_left.

Lemma mult_eq_zero : forall a b : nat, a * b = 0 -> a = 0 \/ b = 0.
intros a b; elim a.
auto with arith.
intros n H_rec H.
right.
elim (plus_eq_zero (n * b) b); auto with arith.
simpl in H; elim plus_comm.
auto with arith.
Qed.
Hint Resolve mult_eq_zero.

Lemma lt_mult_S_S : forall n m : nat, 0 < S n * S m.
simple induction n; simpl in |- *; auto with arith.
Qed.
Hint Resolve lt_mult_S_S.

Lemma mult_S_O : forall n m : nat, 0 = S n * m -> 0 = m.
intros n m H.
elim (mult_eq_zero (S n) m); auto with arith.
intro; absurd (S n = 0); auto with arith.
Qed.

Lemma mult_reg_l : forall a b p : nat, p * a = p * b -> p = 0 \/ a = b.
intros a b p; generalize b; generalize a; clear a b.
simple induction a.
replace (p * 0) with 0.
intros.
cut (p = 0 \/ b = 0).
intro.
elim H0; auto with arith.
cut (p * b = 0).
elim (mult_eq_zero p b); auto with arith.
auto with arith.
apply mult_n_O.
intros n H_rec.
simple induction b.
replace (p * 0) with 0.
intro.
apply (mult_eq_zero p (S n) H).
apply mult_n_O.
intros m H.
replace (p * S n) with (p * n + p).
replace (p * S m) with (p * m + p).
2: apply mult_n_Sm.
2: apply mult_n_Sm.
clear a; clear b.
intro.
elim (H_rec m); auto with arith.
apply (fun a b : nat => plus_reg_l a b p).
elim (plus_comm (p * n) p).
elim (plus_comm (p * m) p); trivial with arith.
Qed.
Hint Resolve mult_reg_l.

Lemma mult_reg_l_bis : forall a b p : nat, 0 < p -> p * a = p * b -> a = b.
intros a b p H H1.
elim (mult_reg_l a b p); auto with arith.
intro; absurd (p = 0); auto with arith.
Qed.
Hint Immediate mult_reg_l_bis.

Lemma mult_eq_zero_bis : forall a b : nat, 0 < a -> a * b = 0 -> b = 0.
intros a b pos H.
elim (mult_eq_zero a b H); auto with arith.
intro h.
absurd (a = 0); auto with arith.
Qed.
Hint Immediate mult_eq_zero_bis.

Lemma lt_nm_mult : forall n m : nat, 0 < n -> 0 < m -> 0 < n * m.
intros n m H1 H2.
elim H1; elim H2; simpl in |- *; auto with arith.
Qed.
Hint Resolve lt_nm_mult.

Lemma same_quotient_order :
 forall b q q' r r' : nat, r < b -> q < q' -> q * b + r < q' * b + r'.
intros.
apply lt_le_trans with (q * b + b).
apply plus_lt_compat_l.
try trivial with arith.
pattern b at 2 in |- *.
replace b with (1 * b).
elim mult_plus_distr_r.
apply le_trans with (q' * b).
elim (mult_comm b (q + 1)); elim (mult_comm b q').
apply le_mult_cst.
replace (q + 1) with (S q).
auto with arith.
elim plus_comm; simpl in |- *; auto with arith.
auto with arith.
simpl in |- *; auto with arith.
Qed.
Hint Resolve same_quotient_order.

(************************************************************************)


Require Import String Arith List Lia.
Import ListNotations.

(*
First, we will define name as we did in the lecture notes.
*)
Definition var := string.

(*
Then we need to define the labels for the in and out.
*)
Inductive label :=
    | In (name: var)
    | Out (name: var)
.

(*
And we need to define actions including the internal action, Tau.
 *)
Inductive action :=
    | Label (l: label)
    | Tau
.

Definition complement (a: action) : action :=
    match a with
    | Label (In n) => Label (Out n)
    | Label (Out n) => Label (In n)
    | Tau => Tau
end.

Definition action_eq (a b: action) : bool :=
    match a with
    | Label (In n) => match b with
                        | Label (In m) => eqb n m
                        | _ => false
                        end
    | Label (Out n) => match b with
                        | Label (Out m) => eqb n m
                        | _ => false
                        end
    | Tau => match b with
                | Tau => true
                | _ => false
                end
end.

(*
We can now define all of our proess expressions as we did in the lecture notes.
 *)
Inductive expr :=
    | Skip
    | Const (v: var) (e: expr)
    | Action (a: action) (e: expr)
    | Sum (e1 e1: expr)
    | Comp (e1 e2: expr)
    | Rest (e: expr) (a: action)
    | Relab (e: expr) (from to: label)
.

(*
Now, let's define our labelling transition step semantics.
 *)
Inductive expr_step: expr -> action -> expr -> Prop :=
    (* The name of the constant can step to the same place that the expression can step *)
    | expr_step_const               : forall (v: var) (e1 e2: expr) (a: action),
                                        expr_step e1 a e2 ->
                                        expr_step (Const v e1) a e2

    (* The action describes the step that can be taken *)
    | expr_step_act                 : forall (e: expr) (a: action),
                                        expr_step (Action a e) a e

    (* If the left side of a sum can take a step, then the entire expression can take a step there *)
    | expr_step_sum_left            : forall (e1 e1' e2: expr) (a: action),
                                        expr_step e1 a e1' ->
                                        expr_step (Sum e1 e2) a e1'

    (* If the right side of a sum can take a step, then the entire expression can take a step there *)
    | expr_step_sum_right           : forall (e1 e2 e2': expr) (a: action),
                                        expr_step e2 a e2' ->
                                        expr_step (Sum e1 e2) a e2'

    (* If the left side of a composition can take a step, then the entire expression can take a step there where the left side is modified *)
    | expr_step_comp_left           : forall (e1 e1' e2: expr) (a: action),
                                        expr_step e1 a e1' ->
                                        expr_step (Comp e1 e2) a e1'

    (* If the right side of a composition can take a step, then the entire expression can take a step there where the right side is modified *)
    | expr_step_comp_right          : forall (e1 e2 e2': expr) (a: action),
                                        expr_step e2 a e2' ->
                                        expr_step (Comp e1 e2) a e2'

    (* If the actions are internal to the composition, we can step to the next composite expression with tau *)
    | expr_step_comp_internal       : forall (e1 e1' e2 e2': expr) (a: action),
                                        expr_step e1 a e1' ->
                                        expr_step e2 (complement a) e2' ->
                                        expr_step (Comp e1 e2) Tau (Comp e1' e2')

    (* The step is preserved as long as the label being restricted isn't the being restricted *)
    | expr_step_res                 : forall (e1 e2: expr) (a b: action),
                                        (action_eq Tau b) = false ->
                                        (action_eq a b) = false ->
                                        (action_eq (complement a) b) = false ->
                                        expr_step e1 a e2 ->
                                        expr_step (Rest e1 b) a (Rest e2 b)

    (* If you can step between two expressions, then you can step to the relabeling of that action taking into account the relabelling of the state it can step to *)
    | expr_step_rel                 : forall (e1 e2: expr) (a b: label),
                                        expr_step e1 (Label a) e2 ->
                                        expr_step (Relab e1 a b) (Label b) (Relab e2 a b)
    .

(*
Let's work through the example we did in the lecture notes.
*)
Example class_example:
    forall (e f: expr) (a b: label),
        expr_step (Rest (Comp (Sum (Action (Label a) e) (Action (Label b) Skip)) (Action (complement (Label a)) f)) (Label a)) Tau (Rest (Comp e f) (Label a)).
Proof.
    intros.
    eapply expr_step_res.
    - auto.
    - auto.
    - auto.
    - eapply expr_step_comp_internal.
        + eapply expr_step_sum_left.
            * apply expr_step_act.
        + apply expr_step_act.
Qed.
(*
It was exactly like the proof in the lecture notes!
*)


Ltac unfold_tactic name := intros; unfold name; (* fold name; *) reflexivity.

Require Import Arith Bool.

Definition specification_of_ackermann_peter_function (ack : nat -> nat -> nat):=
  (forall n : nat,
      ack 0 n = S n)
  /\
  (forall m : nat,
      ack (S m) 0 = ack m 1)
  /\
  (forall m n : nat,
      ack (S m) (S n) = ack m (ack (S m) n)).

Definition specification_of_ackermann_peter_function' (ack : nat -> nat -> nat):=
  forall m n : nat,
    (ack 0 n = S n)
    /\
    (ack (S m) 0 = ack m 1)
    /\
    (ack (S m) (S n) = ack m (ack (S m) n)).

Proposition extensionality_of_the_specification_of_the_ackermann_peter_function :
  forall f g : nat -> nat -> nat,
    specification_of_ackermann_peter_function f ->
    specification_of_ackermann_peter_function g ->
    forall m n : nat,
      f m n = g m n.
Proof.
  intros f g.
  unfold specification_of_ackermann_peter_function.
  intros [S_f_0_l [S_f_0_r S_f_SS]] [S_g_0_l [S_g_0_r S_g_SS]].

  intro m.
  induction m as [ | m' IHm'].

  intro n.
  rewrite -> S_f_0_l.
  rewrite -> S_g_0_l.
  reflexivity.

  intro n.
  induction n as [ | n' IHn'].
  rewrite -> S_f_0_r.
  rewrite -> S_g_0_r.
  rewrite -> IHm'.
  reflexivity.

  rewrite -> S_f_SS.
  rewrite -> S_g_SS.

  rewrite -> IHn'.
  rewrite -> IHm'.
  reflexivity.
Qed.

Proposition equivalence_of_the_two_specifications:
  forall f : nat -> nat -> nat,
    specification_of_ackermann_peter_function f
    <->
    specification_of_ackermann_peter_function' f.
Proof.
  intro f.
  unfold specification_of_ackermann_peter_function.
  unfold specification_of_ackermann_peter_function'.

  split.
  intros [S_f_0_l [S_f_0_r S_f_SS]].

  intros n m.
  split.
  rewrite -> S_f_0_l.
  reflexivity.
  split.
  rewrite -> S_f_0_r.
  reflexivity.
  rewrite -> S_f_SS.
  reflexivity.

  intros S_f_all.
  split.
  intro n.
  Check (S_f_all 0 n).
  apply (S_f_all 0 n).

  split.
  intro m.
  apply (S_f_all m 0).

  intros m n.
  apply (S_f_all m n).
Qed.

Fixpoint primitive_iteration (T : Type) (s : T -> T) (z : T) (i : nat) : T :=
  match i with
  | 0 =>
    z
  | S i' =>
    s (primitive_iteration T s z i')
  end.

Lemma unfold_primitive_iteration_0 :
  forall (T : Type) (s : T -> T) (z : T),
    primitive_iteration T s z 0 = z.
Proof.
  unfold_tactic primitive_iteration.
Qed.

Lemma unfold_primitive_iteration_S :
  forall (T : Type) (s : T -> T) (z : T) (n' : nat),
    primitive_iteration T s z (S n') =
    s (primitive_iteration T s z n').
Proof.
  unfold_tactic primitive_iteration.
Qed.

Definition ack_orig (m : nat) :=
  primitive_iteration
    (nat -> nat)
    (fun f n => primitive_iteration nat f (f 1) n)
    S
    m.

Proposition ack_orig_satisfies_the_specification_of_the_ackermann_peter_function :
  specification_of_ackermann_peter_function ack_orig.
Proof.
  unfold specification_of_ackermann_peter_function.
  unfold ack_orig.
  split.

  intro n.
  unfold primitive_iteration.
  reflexivity.

  split.
  intro m.
  Check (unfold_primitive_iteration_0 (nat -> nat) ).

Abort.

Fixpoint ack (m : nat) :=
  match m with
  | O =>
    S
  | S m' =>
    fix ack_local (n : nat) :=
    match n with
    | O =>
      ack m' 1
    | S n' =>
      ack m' (ack_local n')
    end
  end.

Lemma unfold_ack_0 :
  ack 0 = S.
Proof.
  unfold_tactic ack.
Qed.

Lemma unfold_ack_S :
  forall m' : nat,
    ack (S m') =
    fix ack_local (n : nat) :=
    match n with
    | O =>
      ack m' 1
    | S n' =>
      ack m' (ack_local n')
    end.
Proof.
  unfold_tactic ack.
Qed.
Lemma unfold_ack_S_0 :
  forall m' : nat,
    ack (S m') 0 = ack m' 1.
Proof.
  unfold_tactic ack.
Qed.

Lemma unfold_ack_S_S :
  forall m' n': nat,
    ack (S m') (S n') = ack m' (ack (S m') n').
Proof.
  unfold_tactic ack.
Qed.

Proposition ack_satisfies_the_specification_of_the_ackermann_peter_function:
  specification_of_ackermann_peter_function ack.
Proof.
Abort.

Theorem an_inequality_about_the_ackermann_peter_function:
  forall ack : nat -> nat -> nat,
    specification_of_ackermann_peter_function ack ->
    forall m n : nat,
      n < ack m n.
Proof.
  unfold specification_of_ackermann_peter_function.
  intros ack [S_ack_0_l [S_ack_0_r S_ack_SS]].

  intro m.
  induction m as [ | m' IHm'].
  intro n.
  rewrite -> S_ack_0_l.
  Search (_ < S _).
  apply Nat.lt_succ_diag_r.

  induction n as [ | n' IHn'].
  rewrite -> S_ack_0_r.
  Search (S _ < _).
  (*Nat.lt_succ_l: forall n m : nat, S n < m -> n < m*)
  apply (Nat.lt_succ_l 0 (ack m' 1) (IHm' 1)).

  Check (lt_trans).
  (*Nat.lt_trans
     : forall n m p : nat, n < m -> m < p -> n < p*)


Module Basic.

Inductive num : Type :=
    | Zero : num
    | Succ : num -> num .

Inductive bool : Type :=
    | True : bool
    | False : bool .

Definition pred ( n : num ) : num :=
    match n with
      | Zero => Zero
      | Succ n' => n
    end.

Eval compute in (pred Zero).
Eval compute in (pred (Succ Zero)).

Definition iszero (n : num ) : bool :=
     match n with
      | Zero => True
      | Succ _ => False
     end.

Eval compute in (iszero Zero).
Eval compute in (iszero (Succ Zero)).

Fixpoint sum ( n : num ) ( m : num ) : num :=
     match m with
       | Zero => n
       | Succ n' => Succ (sum n n')
     end.

Eval compute in (sum Zero (Succ Zero)).
Eval compute in (sum (Succ Zero) (Succ Zero)).

Fixpoint product ( n : num ) ( m : num ) : num :=
      match m with
       | Zero => Zero
       | Succ n' => sum n (product n n')
      end.

Eval compute in (product (Succ (Succ Zero)) (Succ (Succ Zero))).

Fixpoint less ( n : num ) ( m : num ) : bool :=
      match n, m with
        | Zero, Zero => False
        | Zero, Succ n' => True
        | Succ n', Zero => False
        | Succ n', Succ m' => less n' m'
      end.

Eval compute in (less Zero (Succ Zero)).

Eval compute in (less (Succ Zero) Zero).

Fixpoint eq ( n : num ) ( m : num ) : bool :=
      match n, m with
        | Zero, Zero => True
        | Zero, Succ m' => False
        | Succ n', Zero => False
        | Succ n', Succ m' => eq n' m'
      end.

Eval compute in (eq Zero Zero).

Definition or ( a : bool ) ( b : bool ) : bool :=
       match a with
         | True => True
         | False => b
       end.

Eval compute in (or False True).
Eval compute in (or True False).

Definition and ( a : bool ) (b : bool) : bool :=
       match a with
         | True => b
         | False => False
       end.

Eval compute in (and False False).
Eval compute in (and True True).

Definition lesseq ( n : num ) ( m : num ) : bool :=
      or (less n m) (eq n m) .

Eval compute in (lesseq Zero Zero).

Definition not ( a : bool ) : bool :=
      match a with
        | True => False
        | False => True
      end.

Definition greater ( n : num ) ( m : num ) : bool :=
     not (lesseq n m).

Definition greatereq (n : num)  (m : num) : bool :=
     not (less n m).

Fixpoint subtract (n : num) (m : num) : num :=
     match n, m with
       | Zero, _ => Zero
       |  _ , Zero => n
       | Succ n' , Succ m' => subtract n' m'
     end.

Fixpoint factorial (n : num) :=
      match n with
       | Zero => Succ Zero
       | Succ n' => product n (factorial n')
      end.

Eval compute in (factorial (Succ (Succ (Succ Zero)))).

Theorem add_commutative : forall a b : nat , a + b = b + a.
Proof. admit. Qed.

Theorem multi_commutative : forall a b : nat, a * b = b * a.
Proof. admit. Qed.

Theorem add_identity : forall a : num, sum a Zero = a.
Proof. intros. reflexivity. Qed.

Theorem multi_identity : forall a : num, product a (Succ Zero) = a.
Proof. intros. reflexivity. Qed.

Example factorial_example : factorial (Succ Zero) = Succ Zero.
Proof. reflexivity. Qed.

Theorem theorem1 : forall a b c : nat, a = b -> b = c -> a + b = b +c .
Proof.  intros.  rewrite -> H. rewrite -> H0. reflexivity. Qed.

Theorem theorem2 : forall a b : nat, a = b + 1 -> a * ( b + 1 ) = a * a.
Proof. intros. rewrite <- H. reflexivity. Qed.

Theorem theorem3 : forall a b : nat, a = b + 1 -> a * ( 1 + b ) = a * a.
Proof. intros. rewrite -> H. rewrite add_commutative. reflexivity. Qed.

End Basic.


(* Level 0 data *)
(* name the `exact` tactic *)
(* tactics apply *)
(* available false *)
(* Level prologue *)
(*
Classically, you can think of a proposition to be a statement
that is True or False. In Homotopy Type Theory, this definition
is a bit more subtle, but instead of `Type`s we may use
`Prop`s. You can think of types `P : Prop` as propositions, and
elements `p : P` as proofs for the proposition `P`. In this case,
functions `P -> Q` become like implications, where we wish to produce
a proof of the proposition `Q` from a proof `p : P` of
the proposition `P`.

Remember our `exact` tactic. It works the same here as in the previous
world, so the proof of this lemma may seem familiar. If you forgot how
you proved this statement for `Type`s in Function World, feel free
to go back and look at your proof there!
*)
Example level0 (P Q : Prop) (p : P) (h : P -> Q) : Q.
Proof.
    exact (h p).
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 1 data *)
(* name the `intro` tactic *)
(* tactics apply *)
(* available false *)
(* Level 1 prologue *)
(*
Let's prove an implication. Like I said in the previous level,
they are kind of like functions, except on `Prop`ositions instead of
`Type`s. In the below lemma,
typing `intro p` will kind of be like saying "assume `P` holds".
It then remains to present some element of type `P`. But we have a proof
of `P`, namely `p`, which we introduced before. It should be enough to then
type `exact p`.

Try it out below!
*)
Lemma imp_self (P : Prop) : P -> P.
Proof.
    intro p.
    exact p.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 2 data *)
(* name the `specialize` tactic *)
(* tactics apply *)
(* available false *)
(* Level 2 prologue *)
(*
Like in function world, we can still use the `specialize` tactic
to make it easier to later `exact _` something of the right type.
Indeed, here we could type
```
exact (l(j(h(p))))
```
but you should try to use the `specialize` tactic to practice!
Remember, it should look something like
```
specialize (h p) as q.
```
*)
Lemma maze (P Q R S T U: Prop)
    (p : P)
    (h : P -> Q)
    (i : Q -> R)
    (j : Q -> T)
    (k : S -> T)
    (l : T -> U)
    : U.
Proof.
    remember (h p) as q.
    remember (j q : T) as t.
    (* what does eremember do vs remember? *)
    eremember (l(t)) as u.
    exact u.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 3 data *)
(* name the `apply` tactic *)
(* tactics apply *)
(* available false *)
(* Level 3 prologue *)
(*
Our hypotheses kind of became a mess on the previous level, so
we should try it again, but then using `apply`. Again, like in
Function world, this allows us to "reason backwards". Try
to `apply` the right functions to turn our goal into `P`,
so we can `exact p.` to finish it off.
*)
Lemma maze2 (P Q R S T U: Prop)
    (p : P)
    (h : P -> Q)
    (i : Q -> R)
    (j : Q -> T)
    (k : S -> T)
    (l : T -> U)
    : U.
Proof.
    apply l.
    apply j, h.
    exact p.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 4 data *)
(* name `P -> (Q -> P)` *)
(* tactics apply *)
(* available false *)
(* Level 4 prologue *)
(*
We want to show that `P -> (Q -> P)` where `P` and `Q` are propositions.
Think about our rule of thumb regarding functions/implications
and the `intro` tactic, and take a good look at our hypothesis
to see what we can `exact` or `apply` here.

Remember you can also use the `intros` tactic to repeatedly
introduce hypotheses?
*)
Example level4 (P Q : Prop) : P -> (Q -> P).
Proof.
    intros p q.
    exact p.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 5 data *)
(* name `(P -> (Q -> R)) -> ((P -> Q) -> (P -> R))` *)
(* tactics apply *)
(* available false *)
(* Level 5 prologue *)
(*
You can solve this level completely with `intro`, `apply` and `exact`.
However, it may happen that `apply`ing a function of type `P -> Q -> R`
produces two subgoals. If you're proving it this way, remember to use
dashes (these: `-`) to specifiy that you're working in a subgoal!
*)
Example level5 (P Q R : Prop) : (P -> (Q -> R)) -> ((P -> Q) -> (P -> R)).
Proof.
    intros j f p.
    apply j.
    - exact p.
    - exact (f p).
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 6 data *)
(* name `(P -> Q) -> ((Q -> R) -> (P -> R))` *)
(* tactics apply *)
(* available false *)
(* Level 6 prologue *)
(*
In Function World, this level did not really mean much, but
thinking of `->` as implication, this level really shows
the transitivity of implications!
*)
Lemma imp_trans (P Q R : Type) : (P -> Q) -> ((Q -> R) -> (P -> R)).
Proof.
    intros f g h.
    apply g, f.
    exact h.
Qed.
(* Level epilogue *)
(* Level end *)

Lemma not_iff_impl_false (P : Prop) : ~ P <-> (P -> False).
Proof.
    unfold not.
    split.
    - trivial.
    - trivial.
Qed.

Require Setoid.

(* Level 7 data *)
(* name `(P -> Q) -> (~Q -> ~P)` *)
(* tactics unfold *)
(* available false *)
(* Level 7 prologue *)
(*
There is a `False` `Prop`osition, with no proofs (kind of
like the empty type, with no inhabitants). We can use this
to define "negation" of a proposition (i.e. `~Q`). In reality,
we have that `~Q` is the same as `Q -> False`.

I have added a lemma
```
#Lemma not_iff_impl_false (P : Prop) : ~ P <-> (P -> False).
```
for you to use in this level. Use it to
```
repeat rewrite not_iff_impl_false.
```
in this level to get rid of the `~`.

Later on, it might be easier to use Coq's own way of doing
this, by writing
```unfold not```
which basically `unfold`s the definition of `not`
(the `~` operator).

Try either of these ways in the proof below!
*)
Lemma contrapositive (P Q : Prop) : (P -> Q) -> (~Q -> ~P).
Proof.
    (* requires Setoid *)
    repeat rewrite not_iff_impl_false.
    intros f g p.
    exact (g (f p)).
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 8 data *)
(* name a big maze *)
(* tactics unfold *)
(* available false *)
(* Level 8 prologue *)
(*
Try to solve the maze below using the tactics you have
learnt in Proposition World and Function World!
*)
Example level8 (A B C D E F G H I J K L : Prop)
    (f1 : A -> B) (f2 : B -> E) (f3 : E -> D) (f4 : D -> A) (f5 : E -> F)
    (f6 : F -> C) (f7 : B -> C) (f8 : F -> G) (f9 : G -> J) (f10 : I -> J)
    (f11 : J -> I) (f12 : I -> H) (f13 : E -> H) (f14 : H -> K) (f15 : I -> L)
: A -> L.
Proof.
    intro a.
    now apply f15, f11, f9, f8, f5, f2, f1.
Qed.
(* Level epilogue *)
(* Level end *)


Require Import
  Coq.NArith.NArith MathClasses.implementations.peano_naturals MathClasses.theory.naturals
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.naturals MathClasses.interfaces.orders
  MathClasses.interfaces.additional_operations.

(* canonical names for relations/operations/constants: *)
Instance N_equiv : Equiv N := eq.
Instance N_0 : Zero N := 0%N.
Instance N_1 : One N := 1%N.
Instance N_plus : Plus N := Nplus.
Instance N_mult : Mult N := Nmult.

(* properties: *)
Instance: SemiRing N.
Proof.
  repeat (split; try apply _); repeat intro.
         now apply Nplus_assoc.
        now apply Nplus_0_r.
       now apply Nplus_comm.
      now apply Nmult_assoc.
     now apply Nmult_1_l.
    now apply Nmult_1_r.
   now apply Nmult_comm.
  now apply Nmult_plus_distr_l.
Qed.

Instance: ∀ x y : N, Decision (x = y) := N_eq_dec.

Instance inject_nat_N: Cast nat N := N_of_nat.
Instance inject_N_nat: Cast N nat := nat_of_N.

Instance: SemiRing_Morphism nat_of_N.
Proof.
  repeat (split; try apply _); repeat intro.
   now apply nat_of_Nplus.
  now apply nat_of_Nmult.
Qed.

Instance: Inverse nat_of_N := N_of_nat.

Instance: Surjective nat_of_N.
Proof. constructor. intros x y E. rewrite <- E. now apply nat_of_N_of_nat. now apply _. Qed.

Instance: Injective nat_of_N.
Proof. constructor. exact nat_of_N_inj. apply _. Qed.

Instance: Bijective nat_of_N := {}.

Instance: Inverse N_of_nat := nat_of_N.

Instance: Bijective N_of_nat.
Proof. apply jections.flip_bijection. Qed.

Instance: SemiRing_Morphism N_of_nat.
Proof. change (SemiRing_Morphism (nat_of_N⁻¹)). split; apply _. Qed.

Instance: NaturalsToSemiRing N := retract_is_nat_to_sr N_of_nat.
Instance: Naturals N := retract_is_nat N_of_nat.

(* order *)
Instance N_le: Le N := Nle.
Instance N_lt: Lt N := Nlt.

Instance: FullPseudoSemiRingOrder N_le N_lt.
Proof.
  assert (PartialOrder N_le).
   repeat (split; try apply _). exact N.le_antisymm.
  assert (SemiRingOrder N_le).
   split; try apply _.
     intros x y E. exists (Nminus y x).
     symmetry. rewrite commutativity. now apply N.sub_add.
    repeat (split; try apply _); intros.
     now apply N.add_le_mono_l.
    eapply N.add_le_mono_l. eassumption.
   intros. now apply Nle_0.
  assert (TotalRelation N_le).
   intros x y. now apply N.le_ge_cases.
  rapply semirings.dec_full_pseudo_srorder.
  split.
   intro. now apply N.le_neq.
  intros [E1 E2]. now apply N.Private_Tac.le_neq_lt.
Qed.

Program Instance: ∀ x y: N, Decision (x ≤ y) := λ y x,
  match Ncompare y x with
  | Gt => right _
  | _ => left _
  end.
Next Obligation. now apply not_symmetry. Qed.

Instance N_cut_minus: CutMinus N := Nminus.
Instance: CutMinusSpec N _.
Proof.
  split; try apply _.
   intros. now apply N.sub_add.
  intros. now apply Nminus_N0_Nle.
Qed.


Require Import Vector Arith Bool List Nat.

(** Remove the following axiom when you've finished all the exercises. This
axoim provides a value of any type to allow the file to compile and incomplete
expressions to be used.
 *)
Axiom fill_me : forall {X : Type}, X.

(** Definitions used in the exercises **)

Definition leq : nat -> nat -> Prop :=
  fun m n => exists k, k + m = n.

Definition Even : nat -> Prop :=
  fun n => exists k, n = 2 * k.

Definition Odd : nat -> Prop :=
  fun n => exists k, n = 2 * k + 1.

(** Exercise 2.1
Prove that filtering a list results in a list with length less than or equal to the length of the original list.
 *)

Theorem length_filter_list : forall A (l : list A) (p : A -> bool), leq (length (filter p l)) (length l).
Proof.
  exact fill_me.
Qed.

(** Exercise 2.2
Prove that less-than-or-equal is transitive.
 *)
Theorem leq_transitive : forall a b c, leq a b -> leq b c -> leq a c.
Proof.
  exact fill_me.
Qed.

(** Exercise 2.3
Prove that less-than-or-equal to is anti-symmetric.
 *)

Theorem leq_antisymmetry : forall a b: nat, leq a b -> leq b a -> a = b.
Proof.
  exact fill_me.
Qed.

(** Hint: The following lemmas may be useful *)

Lemma inj_plus : forall k a: nat, k + a = a -> k = 0.
Proof.
  exact fill_me.
Qed.

Lemma sum_to_zero : forall n m, n + m = 0 -> m = 0.
Proof.
  exact fill_me.
Qed.

(** Exercise 2.4
Prove for all numbers a and b that either a is less-than-or-equal to b or
      b is less than equal to a.
 *)
Theorem either_a_leq_b_or_b_leq_a : forall a b, leq a b \/ leq b a.
Proof.
  exact fill_me.
Qed.

(** Exercise 2.5
Prove that the sum of two even numbers is even.
 *)

Theorem sum_of_two_evens_is_even : forall n m, Even n -> Even m -> Even (n + m).
Proof.
  exact fill_me.
Qed.

(** Exercise 2.6
Prove that the sum of two odd numbers is even.
 *)

Theorem sum_of_two_odds_is_even : forall n m, Odd n -> Odd m -> Even (n + m).
Proof.
  exact fill_me.
Qed.

(** Exercise 2.7
Prove that either n or its succesor is even.
 *)

Theorem either_n_or_succ_n_is_even : forall n, Even n \/ Even (S n).
Proof.
  exact fill_me.
Qed.

(** Exercise 2.8
Prove that all numbers are either even or odd.
 *)

Theorem even_or_odd : forall n, Even n \/ Odd n.
Proof.
  exact fill_me.
Qed.


Require Import List.
Require Import Coq.Logic.Decidable.
Import ListNotations.

Require Import CpdtTactics.

Require Import Equality.

Local Hint Unfold decidable.
Hint Constructors or.

Definition splits_into {A : Type} (l l1 l2 : list A) : Prop :=
  l = l1 ++ l2.

Definition is_prefix_of {A : Type} (p s : list A) : Prop :=
  exists s', splits_into s p s'.

(**
 * We give an inductive definition of being a prefix since proofs
 * work better with those. However, [is_prefix_of] is more straigtforward,
 * and probably easier to work with.
 *)
Inductive IsPrefix {A : Type} : list A -> list A -> Prop :=
  | prefix_nil : forall l, IsPrefix [] l
  | prefix_cons : forall a p l, IsPrefix p l -> IsPrefix (a :: p) (a :: l).

Hint Unfold is_prefix_of splits_into.
Local Hint Constructors IsPrefix.

Lemma splits_into_cons {A : Type} :
  forall (a : A) l l1 l2, splits_into (a :: l) l1 l2 ->
    (exists l1', l1 = a :: l1') \/ (l1 = [] /\ exists l2', l2 = a :: l2').
Proof.
  intros a l l1 l2 H.
  destruct l1.
  - right; split; auto.
    destruct l2; try solve [inversion H].
    inversion H; subst.
    exists l2; auto.
  - left.
    inversion H; subst.
    exists l1; auto.
Qed.

(**
 * Let's show that the two definitions of prefix are equivalent.
 *)
Lemma is_prefix_of_iff_IsPrefix {A : Type} :
  forall p s, @is_prefix_of A p s <-> IsPrefix p s.
Proof.
  intros p s; split; revert s.
  - induction p; intros s H.
    + auto.
    + inversion H as [s' Heq]; clear H.
      unfold splits_into in Heq. subst.
      simpl; constructor.
      apply IHp; clear IHp.
      exists s'; auto.
  - induction p; intros s H.
    + exists s; auto.
    + inversion H; subst; clear H.
      destruct (IHp l H3) as [l' Heq]; clear H3 IHp.
      exists l'. crush.
Qed.

Theorem IsPrefix_decidable {A : Type} :
  eq_decidable A -> forall p s, decidable (@IsPrefix A p s).
Proof.
  Ltac impossible :=
    solve [right; intro HContra; inversion HContra; contradiction].

  intros eq_dec p.
  induction p; intros s.
  - crush.
  - destruct s; try impossible.
    destruct (eq_dec a a0); destruct (IHp s); subst; try impossible; crush.
Qed.

Lemma IsPrefix_app {A : Type} :
  forall e p s, @IsPrefix A p s <-> IsPrefix (e ++ p) (e ++ s).
Proof.
  intros e p s; split; intro H.
  - induction e; crush.
  - induction e.
    + apply H.
    + apply IHe; clear IHe.
      inversion H; auto.
Qed.

Lemma mutual_prefix_implies_eq {A : Type} :
  forall (p1 p2 : list A),
    is_prefix_of p1 p2 ->
    is_prefix_of p2 p1 ->
    p1 = p2.
Proof.
  intros p1 p2 Hprefix1 Hprefix2.
  destruct Hprefix1 as [p2' Heq_p2].
  destruct Hprefix2 as [p1' Heq_p1].
  unfold splits_into in *. subst p2.
  rename Heq_p1 into H.
  rewrite <- app_nil_r in H at 1.
  rewrite <- app_assoc in H.
  apply app_inv_head in H.
  symmetry in H.
  apply app_eq_nil in H.
  destruct H; subst.
  rewrite app_nil_r.
  reflexivity.
Qed.

Definition partitions_into {A : Type} (l : list A) (ls : list (list A)) :=
  l = concat ls.

Hint Unfold partitions_into.

Lemma empty_list_partitions_into_empty_lists {A : Type} :
  forall (ps : list (list A)),
    partitions_into [] ps -> Forall (fun p => p = []) ps.
Proof.
  Hint Constructors Forall.
  induction ps as [ | p ps]; intro H; auto.
  destruct p as [ | a p].
  + crush.
  + inversion H.
Qed.

(* TODO
Theorem empty_partitions_are_irrelevant {A : Type} :
  forall (l : list A) (ps : list (list A)),
    partitions_into l ps <-> partitions_into l (filter (fun p => p <> []) ps).
*)

Lemma partitions_are_prefixes {A : Type} :
  forall (p l : list A) (ps : list (list A)),
    partitions_into l (p :: ps) -> is_prefix_of p l.
Proof.
  intros p l ps H.
  unfold partitions_into in H.
  exists (concat ps).
  auto.
Qed.

(**
 * We say that there is a break between [l1] and [l2] according to
 * [ps] (which is meant to be a partitioning of [l1 ++ l2]) if [ps]
 * can be split into two pieces, one partitioning [l1] and the other
 * partitioning [l2].
 *)
Definition break_between {A : Type} (l1 l2 : list A) (ps : list (list A)) :=
  exists (ps1 ps2 : list (list A)),
    splits_into ps ps1 ps2 /\
    partitions_into l1 ps1 /\
    partitions_into l2 ps2.

Lemma break_between_implies_partition {A : Type} :
  forall (l1 l2 : list A) (ps : list (list A)),
    break_between l1 l2 ps -> partitions_into (l1 ++ l2) ps.
Proof.
  intros l1 l2 ps H.
  inversion H as [ps1 [ps2 [Hsplit [Heqps1 Heqps2]]]].
  unfold partitions_into in *.
  subst l1 l2.
  rewrite Hsplit.
  rewrite concat_app.
  reflexivity.
Qed.

Lemma break_between_cons {A : Type} :
  forall (a l1 l2 : list A) (ps : list (list A)),
    break_between l1 l2 ps <-> break_between (a ++ l1) l2 (a :: ps).
Proof.
  intros a l1 l2 ps; split; intro H.
  - inversion_clear H as [ps1 [ps2 [Hsplit [Heqps1 Heqps2]]]].
    exists (a :: ps1); exists ps2.
    crush.
  - inversion_clear H as [ps1 [ps2 [Hsplit [Heqps1 Heqps2]]]].
    apply splits_into_cons in Hsplit as Hbreak.
    destruct Hbreak as [H | [Heq H]].
    + destruct H as [ps1' H]; subst.
      exists ps1', ps2; repeat split; auto.
      * inversion Hsplit; auto.
      * unfold partitions_into in Heqps1; simpl in Heqps1.
        apply app_inv_head in Heqps1.
        auto.
    + subst.
      apply app_eq_nil in Heqps1; destruct Heqps1; subst.
      inversion_clear H as [ps2' Heqps2']; subst.
      inversion Hsplit; subst.
      exists [], ps2'; crush.
Qed.

Lemma break_between_nil_cons {A : Type} :
  forall (a l2 : list A) (ps : list (list A)),
    break_between [] l2 ps <-> break_between [] (a ++ l2) (a :: ps).
Proof.
  intros a l2 ps; split; intro H.
  - inversion_clear H as [ps1 [ps2 [Hsplit [Heqps1 Heqps2]]]].
    exists []; exists (a :: ps1 ++ ps2); crush.
    unfold partitions_into in *; simpl.
    rewrite concat_app.
    rewrite <- Heqps1.
    rewrite app_nil_l.
    reflexivity.
  - inversion_clear H as [ps1 [ps2 [Hsplit [Heqps1 Heqps2]]]].
    apply splits_into_cons in Hsplit as Hbreak.
    destruct Hbreak as [H | [Heq H]]; subst.
    + destruct a.
      * destruct H as [ps1' Hbreak_ps1]; subst.
        inversion Hsplit.
        exists ps1', ps2; crush.
      * destruct H as [ps1' Hbreak_ps1]; subst.
        inversion Heqps1.
    + destruct H as [ps2' Hsplit_ps2]; subst.
      inversion_clear Hsplit; subst.
      exists [], ps2'; crush.
      unfold partitions_into in *; simpl in Heqps2.
      apply app_inv_head in Heqps2.
      assumption.
Qed.

(**
 * We can decide if there is a break between two list chunks.
 *)
Theorem break_between_decidable {A : Type} :
  eq_decidable A ->
    forall (l1 l2 : list A) (ps : list (list A)),
      decidable (break_between l1 l2 ps).
Proof.
  Ltac impossible_break :=
    solve [
      right;
      intro HContra;
      inversion HContra as [ps1 [ps2 [Hsplit [Hp1 Hp2]]]];
      inversion Hsplit as [Heq];
      symmetry in Heq;
      apply app_eq_nil in Heq; destruct Heq; subst;
      try (solve [inversion Hp1]);
      try (solve [inversion Hp2])
    ].

  intro eq_dec.
  intros l1 l2 ps; revert l1 l2.
  induction ps; intros l1 l2.
  - destruct l1; destruct l2; try impossible_break.
    + left; exists []; exists []; crush.
  - destruct (IsPrefix_decidable eq_dec a l1) as [Hprefix1 | Hprefix1].
    + apply is_prefix_of_iff_IsPrefix in Hprefix1.
      inversion_clear Hprefix1 as [l1' Heql1]; unfold splits_into in Heql1; subst.
      apply (decidable_equivalent (break_between_cons a l1' l2 ps)).
      apply IHps.
    + destruct l1 as [ | x l1'].
      -- destruct (IsPrefix_decidable eq_dec a l2) as [Hprefix2 | Hprefix2].
         ++ apply is_prefix_of_iff_IsPrefix in Hprefix2.
            inversion_clear Hprefix2 as [l2' Heql2].
            unfold splits_into in Heql2; subst.
            apply (decidable_equivalent (break_between_nil_cons a l2' ps)).
            apply IHps.
         ++ right; intro HContra.
            inversion_clear HContra as [ps1 [ps2 [Hsplit [Heqps1 Heqps2]]]].
            apply splits_into_cons in Hsplit as Hbreak.
            destruct Hbreak as [H | [Heq H]]; subst.
            * apply Hprefix1.
              apply is_prefix_of_iff_IsPrefix.
              destruct H as [ps1' Hbreak_ps1]; subst.
              apply partitions_are_prefixes in Heqps1.
              assumption.
            * apply Hprefix2.
              apply is_prefix_of_iff_IsPrefix.
              destruct H as [ps12' Hbreak_ps2]; subst.
              apply partitions_are_prefixes in Heqps2.
              assumption.
      -- right; intro HContra.
         inversion_clear HContra as [ps1 [ps2 [Hsplit [Heqps1 Heqps2]]]].
         apply splits_into_cons in Hsplit as Hbreak.
         destruct Hbreak as [H | [Heq H]]; subst.
         * destruct H as [ps1' Hbreak_ps1]; subst.
           apply Hprefix1.
           apply is_prefix_of_iff_IsPrefix.
           apply partitions_are_prefixes in Heqps1.
           assumption.
         * inversion Heqps1.
Qed.

Lemma empty_partition_only_breaks_empty_list {A : Type} :
  forall (s1 s2 : list A),
    break_between s1 s2 [] -> s1 = [] /\ s2 = [].
Proof.
  intros s1 s2 Hbreak.
  inversion Hbreak as [ps1 [ps2 [Hsplit [Heq_ps1 Heq_ps2]]]].
  unfold splits_into in Hsplit.
  symmetry in Hsplit; apply app_eq_nil in Hsplit as [Hnil_ps1 Hnil_ps2]; subst.
  crush.
Qed.

Lemma concat_app_prefix {A : Type} :
  forall (l1 l23 l12 l3 : list (list A)),
    l1 ++ l23 = l12 ++ l3 ->
    Forall (fun p => p <> []) l1 ->
    is_prefix_of (concat l1) (concat l12) ->
    is_prefix_of l1 l12.
Proof.
  induction l1 as [ | p l1]; intros l23 l12 l3 Heq Hneq_l1 Hprefix.
  - exists l12; auto.
  - destruct l12 as [ | p' l12].
    + destruct Hprefix as [Hl2' Heq_l2'].
      unfold splits_into in Heq_l2'; symmetry in Heq_l2'.
      apply app_eq_nil in Heq_l2' as [Hempty_l1 _].
      simpl in Hempty_l1.
      apply app_eq_nil in Hempty_l1 as [Hempty_p _].
      apply Forall_inv in Hneq_l1.
      contradiction.
    + inversion Heq; subst.

      apply is_prefix_of_iff_IsPrefix in Hprefix.
      simpl in Hprefix.
      apply IsPrefix_app in Hprefix.
      apply is_prefix_of_iff_IsPrefix in Hprefix.
      inversion_clear Hneq_l1.
      specialize (IHl1 l23 l12 l3 H1 H0 Hprefix).

      apply is_prefix_of_iff_IsPrefix.
      apply is_prefix_of_iff_IsPrefix in IHl1.
      apply IsPrefix_app with (e := [p']) in IHl1.
      assumption.
Qed.

Lemma concat_app_eq {A : Type} :
  forall (l1 l2 l1' l2' : list (list A)),
    l1 ++ l2 = l1' ++ l2' ->
    Forall (fun p => p <> []) l1 ->
    Forall (fun p => p <> []) l1' ->
    concat l1 = concat l1' ->
    l1 = l1'.
Proof.
  intros l1 l2 l1' l2' Heq Hno_empty_l1 Hno_empty_l1' Hconcat.
  assert (is_prefix_of l1 l1').
  + apply (concat_app_prefix l1 l2 l1' l2'); auto.
    - exists []; crush.
  + inversion H as [l1'' Heq_l1''].
    unfold splits_into in Heq_l1''; subst.
    replace l1'' with ([] : list (list A)).
    - symmetry; apply app_nil_r.
    - rewrite concat_app in Hconcat.
      rewrite <- app_nil_r in Hconcat at 1.
      apply app_inv_head in Hconcat.
      apply empty_list_partitions_into_empty_lists in Hconcat.
      destruct l1''; auto.
      exfalso.
      apply Forall_app in Hno_empty_l1'.
      destruct Hno_empty_l1' as [_ Hno_empty_l1''].
      apply Forall_inv in Hno_empty_l1''.
      apply Forall_inv in Hconcat.
      contradiction.
Qed.

Theorem break_of_break {A : Type} :
  forall (l1 l2 l3 : list A) (ps : list (list A)),
    Forall (fun p => p <> []) ps -> (* TODO: remove this requirement *)
    break_between (l1 ++ l2) l3 ps ->
    break_between l1 (l2 ++ l3) ps ->
    exists p1 p2 p3,
      ps = p1 ++ p2 ++ p3 /\
      partitions_into l1 p1 /\
      partitions_into l2 p2 /\
      partitions_into l3 p3.
Proof.
  intros l1 l2 l3 ps Hno_empty Hbreak23 Hbreak12.
  inversion_clear Hbreak23 as [p12 [p3 [Hsplit23 [Heq_p12 Heq_p3]]]].
  inversion_clear Hbreak12 as [p1 [p23 [Hsplit12 [Heq_p1 Heq_p23]]]].
  assert (Hprefix_l1 : is_prefix_of p1 p12).
  + apply (concat_app_prefix p1 p23 p12 p3).
    - crush.
    - unfold splits_into in Hsplit12; subst.
      apply Forall_app in Hno_empty.
      apply Hno_empty.
    - exists l2; crush.
  + inversion Hprefix_l1 as [p2 Heq_p2].
    exists p1, p2, p3; repeat split.
    - unfold splits_into in *; crush.
    - assumption.
    - unfold partitions_into in *; subst.
      unfold splits_into in Heq_p2; subst.
      rewrite concat_app in Heq_p12.
      apply app_inv_head in Heq_p12.
      assumption.
    - assumption.
Qed.

Lemma break_between_cons_prefix {A : Type} :
  forall (l1 l2 p : list A) (ps : list (list A)),
    l1 <> [] ->
    break_between l1 l2 (p :: ps) ->
    is_prefix_of p l1.
Admitted.

Local Lemma break_between_obvious {A : Type} :
  forall (p : list A) (ps : list (list A)),
    break_between p (concat ps) (p :: ps).
Proof.
  intros p ps.
  exists [p], ps; repeat split; auto.
  unfold partitions_into; simpl.
  rewrite app_nil_r.
  reflexivity.
Qed.

(**
 * Two partitionings are the same if and only if they
 * induce the same breaks (modulo empty partitions). This
 * gives us a nice way to characterize partitions.
 *)
Lemma breaks_eq_implies_partitions_eq {A : Type} :
  forall (ps1 ps2 : list (list A)),
  Forall (fun p => p <> []) ps1 ->
  Forall (fun p => p <> []) ps2 ->
  (forall (s1 s2 : list A),
     break_between s1 s2 ps1 <-> break_between s1 s2 ps2) ->
  ps1 = ps2.
Proof.
  induction ps1 as [ | p1 ps1]; intros ps2 Hno_empty_ps1 Hno_empty_ps2 Hsame_breaks.
  - destruct ps2 as [ | p2 ps2].
    + reflexivity.
    + inversion_clear Hno_empty_ps2.
      contradict H.
      apply (empty_partition_only_breaks_empty_list p2 (concat ps2)).
      apply Hsame_breaks.
      exists [p2], ps2; crush.
      unfold partitions_into; simpl.
      rewrite app_nil_r.
      reflexivity.

  - destruct ps2 as [| p2 ps2].
    + inversion_clear Hno_empty_ps1.
      contradict H.
      apply (empty_partition_only_breaks_empty_list p1 (concat ps1)).
      apply Hsame_breaks.
      apply break_between_obvious.
    + replace p2 with p1 in *.
      * replace ps2 with ps1; auto.
        apply IHps1.
        -- inversion_clear Hno_empty_ps1; assumption.
        -- inversion_clear Hno_empty_ps2; assumption.
        -- intros s1 s2; split; intro H;
             apply break_between_cons with (a := p1);
             apply Hsame_breaks;
             apply break_between_cons;
             assumption.
      * apply mutual_prefix_implies_eq.
        -- apply break_between_cons_prefix with (l2 := concat ps2) (ps := ps1).
           ** inversion Hno_empty_ps2; assumption.
           ** apply Hsame_breaks.
              apply break_between_obvious.
        -- apply break_between_cons_prefix with (l2 := concat ps1) (ps := ps2).
           ** inversion Hno_empty_ps1; assumption.
           ** apply Hsame_breaks.
              apply break_between_obvious.
Qed.

(* TODO: this might be useful *)
(*
Lemma non_empty_breaks_are_unique {A : Type} :
  forall (s1 s2 : list A) (ps : list (list A)) (cs1 cs2 cs1' cs2' : list (list A)),
    Forall (fun p => p <> []) ps ->
    splits_into ps cs1 cs2 ->
    partitions_into s1 cs1 ->
    partitions_into s2 cs2 ->
    splits_into ps cs1' cs2' ->
    partitions_into s1 cs1' ->
    partitions_into s2 cs2' ->
    cs1 = cs1' /\ cs2 = cs2'.
Proof.
  intros s1 s2 ps cs1 cs2 cs1' cs2' Hno_empty Hsplit Hp_cs1 Hp_cs2 Hsplit' Hp_cs1' Hp_cs2'.
  assert (cs1 = cs1').
  - induction cs1 as [_ | p cs1]; destruct cs1' as [_ | p' cs1']; auto.
    + unfold partitions_into in Hp_cs1; subst.
      simpl in Hp_cs1'.
      apply empty_list_partitions_into_empty_lists in Hp_cs1' as HContra.
      apply Forall_inv in HContra.
      contradict HContra.
      unfold splits_into in Hsplit'; subst.
      apply Forall_inv in Hno_empty.
      assumption.
    + unfold partitions_into in Hp_cs1'; subst.
      simpl in Hp_cs1.
      apply empty_list_partitions_into_empty_lists in Hp_cs1 as HContra.
      apply Forall_inv in HContra.
      contradict HContra.
      unfold splits_into in Hsplit; subst.
      apply Forall_inv in Hno_empty.
      assumption.
    + admit.

  - subst cs1; split; auto.
    unfold splits_into in *.
    rewrite Hsplit' in Hsplit.
    apply app_inv_head in Hsplit.
    symmetry; assumption.
Admitted.

*)

(* TODO: generalize breaks to multiple breaks.

(**
 * Given two partitionings [c, g], we say that [g] is more _granular_
 * than [c] (or [g] is a sub partition of [c]) if every "break" in [c]
 * also exists in [g].
 *)
Inductive IsSubPartition {A : Type} : list (list A) -> list (list A) -> Prop :=
  | sub_partition_nil : IsSubPartition [] []
  | sub_partition_empty : forall c g, IsSubPartition c g -> IsSubPartition c ([] :: g)
  | sub_partition_head : forall c g, forall hc hg rg,
    splits_into hg hc rg -> IsSubPartition c (rg :: g) -> IsSubPartition (hc :: c) (hg :: g).

Theorem IsSubPartition_decidable {A : Type} :
  forall c g, decidable (@IsSubPartition A c g).
Admitted.

Lemma partition_split_decidable {A : Type} :
  forall (l1 l2 : list A) (ps : list (list A)),
    decidable (
      exists (ps1 ps2 : list (list A)),
        splits_into ps ps1 ps2 /\
        partitions_into l1 ps1 /\
        partitions_into l2 ps2).
Proof.
  intros l1 l2 ps.
  destruct (IsSubPartition_decidable [l1; l2] ps).
*)


Require Import Arith List.
Require Import Recdef.

Fixpoint select_min (x: nat) (l: list nat) : nat * list nat :=
  match l with
  | nil => (x,l)
  | h :: tl => if (le_lt_dec x h) then
                 let (m,l') := select_min x tl in
                 (m, h::l')
                   else
                     let (m,l') := select_min h tl in
                     (m, x::l')
  end.

Compute (select_min 2 (1::nil)).
Compute (select_min 2 (1::2::3::0::1::nil)).

Lemma select_min_length: forall l l' x y, select_min x l = (y, l') -> length l = length l'.
Proof.
  induction l.
  - simpl.
    intros l x y H.
    inversion H; subst.
    reflexivity.
  - intros l' x y.
    assert (H: select_min x l = (y, l') -> length l = length l').
        {
          apply IHl.
          }
        generalize dependent y.
        generalize dependent x.
        induction l'.
    + intros x y IH H.
      simpl in H.
      destruct (le_lt_dec x a).
      * destruct (select_min x l).
        inversion H.
      * destruct (select_min a l).
        inversion H.
    + intros x y IH H.
      simpl in H.
      destruct (le_lt_dec x a).
      * simpl. apply f_equal.
        apply IHl with x y.
        destruct (select_min x l).
        inversion H; subst.
        reflexivity.
      * simpl. apply f_equal.
        apply IHl with a y.
        destruct (select_min a l).
        inversion H; subst.
        reflexivity.
Qed.

Function select (l: list nat) {measure length} : list nat :=
  match l with
  | nil => l
  | h :: tl =>
    let (m,l') := select_min h tl in
    (m :: (select l'))
  end.
Proof.
  intros.
  apply select_min_length in teq0.
  rewrite <- teq0.
  simpl.
  apply lt_n_Sn.
Qed.

Inductive ordenada : list nat -> Prop :=
  | lista_vazia : ordenada nil
  | lista_1: forall n : nat, ordenada (cons n nil)
  | lista_nv : forall (x y : nat) (l : list nat), ordenada (cons y l) -> x <= y -> ordenada (cons x (cons y l)).

Lemma ordenada_sub: forall l n, ordenada (n :: l) -> ordenada l.
Proof.
  induction l.
  - intros n H.
    apply lista_vazia.
  - intros n' Hcons.
    inversion Hcons. subst.
    assumption.
Qed.

Fixpoint num_oc n l :=
  match l with
    | nil => 0
    | cons h tl =>
      match eq_nat_dec n h with
        | left _ => S(num_oc n tl)
        | right _ => num_oc n tl
      end
  end.

Definition equiv l l' := forall n:nat, num_oc n l = num_oc n l'.

Lemma equiv_trans: forall l l' l'', equiv l l' -> equiv l' l'' -> equiv l l''.
Proof.
  intros l l' l'' H H'.
  unfold equiv in *.
  intro n.
  apply eq_trans with (num_oc n l').
  apply H.
  apply H'.
Qed.

Lemma equiv_cons: forall l l' a, equiv l l' -> equiv (a::l) (a::l').
Proof.
  intros l l' n H.
  unfold equiv in *.
  intros n'.
  simpl.
  destruct (Nat.eq_dec n' n).
  - apply f_equal.
    apply H.
  - apply H.
Qed.

Lemma equiv_cons_comm: forall l l' x z, equiv l l' -> equiv (z :: x :: l) (x :: z :: l').
Proof.
  intros l l' x z H.
  unfold equiv in *.
  intro n. simpl.
  destruct (Nat.eq_dec n z).
  - destruct (Nat.eq_dec n x).
    + apply f_equal. apply f_equal.
      apply H.
    + apply f_equal.
      apply H.
  - destruct (Nat.eq_dec n x).
    + apply f_equal.
      apply H.
    + apply H.
Qed.

Lemma equiv_cons_cons: forall l l' x y z, equiv (x :: l) (y :: l') -> equiv (x :: z :: l) (y :: z :: l').
Proof.
  intros l l' x y z H.
  assert (H': equiv (z :: x :: l) (z :: y :: l')).
  {
    apply equiv_cons; assumption.
  }
  apply equiv_trans with (z :: x :: l).
  - apply equiv_cons_comm.
    unfold equiv; reflexivity.
  - apply equiv_trans with (z :: y :: l').
    + assumption.
    + apply equiv_cons_comm.
      unfold equiv; reflexivity.
Qed.

Lemma select_min_cons_le: forall l l' x y a, select_min x (a::l) = (y,a::l') -> x <= a -> select_min x l = (y,l').
Proof.
  intros l l' x y a H H'.
  simpl in H.
  destruct (le_lt_dec x a).
  - destruct (select_min x l).
    inversion H; subst.
    reflexivity.
  - destruct (select_min a l).
    apply le_not_lt in H'.
    contradiction.
Qed.

Lemma select_min_cons_lt: forall l l' x y a, select_min x (a::l) = (y,x::l') -> a < x -> select_min a l = (y,l').
Proof.
  intros l l' x y a H H'.
  simpl in H.
  destruct (le_lt_dec x a).
  - destruct (select_min x l).
    apply le_not_lt in l0.
    contradiction.
  - destruct (select_min a l).
    inversion H; subst.
    reflexivity.
Qed.

Lemma select_min_equiv: forall l l' x y, select_min x l = (y, l') -> equiv (x::l) (y::l').
Proof.
  induction l.
  - intros l x y H.
    simpl in H.
    inversion H; subst.
    unfold equiv; reflexivity.
  - intros l' x y. case l'.
    + simpl. intro H.
      destruct (le_lt_dec x a).
      * destruct (select_min x l).
        inversion H.
      * destruct (select_min a l).
        inversion H.
    + intros n l'' H.
      assert (H' := H).
      simpl in H.
      destruct (le_lt_dec x a).
      * destruct (select_min x l).
        inversion H; subst.
        apply equiv_cons_cons.
        clear H.
        apply IHl.
        apply select_min_cons_le in H'.
        ** assumption.
        ** assumption.
      * destruct (select_min a l).
        inversion H; subst.
        apply equiv_trans with (a :: n :: l).
        ** apply equiv_cons_comm.
           unfold equiv; reflexivity.
        ** apply equiv_cons_cons.
           apply IHl.
           apply select_min_cons_lt with n; assumption.
Qed.

Theorem selectionSort_equiv: forall l, equiv l (select l).
Proof.
  intro l.
  functional induction (select l).
  - unfold equiv.
    reflexivity.
  - unfold equiv in *.
    intro n.
    simpl.
    destruct (Nat.eq_dec n h).
    + destruct (Nat.eq_dec n m).
      * apply f_equal.
        apply select_min_equiv in e0.
        subst.
        unfold equiv in e0.
        apply eq_trans with (num_oc m l').
        assert (H: num_oc m (m :: tl) = num_oc m (m :: l')).
        {
          apply e0.
        }
        simpl in H.
        destruct (Nat.eq_dec m m).
        ** inversion H; subst.
           reflexivity.
        ** apply False_ind.
           apply n; reflexivity.
        ** apply IHl0.
      * apply select_min_equiv in e0.
        unfold equiv in e0.
        assert (H: num_oc n (h :: tl) = num_oc n (m :: l')).
        { apply e0. }
        clear e0.
        simpl in H.
        subst.
        destruct (Nat.eq_dec h h).
        ** destruct (Nat.eq_dec h m).
           *** contradiction.
           *** rewrite H.
               apply IHl0.
        ** destruct (Nat.eq_dec h m).
           *** contradiction.
           *** apply False_ind.
               apply n; reflexivity.
    + destruct (Nat.eq_dec n m).
      * subst.
        apply select_min_equiv in e0.
        unfold equiv in e0.
        assert (H := e0 m).
        simpl in H.
        destruct (Nat.eq_dec m h).
        ** destruct (Nat.eq_dec m m).
           *** contradiction.
           *** apply False_ind.
               apply n; reflexivity.
        ** destruct (Nat.eq_dec m m).
           *** rewrite H.
               apply f_equal.
               apply IHl0.
           *** apply False_ind.
               apply n1; reflexivity.
      * apply select_min_equiv in e0.
        unfold equiv in e0.
        assert (H := e0 n).
        simpl in H.
        destruct (Nat.eq_dec n h).
        ** contradiction.
        ** destruct (Nat.eq_dec n m).
           *** contradiction.
           *** rewrite H.
               apply IHl0.
Qed.

Lemma select_min_leq': forall h l m l', select_min h l = (m, l') -> m <= h.
Admitted.

Lemma select_min_smallest: forall x l y l', select_min x l = (y, l') -> Forall (fun z => y <= z) l'.
Proof.
  intros x l. generalize dependent x.
  induction l.
  - intros x y l' H.
    simpl in H.
    inversion H; subst.
    apply Forall_nil.
  - intros x y l' H.
    simpl in H.
    destruct (le_lt_dec x a).
    + destruct (select_min x l) eqn: H'.
      inversion H; subst. clear H.
      assert (H := H').
      apply select_min_leq' in H'.
      apply Forall_cons.
      * apply le_trans with x; assumption.
      * apply IHl with x; assumption.
    + destruct (select_min a l) eqn: H'.
      inversion H; subst. clear H.
      assert (H := H').
      apply select_min_leq' in H'.
      apply Forall_cons.
      * apply Nat.lt_le_incl in l0.
        apply le_trans with a; assumption.
      * apply Nat.lt_le_incl in l0.
        apply IHl with a; assumption.
Qed.

Lemma select_min_leq: forall h1 l1 m1 m2 h2 l2 l3, select_min h1 l1 = (m1, h2 :: l2) -> select_min h2 l2 = (m2, l3) -> m1 <= m2.
Proof.
  intros h1 l1. generalize dependent h1.
  induction l1.
  - intros h1 m1 m2 h2 l2 l3 H.
    inversion H; subst.
  - intros h1 m1 m2 h2 l2 l3 H1 H2.
    apply IHl1 with h1 h2 l2 l3.
    + assert (H: select_min h1 l1 = (m1, h2 :: l2) -> select_min h2 l2 = (m2, l3) -> m1 <= m2).
    {
      apply IHl1.
    }
      simpl in H1.
      destruct (le_lt_dec h1 a).
      * destruct (select_min h1 l1).
        admit.
      * admit.
    + assumption.
Admitted.

Lemma smallest_equiv:
  forall l y l', equiv l l' -> Forall (fun z => y <= z) l -> Forall (fun z => y <= z) l'.
Proof.
  intros l y l'; revert l y.
  induction l' using list_lenght_ind.
  - admit.
  - intros l y Heq H'.
    assert (Hlength: length l = length l').
    { apply equiv_length; assumption. }
    generalize dependent l'.
    intro l'. case l'.
    + intros IH Heq Hlen.
      apply Forall_nil.
    + intros n l'' IH Heq Hlen.
      apply Forall_cons.
      * admit.
      * apply IH with l''.
        ** simpl. auto.
        ** unfold equiv; reflexivity.
        ** admit.
Admitted.

Lemma select_min_cons: forall h h' a m l l', h <= a -> select_min h (a :: l) = (m, a :: h' :: l') -> select_min h l = (m, h' :: l').

Lemma select_min_min: forall l2 h1 l1 m1 m2 h2 l3, select_min h1 l1 = (m1, h2 :: l2) -> select_min h2 l2 = (m2, l3) -> m1 <= m2.
Proof.
Admitted.

Theorem selectionSort_sorts: forall l, ordenada (select l).
Proof.
  intro l. functional induction (select l).
  - apply lista_vazia.
  - generalize dependent l'.
    intro l'.
    case l'.
    + intros H H1.
      rewrite select_equation.
      apply lista_1.
    + intros h' tl' Hl Hord.
      rewrite select_equation in *.
      destruct (select_min h' tl') as [m' l''] eqn: H.
      apply lista_nv.
      assert (H': m <= m').
      (* { apply select_min_min with tl' h tl h' l''; assumption. } *)
      { apply select_min_min with tl' h tl h' l''; assumption. }
      * assumption.
      * inversion H.
        assumption.
Qed.


(** Inductive datatypes were not part of the original calculus of
    constructions. The only native logical connective is product
    ([forall]) but it can be used to define other connectives. *)

(** The first two definitions are fairly useless but illustrate the
    logical interpretation of the product construct. *)
Definition implies (P Q : Prop) := P -> Q.

Definition univ_quantification (T : Type) (P : T -> Prop) := forall (x : T), P x.

(** _Conjunction_ *)
Definition and (P Q : Prop) := forall (R : Prop), (P -> Q -> R) -> R.
(** This can be understood as "any proposition [R] that requires a
    function of type [P -> Q -> R] to be is the type of proofs of [P] and
    [Q]". *)

(** _Disjunction_ *)
Definition or (P Q : Prop) := forall (R : Prop), (P -> R) -> (Q -> R) -> R.

(** _Negation_ *)
Definition not (P : Prop) := forall (Q : Prop), P -> Q.

(** _Existential quantification_ *)
Definition ex (T : Type) (P : T -> Prop) := forall (Q : Prop), (forall (t : T), P t -> Q) -> Q.

(** Prove the following lemmas, first with a proof script, then by
    writing a proof term directly. *)

(** To make it easier to write proof terms, you can write terms with
    placeholders (underscore) such as [fun (x : T) => _]. If the
    content of the placeholder can be inferred because of type
    dependencies, Coq will do so automagically. Otherwise, you get an
    error message which indicates the expected type of the
    placeholder. *)

(* Quantify over P and Q here to avoid a lot clutter in the examples. *)
Section Examples.

Variables P Q : Prop.

(** _Example_ *)
Theorem or_comm : or P Q -> or Q P.
Proof.
  unfold or; intros.
  apply H.
  - exact H1.
  - exact H0.
Qed.

Definition or_comm' : or P Q -> or Q P :=
  fun (H : or P Q) (R : Prop) (H0 : Q -> R) (H1 : P -> R) => H R H1 H0.

Theorem and_comm : and P Q -> and Q P.
  (* write a proof script here *)
Admitted.

Definition and_comm' : and P Q -> and Q P
  (* write a proof term here *)
. Admitted.

Theorem and_proj_l : and P Q -> P.
  (* write a proof script here *)
Admitted.

Definition and_proj_l' : and P Q -> P
  (* write a proof term here *)
. Admitted.

Theorem absurd : P -> not P -> Q.
  (* write a proof script here *)
Admitted.

Definition absurd' : P -> not P -> Q
  (* write a proof term here *)
. Admitted.

Theorem modus_ponens : and (or (not P) Q) P -> Q.
  (* write a proof script here *)
Admitted.

Definition modus_ponens' : and (or (not P) Q) P -> Q
  (* write a proof term here *)
. Admitted.

End Examples.

(** Provide a non-inductive definition of the type of equivalent
    propositions, without relying on a previously defined proposition
    (such as [and]). *)
Definition iff (P Q : Prop) : Prop := False.

Section ExamplesIff.

Variables A B C T : Prop.
Variable P : T -> Prop.

Theorem iff_refl : iff A A.
  (* write a proof script here *)
Admitted.

Definition iff_refl' : iff A A
  (* write a proof term here *)
. Admitted.

Theorem iff_sym : (iff A B) -> (iff B A).
  (* write a proof script here *)
Admitted.

Definition iff_sym' : (iff A B) -> (iff B A)
  (* write a proof term here *)
. Admitted.

Theorem iff_trans : (iff A B) -> (iff B C) -> (iff A C).
  (* write a proof script here *)
Admitted.

Definition iff_trans' : (iff A B) -> (iff B C) -> (iff A C)
  (* write a proof term here *)
. Admitted.

Theorem all_not_ex :
    iff (forall (x : T), not (P x)) (not (ex T P)).
Proof.
  (* write a proof script here *)
Admitted.

Definition all_not_ex' :
    iff (forall (x : T), not (P x)) (not (ex T P))
  (* write a proof term here *)
. Admitted.

End ExamplesIff.

(** Try to give a non-inductive definition of the type of false
    propositions. *)
Definition false : Prop := True.

Section ExamplesFalse.

Variables P : Prop.

(** Hint for the definition: The principle of explosion [forall P,
    false -> P] can be seen as defining falsehood. *)
Theorem ex_falso : false -> P.
  (* write a proof script here *)
Admitted.

Definition ex_falso' : false -> P
  (* write a proof term here *)
. Admitted.

Theorem not_alternative_def : iff (P -> false) (not P).
  (* write a proof script here *)
Admitted.

Definition not_alternative_def' : iff (P -> false) (not P)
  (* write a proof term here *)
. Admitted.

End ExamplesFalse.


From mathcomp Require Import all_ssreflect.

Implicit Type P Q R : Prop.

(** *** Exercise 0:
    - Define not. In type theory negation is defined in terms
      of [False].
*)

Definition not P :=
.

(** *** Exercise 1:
    - Prove the negation of the excluded middle.
*)
Lemma ex0 P : not (P /\ not P).
Proof.
Qed.

(** *** Exercise 2:
    - Declare iff (the constructor being called [iff_intro]).
    - Define iff1 of the given type
*)
Inductive iff P Q :=
.

Definition iff1 P Q : iff P Q -> P -> Q :=

(** *** Exercise 3:
    - Declare xor: two constructors, both have two arguments
    - Prove the following lemmas
*)

Inductive xor P Q : Prop :=
.

Lemma xorC P Q : iff (xor P Q) (xor Q P).
Proof.
Qed.

Lemma xor1 P Q : (xor P Q) -> not Q -> P.
Proof.
Qed.

Lemma xor2 P Q Z : (xor P Q) -> (xor Q Z) -> iff P Z.
Proof.
Qed.

(** *** Exercise 4:
    - Declare exists2
    - Prove a lemma ex1 -> ex2 T
*)

Inductive ex2 T (P Q : pred T) : Prop :=
.

Lemma ex2T T (P : pred T) : (exists x, P x) -> (ex2 T P P).
Proof.
Qed.

(** *** Exercise 5:
    - Write the induction principle for lists
*)
Definition induction_seq A (P : seq A -> Prop) :
  P nil -> (forall a l, P l -> P (a :: l)) -> forall l, P l :=
.

(** *** Exercise 6:
    - remeber [=> /view] to prove the following lemma
    - the two relevant views are [prime_gt1] and [dvdn_leq]
    - Note: [=> /view] combines well with [->] (lesson 3)
    - Hint: the proof can be a one liner [by move=> ....]
    - Recall: the notation "_ < _ <= _" hides a conjunction
*)
About prime_gt1.
About dvdn_leq.

Lemma ex_view p : prime p -> p %| 7 -> 1 < p <= 7.
Proof.
Qed.

(** *** Exercise 7:
    - Define the indexed data type of Cherry tree:
      + the index is a bool and must be truee iff the tree is completely
        flourished
      + leaves can be either Flower or Bud
      + the third constructor is called Node and has two sub trees
*)
Inductive cherryt : bool -> Type :=

Check Node _ Flower Flower : cherryt true.
Check Node _ Bud Bud       : cherryt false.
Fail Check Node _ Flower Bud.