Require Import Arith Omega.

Reserved Notation "x / y == z" (at level 40).
Inductive Div: nat -> nat -> nat -> Prop :=
 | Div0:  forall y,      y <> 0   -> Div 0 y 0
 | DivSz: forall x y z, Div x y z -> Div (x+y)   y (S z)
 | DivSy: forall x y z, Div x y z -> Div (x+z)(S y)   z
where "x / y == z" := (Div x y z).
Hint Constructors Div.
Theorem DivSzE: forall y x z x',
        x / y == z -> x' = (x+y) -> x' / y == S z.
Proof. intros. rewrite H0; auto. Qed.
Theorem DivSyE: forall y x z x',
        x / y == z -> x' = (x+z) -> x' / (S y) == z.
Proof. intros. rewrite H0; auto. Qed.
Hint Resolve DivSzE DivSyE.
Theorem Div0': forall y,
        0 / (S y) == 0.
Proof. intros y. apply Div0. auto. Qed.
Hint Resolve Div0'.
Theorem Div_xx1: forall x,
        x <> 0 -> x / x == 1.
Proof.
 intros x H.
 destruct x.
  elim H. reflexivity.
  eapply DivSzE. apply Div0.
  intros C. inversion C.
  simpl. reflexivity.
Qed.
Theorem Div_xx1': forall x,
        S x / S x == 1.
Proof.
 intros x.
 apply Div_xx1.
 auto.
Qed.
Hint Resolve Div_xx1 Div_xx1'.
Theorem Div_x0z: forall x z,
        x / 0 == z -> False.
Proof.
 intros x z C.
 generalize (refl_equal 0).
 refine (
 match C in Div x y z
   return y = 0 -> False with
 | Div0 y' Hy' => _
 | DivSz x' y' z' HC => _
 | DivSy x' y' z' HC => _
 end); intros Hy.
  exact (Hy' Hy).
 induction HC.
  exact (H Hy). apply IHHC; exact Hy. inversion Hy.
  inversion Hy.
Qed.
Hint Resolve Div_x0z.
Theorem Div0_a: forall y z,
        0 / y == z -> z = 0.
Proof.
 intros.
 inversion H; subst.
  reflexivity.
  destruct (plus_is_O _ _ H0) as [Hx0 Hy0]. subst.
  exact (False_ind _ (Div_x0z _ _ H1)).
 destruct (plus_is_O _ _ H0) as [Hx0 Hy0]. subst.
 reflexivity.
Qed.
Hint Resolve Div0_a.
Theorem Div_le: forall x y z,
        x / y == z -> z <= x.
Proof.
 intros.
 destruct y. exact (False_ind _ (Div_x0z x z H)).
 induction H.
  omega.

  destruct y0. exact (False_ind _ (Div_x0z _ _ H)).
  rewrite plus_comm. simpl. apply le_n_S.
  rewrite plus_comm. apply le_plus_trans. auto.

  rewrite plus_comm. apply le_plus_trans. omega.
Qed.
Hint Resolve Div_le.
Theorem Div_xyx_a: forall x y,
        x <> 0 -> x / y == x -> y = 1.
Proof.
 intros x y Hx H.
 destruct y.
  exact (False_ind _ (Div_x0z x x H)).
 destruct y. reflexivity.
 apply False_ind.
 destruct x. apply Hx. reflexivity.
 clear Hx.
 inversion H.
  rewrite plus_comm in H1. inversion H1.
  subst. simpl in H1. clear H1.
  rewrite plus_comm in H0. inversion H0. clear H0. subst.
  apply Div_le in H. apply Div_le in H3.
  omega.
 assert (x0 = 0) by omega. clear H3. subst.
 rewrite plus_0_l in H0, H2. subst.
 apply Div0_a in H2. inversion H2.
Qed.
Hint Resolve Div_xyx_a.
Theorem S_O: forall n, S n <> 0. Proof. auto. Qed.
Hint Resolve S_O.
Theorem Div_xyx_a': forall x y,
        S x / y == S x -> y = 1.
Proof. eauto. Qed.
Hint Resolve Div_xyx_a'.

Theorem Div_xy0_a: forall x y,
        x / y == 0 -> x = 0.
Proof.
 intros x y H.
 inversion H; subst.
  reflexivity.
  rewrite plus_0_r in H.
  subst.
  destruct x0. reflexivity.
  apply False_ind.
  clear H.
  induction y0. eauto.
  apply IHy0. inversion H0; subst.
  rewrite plus_0_r in H. subst.
  rewrite plus_0_r. exact H2.
Qed.

Theorem Div_x0z_a: forall x y z,
        x / y == z -> y <> 0.
Proof.
 intros.
 destruct y.
  eauto.
 omega.
Qed.
Hint Resolve Div_x0z_a.

Theorem Div_mult: forall y n,
        y <> 0 -> (n*y) / y == n.
Proof.
 intros.
 induction n as [|n'].
  simpl. constructor. exact H.
 simpl. rewrite plus_comm. constructor. exact IHn'.
Qed.
Hint Resolve Div_mult.

Theorem Div_mult_a: forall x y z,
        x / y == z -> x = z*y.
Proof.
 intros.
 induction H.
  reflexivity.
  simpl. omega.
  rewrite IHDiv. ring.
Qed.
Hint Resolve Div_mult_a.

Theorem Div_multE: forall x y z,
        y <> 0 -> x = (z*y) -> x / y == z.
Proof.
 intros.
 rewrite H0.
 eauto.
Qed.
Hint Resolve Div_multE.

Theorem Div_xy1_a: forall x y,
        x / y == 1 -> x = y.
Proof.
 intros x y H.
 specialize (Div_mult_a _ _ _ H). intros Hx.
 rewrite Hx. omega.
Qed. (* 想像以上に証明が短くなった！ *)
Hint Resolve Div_xy1_a.

Example Div_ex1: 12 / 6 == 2.
Proof.
 eauto.
Qed.
Example Div_ex2: ~ 12 / 5 == 2.
Proof.
 intros C.
 specialize (Div_mult_a _ _ _ C).
 intros C2. omega.
Qed.

Theorem Div_inv: forall x y z w a,
        x / y == z -> z / w == a -> x / (y*w) == a.
Proof.
 intros.
 specialize (Div_mult_a _ _ _ H).
 specialize (Div_mult_a _ _ _ H0).
 intros. subst.
 replace (a*w*y) with (a*(y*w)).
 apply Div_mult.
 destruct y. apply False_ind. eauto.
 destruct w. apply False_ind. eauto.
 simpl. auto.
 ring.
Qed.
Hint Resolve Div_inv.

Theorem Div_lt: forall x y z,
        x < y /\ x <> 0 -> x / y == z -> False.
Proof.
 intros.
 destruct H as [Hlt Hneq].
 specialize (Div_mult_a _ _ _ H0). intros Hmult.
 clear H0. subst.
 destruct y.
  auto.
 destruct z.
  simpl in Hneq. omega.
 induction z as [|z'].
  simpl in Hlt. omega.
 apply IHz'. simpl. simpl in Hlt. omega.
 simpl. auto.
Qed.
Hint Resolve Div_lt.

Require Program.
Program Fixpoint div_sig (x y: nat) (Hy: y <> 0) {measure x}:
                 {n: option nat |
                  match n with
                  | None   => ~ exists z, x / y == z
                  | Some z =>             x / y == z
                  end} :=
 match y with
 | O => None
 | S y' =>
   match x with
   | O => Some 0
   | S _ =>
     match le_gt_dec x y with
     | left Hle =>
       match eq_nat_dec x y with
       | left Heq => Some 1
       | right Hneq => None
       end
     | right Hgt =>
       match div_sig (x-y) y Hy with
       | None => None
       | Some z => Some (S z)
       end
     end
   end
 end.
Next Obligation.
Proof.
 rewrite Heq. apply Div_xx1'.
Qed.
Next Obligation.
Proof.
 intros Cex. destruct Cex as [z Cex].
 rename wildcard' into w.
 assert (S w < S y'). omega.
 exact (Div_lt _ _ z (conj H (S_O _)) Cex).
Qed.
Next Obligation.
Proof.
 simpl. omega.
Qed.
Next Obligation.
Proof.
 intros Cex. destruct Cex as [z Cex].
 rename wildcard' into w.
 assert (Hltw: S w - S y' < S w).
  omega.
 remember (proj1_sig (
                   (div_sig (S w - S y') (S y') Hy
                      (div_sig_func_obligation_5 (S w) (S y') Hy
                         div_sig y' eq_refl w eq_refl Hgt Heq_anonymous))
 )) as d. destruct d.
 inversion Heq_anonymous0.
 remember (proj2_sig (
         (div_sig (S w - S y') (S y') Hy
            (div_sig_func_obligation_5 (S w) (S y') Hy div_sig y'
               eq_refl w eq_refl Hgt Heq_anonymous))
 )) as d2. clear Heqd2. rewrite <- Heqd in d2. (* やっとなんか出た！ *)
 clear Heqd. clear Heq_anonymous0.
 unfold gt in Hgt. unfold lt in Hgt.
 apply d2. clear d2. clear Heq_anonymous.
 apply le_Sn_le in Hgt. rename Hgt into Hle.
 specialize (le_plus_minus _ _ Hle). intros Rpm.
 rewrite Rpm in Cex.
 specialize (Div_mult_a _ _ _ Cex). intros Hexm.
 Lemma Div_mult_minus_ex: (forall y' w z, y' <= w -> (y' + (w - y')) / y' == z -> y' + (w - y') = z * y' -> exists z', w - y' = z' * y').
  intros y' w z Hle Cex Hexm.
  rewrite plus_comm in Hexm.
  destruct Cex.
   simpl in Hexm. destruct y. apply False_ind. auto.
    apply False_ind. omega.
   exists z. simpl in Hexm.
   destruct y. apply False_ind. eauto.
   simpl. omega.
  rewrite plus_comm in Hexm.
  rewrite (le_plus_minus_r _ _ Hle) in Hexm.
  destruct z.
   rewrite mult_0_l in Hexm.
   destruct w. apply False_ind. omega.
   inversion Hexm.
  exists z. simpl in Hexm. omega.
 Qed.
 specialize ( Div_mult_minus_ex (S y') (S w) z Hle Cex Hexm). intros H.
 destruct H as [z' H].
 rewrite H.
 exists z'.
 apply Div_mult. auto.
Qed. (* やったあ！ *)
Next Obligation.
Proof.
 (* さて最後だ *)
 rename wildcard' into w.
 remember (proj2_sig (
         (div_sig (S w - S y') (S y') Hy
                      (div_sig_func_obligation_5 (S w) (S y') Hy
                         div_sig y' eq_refl w eq_refl Hgt Heq_anonymous))
 )) as HDiv. clear HeqHDiv. rewrite <- Heq_anonymous0 in HDiv.
 clear Heq_anonymous0. clear Heq_anonymous. clear Hy.
 unfold gt, lt in Hgt. apply le_Sn_le in Hgt. rename Hgt into Hle.
 rewrite (le_plus_minus _ _ Hle).
 rewrite plus_comm. constructor. exact HDiv.
Qed.
(* やったあ！ *)
Definition div x y (Hy:y <> 0): option nat := proj1_sig (div_sig x y Hy).
Hint Unfold div.
Theorem div_Div: forall x y Hy z,
        div x y Hy = Some z -> x / y == z.
Proof.
 intros.
 unfold div in H.
 specialize (proj2_sig (div_sig x y Hy)). intros p.
 simpl in p. (* 結構時間がかかる(Qed.の時にも) *)
 rewrite H in p.
 exact p.
Qed.
Hint Resolve div_Div.
Theorem div_Div': forall x y z,
        div x (S y) (S_O y) = Some z -> x / S y == z.
Proof.
 eauto.
Qed.
Hint Resolve div_Div'.
Lemma plus_reg_r: forall n m p,
      n + p = m + p -> n = m.
Proof.
 intros.
 omega.
Qed.
Theorem DivSz_a: forall x y z,
        Div (x+y) y (S z) -> Div x y z.
Proof.
 intros.
 destruct y. apply False_ind. eauto.
 apply Div_multE. omega.
 apply Div_mult_a in H.
 rewrite mult_succ_l in H.
 apply plus_reg_r in H.
 exact H.
Qed.
Hint Resolve DivSz_a.
Theorem DivSy_a: forall x y z,
        y <> 0 -> Div (x+z) (S y) z -> Div x y z.
Proof.
 intros.
 destruct y. apply False_ind. eauto. clear H.
 apply Div_multE. omega.
 apply Div_mult_a in H0.
 rewrite mult_succ_r in H0.
 apply plus_reg_r in H0.
 exact H0.
Qed.
Hint Resolve DivSy_a.
Theorem Div_xyz_xyz'_a: forall x y z z',
        x / y == z -> x / y == z' -> z = z'.
Proof.
 intros.
 destruct y. apply False_ind. eauto.
 generalize dependent z'.
 induction H; intros.
  apply Div0_a in H0. subst. reflexivity.
  inversion H0; subst.
   symmetry in H1. destruct (plus_is_O _ _  H1). subst. omega.
   assert (x0 = x) by omega. subst. clear H1.
   f_equal. apply IHDiv. exact H2.
   destruct z'.
    apply Div_xy0_a in H0. omega.
   f_equal. apply IHDiv.
   apply DivSz_a in H0. exact H0.
 inversion H0; subst.
  symmetry in H1. destruct (plus_is_O _ _ H1). subst. auto.
  apply Div_mult_a in H. subst.
  apply Div_mult_a in H0.
  rewrite H0 in H1.
  clear H1. clear H2.
  destruct y0.
   rewrite mult_0_r in H0. rewrite mult_1_r in H0. simpl in H0.
   inversion H0. subst. reflexivity.
  rewrite <- mult_succ_r in H0.
  Lemma mult_reg: (forall n m p, n * S p = m * S p -> n = m).
   intros.
   generalize dependent m.
   induction n; intros.
    induction m.
     reflexivity.
    simpl in H. inversion H.
   induction m.
    simpl in H. inversion H.
   f_equal. apply IHn.
   rewrite mult_succ_l in H. rewrite mult_succ_l in H.
   apply plus_reg_r in H. exact H.
  Qed.
  Hint Resolve mult_reg.
  apply mult_reg in H0. exact H0.
 apply Div_mult_a in H. subst.
 apply Div_mult_a in H0.
 rewrite <- mult_succ_r in H0.
 apply mult_reg in H0. subst.
 reflexivity.
Qed.
Hint Resolve Div_xyz_xyz'_a.

Theorem div_NotDiv: forall x y Hy z,
        div x y Hy <> Some z -> ~ x / y == z.
 intros.
 intro. apply H.
 specialize (proj2_sig (div_sig x y Hy)). intros p.
 simpl in p.
 change (proj1_sig (div_sig x y Hy)) with (div x y Hy) in p.
 destruct (div x y Hy).
  rewrite (Div_xyz_xyz'_a _ _ _ _ H0 p). reflexivity.
 apply False_ind. apply p. eauto.
Qed.
Hint Resolve div_NotDiv.
Theorem div_NotDiv': forall x y z,
        div x (S y) (S_O y) <> Some z -> ~ x / S y == z.
Proof. eauto. Qed.
Hint Resolve div_NotDiv'.

Example divDiv_ex1: 18 / 6 == 3.
Proof.
 apply div_Div'.
 unfold div.
(*
 simplしたらメモリ食いつぶして帰ってこないｗｗｗｗ
 でもcbvなら大丈夫。何故？ バグか？
*)
 cbv.
 reflexivity.
Qed.
Example divDiv_ex2: 153 / 9 == 17.
Proof. auto. Qed.
Example divDiv_ex3: ~ 12 / 6 == 3.
Proof.
 apply div_NotDiv'.
 cbv. intro. inversion H.
Qed.


Definition lem := forall p, p \/ ~p.
Print lem.

Definition frobenius := forall (A: Set)(p: A->Prop)(q: Prop),
  (forall x: A, q \/ p x) <-> (q \/ forall x: A, p x).

Theorem lem_to_frobenius: lem -> frobenius.
Proof.
unfold lem, frobenius.
firstorder.
(*assert (G := H q).
destruct G.*)
destruct (H q).
left.
assumption.
right.
intro.
destruct (H0 x).
elim H1.
assumption.
assumption.
Qed.


(* Exercise 84 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_084 : (exists x : D, (P x /\ Q x)) -> (exists x : D, P x) /\ (exists x : D, Q x).
Proof.
imp_i a1.
exi_e (exists x:D, P x /\ Q x) a a2.
hyp a1.
con_i.
exi_i a.
con_e1 (Q a).
hyp a2.
exi_i a.
con_e2 (P a).
hyp a2.
Qed.


Require Import HoTT.

Section Definitions.
	Variable A:Set.
	Definition prod A := A->A->A.
	Definition associative {A} (m : prod A) :=
		forall a b c : A, m (m a b) c = m a (m b c).
	Definition commutative {A} (m : prod A) :=
		forall a b : A, m a b = m b a.
	Definition neutral {A} (e:A) (m:prod A) :=
		forall a:A, (m e a = a) /\ (m a e = a).
	Definition exists_inverse {A} (m:prod A) (e:A) :=
		forall a:A, exists a', m a a' = e /\ m a' a = e.

	Definition isMonoid A (m : prod A) (e:A) :=
		associative m /\ neutral e m.
	Definition isCommutative_Monoid A (m : prod A) (e:A) :=
		associative m /\ neutral e m /\ commutative m.
	Definition isGroup A (m:prod A) (e:A) :=
		associative m /\ neutral e m /\ exists_inverse m e.
	Definition isAbelian_Group A (m:prod A) (e:A) :=
		associative m /\ neutral e m /\ exists_inverse m e /\ commutative m.
End Definitions.

Section Nat.
	Fixpoint add (m:nat) : nat->nat :=
		match m with
			| O => (fun n:nat => n)
			| S m => (fun n:nat => S (add m n) )
		end.

	(*Addition is defined recursively on the first variable.
	It also decreases on second variable: *)
	Lemma pred_second : forall m n : nat, add m (S n) = S (add m n).
	Proof.
		intros m n.
		induction m.
		(*Base case*) * reflexivity.
		(*Induction step*) *
			simpl.
			rewrite IHm. reflexivity.
	Defined.

	Lemma addzero : forall n : nat, add n 0 = n.
	Proof.
	induction n. reflexivity. (*Base case done*)
	(*Induction step:*)
	simpl. rewrite IHn. reflexivity.
	Defined.

	Lemma zeroadd : forall n : nat, add 0 n = n.
	Proof. reflexivity. Defined.

	Lemma add_associative : forall l m n:nat, add (add l m) n = add l (add m n).
		induction l.
			induction m.
				induction n.
					(*l m n = 0*) * reflexivity.
					(*l = m = 0, Step n*)* reflexivity.
					(*l = 0, Step m *)* reflexivity.
					(*Step l*)*
						intros m n.
						simpl.
						apply (ap S).
						apply IHl.
	Defined.

	Lemma add_commutative : forall n m:nat, add n m = add m n.
		induction n.
		(*Base case*) *
			intro m.
			rewrite addzero. reflexivity.
		(*Induction step*) *
			intro m.
			simpl.
			rewrite IHn.
			symmetry.
			apply pred_second.
	Defined.

	Proposition nat_comm_monoid : isCommutative_Monoid nat add O.
		unfold isCommutative_Monoid.
		split.
			(*Associativity*) *
					unfold associative.
					apply add_associative.
				* split.

					unfold neutral.
					intro n.
					split.
							apply zeroadd. apply addzero.
			(*Commutativity*)
				unfold commutative.
				apply add_commutative.
	Defined.

	(*Define addition by recursion on the second variable.*)
	Fixpoint add' (m n : nat) : nat :=
		match n with
		|O => m
		|S n1 => S (add' m n1)
	end.

	Proposition equaladditions : forall m n:nat, add m n = add' m n.
		induction n.
		(*Base case*) * simpl. rewrite addzero. reflexivity.
		(*Induction step*) *
			simpl.
			rewrite pred_second.
			rewrite IHn.
			reflexivity.
	Defined.

	(*Slightly different proof showing that the two additions are equal (doesn't use lemmas)*)
	Proposition equaladditions2 : forall m n:nat, add m n = add' m n.
		induction m.
		(*Base case m*) *
			induction n.
				(*Base case n*) ** reflexivity.
				(*Induction step n*) **
					simpl.
					rewrite <- IHn.
					reflexivity.
		(*Induction step m*) *
 			intro n.
			simpl.
			rewrite IHm.
				induction n.
					(*Base case n*) ** reflexivity.
					(*Induction step n*) **
						simpl.
						rewrite IHn. reflexivity.
	Defined.

End Nat.

Section Integers.
	Inductive Z : Set :=
		|subt (n0 n1:nat) : Z
	.

	Axiom eq_Z_1 : forall m1 m2 n1 n2 : nat,
		add m1 n2 = add n1 m2 -> subt m1 m2 = subt n1 n2.

	Axiom eq_Z_2 : forall m1 m2 n1 n2 : nat,
		subt m1 m2 = subt n1 n2 -> add m1 n2 = add n1 m2.

	Definition inj (n: nat) : Z := subt n O.

	Definition neg (m:Z) :=
		match m with
		|subt m1 m2 => subt m2 m1
	end.

	Definition add_Z (m n : Z) : Z :=
		match m with
		| subt m1 m2 => match n with
			|subt n1 n2 => subt (add m1 n1) (add m2 n2)
		end
	end.

	Definition subt_Z (m n: Z) : Z :=
		add_Z m (neg n).

	Proposition injection : forall m n:nat, inj m = inj n -> m = n.
	Proof.
		unfold inj.
		intros m n p.
 		rewrite <- (addzero m). rewrite <- (addzero n).
		apply eq_Z_2.
		assumption.
	Defined.

	(*Abelian group axioms*)
	Lemma add_Z_associative : forall l m n : Z,
		add_Z (add_Z l m) n = add_Z l (add_Z m n).
	Proof.
		induction l.
		induction m.
		induction n.
		unfold add_Z.
		rewrite add_associative. rewrite add_associative. reflexivity.
	Defined.

	Lemma add_Z_commutative : forall m n : Z,
		add_Z m n = add_Z n m.
		induction m.
		induction n.
		simpl.
		rewrite (add_commutative n2 n0). rewrite (add_commutative n3 n1). reflexivity.
	Defined.

	Definition O_Z := subt O O.

	Lemma addzero_Z : forall n : Z, add_Z n O_Z = n.
	Proof.
		induction n.
		unfold O_Z.
		unfold add_Z.
		rewrite addzero. rewrite addzero. reflexivity.
	Defined.
	Lemma zeroadd_Z : forall n : Z, add_Z O_Z n = n.
		induction n.
		unfold O_Z.
		unfold add_Z.
		rewrite zeroadd. rewrite zeroadd. reflexivity.
	Defined.

	Lemma inverse_neg : forall n : Z, add_Z n (neg n) = O_Z /\ add_Z (neg n) n = O_Z.
	Proof.
		induction n.
		unfold neg.
		unfold add_Z.
		unfold O_Z.
		split.
		*apply eq_Z_1.
		rewrite addzero. rewrite zeroadd.
		apply add_commutative.
		*apply eq_Z_1.
		rewrite addzero. rewrite zeroadd.
		apply add_commutative.
	Defined.

	Proposition Z_abelian : isAbelian_Group Z add_Z O_Z.
		unfold isAbelian_Group.

		split.
		(*Associativity*) *
			unfold associative. apply add_Z_associative.
		* split.
		(*Neutral element*) **
			unfold neutral. intro n. split.
				***apply zeroadd_Z. ***apply addzero_Z.
		** split.
		(*Exists inverse*) ***
			unfold exists_inverse.
				intro n.
				exists (neg n). apply inverse_neg.
		(*Commutativity*) ***
			unfold commutative.
			apply add_Z_commutative.
	Defined.

End Integers.


Inductive True1 : Prop :=
  | tt1 : True1.

Inductive False1 : Prop := .

Inductive conj1 (A B : Prop) : Prop :=
  | and1 : A -> B -> conj1 A B.

Inductive disj1 (A B : Prop) : Prop :=
  | or1 : A -> B -> disj1 A B.

Inductive bool1 : Set :=
  | true1  : bool1
  | false1 : bool1.

Require Import Bool.

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

Definition and_bool (b1 b2 : bool) : bool :=
  match b1 , b2 with
    | true , b2  => b2
    | false , b2 => false
  end.

Definition or_bool (b1 b2 : bool) : bool :=
  match b1 , b2 with
    | true  , b2 => true
    | false , b2 => false
  end.

Definition xor_bool (b1 b2 : bool) : bool :=
  match b1 , b2 with
    | true , false => true
    | false , true => true
    | b1 , b2 => false
  end.

Eval compute in not_bool false.

Eval compute in xor_bool false true.

Lemma not_bool_inv : forall b : bool, not_bool (not_bool b) = b.
  Proof.
    intro b.
    destruct b.
    +
      simpl.
      reflexivity.
    +
      simpl.
      reflexivity.
  Qed.

Lemma and_true_left : forall b, and_bool true b = b.
  Proof.
  intro b.
  destruct b.
  +
    simpl.
    reflexivity.
  +
    simpl.
    reflexivity.
  Qed.

Lemma and_false_left : forall b, and_bool false b = false.
  Proof.
  intro b.
  destruct b.
  +
    simpl.
    reflexivity.
  +
    simpl.
    reflexivity.
  Qed.

Lemma and_com : forall b b', and_bool b b' = and_bool b' b.
  Proof.
  intros b b'.
  destruct b.
  +
    destruct b'.
    -
      simpl.
      reflexivity.
    -
      simpl.
      reflexivity.
  +
    destruct b'.
    -
      simpl.
      reflexivity.
    -
      simpl.
      reflexivity.
  Qed.

Lemma and_assocc : forall b1 b2 b3, and_bool b1 (and_bool b2 b3) = and_bool (and_bool b1 b2) b3.
  Proof.
  intros b1 b2 b3.
  destruct b1.
  +
    destruct b2.
    -
      destruct b3.
      *
        simpl.
        reflexivity.
      *
        simpl.
        reflexivity.
    -
      destruct b3.
      *
        simpl.
        reflexivity.
      *
        simpl.
        reflexivity.
  +
    destruct b2.
    -
      destruct b3.
      *
        simpl.
        reflexivity.
      *
        simpl.
        reflexivity.
    -
      destruct b3.
      *
        simpl.
        reflexivity.
      *
        simpl.
        reflexivity.
  Qed.
(*
Inductive nat1 : Set :=
| O : nat1
| S : nat1 -> nat1.

Fixpoint add (n m : nat) : nat :=
  match n with
    | O    => m
    | S n' => S (add n' m)
  end. *)
(*
Eval compute in add 1 1. *)
(*
Notation "n ':+:' m" := (add n m)(at level 40, left associativity). *)

Lemma zero_identity_add_left : forall n, 0 + n = n.
Proof.
    intro n.
    simpl.
    reflexivity.
Qed.

Lemma zero_identity_add_right : forall n, n + O = n.
  Proof.
    intro n.
    induction n as [ | n' IHn'].
    +
      simpl.
      reflexivity.
    +
      simpl.
      rewrite IHn'.
      reflexivity.
  Qed.

Lemma add_inc : forall m n, S (m + n) = m + S n.
  Proof.
    intros m n.
    induction m as [ | m' IHm'].
    +
      simpl.
      reflexivity.
    +
      simpl.
      rewrite IHm'.
      reflexivity.
  Qed.

Lemma add_commut : forall n m, n + m = m + n.
  Proof.
    intros n m.
    induction n as [| n' IHn'].
    +
      simpl.
      symmetry.
      apply zero_identity_add_right.
    +
      simpl.
      rewrite IHn'. (* nessa versão tem que fazer algumas correcoes*)
      apply add_inc.
  Qed.

Lemma add_associative : forall n m p, n + (m + p) = (n + m) + p.
    Proof.
      intros n m p.
      induction n as [| n' IHn'].
      +
        simpl.
        reflexivity.
      +
        simpl.
        rewrite IHn'.
        reflexivity.
    Qed.

(*
Fixpoint times (n m : nat) : nat :=
      match n with
      | 0    => 0
      | S n' => m + (times n' m)
      end.
*)

Lemma one_identity_times_right : forall n, n * 1 = n.
  Proof.
    intro n.
    induction n as [| n' Ihn'].
    +
      simpl.
      reflexivity.
    +
      simpl.
      rewrite Ihn'.
      reflexivity.
  Qed.

Lemma one_identity_times_left : forall n, 1 * n = n.
  Proof.
    intro n.
    induction n as [| n' Ihn'].
    +
      simpl.
      reflexivity.
    +
      simpl.
      rewrite zero_identity_add_right.
      reflexivity.
  Qed.

Lemma zero_times_left : forall n, 0 * n = 0.
  Proof.
    intro n.
    simpl.
    reflexivity.
  Qed.

Lemma zero_times_right : forall n, n * 0 = 0.
  Proof.
    intro n.
    induction n as [|n' Ihn'].
    +
      reflexivity.
    +
      simpl.
      apply Ihn'.
  Qed.

Lemma add_mult_1 : forall n m p, (n + m) * p = n * p + m * p.
  Proof.
    intro n.
    induction n as [| n' Ihn].
    +
      intros m p.
      simpl.
      reflexivity.
    +
      simpl.
      intros m p.
      rewrite Ihn.
      apply add_associative.
  Qed.

Lemma times_associative : forall n m p, (n * m) * p = n * (m * p).
  Proof.
    intros n.
    induction n as  [| n' Ihn'].
    +
      simpl.
      intros m p.
      reflexivity.
    +
      simpl.
      intros m p.
      rewrite <- Ihn'.
      apply add_mult_1.
  Qed.

Lemma add_1 : forall n m p, n + (m + p) = m + (n + p).
  Proof.
    intro n.
    induction n as [|n' Ihn].
    +
      simpl.
      reflexivity.
    +
      intros m p.
      simpl.
      rewrite Ihn.
      rewrite add_inc.
      reflexivity.
  Qed.

Lemma times_1 : forall n m, n + n * m = n * S m.
  Proof.
    intro n.
    induction n as [| n' Ihn].
    +
      simpl.
      intro m.
      reflexivity.
    +
      simpl.
      intro m.
      rewrite <- Ihn.
      rewrite add_1.
(*       assert (n' + (m + n' * m) = m + (n' + n' * m)).
        admit.
      rewrite H. *)
      reflexivity.
  Qed.

Lemma times_commut : forall n m, n * m = m * n.
  Proof.
    intros n.
    induction n as [| n' Ihn'].
    +
      simpl.
      intro m.
      rewrite zero_times_right.
      reflexivity.
    +
      simpl.
      intro m.
      rewrite Ihn'.
      apply times_1.
  Qed.

Fixpoint even_bool (n : nat) : bool :=
  match n with
    | 0 => true
    | S n => not_bool (even_bool n)
  end.

Lemma even_add_n : forall n, even_bool (n + n) = true.
  Proof.
    intro n.
    induction n as [|n' Ihn].
    +
      simpl.
      reflexivity.
    +
      simpl.
      rewrite add_commut.
      simpl.
      rewrite Ihn.
      simpl.
      reflexivity.
  Qed.

Fixpoint odd_bool (n: nat) : bool :=
  match n with
    | 0 => false
    | S n => not_bool (odd_bool n)
  end.

Lemma odd_add_n_n : forall n, odd_bool (n + n) = false.
  Proof.
    intro n.
    induction n as [|n' Ihn].
    +
      simpl.
      reflexivity.
    +
      simpl.
      rewrite add_commut.
      simpl.
      rewrite Ihn.
      simpl.
      reflexivity.
  Qed.

Lemma odd_add_n_Sn : forall n, odd_bool (n + S n) = true.
  Proof.
    intro n.
    induction n as [|n' Ihn].
    +
      simpl.
      reflexivity.
    +
      simpl.
      rewrite add_commut.
      simpl.
      rewrite odd_add_n_n.
      simpl.
      reflexivity.
  Qed.

Lemma even_SS : forall n, even_bool n = even_bool (S (S n)).
  Proof.
    intro n.
    induction n as [| n' Ihn].
    +
      simpl.
      reflexivity.
    +
      simpl.
      rewrite not_bool_inv.
      reflexivity.
  Qed.

Lemma odd_SS : forall n, odd_bool n = odd_bool (S (S n)).
  Proof.
    intro n.
    induction n as [| n' Ihn].
    +
      simpl.
      reflexivity.
    +
      simpl.
      rewrite not_bool_inv.
      reflexivity.
  Qed.

Lemma even_bool_S : forall n, even_bool n = not_bool (even_bool (S n)).
  Proof.
    intro n.
    induction n as [| n' Ihn].
    +
      simpl.
      reflexivity.
    +
      simpl.
      rewrite not_bool_inv.
      reflexivity.
  Qed.

Lemma length_app
      : forall {A : Type}(xs ys : list A), length (xs ++ ys) = length xs + length ys.
    Proof.
      intros A xs ys.
      induction xs as [| z zs IHzs].
      +
        simpl.
        reflexivity.
      +
        simpl.
        rewrite IHzs.
        reflexivity.
    Qed.

Lemma length_app_1
      : forall {A : Type}(xs ys : list A), length (xs ++ ys) = length xs + length ys.
    Proof.
      intros A xs ys.
      induction xs as [| z zs IHzs].
      +
        simpl.
        reflexivity.
      +
        simpl.
        rewrite IHzs.
        reflexivity.
    Qed.

(*necessario para o restante dos exercicios.*)
Require Import List.

Lemma map_length {A B : Type}{f : A -> B} : forall xs, length (map f xs) = length xs.
    Proof.
      intros xs.
      induction xs as [ | y ys IHys].
      +
        reflexivity.
      +
        simpl.
        rewrite IHys.
        reflexivity.
    Qed.

(*reverse => rev*)
Lemma reverse_length {A : Type}: forall (xs : list A), length xs = length (rev xs).
    Proof.
      intros xs.
      induction xs.
      +
        reflexivity.
      +
        simpl.
        rewrite length_app, add_commut.
        rewrite IHxs.
        reflexivity.
    Qed.

(*reapeat esta com seus parametro trocados.*)
Lemma repeat_length {A : Type} : forall (n : nat)(x : A), length (repeat x n) = n.
    Proof.
      intro n.
      induction n.
      +
        simpl.
        intro x.
        reflexivity.
      +
        intro x.
        simpl.
        rewrite IHn.
        reflexivity.
    Qed.

(*[] => nil - verificar depois*)
Lemma app_nil_right {A : Type} : forall (xs : list A), xs ++ nil = xs.
    Proof.
    intro xs.
    induction xs.
    +
      simpl.
      reflexivity.
    +
      simpl.
      rewrite IHxs.
      reflexivity.
   Qed.

Lemma app_assoc {A : Type} :
  forall (xs ys zs : list A), xs ++ (ys ++ zs) = (xs ++ ys) ++ zs.
    Proof.
      intros xs.
      induction xs.
      +
        simpl.
        reflexivity.
      +
        simpl.
        intros ys zs.
        rewrite IHxs.
        reflexivity.
    Qed.

Lemma map_app {A B : Type}{f : A -> B}
      : forall xs ys, map f (xs ++ ys) = map f xs ++ map f ys.
    Proof.
      intro xs.
      induction xs.
      +
        simpl.
        reflexivity.
      +
        intro ys.
        simpl.
        rewrite IHxs.
        reflexivity.
    Qed.

(*reverse => rev*)

Lemma reverse_app {A : Type}
      : forall (xs ys : list A), rev (xs ++ ys) = rev ys ++ rev xs.
    Proof.
      intros xs.
      induction xs.
      +
        simpl.
        intro ys.
        rewrite app_nil_right.
        reflexivity.
      +
        intro ys.
        simpl.
        rewrite IHxs.
        rewrite app_assoc.
        reflexivity.
   Qed.

Lemma reverse_inv {A : Type}
      : forall (xs : list A), rev (rev xs) = xs.
    Proof.
      intro xs.
      induction xs.
      +
        simpl.
        reflexivity.
      +
        simpl.
        rewrite reverse_app.
        simpl.
        rewrite IHxs.
        reflexivity.
    Qed.

Inductive even : nat -> Prop :=
| ev_zero : even 0
| ev_ss   : forall n, even n -> even (S (S n)).

Definition double (n : nat) := 2 * n.

Lemma double_n :
  forall n, n + n = 2 * n.
    Proof.
      intro n.
      induction n.
      +
        simpl.
        reflexivity.
      +
        simpl.
        rewrite zero_identity_add_right.
        reflexivity.
    Qed.

Lemma double_even :
  forall n, even (double n).
    Proof.
      unfold double.
      intro n.
      induction n.
      +
        simpl.
        apply ev_zero.
      +
        simpl.
        rewrite zero_identity_add_right.
        rewrite add_commut.
        simpl.
        rewrite double_n.
        apply ev_ss.
        apply IHn.
    Qed.

Example teste_le : 3 <= 6.
    Proof.
      apply le_S.
      apply le_S.
      apply le_S.
      apply le_n.
    Qed.

Example teste_le_false : 2 <= 1 -> 1 + 1 = 10.
    Proof.
      intros H.
      inversion H.
      inversion H1.
    Qed.

Lemma le_0_n : forall n, 0 <= n.
    Proof.
      intros n.
      induction n as [| n' IHn'].
      +
        apply le_n.
      +
        apply le_S.
        assumption.
    Qed.

Lemma le_refl : forall n, n <= n.
  Proof.
    intro n.
    induction n.
    +
      apply le_n.
    +
      apply le_n.
  Qed.

Lemma le_cong_S : forall n m, n <= m -> S n <= S m.
  Proof.
    intros n m Hnm.
    induction Hnm.
    +
      apply le_refl.
    +
      apply le_S.
      assumption.
  Qed.

(*não entendi essa prova.*)
Lemma le_S_cong : forall n m, S n <= S m -> n <= m.
  Proof.
    intros n m.
    induction m as [| m' IHm'].
    +
      intros Hnm.
      inversion Hnm.
      -
        apply le_refl.
      -
        inversion H0.
    +
      intros Hnm.
      inversion Hnm.
      -
        subst.
        apply le_refl.
      -
        subst.
        apply le_S.
        apply IHm'.
        assumption.
  Qed.

Lemma le_n_sm :
  forall n m, n <= m -> n <= S m.
    Proof.
      intro n.
      induction n.
      -
        intro m.
        intro H0m.
        apply le_S.
        apply H0m.
     -
        intro m.
        intro Hsmn.
        apply le_S.
        apply Hsmn.
    Qed.

Lemma le_trans :
  forall n m p, n <= m -> m <= p -> n <= p.
    Proof.
      intro n.
      induction n.
      +
        intros m p.
        intro H0m.
        intro Hmp.
        rewrite H0m.
        apply Hmp.
      +
        intros m p.
        intro Hsnm.
        intro Hmp.
        rewrite Hsnm.
        apply Hmp.
    Qed.

Lemma eq_zero_right :
  forall n, n = 0 -> 0 = n.
    Proof.
      intro n.
      induction n.
      +
        intro H00.
        assumption.
      +
        intro Hsn0.
        inversion Hsn0.
    Qed.

Lemma eq_zero_left :
  forall n, 0 = n -> n = 0.
    Proof.
      intro n.
      induction n.
      +
        intro H00.
        assumption.
      +
        intro Hsn0.
        inversion Hsn0.
    Qed.

Lemma le_zero_antisym_right :
  forall n, n <= 0 -> 0 <= n -> n = 0.
    Proof.
      intro n.
      induction n.
      +
        intro H001.
        intro H002.
        apply eq_refl.
      +
        intro Hsn0.
        intro H0sn.
        inversion Hsn0.
   Qed.

Lemma le_zero_antisym_left :
  forall n, 0 <= n -> n <= 0 -> 0 = n.
    Proof.
      intro n.
      induction n.
      +
        intro H001.
        intro H002.
        apply eq_refl.
      +
        intro H0sn.
        intro Hsn0.
        inversion Hsn0.
    Qed.

Lemma le_s_inject : forall n m, S n <= S m -> n <= m.
  Proof.
    intros n m.
    generalize dependent n.
    induction m.
    +
      intros n H.
      inversion H.
      -
        apply le_n.
      -
        inversion H1.
    +
      intro n.
      intro H.
      inversion H.
      -
        apply le_n.
      -
        apply IHm in H1.
        apply le_S.
        assumption.
    Qed.

Lemma le_antisym : forall n m, n <= m -> m <= n -> n = m.
  Proof.
    intro n.
    induction n.
    intro m.
    +
      apply le_zero_antisym_left.
    +
      intro p.
      intro Hsnp.
      intro Hpsn.
      inversion Hsnp.
      -
        reflexivity.
      -
        f_equal.
        apply IHn.
        *
          rewrite <- H0 in Hsnp.
          apply le_s_inject.
          assumption.
        *
          rewrite <- H0 in Hsnp, Hpsn.
          apply le_s_inject.
          assumption.
  Qed.

Import ListNotations.

Inductive Sorted : list nat -> Prop :=
  | sorted_nil : Sorted []
  | sorted_cons1 a : Sorted [a]
  | sorted_consn a b l : Sorted (b :: l) -> a <= b -> Sorted (a :: b :: l) .

Example test_sorted1 : Sorted [].
  Proof.
    apply sorted_nil.
  Qed.

Example test_sorted2 : Sorted [10].
  Proof.
    apply sorted_cons1.
  Qed.

Example test_sorted3 : Sorted [1 ; 3 ; 5 ].
  Proof.
    apply sorted_consn.
    +
      apply sorted_consn.
      -
        apply sorted_cons1.
      -
        apply le_S.
        apply le_S.
        apply le_n.
    +
      apply le_S.
      apply le_S.
      apply le_n.
  Qed.

Reserved Notation "x '<<=' y" (at level 40, no associativity).

Inductive le_alt : nat -> nat -> Prop :=
| le_alt_zero : forall n, 0 <<= n
| le_alt_succ : forall n m, n <<= m -> S n <<= S m
where "x '<<=' y" := (le_alt x y).

 Lemma le_alt_refl : forall n, n <<= n.
    Proof.
      intro n.
      induction n.
      +
        apply le_alt_zero.
      +
        apply le_alt_succ.
        apply IHn.
    Qed.

Lemma le_alt_trans
      : forall n m p, n <<= m -> m <<= p -> n <<= p.
    Proof.
      induction n; intros m p H1 H2.
      +
        apply le_alt_zero.
      +
        inversion H2.
        -
          subst.
          inversion H1.
        -
          subst.
          apply le_alt_succ.
          apply (IHn n0 m0).
          *
            inversion H1.
            assumption.
          *
            assumption.
    Qed.

Lemma le_alt_antisymm :
  forall n m, S n <<= S m -> n <<= m.
  Proof.
    induction n ; intros m H.
    +
      apply le_alt_zero.
    +
      inversion H.
      subst.
      assumption.
  Qed.

Lemma le_alt_antisym :
  forall n m, n <<= m -> m <<= n -> n = m.
    Proof.
      induction n ; intros m H1 H2.
      +
        inversion H2.
        apply eq_refl.
      +
        inversion H1.
        subst.
        f_equal.
        apply (IHn m0).
        -
          inversion H1.
          assumption.
        -
          inversion H2.
          assumption.
    Qed.
Lemma le_zero :
  forall n, 0 <= n.
    Proof.
    induction n ; constructor ; try assumption.
  Qed.

Lemma le_alt_equiv_le :
  forall n m, n <<= m <-> n <= m.
    Proof.
      induction n ; intros ; split ; intros.
      +
        apply le_zero.
      +
       constructor.
      +
        destruct m.
        -
          inversion H.
        -
          apply le_cong_S.
          inversion H.
          apply IHn in H2.
          assumption.
      +
        destruct m.
        -
          inversion H.
        -
          apply le_S_cong in H.
          constructor.
          apply IHn in H.
          assumption.
    Qed.


(**************************** Exercise: 1 star  (nandb)  *********************)

Definition nandb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | false => true
  | true  => match b2 with
             | false => true
             | true  => false
             end
  end.

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.

(************************** Exercise: 1 star (andb3) ***************************)

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
   match b1 with
   | false => false
   | true  => match b2 with
              | false => false
              | true  => b3
              end
   end.

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.

Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.

Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.

Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

(************************** Exercise: 1 star (factorial) ***************************)

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

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

Fixpoint factorial (n:nat) : nat :=
    match n with
    | 0 => 1
    | S n' => mult n (factorial n')
    end.

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

(**************************  Exercise: 1 star (blt_nat) ***************************)

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

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

Definition blt_nat (n m : nat) : bool :=
                    (andb (negb (beq_nat n m)) (leb n m)).

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

(************************** Exercise: 1 star (plus_id_exercise) ***************************)

Theorem plus_id_exercise : forall n m o : nat,
  n = m ->  m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros Ha.
  intros Hb.
  rewrite -> Ha.
  rewrite <- Hb.
  reflexivity. Qed.

(************************** Exercise: 2 stars (mult_S_1) ***************************)

Theorem mult_S_1 : forall n m : nat,
  m = S n ->
  m * (1 + n) = m * m.
Proof.
  intros n m.
  intro Ha.
  rewrite -> Ha.
  reflexivity.
Qed.

(************************** Exercise: 2 stars (andb_true_elim2) ***************************)

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c H.
  destruct b.
   - simpl in H. assumption.
   - simpl in H.
   congruence.
(************************** Exercise: 1 star (zero_nbeq_plus_1) ***************************)

Theorem zero_nbeq_plus_1 : forall n : nat,
  beq_nat 0 (n + 1) = false.
Proof.
  intros n.
  destruct n as [|n'].
   - reflexivity.
   - reflexivity.
Qed.


Require Import EqNat.
Require Import List.
Require Import Peano.
(* syntax of propositional logic, Schoening p 4, lecture notes *)

Inductive atomic :=
| A : nat -> atomic.

Definition beq_atomic (a : atomic) (b : atomic) :=
  match a, b with
    | A n, A m => beq_nat n m
  end.

Inductive formula :=
  | Atom : atomic -> formula
  | Negation : formula -> formula
  | Disjunction : formula -> formula -> formula.

Fixpoint beq_formula (f : formula) (g : formula) :=
  match f, g with
    | Atom foo, Atom bar => beq_atomic foo bar
    | Negation foo, Negation bar => beq_formula foo bar
    | Disjunction foo boo, Disjunction far bar => andb (beq_formula foo far) (beq_formula boo bar)
    | _, _ => false
  end.

Fixpoint get_atoms (f : formula) : list atomic :=
  match f with
    | Atom foo => foo::nil
    | Negation foo => get_atoms foo
    | Disjunction foo bar => (get_atoms foo) ++ (get_atoms bar)
  end.

(* computational definition *)

Fixpoint subformula (F : formula) (G : formula) : bool :=
  (* checks whether F is a subformula of G *)
  if beq_formula F G
  then true
  else match G with
         | Atom foo => false
         | Negation foo => subformula F foo
         | Disjunction foo bar => orb (subformula F foo) (subformula F bar)
       end.

Inductive subformulaR : formula -> formula -> Prop :=
| R_Atom : forall a b,
             beq_atomic a b = true -> subformulaR (Atom a) (Atom b)
| R_Negation : forall f,
                 subformulaR f (Negation f)
| R_Disjunction_L : forall f g,
                      subformulaR f (Disjunction f g)
| R_Disjunction_R : forall f g,
                      subformulaR g (Disjunction f g).

Theorem comp_rel_subformula_eq : forall F G,
                                   subformula F G = true <-> subformulaR F G.
Proof.
  intros. split.
  + intros.
    induction G.
    simpl in H.
    destruct (beq_formula F (Atom a)) eqn:foo.
    destruct F.
    generalize foo.
    apply R_Atom.
    inversion H.
    apply IHG in H.
    generalize H. apply R_Negation.

Eval simpl in get_atoms (Disjunction (Negation (Atom (A 1))) (Disjunction (Atom (A 2)) (Atom (A 3)))).
Eval simpl in subformula (Atom (A 2)) (Disjunction (Negation (Atom (A 1))) (Disjunction (Atom (A 2)) (Atom (A 3)))).

Example ex1: subformula (Disjunction (Atom (A 1)) (Atom (A 2))) (Disjunction (Atom (A 3)) (Disjunction (Atom (A 1)) (Atom (A 2)))) = true.
Proof.
 simpl. reflexivity.
Qed.

Example ex2 : subformulaR (Disjunction (Atom (A 2)) (Atom (A 3))) (Disjunction (Atom (A 2)) (Atom (A 3))).

Eval simpl in subformula (Negation (Atom (A 2))) (Disjunction (Negation (Atom (A 1))) (Disjunction (Atom (A 2)) (Atom (A 3)))).

(* relational definition *)

Definition assignment := list (atomic * bool).

Fixpoint find_assignment (a : atomic) (assignments : assignment) : option bool :=
  match assignments with
    | nil => None
    | (b, truth_value)::tail => if beq_atomic a b
                                then Some truth_value
                                else find_assignment a tail
  end.

(* When we define the semantics of propositional logic, we do so by saying that there exists
   some function (which we call the assignment) of the atomic formulae, which we can expand to be
   true for all formulae built up from the atomic formulae. The function we define here in Coq
   works from the top-down, rather than from the bottom-up. Could we think of the informal proof
   as being like weak induction and the formal one as being like strong induction? Or this mostly
   just the difference between using a function vs using propositions?
*)

Fixpoint eval_formula (phi : formula) (a : assignment) : option bool :=
  (* for now we use the option type to handle cases when the assignment isn't ... *)
  match phi with
    | Atom foo => find_assignment foo a
    | Negation foo => match (eval_formula foo a) with
                        | None => None
                        | Some x => Some (negb x)
                      end
    | Disjunction foo bar => match (eval_formula foo a) with
                               | None => None
                               | Some x => match (eval_formula bar a) with
                                             | None => None
                                             | Some y => Some (orb x y)
                                           end
                             end
  end.

Eval simpl in eval_formula (Negation (Disjunction (Atom (A 1)) (Atom (A 2))))
                           (((A 1), true)::((A 2), true)::nil).
Eval simpl in eval_formula (Negation (Disjunction (Atom (A 1)) (Atom (A 2))))
                           (((A 1), true)::((A 2), false)::nil).
Eval simpl in eval_formula (Negation (Disjunction (Atom (A 1)) (Atom (A 2))))
                           (((A 1), false)::((A 2), false)::nil).

(* computational models *)
Definition suitable1 (f : formula) (a : assignment) := eval_formula f a <> None.

Fixpoint suitable2 (f : formula) (a : assignment) :=
  match a with
    | nil => True
    | (literal, _)::tl => (In literal (get_atoms f)) /\ (suitable2 f tl)
  end.

Definition models (f : formula) (a : assignment) := eval_formula f a = Some true.

Definition satisfiable (f : formula) := exists a,
                                          suitable1 f a -> eval_formula f a = Some true.

Definition unsatisfiable (f : formula) := forall a,
                                            suitable1 f a -> eval_formula f a = Some false.

Definition valid (f : formula) := forall a,
                                    suitable1 f a -> eval_formula f a = Some true.

(* relational models *)

(* Inductive suitableR : formula -> assignment -> Prop := *)
(* | R_Atom : forall (f : formula) (atom : atomic) (a : assignment), *)
(*              find_assignment atom a <> None -> suitableR (Atom atom) a *)
(* | R_Negation : forall (f : formula) (atom : atomic) (a : assignment), *)
(*                  find_assignment atom a <> None -> suitableR f a -> suitableR (Negation f) a  *)
(* | R_Disjunction : forall (f g : formula) (atom : atomic) (a : assignment), *)
(*                     find_assignment atom a <> None -> suitableR f a -> suitableR g a -> suitableR (Disjunction f g) a. *)

(* Inductive satisfiableR : formula -> assignment -> Prop := *)
(* | R_Atom : forall (f : formula) (atom : atomic) (a : assignment), *)
(*              (suitableR f a) f atom a ->  *)

(* Illustrate some examples *)

Definition some_assignments : assignment := ((A 1), false)::((A 2), true)::nil.

Example suitable_ex : suitable1 (Negation (Atom (A 1))) some_assignments.
Proof. compute; intros H; inversion H. Qed.

(* Example suitableR_ex : suitableR (Negation (Atom (A 1))) some_assignments. *)
(* Proof.  *)
(*   unfold some_assignments. *)
(*   apply R_Negation with (atom:=(A 1)). *)
(*   compute; intros; inversion H. *)
(*   apply R_Atom. *)

Example models_ex : models (Negation (Atom (A 1))) some_assignments.
Proof. compute; reflexivity. Qed.

Example sat_ex : satisfiable (Negation (Atom (A 1))).
Proof. unfold satisfiable; exists some_assignments; compute; reflexivity. Qed.

(*Notation "'Conjunction' A B" := (Negation (Disjunction (Negation A) (Negation B))) (at level 85, left associativity).
Check (Conjunction (Atom (A 1)) (Atom (A 2))). *)

(* this is a candidate problem? *)
Example unsat_ex : unsatisfiable (Negation (Disjunction (Atom (A 1)) (Negation (Atom (A 1))))).
Proof.
  unfold unsatisfiable.
  unfold suitable1.
  intros.
  simpl. simpl in H.
  destruct (find_assignment (A 1) a).
  destruct b; simpl; reflexivity.
  unfold not in H.
  assert (H1 : False -> None = Some false).
  + intros. inversion H0.
  + apply H1. apply H. reflexivity.
Qed.

Lemma empty_assignment_not_suitable : forall F,
                                        eval_formula F nil = None -> ~ suitable1 F nil.
Proof.
  induction F as [|F' IHF| F' IHF];
  try (simpl; intros; unfold not; intros; compute in H0; apply H0 in H; inversion H);
  try (intros; unfold not; unfold suitable; unfold not; intros; apply H0 in H; inversion H).
Qed.

(* Schoening, p 9 : A formula F is a tautology iff ~F is unsat *)
(* Lemma not_unsat_sat : forall F, *)
(*                         ~ (unsatisfiable F) -> exists a, *)

Lemma  suitable_invariant_negation : forall F a,
                                       suitable1 F a <-> suitable1 (Negation F) a.
Proof.
  intros. split.
  + induction F; unfold suitable1; unfold not; intros;  simpl in H; simpl in H0.
    (* atomic *)
    destruct (find_assignment a0 a).
    inversion H0.
    (* negation *)
    apply H; apply H0.
    destruct (eval_formula F a).
    inversion H0.
    (* disjunction *)
    apply H; apply H0.
    destruct (eval_formula F1 a).
    destruct (eval_formula F2 a).
    inversion H0.
    apply H; apply H0.
    apply H; apply H0.
  + induction F; unfold suitable1; unfold not; intros.
    (* atomic *)
    simpl in H0.
    destruct (find_assignment a0 a) eqn:stuff.
    inversion H0.
    apply H.
    simpl.
    rewrite stuff.
    reflexivity.
    (* negation *)
    simpl in H0.
    destruct (eval_formula F a) eqn:stuff.
    inversion H0.
    apply H.
    simpl.
    rewrite stuff.
    reflexivity.
    (* disjunction *)
    simpl in H. simpl in H0.
    destruct (eval_formula F1 a) eqn:stuff1.
    destruct (eval_formula F2 a) eqn:stuff2.
    inversion H0.
    apply H; apply H0.
    apply H; apply H0.
Qed.

Lemma atom_eq : forall a b,
                  beq_atomic a b = true -> a = b.
Proof.
  intros.
  induction a. destruct b.
  inversion H.
  apply beq_nat_true_iff in H1.
  rewrite H1. reflexivity.
Qed.

Lemma eq_nat_beq : forall n m,
                     n = m -> beq_nat n m = true.
Proof.
  intros. rewrite H. symmetry. apply beq_nat_refl.
Qed.

Lemma subformula_atomic_reverse : forall a b,
                                    subformulaR (Atom a) (Atom b) -> beq_atomic a b = true.
Proof.
  intros.
  destruct (Atom a).

  generalize a b.
  induction H.
  intros.

Lemma subformula_atom_subset: forall F G,
                                subformulaR F G ->
                                forall a,
                                  In a (get_atoms F) -> In a (get_atoms G).
Proof.
  intros. induction F; induction G.
  simpl. left. simpl in H0. inversion H0.
  rewrite <- H1.


Require Export GeoCoq.Elements.OriginalProofs.lemma_ABCequalsCBA.
Require Export GeoCoq.Elements.OriginalProofs.lemma_equalanglestransitive.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_equalanglesflip :
   forall A B C D E F,
   CongA A B C D E F ->
   CongA C B A F E D.
Proof.
intros.
assert (nCol D E F) by (conclude lemma_equalanglesNC).
assert (CongA D E F A B C) by (conclude lemma_equalanglessymmetric).
assert (nCol A B C) by (conclude lemma_equalanglesNC).
assert (~ Col C B A).
 {
 intro.
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA C B A A B C) by (conclude lemma_ABCequalsCBA).
assert (CongA C B A D E F) by (conclude lemma_equalanglestransitive).
assert (CongA D E F F E D) by (conclude lemma_ABCequalsCBA).
assert (CongA C B A F E D) by (conclude lemma_equalanglestransitive).
close.
Qed.

End Euclid.


From mathcomp Require Import ssreflect ssrbool ssrfun ssrnat finset fingroup fintype bigop.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Import Prenex Implicits.

Section Lagrange.

Open Scope group_scope.

Variable gT: finGroupType.
Variable G: {group gT}.
Variable H: {group gT}.
Hypothesis HG: H \subset G.

Definition R := [rel x y | x * y^-1 \in H].

Lemma equiv_rel_R: equivalence_rel R.
Proof.
  rewrite /equivalence_rel=> x y z /=.
  split.
  - by rewrite mulgV.
  - move=> Hxy.
    apply /idP /idP => Htest.
    + apply groupVr in Hxy.
      rewrite invMg invgK in Hxy.
      move: (groupM Hxy Htest).
      by rewrite -mulgA [X in _ * X]mulgA mulVg mul1g.
    + move: (groupM Hxy Htest).
      by rewrite -mulgA [X in _ * X]mulgA mulVg mul1g.
Qed.

Lemma myCard_rcoset (A: {set gT}):
  A \in rcosets H G -> #|A| = #|H|.
Proof.
  case /rcosetsP => x xinG ->. (* -> : x=y -> P x => P y  *)
  by apply: card_rcoset.
Qed.

Lemma coset_equiv_class (x: gT) (xinG : x \in G):
  H :* x = [set y in G | R x y].
Proof.
  apply /setP => /= y. rewrite inE.
  apply /idP /idP.
  - case /rcosetP => z zinH -> {y}.
    apply /andP; split.
    + apply/ groupM; try by [].
      move/ subsetP: HG => HG'.
      by rewrite HG'.
    + rewrite invMg mulgA mulgV mul1g.
      by apply groupVr.
  - case/ andP => yinG xyvinH.
    apply/ rcosetP.
    exists (y * x^-1); last first.
    + by rewrite -mulgA mulVg mulg1.
    + move: xyvinH.
      by rewrite -groupV invMg invgK.
Qed.

Lemma rcosets_equiv_part: rcosets H G = equivalence_partition R G.
Proof.

Admitted.

End Lagrange.


Inductive day : Type :=
| monday : day
| tuesday : day
| wednesday : day
| thursday : day
| friday : day
| saturday : day
| sunday : day.

Definition next_weekday (d:day) : day :=
  match d with
    | monday => tuesday
    | tuesday => wednesday
    | wednesday => thursday
    | thursday => friday
    | friday => monday
    | saturday => monday
    | sunday => monday
  end.

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.
Proof. simpl. reflexivity. Qed.

Inductive bool : Type :=
| true : bool
| false : bool.

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

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
    | true => b2
    | false => false
  end.

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
    | true => true
    | false => b2
  end.

Definition nandb (b1:bool) (b2:bool) : bool :=
  match b1 with
    | false => true
    | true => negb b2
  end.

Example test_nandb1: (nandb true false) = true.
Proof. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  match b1 with
    | true => andb b2 b3
    | false => false
  end.

Example test_andb31: (andb3 true true true) = true.
Proof. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. reflexivity. Qed.

Module Playground1.
  Inductive nat : Type :=
  | O : nat
  | S : nat -> nat.

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

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

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

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

Example test_oddb1: (oddb (S O)) = true.
Proof. reflexivity. Qed.
Example test_oddb2: (oddb (S (S (S (S O))))) = false.
Proof. reflexivity. Qed.

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

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

  Example test_mult1: (mult 3 3) = 9.
  Proof. reflexivity. Qed.

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

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

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

Example test_factorial1: (factorial 3) = 6.
Proof. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. reflexivity. Qed.

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

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

Example test_ble_nat1: (ble_nat 2 2) = true.
Proof. reflexivity. Qed.
Example test_ble_nat2: (ble_nat 2 4) = true.
Proof. reflexivity. Qed.
Example test_ble_nat3: (ble_nat 4 2) = false.
Proof. reflexivity. Qed.

Definition blt_nat (n m : nat) : bool :=
  andb (ble_nat n m) (negb (beq_nat n m)).

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. reflexivity. Qed.
Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. reflexivity. Qed.
Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. reflexivity. Qed.

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

Theorem plus_1_l : forall n : nat, 1 + n = S n.
Proof.
  intros n. reflexivity.
Qed.

Theorem mult_O_l : forall n : nat, 0 * n = 0.
Proof.
  intros n. reflexivity.
Qed.

Theorem plus_id_example : forall n m : nat,
                            n = m ->
                            n + n = m + m.
Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_id_exercise : forall n m o : nat,
                             n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H1.
  intros H2.
  rewrite -> H1.
  rewrite -> H2.
  reflexivity.
Qed.

Theorem mult_O_plus : forall n m : nat,
                        (O + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_O_n.
  reflexivity.
Qed.

Theorem mult_S_l : forall n m : nat,
                     m = S n ->
                     m * (1 + n) = m * m.
Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_1_neq_O : forall n : nat,
                         beq_nat (n + 1) 0 = false.
Proof.
  intros n. destruct n as [| n'].
    reflexivity.
    reflexivity.
Qed.

Theorem negb_involutive : forall b : bool,
                            negb (negb b) = b.
Proof.
  intros b. destruct b.
    reflexivity.
    reflexivity.
Qed.

Theorem zero_nbeq_plus_l : forall n : nat,
                             beq_nat 0 (n + 1) = false.
Proof.
  intros n. destruct n as [| n'].
    reflexivity.
    reflexivity.
Qed.

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
    (forall (x : bool), f x = x) ->
    forall (b : bool), f (f b) = b.
Proof.
  intros f.
  intros H.
  intros b.
  rewrite -> H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
    (forall (x : bool), f x = negb x) ->
    forall (b : bool), f (f b) = b.
Proof.
  intros f.
  intros H.
  intros b.
  rewrite -> H.
  rewrite -> H.
  destruct b.
    reflexivity.
    reflexivity.
Qed.

Theorem andb_true_true :
  forall (c:bool), andb true c = true -> c = true.
Proof.
  intros c.
  destruct c.
  reflexivity.
Abort.

Theorem andb_eq_orb :
  forall (b c : bool),
    (andb b c = orb b c) ->
    b = c.
Proof.
  intros b c.
  destruct b.
    destruct c.
      reflexivity.
      intros H.
      simpl in H.
      symmetry.
      rewrite -> H.
      reflexivity.
    destruct c.
      intros H.
      simpl in H.
      rewrite -> H.
      reflexivity.
      reflexivity.
Qed.

Inductive bin : Type :=
| Z : bin
| Twice : bin -> bin
| STwice : bin -> bin.

Fixpoint bin_incr (b : bin) : bin :=
  match b with
    | Z => STwice Z
    | Twice b' => STwice (b')
    | STwice b' => Twice (bin_incr b')
  end.

Fixpoint bin_to_nat (b : bin) : nat :=
  match b with
    | Z => O
    | Twice b' => 2 * (bin_to_nat b')
    | STwice b' => 2 * (bin_to_nat b') + 1
  end.

Example test_bin_incr1 : bin_incr Z = STwice Z.
Proof. reflexivity. Qed.
Example test_bin_incr2 : bin_incr (STwice Z) = Twice (STwice Z).
Proof. reflexivity. Qed.
Example test_bin_incr3: bin_incr (Twice (STwice Z)) = STwice (STwice Z).
Proof. reflexivity. Qed.

Example test_bin_to_nat1 : bin_to_nat Z = O.
Proof. reflexivity. Qed.
Example test_bin_to_nat2 : bin_to_nat (STwice Z) = 1.
Proof. reflexivity. Qed.
Example test_bin_to_nat3 : bin_to_nat (Twice (STwice Z)) = 2.
Proof. reflexivity. Qed.
Example test_bin_to_nat4 : bin_to_nat (STwice (STwice Z)) = 3.
Proof. reflexivity. Qed.


(**

  Binary strategy, according to Bergeron, Brlek et al.

  Let $n>3$ be a positive number. We associate to $n$ the half of $n$.
*)

Require Import Arith NArith Pow Compatibility More_on_positive Lia.
Require Export Strategies.

Open Scope positive_scope.

(* begin snippet BinaryStrats:: no-out *)
Definition half (p:positive) :=
  match p with xH => xH
          |    xI q | xO q =>  q
  end.

Definition two (p:positive) := 2%positive.

#[ global ] Instance Binary_strat : Strategy half.
Proof.
  split; destruct p; unfold half; try lia.
Qed.

#[ global ] Instance Two_strat : Strategy two.
Proof.
  split;unfold two; lia.
Qed.
(* end snippet BinaryStrats *)


(** Computing least fixed points, following the Knaster-Tarski theorem. *)

From Coq Require Import Extraction ExtrOcamlBasic.

Section KNASTER_TARSKI.

(** Consider a type [A] equipped with a decidable equality [eq] and a
    transitive ordering [le]. *)

Variable A: Type.

Variable eq: A -> A -> Prop.
Variable eq_dec: forall (x y: A), {eq x y} + {~eq x y}.

Variable le: A -> A -> Prop.
Hypothesis le_trans: forall x y z, le x y -> le y z -> le x z.
Hypothesis eq_le: forall x y, eq x y -> le y x.

(** This is the strict order induced by [le].  We assume it is well-founded:
    all strictly ascending chains are finite. *)

Definition gt (x y: A) := le y x /\ ~eq y x.

Hypothesis gt_wf: well_founded gt.

(** Let [bot] be a smallest element of [A]. *)

Variable bot: A.
Hypothesis bot_smallest: forall x, le bot x.

Section FIXPOINT.

(** Let [F] be a monotonically increasing function from [A] to [A]. *)

Variable F: A -> A.
Hypothesis F_mon: forall x y, le x y -> le (F x) (F y).

Lemma iterate_acc:
  forall (x: A) (acc: Acc gt x) (PRE: le x (F x)) (NEQ: ~eq x (F x)), Acc gt (F x).
Proof.
  intros. apply Acc_inv with x; auto. split; auto.
Defined.

Lemma iterate_le:
  forall (x: A) (PRE: le x (F x)), le (F x) (F (F x)).
Proof.
  intros. apply F_mon. apply PRE.
Qed.

(** We iterate [F] starting from a pre-fixed-point [x], that is, an [x]
    such that [le x (F x)].  This is a structural recursion over a derivation
    of accessibility [Acc gt x] of [x], that is, over the proof that
    all strictly increasing sequences starting from [x] are finite.
    This guarantees that the iteration always terminates! *)

Fixpoint iterate (x: A) (acc: Acc gt x) (PRE: le x (F x)) {struct acc}: A :=
  let x' := F x in
  match eq_dec x x' with
  | left E => x
  | right NE => iterate x' (iterate_acc x acc PRE NE) (iterate_le x PRE)
  end.

(** The fixed point is obtained by iterating from [bot]. *)

Definition fixpoint : A := iterate bot (gt_wf bot) (bot_smallest (F bot)).

(** It is solution to the fixed point equation. *)

Lemma fixpoint_eq: eq fixpoint (F fixpoint).
Proof.
  assert (REC: forall x acc PRE, eq (iterate x acc PRE) (F (iterate x acc PRE))).
  { induction x using (well_founded_induction gt_wf). intros. destruct acc; cbn.
    destruct (eq_dec x (F x)).
    - auto.
    - apply H. split; auto.
  }
  apply REC.
Qed.

(** It is the smallest post-fixed point. *)

Lemma fixpoint_smallest: forall z, le (F z) z -> le fixpoint z.
Proof.
  intros z LEz.
  assert (REC: forall x acc PRE, le x z -> le (iterate x acc PRE) z).
  { induction x using (well_founded_induction gt_wf). intros. destruct acc; cbn.
    destruct (eq_dec x (F x)).
    - auto.
    - apply H. split; auto.
      apply le_trans with (F z). apply F_mon; auto. apply LEz.
  }
  apply REC. apply bot_smallest.
Qed.

End FIXPOINT.

(** If a function [F] is pointwise below another function [G],
    the fixed point of [F] is below that of [G]. *)

Section FIXPOINT_MON.

Variable F: A -> A.
Hypothesis F_mon: forall x y, le x y -> le (F x) (F y).
Variable G: A -> A.
Hypothesis G_mon: forall x y, le x y -> le (G x) (G y).
Hypothesis F_le_G: forall x, le (F x) (G x).

Theorem fixpoint_mon: le (fixpoint F F_mon) (fixpoint G G_mon).
Proof.
  apply fixpoint_smallest.
  eapply le_trans. apply F_le_G. apply eq_le. apply fixpoint_eq.
Qed.

End FIXPOINT_MON.

End KNASTER_TARSKI.

(** Let's ask Coq to extract OCaml executable code from the definition of
    [fixpoint], we see that the arguments [acc] and[PRE] disappear,
    because their only purpose is to prove termination.
    The extracted OCaml code is exactly the code we would have written
    by hand! *)

Recursive Extraction fixpoint.

(** Result:
<<
(** val iterate : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)

let rec iterate eq_dec f x =
  let x' = f x in if eq_dec x x' then x else iterate eq_dec f x'

(** val fixpoint : ('a1 -> 'a1 -> bool) -> 'a1 -> ('a1 -> 'a1) -> 'a1 **)

let fixpoint eq_dec bot f =
  iterate eq_dec f bot
>>
*)


Require Export Lists.
Require Export Basics.

Inductive boollist : Type :=
| bool_nil : boollist
| bool_cons : bool -> boollist -> boollist.

Inductive list (X:Type) : Type :=
| nil : list X
| cons : X -> list X -> list X.

Check nil.
Check cons.

Check (cons nat 2 (cons nat 1 (nil nat))).

Fixpoint length (X:Type) (l:list X) : nat :=
  match l with
  | nil => 0
  | cons h t => S (length X t)
end.

Example test_length1 :
  length nat (cons nat 1 (cons nat 2 (nil nat))) = 2.
Proof. reflexivity. Qed.

Example test_length2 :
  length bool (cons bool true (nil bool)) = 1.
Proof. reflexivity. Qed.

Fixpoint app (X : Type) (l1 l2 : list X) : (list X) :=
  match l1 with
  | nil => l2
  | cons h t => cons X h (app X t l2)
end.

Fixpoint snoc (X:Type) (l:list X) (v:X) : (list X) :=
  match l with
  | nil => cons X v (nil X)
  | cons h t => cons X h (snoc X t v)
end.

Fixpoint rev (X:Type) (l:list X) : list X :=
  match l with
  | nil => nil X
  | cons h t =>snoc X (rev X t) h
end.

Example test_rev1 :
  rev nat (cons nat 1 (cons nat 2 (nil nat)))
  = (cons nat 2 (cons nat 1 (nil nat))).
Proof. reflexivity. Qed.

Example test_rev2 :
  rev bool (nil bool) = nil bool.
Proof. reflexivity. Qed.

Fixpoint app' X l1 l2 : list X :=
  match l1 with
  | nil => l2
  | cons h t => cons X h (app' X t l2)
end.

Check app'.
Check app.

Fixpoint length' (X:Type) (l:list X) : nat :=
  match l with
  | nil => 0
  | cons h t => S (length' _ t)
end.

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil nat))).

Implicit Arguments nil [[X]].
Implicit Arguments cons [[X]].
Implicit Arguments length [[X]].
Implicit Arguments app [[X]].
Implicit Arguments rev [[X]].
Implicit Arguments snoc [[X]].

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).
Check (length list123'').

(* 暗黙の引数*)
Fixpoint length'' {X:Type} (l:list X) : nat :=
  match l with
  | nil => 0
  | cons h t => S (length'' t)
end.

Definition mynil : list nat := nil.

Check @nil.

Definition mynil' := @nil nat.

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

Definition list123''' := [1,2,3].

Fixpoint repeat (X:Type) (n : X) (count : nat) : list X :=
  match count with
  | O => nil
  | S count' => cons n (repeat X n count')
end.

Example test_repeat1:
  repeat bool true 2 = cons true (cons true nil).
Proof. reflexivity. Qed.

Theorem nil_app : forall X:Type, forall l:list X,
      app [] l = l.
Proof. simpl. reflexivity. Qed.

Theorem rev_snoc : forall X : Type,
    forall v : X,
    forall s : list X,
      rev (snoc s v) = v :: (rev s).
Proof.
  intros. induction s as [| v' s'].
  Case "s = nil".
    simpl. reflexivity.
  Case "s = v' :: s'".
    simpl. rewrite -> IHs'. simpl. reflexivity.
Qed.

Theorem snoc_with_append :
  forall X : Type,
  forall l1 l2 : list X,
  forall v : X,
    snoc (l1 ++ l2) v = l1 ++ (snoc l2 v).
Proof.
  intros. induction l1 as [| v' l1'].
  Case "l1 = nil".
    simpl. reflexivity.
  Case "l1 = v' l1'".
    simpl. rewrite -> IHl1'. reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
  pair : X -> Y -> prod X Y.

Implicit Arguments pair [[X][Y]].

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y: Type} (p : X*Y) : X :=
  match p with (x,y) => x end.

Definition snd {X Y: Type} (p : X*Y) : Y :=
  match p with (x,y) => y end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y) : list (X*Y) :=
  match (lx,ly) with
  | ([],_) => []
  | (_,[]) => []
  | (x::tx, y::ty) => (x,y) :: (combine tx ty)
end.

Fixpoint combine' {X Y : Type} (lx : list X) (ly : list Y) : list (X*Y) :=
  match lx, ly with
  | [],_ => []
  | _,[] => []
  | x::tx, y::ty => (x,y) :: (combine' tx ty)
end.

Check @combine.

Eval simpl in (combine [1,2] [false, false, true, true]).

Fixpoint split {X Y : Type} (l : list (X*Y)) : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | h :: t =>
    match h with
    | (x,y) =>
      (x :: fst (split t), y :: snd (split t))
    end
  end
.

Example test_split: split [(1,false), (2,false)] = ([1,2],[false,false]).
Proof. reflexivity. Qed.

Inductive option (X : Type) : Type :=
| some : X -> option X
| none : option X.

Implicit Arguments some [[X]].
Implicit Arguments none [[X]].

Fixpoint index {X : Type} (n : nat) (l : list X) : option X :=
  match l with
  | [] => none
  | a :: l' => if beq_nat n O then some a else index (pred n) l'
end.
Example test_index1 : index 0 [4,5,6,7] = some 4.
Proof. reflexivity. Qed.
Example test_index2 : index 1 [[1],[2]] = some [2].
Proof. reflexivity. Qed.
Example test_index3 : index 2 [true] = none.
Proof. reflexivity. Qed.

Definition hd_opt {X : Type} (l : list X) : option X :=
  match l with
  | [] => none
  | h :: _ => some h
end.

Check @hd_opt.

Example test_hd_opt1 : hd_opt [1,2] = some 1.
Proof. reflexivity. Qed.
Example test_hd_opt2 : hd_opt [[1],[2]] = some [1].
Proof. reflexivity. Qed.

Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
  f (f (f n)).

Check @doit3times.

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity. Qed.
Example test_doit3times': doit3times negb true = false.
Proof. reflexivity. Qed.

Check plus.

Definition plus3 := plus 3.
Check plus3.

Example test_plus3: plus3 4 = 7.
Proof. reflexivity. Qed.
Example test_plus3': doit3times plus3 0 = 9.
Proof. reflexivity. Qed.
Example test_plus3'': doit3times (plus 3) 0 = 9.
Proof. reflexivity. Qed.

Definition prod_curry {X Y Z : Type}
           (f : X * Y -> Z) (x:X) (y:Y) : Z := f (x, y).

Definition prod_uncurry {X Y Z : Type}
           (f : X -> Y -> Z) (p : X * Y) : Z :=
  match p with (x,y) => (f x) y end.

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type) (f : X -> Y -> Z) x y,
    prod_curry (prod_uncurry f) x y = f x y.
Proof. intros. compute. reflexivity. Qed.

Theorem curry_uncurry : forall (X Y Z : Type) (f : (X * Y) -> Z) (p : X * Y),
    prod_uncurry (prod_curry f) p = f p.
Proof. intros. destruct p. compute. reflexivity. Qed.

Fixpoint filter {X:Type} (test : X -> bool) (l:list X) : list X :=
  match l with
  | [] => []
  | h :: t => if test h then h :: (filter test t) else filter test t
end.

Example test_filter1: filter evenb [1,2,3,4] = [2,4].
Proof. reflexivity. Qed.

Definition length_is_1 {X:Type} (l: list X) : bool :=
  beq_nat (length l) 1.

Example test_filter2: filter length_is_1 [[1,2], [3], [4], [5,6,7], [], [8]] = [[3], [4], [8]].
Proof. reflexivity. Qed.

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1: countoddmembers' [1,0,3,1,4,5] = 4.
Proof. reflexivity. Qed.
Example test_countoddmembers'2: countoddmembers' [0,2,4] = 0.
Proof. reflexivity. Qed.
Example test_countoddmembers'3: countoddmembers' nil = 0.
Proof. reflexivity. Qed.

Example test_anon_fun': doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity. Qed.

Example test_filter2':
  filter (fun l => beq_nat (length l) 1)
         [[1,2], [3], [4], [5,6,7], [], [8]] = [[3], [4], [8]].
Proof. reflexivity. Qed.

Definition filter_even_gt7 (l:list nat) : list nat :=
  filter (fun n => andb (evenb n) (blt_nat 7 n)) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1,2,6,9,10,3,12,8] = [10,12,8].
Proof. reflexivity. Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5,2,6,19,129] = [].
Proof. reflexivity. Qed.

Definition partition {X:Type} (test : X -> bool) (l : list X) : list X * list X :=
  (filter test l, filter (fun x => negb (test x)) l).

Fixpoint partition' {X:Type} (test : X -> bool) (l : list X) : list X * list X :=
  match l with
  | [] => ([], [])
  | h :: t => let tmp := partition' test t
              in if test h
              then (h :: (fst tmp), snd tmp)
              else (fst tmp, h :: (snd tmp))
end.

Example test_partition1: partition' oddb [1,2,3,4,5] = ([1,3,5], [2,4]).
Proof. reflexivity. Qed.
Example test_partition2: partition' (fun x => false) [5,9,0] = ([], [5,9,0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y:Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map f t)
end.

Example test_map1 : map (plus 3) [2,0,2] = [5,3,5].
Proof. reflexivity. Qed.

Example test_map2 : map oddb [2,1,2,5] = [false, true, false, true].
Proof. reflexivity. Qed.

Example test_map3 :
  map (fun n => [evenb n, oddb n]) [2,1,2,5] = [[true,false], [false,true], [true,false], [false,true]].
Proof. reflexivity. Qed.

Theorem map_snoc : forall (X Y : Type) (f : X -> Y) (l : list X) (x : X),
    map f (snoc l x) = snoc (map f l) (f x).
Proof.
  intros. induction l as [| x' l'].
  Case "l = nil".
    simpl. reflexivity.
  Case "l = x' :: l'".
    simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
    map f (rev l) = rev (map f l).
Proof.
  intros. induction l as [| x l'].
  Case "l = nil".
    simpl. reflexivity.
  Case "l = x :: l'".
    simpl. rewrite -> map_snoc. rewrite -> IHl'. reflexivity.
Qed.

Fixpoint flat {X:Type} (ll:list (list X)): list X :=
  match ll with
  | [] => []
  | l :: tl =>
    match l with
    | [] => flat tl
    | _  => l ++ flat tl
    end
  end
.

Example test_flat1:
  flat [[1,1,1],[5,5,5],[4,4,4]]
  = [1, 1, 1, 5, 5, 5, 4, 4, 4].
Proof. reflexivity. Qed.
Example test_flat2:
  flat [[1], [], [2,3], [4,5]]
  = [1,2,3,4,5].
Proof. reflexivity. Qed.

Fixpoint flat_map {X Y:Type} (f: X -> list Y) (l:list X) : list Y :=
  match l with
  | [] => []
  | h :: t => (f h) ++ flat_map f t
end.

Example test_flat_map1:
  flat_map (fun n => [n,n,n]) [1,5,4]
  = [1, 1, 1, 5, 5, 5, 4, 4, 4].
Proof. reflexivity. Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X): option Y :=
  match xo with
  | none => none
  | some x => some (f x)
end.

(*以下のfilter'およびmap'は練習問題の解答*)
Fixpoint filter' (X:Type) (test : X -> bool) (l:list X) : list X :=
  match l with
  | [] => []
  | h :: t => if test h then h :: (filter' X test t) else filter' X test t
end.

Fixpoint map' (X Y:Type) (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map' X Y f t)
end.

Fixpoint fold {X Y:Type} (f: X->Y->Y) (l:list X) (b:Y) : Y :=
  match l with
  | [] => b
  | h :: t => f h (fold f t b)
end.

Check (fold plus).
Eval simpl in (fold plus [1,2,3,4] 0).

Example fold_example1: fold mult [1,2,3,4] 1 = 24.
Proof. reflexivity. Qed.
Example fold_example2: fold andb [true,true,false,true] true = false.
Proof. reflexivity. Qed.
Example fold_example3: fold app [[1],[],[2,3],[4]] [] = [1,2,3,4].
Proof. reflexivity. Qed.

Definition constfun {X:Type} (x:X) : nat->X :=
  fun (k:nat) => x.

Definition ftrue := constfun true.

Example constfun_example1: ftrue 0 = true.
Proof. reflexivity. Qed.
Example constfun_example2: (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

Definition override {X:Type} (f:nat->X) (k:nat) (x:X) : nat->X :=
  fun (k':nat) => if beq_nat k k' then x else f k'.

Definition fmostlytrue := override (override ftrue 1 false) 3 false.

Example override_example1 : fmostlytrue 0 = true.
Proof. reflexivity. Qed.
Example override_example2 : fmostlytrue 1 = false.
Proof. reflexivity. Qed.
Example override_example3 : fmostlytrue 2 = true.
Proof. reflexivity. Qed.
Example override_example4 : fmostlytrue 3 = false.
Proof. reflexivity. Qed.

Theorem override_example : forall (b:bool),
    (override (constfun b) 3 true) 2 = b.
Proof.
  intro. destruct b.
  Case "b = true". reflexivity.
  Case "b = false". reflexivity.
Qed.

Theorem unfold_example_bad : forall m n,
    3 + n = m -> plus3 n + 1 = m + 1.
Proof.
  intros m n H. (*Admitted.*)
  rewrite <- H. simpl. reflexivity.
Qed.

Theorem unfold_example : forall m n,
    3 + n = m -> plus3 n + 1 = m + 1.
Proof.
  intros m n H.
  unfold plus3.
  rewrite -> H.
  reflexivity.
Qed.

Theorem override_eq : forall {X:Type} x k (f:nat->X),
    (override f k x) k = x.
Proof.
  intros X x k f.
  unfold override.
  rewrite <- beq_nat_refl. reflexivity.
Qed.

Theorem override_neq : forall {X:Type} x1 x2 k1 k2 (f:nat->X),
    f k1 = x1 -> beq_nat k2 k1 = false -> (override f k2 x2) k1 = x1.
Proof.
  intros X x1 x2 k1 k2 f H I.
  unfold override.
  rewrite -> I. rewrite -> H.
  reflexivity.
Qed.

Theorem eq_add_s : forall (n m : nat),
    S n = S m -> n = m.
Proof.
  intros n m eq. inversion eq. reflexivity.
Qed.

Theorem silly4 : forall (n m : nat),
    [n] = [m] -> n = m.
Proof.
  intros n m eq. inversion eq. reflexivity.
Qed.

Theorem silly5 : forall (n m o : nat),
    [n,m] = [o,o] -> [n] = [m].
Proof.
  intros n m o eq. inversion eq. reflexivity.
Qed.

Example sillyex1: forall (X:Type) (x y z : X) (l j : list X),
    x :: y :: l = z :: j ->
    y :: l = x :: j ->
    x = y.
Proof.
  intros X x y z l j H G.
  inversion H. inversion G. rewrite -> H1. reflexivity.
Qed.

Theorem silly6 : forall (n : nat),
    S n = 0 -> 2 + 2 = 5.
Proof.
  intros n H. inversion H.
Qed.

Theorem silly7 : forall (n m : nat),
    false = true -> [n] = [m].
Proof.
  intros n m contra. inversion contra.
Qed.

Example sillyex2 : forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = [] ->
    y :: l = z :: j ->
    x = z.
Proof.
  intros X x y z l j eq1 eq2.
  inversion eq1.
Qed.

Lemma eq_remove_S : forall n m,
    n = m -> S n = S m.
Proof.  intros n m eq. rewrite -> eq. reflexivity. Qed.

Theorem beq_nat_eq : forall n m,
    true = beq_nat n m -> n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    intros m. destruct m as [| n'].
    SCase "m = 0". reflexivity.
    SCase "m = S m'". simpl. intros contra. inversion contra.
  Case "n = S n'".
    intros m. destruct m as [| m'].
    SCase "m = 0". simpl. intros contra. inversion contra.
    SCase "m = S m'". simpl. intros H.
      apply eq_remove_S. apply IHn'. apply H.
Qed.

Theorem beq_nat_eq' : forall m n,
    beq_nat n m = true -> n = m.
Proof.
  intros m. induction m as [| m'].
  Case "m = 0".
    intros n. induction n as [| n'].
    SCase "n = 0". simpl. reflexivity.
    SCase "n = S n'". simpl. intros contra. inversion contra.
  Case "m = S m'".
    intros n. induction n as [| n'].
    SCase "n = 0". simpl. intros contra. inversion contra.
    SCase "n = S n'". simpl.
      intros H. apply eq_remove_S. apply IHm'. apply H.
Qed.

Theorem length_snoc' : forall (X:Type) (v:X)
                              (l:list X) (n:nat),
    length l = n -> length (snoc l v) = S n.
Proof.
  intros X v l. induction l as [|v' l'].
  Case "l = []". intros n eq. rewrite <- eq. reflexivity.
  Case "l = v' :: l'". intros n eq. simpl.
    destruct n as [| n'].
    SCase "n = 0". inversion eq.
    SCase "n = S n'".
      apply eq_remove_S. apply IHl'. inversion eq. reflexivity.
Qed.

Theorem beq_nat_0_l : forall n,
    true = beq_nat 0 n -> 0 = n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". simpl. reflexivity.
  Case "n = S n'". simpl. intros contra. inversion contra.
Qed.

Theorem beq_nat_0_r : forall n,
    true = beq_nat n 0 -> 0 = n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". simpl. reflexivity.
  Case "n = S n'".
    simpl. intros contra. inversion contra.
Qed.

Theorem double_injective : forall n m,
    double n = double m -> n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". simpl. intros m eq. destruct m as [| m'].
    SCase "m = 0". reflexivity.
    SCase "m = S m'". inversion eq.
  Case "n = S n'". intros m eq. destruct m as [| m'].
    SCase "m = 0". inversion eq.
    SCase "m = S m'".
      apply eq_remove_S. apply IHn'. inversion eq. reflexivity.
Qed.

Theorem S_inj : forall (n m : nat) (b: bool),
    beq_nat (S n) (S m) = b ->
    beq_nat n m = b.
Proof.
  intros n m b H. simpl in H. apply H.
Qed.

Theorem silly3' : forall (n : nat),
    (beq_nat n 5 = true ->
    beq_nat (S (S n)) 7 = true) ->
    true = beq_nat n 5 ->
    true = beq_nat (S (S n)) 7.
Proof.
  intros n eq H.
  symmetry in H. apply eq in H. symmetry in H. apply H.
Qed.

Theorem plus_n_n_injective : forall n m,
    n + n = m + m ->
    n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    destruct m as [| m'].
    SCase "m = 0". reflexivity.
    SCase "m = S m'". intro H. inversion H.
  Case "n = S n'".
    destruct m as [| m'].
    SCase "m = 0". intro H. inversion H.
    SCase "m = S m'".
      intro H. (*この段階でdouble_plusとdouble_injectiveを使えばとけそう*)
      simpl in H.
      rewrite -> plus_comm in H. simpl in H. rewrite <- double_plus in H.
      rewrite -> plus_comm in H. simpl in H. rewrite <- double_plus in H.
      inversion H. apply double_injective in H1.
      rewrite -> H1. reflexivity.
Qed. (*ヌワンツ・カレタモ*)

Definition sillyfun (n : nat) : bool :=
  if beq_nat n 3 then false
  else if beq_nat n 5 then false
       else false.

Theorem sillyfun_false : forall (n : nat),
    sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (beq_nat n 3).
    Case "beq_nat n 3 = true". reflexivity.
    Case "beq_nat n 3 = false". destruct (beq_nat n 5).
      SCase "beq_nat n 5 = true". reflexivity.
      SCase "beq_nat n 5 = false". reflexivity.
Qed.

Theorem override_shadow : forall {X:Type} x1 x2 k1 k2 (f:nat->X),
    (override (override f k1 x2) k1 x1) k2 = (override f k1 x1) k2.
Proof.
  intros X x1 x2 k1 k2 f. unfold override.
  destruct (beq_nat k1 k2).
  Case "beq_nat k1 k2 = true". reflexivity.
  Case "beq_nat k1 k2 = false". reflexivity.
Qed.

(*combine_splitとsplit_combineは後でゆっくりやる*)

Definition sillyfun1 (n : nat) : bool :=
  if beq_nat n 3 then true
  else if beq_nat n 5 then true
       else false.

Theorem sillyfun1_odd_FAILED : forall (n : nat),
    sillyfun1 n = true ->
    oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  remember (beq_nat n 3) as e3.
  destruct e3.
  Case "e3 = true". apply beq_nat_eq in Heqe3.
    rewrite -> Heqe3. reflexivity.
  Case "e3 = false".
    remember (beq_nat n 5) as e5. destruct e5.
    SCase "e5 = true".
      apply beq_nat_eq in Heqe5.
      rewrite -> Heqe5. reflexivity.
    SCase "e5 = false". inversion eq.
Qed.

Theorem override_same : forall {X:Type} x1 k1 k2 (f : nat -> X),
    f k1 = x1 ->
    (override f k1 x1) k2 = f k2.
Proof.
  intros X x1 k1 k2 f eq. unfold override.
  remember (beq_nat k1 k2). destruct b.
  Case "b = true". apply beq_nat_eq in Heqb.
    rewrite <- Heqb. symmetry in eq. apply eq.
  Case "b = false". reflexivity.
Qed.

Example trans_eq_example : forall (a b c d e f : nat),
    [a,b] = [c,d] ->
    [c,d] = [e,f] ->
    [a,b] = [e,f].
Proof.
  intros a b c d e f eq1 eq2.
  rewrite -> eq1. rewrite -> eq2. reflexivity.
Qed.

Theorem trans_eq : forall {X:Type} (n m o : X),
    n = m -> m = o -> n = o.
Proof.
  intros X n m o eq1 eq2. rewrite -> eq1. rewrite -> eq2.
  reflexivity.
Qed.

Example trans_eq_example' : forall (a b c d e f : nat),
    [a,b] = [c,d] ->
    [c,d] = [e,f] ->
    [a,b] = [e,f].
Proof.
  intros a b c d e f eq1 eq2.
  apply trans_eq with (m:=[c,d]). apply eq1. apply eq2.
Qed.

Example trans_eq_exercise : forall (n m o p : nat),
    m = (minustwo o) ->
    (n + p) = m ->
    (n + p) = (minustwo o).
Proof.
  intros n m o p eq1 eq2.
  apply trans_eq with m. apply eq2. apply eq1.
Qed.

(*これ以上は意味不明 apply withの使い方がよくわからん*)
Theorem beq_nat_trans : forall n m p,
    true = beq_nat n m ->
    true = beq_nat m p ->
    true = beq_nat n p.
Proof.
  intros n m p eq1 eq2.
  apply beq_nat_eq in eq1. apply beq_nat_eq in eq2.
Admitted.

Definition fold_length {X:Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4,7,0] = 3.
Proof. reflexivity. Qed.

Theorem fold_length_correct : forall X (l : list X),
    fold_length l = length l.
Proof.
  induction l as [| x l'].
  Case "l = []". unfold fold_length. simpl. reflexivity.
  Case "l = x :: l'". simpl. rewrite <- IHl'.
  unfold fold_length. simpl. reflexivity.
Qed.

Definition fold_map {X Y:Type} (f:X->Y) (l:list X) : list Y :=
  fold (fun x ys => f x :: ys) l [].

Example fold_map_test1: fold_map (fun x => evenb x) [1,2,3,4] = map (fun x => evenb x) [1,2,3,4].
Proof. reflexivity. Qed.

Theorem fold_map_correct : forall {X Y:Type} (f:X->Y) l,
    fold_map f l = map f l.
Proof.
  induction l as [| x l'].
  Case "l = []". unfold fold_map. simpl. reflexivity.
  Case "l = x :: l'". simpl. rewrite <- IHl'.
    unfold fold_map. simpl. reflexivity.
Qed.

Module MumbleBaz.

Inductive mumble : Type :=
| a : mumble
| b : mumble -> nat -> mumble
| c : mumble.
Inductive grumble (X:Type) : Type :=
| d : mumble -> grumble X
| e : X -> grumble X.

Inductive baz : Type :=
| x : baz -> baz
| y : baz -> bool -> baz.

End MumbleBaz.

Fixpoint forallb {X:Type} (f:X->bool) (l:list X) : bool :=
  match l with
  | [] => true
  | h :: t => if f h
              then forallb f t
              else false
  end.

Fixpoint existsb {X:Type} (f:X->bool) (l:list X) : bool :=
  match l with
  | [] => false
  | h :: t => if f h
              then true
              else existsb f t
  end.

Definition existsb' {X:Type} (f:X->bool) (l:list X) : bool :=
  negb (forallb (fun x => negb (f x)) l).

Theorem existsb'_correct : forall {X:Type} (f:X->bool) l,
    existsb' f l = existsb f l.
Proof.
  intros. induction l as [| x l'].
  Case "l = []". unfold existsb'. simpl. reflexivity.
  Case "l = x :: l'". unfold existsb'. simpl.
    destruct (f x).
    SCase "f x = true". simpl. reflexivity.
    SCase "f x = false". simpl. rewrite <- IHl'.
      unfold existsb'. reflexivity.
Qed.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_betweennotequal.

Section Euclid.

Context `{Ax:euclidean_neutral}.

Lemma lemma_onray_neq_A_B :
	forall A B C,
	OnRay A B C ->
	neq A B.
Proof.
	intros A B C.
	intros OnRay_AB_C.

	destruct OnRay_AB_C as (J & _ & BetS_J_A_B).

	pose proof (lemma_betweennotequal _ _ _ BetS_J_A_B) as (neq_A_B & _).

	exact neq_A_B.
Qed.

End Euclid.


Module AExp.

Inductive aexp : Type :=
 | ANum   : nat -> aexp
 | APlus  : aexp -> aexp -> aexp
 | AMinus : aexp -> aexp -> aexp
 | AMult  : aexp -> aexp -> aexp.

Inductive bexp : Type :=
 | BTrue  : bexp
 | BFalse : bexp
 | BEq    : aexp -> aexp -> bexp
 | BLe    : aexp -> aexp -> bexp
 | BNot   : bexp -> bexp
 | BAnd   : bexp -> bexp -> bexp.

Fixpoint aeval (a : aexp) : nat :=
 match a with
 | ANum n => n
 | APlus a1 a2 => (aeval a1) + (aeval a2)
 | AMinus a1 a2 => (aeval a1) - (aeval a2)
 | AMult a1 a2 => (aeval a1) * (aeval a2)
end.

Notation beq_nat := Nat.eqb (compat "8.4").

Notation leb := Nat.leb (compat "8.4").

Fixpoint beval (b : bexp) : bool :=
 match b with
 | BTrue => true
 | BFalse => false
 | BEq a1 a2 => beq_nat (aeval a1) (aeval a2)
 | BLe a1 a2 => leb (aeval a1) (aeval a2)
 | BNot b1 => negb (beval b1)
 | BAnd b1 b2 => andb (beval b1) (beval b2)
end.

Fixpoint optimize_0plus (a:aexp) : aexp :=
  match a with
  | ANum n =>
      ANum n
  | APlus (ANum 0) e2 =>
      optimize_0plus e2
  | APlus e1 e2 =>
      APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2 =>
      AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2 =>
      AMult (optimize_0plus e1) (optimize_0plus e2)
  end.

Theorem optimize_0plus_sound: forall a, aeval (optimize_0plus a) = aeval a.
Proof.
intros a.
induction a.
simpl.
reflexivity.
destruct a1.
destruct n.
simpl.
apply IHa2.
simpl.
rewrite IHa2.
simpl.
reflexivity.
simpl.
simpl in IHa1.
rewrite IHa1.
rewrite IHa2.
reflexivity.
simpl.
simpl in IHa1.
rewrite IHa1.
rewrite IHa2.
reflexivity.
simpl.
simpl in IHa1.
rewrite IHa1.
rewrite IHa2.
reflexivity.
simpl.
rewrite IHa1.
rewrite IHa2.
reflexivity.
simpl.
rewrite IHa1.
rewrite IHa2.
reflexivity.
Qed.

Theorem silly1 : forall ae, aeval ae = aeval ae.
Proof.
try reflexivity.
Qed.

Theorem silly2 : forall(P : Prop), P -> P.
Proof.
intros P HP.
try reflexivity.
apply HP.
Qed.

Lemma foo : forall n, leb 0 n = true.
Proof.
intros.
destruct n;
simpl;
reflexivity.
Qed.

Theorem optimize_0plus_sound': forall a, aeval (optimize_0plus a) = aeval a.
Proof.
intros a.
induction a;
try (simpl; rewrite IHa1; rewrite IHa2; reflexivity).
reflexivity.
destruct a1;
try (simpl; simpl in IHa1; rewrite IHa1; rewrite IHa2; reflexivity).
destruct n;
      simpl; rewrite IHa2; reflexivity.
Qed.

(*General form of ; : T; [T1 | T2 | ... | Tn]*)

Fixpoint optimize_0plus_b (b : bexp) : bexp :=
  match b with
   | BTrue => BTrue
   | BFalse => BFalse
   | BEq a1 a2 => BEq (optimize_0plus a1) (optimize_0plus a2)
   | BLe a1 a2 => BLe (optimize_0plus a1) (optimize_0plus a2)
   | BNot b1 => BNot (optimize_0plus_b b1)
   | BAnd b1 b2 => BAnd (optimize_0plus_b b1) (optimize_0plus_b b2)
  end.

Theorem optimize_0plus_b_sound:
  forall e, beval (optimize_0plus_b e) = beval e.
Proof.
intro e.
  induction e;
    try reflexivity;
    try (simpl; rewrite 2 optimize_0plus_sound; reflexivity).
    simpl. rewrite IHe. reflexivity.
    simpl. rewrite IHe1. rewrite IHe2. reflexivity.
Qed.

Require Import Coq.omega.Omega.

Module aevalR_first_try.

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum : forall (n: nat),
      aevalR (ANum n) n
  | E_APlus : forall (e1 e2: aexp) (n1 n2: nat),
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (APlus e1 e2) (n1 + n2)
  | E_AMinus: forall(e1 e2: aexp) (n1 n2: nat),
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (AMinus e1 e2) (n1 - n2)
  | E_AMult : forall (e1 e2: aexp) (n1 n2: nat),
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (AMult e1 e2) (n1 * n2).


Require Import Setoid.

Set Implicit Arguments.

(** * Module [Lattice]  *)
Module Lattice.
  (** A set is a lattice if it has a meet and a join following the standard
     lattice equations. *)
  Record t (A: Type) := New {
    Meet: A -> A -> A;
    Join: A -> A -> A;

    MeetIdempotent: forall a, Meet a a = a;
    MeetCommutative: forall a b, Meet a b = Meet b a;
    MeetAssociative: forall a b c, Meet (Meet a b) c = Meet a (Meet b c);
    MeetAbsorptive: forall a b, Meet a (Join a b) = a;

    JoinIdempotent: forall a, Join a a = a;
    JoinCommutative: forall a b, Join a b = Join b a;
    JoinAssociative: forall a b c, Join (Join a b) c = Join a (Join b c);
    JoinAbsorptive: forall a b, Join a (Meet a b) = a}.

  (** Implicit parameters used for most of the developments. *)
  Module Type Param.
    (** The current set. *)
    Parameter A: Type.

    (** The current lattice description. *)
    Parameter Lattice: t A.
  End Param.

  Module Instance (P: Param).
    Import P.

    Module Definitions.
      (** Orderering relation: less or equal. *)
      Definition Le a b := Meet Lattice a b = a.
    End Definitions.
    Import Definitions.

    Module Notations.
      Infix "/*\" := (Meet P.Lattice)
        (at level 40, left associativity): lattice_scope.
      Infix "\*/" := (Join P.Lattice)
        (at level 50, left associativity): lattice_scope.
      Infix "<=" := Le : lattice_scope.
    End Notations.
    Import Notations.
    Local Open Scope lattice_scope.

    (** ** Lemmas about lattices. *)
    Module Facts.
      (** *** [a <= b] is an order. *)
      Lemma LeReflexive: forall a, a <= a.
        apply MeetIdempotent.
      Qed.

      Lemma LeAntiSymmetric: forall a b,
        a <= b -> b <= a -> a = b.
        intros a b Ha Hb.
        unfold Le in Hb.
        rewrite MeetCommutative in Hb.
        congruence.
      Qed.

      Lemma LeTransitive: forall a b c,
        a <= b -> b <= c -> a <= c.
        intros a b c Hab Hbc.
        unfold Le in *.
        rewrite <- Hab at 2.
        rewrite <- Hbc.
        rewrite <- MeetAssociative.
        congruence.
      Qed.

      (** *** Some properties relating the ordering and the lattice operators. *)
      Lemma MeetJoinEq: forall a b,
        a /*\ b = a <-> a \*/ b = b.
        split; intro H; rewrite <- H.
          rewrite JoinCommutative.
          rewrite MeetCommutative.
          rewrite JoinAbsorptive.
          reflexivity.
          rewrite MeetAbsorptive.
          reflexivity.
      Qed.

      Lemma ConsistentMeet: forall a b,
        a <= b <-> a /*\ b = a.
        tauto.
      Qed.

      Lemma ConsistentJoin: forall a b,
        a <= b <-> a \*/ b = b.
        intros a b.
        rewrite <- MeetJoinEq.
        apply ConsistentMeet.
      Qed.

      Lemma MeetLeLeft : forall a b, a /*\ b <= a.
        intros a b.
        rewrite ConsistentMeet.
        rewrite MeetCommutative.
        rewrite <- MeetAssociative.
        now rewrite MeetIdempotent.
      Qed.

      Lemma MeetLeRight : forall a b, a /*\ b <= b.
        intros a b.
        rewrite ConsistentMeet.
        rewrite MeetAssociative.
        now rewrite MeetIdempotent.
      Qed.

      Lemma JoinLeLeft : forall a b, a <= a \*/ b.
        intros a b.
        rewrite ConsistentJoin.
        rewrite <- JoinAssociative.
        now rewrite JoinIdempotent.
      Qed.

      Lemma JoinLeRight : forall a b, b <= a \*/ b.
        intros a b.
        rewrite ConsistentJoin.
        rewrite JoinCommutative.
        rewrite JoinAssociative.
        now rewrite JoinIdempotent.
      Qed.

      Lemma CompareToMeetRight: forall u a b,
        u <= a -> u <= b -> u <= a /*\ b.
        intros u a b Ha Hb.
        rewrite <- (proj1 (ConsistentMeet u b)); trivial.
        rewrite <- (proj1 (ConsistentMeet u a)); trivial.
        rewrite MeetAssociative.
        apply MeetLeRight.
      Qed.

      Lemma CompareToMeetLeft: forall u a b,
        a <= u \/ b <= u -> a /*\ b <= u.
        intros u a b [Ha | Hb].
          apply LeTransitive with (b := a); trivial.
          apply MeetLeLeft.

          apply LeTransitive with (b := b); trivial.
          apply MeetLeRight.
      Qed.

      Lemma CompareToJoinLeft: forall u a b,
        a <= u -> b <= u -> a \*/ b <= u.
        intros u a b Ha Hb.
        rewrite <- (proj1 (ConsistentJoin a u)); trivial.
        rewrite <- (proj1 (ConsistentJoin b u)); trivial.
        rewrite <- JoinAssociative.
        apply JoinLeLeft.
      Qed.

      Lemma CompareToJoinRight: forall u a b,
        u <= a \/ u <= b -> u <= a \*/ b.
        intros u a b [Ha | Hb].
          apply LeTransitive with (b := a); trivial.
          apply JoinLeLeft.

          apply LeTransitive with (b := b); trivial.
          apply JoinLeRight.
      Qed.
    End Facts.
  End Instance.
End Lattice.


From Coq Require Import Arith.

Theorem injection_example_1: forall (a b c : nat),
  a = S b -> a = S c -> b = c.
Proof.
  intros. rewrite H0 in H.
  injection H as H.
  rewrite H.
  reflexivity.
Qed.


(** * Logic: Logic in Coq *)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".

Set Implicit Arguments.

Require Import Lia.

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

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

Compute sum 100.

Theorem sum_calc: forall n: nat, 2 * sum n = n * (n+1).
Proof.
  induction n.
  - simpl. auto.
  - simpl. nia.
Qed.

Print sum_calc.

Check (eq_refl: 1 + 1 = 2).

Theorem one_plus_one_is_two: 1 + 1 = 2.
Proof.
  auto.
Qed.

Print one_plus_one_is_two.

(***
    Curry-Howard Isomorphism
 ***)

Inductive and (P Q : Type) : Type :=
| conj (p: P) (q: Q)
.

Notation "A /\ B" := (and A B) : type_scope.

Inductive or (P Q : Type) : Type :=
| or_introl (p: P)
| or_intror (q: Q)
.

Notation "A \/ B" := (or A B) : type_scope.

Inductive False : Type :=
.

Inductive True : Type :=
| I
.

Check (forall P Q : Type, P /\ Q -> P).

Definition pq_imp_p (P Q : Type) (pq: P /\ Q) : P :=
  match pq with
  | conj p q => p
  end.

Check pq_imp_p.

Check ((forall P Q, P -> P /\ Q) -> False).

Definition p_imp_pq_absurd (f: forall P Q, P -> P /\ Q) : False :=
  match (@f True False (I: True)) with
  | conj p q => q
  end.

Check p_imp_pq_absurd.

(**
  Constructive Math vs. Classical Math
 **)

Definition EXM_imp_DNN (EXM: forall Q: Type, Q \/ (Q -> False))
           (P: Type) (NNP: ((P -> False) -> False)) : P
  :=
    match EXM P with
    | or_introl _ Ppf => Ppf
    | or_intror _ NPpf => match NNP NPpf with
                          end
    end.

Check EXM_imp_DNN.

(**
  Dependent Types
 **)

Inductive List (T: Type) : Type :=
| nil
| cons (hd: T) (tl: List T)
.
Arguments nil {T}.

(*
List T: the set of lists of elements of T.

VecN n: the set of lists of natural numbers of length n

List: Type -> Type
VecN: Nat -> Type
*)

Inductive VecN : nat -> Type :=
| vnil : VecN 0
| vcons (hd: nat) (n: nat) (tl: VecN n) : VecN (S n)
.

Check (vnil).
Check (vcons 3 (vcons 2 vnil)).
Check (vcons 1 (vcons 2 (vcons 3 vnil))).

  (* List Nat -> Nat *)    (* forall _:List Nat, Nat *)

  (*  (n:nat) -> VecN n *) (* forall n: nat, VecN n *)
  (*  nat -> List nat *)

Inductive eq: forall A: Type, A -> A -> Type :=
| eq_refl A (x: A) : eq x x
.

Notation "x = y" := (eq x y) (at level 70) : type_scope.

Check (eq_refl (cons 3 nil)).

(*
Fixpoint plus (x y: nat) : nat :=
  match x with
  | 0 => y
  | S x0 => S (plus x0 y)
  end.
 *)

Fixpoint proof_of_false (n:nat) : nat :=
  match n with
  | 0 => 0
  | S n0 => proof_of_false n0
  end.

(*
x^0 + x^1 + x^2 + ...  : [0,1] -> [0,1]

nat -> A

eq_refl 2 : 2 = 2
eq_refl (1+1) : 1+1 = 1+1

eq_refl 2 : 2 = 2
*)

Definition eq_rec_r: forall (A : Type) (x : A) (y : A) (EQ: x = y) (P : A -> Type), P y -> P x :=
  fun A x y EQ => match EQ with
                  | eq_refl z => (fun P PF => PF)
                  end.

Print eq_rec_r.

Fixpoint nat_rec_r (P: nat -> Type) (BASE: P 0) (IND: forall m, P m -> P (S m)) (n: nat) : P n :=
  match n with
  | 0 => BASE
  | S m => IND m (nat_rec_r P BASE IND m)
  end.

Fixpoint foo (n: nat) : 1+n = n+1 :=
  match n with
  | 0 => eq_refl 1
  | S n0 => eq_rec_r (foo n0) (fun z => S z = S _) (eq_refl _)
  end.

Check (forall n: nat, 1 + n = n + 1).

Definition eq_x_plus_Sy: forall x y, x + S y = S (x + y) :=
  fun x y =>
  nat_rec_r (fun x => x + S y = S (x + y))
            (eq_refl _)
            (fun x0 PF => eq_rec_r PF (fun z => S z = _) (eq_refl _))
            x.

(*
  Existential Quantification
*)

Inductive ex (A : Type) (P : A -> Type) : Type :=
| ex_intro (a : A) (pf: P a) : ex P
.

Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'exists' '/ ' x .. y , '/ ' p ']'")
                                  : type_scope.

Definition even_exists: forall n, exists m, m = n + n :=
  fun n => ex_intro _ (n+n) (eq_refl (n+n)).

Definition case_nat: forall n, n = 0 \/ exists m, n = S m :=
  fun n =>
  match n with
  | 0 => or_introl _ (eq_refl 0)
  | S n0 => or_intror _ (ex_intro _ n0 (eq_refl (S n0)))
  end.

(*
Choice (exists f: nat -> nat, P f) : nat->nat
forall f g: nat -> nat, P f -> P g -> forall n, f n = g n.
 *)


Fixpoint factorial (n:nat) : nat :=
  match n with
  | O => S O
  | S n => mult (S n) (factorial n)
  end.

Example test_factorial1: (factorial 3) = 6.
Proof. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. reflexivity. Qed.