Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Category.
Require Import Category.Opposite.

Local Open Scope morphism_scope.

(** The basic Definition of an isomorphism in a category.
An isomorphism is a pair of arrows f : a -> b and g : b -> a such that g ∘ f = id a and f ∘ g = id b. *)
Record Isomorphism {C : Category} (a b : C) : Type :=
{
  iso_morphism : a –≻ b;

  inverse_morphism : b –≻ a;

  left_inverse : (inverse_morphism ∘ iso_morphism)%morphism = id;

  right_inverse : (iso_morphism ∘ inverse_morphism)%morphism = id
}.

Bind Scope morphism_scope with Isomorphism.
Bind Scope isomorphism_scope with Isomorphism.

Hint Resolve left_inverse.

Hint Resolve right_inverse.

Coercion iso_morphism : Isomorphism >-> Hom.

Arguments iso_morphism {_ _ _} _.
Arguments inverse_morphism {_ _ _} _.
Arguments left_inverse {_ _ _} _.
Arguments right_inverse {_ _ _} _.

Notation "f '⁻¹'" := (inverse_morphism f) : morphism_scope.

Notation "a ≃ b" := (Isomorphism a b) : isomorphism_scope.

Notation "a ≃≃ b ::> C" := (@Isomorphism C a b) : isomorphism_scope.

Local Open Scope isomorphism_scope.

(* basic tactics for isomorphisms *)

Ltac simpl_isos_in_goal :=
  repeat(
      match goal with
        | [|- context[(iso_morphism ?A ∘ inverse_morphism ?A)%morphism]] => rewrite (right_inverse A); simpl_ids
        | [|- context[(inverse_morphism ?A ∘ iso_morphism ?A)%morphism] ] => rewrite (left_inverse A); simpl_ids
(* disabled due to problems with reveal_comp complexity *)
(*        | [|- context[iso_morphism ?A] ] =>
          reveal_comp (inverse_morphism A) (iso_morphism A) +
          reveal_comp (iso_morphism A) (inverse_morphism A) *)
      end
    )
.

Ltac simpl_isos_in_I I :=
  repeat(
      match type of I with
        | context[(iso_morphism ?A ∘ inverse_morphism ?A)%morphism] => rewrite (right_inverse A) in I; simpl_ids in I
        | context[(inverse_morphism ?A ∘ iso_morphism ?A)%morphism] => rewrite (left_inverse A) in I; simpl_ids in I
(* disabled due to problems with reveal_comp complexity *)
(*        | context[inverse_morphism ?A] =>
          reveal_comp (inverse_morphism A) (iso_morphism A) in I +
          reveal_comp (iso_morphism A) (inverse_morphism A) in I *)
      end
    )
.

Tactic Notation "simpl_isos" := simpl_isos_in_goal.

Tactic Notation "simpl_isos" "in" hyp(I) := simpl_isos_in_I I.

Hint Extern 3 => progress simpl_isos.

Hint Extern 3 => progress (dohyps (fun H => simpl_isos in H)).

(** simplifies equality of iso-morphisms. This theorem uses proof irrelevance to assume any two proofs for left and right inverse properties are equal.
In other words, two isomorphisms are equal if their underlying morphisms are. *)
Theorem Isomorphism_eq_simplify {C : Category} {a b : C} (I I' : a ≃ b) : (iso_morphism I = iso_morphism I') → (inverse_morphism I = inverse_morphism I') → I = I'.
Proof.
  intros H1 H2.
  destruct I as [iI inI Il Ir]; destruct I' as [iI' inI' Il' Ir'].
  cbn in *.
  ElimEq.
  doHomPIR.
  trivial.
Qed.

(** Isomorphism is an equivalence relation on objects. *)

(** The identity morphism forms an isomorphism, i.e., it is inverse to itself.
This is reflexivity property for the equivalence relation of isomorphism on objects. *)
Program Definition Isomorphism_id {C : Category} {a : C} : a ≃ a :=
{|
  iso_morphism := id;
  inverse_morphism := id
|}.

(** Each ismorphism has an inverse isomorphism. Simply swap the morphisms and proofs of left and right inverse properties.
This is symmetry property for the equivalence relation of isomorphism on objects. *)
Definition Inverse_Isomorphism {C : Category} {a b : C} (I : a ≃ b) : b ≃ a :=
{|
  iso_morphism := I⁻¹;
  inverse_morphism := I;
  left_inverse := right_inverse I;
  right_inverse := left_inverse I
|}.

Notation "f '⁻¹'" := (Inverse_Isomorphism f) : isomorphism_scope.

(** Isomorphisms compose. Simply compose the underlying morphisms of the isomorphism. Left and right inverse properties follow straightforwardly.
This is transitivty property for the equivalence relation of isomorphism on objects. *)
Program Definition Isomorphism_Compose
        {C : Category} {a b c : C} (I : a ≃ b) (I' : b ≃ c) : a ≃ c
  :=
{|
  iso_morphism := I' ∘ I;
  inverse_morphism := I⁻¹ ∘ I'⁻¹
|}.

Next Obligation.
Proof.
  rewrite assoc.
  rewrite (assoc_sym I).
  auto.
Qed.

Next Obligation.
Proof.
  rewrite assoc.
  rewrite (assoc_sym (I'⁻¹)).
  auto.
Qed.

Notation "f ∘ g" := (Isomorphism_Compose g f) : isomorphism_scope.

Local Close Scope isomorphism_scope.

(** A monic arrow (AKA, mono, monomorphic arrow and monomorphism) m is an arrow such that for any two arrows g and h (of the appropriate domain and codomain) we have if m ∘ g = m ∘ h then g = h. *)
Record Monic {C : Category} (a b : Obj) :=
{
  mono_morphism : a –≻ b;
  mono_morphism_monomorphic : ∀ (c : Obj) (g h : c –≻ a), (mono_morphism ∘ g = mono_morphism ∘ h) → g = h
}.

Coercion mono_morphism : Monic >-> Hom.

Arguments mono_morphism {_ _ _} _.
Arguments mono_morphism_monomorphic {_ _ _} _ _ _ _ _.

Notation "a ≫–> b" := (Monic a b) : morphism_scope.

Bind Scope morphism_scope with Monic.

(** An epic arrow (AKA, epi, epimorphic arrow and epimorphism) is a monomorphism in the opposite category. That is, m is epic if for any pair of arrows g and h (of the appropriate domain and codomain) we have if g ∘ m = h ∘ m then g = h. *)
Definition Epic {C : Category} (a b : C) := @Monic (C^op) b a.

Notation "a –≫ b" := (Epic a b) : morphism_scope.

Bind Scope morphism_scope with Epic.

(** The condition for a morphism to be mono-morphic. *)
Definition is_Monic {C : Category} {a b : Obj} (f : a –≻ b) :=
  ∀ (c : Obj) (g h : c –≻ a), (f ∘ g = f ∘ h) → g = h.

(** A mono-morphic morphism forms a Monic. *)
Definition is_Monic_Monic
           {C : Category}
           {a b : Obj}
           {f : a –≻ b}
           (H : is_Monic f)
  : Monic a b
  :=
    {|
      mono_morphism := f;
      mono_morphism_monomorphic := H
    |}
.

(** A morphism is ipic if it is monic in the opposit category. *)
Definition is_Epic {C : Category} {a b : C} (f : a –≻ b) := @is_Monic (C^op) b a f.

(** A morphism f : a –≻ b is split monic if there is another morphism
g : b –≻ a such that g ∘ f = idₐ *)
Record is_split_Monic {C : Category} {a b : Obj} (f : a –≻ b) :=
  {
    is_split_monic_left_inverse : b –≻ a;
    is_split_monic_left_inverse_is_left_inverse :
      (is_split_monic_left_inverse ∘ f) = id
  }
.

Arguments is_split_monic_left_inverse {_ _ _ _} _.
Arguments is_split_monic_left_inverse_is_left_inverse {_ _ _ _} _.

(** A morphism is ipic if it is monic in the opposit category. *)
Definition is_split_Epic {C : Category} {a b : C} (f : a –≻ b) := @is_split_Monic (C^op) b a f.

(** A split monic morphism is a monomorphism. *)
Program Definition is_split_Monic_Monic
           {C : Category}
           {a b : Obj}
           {f : a –≻ b}
           (H : is_split_Monic f)
  : Monic a b
  :=
    {|
      mono_morphism := f;
      mono_morphism_monomorphic := fun c g h H1 => _
    |}
.

Next Obligation.
Proof.
  assert (H2 := f_equal (fun w : c –≻ b => (is_split_monic_left_inverse H) ∘ w) H1).
  cbn in H2.
  repeat rewrite assoc_sym in H2.
  rewrite is_split_monic_left_inverse_is_left_inverse in H2.
  auto.
Qed.

(** If a monic morphism is split epic, it forms an isomorphism. *)
Program Definition Monic_is_split_Epic_Iso
        {C : Category}
        (a b : Obj)
        (f : a ≫–> b)
        (H : is_split_Epic f)
  :
    (a ≃ b)%isomorphism
  :=
    {|
      iso_morphism := f;
      inverse_morphism := is_split_monic_left_inverse H;
      right_inverse := is_split_monic_left_inverse_is_left_inverse H
    |}
.

Next Obligation.
Proof.
  apply (mono_morphism_monomorphic f).
  rewrite assoc_sym.
  cbn_rewrite (is_split_monic_left_inverse_is_left_inverse H).
  auto.
Qed.

(** If both g and (f ∘ g) are monic, then so is f. *)
Program Definition Compose_Monic_is_Monic_then_Monic
           {C : Category}
           {a b c : C}
           (M : a –≻ b)
           (M' : b ≫–> c)
           (H : is_Monic (M' ∘ M))
  :
    Monic a b
  :=
    {|
      mono_morphism := M;
      mono_morphism_monomorphic := fun d g h H1 => _
    |}
.

Next Obligation.
Proof.
  assert (H2 := f_equal (fun w : d –≻ b => M' ∘ w) H1).
  cbn in H2.
  repeat rewrite assoc_sym in H2.
  apply H; trivial.
Qed.

(** Monomorphisms compose. The case for epis follows by duality.*)
Section Mono_compose.
  Context {C : Category} {a b c : C} (M : a ≫–> b) (M' : b ≫–> c).

  Local Hint Resolve mono_morphism_monomorphic.

  Local Obligation Tactic := eauto.

  Program Definition Mono_compose : a ≫–> c :=
    {|
      mono_morphism := M' ∘ M
    |}.

End Mono_compose.

Local Open Scope isomorphism_scope.

(** An isomorphism is both monic and epic. *)
Section Iso_Mono_Epi.
  Context {C : Category} {a b : Obj} (I : a ≃ b).

  Program Definition Ismorphism_Monic : a ≫–> b :=
    {|
      mono_morphism := I
    |}.

  Next Obligation. (* mono_morphism_monomorphism *)
  Proof.
    match goal with
        [ H : (_ ∘ ?f = _ ∘ ?f')%morphism |- ?f = ?f'] =>
        match type of H with
            ?A = ?B =>
            let H' := fresh "H" in
            cut (I⁻¹ ∘ A = I⁻¹ ∘ B)%morphism; [auto | rewrite H; trivial]
        end
    end.
    repeat rewrite assoc_sym.
    auto.
  Qed.

  Program Definition Ismorphism_Epic : b –≫ a :=
    {|
      mono_morphism := inverse_morphism I
    |}.
  Next Obligation. (* epi_morphism_epimorphism *)
  Proof.
    match goal with
        [ H : (?f ∘ _ = ?f' ∘ _)%morphism |- ?f = ?f'] =>
        match type of H with
            ?A = ?B =>
            let H' := fresh "H" in
            cut (A ∘ I = B ∘ I)%morphism; [auto | rewrite H; trivial]
        end
    end.
    repeat rewrite assoc.
    auto.
  Qed.

End Iso_Mono_Epi.

(** If two objects are isomorphic in category C then they are also isomorphic in C^op. *)
Theorem CoIso {C : Category} (a b : C) : a ≃≃ b ::> C → a ≃≃ b ::> C^op.
Proof.
  intros I.
  eapply (Build_Isomorphism (C^op)%category _ _ (I⁻¹) I); unfold compose; simpl; auto.
Qed.


Require Export List.
Require Export Omega.

Module Type Comparable_data.
Parameter A : Type.
Parameter Ale : A -> A -> Prop.
Parameter Ale_dec : forall x y:A, {Ale x y} + {Ale y x}.
End Comparable_data.

Module Type SORTING_BASICS.
Parameter A : Type.
Parameter Ale : A -> A -> Prop.
Parameter Ale_dec : forall x y:A, {Ale x y} + {Ale y x}.
Parameter sort : list A -> list A.

Inductive sorted : list A -> Prop :=
  | sorted0 : sorted nil
  | sorted1 : forall x:A, sorted (x :: nil)
  | sorted2 :
      forall (x y:A) (l:list A),
        Ale x y -> sorted (y :: l) -> sorted (x :: y :: l).

Inductive permutation : list A -> list A -> Prop :=
  | transpose_first :
      forall (a b:A) (l:list A), permutation (a :: b :: l) (b :: a :: l)
  | permutation_same_head :
      forall (a:A) (l1 l2:list A),
        permutation l1 l2 -> permutation (a :: l1) (a :: l2)
  | permutation_empty : permutation nil nil
  | permutation_transitive :
      forall l1 l2 l3:list A,
        permutation l1 l2 -> permutation l2 l3 -> permutation l1 l3.

Parameter sort_sorted : forall l:list A, sorted (sort l).

Parameter sort_permutation : forall l:list A, permutation (sort l) l.

End SORTING_BASICS.

Module merge_sort_basics (Data: Comparable_data) :
  SORTING_BASICS
  with   Definition A := Data.A
  with Definition Ale := Data.Ale
  with Definition  Ale_dec := Data.Ale_dec.

Definition A := Data.A.
Definition Ale := Data.Ale.
Definition Ale_dec := Data.Ale_dec.

Fixpoint merge_aux (l1 l2:list A) (b:nat) {struct b} :
 list A :=
  match b with
  | O => nil (A:=A)
  | S b' =>
      match l1, l2 with
      | nil, l => l
      | l, nil => l
      | a :: l, b :: l' =>
          match Ale_dec a b with
          | left _ => a :: merge_aux l (b :: l') b'
          | right _ => b :: merge_aux (a :: l) l' b'
          end
      end
  end.

Definition merge (l1 l2:list A) := merge_aux l1 l2 (length l1 + length l2).

(* Make a list of singleton lists to initiate merging. *)

Fixpoint mk_singletons (l:list A) : list (list A) :=
  match l with
  | nil => nil (A:=(list A))
  | a :: tl => (a :: nil) :: mk_singletons tl
  end.

(* Given a list of lists, merge the first with the second,
  then the third with the fourth, and so on. *)

Fixpoint sort_aux1 (l:list (list A)) : list (list A) :=
  match l with
  | l1 :: l2 :: tl => merge l1 l2 :: sort_aux1 tl
  | _ => l
  end.

Fixpoint sort_aux2 (l:list (list A)) (b:nat) {struct b} :
 list A :=
  match b with
  | O => nil (A:=A)
  | S b' =>
      match l with
      | nil => nil (A:=A)
      | l' :: nil => l'
      | _ => sort_aux2 (sort_aux1 l) b'
      end
  end.

Definition sort (l:list A) := sort_aux2 (mk_singletons l) (length l).

(* In principle the exercise stops here.  But what follows is
  used to ensure that the sorting function we have defined does really
  sort a list of data. *)

Inductive sorted : list A -> Prop :=
  | sorted0 : sorted nil
  | sorted1 : forall x:A, sorted (x :: nil)
  | sorted2 :
      forall (x y:A) (l:list A),
        Ale x y -> sorted (y :: l) -> sorted (x :: y :: l).

Theorem sorted_inv : forall (a:A) (l:list A), sorted (a :: l) -> sorted l.
Proof.
 intros a l H; inversion H; assumption || constructor.
Qed.

Inductive all_sorted : list (list A) -> Prop :=
  | all_sorted_nil : all_sorted nil
  | all_sorted_rec :
      forall (l:list A) (tl:list (list A)),
        sorted l -> all_sorted tl -> all_sorted (l :: tl).

Theorem mk_singletons_all_sorted :
 forall l:list A, all_sorted (mk_singletons l).
Proof.
 intros l; elim l; simpl in |- *; repeat (intros; constructor || assumption).
Qed.

Theorem mk_singletons_length :
 forall l:list A, length (mk_singletons l) = length l.
Proof.
 simple induction l; simpl in |- *; auto.
Qed.

Inductive first_elem_prop : list A -> list A -> list A -> Prop :=
  | all_empty : first_elem_prop nil nil nil
  | fep_first :
      forall (a:A) (l1 l2 l3:list A),
        first_elem_prop (a :: l1) l2 (a :: l3)
  | fep_second :
      forall (a:A) (l1 l2 l3:list A),
       first_elem_prop l1 (a :: l2) (a :: l3).

Theorem merge_aux_sorted :
 forall (b:nat) (l1 l2:list A),
   length l1 + length l2 <= b ->
   sorted l1 ->
   sorted l2 ->
   sorted (merge_aux l1 l2 b) /\
   first_elem_prop l1 l2 (merge_aux l1 l2 b).
Proof.
 intros b; elim b.
 -  intros l1 l2.
    case l1; case l2; simpl in |- *;
    try (intros; match goal with
                   | id:(S _ <= _) |- _ => inversion id; fail
                 end).
    repeat constructor.

 -  intros b' Hrec l1; case l1.
    simpl in |- *; intros; split; [ assumption | case l2; constructor ].
    intros a l l2; case l2.
    +  simpl in |- *; intros; split; [ assumption | constructor ].
    +  simpl in |- *; intros a' l' Hle Hsorted1 Hsorted2; case (Ale_dec a a').
       *  elim (Hrec l (a' :: l')); auto.
          intros Hsorted' Hfep.
          generalize Hsorted' Hsorted1 Hsorted2; clear Hsorted1 Hsorted2 Hsorted'.
          inversion Hfep.
          intros Hsorted' Hsorted1 Hsorted2 Hale.
          inversion Hsorted1; repeat constructor || assumption.
          intros Hsorted' Hsorted1 Hsorted2 Hale.
          inversion Hsorted2; repeat constructor || assumption.
          simpl in |- *; omega.
          eapply sorted_inv; eauto.
       * elim (Hrec (a :: l) l'); auto.
         intros Hsorted' Hfep.
         generalize Hsorted' Hsorted1 Hsorted2; clear Hsorted1 Hsorted2 Hsorted'.
         inversion Hfep.
         intros Hsorted' Hsorted1 Hsorted2 Hale.
         inversion Hsorted1; repeat constructor || assumption.
         intros Hsorted' Hsorted1 Hsorted2 Hale.
         inversion Hsorted2; repeat constructor || assumption.
         simpl in |- *; omega.
         eapply sorted_inv; eauto.
Qed.

Theorem merge_sorted :
 forall l1 l2:list A, sorted l1 -> sorted l2 -> sorted (merge l1 l2).
Proof.
 unfold merge in |- *; intros l1 l2 H1 H2;
  elim (merge_aux_sorted (length l1 + length l2) l1 l2);
  auto.
Qed.

(* sort_aux1 has a multiple recursion step, we need a
   specific induction principle to work on this function. *)

Theorem list_ind2 :
 forall (B:Type) (P:list B -> Prop),
   P nil ->
   (forall x:B, P (x :: nil)) ->
   (forall (x1 x2:B) (l:list B), P l -> P (x1 :: x2 :: l)) ->
   forall l:list B, P l.
Proof.
 intros B P P0 P1 Pr l;assert (H: P l /\  forall x:B, P (x :: l)) by
     (elim l; intuition).
 now destruct H.
Qed.

Theorem sort_aux1_all_sorted :
 forall l:list (list A), all_sorted l -> all_sorted (sort_aux1 l).
Proof.
 intros l; elim l using list_ind2.
 -  simpl in |- *; trivial.
 -  simpl in |- *; trivial.
 -  intros x1 x2 tl Hrec Has; inversion Has; clear Has.
     match goal with
       | id:(all_sorted _) |- _ => inversion id
     end.
     simpl in |- *; constructor.
     + apply merge_sorted; auto.
     +  auto.
Qed.

Theorem sort_aux1_shorter :
 forall l:list (list A), length (sort_aux1 l) <= length l.
Proof.
 intros l; elim l using list_ind2; simpl in |- *; auto with arith.
Qed.

Theorem sort_aux2_sorted :
 forall (b:nat) (l:list (list A)),
   length l <= b -> all_sorted l -> sorted (sort_aux2 l b).
Proof.
 induction b as [ | b IHb].
 -  intros l; case l.
  +  intros; constructor.
  +  simpl in |- *; intros a l' Hle; inversion Hle.
 - intro  l; case l.
   +  simpl in |- *; intros; constructor.
   +  intros l1 tl; case tl.
      *  intros Hle Has; inversion Has; assumption.
      *  simpl in |- *; intros l2 tl' Hle Has; apply IHb.
         simpl in |- *.
         generalize (sort_aux1_shorter tl'); intros; omega.
         inversion Has; clear Has.
         match goal with
           | id:(all_sorted _) |- _ => inversion id
         end.
         constructor.
         apply merge_sorted; assumption.
         apply sort_aux1_all_sorted; assumption.
Qed.

Theorem sort_sorted : forall l:list A, sorted (sort l).
Proof.
 intros l; unfold sort in |- *.
 apply sort_aux2_sorted.
 rewrite mk_singletons_length; auto.
 apply mk_singletons_all_sorted.
Qed.

Inductive permutation : list A -> list A -> Prop :=
  | transpose_first :
      forall (a b:A) (l:list A), permutation (a :: b :: l) (b :: a :: l)
  | permutation_same_head :
      forall (a:A) (l1 l2:list A),
        permutation l1 l2 -> permutation (a :: l1) (a :: l2)
  | permutation_empty : permutation nil nil
  | permutation_transitive :
      forall l1 l2 l3:list A,
        permutation l1 l2 -> permutation l2 l3 -> permutation l1 l3.

Theorem permutation_reflexive : forall l:list A, permutation l l.
Proof.
 intros l; elim l; constructor; assumption.
Qed.

Theorem permutation_symmetric :
 forall l1 l2:list A, permutation l1 l2 -> permutation l2 l1.
Proof.
 intros l1 l2 H; elim H; try (intros; constructor; assumption).
 intros l3 l4 l5; intros; apply permutation_transitive with l4;
  assumption.
Qed.

Theorem permutation_app_cons :
 forall (l:list A) (a:A) (l':list A),
   permutation (l ++ a :: l') (a :: l ++ l').
Proof.
 intros l; elim l.
 simpl in |- *; intros; apply permutation_reflexive.
 simpl in |- *; intros a' tl Hrec a l'.
 apply permutation_transitive with (a' :: a :: tl ++ l');
  constructor; auto.
Qed.

Theorem merge_aux_permutation :
 forall (b:nat) (l1 l2:list A),
   length l1 + length l2 <= b ->
   permutation (merge_aux l1 l2 b) (l1 ++ l2).
Proof.
 intros b; elim b.
 -  intros l1 l2; case l1; case l2;
    try
      (simpl in |- *; intros;
       match goal with
         | id:(S _ <= _) |- _ => inversion id; fail
       end).
    simpl in |- *; constructor.
 -  intros b' Hrec l1 l2; case l1.
    simpl in |- *; intros Hle; apply permutation_reflexive.
    + simpl in |- *; intros a l; case l2.
      simpl in |- *; intros Hle; rewrite <- app_nil_end;
      apply permutation_reflexive.
      simpl in |- *; intros a' l'; case (Ale_dec a a').
      * intros Hale Hle;
        apply permutation_transitive with (a :: a' :: l ++ l').
        apply permutation_same_head.
        apply permutation_transitive with (l ++ a' :: l').
        apply (Hrec l (a' :: l')).
        simpl in |- *; omega.
        apply permutation_app_cons.
        constructor.
        apply permutation_symmetric.
        apply permutation_app_cons.
      *  intros Hale Hle.
         apply permutation_transitive with (a' :: a :: l ++ l').
         apply permutation_same_head.
         apply (Hrec (a :: l) l').
         simpl in |- *; omega.
         apply permutation_transitive with (a :: a' :: l ++ l').
         constructor.
         apply permutation_same_head.
         apply permutation_symmetric.
         apply permutation_app_cons.
Qed.

Theorem merge_permutation :
 forall l1 l2:list A, permutation (merge l1 l2) (l1 ++ l2).
Proof.
 unfold merge in |- *; intros l1 l2; apply merge_aux_permutation; auto.
Qed.

Fixpoint app_all (l:list (list A)) : list A :=
  match l with
  | nil => nil (A:=A)
  | l1 :: tl => l1 ++ app_all tl
  end.

Theorem app_all_mk_singletons_eq :
 forall l:list A, app_all (mk_singletons l) = l.
Proof.
 intros l; elim l; simpl in |- *; auto.
 intros a l' Hrec; rewrite Hrec; auto.
Qed.

Theorem permutation_app :
 forall l1 l2:list A, permutation (l1 ++ l2) (l2 ++ l1).
Proof.
 intros l1; elim l1; simpl in |- *.
 -  intros l2; rewrite <- app_nil_end.
     apply permutation_reflexive.
 - intros a tl Hrec l2.
   apply permutation_transitive with (a :: l2 ++ tl).
   +  apply permutation_same_head.
      apply Hrec.
   + apply permutation_symmetric; apply permutation_app_cons.
Qed.

Theorem permutation_long_head :
 forall l1 l2 l3:list A,
   permutation l2 l3 -> permutation (l1 ++ l2) (l1 ++ l3).
Proof.
 intros l1; elim l1; simpl in |- *; auto.
 intros a l1' Hrec l2 l3 H.
  constructor; auto.
Qed.

Theorem permutation_app4 :
 forall l1 l2 l3 l4:list A,
   permutation l1 l2 ->
   permutation l3 l4 -> permutation (l1 ++ l3) (l2 ++ l4).
Proof.
 intros l1 l2 l3 l4 H H0.
 apply permutation_transitive with (l1 ++ l4).
 -  apply permutation_long_head; assumption.
 -  apply permutation_transitive with (l4 ++ l1).
    +  apply permutation_app.
    +  apply permutation_transitive with (l4 ++ l2).
     *  apply permutation_long_head; assumption.
     * apply permutation_app.
Qed.

Theorem sort_aux1_permutation :
 forall l:list (list A), permutation (app_all (sort_aux1 l)) (app_all l).
Proof.
 intros l; elim l using list_ind2.
 -  simpl in |- *; constructor.
 -  simpl in |- *; intros; apply permutation_reflexive.
 -  intros l1 l2 tl Hrec; simpl in |- *.
    rewrite ass_app.
    apply permutation_app4;auto.
    apply merge_permutation; auto.
Qed.

Theorem sort_aux2_permutation :
 forall (b:nat) (l:list (list A)),
   length l <= b -> permutation (sort_aux2 l b) (app_all l).
Proof.
 intros b; elim b; simpl in |- *; auto.
 -  intros l; case l; simpl in |- *; try constructor.
    intros l' tl H; inversion H.
 -  intros b' Hrec l; case l.
   +  simpl in |- *; intros; constructor.
   +  intros l1 tl; case tl.
      *  simpl in |- *; intros;
         rewrite <- app_nil_end; apply permutation_reflexive.
      *  intros l2 tl' Hle;
        apply permutation_transitive with
        (app_all (sort_aux1 (l1 :: l2 :: tl'))).
        apply Hrec.
        simpl in Hle; generalize (sort_aux1_shorter tl').
        simpl in |- *; intros Hle'; omega.
        apply sort_aux1_permutation.
Qed.

Theorem sort_permutation : forall l:list A, permutation (sort l) l.
Proof.
 unfold sort in |- *; intros l; rewrite <- mk_singletons_length.
 pattern l at 3 in |- *; rewrite <- app_all_mk_singletons_eq.
 apply sort_aux2_permutation; auto.
Qed.

(* A nice complement to the exercise would be to define another merge-sorting
  function, but this time using well-founded induction, and yet another
  step would be to use an ad-hoc domain predicate. *)

End merge_sort_basics.


Require Import Arith Lia.

Definition zero_one_dec : forall n:nat, n<=1 -> {n=0}+{n=1}.
Proof.
 simple destruct n.
 -  left; auto.
 -  simple destruct n0.
    +  right; auto.
    +  intros  n1 H1; absurd (S (S n1) <= 1); auto with arith.
Defined.

Definition div2_mod2 :
  forall n:nat, {q:nat & {r:nat | n = 2*q + r /\ r <= 1}}.
Proof.
 induction n as [ |n IHn].
 -  exists 0, 0; cbn ; auto with arith.
 -  case IHn; intros q' Hq'; case Hq'; intros r' [H1 H2]; cbn.
    case (zero_one_dec  r' H2); intro H3.
    +  exists q', 1; lia.
    +  exists (S q'), 0; lia.
Defined.


Require Import Arith.

Section LargeProofTerm.

Inductive is_even : nat -> Prop :=
| even_O : is_even 0
| even_SS : forall n, is_even n -> is_even (S (S n)).

Goal is_even 10.
Proof.
    repeat (apply even_SS || apply even_O).
    Show Proof.
Qed.

Goal is_even (10 * 10 * 10 * 10).
Proof.
    Time (repeat (apply even_SS || apply even_O)).
    Show Proof.
Abort.

(* Proof by Reflection *)
Fixpoint dec_even (n : nat) :=
    match n with
    | 0 => true
    | 1 => false
    | S (S n') => dec_even n'
    end.

Lemma strong_induction (P : nat -> Prop) :
    (forall m, (forall k, k < m -> P k) -> P m)
    -> (forall n, P n).
Proof.
    intros sIH n.
    enough (G : forall p, p <= n -> P p).
    - apply G. constructor.
    - induction n.
        + intros p H. inversion H. apply sIH. intros k HH. inversion HH.
        + intros p H. apply sIH. intros k Hk. apply IHn.
          enough (HH : k < S n) by (apply (Nat.lt_succ_r); assumption).
          apply (Nat.lt_le_trans k p (S n)); assumption.
Qed.

Lemma dec_even_sound (n : nat):
    dec_even n = true -> is_even n.
Proof.
    induction n as [n IH] using strong_induction.
    destruct n. constructor. destruct n. discriminate.
    simpl. intros Hn. apply even_SS. auto.
Qed.

Goal is_even (10 * 10 * 10 * 10).
Proof.
    apply dec_even_sound.
    (* dec_even (10 * 10 * 10 * 10) == dec_even 10000 == true *)
    (* vm_compute is faster than simpl, but produces less readable result *)
    vm_compute.
    reflexivity.
    Show Proof.
    (* !!!!!!!! The key part of the proof term is just some eq_refl !!!!!!!! *)
Qed.

Goal is_even (100 * 100 * 100 * 100).
Proof.
    apply dec_even_sound.
Abort.

Inductive mexp : Set :=
| Num (n : nat)
| Mul (e1 e2 : mexp).

Fixpoint meval (e : mexp) :=
    match e with
    | Num n => n
    | Mul e1 e2 => (meval e1) * (meval e2)
    end.

Check (eq_refl : meval (Mul (Num 10) (Num 10)) = 10 * 10).

Fixpoint dec_even_mexp (e : mexp) :=
    match e with
    | Num n => dec_even n
    | Mul e1 e2 => orb (dec_even_mexp e1) (dec_even_mexp e2)
    end.

Lemma is_even_add x y :
    is_even x -> is_even y -> is_even (x + y).
Proof.
    revert y.
    induction x as [x IH] using strong_induction. intros y Hx.
    destruct x. intros; assumption. destruct x; inversion Hx.
    intros Hy. simpl. constructor. auto.
Qed.

Lemma is_even_mul x y :
    is_even x \/ is_even y -> is_even (x * y).
Proof.
    intros H. case H.
    - intros Hx. rewrite Nat.mul_comm. induction y.
      + constructor.
      + simpl. apply is_even_add; auto.
    - intros Hy. induction x.
      + constructor.
      + simpl. apply is_even_add; auto.
Qed.

Lemma dec_even_mexp_sound e :
    dec_even_mexp e = true -> is_even (meval e).
Proof.
    induction e.
    - simpl. apply dec_even_sound.
    - simpl. intros H. apply Bool.orb_prop in H. apply is_even_mul. case H.
      + intros H1. left. auto.
      + intros H2. right. auto.
Qed.

Goal is_even (100 * 100 * 100 * 100).
Proof.
    (* change P replace the current goal with P,
       when P and the current goal are judgementally equal (convertible) *)
    Fail change (true = true).
    change (is_even (meval (Mul (Mul (Mul (Num 100) (Num 100)) (Num 100)) (Num 100)))).
    apply dec_even_mexp_sound.
    simpl.
    reflexivity.
Qed.

(*  How to obtain (meval (Mul (Mul (Mul (Num 100) (Num 100)) (Num 100)) (Num 100)))
    from 100 * 100 * 100 * 100 ?

    Reification
*)

Ltac rf_mul x :=
    match x with
    | ?n * ?m =>
        let n' := rf_mul n in
        let m' := rf_mul m in
            constr:(Mul n' m')
    | _ => constr:(Num x)
    end.

(* For Ltac, see Section 7.6 in CoqArt and Chapter 14 in Certified Programming with Dependent Types *)

Goal is_even (123 * 100 * 100 * 100).
Proof.
    match goal with
    | [|- is_even ?x] =>
        let x' := rf_mul x in
            change (is_even (meval x'))
    end.
    apply dec_even_mexp_sound.
    simpl.
    reflexivity.
    Show Proof.
Qed.

End LargeProofTerm.

Section PlusExp.

Fixpoint plusn0 (n x : nat) :=
    match n with
    | 0 => x
    | S n => plusn0 n (x + 0)
    end.

Variable n : nat.
Goal plusn0 10 n = n.
Proof.
    simpl. rewrite <- !plus_n_O. reflexivity.
    Show Proof.
Qed.

Goal plusn0 100 n = n.
Proof.
    Time (vm_compute; rewrite <- !plus_n_O; reflexivity).
Qed.

Inductive aexp : Set :=
| AZero
| ANum (n : nat)
| APlus (a1 a2 : aexp).

Fixpoint aeval (a : aexp) : nat :=
    match a with
    | AZero => 0
    | ANum n => n
    | APlus a1 a2 => (aeval a1) + (aeval a2)
    end.

Fixpoint opt0 (a : aexp) : aexp :=
    match a with
    | APlus AZero a => opt0 a
    | APlus a AZero => opt0 a
    | APlus a1 a2 => APlus (opt0 a1) (opt0 a2)
    | _ => a
    end.

Lemma opt0_sound (a : aexp) :
    aeval a = aeval (opt0 a).
Proof.
    induction a as [ | | a1 IHa1 a2 IHa2]; try reflexivity.
    destruct a1 eqn:Ea1.
    - simpl. rewrite IHa2. reflexivity.
    - simpl. destruct a2; try reflexivity.
        + simpl. rewrite <- plus_n_O. reflexivity.
        + simpl. simpl in IHa2. rewrite IHa2. reflexivity.
    - destruct a2 eqn:Ea2.
        + simpl. simpl in IHa1. rewrite IHa1. rewrite <- plus_n_O. reflexivity.
        + simpl. simpl in IHa1. rewrite IHa1. reflexivity.
        + simpl. simpl in IHa1. simpl in IHa2. rewrite IHa1. rewrite IHa2. reflexivity.
Qed.

Fixpoint plusn0_aexp (n x : nat) :=
    match n with
    | 0 => ANum x
    | S n => APlus (plusn0_aexp n x) AZero
    end.

Eval simpl in (plusn0_aexp 10 n).
Eval simpl in aeval (plusn0_aexp 10 n).

Goal plusn0 10 n = n.
Proof.
    (* plusn0 10 n == aeval (plusn0_aexp 10 n) *)
    change (aeval (plusn0_aexp 10 n) = n).
    rewrite opt0_sound.
    simpl.
    reflexivity.
    Show Proof.
Qed.

Goal plusn0 20 n = n.
Proof.
    Time (simpl; rewrite <- !plus_n_O; reflexivity).
    Restart.
    Time (change (aeval (plusn0_aexp 20 n) = n);
    rewrite opt0_sound;
    simpl;
    reflexivity).
Qed.

(* how to obtain (APlus (ANum a) AZero) from (a + 0)? *)

Ltac rf_plus a :=
    match a with
    | (?x + ?y) =>
        let x' := rf_plus x in
        let y' := rf_plus y in
        constr:(APlus x' y')
    | 0 => constr:(AZero)
    | _ => constr:(ANum a)
    end.

Goal False.
let x := rf_plus (n + (n + 0) + 0) in pose x as a.
Abort.

Goal plusn0 10 n = n.
Proof.
    simpl.
    match goal with
    | [|- ?x = ?y] =>
        let x' := rf_plus x in
        change (aeval x' = y)
    end.
    rewrite opt0_sound.
    simpl.
    reflexivity.
Defined.

(* association *)

(* h + (t1 + t2 + t3 + ...) -> (((h + t1) + t2) + t3) + ... *)
Fixpoint norm_asc_tail (h t : aexp) :=
    match t with
    | APlus t1 t2 => norm_asc_tail (norm_asc_tail h t1) t2
    | _ => APlus h t
    end.

Fixpoint norm_asc (a : aexp) :=
    match a with
    | APlus a1 a2 => norm_asc_tail (norm_asc a1) a2
    | _ => a
    end.

Eval simpl in (norm_asc (APlus (APlus AZero AZero) (APlus AZero AZero))).

Lemma norm_asc_tail_sound (h t : aexp):
    aeval (APlus h t) = aeval (norm_asc_tail h t).
Proof.
    generalize dependent h.
    induction t as [| | t1 IHt1 t2 IHt2]; try reflexivity.
    intros h. simpl. rewrite <- IHt2. simpl. rewrite <- IHt1.
    simpl. rewrite Nat.add_assoc. reflexivity.
Qed.

Lemma norm_asc_sound : forall t,
    aeval t = aeval (norm_asc t).
Proof.
    induction t as [| | t1 IHt1 t2 IHt2]; try reflexivity.
    simpl. rewrite <- norm_asc_tail_sound. simpl. rewrite <- IHt1. reflexivity.
Qed.

Goal forall (x y z m n : nat),
    x + ((y + (z + m)) + n) = x + (y + (z + (m + n))).
Proof.
    intros.
    rewrite !Nat.add_assoc.
    reflexivity.
    Show Proof.
Qed.

Goal forall (x y z m n : nat),
    x + ((y + (z + m)) + n) = x + (y + (z + (m + n))).
Proof.
    intros.
    match goal with
    | [|- ?l = ?r] =>
        let l' := rf_plus l in
        let r' := rf_plus r in
        refine (_ : aeval l' = aeval r');
        rewrite (norm_asc_sound l');
        rewrite (norm_asc_sound r')
    end.
    simpl.
    reflexivity.
    Show Proof.
Qed.

End PlusExp.

(* For more on reification, see
   http://adam.chlipala.net/papers/ReificationITP18/
   https://github.com/LPCIC/coq-elpi
*)


Inductive Nat : Type :=
  | O : Nat
  | S : Nat -> Nat.

Fixpoint plus (n m : Nat) {struct n} : Nat :=
  match n with
  | O => m
  | S n' => S (plus n' m)
  end.

Notation "n + m" := (plus n m)
  (at level 50, left associativity).

Fixpoint mul (n m : Nat) {struct n} : Nat :=
  match n with
  | O => O
  | S n' => m + (mul n' m)
  end.

Notation "n * m" := (mul n m)
  (at level 40, left associativity).

Example mul_test_1 : S (S O) * S O = S (S O).
Proof.
  compute.
  trivial.
Qed.

Example mul_test_2 : S (S O) * S (S (S O)) = S (S (S (S (S (S O))))).
Proof.
  compute.
  trivial.
Qed.

Example mul_test_3 : S (S O) * O = O.
Proof.
  compute.
  trivial.
Qed.

Example mul_test_4 : O * S (S O) = O.
Proof.
  compute.
  trivial.
Qed.

Lemma add_associativity (n m o : Nat) : n + (m + o) = (n + m) + o.
Proof.
  intros.
  induction n.
  (* Inductional Hyptothesis *)
    simpl.
    trivial.
  (* Inductional step *)
    simpl.
    rewrite IHn.
    trivial.
Qed.

Lemma add_right_id (a : Nat) : a + O = a.
Proof.
  induction a.
    simpl. trivial.
    simpl. congruence.
Qed.

Lemma add_right_suc (a b : Nat) : a + S b = S a + b.
Proof.
  induction a.
    simpl. trivial.
    simpl. rewrite IHa. simpl. trivial.
Qed.

Lemma add_commutativity (a b: Nat) : a + b = b + a.
Proof.
  induction a.
  (* Inductional Hyptothesis *)
    simpl. rewrite add_right_id. trivial.
  (* Inductional step *)
    simpl. rewrite add_right_suc. simpl. congruence.
Qed.

Lemma add_eq_prop (a x y : Nat) : x = y -> a + x = a + y.
Proof.
  intros.
  induction a.
    simpl. trivial.
    simpl. congruence.
Qed.

Lemma mul_add_distributivity (a b c : Nat) : a * (b + c) = a*b + a*c.
Proof.
  induction a.
  (* IH *)
    simpl. trivial.

  (* step *)
    simpl.
    rewrite IHa.
    rewrite <- add_associativity.
    rewrite <- add_associativity.

    remember (c + (a * b + a * c)) as lhs.
    remember (a * b + (c + a * c)) as rhs.
    assert (reductionH : lhs = rhs).

    rewrite Heqlhs. rewrite Heqrhs.
    rewrite (add_commutativity c _).
    rewrite (add_commutativity c _).
    rewrite (add_associativity _ _ c).
    trivial.

    rewrite (add_eq_prop _ _ _ reductionH).
    trivial.
Qed.

Lemma mul_right_zero (a : Nat) : a * O = O.
Proof.
  induction a.
    trivial.

    trivial.
Qed.

Lemma add_suc (a : Nat) : S a = a + (S O).
Proof.
  rewrite add_right_suc.
  rewrite add_right_id.
  trivial.
Qed.

Lemma mul_right_id (a : Nat) : a * S O = a.
Proof.
  induction a.
    trivial.
    simpl. congruence.
Qed.

Lemma mul_right_suc (a b : Nat) : a * S b = a + a * b.
Proof.
  rewrite (add_suc b).
  rewrite mul_add_distributivity.
  rewrite mul_right_id.
  rewrite add_commutativity.
  trivial.
Qed.

Lemma mul_associativity (a b c : Nat) : a * (b * c) = a * b * c.
Proof.
  induction c.
    simpl.
    rewrite mul_right_zero.
    rewrite mul_right_zero.
    rewrite mul_right_zero.
    trivial.

    rewrite mul_right_suc.
    rewrite mul_add_distributivity.
    rewrite mul_right_suc.
    rewrite IHc.
    trivial.
Qed.

Lemma mul_commutativity (a b : Nat) : a * b = b * a.
Proof.
  induction a.
    rewrite mul_right_zero. trivial.

    simpl. rewrite mul_right_suc.
    rewrite IHa.
    trivial.
Qed.


Require Import Coq.ZArith.ZArith.
Open Scope Z_scope.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.

Inductive bit : Type :=
  | B0
  | B1.

Definition bin : Type := list bit.

Fixpoint incr (b : bin) : bin :=
  match b with
  | [] => [B1]
  | B0 :: b' => B1 :: b'
  | B1 :: b' => B0 :: (incr b')
  end.

Fixpoint incr_signed (b : bin) : bin :=
  match b with
  | [] | [B0] => [B1; B0]
  | [B1] => [B1; B1]
  | B0 :: b' => B1 :: b'
  | B1 :: b' => B0 :: (incr_signed b')
  end.

Fixpoint to_nat (b : bin) : nat :=
  match b with
  | [] => 0
  | B0 :: b' => 2 * to_nat b'
  | B1 :: b' => 1 + 2 * to_nat b'
  end.

Fixpoint of_nat (n : nat) : bin :=
  match n with
  | O => [B0]
  | S n' => incr (of_nat n')
  end.

Fixpoint of_nat_signed (n : nat) : bin :=
  match n with
  | O => [B0; B0]
  | S n' => incr_signed (of_nat_signed n')
  end.

Fixpoint to_positive (b : bin) : option positive :=
  let fix digits_to_positive (b : bin) : positive :=
    match b with
    | [] => xH
    | B0 :: b' => xO (digits_to_positive b')
    | B1 :: b' => xI (digits_to_positive b')
    end in
  match b with
  | [] => None
  | B0 :: b' => to_positive b'
  | B1 :: b' => Some (digits_to_positive b')
  end.

Fixpoint of_positive (p : positive) : bin :=
  match p with
  | xH => [B1]
  | xO p' => B0 :: of_positive p'
  | xI p' => B0 :: of_positive p'
  end.

Definition to_Z (b : bin) : Z :=
  match hd B0 b, to_positive (tl b) with
  | _, None => Z0
  | B0, Some p => Zpos p
  | B1, Some p => Zneg p
  end.

Definition of_Z (z : Z) : bin :=
  match z with
  | Z0 => [B0]
  | Zpos p => B0 :: of_positive p
  | Zneg p => B1 :: of_positive p
  end.

Definition to_N (b : bin) : N :=
  match to_positive b with
  | None => N0
  | Some p => Npos p
  end.

Definition of_N (n : N) : bin :=
  match n with
  | N0 => [B0]
  | Npos p => of_positive p
  end.

Definition bit_to_bool (b : bit) : bool :=
  match b with
  | B0 => false
  | B1 => true
  end.

Definition bool_to_bit (b : bool) : bit :=
  match b with
  | false => B0
  | true => B1
  end.

Theorem bit_bool_bit : forall b,
  bool_to_bit (bit_to_bool b) = b.
Proof. intros []; reflexivity. Qed.

Theorem bool_bit_bool : forall b,
  bit_to_bool (bool_to_bit b) = b.
Proof. intros []; reflexivity. Qed.

Definition bits_to_ascii (b0 b1 b2 b3 b4 b5 b6 b7 : bit) : ascii :=
  Ascii (bit_to_bool b0)
        (bit_to_bool b1)
        (bit_to_bool b2)
        (bit_to_bool b3)
        (bit_to_bool b4)
        (bit_to_bool b5)
        (bit_to_bool b6)
        (bit_to_bool b7).

Fixpoint to_string (b : bin) : option string :=
  match b with
  | [] => Some EmptyString
  | b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: b' =>
      match to_string b' with
      | None => None
      | Some s =>
          Some (String (bits_to_ascii b0 b1 b2 b3 b4 b5 b6 b7) s)
      end
  | _ => None
  end.

Fixpoint of_string (s : string) : bin :=
  match s with
  | EmptyString => []
  | String (Ascii b0 b1 b2 b3 b4 b5 b6 b7) s' =>
      bool_to_bit b0 ::
          bool_to_bit b1 ::
          bool_to_bit b2 ::
          bool_to_bit b3 ::
          bool_to_bit b4 ::
          bool_to_bit b5 ::
          bool_to_bit b6 ::
          bool_to_bit b7 ::
          of_string s'
  end.

Theorem bin_string_bin : forall b s,
  to_string b = Some s -> of_string s = b.
Proof.
  induction b as [|b0 [|b1 [|b2 [|b3 [|b4 [|b5 [|b6 [|b7 b']]]]]]]];
  intros; inversion H; subst; clear H.
  - reflexivity.
  - generalize dependent s.
    induction b'. cbn in *. Admitted.

Theorem string_bin_string : forall s,
  to_string (of_string s) = Some s.
Proof.
  induction s.
  - reflexivity.
  - destruct a. cbn. rewrite IHs.
    unfold bits_to_ascii. repeat rewrite bool_bit_bool. reflexivity.
Qed.

Fixpoint positive_to_nat (p : positive) : nat :=
  match p with
  | xH => 1
  | xO p' => 2 * positive_to_nat p'
  | xI p' => 1 + 2 * positive_to_nat p'
  end.

Definition Z_to_nat (z : Z) : option nat :=
  match z with
  | Z0 => Some O
  | Zpos p => Some (positive_to_nat p)
  | Zneg _ => None
  end.

Definition N_to_nat (n : N) : nat :=
  match n with
  | N0 => 0
  | Npos p => positive_to_nat p
  end.


Inductive Z : Type :=
| Pos : nat -> Z
| Zero : Z
| Neg : nat -> Z.

Definition neg (n: Z) : Z :=
match n with
| Pos k => Neg k
| Zero => Zero
| Neg k => Pos k
end.

Definition abs (n: Z) : Z :=
match n with
| Pos k => Pos k
| Zero => Zero
| Neg k => Pos k
end.

Definition succ (n: Z) : Z :=
match n with
| Pos k => Pos (S k)
| Zero => Pos O
| Neg O => Zero
| Neg (S n) => Neg n
end.

Definition pred (n: Z) : Z :=
match n with
| Pos (S n) => Pos n
| Pos O => Zero
| Zero => Neg O
| Neg n => Neg (S n)
end.

Theorem one_is_zero_succ : Pos O = succ Zero.
Proof.
  cbn. trivial.
Qed.

Theorem succ_S : forall n: nat, Pos (S n) = succ (Pos n).
Proof.
  destruct n; cbn; trivial.
Qed.

Theorem minus_one_is_zero_pred : Neg O = pred Zero.
Proof.
  cbn. trivial.
Qed.

Theorem pred_S : forall n: nat, Neg (S n) = pred (Neg n).
Proof.
  destruct n; cbn; trivial.
Qed.

Theorem Z_ind' (P : Z -> Prop) (base: P Zero) (suc: forall z: Z, P z -> P (succ z))
  (pre: forall z: Z, P z -> P (pred z)) : forall z: Z, P z.
Proof.
  intro z. destruct z; [| assumption |].
  - induction n.
    + rewrite one_is_zero_succ. apply suc. assumption.
    + rewrite succ_S. apply suc. assumption.
  - induction n.
    + rewrite minus_one_is_zero_pred. apply pre. assumption.
    + rewrite pred_S. apply pre. assumption.
Qed.

Theorem Z_ind'' (P : Z -> Prop) (base: P Zero) (base_pos: P (Pos O)) (base_neg: P (Neg O))
  (suc: forall n: nat, P (Pos n) -> P (Pos (S n)))
  (pre: forall n: nat, P (Neg n) -> P (Neg (S n))) : forall z: Z, P z.
Proof.
  intro z. destruct z.
  - induction n.
    + assumption.
    + apply suc. assumption.
  - assumption.
  - induction n.
    + assumption.
    + apply pre. assumption.
Qed.

Theorem neg_neg: forall n : Z, neg (neg n) = n.
Proof.
  intro n. destruct n; cbn; reflexivity.
Qed.

Theorem abs_impotent: forall n : Z, abs n = abs (abs n).
Proof.
  intro n. destruct n; cbn; reflexivity.
Qed.

Theorem succ_pred : forall n: Z, succ (pred n) = n.
Proof.
  intro n. destruct n; [| auto |]; now destruct n.
Qed.

Theorem pred_succ : forall n: Z, pred (succ n) = n.
Proof.
  intro n. destruct n; [| auto |]; now destruct n.
Qed.

(* add *)

Fixpoint map_n {A: Type} (n: nat) (f: A -> A) (x: A) : A :=
match n with
| O => x
| S n' => f (map_n n' f x)
end.

Definition add (a b : Z) : Z :=
match a with
| Pos n => map_n (S n) succ b
| Zero => b
| Neg n => map_n (S n) pred b
end.

Theorem add_r_zero : forall x: Z, add x Zero = x.
Proof.
  induction x using Z_ind''; cbn; [trivial | trivial | trivial |rewrite succ_S | rewrite pred_S];
  f_equal; apply IHx.
Qed.

Theorem add_r_succ : forall x y: Z, add x (succ y) = succ (add x y).
Proof.
  intros x y. induction x using Z_ind''; trivial; cbn in *.
  - rewrite pred_succ. rewrite succ_pred. trivial.
  - f_equal. apply IHx.
  - rewrite succ_pred. rewrite succ_pred in IHx. rewrite IHx. trivial.
Qed.

Theorem add_r_pred : forall x y: Z, add x (pred y) = pred (add x y).
Proof.
  intros x y. induction x using Z_ind''; trivial; cbn in *.
  - rewrite pred_succ, succ_pred. trivial.
  - rewrite pred_succ, IHx in *. trivial.
  - f_equal. apply IHx.
Qed.

Theorem add_sym: forall x y: Z, add x y = add y x.
Proof.
  intro x. induction x using Z_ind''; intro y; cbn.
  - rewrite add_r_zero. cbn. trivial.
  - rewrite one_is_zero_succ, add_r_succ, add_r_zero. trivial.
  - rewrite minus_one_is_zero_pred, add_r_pred, add_r_zero. trivial.
  - rewrite succ_S, add_r_succ. f_equal. apply IHx.
  - rewrite pred_S, add_r_pred. f_equal. apply IHx.
Qed.

Theorem neg_succ : forall x: Z, neg (succ x) = pred (neg x).
Proof.
  destruct x; [| auto |]; now destruct n.
Qed.

Theorem neg_pred : forall x: Z, neg (pred x) = succ (neg x).
Proof.
  destruct x; [| auto |]; now destruct n.
Qed.

Theorem add_pred_succ : forall x y: Z, add (pred x) (succ y) = add x y.
Proof.
  intros x y.
  now rewrite add_r_succ, (add_sym (pred x) y), add_r_pred, succ_pred, add_sym.
Qed.

Theorem neg_is_add_inv : forall x: Z, add x (neg x) = Zero.
Proof.
  induction x using Z_ind''; trivial.
  - now rewrite succ_S, neg_succ, add_sym, add_pred_succ, add_sym.
  - now rewrite pred_S, neg_pred, add_pred_succ.
Qed.

Theorem add_l_succ : forall x y: Z, add (succ x) y = succ (add x y).
Proof.
  intros x y. rewrite (add_sym (succ x) y), add_r_succ. f_equal. apply add_sym.
Qed.

Theorem add_succ_swap : forall x y: Z,  add x (succ y) = add (succ x) y.
Proof.
  intros x y. rewrite add_r_succ, add_l_succ. trivial.
Qed.

Theorem add_l_pred : forall x y: Z, add (pred x) y = pred (add x y).
Proof.
  intros x y. rewrite (add_sym (pred x) y), add_r_pred. f_equal.
  apply add_sym.
Qed.

Theorem add_pred_swap : forall x y: Z, add x (pred y) = add (pred x) y.
Proof.
  intros x y. rewrite add_r_pred, add_l_pred. trivial.
Qed.

Theorem add_assoc : forall x y z: Z, add (add x y) z = add x (add y z).
Proof.
  intros x y z. induction x using Z_ind'';
  [ auto | cbn; apply add_l_succ | cbn; apply add_l_pred | ..].
  - rewrite succ_S, add_l_succ, add_l_succ, add_l_succ. f_equal. apply IHx.
  - rewrite pred_S, add_l_pred, add_l_pred, add_l_pred. f_equal. apply IHx.
Qed.

Theorem add_one : forall x: Z, add x (Pos O) = succ x.
Proof.
  intro x. rewrite one_is_zero_succ, add_r_succ, add_r_zero. trivial.
Qed.

Theorem add_minus_one : forall x: Z, add x (Neg O) = pred x.
Proof.
  intro x. now rewrite minus_one_is_zero_pred, add_r_pred, add_r_zero.
Qed.

Theorem add_neg : forall x y: Z, add (neg x) (neg y) =  neg (add x y).
Proof.
  intros x y. induction x using Z_ind'';
  [ trivial | cbn; symmetry; apply neg_succ | cbn; symmetry; apply neg_pred | ..].
  - now rewrite succ_S, add_l_succ, neg_succ, neg_succ, <- IHx, add_l_pred.
  - now rewrite pred_S, add_l_pred, neg_pred, neg_pred, <- IHx, add_l_succ.
Qed.

Theorem add_r_neg : forall x y: Z, add x (neg y) =  neg (add (neg x) y).
Proof.
  intros x y. induction x using Z_ind'';
  [ trivial | cbn; now rewrite neg_pred | cbn; now rewrite neg_succ | ..].
  - now rewrite succ_S, add_l_succ, IHx, neg_succ, add_l_pred, neg_pred.
  - now rewrite pred_S, add_l_pred, neg_pred, add_l_succ, neg_succ, IHx.
Qed.

Theorem add_l_neg : forall x y: Z, add (neg x) y =  neg (add x (neg y)).
Proof.
  intros x y. now rewrite add_sym, add_r_neg, add_sym.
Qed.

(* mul *)

Definition mul (a b: Z) : Z :=
match a with
| Pos n => map_n (S n) (add b) Zero
| Zero => Zero
| Neg n => neg (map_n (S n) (add b) Zero)
end.

Definition id {A: Type} (x: A) := x.

Theorem mul_r_zero : forall x: Z, mul x Zero = Zero.
Proof.
  intros x. destruct x; cbn; [| auto |]; now induction n.
Qed.

Theorem mul_r_one : forall x: Z, mul x (Pos O) = x.
Proof.
  induction x using Z_ind''; [auto | auto | auto | ..]; cbn.
  - rewrite succ_S. now f_equal.
  - rewrite pred_S, neg_succ. now f_equal.
Qed.

Theorem mul_r_minus_one : forall x: Z, mul x (Neg O) = neg x.
Proof.
  induction x using Z_ind''; [auto | auto | auto | ..]; cbn.
  - rewrite pred_S. now f_equal.
  - rewrite succ_S, neg_pred. now f_equal.
Qed.

Theorem mul_r_succ : forall x y: Z, mul x (succ y) = add (mul x y) x.
Proof.
  intros x y. induction x using Z_ind''; [trivial|..]; cbn in *.
  - now rewrite add_r_zero, add_r_zero, add_one.
  - now rewrite add_r_zero, add_r_zero, add_minus_one, neg_succ.
  - rewrite IHx, add_l_succ, succ_S, add_r_succ. f_equal.
    now rewrite add_assoc, add_assoc, add_assoc.
  - rewrite pred_S, <- add_neg, IHx, <- add_neg, <- add_neg, <- add_neg,
    add_r_pred, neg_succ, add_l_pred. f_equal.
    now rewrite add_assoc, add_assoc, add_assoc.
Qed.

Theorem mul_r_pred : forall x y: Z, mul x (pred y) = add (mul x y) (neg x).
Proof.
  intros x y. induction x using Z_ind''; [trivial| ..]; cbn in *.
  - now rewrite add_r_zero, add_r_zero, add_minus_one.
  - now rewrite add_r_zero, add_r_zero, add_one, neg_pred.
  - rewrite IHx, add_l_pred, pred_S, add_r_pred. f_equal.
    now rewrite add_assoc, add_assoc, add_assoc.
  - rewrite succ_S, <- add_neg, IHx, <- add_neg,  <- add_neg, <- add_neg,
    add_r_succ, neg_pred, add_l_succ. f_equal.
    now rewrite add_assoc, add_assoc, add_assoc.
Qed.

Theorem mul_sym : forall x y: Z, mul x y = mul y x.
Proof.
  intros x y. induction x using Z_ind''.
  - now rewrite mul_r_zero.
  - cbn. now rewrite mul_r_one, add_r_zero.
  - cbn. now rewrite mul_r_minus_one, add_r_zero.
  - rewrite succ_S, mul_r_succ, <- IHx. cbn. rewrite add_assoc.
    f_equal. apply add_sym.
  - rewrite pred_S, mul_r_pred, <- IHx. cbn.
    now rewrite <- add_neg, <- add_neg, add_sym.
Qed.

Theorem mul_l_succ : forall x y: Z, mul (succ x) y = add (mul x y) y.
Proof.
  intros x y. now rewrite mul_sym, mul_r_succ, (mul_sym x y).
Qed.

Theorem mul_l_pred : forall x y: Z, mul (pred x) y = add (mul x y) (neg y).
Proof.
  intros x y. now rewrite mul_sym, mul_r_pred, (mul_sym x y).
Qed.

Theorem mul_r_neg : forall x y: Z, mul x (neg y) = neg (mul x y).
Proof.
  intros x y. induction x using Z_ind'; [auto | auto | auto |..].
  - now rewrite mul_l_succ, mul_l_succ, IHx, add_neg.
  - now rewrite mul_l_pred, mul_l_pred, IHx, add_r_neg, neg_neg.
Qed.

Theorem mul_l_neg : forall x y: Z, mul (neg x) y = neg (mul x y).
Proof.
  intros x y. now rewrite mul_sym, mul_r_neg, mul_sym.
Qed.

Theorem mul_neg : forall x y: Z, mul (neg x) (neg y) = mul x y.
Proof.
  intros x y. now rewrite mul_r_neg, mul_l_neg, neg_neg.
Qed.

Theorem mul_neg_swap : forall x y: Z, mul (neg x) y = mul x (neg y).
Proof.
  intros x y. now rewrite mul_r_neg, mul_l_neg.
Qed.

Theorem mul_dist_add : forall x y z: Z, mul x (add y z) = add (mul x y) (mul x z).
Proof.
  intros x y z. induction x using Z_ind'; [auto | auto | auto |..].
  - now rewrite mul_l_succ, mul_l_succ, mul_l_succ, IHx, add_assoc, add_assoc,
    (add_sym (mul x z) (add y z)), (add_sym (mul x z) z), add_assoc.
  - now rewrite mul_l_pred, mul_l_pred, mul_l_pred, IHx, add_assoc, add_assoc,
    (add_sym (neg y) (add (mul x z) (neg z))), (add_sym y z), add_assoc, add_neg.
Qed.

Theorem mul_assoc : forall x y z: Z, mul (mul x y) z = mul x (mul y z).
Proof.
  intros x y z. induction x using Z_ind'; [auto | auto | auto |..].
  - rewrite mul_l_succ, mul_l_succ, mul_sym, mul_dist_add, <- IHx.
    f_equal; apply mul_sym.
  - rewrite mul_l_pred, mul_l_pred, add_r_neg, mul_l_neg, add_r_neg.
    f_equal. rewrite mul_sym, mul_dist_add. f_equal.
    + rewrite <- IHx, mul_r_neg. f_equal. apply mul_sym.
    + apply mul_sym.
Qed.


From NAT Require Import Peanos_axioms.
From NAT Require Import Tutorial_World.
From NAT Require Import Addition_World.
From NAT Require Import Multiplication_World.
From NAT Require Import Power_World.
From NAT Require Import Function_World.
From NAT Require Import Proposition_World.
From NAT Require Import Advanced_Proposition_World.
From NAT Require Import Advanced_Addition_World.

Section Inequality_World.

(*Now for our final section, Inequality World!*)
(*Up until now we have been working with strict equality, which is great, but a lot of the things we want to do with the naturals will require a notion of order.
Just like in Power World, we should consider what it even means for a <= b. Initially, these are just random meaninless symbols and we can derive nothing from them, since our premise is not clear in the first place!
The best place to start is to realise that for a < b, there should be some `space` between them. That is b should be some distance away from a. From this idea we easily see how to define less than or equal to. *)
Definition less_than_or_equal (a b : nat):=
    exists c : nat, b = a + c.

Notation "a <= b" := (less_than_or_equal (a)(b)).

(*Now let us just restate the definition in a way that will be more useable later, and of course show that it is a true iff statement.*)
Proposition le_iff_exists_add (a b : nat) :
a <= b <-> exists c : nat, b = a + c.
Proof.
    split.
    intro h. exact (h).
    intro h. exact (h).
Qed.

Proposition one_add_le_self (x : nat) : x <= 1 + x.
Proof.
    apply le_iff_exists_add.
    exists 1.
    rewrite commute.
    reflexivity.
Qed.
(*If you find yourself trying some crazy proof method, take a step back and see if it cannot be done simpler.*)
Proposition le_refl (x : nat) : x <= x.
Proof.
    apply le_iff_exists_add.
    exists 0.
    rewrite add_zero.
    reflexivity.
Qed.
(*There are a few good ways to do this, both with previous results and just with tactics.*)
Proposition le_succ (a b : nat) : a <= b -> a <= S b.
Proof.
    intro h.
    apply le_iff_exists_add.
    assert (exists c : nat, b = a + c). exact h.
    destruct H.
    exists (x + 1).
    rewrite add_one. rewrite H. rewrite add_assoc.
    reflexivity.
Qed.
(*This is one of those theorems that you must prove in order to satisfy a lot of base cases and to make sure your definition is functioning in the way that you inteded it to.*)
Proposition zero_le (a : nat) : 0 <= a.
Proof.
    apply le_iff_exists_add.
    exists a.
    rewrite zero_add.
    reflexivity.
Qed.

Proposition le_trans (a b c : nat)(hab : a <= b)(hbc : b <= c): a <= c.
Proof.
     apply le_iff_exists_add.
     assert (exists c0 : nat, b = a + c0). exact hab.
     assert (exists c0 : nat, c = b + c0). exact hbc.
     destruct H. destruct H0.
     exists (x + x0).
     rewrite H0. rewrite H. rewrite add_assoc. reflexivity.
Qed.

Lemma left_cancel (a b c: nat): a + b= a + c -> b = c.
Proof.
    intro h.
    rewrite (commute (a)(b)) in h. rewrite (commute (a)(c)) in h.
    apply add_right_cancel_iff in h. exact h.
Qed.

Proposition le_antisymm (a b : nat) (hab : a <= b)(hba : b <= a): a = b.
Proof.
    assert (exists c : nat, b = a + c). exact hab.
    assert (exists c : nat, a = b + c). exact hba.
    destruct H. destruct H0.
    rewrite H in H0.
    rewrite <- (add_zero (a)) in H0.
    rewrite add_assoc in H0. rewrite add_assoc in H0.
    apply (left_cancel (a)(0)((0 + x + x0))) in H0.
    rewrite zero_add in H0.
    symmetry in H0.
    apply add_right_eq_zero in H0.
    rewrite H0 in H.
    rewrite add_zero in H.
    symmetry in H.
    exact H.
Qed.

Proposition le_zero (a : nat)(h :  a <= 0) : a = 0.
Proof.
    assert (0 <= a).
    apply le_iff_exists_add.
    exists a. rewrite zero_add. reflexivity.
    exact (le_antisymm (a)(0)(h)(H)).
Qed.

Proposition succ_le_succ (a b : nat)(h : a <= b) :
S a <= S b.
Proof.
    apply le_iff_exists_add.
    assert (exists c : nat, b = a + c). exact h.
    destruct H.
    exists x.
    rewrite add_succ.
    rewrite H. reflexivity.
Qed.

Lemma n_less_than_succ (n : nat): n <= S n.
Proof.
    apply le_iff_exists_add.
    exists 1. rewrite add_one. reflexivity.
Qed.
Proposition le_total (a b : nat) : a <= b \/ b <=a.
Proof.
    elim b.
    right. exact (zero_le (a) ).
    intros h1 h2. destruct h2.
    left.
    assert  (exists c : nat, h1 = a + c). exact H.
    destruct H0.
    apply le_iff_exists_add. exists (x+1).
    rewrite add_one. rewrite H0. rewrite add_assoc.
    reflexivity.
    assert (exists c, a = h1 + c). exact H.
    destruct H0. induction x. rewrite add_zero in H0.
    left. rewrite H0. exact (n_less_than_succ (h1)).
    right.
    apply le_iff_exists_add.
    exists x.
    rewrite add_succ. rewrite succ_add in H0.
    exact H0.
Qed.

Proposition add_le_add_right (a b : nat) :
a <= b -> forall t, (a + t) <= (b + t).
Proof.
    intros h ht.
    assert (exists c, b = a + c). exact h.
    destruct H.
    apply le_iff_exists_add.
    exists (x).
    rewrite H. rewrite add_assoc. rewrite (commute (x)(ht)).
    rewrite add_assoc. reflexivity.
Qed.

Proposition le_of_succ_le_succ (a b : nat) :
S a <= S b -> a <= b.
Proof.
    intro h.
    assert (exists c, S b = S a + c ). exact h.
    destruct H.
    rewrite add_one in H.
    rewrite (add_one (a)) in H.
    rewrite commute in H. rewrite (commute (a)(1)) in H.
    rewrite add_assoc in H.
    apply add_left_cancel in H.
    apply le_iff_exists_add.
    exists x. exact H.
Qed.

Proposition not_succ_le_self (a : nat) : ~(S a <= a).
Proof.
    intro h.
    assert (exists c, a = S a + c). exact h.
    destruct H. rewrite add_one in H. rewrite add_assoc in H.
    symmetry in H.
    rewrite <- (add_zero) in H.
    apply (add_left_cancel) in H.
    rewrite commute in H.
    rewrite <- (add_one) in H.
    apply zero_not_succ in H. exact H.
Qed.

Proposition add_le_add_left (a b : nat) (h : a <= b) (t :nat):
t +a <= t + b.
Proof.
    assert (exists c, b = a + c). exact h. destruct H.
    apply le_iff_exists_add. exists x.
    rewrite H. rewrite add_assoc. reflexivity.
Qed.

Proposition lt_aux_one (a b : nat) :
a <= b /\ ~(b <= a) -> S a <= b.
Proof.
    intro h.
    destruct h as [hab hba].
    assert (exists c, b = a + c). exact hab. destruct H.
    induction x. rewrite add_zero in H. symmetry in H.
    rewrite <- (add_zero) in H.
    assert (b <= a). exists 0. exact H.
    exfalso. exact (hba (H0)).
    apply le_iff_exists_add.
    exists x. rewrite add_succ.
    rewrite succ_add in H.
    exact H.
Qed.

Proposition lt_aux_two (a b : nat):
S a <= b -> a <= b /\ ~(b <= a).
Proof.
    intro h.
    split.
    assert (exists c, b = S a + c). exact h. destruct H.
    apply le_iff_exists_add.
    exists (1 + x).
    rewrite add_one in H. rewrite add_assoc in H.
    exact H.

    assert (exists c, b = S a + c). exact h. destruct H.
    intro hba.
    assert (exists c, a = b + c). exact hba. destruct H0.
    rewrite H0 in H.
    clear h. clear hba. clear H0.
    rewrite <- succ_add in H.
    rewrite add_assoc in H. symmetry in H.
    rewrite <- add_zero in H.
    symmetry in H. apply add_left_cancel in H.
    rewrite add_succ in H. symmetry in H.
    apply (zero_not_succ) in H. exact H.
Qed.

Definition less_than (a b : nat) := (a <= b) /\ ~(b <= a).
Notation "a < b" := (less_than (a)(b)).

Proposition lt_iff_succ_le (a b : nat) :
a < b <-> S a <= b.
Proof.
    split.
    intro h.
    assert ((a <= b) /\ ~(b <= a)). exact h.
    exact (lt_aux_one (a)(b)(H)).

    intro h.
    apply lt_aux_two in h. exact h.
Qed.

End Inequality_World.


Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import fintype finfun finset.

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

Module POSETDef.
  Class POSET (T : Type) :=
    Mixin
      {
        rel_op : T -> T -> bool;
        refl (x : T) : rel_op x x;
        asym (x y : T) : rel_op x y -> rel_op y x -> x = y;
        trans (y x z : T) : rel_op x y -> rel_op y z -> rel_op x z
      }.
  Notation "x <== y" := (rel_op x y) (at level 70, no associativity).
End POSETDef.
Export POSETDef.

Section NatPosetExamples.
  Check leqnn : forall n : nat, n <= n.
  Lemma eqn_leq' : forall m n, m <= n -> n <= m -> m = n.
  Proof.
    move=> m n.
    elim: m n => [|m IHm] [|n] //.
      move=> H1 H2; congr (_ .+1); move: H1 H2.
      by apply (IHm n).
  Qed.
  Check leq_trans : forall n m p : nat, m <= n -> n <= p -> m <= p.

  Instance natPOSET : POSET nat :=
    {
    (* *** *)
    }.
  Proof.
    by apply leqnn.
    by apply eqn_leq'.
    by apply leq_trans.
  Qed.

  Variables x y z : nat.

  Goal x <== x.
  Proof.
    by apply: refl.
  Qed.

  Goal x <== y -> y <== x -> x = y.
  Proof.
    by apply: asym.
  Qed.

  Goal x <== y -> y <== z -> x <== z.
  Proof.
    by apply: trans.
  Qed.
End NatPosetExamples.

(* END *)


From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.
Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.

Require Import List Arith_base PeanoNat String.
Import ListNotations.

Open Scope coq_nat.

Section ISORT.

  Fixpoint insert (x : nat)(xs : list nat) : list nat :=
    match xs with
    | [] => [ x ]
    | (y :: ys) =>
      if leb x y then x :: y :: ys else y :: (insert x ys)
    end.

  Fixpoint isort (xs : list nat) : list nat :=
    match xs with
    | [] => []
    | (x :: xs) => insert x (isort xs)
    end.
End ISORT.

Section TEST_SPEC.

  Fixpoint is_sorted (xs : list nat) : bool :=
    match xs with
    | [] => true
    | [ x ] => true
    | (x :: x' :: xs) => leb x x' && is_sorted xs
    end.

  Fixpoint elem (x : nat)(xs : list nat) : bool :=
    match xs with
    | [] => false
    | (y :: ys) => beq_nat x y || elem x ys
    end.

  Definition is_permutation (xs ys : list nat) :=
    forallb (fun x => elem x ys) xs &&
            forallb (fun y => elem y xs) ys.

  Definition isort_is_sorted (xs : list nat) := is_sorted (isort xs).

  Definition isort_permutation (xs : list nat) := is_permutation xs (isort xs).

  Definition isort_correct (xs : list nat) :=
    isort_is_sorted xs && isort_permutation xs.

End TEST_SPEC.

QuickChick isort_correct.

Section PROOF.

  Inductive sorted : list nat -> Prop :=
  | SortedNil : sorted []
  | SortedSing : forall x, sorted [ x ]
  | SortedRec : forall x y l, x <= y -> sorted (y :: l) -> sorted (x :: y :: l).

  Hint Constructors sorted.

  Require Import Omega.

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

  Lemma sorted_inv : forall x l, sorted (x :: l) -> sorted l.
  Proof.
    intros x l H ; inv H ; auto.
  Qed.

  Lemma insert_sorted
    : forall l x, sorted l -> sorted (insert x l).
  Proof.
    intros l x H ; elim H ; simpl ; eauto.
    intros z ; destruct (x <=? z) eqn : Heqn; simpl ; eauto.
    +
      apply leb_iff in Heqn ; eauto.
    +
      apply leb_iff_conv in Heqn.
      assert (z <= x) by omega.
      eauto.
    +
      intros.
      destruct (x <=? y) eqn : Heqn ; destruct (x <=? x0) eqn : Heqm.
      apply leb_iff in Heqn.
      apply leb_iff in Heqm.
      eauto.
      apply leb_iff in Heqn.
      apply leb_iff_conv in Heqm.
      assert (x0 <= x) by omega.
      eauto.
      apply leb_iff_conv in Heqn.
      apply leb_iff in Heqm.
      eauto.
      apply leb_iff_conv in Heqn.
      apply leb_iff_conv in Heqm.
      eauto.
  Qed.

  Inductive permutation {A : Type}: list A -> list A -> Prop :=
    perm_nil : permutation [] []
  | perm_skip : forall (x : A) (l l' : list A),
                permutation l l' ->
                permutation (x :: l) (x :: l')
  | perm_swap : forall (x y : A) (l : list A),
                permutation (y :: x :: l) (x :: y :: l)
  | perm_trans : forall l l' l'' : list A,
                 permutation l l' ->
                 permutation l' l'' ->
                 permutation l l''.

  Hint Constructors permutation.

  Lemma permutation_refl {A : Type}: forall (l : list A), permutation l l.
  Proof.
    induction l ; eauto.
  Qed.

  Lemma permutation_sym {A : Type}
    : forall (l l' : list A), permutation l l' -> permutation l' l.
  Proof.
    induction 1 ; eauto.
  Qed.

  Lemma permutation_trans {A : Type}
    : forall (l1 l2 l3 : list A), permutation l1 l2 ->
                  permutation l2 l3 ->
                  permutation l1 l3.
  Proof.
    induction 1 ; intros ; eauto.
  Qed.

  Lemma permutation_nil {A : Type} : forall (l : list A), permutation [] l -> l = [].
  Proof.
      intros l HF.
      remember (@nil A) as m in HF.
      induction HF; discriminate || auto.
  Qed.

  Lemma insert_permutation
    : forall l x, permutation (x :: l) (insert x l).
  Proof.
    induction l ; intros ; simpl in * ; eauto.
    destruct (x <=? a) eqn : Ha ; eauto.
  Qed.

  Lemma isort_permutation_thm : forall l, permutation l (isort l).
  Proof.
    Hint Resolve insert_permutation.
    induction l ; simpl in * ; eauto.
  Qed.

  Theorem isort_correct_thm : forall l, permutation l (isort l) /\
                                   sorted (isort l).
  Proof.
    induction l ; split ; simpl ; eauto.
    +
      destruct IHl ; simpl ; eauto.
    +
      destruct IHl.
      apply insert_sorted ; auto.
  Qed.
End PROOF.


Require Import PeanoNat.
Require Import Arith.
Require Import List.

(*** Zadanie 1 - 4p *)

(* Struktury algebraiczne możemy wygodnie reprezentować w Coqu za
pomocą rekordów zależnych, których pola opisują własności definiujące
daną strukturę. *)

(* 1. Zapoznaj się z komendą Record. *)

(* 2. Zdefiniuj typ monoidu jako rekord zależny, zawierający odpowiednie
pola, w tym łączność operacji i obustronną neutralność wyróżnionego
elementu. *)
Record Monoid {A:Type} (dot : A -> A -> A) (empty : A) : Prop := mkMonoid
  { dot_assoc : forall a b c, dot a (dot b c) = dot (dot a b) c
  ; empty_r : forall a, dot a empty = a
  ; empty_l : forall a, dot empty a = a
  }.

(* 3. Udowodnij, że w każdym monoidzie istnieje dokładnie jeden element
neutralny. *)
Goal forall (A:Type) (dot : A -> A -> A) (e : A) (e' : A),
  Monoid dot e -> Monoid dot e' -> e = e'.
Proof.
  intros.
  (* e = dot e e' = e' *)
  assert (dot e e' = e).
  apply empty_r. assumption.
  rewrite <- H1.
  apply empty_l. assumption.
Qed.

(* 4. Zdefiniuj w Coqu pojęcie homomorfizmu między monoidami. *)
(* Record Homomorphism {A B: Type} (f : A -> B) := mkHomomorphism
  { homomorph : forall dot dot' e e', Monoid dot e -> Monoid dot' e' ->
      forall a b, f (dot a b) = dot' (f a) (f b)
  }. *)
Record Homomorphism {A B: Type}
  {dot: A -> A -> A} {e : A} {dot' : B -> B -> B} {e' : B}
  (f : A -> B)
  (* (dot : A -> A -> A) (e : A) (dot' : B -> B -> B) (e' : B) *)
  (m1 : Monoid dot e) (m2 : Monoid dot' e') := mkHomomorphism
    { homomorph : forall a b, f (dot a b) = dot' (f a) (f b)
    }.

(* 5. Podaj dwa przykłady monoidów i zainstaluj je w typie monoid. Napisz
funkcję pomiędzy nośnikami tych monoidów, która definiuje homomorfizm
pomiędzy nimi. Udowodnij, że jest to homomorfizm. *)

(* Search (_ + (_ + _) = _ + _ + _).
Search (_ + 0).
Search (0 + _).
Search (forall a b c, a + (b + c) = a + b + c).
SearchHead (Nat.add_assoc). *)

Definition mono_add :=
  mkMonoid nat Nat.add 0 Nat.add_assoc Nat.add_0_r Nat.add_0_l.

Import ListNotations.

Definition app_unit (xs : list unit) (ys : list unit) : list unit :=
  app xs ys.

Lemma app_assoc_unit : forall a b c,
  app_unit a (app_unit b c) = app_unit (app_unit a b) c.
Proof.
  intros. unfold app_unit. apply app_assoc.
Qed.

Lemma app_nil_l_unit : forall a, app_unit [] a = a.
Proof.
  intros. unfold app_unit. apply app_nil_l.
Qed.

Lemma app_nil_r_unit : forall a, app_unit a [] = a.
Proof.
  intros. unfold app_unit. apply app_nil_r.
Qed.

Definition mono_list :=
  mkMonoid (list unit) app_unit [] app_assoc_unit app_nil_r_unit app_nil_l_unit.

Fixpoint nat_to_list (n : nat) : list unit :=
  match n with
  | 0 => []
  | S n => tt :: (nat_to_list n)
  end.

Lemma homomorph_nat_to_list :
  forall a b, nat_to_list (a + b) = app_unit (nat_to_list a) (nat_to_list b).
Proof.
  intros.
  unfold app_unit.
  induction a.
  - cbn. reflexivity.
  - cbn. rewrite IHa. reflexivity.
Qed.

Definition hom_nat_to_list :=
  mkHomomorphism nat (list unit) Nat.add 0 app_unit []
    nat_to_list mono_add mono_list homomorph_nat_to_list.

(* 6. Record jest cukrem syntaktycznym. W jaki sposób za pomocą znanych
konstrukcji Coqa możemy inaczej zdefiniować typ monoid? *)

Inductive monoid' {A:Type} (dot : A -> A -> A) (empty : A) : Prop :=
| mkMonoid' :
    forall a b c, dot a (dot b c) = dot (dot a b) c ->
    forall a, dot a empty = a ->
    forall a, dot empty a = a ->
    monoid' dot empty.

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

(*** Zadanie 2 - 4p + 10p *)

(* 1. Zdefiniuj indukcyjny typ danych reprezentujący drzewa
czerwono-czarne  *)
Inductive color := black | red.

Inductive rbtree (A : Set) : color -> nat -> Set :=
| rb_e : rbtree A black 0
| rb_r : forall h, rbtree A black h -> A -> rbtree A black h -> rbtree A red h
| rb_b : forall h c c', rbtree A c h -> A -> rbtree A c' h -> rbtree A black (S h).

(* taki, że typ rbtree A c h reprezentuje drzewa zawierające elementy
typu A, których korzeń ma kolor c i głębokość czarnych węzłów h. *)

(* 2. Zdefiniuj funkcję  *)
(* Fixpoint depth {A : Set} {c : color} {n : nat} *)
Fixpoint depth {A : Set} {c : color} {n : nat}
    (cmp : nat -> nat -> nat) (t : rbtree A c n) : nat :=
  match t with
  | rb_e _ => 0
  | rb_r _ h tl _ tr => S (cmp (depth cmp tl) (depth cmp tr))
  | rb_b _ _ _ _ tl _ tr => S (cmp (depth cmp tl) (depth cmp tr))
  end.

(* pozwalającą obliczyć maksymalną i minimalną głębokość drzewa, w
zależności od tego, jaką funkcję podamy jako argument. *)

Require Import Coq.Structures.GenericMinMax.

SearchPattern (_ <= _ -> S _ <= S _).

(* 3. Udowodnij własności  *)
Goal forall A c n (t : rbtree A c n), depth min t >= n.
Proof.
  intros.
  induction t; cbn; unfold ge in *; auto.
  - apply le_S. apply Nat.min_glb_iff. split; assumption.
  - apply le_n_S. apply Nat.min_glb_iff. split; assumption.
Qed.

Search (forall n m, n*m = m*n).
Search (forall n, n + 1 = S n).
Search (forall a b c, a + (b + c) = (a + b) + c).
Check Nat.add_assoc.

Lemma depth_max' : forall A c n (t : rbtree A c n),
  match c with
    | red => depth max t <= 2 * n + 1
    | black => depth max t <= 2 * n
  end.
Proof.
  intros.

  assert (forall h, 2 * h = h + h). intro.
  assert (h * 1 + h = h + h). auto with arith.
  rewrite <- H.
  rewrite mult_n_Sm.
  rewrite Nat.mul_comm.
  rewrite Nat.mul_comm.
  reflexivity.

  induction t; cbn; auto.
  - rewrite Nat.add_0_r.
    rewrite Nat.add_1_r.
    apply le_n_S.
    rewrite <- H.
    apply Nat.max_lub_iff.
    split; assumption.
  - apply le_n_S.
    assert (2 * h + 1 = h + S (h + 0)).
      rewrite Nat.add_0_r.
      rewrite <- Nat.add_1_r with (n := h).
      rewrite Nat.add_assoc.
      rewrite H. reflexivity.
    rewrite <- H0.
    case c, c'; apply Nat.max_lub_iff; split; auto with arith.
Qed.

Goal forall A c n (t : rbtree A c n), depth max t <= 2 * n + 1.
Proof.
  intros.
  cut (match c with
    | red => depth max t <= 2 * n + 1
    | black => depth max t <= 2 * n
  end).
  - induction c; auto with arith.
  - apply depth_max'.
Qed.

(* 4**. Chcielibyśmy teraz napisać funkcję, która wstawia element do
drzewa. Taka operacja może zepsuć własność drzewa czerwono-czarnego,
dlatego potrzebujemy zdefiniować nowy typ danych, który reprezentuje
takie pośrednie drzewo, które następnie będziemy rebalansować. Spróbuj
napisać funkcję balansowania, a następnie wstawiania elementu do
drzewa, stosując rozwiązanie Okasakiego opisane tutaj:
https://pdfs.semanticscholar.org/7756/16cf29e9c4e6d06e5999116f777e431cafa3.pdfs *)

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

(*** Zadanie 3 - 3p *)
(* 1. Zdefiniuj indukcyjny typ danych reprezentujący termy rachunku
kombinatorów: https://pl.wikipedia.org/wiki/Rachunek_kombinatorów *)

Inductive comb := S | K | app : comb -> comb -> comb.

Notation "a · b" :=
  (app a b)
  (at level 61, left associativity).

(* 2. Zdefiniuj redukcję na termach rachunku kombinatorów.  Podstawowy
krok redukcji zdefiniowany jest przez reguły
K t s -> t
S r s t -> (r t) (s t)
które można stosować w dowolnym podtermie danego termu. *)

Reserved Notation "a ->p b"
  (at level 70, no associativity).

Inductive redu : comb -> comb -> Prop :=
| red_K : forall t s, K · t · s ->p t
| red_S : forall r s t, S · r · s · t ->p r · t · (s · t)
| red_l : forall r r' s, r ->p r' -> r · s ->p r' · s
| red_r : forall r s' s, s ->p s' -> r · s ->p r · s'
where "a ->p b" := (redu a b).

(* Następnie zdefiniuj relację normalizacji jako zwrotno-przechodnie domknięcie
relacji redukcji. *)

(* refl_trans_closure *)
Inductive rt_clo {A : Set} (f : A -> A -> Prop) : A -> A -> Prop :=
| rt_clo_r : forall x, rt_clo f x x
| rt_clo_t : forall a b c, f a b -> rt_clo f b c -> rt_clo f a c.

Definition redu_t : comb -> comb -> Prop := rt_clo redu.

Notation "a ->* b" :=
  (redu_t a b)
  (at level 50, no associativity).

(* 3. Zdefiniuj typ danych reprezentujący typy proste z jednym typem bazowym. *)

(* t ::= a | t -> t *)
Inductive type := alpha | appT : type -> type -> type.

Notation "a => b" :=
  (appT a b)
  (at level 62, right associativity).

(* 4. Zdefiniuj indukcyjny predykat, który przypisuje typy termom
rachunku kombinatorów wg poniższych reguł:
K : A -> B -> A
S : (A -> B -> C) -> (A -> B) -> (A -> C)
M N : B jeśli M : A -> B i N : A
*)

Reserved Notation "a : b"
  (at level 70, no associativity).

Inductive comb_type : comb -> type -> Prop :=
| type_K : forall A B, K : (A => B => A)
| type_S : forall A B C, S : ((A => B => C) => (A => B) => (A => C))
| type_app : forall M N A B, M : (A => B) -> N : A -> M · N : B
where "a : b" := (comb_type a b).

(* 5. Udowodnij, że redukcja zachowuje typy (subject reduction). *)

Lemma primitive_preservation : forall M N A,
  M ->p N ->
  M : A ->
  N : A.
Proof.
  intros M N A H.
  generalize A.
  induction H.
  - intros.
    inversion H. clear H. subst.
    inversion H2. clear H2. subst.
    inversion H1. clear H1. subst.
    assumption.
  - intros.
    inversion H. clear H. subst.
    inversion H2. clear H2. subst.
    inversion H1. clear H1. subst.
    inversion H2. clear H2. subst.
    apply type_app with (M := r · t) (N := s · t) (A := B).
    + apply type_app with (A := A1); assumption.
    + apply type_app with (A := A1); assumption.
  - intros.
    inversion H0. clear H0. subst.
    apply IHredu in H3.
    apply type_app with (A := A1); assumption.
  - intros.
    inversion H0. clear H0. subst.
    apply IHredu in H5.
    apply type_app with (A := A1); assumption.
Qed.

Lemma preservation : forall M N A,
  M : A ->
  M ->* N ->
  N : A.
Proof.
  intros.
  induction H0.
  - assumption.
  - clear H1.
    apply IHrt_clo.
    apply primitive_preservation with (M := a); assumption.
Qed.