Require Import BinNat.
Require Import BinPos.
Include BinNat.N.

From Proyecto Require Export Defs_Bin.

(* Todo número binario es igual a sí mismo. *)
Lemma bin_eq: forall (b: N), N.eqb b b = true.
Proof.
intro.
apply eqb_eq.
trivial.
Qed.

(* Equivalencia entre mi podd y el odd de Coq. *)
Theorem podd_correct: forall (p: positive), N.odd (Npos p) = podd p.
Proof.
unfold N.odd.
induction p; reflexivity.
Qed.

(* Nuestra división entre 2 es equivalente a la de coq *)
Theorem pdiv2_correct: forall (p: positive), p <> xH ->
Npos (pdiv2 p) = N.div2 (Npos p).
Proof.
induction p.
+ reflexivity.
+ reflexivity.
+ intro.
  contradiction.
Qed.

(* El XOR de un positivo con si mismo es 0. *)
Theorem pos_xor_zero: forall p, Pos.lxor p p = N0.
Proof.
induction p.
- simpl.
  rewrite IHp.
  reflexivity.
- simpl.
  rewrite IHp.
  reflexivity.
- reflexivity.
Qed.

(* XOR de un número con si mismo siempre es 0. *)
Theorem xor_zero: forall k, N.lxor k k = N0.
Proof.
destruct k.
+ reflexivity.
+ simpl.
  apply pos_xor_zero.
Qed.

(* Xor de dos positivos distintos no es 0. *)
Theorem xor_not_zero_pos: forall k1 k2, k1 <> k2 -> Pos.lxor k1 k2 <> N0.
Proof.
induction k1.
+ intros.
  simpl.
  destruct k2.
  - unfold Pos.Ndouble.
    assert (Pos.lxor k1 k2 <> 0%N).
    * apply IHk1.
      intro contra.
      rewrite contra in H.
      contradiction H.
      trivial.
    * destruct (Pos.lxor k1 k2) eqn:lxor.
      ++ assumption.
      ++ discriminate.
  - unfold Pos.Nsucc_double.
    destruct (Pos.lxor k1 k2).
    * discriminate.
    * discriminate.
  - discriminate.
+ intros.
  destruct k2.
  - simpl.
    unfold Pos.Nsucc_double.
    destruct (Pos.lxor k1 k2); discriminate.
  - simpl.
    unfold Pos.Ndouble.
    destruct (Pos.lxor k1 k2) eqn:xor.
    * apply IHk1 in xor.
      ++ exfalso.
         assumption.
      ++ intro.
         rewrite H0 in H.
         contradiction H.
         trivial.
    * discriminate.
  - destruct k1.
    * simpl.
      discriminate.
    * simpl.
      discriminate.
    * simpl.
      discriminate.
+ intros.
  destruct k2; simpl.
  - discriminate.
  - discriminate.
  - contradiction H.
    reflexivity.
Qed.

(* Xor de dos números distintos no es 0. *)
Theorem xor_not_zero: forall k1 k2, k1 <> k2 -> N.lxor k1 k2 <> N0.
Proof.
induction k1.
+ simpl.
  intros.
  intuition.
+ intros.
  simpl.
  destruct k2.
  - assumption.
  - apply xor_not_zero_pos.
    intro.
    rewrite H0 in H.
    contradiction H.
    reflexivity.
Qed.

Lemma obvious_matchP: forall k x, matchPrefix k (mask k x) x = true.
Proof.
intros.
unfold matchPrefix.
rewrite bin_eq.
trivial.
Qed.

(* 0 es neutro en xor. *)
Theorem xor_neutral: forall x, N.lxor x N0 = x.
Proof.
destruct x.
+ reflexivity.
+ destruct p; reflexivity.
Qed.

(* Xor conmuta para positivos. *)
Theorem xor_comm_pos: forall p1 p2, Pos.lxor p1 p2 = Pos.lxor p2 p1.
induction p1.
+ intro.
  simpl.
  destruct p2 eqn:P2.
  - rewrite IHp1.
    reflexivity.
  - rewrite IHp1.
    reflexivity.
  - reflexivity.
+ intro.
  simpl.
  destruct p2 eqn:P2.
  - rewrite IHp1; reflexivity.
  - rewrite IHp1; reflexivity.
  - reflexivity.
+ intro.
  destruct p2 eqn:P2; reflexivity.
Qed.

(* lxor es conmutativo *)
Theorem xor_comm: forall n1 n2, N.lxor n1 n2 = N.lxor n2 n1.
Proof.
destruct n1, n2.
+ reflexivity.
+ reflexivity.
+ reflexivity.
+ simpl; rewrite xor_comm_pos; trivial.
Qed.

(* branchingBit es conmutativo. *)
Lemma branchingBit_comm: forall x k, branchingBit x k = branchingBit k x.
Proof.
intros.
unfold branchingBit.
rewrite xor_comm.
trivial.
Qed.

(* Predecesor de 1 es 0 *)
Lemma pred_1: forall x, Pos.pred_N x = N0 -> x = xH.
Proof.
destruct x; simpl.
+ intro.
  inversion H.
+ intro.
  inversion H.
+ intro.
  trivial.
Qed.

(* El predecesor del doble del bit más bajo de un número es es el predecesor del
   número con un 1 pegado.*)
Lemma pred_double_pred: forall (x w:positive), Pos.pred_N (lowestBitP x) = pos w -> Pos.pred_double (lowestBitP x) = (xI w).
Proof.
induction x.
+ intros.
  simpl in H.
  inversion H.
+ intros.
  simpl in H.
  simpl.
  inversion H.
  trivial.
+ intros.
  simpl in H.
  inversion H.
Qed.

Lemma lowestBit_mask: forall x, mask x (lowestBit x) = N0.
Proof.
induction x.
+ reflexivity.
+ induction p.
  - reflexivity.
  - simpl.
    simpl in IHp.
    destruct (Pos.pred_N (lowestBitP p)) eqn:Predecessor.
    * unfold Pos.pred_N in Predecessor.
      ++ assert (lowestBitP p = 1%positive).
         -- destruct (lowestBitP p) eqn:Low.
            ** inversion Predecessor.
            ** inversion Predecessor.
            ** trivial.
         -- rewrite H.
            reflexivity.
    * apply pred_double_pred in Predecessor.
      rewrite Predecessor.
      rewrite IHp.
      reflexivity.
  - reflexivity.
Qed.

(* Multiplicar por dos es pegar un 0 *)
Theorem Ndouble_0: forall p, Pos.Ndouble (pos p) = pos (p~0).
Proof.
destruct p; reflexivity.
Qed.

(* Lemma auxiliar sobre branchingBit. *)
Lemma branchingBit_end1: forall p1 p2 x, branchingBit (pos p1) (pos p2) = pos x ->
                                         branchingBit (pos p1~1) (pos p2~1) = pos x~0.
Proof.
induction p1.
+ intros.
  unfold branchingBit.
  simpl.
  unfold branchingBit in H; simpl in H.
  destruct p2 eqn:P2.
  - simpl.
    destruct (Pos.Ndouble (Pos.lxor p1 p)) eqn:Double.
    * simpl in H.
      inversion H.
    * rewrite Ndouble_0.
      simpl in H.
      simpl.
      inversion H.
      trivial.
  - unfold lowestBit in H.
    unfold Pos.Nsucc_double in H.
    destruct (Pos.lxor p1 p) eqn:Xor.
    * simpl in H.
      simpl.
      inversion H.
      trivial.
    * simpl in H.
      inversion H.
      reflexivity.
  - unfold lowestBit in H.
    simpl in H.
    unfold lowestBit.
    simpl.
    inversion H.
    trivial.
+ intros.
  unfold branchingBit in H.
  simpl in H.
  destruct p2 eqn:P2.
  - unfold lowestBit in H.
    destruct (Pos.lxor p1 p) eqn:Xor.
    * simpl in H.
      inversion H.
      unfold branchingBit.
      simpl.
      rewrite Xor.
      reflexivity.
    * unfold branchingBit.
      simpl.
      rewrite Xor.
      simpl.
      inversion H.
      trivial.
  - destruct (Pos.lxor p1 p) eqn:Xor.
    * inversion H.
    * inversion H.
      unfold branchingBit.
      simpl.
      rewrite Xor.
      reflexivity.
  - inversion H.
    unfold branchingBit.
    reflexivity.
+ intros.
  unfold branchingBit in H.
  inversion H.
  destruct p2 eqn:P2.
  - unfold branchingBit.
    simpl.
    inversion H1.
    trivial.
  - inversion H1.
    unfold branchingBit; reflexivity.
  - inversion H1.
Qed.

(* Auxiliar, predecesor del doble es predecesor del número con un 0 pegado *)
Lemma pred_double_pred_0: forall x, pos (Pos.pred_double x) = N.pred (pos (x~0)).
Proof.
destruct x; reflexivity.
Qed.

(* Auxiliar *)
Lemma first_branchingBit: forall p1 p2, branchingBit (pos p1~0) (pos p2~1) = (pos xH).
Proof.
unfold branchingBit.
unfold lowestBit.
intros.
destruct (N.lxor (pos p1~0) (pos p2~1)) eqn:Xor.
+ simpl in Xor.
  unfold Pos.Nsucc_double in Xor.
  - destruct (Pos.lxor p1 p2) eqn:Xor2.
    * inversion Xor.
    * inversion Xor.
+ destruct p eqn:P.
  - reflexivity.
  - simpl in Xor.
    unfold Pos.Nsucc_double in Xor.
    destruct (Pos.lxor p1 p2) eqn:Xor2.
    * inversion Xor.
    * inversion Xor.
  - reflexivity.
Qed.

(* Lema auxiliar para positivos *)
Lemma obvious_matchP_pos: forall p x, matchPrefix (pos p) (mask x (branchingBit x (pos p)))
  (branchingBit x (pos p)) = true.
Proof.
induction p.
+ intro.
  unfold matchPrefix.
  simpl.
  destruct x eqn:X.
  - reflexivity.
  - simpl.
    destruct p0 eqn:P0.
    * simpl.
      destruct (branchingBit (pos p1) (pos p)) eqn:Branch.
      ++ unfold branchingBit in Branch.
         simpl in Branch.
         destruct (Pos.lxor p1 p) eqn:Xor.
         -- unfold branchingBit.
            simpl.
            rewrite Xor.
            reflexivity.
         -- destruct p2 eqn:P2.
            ** simpl in Branch.
               inversion Branch.
            ** inversion Branch.
            ** inversion Branch.
      ++ rewrite (branchingBit_end1 p1 p p2).
         -- simpl.
            destruct p2 eqn:P2.
            ** unfold branchingBit in Branch.
               simpl in Branch.
               destruct (Pos.lxor p1 p) eqn:Xor.
               +++ inversion Branch.
               +++ destruct p4 eqn:P4; inversion Branch.
            ** simpl.
               unfold matchPrefix in IHp.
               unfold branchingBit in IHp.
               unfold branchingBit in Branch.
               unfold lowestBit in Branch.
               destruct (N.lxor (pos p1) (pos p)) eqn:Xor.
               +++ inversion Branch.
               +++ simpl in IHp.
                   assert (Hip:= (IHp (pos p1))).
                   rewrite Xor in Hip.
                   destruct (lowestBit (pos p4)) eqn:Low.
                   --- unfold lowestBit in Low.
                       inversion Low.
                   --- destruct p5 eqn:P5.
                       *** simpl in Hip.
                           simpl in Low.
                           inversion Low.
                           inversion Branch.
                           rewrite H0 in H1.
                           inversion H1.
                       *** simpl in Hip.
                           inversion Low; inversion Branch.
                           rewrite H0 in H1.
                           inversion H1.
                           rewrite <- H2.
                           apply eqb_eq in Hip.
                           rewrite Hip.
                           apply eqb_eq.
                           trivial.
                       *** simpl in Low; inversion Branch; inversion Low.
                           rewrite H0 in H1; inversion H1.
            ** reflexivity.
         -- trivial.
    * simpl.
      rewrite first_branchingBit.
      reflexivity.
    * simpl.
Admitted.

Lemma obvious_matchP2: forall k x, matchPrefix k (mask x (branchingBit x k))
             (branchingBit x k) = true.
Proof.
induction k.
+ unfold matchPrefix.
  intro.
  simpl.
  rewrite branchingBit_comm.
  unfold branchingBit.
  simpl.
  rewrite lowestBit_mask.
  trivial.
+ intro.
  unfold matchPrefix.
  simpl.
  destruct (N.pred (branchingBit x (pos p))) eqn:Pred.
  - simpl.
Admitted.

(* Un número siempre tiene branchingBit 0 con si mismo *)
Lemma zeroBit_self: forall k, zeroBit k (branchingBit k k) = true.
Proof.
intro.
unfold branchingBit.
unfold lowestBit.
unfold zeroBit.
destruct k.
+ reflexivity.
+ rewrite xor_zero.
  simpl.
  trivial.
Qed.

(* Lema auxiliar *)
Lemma branchingBit_zero_r: forall x, branchingBit x N0 = lowestBit x.
Proof.
intro.
unfold branchingBit.
destruct x eqn:X.
+ reflexivity.
+ reflexivity.
Qed.

(* El bit más pequeño prendido de un número que termina en 0 no es el último. *)
Lemma lowestBit_not_last: forall p, lowestBitP (xO p) = xO (lowestBitP p).
Proof.
destruct p; reflexivity.
Qed.

(* Si el doble de un número es 0, el número es 0. *)
Lemma double_zero: forall p, Pos.Ndouble p = N0 -> p = N0.
induction p.
+ reflexivity.
+ intros.
  simpl in H.
  inversion H.
Qed.

(* La máscara conserva bit 0. *)
Lemma mask_cons_0: forall p q, mask (pos (xO p)) (pos (xO q)) = N0 -> mask (pos p) (pos q) = N0.
Proof.
induction p.
+ intros.
  destruct q eqn:Q.
  - simpl.
    simpl in H.
    apply double_zero in H.
    trivial.
  - simpl in H.
    simpl.
    apply double_zero in H; trivial.
  - reflexivity.
+ intros.
  simpl.
  destruct (Pos.pred_N q) eqn:Predq.
  - trivial.
  - destruct p0 eqn:P0.
    * simpl in IHp.
Admitted.

(* La máscara de un número con su bit prendido más pequeño es 0. *)
Lemma mask_lowestBit: forall p, mask (pos p) (lowestBit (pos p)) = N0.
Proof.
destruct p.
+ reflexivity.
+ induction p.
  - reflexivity.
  - unfold lowestBit.
    rewrite lowestBit_not_last.
Admitted.

(* Lema auxiliar *)
Lemma compl_matchP: forall a x, matchPrefix a (mask x (branchingBit x a)) (branchingBit x a) = true.
Proof.
induction a.
+ simpl.
  intro.
  destruct x eqn:X.
  * reflexivity.
  * rewrite branchingBit_zero_r.
    simpl.
    destruct (Pos.pred_N (lowestBitP p)) eqn:Pos.
    - reflexivity.
    - unfold matchPrefix.
      unfold mask.
      simpl.
Admitted.

(* matchPrefix k x y = false /\ matchPrefix k x z = true -> z < y *)
Lemma matchP_lt: forall k x y z, matchPrefix k x y = false /\ matchPrefix k x z = true -> (N.lt z y).
Proof.
induction k.
+ intros.
  destruct H.
  unfold matchPrefix in H0.
  unfold mask in H0.
  simpl in H0.
  destruct x eqn:X.
  - unfold matchPrefix in H.
    unfold mask in H.
    simpl in H.
    inversion H.
  - inversion H0.
+ intros.
  unfold matchPrefix in H.
  unfold mask in H.
  destruct H.
  simpl in H.
  simpl in H0.
  destruct y eqn:Y.
  - simpl in H.
    destruct x eqn:X.
    * inversion H.
    * destruct z eqn:Z.
      ++ simpl in H0.
         inversion H0.
      ++ destruct p1 eqn:P1.
         -- simpl in H0.
Admitted.

(* Lema auxiliar matchPrefix k n n0 = true -> n0 < branchingBit en este caso*)
Lemma very_specific: forall k x n n0, matchPrefix k (mask x (branchingBit x n)) (branchingBit x n) = false
                     /\ matchPrefix k n n0 = true -> matchPrefix x n n0 = true.
Proof.
destruct k.
+ intros.
  destruct H.
  unfold matchPrefix in H0.
  simpl in H0.
  destruct n eqn:N.
  - unfold matchPrefix in H.
    simpl in H.
    unfold branchingBit in H.
    rewrite xor_neutral in H.
    rewrite lowestBit_mask in H.
    inversion H.
  - inversion H0.
+ intros.
  induction p.
  - apply IHp.
    unfold matchPrefix in H; unfold branchingBit in H; destruct H.
    simpl in H.
    unfold matchPrefix; unfold branchingBit.
    simpl.
    destruct (lowestBit (N.lxor x n)) eqn:Low.
    * simpl.
      simpl in H.
      split.
      trivial.
      simpl in H0.
      destruct (N.pred n0) eqn:Pred.
      ++ trivial.
      ++ destruct p0 eqn:P0.
         -- simpl in H0.
Admitted.


(* Section の練習 *)

Section Poslist.
  (* このセクションの中では、Aが共通の変数として使える。 *)
  Variable A : Type.
  (* 非空なリスト *)
  Inductive poslist : Type := one: A -> poslist
    | cons: A -> poslist -> poslist.

  Section Fold.
    (* 二項演算 *)
    Variable g : A -> A -> A.

   (* gによって畳み込む。
    * 次のどちらかを定義すること。どちらでもよい。
    * 左畳み込み : リスト [a; b; c] に対して (a * b) * c を計算する。
    * 右畳み込み : リスト [a; b; c] に対して a * (b * c) を計算する。
    *)
    Fixpoint fold (l : poslist): A :=
      match l with
        | one x => x
        | cons x y => g x (fold y)
      end.
    (* DefinitionをFixpointなどに置き換えてもよい。 *)
  End Fold.
  Check fold.
End Poslist.
Check fold.
(* Poslistから抜けたことにより、poslistは変数Aについて量化された形になる。 *)

(* このリストに関するmap関数 *)
Section PoslistMap.
  Variable A B : Type.
  Variable f : A -> B.

  Fixpoint map (ls: poslist A): poslist B :=
    match ls with
    | one _ x => one _ (f x)
    | cons _ x y => cons _ (f x) (map y)
    end.
End PoslistMap.

(* 今回は証明すべきことはないので、定義を正確に *)


Require Import List Orders.
Require Import Coq.Structures.OrdersFacts.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Sorting.Sorted.
Require Import Sorticoq.SortedList.
Import ListNotations.

Module InsertionSort (Import O: UsualOrderedTypeFull').

Include (OrderedTypeFacts O).

Definition A := O.t.

Fixpoint Insert (l: list A) x : list A :=
  match l with
  | [] => [x]
  | h::t => match (O.compare x h) with
    | Lt => x::l
    | _ => h::(Insert t x)
    end
  end.

Definition InsertionSort (l: list A) :=
  @fold_right (list A) A (fun x y => Insert y x) [] l.

Hint Resolve perm_skip perm_swap.
Hint Constructors LocallySorted.
Hint Extern 1 (?x <= ?y) => apply le_lteq; OrderTac.order.

Ltac convert_compare :=
  repeat match goal with
  | H: compare ?x ?y = Lt |- _ => apply compare_lt_iff in H
  | H: compare ?x ?y = Gt |- _ => apply compare_gt_iff in H
  | H: compare ?x ?y = Eq |- _ => apply compare_eq in H
  end.

Lemma Permute: forall l x,
  Permutation (x::l) (Insert l x).
Proof.
  induction l; simpl; auto.
  intros. destruct (compare _ _);
  specialize IHl with x; transitivity (a::x::l); auto.
Qed.

Lemma InsertionSort_Permutation: forall l,
  Permutation l (InsertionSort l).
Proof.
  induction l; simpl; auto.
  transitivity (a::(InsertionSort l)); auto.
  apply Permute.
Qed.

Lemma Insert_LocallySorted: forall l a,
  LocallySorted le l -> LocallySorted le (Insert l a).
Proof.
  induction 1; [simpl | simpl | ]; auto.
  - destruct (compare a a0) eqn:E; convert_compare; subst; auto.
  - simpl in *. destruct (compare _ _) eqn:R1;
    destruct (compare a a0) eqn:R2; convert_compare; subst; auto.
Qed.

Lemma InsertionSort_LocallySorted: forall l,
  LocallySorted le (InsertionSort l).
Proof.
  induction l; simpl; auto.
  apply Insert_LocallySorted; auto.
Qed.

Corollary InsertionSort_Sorted: forall l,
  Sorted le (InsertionSort l).
Proof.
  intros; apply Sorted_LocallySorted_iff.
  apply InsertionSort_LocallySorted.
Qed.

Theorem InsertionSort_is_sorting_algo:
  is_sorting_algo le InsertionSort.
Proof.
  unfold is_sorting_algo; intros; split.
  - apply InsertionSort_Permutation.
  - apply InsertionSort_Sorted.
Qed.

End InsertionSort.

(**
   An example
*)

Require Import ZArith.

Module Import ZSort := InsertionSort Z.

Example SortingExample: [2%Z; 4%Z; 4%Z; 6%Z; 8%Z] =
  (InsertionSort [4%Z; 2%Z; 8%Z; 4%Z; 6%Z]).
Proof.
  compute. reflexivity.
Qed.


Require Export Induction.

Inductive natprod : Type :=
| pair : nat -> nat -> natprod.

Check (pair 3 5).

Definition fst (p : natprod) : nat :=
  match p with
  | pair x y => x
  end.

Definition snd (p : natprod) : nat :=
  match p with
  | pair x y => y
  end.

Compute (fst (pair 3 5)).

Notation "( x , y )" := (pair x y).

Compute (fst (3,5)).

Definition fst' (p : natprod) : nat :=
  match p with
  | (x,y) => x
  end.

Definition snd' (p : natprod) : nat :=
  match p with
  | (x,y) => y
  end.

Definition swap_pair (p : natprod) :=
  match p with
  | (x,y) => (y,x)
  end.

Theorem surjective_pairing' : forall (n m : nat),
  (n,m) = (fst (n,m), snd (n,m)).
Proof.
  simpl. reflexivity.
Qed.

Theorem surjective_pairing : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  intros p. destruct p as [n m].
  simpl. reflexivity.
Qed.

Theorem snd_fst_is_swap : forall (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  intros p. destruct p as [n m].
  simpl. reflexivity.
Qed.

Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  intros p. destruct p as [n m].
  simpl. reflexivity.
Qed.

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

Definition mylist := cons 1 (cons 2 (cons 3 nil)).

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1;2;3].

Fixpoint repeat (n count : nat) : natlist :=
  match count with
  | O => nil
  | S count' => n :: (repeat n count')
  end.

Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => 0
  | h :: t => 1 + (length t)
  end.

Fixpoint app (l_1 l_2 : natlist) : natlist :=
  match l_1 with
  | nil => l_2
  | h :: t => h :: (app t l_2)
  end.

Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).

Example test_appl: [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity. Qed.
Example test_app2: nil ++ [4;5] = [4;5].
Proof. reflexivity. Qed.
Example test_app3: [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity. Qed.

Definition hd (default:nat) (l:natlist) : nat :=
  match l with
  | nil => default
  | h :: t => h
  end.

Definition tl (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.

Example test_hd_1: hd 0 [1;2;3] = 1.
Proof. reflexivity. Qed.
Example test_hd_2: hd 0 [] = 0.
Proof. reflexivity. Qed.
Example test_t1: tl [1;2;3] = [2;3].
Proof. reflexivity. Qed.

Fixpoint nonzeros (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => match beq_nat h 0 with
              | true => nonzeros t
              | false => h :: (nonzeros t)
              end
end.

Example test_nonzeros:
  nonzeros [0;1;0;2;3;0;0] = [1;2;3].
Proof. reflexivity. Qed.

Fixpoint oddmembers (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => match evenb h with
              | true => oddmembers t
              | false => h :: (oddmembers t)
              end
end.

Example test_oddmembers:
  oddmembers [0;1;0;2;3;0;0] = [1;3].
Proof. reflexivity. Qed.

Definition countoddmembers (l:natlist) : nat :=
  length (oddmembers l).

Example test_countoddmembers1:
  countoddmembers [1;0;3;1;4;5] = 4.
Proof. reflexivity. Qed.

Example test_countoddnumbers2:
  countoddmembers [0;2;4] = 0.
Proof. reflexivity. Qed.

Example test_countoddnumbers3:
  countoddmembers nil = 0.
Proof. reflexivity. Qed.

Fixpoint alternate (l_1 l_2 : natlist) : natlist :=
  match l_1 with
  | nil => l_2
  | h :: t => match l_2 with
              | nil => l_1
              | h' :: t' => h :: h' :: (alternate t t')
              end
end.

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

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

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

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

Definition bag := natlist.

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
  | nil => 0
  | h :: t => match beq_nat h v with
              | true => S (count v t)
              | false => count v t
              end
  end.

Example test_count1: count 1 [1;2;3;1;4;1] = 3.
Proof. reflexivity. Qed.

Example test_count2: count 6 [1;2;3;1;4;1] = 0.
Proof. reflexivity. Qed.

Definition sum : bag -> bag -> bag :=
  app.

Example test_sum_1: count 1 (sum [1;2;3] [1;4;1]) = 3.
Proof. reflexivity. Qed.

Definition add (v:nat) (s:bag) : bag :=
  v :: s.

Example test_add1: count 1 (add 1 [1;4;1]) = 3.
Proof. reflexivity. Qed.

Example test_add2: count 5 (add 1 [1;4;1]) = 0.
Proof. reflexivity. Qed.

Definition member (v:nat) (s:bag) : bool :=
  match count v s with
  | 0 => false
  | _ => true
  end.

Example test_member1: member 1 [1;4;1] = true.
Proof. reflexivity. Qed.

Example test_member2: member 2 [1;4;1] = false.
Proof. reflexivity. Qed.

Fixpoint remove_one (v:nat) (s:bag) : bag :=
  match s with
  | nil => nil
  | h :: t => match beq_nat h v with
              | true => t
              | false => h :: (remove_one v t)
              end
  end.

Example test_remove_one1:
  count 5 (remove_one 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_one2:
  count 5 (remove_one 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_one3:
  count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.

Example test_remove_one4:
  count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
Proof. reflexivity. Qed.

Fixpoint remove_all (v:nat) (s:bag) : bag :=
  match s with
  | nil => nil
  | h :: t => match beq_nat h v with
              | true => (remove_all v  t)
              | false => h :: (remove_all v t)
              end
  end.

Example test_remove_all1: count 5 (remove_all 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_all2: count 5 (remove_all 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_all3: count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.

Example test_remove_all4: count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
Proof. reflexivity. Qed.

Fixpoint subset (s_1:bag) (s_2:bag) : bool :=
  match s_1 with
  | nil => true
  | h :: t => match member h s_2 with
              | true => subset t (remove_one h s_2)
              | false => false
              end
  end.

Example test_subset1: subset [1;2] [2;1;4;1] = true.
Proof. reflexivity. Qed.

Example test_subset2: subset [1;2;2] [2;1;4;1] = false.
Proof. reflexivity. Qed.

Theorem nil_app : forall l:natlist,
  [] ++ l = l.
Proof. reflexivity. Qed.

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (tl l).
Proof.
  intros l. destruct l as [| n l'].
  - reflexivity.
  - reflexivity. Qed.

Theorem app_assoc : forall l_1 l_2 l_3 : natlist,
  (l_1 ++ l_2) ++ l_3 = l_1 ++ (l_2 ++ l_3).
Proof.
  intros l_1 l_2 l_3.
  induction l_1 as [| n l_1' IHl1'].
  - reflexivity.
  - simpl. rewrite -> IHl1'. reflexivity. Qed.

Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => (rev t) ++ [h]
  end.

Example test_rev1: rev [1;2;3] = [3;2;1].
Proof. reflexivity. Qed.

Example test_rev2: rev nil = nil.
Proof. reflexivity. Qed.

Theorem app_length : forall l_1 l_2 : natlist,
  length (l_1 ++ l_2) = (length l_1) + (length l_2).
Proof.
  intros l_1 l_2. induction l_1 as [| n l_1' IHl1'].
  - reflexivity.
  - simpl. rewrite -> IHl1'. reflexivity. Qed.

Theorem rev_length : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl1'].
  - reflexivity.
  - simpl. rewrite -> app_length, plus_comm.
    rewrite -> IHl1'. simpl. reflexivity. Qed.

Theorem app_nil_r : forall l : natlist,
  l ++ [] = l.
Proof.
  intros l.
  induction l as [| n l' IHl'].
  - reflexivity.
  - simpl.
    rewrite -> IHl'.
    reflexivity.
  Qed.

Theorem rev_app_distr : forall l_1 l_2 : natlist,
  rev (l_1 ++ l_2) = rev l_2 ++ rev l_1.
Proof.
  intros l_1 l_2.
  induction l_1 as [| n l_1' IHl1'].
  - simpl.
    rewrite -> app_nil_r.
    reflexivity.
  - simpl.
    rewrite -> IHl1'.
    rewrite -> app_assoc.
    reflexivity.
  Qed.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intros l.
  induction l as [| n l' IHl'].
  - reflexivity.
  - simpl.
    rewrite -> rev_app_distr.
    simpl.
    rewrite -> IHl'.
    reflexivity.
  Qed.

Theorem app_assoc4 : forall l_1 l_2 l_3 l_4 : natlist,
  l_1 ++ (l_2 ++ (l_3 ++ l_4)) = ((l_1 ++ l_2) ++ l_3) ++ l_4.
Proof.
  intros l_1 l_2 l_3 l_4.
  rewrite -> app_assoc, app_assoc.
  reflexivity.
Qed.

Lemma nonzeros_app : forall l_1 l_2 : natlist,
  nonzeros (l_1 ++ l_2) = (nonzeros l_1) ++ (nonzeros l_2).
Proof.
  intros l_1 l_2.
  induction l_1 as [|n l_1' IHl1'].
  - reflexivity.
  - simpl.
    rewrite -> IHl1'.
    destruct beq_nat.
    + reflexivity.
    + reflexivity.
  Qed.

Fixpoint beq_natlist (l_1 l_2 : natlist) : bool :=
   match l_1 with
    | nil => match l_2 with
             | nil => true
             | _ => false
             end
    | h1 :: t1 => match l_2 with
                  | nil => false
                  | h2 :: t2 => beq_nat h1 h2 && beq_natlist t1 t2
                  end
    end.

Example test_beq_natlist1 :
  (beq_natlist nil nil = true).
Proof.
  reflexivity.
Qed.

Example test_beq_natlist2 :
  beq_natlist [1;2;3] [1;2;3] = true.
Proof.
  reflexivity.
Qed.

Example test_beq_natlist3 :
  beq_natlist [1;2;3] [1;2;4] = false.
Proof.
  reflexivity.
Qed.

Theorem beq_nat_refl : forall n : nat,
  true = beq_nat n n.
Proof.
  intros n. induction n as [|n' IHn'].
  - simpl. reflexivity.
  - simpl. rewrite <- IHn'. reflexivity.
Qed.

Theorem beq_natlist_refl : forall l:natlist,
  true = beq_natlist l l.
Proof.
  intros l.
  induction l as [| n l' IHl'].
  - reflexivity.
  - simpl.
    rewrite <- IHl'.
    rewrite <- beq_nat_refl.
    reflexivity.
Qed.

Theorem count_member_nonzero : forall s:bag,
  leb 1 (count 1 (1 :: s)) = true.
Proof.
  intros s.
  reflexivity.
Qed.

Theorem ble_n_Sn : forall n,
  leb n (S n) = true.
Proof.
  intros n.
  induction n as [| n' IHn'].
  - reflexivity.
  - simpl.
    rewrite -> IHn'.
    reflexivity.
Qed.

Theorem remove_does_not_increase_count : forall (s : bag),
  leb (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  intros l.
  induction l as [| n l' IHl'].
  - reflexivity.
  - destruct n as [| n'].
    + simpl.
      rewrite -> ble_n_Sn.
      reflexivity.
    + simpl.
      rewrite -> IHl'.
      reflexivity.
Qed.


Require Export Arith.
Require Export XR_S_INR.
Require Export XR_Rplus_0_r.
Require Export XR_Rplus_assoc.

Local Open Scope R_scope.

Lemma plus_INR : forall n m:nat,
  INR (n + m) = INR n + INR m.
Proof.
  intros n m.
  induction m as [ | m im ].
  {
    simpl.
    rewrite Rplus_0_r.
    rewrite <- plus_n_O.
    reflexivity.
  }
  {
    rewrite Nat.add_comm.
    simpl.
    rewrite S_INR.
    rewrite Nat.add_comm.
    rewrite im.
    rewrite S_INR.
    repeat rewrite <- Rplus_assoc.
    reflexivity.
  }
Qed.


(* 変数名 x, y, z *)
Definition var := nat.
Definition eqb := Nat.eqb.

(* 型名 S, T *)
Inductive type :=
  | tyBool
  | tyFun : type -> type -> type.

(* 文脈 C *)
Definition context := var -> type -> Prop.
(* C, x1 : T1 *)
Definition append (C:context) x1 T1 x2 T2 := x1 = x2 /\ T1 = T2 \/ C x2 T2.
(* 空の文脈 *)
Definition empty_context:context := fun x T => False.

(* 値 u, v，項 s, t *)
Inductive term :=
  | tmVal : value -> term
  | tmIf : term -> term -> term -> term (* if t then t else t *)
  | tmVar : var -> term
  | tmApp : term -> term -> term (* t t *)
with value :=
  | vTrue | vFalse
  | vAbs : nat -> type -> term -> value  (* λx:T.t *).

Definition tmTrue := tmVal vTrue.
Definition tmFalse := tmVal vFalse.
Definition tmAbs x T t := tmVal (vAbs x T t).

(* C ⊢ t : T *)
Fixpoint is_type_candidate C t T {struct t} :=
  match t, T with
  | tmVal vTrue, tyBool => True
  | tmVal vFalse, tyBool => True
  | tmVal (vAbs x T1 t1), tyFun T2 T3 => T1 = T2 /\ is_type_candidate (append C x T1) t1 T3
  | tmIf t1 t2 t3, T1 => is_type_candidate C t1 tyBool /\ is_type_candidate C t2 T1 /\ is_type_candidate C t3 T1
  | tmVar x, T1 => C x T1
  | tmApp t1 t2, T1 => exists T2, is_type_candidate C t1 (tyFun T2 T1) /\ is_type_candidate C t2 T2
  | _, _ => False
  end.

Definition is_typed t T :=
  is_type_candidate empty_context t T
  /\ forall S, is_type_candidate empty_context t S -> S = T.

Example type_of_true : is_typed tmTrue tyBool.
Proof.
  split.
  - simpl.
    trivial.
  - destruct S.
    reflexivity.
    contradiction.
Qed.
Example type_of_false : is_typed tmFalse tyBool.
Proof.
  split.
  - simpl.
    trivial.
  - destruct S.
    reflexivity.
    contradiction.
Qed.

Goal
  let t := (tmAbs 0 tyBool (tmAbs 0 (tyFun tyBool tyBool) (tmApp (tmVar 0) (tmVar 0)))) in
  let T := (tyFun tyBool (tyFun (tyFun tyBool tyBool) tyBool)) in
  is_typed t T.
Proof.
  intros t T.
  assert (is_type_candidate empty_context t T). {
    split. reflexivity. split. reflexivity.
    exists tyBool. split.
    - left. split. reflexivity. reflexivity.
    - right. left. split. reflexivity. reflexivity.
  }
  split. exact H. destruct S.
  - contradiction.
  - destruct S2 as [| S21 S22].
    + intros [_ H0]. contradiction.
    + destruct S22.
      * intros [HS1 [HS21 _]].
        rewrite <-HS1, <-HS21.
        reflexivity.
      * intros [_[_[S22[[[_ HS221]|[[_ HS222]|HS223]] _]]]].
        discriminate. discriminate. contradiction.
Qed.


(* dokumentacja
https://coq.inria.fr/distrib/current/refman/index.html
*)

Check Set.
Check Prop.
Check Type.

Section Logic.

Variables A B C : Prop.

Check True.
Check False.
Check and.
Check or.
Check not.

Check (A \/ B).
Check (A /\ B).
Check (A -> B).

Search "/\".

Lemma id_auto:
A -> A.
Proof.
auto.
Qed.

Lemma id_2:
A -> A.
Proof.
intro.
assumption.
Qed.

Print id_2.

Lemma contraction:
A /\ A -> A.
Proof.
intro.
destruct H.
assumption.
Qed.

Lemma apply:
(A -> B) -> A -> B.
Proof.
intros H1 H2.
apply H1.
assumption.
Qed.

Print apply.

Variable T : Type.
Variable P Q : T -> Prop.

Lemma first_order:
(forall x, P x) \/ (forall x, Q x) -> forall x, P x \/ Q x.
Proof.
intros.
destruct H.
left.
apply H.
right.
apply H.
Qed.

End Logic.

Section Nats.

Check nat.
Check 0.
Check (fun x => x).
Check (fun x => x + 0).

Definition double := fun x => x * 2.
Check double.

Eval compute in (double 4).

(* Popraw definicje compose *)

(* Definition compose := fun f => fun g => fun x => f (g x).*)

End Nats.

Section Lambda.

Variable L : Type.
Variable red_trans_refl : L -> L -> Prop. (* ->*_beta *)

(* Uzupelnij definicje *)

(* t jest w postaci normalnej *)
Definition normal t : Prop :=
.

(* red_trans_refl jest konfluentna *)
Definition confluent : Prop :=
.

(* t ma postac normalna *)
Definition has_normal  t : Prop :=
.

(* Zapisz lemat: istnieje term, ktory nie ma postaci normalnej *)

End Lambda.


Require Export InsertionSortAlgorithm.

(** Sorting stuff **)

(** Preliminary lemmas:
    Here we prove some general facts that will be useful
    later on. *)

(** Count distributes over append as addition *)
Theorem append_add_counts : forall (x y : natlist) (v : nat),
  count v (x ++ y) = count v x + count v y.
Proof.
  intros x y v. induction x as [ | h t].
  Case "x = []". simpl. reflexivity.
  Case "x = h :: t". destruct (beq_nat v h) eqn:Casev.
    SCase "v = h". simpl. rewrite Casev. rewrite IHt. simpl. reflexivity.
    SCase "v != h". simpl. rewrite Casev. rewrite IHt. reflexivity. Qed.

(** Helper for later: If v is not present in a list l, it is not
    present in the tail of l *)
Lemma count_helper : forall (v h : nat) (l : natlist),
  count v (h :: l) = 0 -> count v l = 0.
Proof.
  intros v h l. intros H. simpl in H.
  destruct (beq_nat v h) eqn:Casevh.
  Case "v <= h". inversion H.
  Case "v > h". apply H. Qed.

(** Disjunction of opposites is always true *)
Lemma orb_x_negx_true : forall (b : bool),
  orb b (negb b) = true.
Proof.
  intros b. destruct b.
  Case "b = true". reflexivity.
  Case "b = false". reflexivity. Qed.

(** Equality is transitive *)
Theorem trans_eq : forall (n m o : nat),
  n = m -> m = o -> n = o.
Proof.
  intros n m o eq1 eq2. rewrite -> eq1. rewrite -> eq2. reflexivity.  Qed.

(** Helpful properties of ble_nat:
    Here we assume some basic properties of the less than
    or equal relation.*)

Lemma ble_nat_helper : forall (u v : nat),
  ble_nat (S u) v = true -> ble_nat u v = true.
Proof.
  intros u v.
  intros H.
  induction v as [ | v'].
  simpl in H.
  inversion H.
  simpl in H.
  Admitted.

Theorem ble_nat_transitive : forall (u v w : nat),
  ble_nat u v = true -> ble_nat v w = true -> ble_nat u w = true.
Proof.
  intros u v w.
  intros H.
  intros H'.
  induction v as [ | v'].
  destruct u as [ | u'].
  reflexivity.
  simpl in H.
  inversion H.
  Admitted.

Lemma ble_nat_anticomm : forall (u v : nat),
  (ble_nat u v) = false -> (ble_nat v u) = true.
Proof.
  intros u v.
  intros H.
  induction u as [ | u'].
  Case "u = 0".
  simpl. simpl in H.
  destruct (ble_nat v 0).
  reflexivity.
  rewrite H. reflexivity.
  induction v as [ | v'].
  simpl. reflexivity.
  simpl. simpl in IHu'.
  Admitted.

Lemma ble_nat_helper1 : forall (u v w: nat),
  ble_nat u v = false -> ble_nat u w = true -> beq_nat v w = false.
Proof.
  intros u v w. intros H. intros H'.
  Admitted.

(** Sorting basics:
    Here we introduce predicates that test whether a list
    is sorted, and whether one list is a permutation of another.
    We use these two properties to define what it means for a
    sorting algorithm to be correct: it has to produce a sorted
    list which is a permutation of the original list *)

(** Sortedness predicate: compare first two elements, and recurse *)
Fixpoint is_sorted (l : natlist) : bool :=
  match l with
  | [] => true
  | h :: t => match t with
              | [] => true
              | h1 :: t1 => andb (ble_nat h h1) (is_sorted t)
  end
  end.

(** Permutation predicate: every natural number appears the
    same number of times in the two lists *)
Definition is_permutation (l l' : natlist) : Prop :=
  forall (v : nat), (count v l) = (count v l').

(** Helpful properties of is_sorted *)

(** Appending an element smaller than the head to a sorted list
    preserves sortedness *)
Lemma sorted_from_tail : forall (l : natlist) (v h : nat),
  andb (ble_nat v h) (is_sorted (h :: l)) = true -> is_sorted (v :: h :: l) = true.
Proof.
  intros l v h. intros H. simpl in H. simpl. apply H. Qed.

(** For a sorted list, the tail is sorted *)
Lemma sorted_implies_subsorted : forall (l : natlist) (v : nat),
  is_sorted (v :: l) = true -> is_sorted l = true.
Proof.
  intros l v. intros H. simpl.
  destruct l as [ | h t].
  Case "l = []". simpl. reflexivity.
  Case "l = h t".
    simpl in H.  apply andb_true_elim2 in H.
    destruct t as [ | h' t'].
    SCase "t = []". simpl. reflexivity.
    SCase "t = h' t'". apply sorted_from_tail. apply H. Qed.

(** Predicate that tests whether an element is less than or equal to
    all elements in a given list. This will be useful later on
    when we prove correctness of insertion sort, so we'll prove
    some properties of that predicate now. *)
Fixpoint leq_than_all (v : nat) (l : natlist) : bool :=
  match l with
  | [] => true
  | h :: t => andb (ble_nat v h) (leq_than_all v t)
  end.

(** For a sorted list, the head is <= all elements of the tail *)
Lemma sorted_implies_head_leq_than_all : forall (v : nat) (l : natlist),
  is_sorted (v :: l) = true -> leq_than_all v l = true.
Proof.
  intros v l. intros H. induction l as [ | h t].
  (* we induct on the list l: the rest is piecing
     the inequalities in the right way and doing casework
     unfolding is_sorted and leq_than_all. The key point is that
     the two functions are defined in terms of the same recursion. *)
  Case "l = []". simpl. reflexivity.
  Case "l = h :: t". simpl.
    assert (Lemma1 : is_sorted (v :: h :: t) = true).
      SCase "Proof of Lemma 1". apply H.
    assert (Lemma2 : ble_nat v h = true).
      SCase "Proof of Lemma 2". simpl in Lemma1. apply andb_true_elim1 in Lemma1.
        apply Lemma1.
  rewrite Lemma2.
  assert (Lemma3 : is_sorted t = true).
    SCase "Proof of Lemma 3". apply sorted_implies_subsorted in H.
      apply sorted_implies_subsorted in H. apply H.
  destruct t as [ | h' t'].
  SCase "t = []". simpl. reflexivity.
  SCase "t = h' :: t'".
    apply sorted_implies_subsorted in H. simpl in H. apply andb_true_elim1 in H.
  assert (Lemma4 : ble_nat v h' = true).
    SSCase "Proof of Lemma 4".
      apply ble_nat_transitive with (v := h). apply Lemma2. apply H.
  assert (Lemma5 : is_sorted (v :: h' :: t') = true).
    SSCase "Proof of Lemma 5".
      apply sorted_from_tail. rewrite Lemma4. rewrite Lemma3. simpl. reflexivity.
  assert (Lemma6 : leq_than_all v (h' :: t') = true).
    SSCase "Proof of Lemma 6".
      apply IHt. apply Lemma5.
  rewrite Lemma6. simpl. reflexivity. Qed.

(** Helpful properties of is_permutation: among other things, here we show
    that the permutation relation we've defined is an equivalence
    relation: that is, it is reflexive, symmetric and transitive. *)

Theorem is_permutation_reflexive : forall (l : natlist),
  is_permutation l l.
Proof.
  intros l. unfold is_permutation. reflexivity. Qed.

Theorem is_permutation_symmetric : forall (l l' : natlist),
  is_permutation l l' -> is_permutation l' l.
Proof.
  intros l l'. intros H. unfold is_permutation in H. symmetry in H.
  unfold is_permutation. apply H. Qed.

Theorem is_permutation_transitive : forall (l l' l'' : natlist),
  is_permutation l l' -> is_permutation l' l'' -> is_permutation l l''.
Proof.
  intros l l' l''. intros H1. intros H2. unfold is_permutation in H1, H2.
  unfold is_permutation. intros v.
  (* the rest of the proof is just an application of transitivity of
     equality. *)
  assert (Lemma1 : count v l = count v l').
    Case "Proof of Lemma 1". apply H1.
  assert (Lemma2 : count v l' = count v l'').
    Case "Proof of Lemma 2". apply H2.
  apply trans_eq with (m := count v l').
  rewrite Lemma1. reflexivity. rewrite Lemma2. reflexivity. Qed.

(** If two lists can be broken into parts that are permutations of one
    another, the lists are permutations of one another *)
Theorem is_permutation_append : forall (x x' y y' : natlist),
  is_permutation x y -> is_permutation x' y' -> is_permutation (x ++ x') (y ++ y').
Proof.
  intros x x' y y'. intros H. intros H'.
  unfold is_permutation.
  intros v.
  (* at this point, the theorem is a simple consequence of
     the fact that count distributes over append as addition *)
  rewrite append_add_counts. rewrite append_add_counts.
  unfold is_permutation in H, H'. rewrite H. rewrite H'. reflexivity. Qed.

(** For a list of length 2, transpositing the elements is a
    permutation. *)
Theorem is_permutation_transposition : forall (v h : nat),
  is_permutation (v :: [h]) (h :: [v]).
Proof.
  intros v h. unfold is_permutation. intros v0.
  (* this is just a lot of casework *)
  destruct (beq_nat v0 v) eqn:Casev.
  destruct (beq_nat v0 h) eqn:Caseh.
  Case "v0 = v, v0 = h". simpl. rewrite Casev. rewrite Caseh. reflexivity.
  Case "v0 = v, v0 != h". simpl. rewrite Casev. rewrite Caseh. reflexivity.
  destruct (beq_nat v0 h) eqn:Caseh.
  Case "v0 != v, v0 = h". simpl. rewrite Casev. rewrite Caseh. reflexivity.
  Case "v0 != v, v0 != h". simpl. rewrite Casev. rewrite Caseh. reflexivity. Qed.

(** Swapping the first two elements in a list is a permutation *)
 Theorem is_permutation_swap_first : forall (l : natlist) (v h : nat),
  is_permutation (v :: h :: l) (h :: v :: l).
Proof.
  intros l v h.
  (* the goal follows readily by combining is_permutation_transposition
     with is_permutation_append *)
  assert (Lemma1 : is_permutation (v :: [h]) (h :: [v])).
    Case "Proof of Lemma 1". apply is_permutation_transposition.
  apply is_permutation_append with (x := (v :: [h]))
                                   (x' := l) (y := (h :: [v])) (y' := l).
  apply is_permutation_transposition. apply is_permutation_reflexive. Qed.

(** Prepending the same element to two lists that are permutations
    of each other preserves the permutation relation. *)
Theorem is_permutation_same_head : forall (v : nat) (l l' : natlist),
  is_permutation l l' -> is_permutation (v :: l) (v :: l').
Proof.
  intros v l l'. intros H.
  (* this easily follows by is_permutation_append *)
  apply is_permutation_append with (x := [v]) (x' := l) (y := [v]) (y' := l').
  apply is_permutation_reflexive. apply H. Qed.

(** Insertion sort : correctness.
    Here we show insertion sort is correct, that is, for every list
    l, (insertion_sort l) is a sorted list and a permutation of l. *)

(** Permutation correctness: here we show that for every list l,
    (insertion_sort l) is a permutation of l. *)

(* First, we show that the insert subroutine gives a permutation
   of what we would get if we just inserted in the first position. *)
Theorem insert_is_permutation : forall (v : nat) (l : natlist),
  is_permutation (v :: l) (insert v l).
Proof.
  intros v l. induction l as [ | h t].
  Case "l = []". simpl. apply is_permutation_reflexive.
  Case "l = h :: t".
  destruct (ble_nat v h) eqn:Case1.
    SCase "v <= h".
      simpl. rewrite Case1. apply is_permutation_reflexive.
    SCase "v > h".
      simpl. rewrite -> Case1.
      assert (Lemma1 : is_permutation (v :: h :: t) (h :: v :: t)).
        SSCase "Proof of Lemma 1". apply is_permutation_swap_first.
      apply is_permutation_transitive with (l' := (h :: v :: t)).
        apply Lemma1.
        apply is_permutation_same_head with (v := h) (l := (v :: t))
                                                     (l' := (insert v t)).
        apply IHt. Qed.

(* Now it's easy to show the main lemma *)
Theorem insertion_sort_is_permutation : forall (l : natlist),
  is_permutation l (insertion_sort l).
Proof.
  intros l. induction l as [ | h t].
  Case "l = []".
  simpl. apply is_permutation_reflexive.
  Case "l = h :: t".
  simpl.
  assert (Lemma1 : is_permutation (insert h (insertion_sort t)) (h :: (insertion_sort t))).
  SCase "Proof of Lemma 1". apply is_permutation_symmetric. apply insert_is_permutation.
  assert (Lemma2 : is_permutation (h :: t) (h :: (insertion_sort t))).
  SCase "Proof of Lemma 2". apply is_permutation_same_head. apply IHt.
  apply is_permutation_symmetric in Lemma1.
  apply is_permutation_transitive with (l' := (h :: insertion_sort t)).
  apply Lemma2.
  apply Lemma1. Qed.

(* Sortedness correctness *)

Theorem leq_than_all_alternative_def : forall (v : nat) (l : natlist),
  (leq_than_all v l) = true -> (forall (n : nat), (ble_nat v n) = false -> count n l = 0).
Proof.
  intros v l. intros H. intros n. intros H'. induction l as [ | h t].
  Case "l = []". simpl. reflexivity.
  Case "l = h :: t". simpl.
    assert (Helper1 : leq_than_all v (h :: t) = true).
      SCase "Proof of Helper 1". rewrite H. reflexivity.
    assert (Helper2 : leq_than_all v (h :: t) = true).
      SCase "Proof of Helper 1". rewrite H. reflexivity.
    assert (Lemma1: leq_than_all v t = true).
      SCase "Proof of Lemma 1". simpl in Helper1. apply andb_true_elim2 in Helper1.
        apply Helper1.
    rewrite Lemma1 in IHt. rewrite IHt.
    assert (Lemma2: ble_nat v h = true).
      SCase "Proof of Lemma 2". simpl in Helper2. apply andb_true_elim1 in Helper2.
        apply Helper2.
    assert (Lemma3: beq_nat n h = false).
      SCase "Proof of Lemma 3". apply ble_nat_helper1 with (u := v).
        apply H'. apply Lemma2.
  rewrite Lemma3. reflexivity. reflexivity. Qed.

Theorem leq_than_all_alternative_def1 : forall (v : nat) (l : natlist),
  (forall (n : nat), (ble_nat v n) = false -> count n l = 0) -> (leq_than_all v l) = true.
Proof.
  intros v l. intros H. induction l as [ | h t].
  Case "l = []". simpl. reflexivity.
  Case "l = h :: t". simpl.
  assert (Lemma1 : forall (n : nat), count n (h :: t) = 0 -> count n t = 0).
    SCase "Proof of Lemma 1". intros n. apply count_helper.
  assert (Lemma2 : forall n : nat, ble_nat v n = false -> count n t = 0).
    SCase "Proof of Lemma 2". intros n H'. apply Lemma1. apply H. apply H'.
  assert (Lemma3 : leq_than_all v t = true).
    SCase "Proof of Lemma 3". apply IHt. apply Lemma2.
  rewrite Lemma3. destruct (ble_nat v h) eqn:Casevh.
  SCase "v <= h". simpl. reflexivity.
  SCase "v > h".
  assert (Lemma4 : count h (h :: t) = 0).
    SSCase "Proof of Lemma 4". apply H. apply Casevh.
  simpl in Lemma4. rewrite <- beq_nat_refl in Lemma4. inversion Lemma4. Qed.

Theorem leq_than_all_invariant_permutation : forall (v : nat) (l l' : natlist),
  is_permutation l l' -> (leq_than_all v l) = true -> (leq_than_all v l') = true.
Proof.
  intros v l l'. intros H. intros H'. unfold is_permutation in H.
  assert (Lemma1 : forall (n : nat), (ble_nat v n) = false -> count n l = 0).
    Case "Proof of Lemma 1". apply leq_than_all_alternative_def. apply H'.
  assert (Lemma2 : forall (n : nat), (ble_nat v n) = false -> count n l' = 0).
    Case "Proof of Lemma 2". intros n.
      assert (Lemma21 : count n l = count n l'). apply H.
      rewrite <- Lemma21. apply Lemma1.
  apply leq_than_all_alternative_def1. apply Lemma2. Qed.

Theorem insertion_helper : forall (l : natlist) (v h: nat),
  leq_than_all v l = true -> ble_nat v h = true -> leq_than_all v (insert h l) = true.
Proof.
  intros l v h. intros H. intros H'.
  assert (Lemma1 : leq_than_all v (h :: l) = true).
    Case "Proof of Lemma 1". simpl. rewrite H. rewrite H'. simpl. reflexivity.
  assert (Lemma2 : is_permutation (h :: l) (insert h l)).
    Case "Proof of Lemma 2". apply insert_is_permutation.
  apply leq_than_all_invariant_permutation with (l := (h :: l)).
  apply Lemma2. apply Lemma1. Qed.

Theorem insert_preserves_sortedness : forall (v : nat) (l : natlist),
  is_sorted l = true -> is_sorted (insert v l) = true.
Proof.
  intros v l. intros H. induction l as [ | h t].
  Case "l = []". simpl. reflexivity.
  Case "l = h :: t". simpl.
    assert (Lemma1: andb (ble_nat v h) (is_sorted (h :: t)) = true
                    -> is_sorted (v :: h :: t) = true).
      SCase "Proof of Lemma 1". apply sorted_from_tail.
    assert (Lemma2 : is_sorted (h :: t) = true).
      SCase "Proof of Lemma 2". rewrite H. reflexivity.
    assert (Lemma3: is_sorted t = true).
      SCase "Proof of Lemma 3".
        apply sorted_implies_subsorted in Lemma2. rewrite -> Lemma2. reflexivity.
    assert (Lemma4: is_sorted (insert v t) = true).
      SCase "Proof of Lemma 4". rewrite Lemma3 in IHt. apply IHt. reflexivity.
  destruct (insert v t) as [ | h' t'] eqn:Caseinsert.
    SCase "insert v t = []". destruct (ble_nat v h) eqn:Casevh.
      rewrite H in Lemma1. apply Lemma1. simpl. reflexivity. simpl. reflexivity.
    SCase "insert v t = h' :: t'". destruct (ble_nat v h) eqn:Casevh.
      SSCase "v <= h". rewrite H in Lemma1. apply Lemma1. simpl. reflexivity.
      SSCase "v > h".
        assert (Lemma5 : ble_nat h v = true).
          SSSCase "Proof of Lemma 5". apply ble_nat_anticomm. apply Casevh.
        assert (Lemma6 : leq_than_all h t = true).
          SSSCase "Proof of Lemma 6".
            apply sorted_implies_head_leq_than_all. apply H.
        assert (Lemma7 : leq_than_all h (insert v t) = true).
          SSSCase "Proof of Lemma 7".
            apply insertion_helper. apply Lemma6. apply Lemma5.
        assert (Lemma8 : ble_nat h h' = true).
          SSSCase "Proof of Lemma 8".
            rewrite Caseinsert in Lemma7. simpl in Lemma7.
            apply andb_true_elim1 in Lemma7. apply Lemma7.
      apply sorted_from_tail. rewrite Lemma8. rewrite Lemma4. simpl. reflexivity. Qed.

Theorem insertion_sort_correct : forall (l : natlist),
  is_sorted (insertion_sort l) = true.
Proof.
  intros l. induction l as [ | h t].
  Case "l = []". simpl. reflexivity.
  Case "l = h :: t". simpl.
    apply insert_preserves_sortedness with (v:=h) in IHt.
    rewrite IHt. reflexivity. Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Load Preamble.

(*  Here is the most common formulation of Lawvere's Fixpoint theorem:
    If there is a surjection X -> X -> Y, then every function Y -> Y
    has a fixpoint.
 *)
Section Lawvere.
  Variables X Y : Type.
  Implicit Type g : Y -> Y.
  Implicit Type f : X -> X -> Y.

  Fact Lawvere_surj f :
    surj f -> forall g, exists y, g y = y.
  Proof.
    intros Surj g.
    destruct (Surj (fun x => g (f x x))) as [a Ha].
    exists (f a a). pattern (f a) at 2.
    now rewrite Ha.
  Qed.
End Lawvere.

(*  Remark (2.2) on nLab: Lawvere remarks that surjectivity up to
    functional extensionality (he calls it weak surj.) is enough
    to show the fixpoint theorem.

    We additionally want to note that we can generalize from the
    function type Y -> Y to relations Y -> Y -> Prop. This turns
    the fixpoint-theorem into a theorem showing the existence of
    a reflexive element.
 *)
Section repr.
  Variables I X Y : Type.
  Implicit Type R : X -> Y -> Prop.

  Definition repr R f :=
    forall x : X, R x (f x).

  Definition ext_repr R f :=
    exists i : I, repr R (f i).

  Definition ext_surj f :=
    forall R, ext_repr R f.
End repr.
Arguments repr {_ _}.
Arguments ext_repr {_ _ _}.
Arguments ext_surj {_ _ _}.

Section Lawvere.

Variables X Y : Type.
Implicit Type R : Y -> Y -> Prop.
Implicit Type f : X -> X -> Y.

Definition diag R f := fun x => R (f x x).

(*  If we are interested in a reflexive point for one particular
    relation R, we only need a representation (up to extensionality)
    of R (f x x)
 *)
Fact diag_refl R f :
  forall a, repr (diag R f) (f a) -> R (f a a) (f a a).
Proof.
  refine (fun a H => H a).
Qed.

Fact Lawvere_diag R f :
  ext_repr (diag R f) f -> exists y, R y y.
Proof.
  intros [a ?%diag_refl]. now exists (f a a).
Qed.

Fact Lawvere f :
  ext_surj f -> forall R, exists y, R y y.
Proof.
  intros Hf R. apply (Lawvere_diag R f), Hf.
Qed.

Fact CP_Lawvere :
  (exists R, forall y, ~ R y y) -> forall f, ~ ext_surj f.
Proof.
  intros [g Hg] f Hf.
  destruct (Lawvere f Hf g) as [y ].
  now apply (Hg y).
Qed.

End Lawvere.

Definition Pow X := X -> bool.
Example Cantor X :
  forall f : X -> Pow X, ~ ext_surj f.
Proof.
  intros f.
  eapply CP_Lawvere.
  exists (fun x y => y = negb x).
  now intros [].
Qed.

Definition Preds X := X -> Prop.
Example Cantor2 X :
  forall f : X -> Preds X, ~ ext_surj f.
Proof.
  intros f.
  eapply CP_Lawvere.
  exists (fun x y => (x <-> ~ y)).
  tauto.
Qed.

Example Negation X :
  ~ exists f : X -> (X -> False), surj f.
Proof.
  intros [f Hf].
  now destruct (Lawvere_surj _ _ _ Hf (fun F => F)) as [[] ].
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Require Export P02.

Theorem contrapositive : forall P Q : Prop,
  (P -> Q) -> (~Q -> ~P).
Proof.
  intros P Q H HQnot.
  unfold not. unfold not in HQnot. intros P'. apply HQnot. apply H. apply P'.
Qed.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.

Section Euclid.

Context `{Ax1:euclidean_neutral}.

Lemma lemma_NCdistinct :
	forall A B C,
	nCol A B C ->
	neq A B /\ neq B C /\ neq A C /\ neq B A /\ neq C B /\ neq C A.
Proof.
	intros A B C.
	intros nCol_A_B_C.
	destruct nCol_A_B_C as (neq_A_B & neq_A_C & neq_B_C & _).
	apply lemma_inequalitysymmetric in neq_A_B as neq_B_A.
	apply lemma_inequalitysymmetric in neq_B_C as neq_C_B.
	apply lemma_inequalitysymmetric in neq_A_C as neq_C_A.

	repeat split.
	exact neq_A_B.
	exact neq_B_C.
	exact neq_A_C.
	exact neq_B_A.
	exact neq_C_B.
	exact neq_C_A.
Qed.

End Euclid.


(** Homework Assignment 0#
#
##Interactive Computer Theorem
Proving#
#
CS294-9, Fall 2006#
#
UC Berkeley *)

(** * Installing Coq *)

(** This section deals with getting Coq, the main tool we'll use in this class,
  up and running.
  - ##Download Coq version
    8.0## from ##the Coq web site##.
    -- Version 8.1 might work for what we'll do in this class, but I haven't
       tried it yet.
    -- For any ##Debian Linux## fans out
       there, there are
       ##Coq Debian
       packages## that aren't mentioned on the Coq download page.
  - Following the installation instructions, you should end up with a
    #<tt>#coqtop#</tt># program that you can invoke from a command-line.  This
    is the simplest, text-based interface to Coq.  Try running
    #<tt>#coqtop#</tt># and stepping through the following interactive session,
    where the text on lines after #<# prompts is for you to enter, and the
    rest should be produced by #<tt>#coqtop#</tt>#.
<<
Welcome to Coq 8.0pl3 (Jan 2006)

Coq < Check (1 + 1 = 2).
1 + 1 = 2
     : Prop

Coq < Goal (1 + 1 = 2).
1 subgoal

  ============================
   1 + 1 = 2

Unnamed_thm < trivial.
Proof completed.

Unnamed_thm < Qed.
trivial.
Unnamed_thm is defined

Coq < ^D
>>
  *)

(** * The Proof General Emacs mode *)

(**
  - I'm going to run briefly through how to use a particular "IDE" of sorts for
    Coq.  I use
    ##Proof General##
    (##Debian
    package##),
    an Emacs mode that supports a number of proof assistants.  There's also
    CoqIDE, the "official" IDE that is distributed with Coq.  I started using
    Proof General before CoqIDE was available and never switched, so I can't
    offer much advice on it.  You might want to try both, but, in any case,
    having something beyond #<tt>#coqtop#</tt>#'s console interface is seriously
    beneficial.  Without one, using Coq will feel like programming with
    #<tt>#ed#</tt>#.
  - Let's walk through an example with Proof
    General.  The HTML file you're reading was actually generated from a Coq
    source file. ##Download it## to some convenient
    location.  Assuming you've installed Proof General for your preferred Emacs,
    you should be able to open the HW0.v file and see a fancy Proof General
    splash screen, followed by a syntax-highlighted display of that source file.
  - Press C-c . to turn on "electric period" mode, where every press of the
    period key is used to signal that you've finished entering a command.
  - Move to the end of the following definition of a list datatype and press the
    period key.  The definition should be accepted, as indicated by a message in
    a new buffer that is opened.  A general note about this section is that I'm
    not expecting you to understand what this code means, but rather just to get
    a feel for the Proof General interaction process.
  *)

Inductive list : Set :=
  | nil : list
  | cons : nat -> list -> list.

(** Do the same for this recursive definition of a list append function. *)

Fixpoint append (ls1 ls2 : list) {struct ls1} : list :=
  match ls1 with
    | nil => ls2
    | cons x ls1' => cons x (append ls1' ls2)
  end.

(** Now let's prove that [append] is associative.  Move the cursor after the
  period in the following [Theorem] command and press the period key.
  *)

Theorem append_associative : forall ls1 ls2 ls3,
  append (append ls1 ls2) ls3 = append ls1 (append ls2 ls3).

(** In the other buffer, you should see a representation of the initial proof
  state.  The formula we want to prove is displayed below a double-dashed line.
  We need to specify ##tactics## to direct Coq in performing the proof.
  Hit the period key at the end of the next line to send the first batch of
  instructions, which say that we want to proceed by induction on the first
  quantified argument [ls1].
  *)

  induction ls1; simpl; intros.

(** You should now see two subgoals displayed in the other buffer; one for the
  base ([nil]) case of the proof and one for the inductive ([cons]) case.  Now
  we have some named variables appearing above the double-dashed line.  Their
  presence tells us that we need to prove the formula for ##any## values
  of those variables.  You can probably see that the formula in this case is
  obviously true, so advance the proof by hitting period at the end of the next
  line.
  *)

  trivial.

(** In a less trivial case, we might have made a mistake and wish to back up.
  Position the cursor at the ##start## of the previous proof line and
  press C-c C-RET to undo the proof interaction back to that point.  After
  undoing, you can advance forward again by hitting the period key at the end of
  the line you want to return to, or by using C-c C-RET again with the cursor
  positioned anywhere on the line to fast-forward to.

  Now we're ready to finish the proof.  If you haven't already, fast-forward the
  proof state back to directly after the lone [trivial] tactic.  This leaves us
  with the task of giving the inductive step of the proof.

  We have our most complicated proof state yet.  Not only are there variables of
  types [nat] and [list] above the double line, but we also have a logical
  assumption [IHls1] that expresses the induction hypothesis.  We can finish the
  proof by rewriting the goal using the IH's quantified equality:
  *)

  rewrite IHls1; trivial.

(** Finally, we add this named theorem to the environment: *)
Qed.

Print append_associative.

(** And that's that.  There's no need to "turn in" this assignment, but
  definitely ##let me know## if you
  run into any problems getting this basic interaction to work.
  *)


(** * Rel: Properties of Relations *)

(* $Date: 2011-03-21 10:44:46 -0400 (Mon, 21 Mar 2011) $ *)

(** This short chapter develops some basic definitions that will be
    needed when we come to working with small-step operational
    semantics in [Smallstep.v].  It can be postponed until just before
    [Smallstep.v], but it is also a good source of good exercises for
    developing facility with Coq's basic reasoning facilities, so it
    may be useful to look at it just after [Logic.v]. *)

(* Require Export Logic. *)
Require Import SfLib.

(** A _relation_ is just a parameterized proposition.  As you know
    from your undergraduate discrete math course, there are a lot of
    ways of discussing and describing relations _in general_ -- ways
    of classifying relations (are they reflexive, transitive, etc.),
    theorems that can be proved generically about classes of
    relations, constructions that build one relation from another,
    etc.  Let us pause here to review a few that will be useful in
    what follows. *)

(** A relation _on_ a set [X] is a proposition parameterized by two
    [X]s -- i.e., it is a logical assertion involving two values from
    the set [X].  *)

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

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

(* ######################################################### *)
(** * Basic Properties of Relations *)

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

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

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

(* Copied from Logic.v *)
Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Theorem next_nat_partial_function :
   partial_function next_nat.
Proof.
  unfold partial_function.
  intros x y1 y2 P Q.
  inversion P. inversion Q.
  reflexivity.  Qed.

(** However, the [<=] relation on numbers is not a partial function.

    This can be shown by contradiction.  In short: Assume, for a
    contradiction, that [<=] is a partial function.  But then, since
    [0 <= 0] and [0 <= 1], it follows that [0 = 1].  This is nonsense,
    so our assumption was contradictory. *)

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros H.
  assert (0 = 1) as Nonsense.
   Case "Proof of assertion".
   apply H with 0.
     apply le_n.
     apply le_S. apply le_n.
  inversion Nonsense.   Qed.

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

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

(** **** Exercise: 2 stars, optional *)
(** Show that the [empty_relation] defined in Logic.v is a partial
    function. *)

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

(** A _reflexive_ relation on a set [X] is one that holds for every
    element of [X]. *)

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

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

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

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

Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  Case "le_n". apply Hnm.
  Case "le_S". apply le_S. apply IHHmo.  Qed.

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

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

Theorem lt_trans' :
  transitive lt.
Proof.
  (* Prove this by induction on evidence that [m] is less than [o]. *)
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [| m' Hm'o].
    (* FILL IN HERE *) Admitted.
(** [] *)

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

Theorem lt_trans'' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

(** **** Exercise: 1 star, optional *)
Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

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

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

(** **** Exercise: 1 star, optional *)
Theorem le_Sn_n : forall n,
  ~ (S n <= n).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

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

(** **** Exercise: 2 stars, optional *)
Theorem le_not_symmetric :
  ~ (symmetric le).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

(** **** Exercise: 2 stars, optional *)
Theorem le_antisymmetric :
  antisymmetric le.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional *)
Theorem le_step : forall n m p,
  n < m ->
  m <= S p ->
  n <= p.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

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

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

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

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

Theorem le_order :
  order le.
Proof.
  unfold order. split.
    Case "refl". apply le_reflexive.
    split.
      Case "antisym". apply le_antisymmetric.
      Case "transitive.". apply le_trans.  Qed.

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

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

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

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

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

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

    Here is a more useful definition... *)

Inductive refl_step_closure {X:Type} (R: relation X)
                            : X -> X -> Prop :=
  | rsc_refl  : forall (x : X),
                 refl_step_closure R x x
  | rsc_step : forall (x y z : X),
                    R x y ->
                    refl_step_closure R y z ->
                    refl_step_closure R x z.

(** (The following [Tactic Notation] definitions are explained in
    Imp.v.  You can ignore them if you haven't read that chapter
    yet.) *)

Tactic Notation "rt_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "rt_step" | Case_aux c "rt_refl"
  | Case_aux c "rt_trans" ].

Tactic Notation "rsc_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "rsc_refl" | Case_aux c "rsc_step" ].

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

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

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

Theorem rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> refl_step_closure R x y.
Proof.
  intros X R x y r.
  apply rsc_step with y. apply r. apply rsc_refl.   Qed.

(** **** Exercise: 2 stars, optional (rsc_trans) *)
Theorem rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      refl_step_closure R x y  ->
      refl_step_closure R y z ->
      refl_step_closure R x z.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

(** **** Exercise: 3 stars, optional (rtc_rsc_coincide) *)
Theorem rtc_rsc_coincide :
         forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <-> refl_step_closure R x y.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)


Set Warnings "-notation-overridden,-parsing".
From LF Require Export tactics.

(*命題に名前付けられるよ。嬉しいね。*)
Definition plus_fact : Prop := 2 + 2 = 4.
Check plus_fact.
Theorem plus_fact_is_true :
  plus_fact.
Proof. reflexivity. Qed.

Definition is_three (n : nat) : Prop :=
  n = 3.
Check is_three.

Definition injective {A B} (f : A -> B) :=
  forall x y : A, f x = f y -> x = y.

Lemma succ_inj : injective S.
Proof.
  intros n m H. injection H as H1. apply H1.
Qed.

(*論理積の書き方*)
Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  split.
  - reflexivity.
  - reflexivity.
Qed.

Lemma and_intro : forall A B : Prop, A -> B -> A /\ B.
Proof.
  intros A B HA HB. split.
  - apply HA.
  - apply HB.
Qed.

(*and_introでsplitと同じことができる*)
Example and_example' : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  apply and_intro.
  - reflexivity.
  - reflexivity.
Qed.

Example and_exercise :
  forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  intros [] []. split.
  reflexivity. reflexivity. discriminate. discriminate. discriminate.
Qed.

(*仮説の論理積の分解方法
   destruct H as [Hn Hm] |
   intros [Hn Hm]*)
Lemma and_example2 :
  forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof.
  intros n m H.
  destruct H as [Hn Hm].
  rewrite Hn. rewrite Hm.
  reflexivity.
Qed.

Lemma and_example2' :
  forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof.
  intros n m [Hn Hm].
  rewrite Hn. rewrite Hm.
  reflexivity.
Qed.

(*論理積をHn -> Hmで表記できるけど論理積の扱いは理解しよう*)

Lemma and_example3 :
  forall n m : nat, n + m = 0 -> n * m = 0.
Proof.
  intros n m H.
  assert (H' : n = 0 /\ m = 0).
  { apply and_exercise. apply H. }
  destruct H' as [Hn Hm].
  rewrite Hn. reflexivity.
Qed.

Lemma proj1 : forall P Q : Prop,
  P /\ Q -> P.
Proof.
  intros P Q [HP HQ].
  apply HP. Qed.
Lemma proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof. intros P Q [HP HQ].
       apply HQ. Qed.

Theorem and_commut : forall P Q : Prop,
  P /\ Q -> Q /\ P.
Proof.
  intros P Q [HP HQ].
  split.
    - apply HQ.
    - apply HP. Qed.

Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R [HP [HQ HR]].
  split. split. apply HP. apply HQ. apply HR.
Qed.

Check and. (*Prop -> Prop -> Prop*)

(*------------論理和----------------*)
Lemma or_example :
  forall n m : nat, n = 0 \/ m = 0 -> n * m = 0.
Proof.
  intros n m [Hn | Hm].
  -
    rewrite Hn. reflexivity.
  -
    rewrite Hm. rewrite <- mult_n_O.
    reflexivity.
Qed.

(*論理和なんだから証明は片方でいいじゃん！！*)
Lemma or_intro : forall A B : Prop, A -> A \/ B.
Proof.
  intros A B HA.
  left.
  apply HA.
Qed.

Lemma zero_or_succ :
  forall n : nat, n = 0 \/ n = S (pred n).
Proof.
  intros [|n].
  - left. reflexivity.
  - right. reflexivity.
Qed.

Lemma mult_eq_0 :
  forall n m, n * m = 0 -> n = 0 \/ m = 0.
Proof.
  intros [] [] H. - left. reflexivity. - left. reflexivity.
  - right. reflexivity. - discriminate.
Qed.

Theorem or_commut : forall P Q : Prop,
  P \/ Q -> Q \/ P.
Proof. intros P Q [HP | HQ]. right. apply HP. left. apply HQ.
Qed.

Module MyNot.

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

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

Check not.

End MyNot.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  destruct contra. Qed.

Fact not_implies_our_not : forall (P:Prop),
  ~ P -> (forall (Q:Prop), P -> Q).
Proof.
  intros P notP Q HP. destruct notP. apply HP.
Qed.

Notation "x <> y" := (~(x = y)).

Theorem zero_not_one : 0 <> 1.
Proof.
  unfold not. discriminate.
Qed.

Theorem not_False :
  ~ False.
Proof.
  unfold not. intros H. destruct H. Qed.

Theorem contradiction_implies_anything : forall P Q : Prop,
  (P /\ ~P) -> Q.
Proof.
  intros P Q [HP HNA]. unfold not in HNA.
  apply HNA in HP. destruct HP. Qed.

Theorem double_neg : forall P : Prop,
  P -> ~~P.
Proof.
  intros P H. unfold not. intros G. apply G. apply H. Qed.

Theorem  double_neg' : forall P : Prop,
  P -> ~~P.
Proof.
  unfold not. intros. apply H0. apply H.
Qed.

Theorem contrapositive : forall (P Q : Prop),
  (P -> Q) -> (~Q -> ~P).
Proof.
  unfold not. intros. apply H in H1. apply H0 in H1. apply H1.
Qed.

Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
  unfold not. intros P H. destruct H. apply H0 in H. apply H.
Qed.

(*true = false などの矛盾したゴールのときは
　apply ex_falso_quodlibet.
　でFalseをゴールに設定できる*)
Theorem not_true_is_false : forall b : bool,
  b <> true -> b = false.
Proof.
  intros [] H.
  -
    unfold not in H.
    apply ex_falso_quodlibet.
    apply H. reflexivity.
  -
    reflexivity.
Qed.

(*exfalso.はapply ex_falso_quodlibet.の代わりに使える*)
Theorem not_true_is_false' : forall b : bool,
  b <> true -> b = false.
Proof.
  intros [] H.
  -
    unfold not in H.
    exfalso.     apply H. reflexivity.
  - reflexivity.
Qed.

(*定数Iは予めTrueに設定されている*)
Lemma True_is_true : True.
Proof. apply I. Qed.

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

Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P).

Notation "P <-> Q" := (iff P Q)
                      (at level 95, no associativity)
                      : type_scope.

Theorem iff_sym : forall P Q : Prop,
  (P <-> Q) -> (Q <-> P).
Proof.
  intros P Q [HAB HBA].
  split.
  - apply HBA.
  - apply HAB. Qed.

Lemma not_true_iff_false : forall b,
  b <> true <-> b = false.
Proof.
  intros b. split.
  - apply not_true_is_false.
  -
    intros H. rewrite H. intros H'. discriminate H'.
Qed.

Theorem iff_refl : forall P : Prop,
  P <-> P.
Proof.
  split.
  - intros. apply H.
  - intros. apply H.
Qed.

Theorem iff_trans : forall P Q R : Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  split. intros.
  - apply H0. apply H. apply H1.
  - intros. apply H. apply H0. apply H1.
Qed.

Theorem or_distributes_over_and1 : forall P Q R : Prop,
  P \/ (Q /\ R) -> (P \/ Q) /\ (P \/ R).
Proof.
  split.
  - inversion H as [HP | [HQ HR]].
     + left. apply HP.
     + right.  apply HQ.
  - inversion H as [HP | [HQ HR]].
     + left.  apply HP.
     + right. apply HR.
Qed.

From Coq Require Import Setoids.Setoid.

Lemma mult_0 : forall n m, n * m = 0 <-> n = 0 \/ m = 0.
Proof.
  split.
  - apply mult_eq_0.
  - apply or_example.
Qed.

Lemma or_assoc :
  forall P Q R : Prop, P \/ (Q \/ R) <-> (P \/ Q) \/ R.
Proof.
  intros P Q R. split.
  - intros [H | [H | H]].
    + left. left. apply H.
    + left. right. apply H.
    + right. apply H.
  - intros [[H | H] | H].
    + left. apply H.
    + right. left. apply H.
    + right. right. apply H.
Qed.

Lemma apply_iff_example :
  forall n m : nat, n * m = 0 -> n = 0 \/ m = 0.
Proof.
  intros n m H. apply mult_0. apply H.
Qed.

(*exists == ∃*)
Lemma four_is_even : exists n : nat, 4 = n + n.
Proof.
  exists 2. reflexivity.
Qed.

Theorem exists_example_2 : forall n,
  (exists m, n = 4 + m) ->
  (exists o, n = 2 + o).
Proof.
  intros n [m Hm].   exists (2 + m).
  apply Hm. Qed.

Theorem dist_not_exists : forall (X:Type) (P : X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  intros. unfold not. intros H1. destruct H1. apply H0. apply H.
Qed.

Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  intros. split.
  - intros. destruct H as [m Hm]. inversion Hm as [HP | HQ].
     + apply or_introl. exists m. apply HP.
     + apply or_intror. exists m. apply HQ.
  - intros. inversion H as [HH | H0]. inversion HH as [m  H2].
     + exists m. apply or_introl. apply H2.
     + inversion H0. exists x. apply or_intror. apply H1.
Qed.

Fixpoint In {A : Type} (x : A) (l : list A) : Prop :=
  match l with
  | [] => False
  | x' :: l' => x' = x \/ In x l'
  end.

Example In_example_1 : In 4 [1; 2; 3; 4; 5].
Proof.
  simpl. right. right. right. left. reflexivity.
Qed.

Example In_example_2 :
  forall n, In n [2; 4] ->
  exists n', n = 2 * n'.
Proof.
  simpl.
  intros n [H | [H | []]].
  - exists 1. rewrite <- H. reflexivity.
  - exists 2. rewrite <- H. reflexivity.
Qed.

Lemma In_map :
  forall (A B : Type) (f : A -> B) (l : list A) (x : A),
    In x l ->
    In (f x) (map f l).
Proof.
  intros A B f l x.
  induction l as [|x' l' IHl'].
  -
    simpl. intros [].
  -
    simpl. intros [H | H].
    + rewrite H. left. reflexivity.
    + right. apply IHl'. apply H.
Qed.

Lemma In_map_iff :
  forall (A B : Type) (f : A -> B) (l : list A) (y : B),
    In y (map f l) <->
    exists x, f x = y /\ In x l.
Proof.
  intros. split.
  induction l as [|h t].
  - simpl. intros [].
  - simpl. intros [].
    + exists h. split. apply H. left. reflexivity.
    + apply IHt in H. destruct H as [w [F I]].
      exists w. split. apply F. right. apply I.
  - intros [w [F I]].
    rewrite <- F. apply In_map. apply I.
Qed.

Fixpoint All {T : Type} (P : T -> Prop) (l : list T) : Prop :=
  match l with
  | [] => True
  | x' :: l' => (P x') \/ All P l'
  end.

Definition combine_odd_even (Podd Peven : nat -> Prop) : nat -> Prop :=
  fun n =>
    match oddb n with
      | true => Podd n
      | false => Peven n
    end.

Theorem combine_odd_even_intro :
  forall (Podd Peven : nat -> Prop) (n : nat),
    (oddb n = true -> Podd n) ->
    (oddb n = false -> Peven n) ->
    combine_odd_even Podd Peven n.
Proof.
  intros. unfold combine_odd_even. destruct (oddb n).
  - apply H. reflexivity.
  - apply H0. reflexivity.
Qed.

Theorem combine_odd_even_elim_odd :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = true ->
    Podd n.
Proof.
  intros A B n. unfold combine_odd_even. destruct (oddb n).
  + intros. apply H.
  + intros. discriminate H0.
Qed.

Theorem combine_odd_even_elim_even :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = false ->
    Peven n.
Proof.
  intros A B n.  unfold combine_odd_even. destruct (oddb n).
  + intros. discriminate.
  + intros. apply H.
Qed.

Check plus_comm. (*forall n m : nat, n + m = m + n*)

Lemma plus_comm3 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm. (*y + z + x = z + y + x*)
  rewrite plus_comm. (*x + (y + z) = z + y + x*)
Abort.

Lemma plus_comm3_take2 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  assert (H : y + z = z + y).
  { rewrite plus_comm. reflexivity. }
  rewrite H.
  reflexivity.
Qed.

Lemma plus_comm3_take3 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  rewrite (plus_comm y z).
  reflexivity.
Qed.

Lemma in_not_nil :
  forall A (x : A) (l : list A), In x l -> l <> [].
Proof.
  intros A x l H. unfold not. intro Hl. destruct l.
  - simpl in H. destruct H.
  - discriminate Hl.
Qed.

Lemma in_not_nil_42 :
  forall l : list nat, In 42 l -> l <> [].
Proof.
  intros l H.
  Fail apply in_not_nil.
Abort.

Lemma in_not_nil_42_take2 :
  forall l : list nat, In 42 l -> l <> [].
Proof.
  intros l H.
  apply in_not_nil with (x := 42).
  apply H.
Qed.

Lemma in_not_nil_42_take3 :
  forall l : list nat, In 42 l -> l <> [].
Proof.
  intros l H.
  apply in_not_nil in H.
  apply H.
Qed.

Lemma in_not_nil_42_take4 :
  forall l : list nat, In 42 l -> l <> [].
Proof.
  intros l H.
  apply (in_not_nil nat 42).
  apply H.
Qed.

Lemma in_not_nil_42_take5 :
  forall l : list nat, In 42 l -> l <> [].
Proof.
  intros l H.
  apply (in_not_nil _ _ _ H).
Qed.

Example lemma_application_ex :
  forall {n : nat} {ns : list nat},
    In n (map (fun m => m * 0) ns) ->
    n = 0.
Proof.
  intros n ns H.
  destruct (proj1 _ _ (In_map_iff _ _ _ _ _) H)
           as [m [Hm _]].
  rewrite mult_0_r in Hm. rewrite <- Hm. reflexivity.
Qed.

(*------------Coq VS Set Theory-------*)

(*関数の等価性*)
Example function_equality_ex1 :
  (fun x => 3 + x) = (fun x => (pred 4) + x).
Proof. reflexivity. Qed.

(*(forall x, f x = g x) -> f = g
　　が組み込み論理ではない*)
Example function_equality_ex2 :
  (fun x => plus x 1) = (fun x => plus 1 x).
Proof.
Abort.

(*AxiomはAdmittedと同じ役割をするが、あとで証明するわけではないことを明示する*)
Axiom functional_extensionality : forall {X Y: Type}
                                    {f g : X -> Y},
  (forall (x:X), f x = g x) -> f = g.

Example function_equality_ex2 :
  (fun x => plus x 1) = (fun x => plus 1 x).
Proof.
  apply functional_extensionality. intros x.
  apply plus_comm.
Qed.

(*Print Assumptions ：自分で追加した公理に依存しているか確認*)
Print Assumptions function_equality_ex2.

Fixpoint rev_append {X} (l1 l2 : list X) : list X :=
  match l1 with
  | [] => l2
  | x :: l1' => rev_append l1' (x :: l2)
  end.

Definition tr_rev {X} (l : list X) : list X :=
  rev_append l [].

Lemma tr_rev_correct : forall X, @tr_rev X = @rev X.
Proof.
  intros. apply functional_extensionality.
  intros l. unfold tr_rev. induction l.
  - unfold tr_rev. simpl. reflexivity.
  - simpl. rewrite <- IHl.
    assert ( H: forall T l1 l2, @rev_append T l1 l2 = @rev_append T l1 [] ++ l2).
    { intros T. induction l1 as [|h' t'].
      - reflexivity.
      - simpl. rewrite IHt'. intros.
        rewrite (IHt' (h'::l2)).
        rewrite <- app_assoc. reflexivity. }
    apply H.
Qed.

(*偶数の確認方法*)
Example even_42_bool : evenb 42 = true.
Proof. reflexivity. Qed.
Example even_42_prop : exists k, 42 = double k.
Proof. exists 21. reflexivity. Qed.

Theorem evenb_double : forall k, evenb (double k) = true.
Proof.
  intros k. induction k as [|k' IHk'].
  - reflexivity.
  - simpl. apply IHk'.
Qed.

Theorem evenb_double_conv : forall n,
  exists k, n = if evenb n then double k
                else S (double k).
Proof.
  intros. induction n.
  - simpl. exists 0. reflexivity.
  - rewrite evenb_S. destruct IHn as [w H].
    destruct (evenb n).
    + simpl. exists w. rewrite H. reflexivity.
    + simpl. exists (S w). rewrite H. reflexivity.
Qed.

Theorem even_bool_prop : forall n,
  evenb n = true <-> exists k, n = double k.
Proof.
  intros n. split.
  - intros H. destruct (evenb_double_conv n) as [k Hk].
    rewrite Hk. rewrite H. exists k. reflexivity.
  - intros [k Hk]. rewrite Hk. apply evenb_double.
Qed.

Theorem eqb_eq : forall n1 n2 : nat,
  n1 == n2 = true <-> n1 = n2.
Proof.
  intros n1 n2. split.
  - apply eqb_true.
  - intros H. rewrite H. rewrite <- eqb_refl. reflexivity.
Qed.

Fail Definition is_even_prime n :=
  if n = 2 then true
  else false.

(*bool値はreflexivityでできる*)
Example even_1000 : exists k, 1000 = double k.
Proof. exists 500. reflexivity. Qed.
Example even_1000' : evenb 1000 = true.
Proof. reflexivity. Qed.
Example even_1000'' : exists k, 1000 = double k.
Proof. apply even_bool_prop. reflexivity. Qed.

Lemma plus_eqb_example : forall n m p : nat,
    n == m = true -> n + p == m + p = true.
Proof.
  intros n m p H.
    apply eqb_eq in H.
  rewrite H.
  apply eqb_eq.
  reflexivity.
Qed.

Lemma andb_true_iff : forall b1 b2:bool,
  b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof.
  intros [] []. split.
  - intros. split. reflexivity. reflexivity.
  - intros. reflexivity.
  - simpl. split. discriminate. intros. apply proj2 in H. apply H.
  - split. intros. discriminate. intros. simpl. apply proj1 in H. apply H.
  - simpl. split. discriminate. intros. apply proj1 in H. apply H.
Qed.

Lemma orb_true_iff : forall b1 b2,
  b1 || b2 = true <-> b1 = true \/ b2 = true.
Proof.
  intros [] [].  split.
  - intros. left. reflexivity.
  - intros. simpl. reflexivity.
  - simpl. split. intros. left. reflexivity. intros. reflexivity.
  - simpl. split. intros. right. reflexivity. intros. reflexivity.
  - simpl. split. intros. discriminate. intros. Search or. induction H. apply H. apply H.
Qed.

Theorem eqb_neq : forall x y : nat,
  x == y = false <-> ~(x = y).
Proof.
  intros x y. unfold not.
  destruct (x == y) eqn:IH. split.
  -  discriminate.
  -  intros. rewrite <- IH. apply eqb_true in IH. destruct H. apply IH.
  - split. intros. destruct H0. rewrite eqb_nn in IH. discriminate.
      + intros. reflexivity.
Qed.

Fixpoint eqb_list {A : Type} (eqb : A -> A -> bool)
                  (l1 l2 : list A) : bool :=
  match l1 with
  | nil => match l2 with
           | nil => true
           | _   => false
           end
  | h1 :: t1 => match l2 with
                | nil => false
                | h2 :: t2 => if (eqb h1 h2) then eqb_list eqb t1 t2
                                             else false
                end
end.

Lemma eqb_list_true_iff :
  forall A (eqb : A -> A -> bool),
    (forall a1 a2, eqb a1 a2 = true <-> a1 = a2) ->
    forall l1 l2, eqb_list eqb l1 l2 = true <-> l1 = l2.
Proof.
  intros A eqb H.
  induction l1 as [| a t IH].
  - destruct l2.
    + split.
      intros _. reflexivity.
      intros _. reflexivity.
    + split.
      * intros H'. discriminate.
      * intros H'. discriminate.
  - destruct l2.
    + split.
      * intros H'. discriminate.
      * intros H'. discriminate.
    + simpl. split.
      * intros H'. apply andb_true_iff in H'.
        destruct H' as [H1 H2].
        apply H in H1.
        apply IH in H2.
        rewrite H1, H2.
        reflexivity.
      * intros H'.
        injection H' as H1 H2.
        apply H in H1.
        apply IH in H2.
        rewrite H1, H2.
        reflexivity.
Qed.

Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool :=
  match l with
  | [] => true
  | x :: l' => andb (test x) (forallb test l')
  end.

Theorem forallb_true_iff : forall X test (l : list X),
   forallb test l = true <-> All (fun x => test x = true) l.
Proof.
  intros. split.
  - induction l. simpl. + intro. reflexivity.
      + simpl. intros. apply andb_true_iff in H. left. apply proj1 in H. apply H.
  - induction l. simpl. intro. reflexivity.
      + simpl. intros H. apply andb_true_iff. induction (forallb test l).
Admitted.

Definition excluded_middle := forall P : Prop,
  P \/ ~ P.

Theorem restricted_excluded_middle : forall P b,
  (P <-> b = true) -> P \/ ~ P.
Proof.
  intros P [] H.
  - left. apply H. reflexivity.
  - right. unfold not. intros. apply H in H0. discriminate.
Qed.

Theorem prop_no : forall (P : Prop),
  P -> ~~P.
Proof.
  intros. unfold not. intros. apply H0. apply H.
Qed.

Theorem excluded_middle_irrefutable: forall (P:Prop),
  ~ ~ (P \/ ~ P).
Proof.
  unfold not. intros. apply H. right.
  intros. apply H. left. apply H0.
Qed.

Theorem not_exists_dist :
  excluded_middle ->
  forall (X:Type) (P : X -> Prop),
    ~ (exists x, ~ P x) -> (forall x, P x).
Proof.
  unfold excluded_middle. intros H X P H0 a.
   assert ( P a \/ ~ P a).  apply H.
   inversion H1. apply H2. apply ex_falso_quodlibet.
   unfold not in H0. apply H0. unfold not in H2. exists a.
   apply H2.
Qed.

(*以下の４つとexcluded_middle は等価である証明
  できたらやる。*)
Definition peirce := forall P Q: Prop,
  ((P->Q)->P)->P.

Definition double_negation_elimination := forall P:Prop,
  ~~P -> P.

Definition de_morgan_not_and_not := forall P Q:Prop,
  ~(~P /\ ~Q) -> P\/Q.

Definition implies_to_or := forall P Q:Prop,
  (P->Q) -> (~P\/Q).

Lemma In_app_iff : forall A l l' (a:A),
  In a (l++l') <-> In a l \/ In a l'.
Proof.
  intros. split. induction l.
  - simpl. intros. right. apply H.
  - simpl. induction l'.
      + simpl. rewrite app_nil_r. rewrite app_nil_r in IHl. simpl in IHl. intros. left. apply H.
      + simpl. simpl in IHl. intros.
Admitted.

(*
Theorem or_distributes_over_and_2 : forall P Q R : Prop,
  (P \/ Q) /\ (P \/ R) -> P \/ (Q /\ R).
Proof.
 intros P Q R H. inversion H. inversion H0.
 - left. apply H2.
 - apply  or_commut in H0. Search and. apply proj1 in H0. inversion H1.
    + left. apply H3.
    + apply (and_commut R Q). Search and. rewrite proj2. generalize dependent H2. apply (or_intror R Q ). apply or_commut in H1. apply  Search or. split.
    + right.  Search and. apply (proj2 Q R).  apply H.

Lemma All_In :
  forall T (P : T -> Prop) (l : list T),
    (forall x, In x l -> P x) <->
    All P l.
Proof.
  intros. split.
  - induction l as [|h t].
    + reflexivity.
    + intros. simpl.
      left. apply H. simpl. left. reflexivity.
  - induction l as [|h t].
    + intros. inversion H0.
    + intros. simpl in H0. simpl in H.
      apply IHt. generalize dependent H. Search or. apply or_comm.
 apply proj2 with (P h ). Search and. in H.  apply H. inversion H.
      inversion H0. apply or_intro in H. inversion H. rewrite H1 in H2.
      apply H2.
      destruct H as [PH | APT].*)