(* In this file, we have formalized the (correct) notion of isomorphisms in dagger categories, the so called unitary morphisms.
Notice that this definition is different compared to (non-dagger) categories, therefore, we can not reuse is_z_isomorphism. *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.DaggerCategories.Categories.

Local Open Scope cat.

Section UnitaryMorphisms.

  Definition is_unitary
             {C : category} (dag : dagger_structure C)
             {x y : C} (f : C⟦x,y⟧)
    : UU := is_inverse_in_precat f (dag x y f).

  Lemma isaprop_is_unitary
        {C : category} (dag : dagger_structure C)
        {x y : C} (f : C⟦x,y⟧)
    : isaprop (is_unitary dag f).
  Proof.
    apply isaprop_is_inverse_in_precat.
  Qed.

  Definition unitary {C : category} (dag : dagger_structure C)
             (x y : C)
    : UU
    := ∑ f : C⟦x,y⟧, is_unitary dag f.

  Definition unitary_to_mor
             {C : category} {dag : dagger_structure C}
             {x y : C} (u : unitary dag x y)
    : C⟦x,y⟧ := pr1 u.
  Coercion unitary_to_mor : unitary >-> precategory_morphisms.

  Lemma isaset_unitary
        {C : category} (dag : dagger_structure C) (x y : C)
    : isaset (unitary dag x y).
  Proof.
    apply isaset_total2.
    - apply homset_property.
    - intro ; apply isasetaprop ; apply isaprop_is_unitary.
  Qed.

  Lemma unitary_eq
        {C : category} {dag : dagger_structure C}
        {x y : C}
        (f g : unitary dag x y)
    : pr1 f = pr1 g -> f = g.
  Proof.
    intro p.
    apply (total2_paths_f p).
    apply isaprop_is_unitary.
  Qed.

  Definition unitary_id
             {C : category} (dag : dagger C)
             (x : C)
    : unitary dag x x.
  Proof.
    exists (identity_z_iso x).
    abstract (apply make_is_inverse_in_precat ;
              [ refine (id_left _ @ _) ; apply dagger_to_law_id
              | refine (id_right _ @ _) ; apply dagger_to_law_id ]).
  Defined.

  Lemma is_unitary_comp
             {C : category} {dag : dagger C}
             {x y z : C}
             {f : C⟦x,y⟧} (ff : is_unitary dag f)
             {g : C⟦y,z⟧} (gg : is_unitary dag g)
    : is_unitary dag (f · g).
  Proof.
    split.
    - etrans.
      { apply maponpaths, dagger_to_law_comp. }
      etrans.
      { apply assoc. }
      etrans.
      { apply maponpaths_2, assoc'. }
      etrans.
      { apply maponpaths_2, maponpaths, gg. }
      etrans.
      { apply maponpaths_2, id_right. }
      apply ff.
    - etrans.
      { apply maponpaths_2, dagger_to_law_comp. }
      etrans.
      { apply assoc. }
      etrans.
      { apply maponpaths_2, assoc'. }
      etrans.
      { apply maponpaths_2, maponpaths, ff. }
      etrans.
      { apply maponpaths_2, id_right. }
      apply gg.
  Qed.

  Definition unitary_comp
             {C : category} {dag : dagger C}
             {x y z : C}
             (f : unitary dag x y)
             (g : unitary dag y z)
    : unitary dag x z
    := _ ,, is_unitary_comp (pr2 f) (pr2 g).

  Lemma unitary_inv_is_unitary
             {C : category} {dag : dagger C}
             {x y : C} {f : C⟦x,y⟧}
             (ff : is_unitary dag f)
    : is_unitary dag (pr1 dag x y f).
  Proof.
    split.
    - refine (! dagger_to_law_comp dag y x y (pr1 dag x y f) f @ _).
      etrans.
      { apply maponpaths, ff. }
      apply dagger_to_law_id.
    - refine (! dagger_to_law_comp dag x y x f (pr1 dag x y f) @ _).
      etrans.
      { apply maponpaths, ff. }
      apply dagger_to_law_id.
  Qed.

  Definition unitary_inv
             {C : category} {dag : dagger C}
             {x y : C}
             (f : unitary dag x y)
    : unitary dag y x
    := _ ,, unitary_inv_is_unitary (pr2 f).

  Lemma unitary_inv_of_unitary_inv
        {C : category} {dag : dagger C}
        {x y : C}
        (f : unitary dag x y)
    : unitary_inv (unitary_inv f) = f.
  Proof.
    use unitary_eq.
    apply dagger_to_law_idemp.
  Qed.

End UnitaryMorphisms.

Section EquationalReasoningLemmas.

  Context {C : category} (dag : dagger C).

  Lemma unitary_inv_to_left {a b c : C}
        (f : C⟦ a, b ⟧) (g : C⟦b, c⟧) (h : C⟦ a, c ⟧)
    : is_unitary dag f -> dag _ _ f · h = g → h = f · g.
  Proof.
    exact (λ u p, z_iso_inv_to_left _ _ _ (make_z_iso _ _ (_,,pr2 u)) _ _ p).
  Qed.

  Lemma unitary_inv_on_left {a b c : C}
        (f : C⟦ a, b ⟧) (g : C⟦b, c⟧) (h : C⟦ a, c ⟧)
    : is_unitary dag g -> h = f · g → f = h · dag _ _ g.
  Proof.
    exact (λ u p, z_iso_inv_on_left _ _ _ _ (make_z_iso _ _ (_,,pr2 u)) _ p).
  Qed.

  Lemma unitary_inv_on_right {a b c : C}
        (f : C⟦ a, b ⟧) (g : C⟦b, c⟧) (h : C⟦ a, c ⟧)
    : is_unitary dag f ->  h = f · g → dag _ _ f · h = g.
  Proof.
    exact (λ u p, z_iso_inv_on_right _ _ _ (make_z_iso _ _ (_,,pr2 u)) _ _ p).
  Qed.

  Lemma unitary_inv_to_right {a b c : C}
        (f : C⟦ a, b ⟧) (g : C⟦b, c⟧) (h : C⟦ a, c ⟧)
    : is_unitary dag g ->   f = h · dag _ _ g → f · g = h.
  Proof.
    exact (λ u p, z_iso_inv_to_right _ _ _ _ (make_z_iso _ _ (_,,pr2 u)) _ p).
  Qed.

End EquationalReasoningLemmas.


(*
  This is a test document filled with exercises from
  https://coq.inria.fr/tutorial-nahas
*)

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

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

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

Theorem backward_large : (forall A B C : Prop, A -> (A -> B) -> (B -> C) -> C).
Proof.
  intros.
  refine (H1 _).
  refine (H0 _).
  exact H.
Qed.

Theorem backward_huge : (forall A B C : Prop,
                         A -> (A -> B) -> (A -> B -> C) -> C).
Proof.
  intros.
  refine (H1 _ _).
    exact H.
    refine (H0 _).
      exact H.
Qed.

Theorem forward_huge : (forall A B C : Prop,
                        A -> (A -> B) -> (A -> B -> C) -> C).
Proof.
  intros.
  pose (proof_of_B := H0 H).
  pose (proof_of_C := H1 H proof_of_B).
  exact proof_of_C.
Qed.

Theorem True_can_be_proven : True.
Proof.
  exact I.
Qed.

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

Theorem False_cannot_be_proven__again : ~False.
Proof.
  intros proof_of_False.
  case proof_of_False.
Qed.

Theorem absurd : forall A C : Prop, A -> ~A -> C.
Proof.
  intros.
  unfold not in H0.
  pose (proof_of_False := H0 H).
  case proof_of_False.
Qed.

Require Import Bool.

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

Theorem not_eqb_true_false: ~(Is_true (eqb true false)).
Proof.
  (* these next two aren't actually needed!*)
  unfold not.
  simpl.
  exact False_cannot_be_proven.
Qed.

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

Theorem thm_eqb_a_t: (forall a : bool, (Is_true (eqb a true)) -> (Is_true a)).
Proof.
  intros a.
  case a.
    simpl.
    intros proof_of_True.
    exact I.

    simpl.
    intros proof_of_False.
    case proof_of_False.
Qed.

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

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

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

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

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

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

Theorem and_communtes__again : (forall A B : Prop, A /\ B -> B /\ A).
Proof.
  intros.
  destruct H as [proof_of_A proof_of_B].
  refine (conj _ _).
    exact proof_of_B.
    exact proof_of_A.
Qed.

Theorem orb_is_or : (forall a b, Is_true (orb a b) <-> Is_true a \/ Is_true b).
Proof.
  intros a b.
  unfold iff.
  refine (conj _ _).
    intros.
    case a, b.
      simpl.
      exact (or_introl I).

      simpl.
      exact (or_introl I).

      simpl.
      exact (or_intror I).

      simpl in H.
      refine (or_introl _).
      simpl.
      case H.
    intros.
    case a,b.
      exact I.
      exact I.
      exact I.
      case H.
        intros A.
        simpl in A.
        case A.

        intros B.
        simpl in B.
        case B.
Qed.

Theorem andb_is_and : (forall a b,
                       Is_true (andb a b) <-> Is_true a /\ Is_true b).
Proof.
  intros a b.
  unfold iff.
  refine (conj _ _).
    intros H.
    case a, b.
      simpl.
      exact (conj I I).

      simpl in H.
      case H.

      simpl in H.
      case H.

      simpl in H.
      case H.
    intros H.
    case a, b.
      simpl.
      exact I.

      simpl in H.
      destruct H as [A B].
      case B.

      simpl in H.
      destruct H as [A B].
      case A.

      simpl in H.
      destruct H as [A B].
      case A.
Qed.

(* !a <-> !A where a : bool, A : Prop *)
Theorem negb_is_not : (forall a, Is_true (negb a) <-> (~(Is_true a))).
Proof.
  intros.
  unfold iff.
  case a.
    (* a is true *)
    simpl.
    refine (conj _ _).
      (* False -> ~True *)
      intros.
      unfold not.
      case H.

      (* ~True -> False *)
      unfold not.
      intros.
      case H.
      exact I.
    (* a is false *)
    simpl.
    refine (conj _ _).
      (* True -> ~False*)
      unfold not.
      intros.
      case H0.

      (* ~False -> True *)
      unfold not.
      intros.
      exact I.
Qed.

Definition basic_predicate := (fun a => Is_true (andb a true)).

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

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

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

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

Theorem forall_exists : (forall P : Set -> Prop,
                        (forall x, ~(P x)) -> ~(exists x, P x)).
Proof.
  intros.
  unfold not in H.
  unfold not.
  intros exists_set_px.
  destruct exists_set_px as [exists_set exists_px].
  pose (not_Pwitness := H exists_set exists_px).
  case not_Pwitness.
Qed.

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

Theorem thm_eq_sym : (forall x y : Set, x = y -> y = x).
Proof.
  intros x y.
  intros x_y.
  destruct x_y as [].
  exact (eq_refl x).
Qed.

Theorem them_eq_trans : (forall x y z : Set, x = y -> y = z -> x = z).
Proof.
  intros.
  destruct H as [].
  destruct H0 as [].
  exact (eq_refl x).
Qed.

Theorem thm_eq_trans__again : (forall x y z: Set, x = y -> y = z -> x = z).
Proof.
  intros.
  rewrite H.
  rewrite H0.
  exact (eq_refl z).
Qed.

Theorem thm_eq_trans__again2 : (forall x y z: Set, x = y -> y = z -> x = z).
Proof.
  intros.
  rewrite H.
  rewrite <-H0.
  exact (eq_refl y).
Qed.

Theorem andb_sym : (forall a b, a && b = b && a).
Proof.
  intros.
  case a, b.
    simpl.
    exact (eq_refl true).

    simpl.
    exact (eq_refl false).

    simpl.
    exact (eq_refl false).

    simpl.
    exact (eq_refl false).
Qed.

Theorem neq_nega: (forall a, a <> (negb a)).
Proof.
  intros.
  unfold not.
  case a.
    simpl.
    discriminate.
    simpl.
    discriminate.
Qed.

Theorem neq_nega__book: (forall a, a <> (negb a)).
Proof.
  intros a.
  unfold not.
  case a.
    intros a_eq_neg_a.
    simpl in a_eq_neg_a.
    discriminate a_eq_neg_a.

    intros a_eq_neg_a.
    simpl in a_eq_neg_a.
    discriminate a_eq_neg_a.
Qed.

(* Peano Arithmetic *)

Theorem plus_2_3 : (2 + 3 = 5).
  simpl.
  exact (eq_refl 5).
Qed.

Theorem plus_2_3_long : (S (S O)) + (S (S (S O))) = (S (S (S (S (S O))))).
Proof.
  simpl.
  exact (eq_refl 5).
Qed.

Theorem plus_O_n : (forall n, O + n = n).
Proof.
  intros n.
  simpl.
  exact (eq_refl n).
Qed.

Theorem plus_n_O : (forall n, n + O = n).
Proof.
  intros n.
  elim n.
    (* base case *)
    simpl.
    exact (eq_refl _).

    (* inductive case *)
    intros.
    simpl.
    rewrite H.
    exact (eq_refl _).
Qed.

Theorem plus_symmetric : (forall n m, n + m = m + n).
Proof.
  intros.
  elim n.
    elim m.
      simpl.
      exact (eq_refl _).

      intros.
      simpl.
      rewrite <- H.
      simpl.
      exact (eq_refl _).
    intros.
    simpl.
    rewrite H.
    elim m.
      simpl.
      exact (eq_refl _).

      intros.
      simpl.
      rewrite H0.
      exact (eq_refl _).
Qed.

Require Import List.

(* Adding an element to a list increases its length by 1 *)
Theorem cons_adds_one_to_length :
    (forall A : Type,
    (forall (x : A) (lst : list A),
     length (x :: lst) = (S (length lst)))).
Proof.
  intros.
  simpl.
  exact (eq_refl _).
Qed.

Definition hd (A : Type) (default : A) (l : list A) :=
match l with
| nil => default
| x :: _ => x
end.

(* currying the above function with 2 parameters*)
Definition hd_for_nat_lists := hd nat 0.
(* Compute hd_for_nat_lists (5 :: 4 :: nil). *)
(* Compute hd_for_nat_lists (nil). *)

Theorem correctness_of_hd :
    (forall A : Type,
    (forall (default : A) (x : A) (l : list A),
    (hd A default nil) = default /\ (hd A default (x :: l) = x))).
Proof.
  intros.
  simpl.
  refine (conj _ _).
    exact (eq_refl _).
    exact (eq_refl _).
Qed.

(* `: option A` can be inferred *)
Definition hd_error (A : Type) (l : list A) : option A :=
match l with
| nil => None
| x :: _ => Some x
end.
(* Compute hd_error nat nil.
Compute hd_error nat (5 :: 4 :: nil). *)

Theorem correctness_of_hd_error :
    (forall A : Type,
    (forall (x : A) (l : list A),
    (hd_error A nil) = None /\ (hd_error A (x :: l)) = Some x)).
Proof.
  intros.
  simpl.
  refine (conj _ _).
    exact (eq_refl _).
    exact (eq_refl _).
Qed.

(* some crazy shit?!?! *)
(* pass a proof that hte list is not nil *)
Definition hd_never_fail (A : Type) (lst : list A) (safety_proof : lst <> nil)
  : A
:=
  (match lst as b return (lst = b -> A) with
    | nil => (fun foo : lst = nil =>
                   match (safety_proof foo) return A with
                   end
                )
    | x :: _ => (fun foo : lst = x :: _ =>
                   x
                )
  end) eq_refl.

Theorem correctness_of_hd_never_fail :
   (forall A:Type,
   (forall (x : A) (rest : list A),
   (exists safety_proof : ((x :: rest) <> nil),
      (hd_never_fail A (x :: rest) safety_proof) = x))).
Proof.
  intros.
  assert (witness : ((x :: rest) <> nil)).
    unfold not.
    intros.
    discriminate H.
  refine (ex_intro _ witness _).
    simpl.
    exact (eq_refl _).
Qed.

Definition tl (A : Type) (l:list A) :=
  match l with
    | nil => nil
    | a :: m => m
  end.

Theorem hd_tl :
   (forall A:Type,
   (forall (default : A) (x : A) (lst : list A),
   (hd A default (x::lst)) :: (tl A (x::lst)) = (x :: lst))).
Proof.
  intros.
  simpl.
  exact (eq_refl _).
Qed.

(* exercises *)

Theorem app_nil_l : (forall A : Type, (forall l : list A, nil ++ l = l)).
Proof.
  intros.
  simpl.
  exact (eq_refl _).
Qed.

Theorem app_nil_r : (forall A:Type, (forall l:list A, forall l:list A, l ++ nil = l)).
Proof.
  intros.
  simpl.
  elim l0.
    simpl.
    exact (eq_refl _).
  intros.
  simpl.
  rewrite H.
  exact (eq_refl _).
Qed.

Theorem app_comm_cons : forall A (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y.
Proof.
  intros.
  simpl.
  exact (eq_refl _).
Qed.

Theorem app_assoc : forall A (l m n:list A), l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros.
  elim l.
    simpl.
    exact (eq_refl _).
  intros.
  simpl.
  rewrite H.
  exact (eq_refl _).
Qed.

Theorem app_cons_not_nil : forall A (x y:list A) (a:A), nil <> x ++ a :: y.
Proof.
  intros.
  unfold not.
  elim x.
    simpl.
    discriminate.

    intros.
    simpl in H0.
    discriminate H0.
Qed.


Require Import Nat Arith Bool.

Inductive Lst : Type := nil : Lst | cons : nat -> Lst -> Lst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint lst_mem (mem_arg0 : nat) (mem_arg1 : Lst) : bool
:= match mem_arg0, mem_arg1 with
    | x, nil => false
    | x, cons y z => orb (beq_nat x y) (lst_mem x z)
    end.

Fixpoint lst_subset (lst_subset_arg0 : Lst) (lst_subset_arg1 : Lst) : Prop
           := match lst_subset_arg0, lst_subset_arg1 with
              | nil, x => True
              | cons n x, y => and (lst_subset x y) (lst_mem n y = true)
              end.

Definition lst_eq (lst_eq_arg0 : Lst) (lst_eq_arg1 : Lst) : Prop
           := match lst_eq_arg0, lst_eq_arg1 with
              | x, y => and (lst_subset x y) (lst_subset y x)
              end.

Fixpoint lst_union (lst_union_arg0 : Lst) (lst_union_arg1 : Lst) : Lst
           := match lst_union_arg0, lst_union_arg1 with
              | nil, x => x
              | cons n x, y => if lst_mem n y then lst_union x y else cons n (lst_union x y)
              end.

Lemma subset_cons: forall l1 l2 n, lst_subset l1 l2 -> lst_subset l1 (cons n l2).
Proof.
  induction l1.
  - intros. reflexivity.
  - intros. simpl. split.
    * apply IHl1. inversion H. assumption.
    * destruct (beq_nat n n0). reflexivity. simpl.
      inversion H. assumption.
Qed.

Lemma beq_nat_refl: forall n, beq_nat n n = true.
Proof.
  induction n. reflexivity. simpl. assumption.
Qed.

Lemma subset_refl : forall (x : Lst), lst_subset x x.
Proof.
induction x. simpl. reflexivity.
simpl. split.
- apply subset_cons. assumption.
- rewrite beq_nat_refl. reflexivity.
Qed.

Theorem theorem0 : forall (x : Lst) (y : Lst), lst_subset x y -> lst_eq (lst_union x y) y.
Proof.
  intros.
  induction x.
  - simpl. unfold lst_eq. split.
    + apply subset_refl.
    + apply subset_refl.
  - simpl. simpl in H. destruct H. rewrite H0. apply IHx. assumption.
Qed.

(* This proof uses subset_cons above -- the goal is exactly the consequent of that lemma, but we also need a hypothesis. *)
Theorem theorem1: forall (x : Lst) (y : Lst), lst_subset x (append x y).
Proof.
  induction x.
  - intros. simpl. reflexivity.
  - intros. simpl. split.
    * apply subset_cons. apply IHx.
    * rewrite beq_nat_refl. simpl. reflexivity.
Qed.

(* This one does as well, and also reflexivity. Again, no synthesis or generalization. *)
Theorem theorem2: forall (x : Lst) (y : Lst), lst_subset y (append x y).
Proof.
  induction x.
  - intros. simpl. apply subset_refl.
  - intros. simpl. apply subset_cons. apply IHx.
Qed.

Lemma mem_union: forall n x y,
  lst_mem n y = true ->
  lst_mem n (lst_union x y) = true.
intro. induction x.
- intros. simpl. assumption.
- intros. simpl. destruct (lst_mem n0 y).
  * apply IHx. assumption.
  * simpl. destruct (beq_nat n n0). reflexivity.
    simpl. apply IHx. assumption.
Qed.

(* Same here. *)
Theorem theorem3: forall (x : Lst) (y : Lst), lst_subset x (lst_union x y).
Proof.
  intros. induction x.
  - simpl. reflexivity.
  - simpl. split.
    * destruct (lst_mem n y).
      +  assumption.
      + apply subset_cons. assumption.
    * remember (lst_mem n y) as m.
      destruct m.
      -- apply mem_union. rewrite Heqm.
         reflexivity.
      -- simpl. rewrite beq_nat_refl. 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.

Definition geb (n m : nat) := m <=? n.
(* Hint Unfold geb : core. *)
Infix ">=?" := geb (at level 70) : nat_scope.
Definition gtb (n m : nat) := m <? n.
(* Hint Unfold gtb : core. *)
Infix ">?" := gtb (at level 70) : nat_scope.

(* Try lia. *)
Example lia_example :
  forall i j k,
    i > j -> k > i + 3 -> k > j.
Proof.
  intros. lia.
Qed.

Definition swap(l : list nat) : list nat :=
  match l with
  | a :: b :: l' => if a >? b then b :: a :: l' else l
  | _ => l
  end.

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.
Lemma gtb_reflect : forall x y, reflect (x > y) (x >? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.ltb_lt.
Qed.
Lemma geb_reflect : forall x y, reflect (x >= y) (x >=? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.leb_le.
Qed.

Example reflect_example1: forall a,
    (if a <? 5 then a else 2) < 6.
Proof.
  intros.
  destruct (ltb_reflect a 5); lia.
Qed.

Hint Resolve ltb_reflect leb_reflect gtb_reflect geb_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;
    [ auto with bdestruct
    | destruct H as [H|H];
       [ | try first [apply not_lt in H | apply not_le in H]]].

Theorem swap_is_idempotent : forall l,
  swap (swap l) = swap l.
Proof.
  intros. destruct l as [| lhs l].
  - reflexivity.
  - destruct l as [| rhs l].
    + reflexivity.
    + simpl. bdestruct (lhs >? rhs).
      * simpl. bdestruct (rhs >? lhs). lia. trivial.
      * simpl. bdestruct (lhs >? rhs). lia. trivial.
Qed.

Check perm_skip.
Check perm_trans.
Check Permutation_refl.
Check Permutation_app_comm.
Check app_assoc.
Check app_nil_r.
Check app_comm_cons.

Example permut_example: forall (a b: list nat),
  Permutation (5 :: 6 :: a ++ b) ((5 :: b) ++ (6 :: a ++ [])).
Proof.
  intros.
  simpl. rewrite app_nil_r.
  apply perm_trans with (5 :: 6 :: (b ++ a)).
  - apply perm_skip. apply perm_skip. apply Permutation_app_comm.
  - apply perm_skip. apply perm_trans with (6 :: a ++ b).
    + apply perm_skip. apply Permutation_app_comm.
    + replace (6 :: a ++ b) with ((6 :: a) ++ b). apply Permutation_app_comm. trivial.
Qed.

Check Permutation_cons_inv.
Check Permutation_length_1_inv.

(* The point is, [1] != [2]. *)
Example not_a_permutation:
  ~ Permutation [1;1] [1;2].
Proof.
  unfold not. intros.
  apply Permutation_cons_inv in H. inversion H.
  apply Permutation_length_1_inv in H0.
  apply Permutation_sym in H1. apply Permutation_length_1_inv in H1.
  rewrite H0 in H1. inversion H1.
Qed.

(*
Now we can prove that maybe_swap is a permutation: it reorders elements but does not add or remove any.
*)

Theorem swap_perm : forall l,
  Permutation l (swap l).
Proof.
  intros. destruct l.
  - trivial.
  - destruct l.
    + trivial.
    + simpl. bdestruct (n >? n0).
      * apply perm_swap.
      * trivial.
Qed.

Definition first_le_second (l : list nat) : Prop :=
  match l with
  | a :: b :: l' => a <= b
  | _ => True
  end.

Theorem swap_correct : forall l,
  Permutation l (swap l) /\ first_le_second (swap l).
Proof.
  intros. split.
  - apply swap_perm.
  - destruct l.
    + reflexivity.
    + simpl. destruct l.
      * reflexivity.
      * unfold first_le_second. bdestruct (n >? n0); lia.
Qed.

(* Forall is Coq library's version of the All proposition defined in Logic, but defined as an inductive
proposition rather than a fixpoint. Prove this lemma by induction. You will need to decide what to induct
on: al, bl, Permutation al bl, and Forall f al are possibilities. *)
Theorem Forall_perm: forall {A} (f: A -> Prop) al bl,
  Permutation al bl ->
  Forall f al -> Forall f bl.
Proof.
  intros. induction H.
  - apply H0.
  - apply Forall_cons. apply Forall_inv in H0.
    apply H0. apply Forall_inv_tail in H0.
    apply IHPermutation in H0. apply H0.
  - apply Forall_cons. apply Forall_inv_tail in H0. apply Forall_inv in H0. apply H0.
    apply Forall_cons. apply Forall_inv in H0. apply H0. apply Forall_inv_tail in H0. apply Forall_inv_tail in H0. apply H0.
  - apply IHPermutation2. apply IHPermutation1. apply H0.
Qed.


(* exercise 3.2 *)

Section exercise_3_2.
  Variable (P Q R : Prop).

  Lemma id_P : P -> P.
  Proof.
    intro p.
    assumption.
  Qed.

  Lemma id_PP : (P -> P) -> (P -> P).
  Proof.
    intros pp p.
    assumption.
  Qed.

  Lemma imp_trans : (P -> Q) -> (Q -> R) -> (P -> R).
  Proof.
    intros pq qr p.
    apply qr.
    apply pq.
    assumption.
  Qed.

  Lemma imp_perm : (P -> Q -> R) -> (Q -> P -> R).
  Proof.
    intros pqr q r.
    apply pqr.
    assumption.
    assumption.
  Qed.

  Lemma ignore_Q : (P -> R) -> P -> Q -> R.
  Proof.
    intros pr p q.
    apply pr.
    assumption.
  Qed.

  Lemma delta_imp : (P -> P -> Q) -> P -> Q.
  Proof.
    intros ppq p.
    apply ppq.
    assumption.
    assumption.
  Qed.

  Lemma delta_impR : (P -> Q) -> (P -> P -> Q).
  Proof.
    intros pq p p2.
    apply pq.
    assumption.
  Qed.

  Variable T : Prop.

  Lemma diamond : (P -> Q) -> (Q -> R) -> (Q -> R -> T) -> P -> T.
  Proof.
    intros pq qr qrt p.
    apply qrt.
    apply pq.
    assumption.
    apply qr.
    apply pq.
    assumption.
  Qed.

  Lemma weak_pierce : ((((P -> Q) -> P) -> P) -> Q) -> Q.
  Proof.
    intro pqppq.
    apply pqppq.
    intro pqp.
    apply pqp.
    intro p.
    apply pqppq.
    intro pqp2.
    assumption.
  Qed.
End exercise_3_2.


From NaturalNumbers Require Export Base Tutorial Addition
    Multiplication Power Proposition AdvProposition AdvAddition AdvMultiplication.

Definition le (a b : mynat) := exists (c : mynat), b = a + c.

Infix "<=" := le.
Notation "(<=)" := le (only parsing).
Notation "( f <=)" := (le f) (only parsing).
Notation "(<= f )" := (fun g => le g f) (only parsing).

Fact le_iff_exists_add (a b : mynat) : a <= b <-> exists (c : mynat), b = a + c.
Proof.
    split.
    - trivial.
    - trivial.
Qed.

(* Level 0 data *)
(* name `one_add_le_self` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
I have just added a new definition, that of `<=`. The statment
`a <= b` is defined to mean
```exists (c : mynat), b = a + c```
In other words, we can find some `c : mynat` such that `b = a + c`.

If you really want, you can use the lemma I have added,
```
#Fact le_iff_exists_add (a b : mynat) : a <= b <-> exists (c : mynat), b = a + c.
```
to rewrite `<=` into the `exists` statment, but it is not really necessary,
since Coq knows what `<=` means, so you can just treat it as if it is written
like the `exists` statement already.

Now how does one go about proving an `exists` statement? There is a tactic,
also called `exists`, that we can use. Basically, if we have to prove something
of the form
`exists (c : mynat), 1 + x = x + c`,
typing `exists 1.` substitutes `1` for `c` in the equation, and turns our goal
into `1 + x = x + 1`. Now you can easily use the powerful `ring` tactic to
finish the proof. Try it yourself below!
*)
Lemma one_add_le_self (x : mynat) : x <= 1 + x.
Proof.
    exists 1.
    ring.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 1 data *)
(* name `le_refl` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
Here is an easy one, try using the `exists` tactic with
the right value for `c` to solve this one!
*)
Lemma le_refl (x : mynat) : x <= x.
Proof.
    exists 0.
    ring.
Qed.
(* Level epilogue *)
(*
Now we have shown that `<=` is a reflexive equation.
I can now power up our `reflexivity` tactic, by typing
```
Require Import Coq.Classes.RelationClasses.
Global Instance le_Reflexive : Reflexive le := le_refl.
```
which allows us to prove statements like the following a lot
easier:
```
#Example refl : 0 <= 0.
#Proof.
#    reflexivity.
#Qed.
```
*)
(* Level end *)

Require Import Coq.Classes.RelationClasses.

Global Instance le_Reflexive : Reflexive le := le_refl.

Example refl : 0 <= 0.
Proof.
    reflexivity.
Qed.

(* Level 2 data *)
(* name `le_succ` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
Okay, we have seen how goals with `exists` work, but what if we have
a hypothesis with an `exists` statement? Well, we can use our `destruct`
tactic to obtain the variable that exists, and a witness for the statement
in the `exists` statement.

Basically, in this level, if we `intro h` we obtain `h : a <= b`. If we type
```
destruct h as [c H].
```
we obtain
```
c : mynat
H : b = a + c
```
Try it out below.
*)
Lemma le_succ (a b : mynat) : a <= b -> a <= S b.
Proof.
    intro h.
    destruct h as [c H].
    exists (S c).
    now rewrite H, add_succ.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 3 data *)
(* name `zero_le` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
Another easy one.
*)
Lemma zero_le (a : mynat) : 0 <= a.
Proof.
    exists a.
    ring.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 4 data *)
(* name `le_trans` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
Again, this one should not be too tough.
*)
Lemma le_trans (a b c : mynat) (hab : a <= b) (hbc : b <= c) : a <= c.
Proof.
    destruct hab as [ca ha].
    destruct hbc as [cb hb].
    rewrite ha in hb.
    exists (ca + cb).
    rewrite hb.
    ring.
Qed.
(* Level epilogue *)
(*
We have shown that `<=` is transitive. I can type the following
```
#Global Instance le_Transitive : Transitive le := le_trans.
#Global Instance le_PreOrder : PreOrder le.
#Proof.
#    constructor.
#    - exact le_Reflexive.
#    - exact le_Transitive.
#Qed.
```
to let Coq know that `<=` actually defines a preorder on `mynat`.
*)
(* Level end *)

Global Instance le_Transitive : Transitive le := le_trans.
Global Instance le_PreOrder : PreOrder le.
Proof.
    constructor.
    - exact le_Reflexive.
    - exact le_Transitive.
Qed.

(* Level 5 data *)
(* name `le_antisymm` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
In advanced addition world, we have shown
```
#Lemma eq_zero_of_add_right_eq_self {a b : mynat} : a + b = a -> b = 0.
```
which might be useful here. Remember you can use `specialize` to create
new hypotheses out of ones you have, and theorems we have shown before.
So if we have `hd : a + (c + d) = a` and we want `h : c + d = 0`, you
can write
```
specialize (eq_zero_of_add_right_eq_self hd) as h.
```
to do so.
*)
Lemma le_antisymm (a b : mynat) (hab : a <= b) (hba : b <= a) : a = b.
Proof.
    destruct hab as [ca ha].
    destruct hba as [cb hb].
    rewrite ha, add_assoc in hb.
    symmetry in hb.
    specialize (eq_zero_of_add_right_eq_self hb) as hcacb.
    specialize (add_right_eq_zero hcacb) as hca.
    rewrite hca, add_zero in ha.
    symmetry.
    exact ha.
Qed.
(* Level epilogue *)
(*
We have now shown that `<=` is a partial order! I typed
```
#Global Instance le_Antisymmetric : Antisymmetric _ _ le := le_antisymm.
#Global Instance le_PartialOrder : PartialOrder _ le.
#Proof.
#    constructor.
#    - intro h.
#      split; now exists 0.
#    - intro h.
#      destruct h as [h1 h2].
#      exact ((le_antisymm x x0) h1 h2).
#Qed.
```
to let Coq know it is.
*)
(* Level end *)

Global Instance le_Antisymmetric : Antisymmetric _ _ le := le_antisymm.
Global Instance le_PartialOrder : PartialOrder _ le.
Proof.
    constructor.
    - intro h.
      split; now exists 0.
    - intro h.
      destruct h as [h1 h2].
      exact ((le_antisymm x x0) h1 h2).
Qed.

(* Level 6 data *)
(* name `le_zero` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
Remember the `symmetry` tactic? You can also use `symmetry`
in hypothesis by for example writing `symmetry in h` if
`h` is a hypothesis you have. It may come in useful in this level.
*)
Lemma le_zero (a : mynat) (h : a <= 0) : a = 0.
Proof.
    destruct h as [c h].
    symmetry in h.
    exact (add_right_eq_zero h).
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 7 data *)
(* name `succ_le_succ` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
Another straightforward one.
*)
Lemma succ_le_succ (a b : mynat) (h : a <= b) : S a <= S b.
Proof.
    destruct h as [c h].
    exists c.
    now rewrite h, succ_add.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 8 data *)
(* name `le_total` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
Try using `revert a` to prove this one, otherwise you
might get stuck!
*)
Lemma le_total (a b : mynat) : a <= b \/ b <= a.
Proof.
    revert a.
    induction b as [| ? h].
    - intro a.
      right. exact (zero_le a).
    - intro a.
      destruct a.
      * left. exact (zero_le (S b)).
      * specialize (h a) as h.
        destruct h.
        + left. now apply succ_le_succ.
        + right. now apply succ_le_succ.
Qed.
(* Level epilogue *)
(*
We have now shown that `<=` defines a linear order. Sadly
Coq does not have a builtin class for this.
*)
(* Level end *)

(* Total order? *)

(* Level 9 data *)
(* name `le_succ_self` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
It is possible to write a two line proof for this level!
*)
Lemma le_succ_self (a : mynat) : a <= S a.
Proof.
    rewrite succ_eq_add_one.
    now exists 1.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 10 data *)
(* name `add_le_add_right` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
Remember to use the `intro` tactic on `forall` goals!
*)
Lemma add_le_add_right {a b : mynat} : a <= b -> forall (t : mynat), (a + t) <= (b + t).
Proof.
    intros h t.
    induction t as [| ? ht].
    - now simpl.
    - repeat rewrite add_succ.
      now apply succ_le_succ.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 11 data *)
(* name `le_of_succ_le_succ` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
Lemma le_of_succ_le_succ (a b : mynat) : S a <= S b -> a <= b.
Proof.
    intro h.
    destruct h as [c hc].
    rewrite succ_add in hc.
    exists c.
    now rewrite eq_iff_succ_eq_succ in hc.

    (* now inversion hc. *)
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 12 data *)
(* name `not_succ_le_self` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
Remember to `unfold not` to turn negations `~P` into `P -> False`.
*)
Lemma not_succ_le_self (a : mynat) : ~(S a <= a).
Proof.
    unfold not.
    intro h.
    induction a as [| ? ha].
    - specialize (le_zero (S 0)) as h1.
      apply (succ_ne_zero 0).
      exact (h1 h).
    - apply ha.
      apply le_of_succ_le_succ.
      exact h.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 13 data *)
(* name `add_le_add_left` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
These levels may seem easy, but they are the things we need
to show that `mynat` is in fact an ordered commutative monoid.
*)
Lemma add_le_add_left {a b : mynat} (h : a <= b) (t : mynat) : t + a <= t + b.
Proof.
    rewrite add_comm, (add_comm t b).
    exact (add_le_add_right h _).
Qed.
(* Level epilogue *)
(* Level end *)

Definition lt (a b : mynat) := (a <= b) /\ ~(b <= a).

Infix "<" := lt.
Notation "(<)" := le (only parsing).
Notation "( f <)" := (le f) (only parsing).
Notation "(< f )" := (fun g => le g f) (only parsing).

(* Level 14 data *)
(* name `lt_aux_one` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
I have just introduced the definition of `<`. By definition,
`a < b` is the same as `(a <= b) /\ ~(b <= a)`.
Remember to use the `destruct` tactic.
*)
Lemma lt_aux_one (a b : mynat) : a  S a <= b.
Proof.
    intro h.
    destruct h as [hab hnba].
    destruct hab as [c habc].
    destruct c.
    - exfalso.
      rewrite add_zero in habc.
      apply hnba.
      rewrite habc.
      reflexivity.
    - rewrite habc.
      rewrite add_succ.
      exists c.
      now rewrite succ_add.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 15 data *)
(* name `lt_aux_two` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
Now the other way.
*)
Lemma lt_aux_two (a b : mynat) : S a <= b -> a <= b /\ ~(b <= a).
Proof.
    intro h.
    split.
    - apply (le_trans a (S a) b); trivial.
      * exact (le_succ_self a).
    - unfold not.
      intro k.
      specialize (le_trans (S a) b a) as haSab.
      apply (not_succ_le_self a).
      now apply haSab.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 16 data *)
(* name `lt_iff_succ_le` *)
(* tactics exists *)
(* theorems le_iff_exists_add *)
(* Level prologue *)
(*
Alright, we can combine the previous levels
(`lt_aux_one` and `lt_aux_two`) into this if and only
if statement, and then we have shown that `mynat` is an ordered
cancellative commutative monoid.
*)
Lemma lt_iff_succ_le (a b : mynat) : a < b <-> (S a) <= b.
Proof.
    split.
    - exact (lt_aux_one _ _).
    - exact (lt_aux_two _ _).
Qed.
(* Level epilogue *)
(*
That's it for the natural numbers game! If you enjoyed, feel
free to leave a star on the
source code on GitHub.

I hope this helped you learn a bit about Coq and proof formalization.
*)
(* Level end *)


(*
  CPDTより：
  Some more recent Coq features provide more convenient syntax for
  defining recursive functions.  Interested readers can consult the
  Coq manual about the commands %\index{Function}%[Function] and
  %\index{Program Fixpoint}%[Program Fixpoint].
*)

(* オリジナルは、CPDTの  GeneralRec.v *)

Require Import Arith List Omega.
Require Import Cpdt.CpdtTactics Cpdt.Coinductive.
Require Import Permutation Sorted Program Recdef.

Set Implicit Arguments.
Set Asymmetric Patterns.

Section mergeSort.
  Variable A : Type.
  Variable le : A -> A -> bool.

  Fixpoint insert (x : A) (ls : list A) : list A :=
    match ls with
      | nil => x :: nil
      | h :: ls' =>
        if le x h
          then x :: ls
          else h :: insert x ls'
    end.

  Fixpoint merge (ls1 ls2 : list A) : list A :=
    match ls1 with
      | nil => ls2
      | h :: ls' => insert h (merge ls' ls2)
    end.

  Fixpoint split (ls : list A) : list A * list A :=
    match ls with
      | nil => (nil, nil)
      | h :: nil => (h :: nil, nil)
      | h1 :: h2 :: ls' =>
        let (ls1, ls2) := split ls' in
          (h1 :: ls1, h2 :: ls2)
    end.

  (* yoshihiro *)
  Lemma split_length : forall zs xs ys,
      split zs = (xs, ys) -> length zs = length xs + length ys.
  Proof.
  Admitted.

  (* yoshihiro *)
  Function mergesort (xs : list A) {measure length xs} : list A :=
    match xs with
    | nil => nil
    | x::nil => x::nil
    | x::y::zs =>
      match split (x::y::zs) with
      | (xs, ys) => merge (mergesort xs) (mergesort ys)
      end
    end.
  Proof.
    - intros xs x l ys zs teq0 teq xs0 ys0 teq1.
      Check (@split_length (x :: ys :: zs) xs0 ys0 teq1).
      Check (@split_length _ _ _ teq1).
      rewrite (@split_length _ _ _ teq1).
      simpl in teq1.
      generalize teq1.
      case (split zs).
      intros.
      inversion teq2.
      now crush.
    - intros xs x l ys zs teq0 teq xs0 ys0 teq1.
      rewrite (@split_length _ _ _ teq1).
      simpl in teq1.
      generalize teq1.
      case (split zs).
      intros.
      inversion teq2.
      now crush.
  Defined.

  (* CPDT オリジナル *)
  Definition lengthOrder (ls1 ls2 : list A) :=
    length ls1 < length ls2.

  Lemma split_wf1 : forall ls, 2 <= length ls
    -> lengthOrder (fst (split ls)) ls.
  Admitted.

  Lemma split_wf2 : forall ls, 2 <= length ls
    -> lengthOrder (snd (split ls)) ls.
  Admitted.

  Lemma split_wf1' : forall ls, 2 <= length ls
    -> length (fst (split ls)) < length ls.
  Proof.
    pose split_wf1 as H.
    unfold lengthOrder in H.
    crush.
  Qed.

  Lemma split_wf2' : forall ls, 2 <= length ls
    -> length (snd (split ls)) < length ls.
  Proof.
    pose split_wf2 as H.
    unfold lengthOrder in H.
    crush.
  Qed.

  (*  Hint Resolve split_wf1 split_wf2. *)
  Hint Resolve split_wf1' split_wf2'.

  Function mergeSort (ls : list A) {measure length ls} : list A :=
    if le_lt_dec 2 (length ls) then
      let lss := split ls in
      merge (mergeSort (fst lss)) (mergeSort (snd lss))
    else
      ls.
  Proof.
    - auto.
    - auto.

      (*
    - pose split_wf2 as H.
      unfold lengthOrder in H.
      crush.
    - pose split_wf1 as H.
      unfold lengthOrder in H.
      crush.
       *)

      (*
      rewrite (split_length' ls).
      case (le_lt_dec 2 (length ls)); intros H.
      + apply (split_len_1 ls) in H.
        crush.
      + crush.                              (* len ls < 2 で矛盾  *)
    - intros ls le2 teq2.
      rewrite (split_length' ls).
      case (le_lt_dec 2 (length ls)); intros H.
      + apply (split_len_2 ls) in H.
        crush.
      + crush.                              (* len ls < 2 で矛盾  *)
*)
  Defined.
(*
mergeSort_tcc is defined
mergeSort_terminate is defined
mergeSort_ind is defined
mergeSort_rec is defined
mergeSort_rect is defined
R_mergeSort_correct is defined
R_mergeSort_complete is defined
*)

  Check mergeSort_ind : forall P : list A -> list A -> Prop,
       (forall (ls : list A) (_x : 2 <= length ls),
        le_lt_dec 2 (length ls) = in_left ->
        let lss := split ls in
        P (fst lss) (mergeSort (fst lss)) ->
        P (snd lss) (mergeSort (snd lss)) ->
        P ls (merge (mergeSort (fst lss)) (mergeSort (snd lss)))) ->
       (forall (ls : list A) (_x : length ls < 2),
        le_lt_dec 2 (length ls) = in_right -> P ls ls) ->
       forall ls : list A, P ls (mergeSort ls)

End mergeSort.

Extraction merge.
Extraction split.
Extraction mergeSort.

(* END *)


Require Import Le Lt.

Inductive Vec (A : Type) : nat -> Type :=
  | Vnil : Vec A 0
  | Vcon : forall {n : nat} (hd : A) (tl : Vec A n), Vec A (S n).

Arguments Vnil {A}.
Arguments Vcon [A n] hd tl.

Fixpoint Vget {A : Type} {n : nat} (v : Vec A n) (m : nat) (mltn : m < n) : A.
destruct v.
 apply False_rect ; eapply lt_n_O ; eassumption.
 destruct m.
  exact hd.
  eapply Vget ; [| eapply lt_S_n ] ; eassumption.
Defined.

Definition Vec_ext {A n} (v1 v2 : Vec A n) :=
  forall (p : nat) (pr : p < n), Vget v1 p pr = Vget v2 p pr.

Fixpoint Vconcat {A : Type} {m n : nat} (v1 : Vec A m) (v2 : Vec A n) : Vec A (m + n) :=
match v1 in Vec _ m return Vec A (m + n) with
  | Vnil         => v2
  | Vcon hd tl => Vcon hd (Vconcat tl v2)
end.

Fixpoint Vupdate {A : Type} {n : nat} (v : Vec A n) (m : nat) (mltn : m < n) (a : A)
 {struct v} : Vec A n.
destruct v.
 constructor.
 destruct m.
  constructor ; [exact a | exact v].
  constructor.
   exact hd.
   eapply (Vupdate _ _ v m (lt_S_n _ _ mltn) a).
Defined.

Fixpoint Vmap {A B : Type} {n : nat} (f : A -> B) (v : Vec A n) : Vec B n :=
match v in (Vec _ n0) return (Vec B n0) with
  | Vnil         => Vnil
  | Vcon hd tl => Vcon (f hd) (Vmap f tl)
end.

Fixpoint Vmap_full {A B : Type} {n : nat} (f : forall (m : nat) (mltn : m < n), A -> B)
  (v : Vec A n): Vec B n.
destruct v.
 constructor.
 constructor.
  exact (f O (lt_0_Sn _) hd).
  eapply Vmap_full.
  eexact (fun  m mltn => f (S m) (lt_n_S _ _ mltn)).
  assumption.
Defined.

Fixpoint genVec_cst {A : Type} (n : nat) (a : A) : Vec A n :=
match n with
  | O    => Vnil
  | S n' => Vcon a (genVec_cst n' a)
end.

Definition genVec_pr (n : nat) : Vec {p |  p < n} n :=
  Vmap_full (fun m mltn _ => exist (fun p => p < n) m mltn) (genVec_cst n O).

Definition genVec (n : nat) : Vec nat n :=
  Vmap_full (fun m _ _ => m) (genVec_cst n O).

Definition genVec_P {A : Type} (n : nat) (P : forall m, m < n -> A) : Vec A n :=
  Vmap_full (fun m mltn _ => P m mltn) (genVec_cst n 0).

(*
Definition genVec2 (n : nat) : Vec nat n := genVec_P n (fun m _ => m).
*)


Theorem pair_eq : forall (A B: Type)(a a': A)(b b': B),
(a, b) = (a', b') <-> a = a' /\ b = b'.
Proof.
unfold iff. intros. apply conj.
- intros. injection H. intros. apply conj. apply H1. apply H0.
- intros. apply proj1 in H as H1. apply proj2 in H as H2.
  rewrite H1. rewrite H2. reflexivity.
Qed.

Definition Relation (A B : Type) : Type := (prod A B -> Prop).

Axiom Relation_eq : forall {A B} (R S : Relation A B),
(forall (a:A)(b:B), R(a, b) <-> S(a, b)) <-> R = S.

Definition dom {A B}(R : Relation A B) : (A -> Prop) :=
(fun x => (exists y:B, R(x, y))).

Definition ran {A B}(R : Relation A B) : (B -> Prop) :=
(fun y => (exists x:A, R(x, y))).

Definition image {A B}(R : Relation A B) : ((A -> Prop) -> (B -> Prop)) :=
(fun A_ => (fun y => (exists x:A, A_ x -> R(x, y)))).

Definition inv_image {A B}(R : Relation A B) : ((B -> Prop) -> (A -> Prop)) :=
(fun B_ => (fun x => (exists y:B, B_ y -> R(x, y)))).

Definition inv {A B}(R : Relation A B) : Relation B A :=
(fun p => (match p with
  | (b,a) => R(a, b)
end)).

Definition composition {A B C} (R : Relation A B) (S : Relation B C) : Relation A C :=
(fun p => (match p with
  | (a, c) => exists b, R(a, b) /\ S(b, c)
end)).

Definition symmetric {A} (R : Relation A A) : Prop :=
forall (a b : A), R(a, b) -> R(b, a).

Definition antisymmetric {A} (R : Relation A A) : Prop :=
forall (a b : A), R(a, b) -> R(b, a) -> a = b.

Definition asymmetric {A} (R: Relation A A) : Prop :=
forall (a b : A), R(a, b) -> not (R(b, a)).

Definition transitive {A} (R: Relation A A) : Prop :=
forall (a b c : A), R(a, b) -> R(b, c) -> R(a, c).

Definition reflexive {A} (R : Relation A A) : Prop :=
forall (a : A), R(a, a).

Definition injective {A B} (R : Relation A B) : Prop :=
forall (a1 a2 : A)(b : B), R(a1, b) -> R(a2, b) -> a1 = a2.

Definition functional {A B} (R : Relation A B) : Prop :=
forall (a : A)(b1 b2 : B), R(a, b1) -> R(a, b2) -> b1 = b2.

Definition one_to_one {A B} (R : Relation A B) : Prop :=
injective R /\ functional R.

Definition left_total {A B} (R : Relation A B) : Prop :=
forall (a : A), exists (b : B), R(a, b).

Definition surjective {A B} (R : Relation A B) : Prop :=
forall (b : B), exists (a : A), R(a, b).

Definition equiv {A} (R : Relation A A) : Prop :=
reflexive R /\ transitive R /\ symmetric R.


Require Import Arith.

Inductive fact_domain : nat -> Prop :=
| fact_domain_zero :
  fact_domain 0
| fact_domain_pos :
  forall n : nat, fact_domain (n-1) -> fact_domain n.

Theorem fact_domain_pos_true : forall n : nat, fact_domain n -> 0 <= n.
Proof.
  intros n H. case H. auto with arith.
  intros n' H'. case H'. auto with arith.
  intros n'' H''. auto with arith.
Defined.

Theorem fact_domain_inv :
  forall n : nat, fact_domain n -> 0 < n -> fact_domain (n-1).
Proof.
  intros n H Hlt. case H. simpl. apply fact_domain_zero.
  intros n0' H'. auto.
Defined.
Transparent fact_domain_inv.

Require Import Arith.

Print fact_domain_inv.

Fixpoint fact (n : nat) (h : fact_domain n) {struct h} : nat :=
  match lt_eq_lt_dec n 0 with
    | inleft hle =>
      match hle with
        | left nlt0 => False_rec nat (lt_n_O n nlt0)
        | right neq0 => 1
      end
    | inright hgt =>
      match h in (fact_domain n) return (fact_domain (n - 1)) with
        | fact_domain_zero => fact_domain_zero
        | fact_domain_pos _ H' => n * (fact (n-1) H')
      end
  end.

(fact_domain_inv n h hgt))
  end.

Definition fact (n: nat) (h : fact_domain n) : nat.
Proof.
  refine
    (fix f (n : nat) (h : fact_domain n) {struct h} :=
      match le_gt_dec n 0 with
        | left _ => 1
        | right hgt => n * (f (n-1) (fact_domain_inv n h hgt))
      end).
  destruct n. inversion hgt.
  simpl. cut (n-0 = n). intros. inversion h. simpl in *. rewrite H in *.
  auto. auto with arith.
Defined.

Require Import Ascii.
Require Import String.

Inductive Suffix (s:string) : string -> Prop :=
| suffix_refl : Suffix s s
| suffix_next : forall s' c, Suffix s s' -> Suffix s (String c s').
Hint Constructors Suffix.

Lemma Suffix_empty : forall (s:string), Suffix "" s.
Proof.
  induction s ; auto ; destruct s ; auto.
Defined.
Hint Resolve Suffix_empty.

Lemma Suffix_both : forall (s' s:string) c c',
  Suffix (String c s) (String c' s') -> Suffix s s'.
Proof.
  induction s' ;intros ; inversion H ; subst ; auto. inversion H1.
  apply suffix_next. eapply IHs'. eauto.
Defined.

Definition ProperSuffix (s s':string) := exists c, Suffix (String c s) s'.
Hint Unfold ProperSuffix.

Lemma ProperSuffix_irrefl (s :string) : ~ ProperSuffix s s.
Proof.
  induction s. unfold not. intros. inversion H.
  inversion H0.
  unfold not. intros. inversion H.
  eapply Suffix_both in H0.
  cut (ProperSuffix s s). intros. auto.
  eauto.
Defined.

Lemma ProperSuffix_not_empty (s :string) : ~ProperSuffix s "".
Proof.
  induction s. unfold  not. intros. inversion H. inversion H0.
  unfold not. intros. inversion H. inversion H0.
Defined.

Lemma ProperSuffix_both : forall (s s':string) c c',
  ProperSuffix (String c s) (String c' s') -> ProperSuffix s s'.
Proof.
  destruct s; intros. inversion H ; subst ; auto.
  apply Suffix_both in H0. unfold ProperSuffix.
  exists c. auto.

  inversion H. apply Suffix_both in H0.
  unfold ProperSuffix. exists c. auto.
Defined.

Definition SuffixFamily (s:string) := {s' | Suffix s' s}.


Require Import Arith Omega.
Require Import List.
Require Import Sorted.

Definition P {A} (u v : list A) := exists x, In x u /\ In x v.

Definition Spec (f : list nat -> list nat -> bool) := forall u v, StronglySorted (lt) u -> StronglySorted (lt) v -> if f u v then P u v else ~ P u v.

Definition Spec' (f : list nat * list nat -> bool) := forall uv, StronglySorted (lt) (fst uv) -> StronglySorted (lt) (snd uv) -> if f uv then P (fst uv) (snd uv) else ~ P (fst uv) (snd uv).

Require Import Recdef.

Definition totallen (uv : list nat * list nat) := length (fst uv) + length (snd uv).

Function intp (uv : list nat * list nat) {measure totallen} : bool :=
  match fst uv with
    | nil => false
    | x :: xs =>
      match snd uv with
        | nil => false
        | y :: ys =>
          match lt_eq_lt_dec x y with
            | inleft (left _) (* x < y *) => intp (xs, y :: ys)
            | inleft (right _) (* x = y *) => true
            | inright _ (* x > y *) => intp (x :: xs, ys)
          end
      end
  end.

unfold totallen; intros; destruct uv; simpl in *; subst; simpl.
omega.

unfold totallen; intros; destruct uv; simpl in *; subst; simpl.
omega.
Defined.

Check (intp_ind (fun uv b => if b then P (fst uv) (snd uv) else ~ P (fst uv) (snd uv))).

Lemma not_P_nil {A} (v : list A) : ~ P nil v.
Proof.
  unfold P; intros [x [l r]].
  inversion l.
Qed.

Lemma not_P_nil2 {A} (v : list A) : ~ P v nil.
Proof.
  unfold P; intros [x [l r]].
  inversion r.
Qed.

Lemma P_head {A} (v : A) (us vs : list A) : P (v :: us) (v :: vs).
Proof.
  exists v; split; constructor; reflexivity.
Qed.

Lemma In_lemma (x a0 : nat) (v : list nat) :
  StronglySorted lt (a0 :: v) ->
  x < a0 ->
  ~In x (a0 :: v).
Proof.
  intros S l I.
  inversion I; subst.
  omega.
  destruct v.
  inversion H.
  inversion S; subst.
  destruct (Forall_forall (lt a0) (n :: v)) as [Lemma _].
  pose (Lemma H3 x H).
  omega.
Qed.

Theorem intp_Spec : Spec' intp.
Proof.
  unfold Spec'.

  intros uv.

  apply (intp_ind (fun uv b => StronglySorted lt (fst uv) -> StronglySorted lt (snd uv) -> if b then P (fst uv) (snd uv) else ~ P (fst uv) (snd uv))); simpl; intros;
  repeat match goal with
           | [ uv : (?a * ?b)%type |- _ ] => destruct uv
         end; simpl in *; subst.

  apply not_P_nil.

  apply not_P_nil2.

  unfold P in *.
  destruct (intp (xs, y :: ys)).
  Focus 1.
  assert (StronglySorted lt xs) as H2.
  inversion H0; assumption.
  destruct (H H2 H1) as [x' [L R]].
  exists x'; split.
  right; assumption.
  assumption.
  Focus 1.
  assert (StronglySorted lt xs) as H2.
  inversion H0; assumption.
  intro H3; apply (H H2 H1); clear H.
  destruct H3 as [x' [L R]].
  inversion L; subst.
  pose (In_lemma _ _ _ H1 _x R) as f.
  elim f.
  exists x'; split; assumption.

  unfold P in *.
  exists y; split; constructor; reflexivity.

  unfold P in *.
  destruct (intp (x :: xs, ys)).
  Focus 1.
  assert (StronglySorted lt ys) as H2.
  inversion H1; assumption.
  destruct (H H0 H2) as [x' [L R]].
  exists x'; split.
  assumption.
  right; assumption.
  Focus 1.
  assert (StronglySorted lt ys) as H2.
  inversion H1; assumption.
  intro H3; apply (H H0 H2); clear H.
  destruct H3 as [x' [L R]].
  inversion R; subst.
  pose (In_lemma _ _ _ H0 _x L) as f.
  elim f.
  exists x'; split; assumption.
Qed.

Extraction Language Ocaml.

Extraction intp.

(****

(** val intp : (nat list, nat list) prod -> bool **)

let rec intp uv =
  match fst uv with
  | Nil -> False
  | Cons (x, xs) ->
    (match snd uv with
     | Nil -> False
     | Cons (y, ys) ->
       (match lt_eq_lt_dec x y with
        | Inleft s ->
          (match s with
           | Left -> intp (Pair (xs, (Cons (y, ys))))
           | Right -> True)
        | Inright -> intp (Pair ((Cons (x, xs)), ys))))

 ***)


(** V tej lekciji bomo spoznali induktivne tipe.

    Najbolj znan primer induktivnega tipa so naravna števila.
    Drugi znani primeri so seznami in drevesa.

    Induktivni tip [T] definiran tako, da podamo nekaj
    _konstruktorjev_ (ki nimajo zveze s konstruktorji
    v objektnem programiranju)

      c_1 : ... -> T
      c_2 : ... -> T
      ...
      c_n : ... -> T

    Vsak od konstruktorjev sprejme še nič ali več argumentov
    različnih tipov (zgoraj označeno z ...). Nekateri argumenti
    so lahko spet tipa [T] (ali celo bolj splošni, v kar se tu ne
    bomo spuščali), zato so induktivni tipi _rekurzivni_.

    Elementi tipa [T] so vsi tisti izrazi oblike [c_i e_1 .. e_k]
    za katere so [e_1, ..., e_k] ustrezni argumenti in je [c_i]
    eden od konstruktorjev. Drugač povedano, elemente [T] gradimo
    _indkutivno_, začenši s konstruktorji brez argumentov.

    Na primer, naravna števila lahko definiramo takole.
*)

Inductive N :=
  | o : N
  | s : N -> N.

(** Imamo dva konstruktorja. Konstruktor [o] ne sprejme nobenega
    parametra, torej je to _konstanta_ tipa [nat]. Konstruktor [s]
    sprejme kot argument naravno število. Katere elemente lahko
    zgradimo s pomočjo teh dveh konstruktorjev? *)

Check o.
Check s o.
Check s (s o).
Check s (s (s o)).
Check s (s (s (s o))).

(** Res dobivamo naravna števila. Ker je tip _indkutiven_
    "neskončni" izraz [s (s (s (s ...)))], v katerem se [s]
    v nedogled ponavlja, _ni_ veljaven. Coq pozna tudi _koinduktivne_
    tipe, ki vsebujejo tudi neskončne izraze.
*)

(** Tudi seznami so induktivni tip. Takole definiramo sezname,
    ki imajo elemente tipa [A]:  *)

Inductive seznam (A : Type) :=
  | prazen : seznam A
  | sestavi : A -> seznam A -> seznam A.

(** To definicijo preberemo takole: definirali smo
    induktivni tip [seznam], ki je parameteriziran s
    tipom [A]. To pomeni, da za vsak tip [A] dobimo
    tip [seznam A]. Elementi tipa [seznam A] so:

    - [prazen A] je element tipa [seznam A],
    - [sestavi A x l] je element tipa [seznam A], pri predpostavki
      da je [x : A] in [l : seznam A].

    Tu je nekaj seznamov tipa [seznam bool]. *)

Check prazen bool. (* prazen seznam *)
Check sestavi bool false (sestavi bool true (prazen bool)). (* seznam [false, true] *)

(* Kot vidimo, je treba vedno povedati tip [A], kar je precej
   nepraktično. Coq-u lahko razložimo, da naj bo [A] impicitni argument
   pri konstruktorjih [prazen] in [sestavi].
   Tako ga bo Coq sam izračunal iz ostalih podatkov (ali se pritožil,
   če ne bo znal. *)

Arguments prazen {A}.
Arguments sestavi {A} _ _.

(** Sedaj lahko pišemo krajše: *)

Check @prazen bool. (* prazen seznam elementov tipa [bool]. *)
Check sestavi false (sestavi true prazen). (* seznam [false, true] *)

(** Pri praznem seznamu smo morali še vedno pisati [bool], saj sicer
    Coq ne more uganiti, da gre za prazen seznam elementov tipa [bool]. *)

(** Coq pravzaprav že ima definirana naravna števila in sezname. *)
Print nat.
Print list.

(** Za naravna števila ima Coq običajno notacijo. *)
Check 42.

(** Za sezname uporablja enako notacijo kot OCaml. *)
Check @nil bool.
Check cons false (cons true nil). (* seznam [false, true] *)

(** Namesto [cons x xs] lahko pišemo [x :: xs], če aktiviramo
    notacijo iz [list_scope]. *)
Check (false :: true :: nil)%list.
Local Open Scope list_scope.
Check false :: true :: nil.

(** Od sedaj naprej bomo uporabljali Coq-ova tipa [nat] in [list]. *)

Require Import Arith. (* Knjižnica izrekov o [nat]. *)
Require Import List.  (* Knjižnica izrekov o [list]. *)

(** Funkcije na induktivnih tipih definiramo rekurzivno.
    Rekurzivne funkcije definiramo s [Fixpoint] ali [fix].
*)

Fixpoint dolzina {A : Type} (lst : list A) : nat :=
  match lst with
    | nil => 0
    | _ :: lst' => S (dolzina lst')
  end.

(** Ekvivalentna defincija s [fix]. Ta je podoben kot
    [fun], saj definira anonimno funkcijo. V spodnji
    definiciji je [f] vezana spremenljivka.
*)
Definition dolzina' {A: Type} :=
   fix f (lst : list A) : nat :=
     match lst with
       | nil => 0
       | _ :: lst' => S (f lst')
     end.

(** Primer računanja s funkcijo [dolzina]. *)
Eval compute in dolzina (2 :: 4 :: 3 :: nil).

(** V standardni knjižnici je funkcija za dolžino seznama že definirana. *)
Print length.

Eval compute in length (2 :: 4 :: 3 :: nil).

(** Sestavi funkcijo [range n], ki vrne seznam naravnih števil
    [(n-1) :: (n-2) :: ... 1 :: 0 :: nil].

    [Definition] spremeni v [Fixpoint] ali pa uporabo [fix].
*)
Definition range : nat -> list nat.
Admitted.

(*
  Fixpoint range (n : nat) :=
    ???
*)

(** Naslednji izračun mora vrniti
    9 :: 8 :: 7 :: 6 :: 5 :: 4 :: 3 :: 2 :: 1 :: 0 :: nil *)
Eval compute in range 10.

(** Definirajmo še funkcijo za stikanje dveh seznamov. *)
Fixpoint stakni {A : Type} (lst1 : list A) (lst2 : list A) : list A :=
  match lst1 with
    | nil => lst2
    | x :: lst1' => x :: (stakni lst1' lst2)
  end.

Eval compute in stakni (range 5) (range 7).

(* Coq ne dovoli definirati rekurzivne funkcije, ki ni povsod definirana.
   Zato moramo vedno zagotoviti, da se rekurzivni klici izvajajo na manjših
   argumentih. Coq sam ugotovi, kateri argument se zmanjšuje. Če tega ne
   zna sam, mu lahko to povemo z določilom [{struct ..}]. Recimo:
*)

Fixpoint stakni' {A : Type} (lst1 : list A) (lst2 : list A) {struct lst1}: list A :=
  match lst1 with
    | nil => lst2
    | x :: lst1' => x :: (stakni' lst1' lst2)
  end.

(** V standardni knjižnici že imamo funkcijo [app], ki stika sezname.
    Namesto [app x lst] lahko pišemo [x ++ lst]. *)
Print app.

Eval compute in range 5 ++ range 7.

(** Naloga: definiraj funkcijo, ki obrne seznam.
    Koda naj ustreza naslednji definiciji:

    - obrnjeni prazen seznam je spet prazen seznam
    - seznam x :: l' obrnemo tako, da obrnemo l' in ga staknemo
      s seznamom, ki vsebuje samo x.

    Nato v standardni knjižnici poišči funkcijo, ki obrača sezname.
    Primerjaj definicijo. *)
Definition obrni {A : Type} (lst : list A) : list A.
Admitted.

(*
  Fixpoint obrni {A : Type} (lst : list A) :=
  ???
*)

(** Tole mora izračunati 5 :: 4 :: 3 :: 2 :: 1 :: nil *)
Eval compute in obrni (1 :: 2 :: 3 :: 4 :: 5 :: nil).

(** V standradni knjižnici poišči funkcijo za obračanje seznamov. *)

(** Izreke o induktivnih tipih dokazujemo z indukcijo.
    Vsak induktivni tip ima namreč pripadajoči princip indukcije.
    Indukcija na naravnih številih je le poseben primer splošne indukcije.

    Ko definiramo induktivni tip, Coq sam generira nekaj variant ustreznih
    principov indukcije. S taktiko [induction] lahko uporabimo tako generirani
    princip.
*)

(** Z indukcijo dokažimo, da je stik seznama [lst] in praznega seznama spet [lst]. *)
Lemma app_nil (A : Type) (lst : list A) : lst = lst ++ nil.
Proof.
  (* Indukcija na lst. *)
  induction lst.
  - (* osnovni primer: prazen seznam *)
    reflexivity.
  - (* indukcijski korak: seznam oblike [a :: lst] *)
    simpl.
    rewrite <- IHlst.
    reflexivity.
Qed.

(** Z indukcijo pokažimo, da velja [rev (lst1 ++ lst2) = (rev lst2) ++ (rev lst1)]. *)
Lemma rev_app (A : Type) (lst1 lst2 : list A) : rev (lst1 ++ lst2) = rev lst2 ++ rev lst1.
Proof.
  induction lst1.
  - apply app_nil.
  - simpl.
    (* Menda obstaja lema, da je [app] asociativen. *)
    SearchAbout (?x ++ ?y ++ ?z).
    rewrite app_assoc.
    rewrite <- IHlst1.
    reflexivity.
Qed.

(** Z indukcijo dokaži, da je dvakrat obrnjeni seznam enak prvotnemu. *)
Lemma rev_rev (A : Type) (lst : list A) : lst = rev (rev lst).
Proof.
  admit.
Qed.

(** Obravnavajmo še dvojiška drevesa. *)
Inductive tree :=
  | empty : tree
  | node : tree -> tree -> tree.

(** Število elementov v drevesu. *)
Fixpoint size (t : tree) :=
  match t with
    | empty => 0
    | node l r => S (size l + size r)
  end.

(** Globina drevesa. *)
Fixpoint depth (t : tree) :=
  match t with
    | empty => 0
    | node l r => S (max (depth l) (depth r))
  end.

(** Polno drevo globine n. *)
Fixpoint complete (n : nat) : tree :=
  match n with
    | 0 => empty
    | S n' => node (complete n') (complete n')
  end.

Eval compute in complete 3.
Eval compute in depth (complete 5).
Eval compute in size (complete 5).

(** Dokažimo, da ima [complete n] res globino [n] in da ima
     velikost [2^n - 1]. Potenciranje se skriva v knjižnici [NPeano]. *)

Require Import NPeano.

(** Vaja. *)
Lemma complete_depth (n : nat) : depth (complete n) = n.
Proof.
  admit.
Qed.

(** To naredimo skupaj na predavanjih. *)
Lemma complete_size (n : nat) : S (size (complete n)) = 2 ^ n.
Proof.
  induction n.
  - auto.
  - simpl.
    ring_simplify.
    SearchAbout (?x * ?y + ?x).
    rewrite <- mult_succ_r.
    congruence.
Qed.

(** Funkcija, ki zamenja levo in desno podrevo, in naredi
    isto še v obeh podrevesih. *)
Fixpoint flip (t : tree) :=
  match t with
    | empty => empty
    | node l r => node (flip r) (flip l)
  end.

(** Če obrnemo dvakrat, dobimo isto drevo. *)
Lemma flip_idem (t : tree) : flip (flip t) = t.
Proof.
  admit.
Qed.

(** Obračanje ne spremeni velikosti. *)
Lemma flip_size (t : tree) : size t = size (flip t).
Proof.
  admit.
Qed.

(** Obrnjeno polno drevo je spet polno drevo. *)
Lemma flip_complete (n : nat) : complete n = flip (complete n).
Proof.
  admit.
Qed.

(** Pri naslednji nalogah ne potrebuješ indukcije, ker so
    indukcijske hipoteze neuporabne. Namesto [induction t]
    raje poskusi [destruct t] ali [destruct t as [|u1 u2]]. *)

(** Edino drevo globine 0 je prazno drevo. *)
Lemma globina_0 (t : tree) : depth t = 0 -> t = empty.
Proof.
  admit.
Qed.

(** Edino drevo globine 1 je [node empty empty]. *)
Lemma globina_1 (t : tree) :
  depth t = 1 -> t = node empty empty.
Proof.
  admit.
Qed.

(** Obstajajo tri drevesa globine 2. *)
Lemma globina_2 (t : tree) :
  depth t = 2 ->
  t = node (node empty empty) empty \/
  t = node empty (node empty empty) \/
  t = node (node empty empty) (node empty empty).
Proof.
  intro H.
  destruct t as [|t1 t2] ; try discriminate || auto.
  admit.
Qed.


(* BEGIN FIX *)
Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (n1 n2 : nat)
  | BGe (n1 n2 : nat)
  | BNot (b : bexp)
  | BOr (b1 b2 : bexp).

From Coq Require Import Init.Nat.

Eval compute in 3 =? 4.
Eval compute in 3 <=? 3.

Fixpoint beval (b : bexp) : bool :=
(* END FIX *)
  match b with
    | BTrue => true
    | BFalse => false
    | BEq n1 n2 => n1 =? n2
	  | BGe n1 n2 => negb (n1 <? n2)
	  | BNot b => negb (beval b)
	  | BOr b1 b2 => orb (beval b1) (beval b2)
end.

(* BEGIN FIX *)
Example beval_test_1 : beval (BGe 3 4) = false.
(* END FIX *)
simpl. reflexivity. Qed.

(* BEGIN FIX *)
Example beval_test_2 : beval (BGe 3 3) = true.
(* END FIX *)
simpl. reflexivity. Qed.

(* BEGIN FIX *)
Example beval_test_3 : beval (BGe 5 3) = true.
(* END FIX *)
simpl. reflexivity. Qed.

(* BEGIN FIX *)
Example beval_test_4 : beval (BOr (BGe 3 4) (BGe 3 2)) = true.
(* END FIX *)
simpl. reflexivity. Qed.

(* BEGIN FIX *)
Definition BAnd (b1 b2 : bexp) : bexp :=
(* END FIX *)
  BNot(BOr (BNot b1) (BNot b2))
.
(* BEGIN FIX *)
Example beval_test_5 : beval (BAnd (BGe 3 4) (BGe 3 2)) = false.
(* END FIX *)
simpl. reflexivity.
Qed.

(* BEGIN FIX *)
Example beval_test_6 : beval (BAnd (BGe 4 4) (BGe 3 2)) = true.
(* END FIX *)
simpl. reflexivity. Qed.

(* BEGIN FIX *)
Example beval_test_7 : beval
  (BAnd
    (BOr
      (BOr
        (BNot BTrue)
        (BEq 3 3))
      (BGe 5 3))
    (BNot (BEq 3 4)))
  = true.
(* END FIX *)
simpl. reflexivity. Qed.

(* BEGIN FIX *)
Lemma bor_left_unit (b : bexp) : beval (BOr BFalse b) = beval b.
(* END FIX *)
simpl. reflexivity. Qed.

(* BEGIN FIX *)
Lemma lem (b : bexp)(p : beval b = true) : beval (BAnd b BTrue) = true.
(* END FIX *)
simpl.
rewrite -> p.
simpl.
reflexivity.
Qed.


Require Export Lists.List.
Require Export GenReflect SetSpecs.
Require Export Sorting.
Require Export DecType SetReflect.
Require Export DecList.

Set Implicit Arguments.

Section MoreDecList.

Context { A: eqType}.
(*------------------ Uniform list -----------------------------------------------------*)

Inductive uniform : list A -> Prop:=
| Nil_uni: uniform nil
|Sing_uni(a:A): uniform (a::nil)
|Ind_uni(a b:A)(l:list A): a=b -> uniform (b::l)-> uniform (a::b::l).

Lemma uniform_elim (a:A)(l: list A): uniform (a::l)-> (forall x, In x l -> x=a).
Proof. Admitted.
Lemma uniform_elim1 (a:A)(l: list A): uniform (a::l)-> (forall x, In x (a::l)-> x=a).
Proof. Admitted.
Lemma uniform_elim2 (a:A) (l: list A): uniform (a::l)-> uniform l.
Proof. Admitted.
Lemma uniform_intro (a:A)(l: list A): (forall x, In x l -> x=a) -> uniform (a::l).
Proof. Admitted.

(* ----------------- delete_all operation ---------------------------------------------  *)

Fixpoint del_all (a:A)(l: list A): list A:=
    match l with
    |nil => nil
    | a1::l1 => match  (a == a1) with
               |true => del_all a l1
               |false => a1 :: del_all a l1
               end
    end.

(* This function deletes all occurences of a in the list l *)

  Lemma del_all_elim1 (a b:A)(l: list A): In a (del_all b l)-> In a l.
  Proof. Admitted.
  Lemma del_all_elim2 (a b:A)(l: list A): In a (del_all b l)-> (a<>b).
  Proof. Admitted.

  Lemma del_all_intro (a b: A)(l:list A): In a l -> a<>b -> In a (del_all b l).
  Proof. Admitted.
  Lemma del_all_iff (a b:A)(l: list A): (In a (del_all b l) <-> (In a l /\ a<>b)).
  Proof. Admitted.

  Hint Resolve del_all_elim1 del_all_elim2 del_all_intro: core.

  Lemma del_all_nodup (a:A)(l: list A): NoDup l -> NoDup (del_all a l).
  Proof. Admitted.

  Hint Resolve del_all_nodup: core.

 (* ------- count of an element a in the list l ----------------------------------------*)

 Fixpoint count (a:A) (l:list A) : nat:= match l with
                          | nil => 0
                          |a1::l1 => match a == a1 with
                                    |true => S (count a l1)
                                    |false => count a l1
                                    end
                                        end.
  Lemma countP1 (a:A) (l:list A): In a l -> (count a l >= 1).
  Proof. Admitted.
  Lemma countP2 (a:A)(l: list A): ~ In a l -> (count a l = 0).
  Proof. Admitted.
  Lemma countP3 (a:A)(l: list A): (count a l = 0) -> ~ In a l.
  Proof. Admitted.
  Lemma countP4 (a:A)(l: list A): count a (a::l) = S (count a l).
  Proof. Admitted.
  Lemma countP5 (a b:A)(l: list A): (count a l) <= count a (b::l).
  Proof. Admitted.
  Lemma countP6 (a: A)(l: list A): count a l <= |l|.
  Proof. Admitted.
  Lemma countP7 (a:A) (l:list A): In a l -> count a l = S(count a (delete a l)).
  Proof. Admitted.
  Lemma countP8 (a:A) (l:list A): forall x, x<>a-> count x (a::l) = count x l.
  Proof. Admitted.
  Lemma countP9 (a:A) (l:list A): forall x, x<>a -> count x l = count x (delete a l).
  Proof. Admitted.
  Lemma countP10 (a:A)(l s:list A): count a l <= count a s -> count a (a::l) <= count a (a::s).
  Proof. Admitted.
  Lemma countP11 (a:A)(l s: list A): count a l = count a s -> count a (a::l) = count a (a::s).
  Proof. Admitted.
  Lemma countP12 (a:A)(l s: list A): count a l < count a s -> count a (a::l) < count a (a::s).
  Proof. Admitted.

  Hint Immediate countP1 countP2 countP3: core.
  Hint Resolve countP4 countP5 countP6 countP7 countP8 countP9: core.

End MoreDecList.

 Hint Resolve del_all_elim1 del_all_elim2 del_all_intro: core.
 Hint Resolve del_all_nodup: core.

 Hint Immediate countP1 countP2 countP3: core.
 Hint Resolve countP4 countP5 countP6 countP7 countP8 countP9:  core.
 Hint Resolve countP10 countP11 countP12: core.

Section Permutation.

  Context { A: eqType }.

   Lemma EM:forall x y : A, x=y \/ x<>y.
   Proof. eauto. Qed.

   Definition empty: list A:= nil.

   Lemma count_in_putin1 (a: A)(l: list A)(lr: A-> A-> bool):
     count a (putin lr a l)= S (count a l).
   Proof. { induction l. simpl. destruct (a==a) eqn:H. auto. conflict_eq.
           { simpl. case (lr a a0) eqn: H0.
             { destruct (a==a0) eqn:H1. move /eqP in H1.
               subst a0. assert (H: count a (a::a::l)=S(count a (a::l))). eauto.
               rewrite H. eauto.
               assert (H: count a (a :: a0 :: l) = S (count a (a0::l))).
               eauto.  move /eqP in H1. rewrite H. eauto. }
             { simpl. destruct (a==a0) eqn:H1. omega. auto. } } } Qed.

   Lemma count_in_putin2 (a b: A)(l: list A)(lr: A-> A-> bool):
     a<>b -> count a l = count a (putin lr b l).
   Proof. { induction l.
            { simpl; destruct (a==b) eqn:H. intros;conflict_eq. auto. }
            { intros.  simpl. case (lr b a0) eqn: H0.
              { destruct (a==a0) eqn:H1.
                move /eqP in H1. subst a0.
                replace (count a (b :: a :: l)) with (count a (a :: l)).
                eauto. symmetry; auto. move /eqP in H1.
                replace (count a (b :: a0 :: l)) with (count a (a0 :: l)).
                all: symmetry;eauto. }
              { destruct (a==a0) eqn: H1.
                move /eqP in H1. subst a0.
                replace (count a (a :: putin lr b l)) with (S(count a (putin lr b l))).
                 eauto. symmetry. auto.
                replace (count a (a0 :: putin lr b l)) with (count a (putin lr b l)).
                auto. move /eqP in H1. symmetry;auto. }  } } Qed.

  Lemma count_in_sorted (a: A)(l: list A)(lr: A-> A-> bool): count a l = count a (sort lr l).
  Proof. { induction l. simpl; auto.
           simpl. destruct  (a == a0) eqn:H0.
           move /eqP in H0. subst a.
           rewrite IHl. symmetry; apply count_in_putin1.
           move /eqP in H0. rewrite IHl.  apply count_in_putin2. auto. }  Qed.

  Hint Resolve count_in_putin1 count_in_putin2 count_in_sorted: core.

  (* ---------------  sublist of a list (subsequence)------------------------------------ *)

  Fixpoint sublist (l s: list A): bool := match (l, s) with
                                              |(nil , _) => true
                                              |(a::l1, nil) => false
                                              |(a::l1, b::s1) => match (a == b) with
                                                          |true => sublist l1 s1
                                                          |false => sublist l s1
                                                          end
                                       end.

  Lemma sublist_intro (l: list A): sublist nil l.
  Proof.   destruct l;simpl;auto. Qed.
  Lemma sublist_reflex (l: list A): sublist l l.
  Proof. induction l;simpl.
         auto. destruct (a==a) eqn:H; [auto | conflict_eq].  Qed.

  Lemma sublist_elim1 (l: list A): sublist l nil -> l=nil.
  Proof. destruct l; [auto | simpl; intro H; inversion H]. Qed.

  Lemma sublist_elim2 (a:A)(l s: list A): sublist (a::l) s -> In a s.
  Proof. induction s.  simpl; auto. simpl. destruct (a==a0) eqn:H. move /eqP in H.
         subst a0; auto. intro;right;auto. Qed.

  Lemma sublist_elim3 (a: A)(l s: list A): sublist (a::l) s -> sublist l s.
  Proof. { revert l; revert a. induction s.
         { auto. }
         { intros a0 l.
           simpl. destruct (a0 == a) eqn:H.
           { destruct l. auto.  destruct (e == a) eqn:H1.
             apply IHs. auto.  }
           { destruct l. auto.  destruct (e == a) eqn:H1.
             { intro H2. assert (H2a: sublist (e::l) s). eapply IHs;exact H2.
               eapply IHs; exact H2a. }
             { apply IHs. }
         } } } Qed.

  Lemma sublist_elim3a (a e: A)(l s: list A): sublist (a::l)(e::s)-> sublist l s.
  Proof. simpl. destruct (a==e) eqn:H. auto.   eauto using sublist_elim3. Qed.

   Lemma sublist_intro1 (a:A)(l s: list A): sublist l s -> sublist l (a::s).
   Proof.  { revert s;revert a. induction l.
           { auto. }
           { intros a0 s.
             simpl. destruct (a == a0) eqn:H. apply sublist_elim3. auto. } } Qed.

   Lemma sublist_Subset (l s: list A): sublist l s -> Subset l s.
   Proof. { revert s. induction l.  eauto.
           intros s H. eauto. unfold "[<=]". intros x H1.
           destruct H1. subst x. eauto using  sublist_elim2. apply sublist_elim3 in H.
           apply IHl in H. eauto. } Qed.

   Lemma sublist_elim4 (l s: list A): sublist l s -> (forall a, count a l <= count a s).
   Proof. { revert l. induction s as [| e s'].
          { intro l. intro H. assert (H1: l=nil); auto using sublist_elim1.
            subst l; auto.  }
          { intros l H x. destruct l as [|a l'].
            simpl. omega. destruct (x==a) eqn:Hxa.
            { move /eqP in Hxa. subst x.
              simpl in H. destruct (a == e) eqn: Hae. move /eqP in Hae.
              subst e.
              cut (count a l' <= count a s'); auto.
              assert (H1: count a (a :: l') <= count a  s'). eauto.
              cut (count a s' <= count a (e::s')). omega. auto. }
            { assert (H1: count x (a::l')<= count x s').
              { simpl. rewrite Hxa. eauto using sublist_elim3a. }
              cut (count x s' <= count x (e::s')). omega. auto. } } } Qed.

  Lemma sublist_trans (l1 l2 l3: list A): sublist l1 l2 -> sublist l2 l3 -> sublist l1 l3.
  Proof. Admitted.

  Hint Extern 0 (is_true ( sublist ?x ?z) ) =>
  match goal with
  | H: is_true (sublist x  ?y) |- _ => apply (@sublist_trans  x y z)
  | H: is_true (sublist ?y  z) |- _ => apply (@sublist_trans  x y z)
  end.

  Hint Resolve sublist_intro sublist_intro1 sublist_reflex sublist_Subset sublist_elim1: core.
  Hint Resolve sublist_elim2 sublist_elim3 sublist_elim4: core.

  (* -------------- list inclusion (subset in multiset) ----------------------------------*)

  Fixpoint included (l s: list A): bool := match l with
                                        |nil => true
                                        | a::l1 => match (memb a s) with
                                                  |true => included l1 (delete a s)
                                                  |false => false
                                                  end
                                        end.
  Lemma included_intro1 (l: list A): included nil l.
  Proof. Admitted.
   Lemma included_refl (l: list A): included l l.
  Proof. Admitted.
  Lemma included_intro2 (a:A)(l s: list A): In a s -> included l (delete a s)-> included (a::l) s.
  Proof. Admitted.
  Lemma included_intro3 (l s: list A): sublist l s -> included l s.
  Proof. Admitted.
  Lemma included_intro (l s: list A): (forall a, count a l <= count a s)-> included l s.
  Proof. { revert s. induction l. intros;apply included_intro1;auto.
           { intros s H. simpl.  case (memb a s) eqn:Has;move /membP in Has.
             apply IHl. intro x. destruct (EM x a).
             Focus 2.  replace (count x l) with (count x (a::l)).
             replace (count x (delete a s)) with (count x s).
             all: eauto. subst x.
             replace (count a l) with ((count a (a::l)) -1).
             replace (count a (delete a s)) with ((count a s)-1).
             specialize (H a).  omega.
             replace (count a s) with (S (count a (delete a s))). omega.
             symmetry; eauto.
             replace (count a (a :: l)) with (S (count a l)). omega.
             symmetry; eauto.
             specialize (H a). rewrite countP4 in H.
             replace (count a s) with 0 in H. inversion H. symmetry; eauto. } } Qed.

  Lemma included_elim1 (l: list A): included l nil -> l=nil.
  Proof. Admitted.
  Lemma included_elim2 (a:A)(l s: list A): included (a::l) s -> In a s.
  Proof. Admitted.
  Lemma included_elim3 (a:A)(l s: list A): included (a::l) s -> included l (delete a s).
  Proof. Admitted.
  Lemma included_elim4 (a:A)(l s: list A): included (a::l) s -> included l s.
  Proof. Admitted.
  Lemma included_elim5 (l s: list A): included l s -> Subset l s.
  Proof. Admitted.

  Lemma included_elim (l s: list A): included l s-> (forall a, count a l <= count a s).
  Proof. { revert s. induction l. simpl. intros;omega.
           intros s H x. apply included_elim2 in H as H1. apply included_elim3 in H as H2.
           assert (H3: count a l <= count a (delete a s)).  eapply IHl with (s:= (delete a s)).
           auto.  destruct (EM x a).
           subst x. replace (count a (a::l)) with (S(count a l)).
           replace (count a s) with (S( count a (delete a s))).
           omega. symmetry; eauto.  eauto.
           replace (count x (a::l)) with (count x l).
           replace (count x s) with  (count x (delete a s)).
           eauto. all: symmetry;eauto. } Qed.

  Lemma included_trans (l1 l2 l3: list A):
  included l1 l2-> included l2 l3 -> included l1 l3.
  Proof. Admitted.

   Hint Extern 0 (is_true ( included ?x ?z) ) =>
  match goal with
  | H: is_true (included x  ?y) |- _ => apply (@included_trans  x y z)
  | H: is_true (included ?y  z) |- _ => apply (@included_trans  x y z)
  end.

  Hint Resolve included_intro1 included_intro2 included_intro3: core.
  Hint Resolve included_refl included_intro: core.
  Hint Resolve included_elim1 included_elim2 included_elim3: core.
  Hint Resolve included_elim4 included_elim5 included_elim: core.

  (* ----- Some Misc Lemmas on nodup, sorted, sublist, subset and included ---------------- *)

  Lemma nodup_subset_included (l s: list A): NoDup l -> l [<=] s -> included l s.
  Proof. Admitted.
  Lemma sorted_included_sublist (l s: list A)(lr: A->A-> bool):
    Sorted lr l-> Sorted lr s-> included l s-> sublist l s.
  Proof. Admitted.
  Lemma first_in_ordered_sublists (a e:A)(l s: list A)(lr: A->A-> bool):
    Sorted lr (a::l)-> Sorted lr (e::s)-> sublist (a::l)(e::s)-> lr e a.
  Proof. Admitted.

  Hint Resolve nodup_subset_included: core.
  Hint Immediate sorted_included_sublist first_in_ordered_sublists:core.

  (* --------------------  permuted lists (permutation) -------------------------------------*)

  Definition perm (l s: list A): bool:= included l s && included s l.

  Lemma perm_intro  (l s: list A): (forall a, count a l = count a s)-> perm l s.
  Proof.  { intro H; split_; apply included_intro; intro a; specialize (H a); omega. } Qed.

  Lemma perm_intro0a (l: list A)(lr: A-> A-> bool): perm l (sort lr l).
  Proof. apply perm_intro. eauto. Qed.

  Lemma perm_intro0b (l: list A)(lr: A-> A-> bool): perm (sort lr l) l.
  Proof. apply perm_intro; eauto. Qed.

  Lemma perm_nil: perm nil nil.
  Proof. split_; eauto.  Qed.

  Lemma perm_refl (l: list A): perm l l.
  Proof. split_; eauto.  Qed.

  Lemma perm_intro3 (l s: list A): sublist l s -> sublist s l -> perm l s.
  Proof. intros; split_; eauto.  Qed.

  Lemma perm_elim   (l s: list A): perm l s -> (forall a, count a l = count a s).
  Proof.  { intros H a. move /andP in H. destruct H as [H1 H2].
          cut (count a l <= count a s). cut (count a s <= count a l). omega.
          all: eauto. } Qed.

  Lemma perm_elim1 (l: list A): perm l nil -> l = nil.
  Proof. intro H; move /andP in H; destruct H as [H1 H2]; eauto. Qed.
  Lemma perm_elim2 (l s: list A): perm l s -> l [=] s.
  Proof. move /andP;intro H; destruct H; split; eauto. Qed.
  Lemma perm_sym (l s: list A): perm l s -> perm s l.
  Proof. move /andP;intro H; apply /andP; tauto. Qed.

  Lemma perm_trans (x y z: list A): perm x y -> perm y z -> perm x z.
  Proof. intros H H1; move /andP in H; move /andP in H1; apply /andP.
         split;destruct H; destruct H1. all: auto. Qed.

  Hint Extern 0 (is_true ( perm ?x ?z) ) =>
  match goal with
  | H: is_true (perm x  ?y) |- _ => apply (@perm_trans x y z)
  | H: is_true (perm ?y  z) |- _ => apply (@perm_trans x y z)
  end.

  Hint Resolve  perm_intro0a  perm_intro0b perm_refl perm_nil perm_elim1 : core.
  Hint Immediate perm_elim perm_intro perm_sym: core.

  Lemma perm_sort1 (l s: list A)(lr: A-> A-> bool): perm l s -> perm  l (sort lr s).
  Proof.  eauto. Qed.

   Lemma perm_sort2 (l s: list A)(lr: A-> A-> bool): perm l s -> perm  (sort lr l) s.
   Proof. eauto.  Qed.

   Lemma perm_sort3 (l s: list A)(lr: A-> A-> bool): perm l s -> perm (sort lr l)(sort lr s).
   Proof. eauto using perm_sort1. Qed.

   Hint Resolve perm_sort1 perm_sort2 perm_sort3: core.

 End Permutation.

  Hint Resolve count_in_putin1 count_in_putin2 count_in_sorted: core.

  Hint Resolve sublist_intro sublist_intro1 sublist_reflex sublist_Subset sublist_elim1: core.
  Hint Resolve sublist_elim2 sublist_elim3 sublist_elim3a sublist_elim4: core.

  Hint Extern 0 (is_true ( sublist ?x ?z) ) =>
  match goal with
  | H: is_true (sublist x  ?y) |- _ => apply (@sublist_trans _ x y z)
  | H: is_true (sublist ?y  z) |- _ => apply (@sublist_trans _ x y z)
  end.

  Hint Resolve included_intro1 included_intro2 included_intro3: core.
  Hint Resolve included_refl included_intro: core.
  Hint Resolve included_elim1 included_elim2 included_elim3: core.
  Hint Resolve included_elim4 included_elim5 included_elim: core.

  Hint Extern 0 (is_true ( included ?x ?z) ) =>
  match goal with
  | H: is_true (included x  ?y) |- _ => apply (@included_trans _ x y z)
  | H: is_true (included ?y  z) |- _ => apply (@included_trans _ x y z)
  end.

  Hint Resolve nodup_subset_included: core.
  Hint Immediate sorted_included_sublist first_in_ordered_sublists:core.

  Hint Resolve  perm_intro0a  perm_intro0b perm_refl perm_nil perm_elim1 : core.
  Hint Immediate perm_elim perm_intro perm_sym: core.
  Hint Resolve perm_elim1 perm_elim2: core.

  Hint Extern 0 (is_true ( perm ?x ?z) ) =>
  match goal with
  | H: is_true (perm x  ?y) |- _ => apply (@perm_trans _ x y z)
  | H: is_true (perm ?y  z) |- _ => apply (@perm_trans _ x y z)
  end.

  Hint Resolve perm_sort1 perm_sort2 perm_sort3: core.


Require Import aula3 aula4 aula5 aula6 aula7.

(** Complete the definitions of [nonzeros], [oddmembers] and
    [countoddmembers] below. Have a look at the tests to understand
    what these functions should do. *)

(** **** Exercise: 2 star  *)
Fixpoint nonzeros (l:natlist) : natlist :=
match l with
 | nil => nil
 | h :: t => match h with
             | 0 => nonzeros t
             | S n => h :: nonzeros t
             end
end.

(** **** Exercise: 1 star  *)
Example test_nonzeros:
  nonzeros [0;1;0;2;3;0;0] = [1;2;3].
Proof.
simpl.
reflexivity.
Qed.
(** **** Exercise: 2 star  *)
Fixpoint oddmembers (l:natlist) : natlist :=
match l with
 | nil => nil
 | h :: t => match oddb h with
            |false => oddmembers t
            |true => h :: oddmembers t
            end
end.

(** **** Exercise: 1 star  *)
Example test_oddmembers:
  oddmembers [0;1;0;2;3;0;0] = [1;3].
Proof.
simpl.
reflexivity.
Qed.

(** **** Exercise: 2 star  *)
Definition countoddmembers (l:natlist) : nat := (length(oddmembers l)).

(** **** Exercise: 1 star  *)
Example test_countoddmembers1:
  countoddmembers [1;0;3;1;4;5] = 4.
Proof.
unfold countoddmembers.
simpl.
reflexivity.
Qed.

(** **** Exercise: 1 star  *)
Example test_countoddmembers2:
  countoddmembers [0;2;4] = 0.
Proof.
reflexivity.
Qed.
(** **** Exercise: 1 star  *)
Example test_countoddmembers3:
  countoddmembers nil = 0.
Proof.
reflexivity.
Qed.

(** **** Exercise: 3 stars, advanced (alternate)  *)
(** Complete the definition of [alternate], which "zips up" two lists
    into one, alternating between elements taken from the first list
    and elements from the second.  See the tests below for more
    specific examples.

    Note: one natural and elegant way of writing [alternate] will fail
    to satisfy Coq's requirement that all [Fixpoint] definitions be
    "obviously terminating."  If you find yourself in this rut, look
    for a slightly more verbose solution that considers elements of
    both lists at the same time.  (One possible solution requires
    defining a new kind of pairs, but this is not the only way.)  *)

Fixpoint alternate (l1 l2 : natlist) : natlist :=
match l1 with
| nil => l2
| h :: t => match l2 with
           | nil => l1
           | h0 :: t0 => h :: h0 :: alternate t t0
           end
end.

Example test_alternate1:
  alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Proof.
simpl.
reflexivity.
Qed.

Example test_alternate2:
  alternate [1] [4;5;6] = [1;4;5;6].
Proof.
simpl.
reflexivity.
Qed.

Example test_alternate3:
  alternate [1;2;3] [4] = [1;4;2;3].
Proof.
simpl.
reflexivity.
Qed.

Example test_alternate4:
  alternate [] [20;30] = [20;30].
Proof.
simpl.
reflexivity.
Qed.


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.

Lemma le_SS : forall n m,
  n <= m -> S n <= S m.
Proof.
  intros n m H.
  induction H.
  - apply le_n.
  - apply le_S. apply IHle.
Qed.

Lemma plus_le_r : forall (x y z : nat),
  x <= y -> x + z <= y + z.
Proof.
  intros x y z.
  generalize dependent y.
  generalize dependent x.
  induction z as [|z' IH].
  - intros x y. intros H.
    rewrite plus_0_r. rewrite plus_0_r. apply H.
  - intros x y. intros H.
    rewrite <- plus_Snm_nSm.
    rewrite <- plus_Snm_nSm.
    apply IH.
    apply le_SS. apply H.
Qed.

Lemma plus_le_l : forall (x y z : nat),
  x + z <= y + z -> x <= y.
Proof.
  intros x y z.
  generalize dependent y.
  generalize dependent x.
  induction z as [|z' IH].
  - intros x y. intros H.
    rewrite plus_0_r in H.
    rewrite plus_0_r in H.
    apply H.
  - intros x y. intros H.
    rewrite <- plus_Snm_nSm in H.
    rewrite <- plus_Snm_nSm in H.
    apply IH in H.
    inversion H.
    + reflexivity.
    + transitivity (S x).
      * apply le_S. reflexivity.
      * apply H1.
Qed.

Lemma combine_le : forall x1 y1 x2 y2 : nat,
  x1 <= y1 ->
  x2 <= y2 ->
    x1 + x2 <= y1 + y2.
Proof.
  intros x1 y1 x2 y2.
  intros H1 H2.
  transitivity (x1 + y2).
  - rewrite plus_comm. rewrite (plus_comm x1).
    apply plus_le_r. apply H2.
  - apply plus_le_r. apply H1.
Qed.

Lemma lebP : forall n m, reflect (n <= m) (n <=? m).
Proof.
  intros n m. apply iff_reflect. split.
  - intros H. apply leb_correct. apply H.
  - intros H. apply leb_complete. apply H.
Qed.

Lemma leb_trans : forall i j k,
  i <= j -> j <= k ->
    i <= k.
Proof.
  intros i j k.
  intros H1 H2.
  transitivity j.
  - apply H1.
  - apply H2.
Qed.


(*|
##########################################################################################################
How to prove that another definition of permutation is the same as the Default Permutation Library for Coq
##########################################################################################################

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

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

I need to prove that a secondary definition of permutation is
equivalent to the default definition of permutation in Coq:

Down bellow is the default Permutation definition in Coq

.. coq:: none
|*)

Require Import List.
Import ListNotations.

Definition A := nat.

(*||*)

Inductive Permutation : list A -> list A -> Prop :=
| perm_nil : Permutation [] []
| perm_skip x l l' : Permutation l l' -> Permutation (x :: l) (x :: l')
| perm_swap x y l : Permutation (y :: x :: l) (x :: y :: l)
| perm_trans l l' l'' :
  Permutation l l' -> Permutation l' l'' -> Permutation l l''.

(*|
I need to prove that the above mentioned definition is equivalent to
the following definition:

.. coq:: none
|*)

Require Import PeanoNat.

Fixpoint occurences_number x l :=
  match l with
  | nil => 0
  | h :: tl => if (x =? h)
               then S (occurences_number x tl)
               else occurences_number x tl
  end.

(*||*)

Definition perm l l' := forall x, occurences_number x l = occurences_number x l'.

(*|
Which as you have noticed uses the definition ``occurences_number``
down bellow:
|*)

Reset occurences_number. (* .none *)
Fixpoint occurences_number x l :=
  match l with
  | nil => 0
  | h :: tl => if (x =? h)
               then S (occurences_number x tl)
               else occurences_number x tl
  end.

(*| .. coq:: none |*)

Definition perm l l' := forall x, occurences_number x l = occurences_number x l'.

(*| What I need to prove indeed is the following: |*)

Lemma permutation_to_perm : forall l l', Permutation l l' -> perm l l'.

(*| Down bellow is my incomplete proof |*)

Proof.
  induction l.
  - admit.
  - intros l' Hequiv.
    generalize dependent a.
    generalize dependent l.
    case l'.
    + Admitted.

(*|
----

**A (Arthur Azevedo De Amorim):** It is probably easier to do
induction on the hypothesis ``Permutation l l'`` instead of ``l``.

**Q:** What do you mean @ArthurAzevedoDeAmorim?

**A (Arthur Azevedo De Amorim):** In Coq, you can do induction not
only on data structures, but also on hypotheses that state inductively
defined propositions. If you are not familiar with this concept, I
recommend having a look at the Software Foundations book:
https://softwarefoundations.cis.upenn.edu/lf-current/IndProp.html#lab216
|*)

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

Here is a proof that follows the strategy I outlined above:
|*)

Lemma Permutation_to_perm l l' : Permutation l l' -> perm l l'.
Proof.
  intros H. induction H as [| x l1 l2 _ IH | x y l | l1 l2 l3 _ IH1 _ IH2 ].
  - intros ?; reflexivity.
  - intros y. simpl. now rewrite IH.
  - intros z. simpl. now destruct (z =? y), (z =? x).
  - intros ?. now rewrite IH1.
Qed.