(**************************************************************************
* TLC: A library for Coq                                                  *
* Examples for other tactics provided by TLC                              *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics.
From TLC Require Import LibLogic LibEqual LibList LibRelation LibWf LibList LibLN.

(* ---------------------------------------------------------------------- *)
(** ** Demo of extens tactics *)

Lemma test_extensionality_1 : forall A1 (P Q :  A1->Prop),
  (forall x1, P x1 <-> Q x1) ->
  P = Q.
Proof using.
  intros. applys extensionality. hnf.
Abort.

Lemma test_extensionality_2 : forall A1 (A2: A1->Type) (P Q : forall (x1:A1) (x2:A2 x1), Prop),
  (forall x1 x2, P x1 x2 <-> Q x1 x2) ->
  P = Q.
  intros. applys extensionality. hnf.
Abort.

Section FuncExtDepTest.
Variables (A1 : Type).
Variables (A2 : forall (x1 : A1), Type).
Variables (A3 : forall (x1 : A1) (x2 : A2 x1), Type).
Variables (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type).

Lemma test_fun_ext_3 : forall (f g : forall (x1:A1) (x2:A2 x1) (x3:A3 x2), A4 x3),
  (forall x1 x2 x3, f x1 x2 x3 = g x1 x2 x3) ->
  f = g.
Proof using. intros. applys extensionality. hnf. Abort.

End FuncExtDepTest.

Lemma prop_ext_1_test : forall (P Q : Prop),
  (P <-> Q) ->
  P = Q.
Proof using.
  intros. applys extensionality. simpl extensionality_hyp.
Abort.

(* ---------------------------------------------------------------------- *)
(** ** Demo of LibLogic tactics *)
Lemma absurds_demo : forall (P Q : Prop),
  P /\ (~ P) /\ (Q \/ ~ P).
Proof using.
  intros. splits.
  { absurds ;=> H. admit. }
  { absurds ;=> H. admit. }
  { absurds ;=> (H1&H2). admit. }
Abort.

(* ********************************************************************** *)
(** * How to do recursion/induction on terms with list of subterms *)

Module SubtermIndDemos.

Import LibLogic LibList.

(** Definition of trees with list of subtrees *)

Inductive tree : Type :=
  | leaf : nat -> tree
  | node : list tree -> tree.

(** Example of a primitive-recursive function on trees
    using an inlined fixed point -- not recommended *)

Fixpoint tree_incr' (t:tree) :=
  match t with
  | leaf n => leaf (S n)
  | node ts =>
     node ((fix aux ts := match ts with
            | nil => nil
            | t::ts' => tree_incr' t :: aux ts'
            end) ts)
  end.

(** Same example but using the map function on lists
    -- recommended
    -- this works only because List.map has exactly
    the same form as the local [fix] used above.
    -- if you wanted to use LibList.map instead of
    List.map, it would not work; you would have to
    either use the optimal fixed point (see LibFixDemos)
    or you would have to exploit [List.map = LibList.map] *)

Fixpoint tree_incr (t:tree) :=
  match t with
  | leaf n => leaf (S n)
  | node ts => node (List.map tree_incr ts)
  end.

(** Another example -- recommended *)

Fixpoint tree_map (f:nat->nat) (t:tree) :=
  match t with
  | leaf n => leaf (f n)
  | node ts => node (List.map (tree_map f) ts)
  end.

(** Another example using List.fold -- recommended *)

Fixpoint tree_sum (t:tree) :=
  match t with
  | leaf n => n
  | node ts => List.fold_left (fun acc t => acc + tree_sum t) ts 0
  end.

(** Proof of the recursion principle *)

Section Tree_induct.
(* Note: some hypotheses are given directly by [Check tree_ind] *)
Variables
(P : tree -> Prop)
(Q : list tree -> Prop)
(P1 : forall n, P (leaf n))
(P2 : forall ts, Q ts -> P (node ts))
(Q1 : Q nil)
(Q2 : forall t ts, P t -> Q ts -> Q (t::ts)).

Fixpoint tree_induct_gen (t : tree) : P t :=
  match t as x return P x with
  | leaf n => P1 n
  | node ts => P2
      ((fix tree_list_induct (ts:list tree) : Q ts :=
      match ts as x return Q x with
      | nil   => Q1
      | t::ts' => Q2 (tree_induct_gen t) (tree_list_induct ts')
      end) ts)
  end.

End Tree_induct.

(** Example of a direct inductive proof -- not recommended *)

Lemma tree_map_pred_succ_1 : forall t,
  tree_map pred (tree_map S t) = t.
Proof using.
  intros. pattern t. match goal with |- ?F _ => sets P: F end.
  eapply tree_induct_gen with (Q := Forall P); subst P; simpl; intros.
  fequals.
  fequals. induction ts; simpl.
    fequals.
    inverts H. fequals~.
  constructors.
  constructors~.
Qed.

(** Proof of the induction principle with Forall *)

Lemma tree_induct_forall : forall (P : tree -> Prop),
  (forall n : nat, P (leaf n)) ->
  (forall ts : list tree, Forall P ts -> P (node ts)) ->
  forall t : tree, P t.
Proof using.
  introv Hl Hn. eapply tree_induct_gen with (Q := Forall P); intros.
  auto. auto. constructors~. constructors~.
Qed.

(** Example of an inductive proof with Forall
    -- recommended *)

Lemma tree_map_pred_succ_2 : forall t,
  tree_map pred (tree_map S t) = t.
Proof using.
  intros. induction t using tree_induct_forall; simpl.
  fequals.
  fequals. induction ts; simpl.
    auto.
    inverts H. fequals~.
Qed.

(** Proof of the induction principle with Mem *)

Lemma tree_induct_mem : forall (P : tree -> Prop),
  (forall n : nat, P (leaf n)) ->
  (forall ts : list tree,
    (forall t, mem t ts -> P t) -> P (node ts)) ->
  forall t : tree, P t.
Proof using.
  introv Hl Hn. eapply tree_induct_gen with (Q := fun ts =>
    forall t, mem t ts -> P t); intros.
  auto. auto. inverts H. inverts~ H1.
Qed.

#[global]
Hint Constructors mem.

(** Example of an inductive proof with Mem
    -- usually not as good as the one with [Forall] *)

Lemma tree_map_pred_succ_3 : forall t,
  tree_map pred (tree_map S t) = t.
Proof using.
  intros. induction t using tree_induct_mem; simpl.
  fequals.
  fequals. induction ts; simpl.
    fequals.
    fequals.
      apply H. constructor.
      apply IHts. introv M. apply H. auto.
Qed.

(** Definition of the relation "immediate subtree of" *)

Import LibRelation LibWf.

Inductive subtree : binary tree :=
  | subtree_intro : forall t ts,
     mem t ts -> subtree t (node ts).
  (* there is typically more than one case here *)

#[global]
Hint Constructors subtree.

(** Proof of well-foundedness of the subtree relation *)

Lemma subtree_wf : wf subtree.
Proof using.
  intros t. induction t using tree_induct_mem;
  constructor; introv K; inversions~ K.
Qed.

(** Example of a proof on the well-founded subtree order
    -- usually a bit longer, so not recommended *)

Lemma tree_map_pred_succ_4 : forall t,
  tree_map pred (tree_map S t) = t.
Proof using.
  intros. induction_wf IH: subtree_wf t.
  destruct t as [|ts]; simpl.
  fequals.
  fequals. induction ts; simpl.
    fequals.
    fequals.
      applys IH. auto.
      applys IHts. introv M. inverts M.
       auto. (* apply IH. constructors. constructors. *)
Qed.

End SubtermIndDemos.

(* ********************************************************************** *)
(** * Tactics exported by LibVar *)

Module LibVarDemos.
Import LibList LibLN.
Section LibVarDemo.
Implicit Types x y : var.

(* ---------------------------------------------------------------------- *)
(** ** Demo for notin *)

Lemma test_notin_solve_1 : forall x E F G,
  x \notin E \u F -> x \notin G -> x \notin (E \u G).
Proof using.
  intros. dup.
  notin_simpl. notin_solve. notin_solve.
  notin_solve.
Qed.

Lemma test_notin_solve_2 : forall x y E F G,
  x \notin E \u \{y} \u F -> x \notin G ->
  x \notin \{y} /\ y \notin \{x}.
Proof using.
  split. notin_solve. notin_solve.
Qed.

Lemma test_notin_solve_3 : forall x y,
  x <> y -> x \notin \{y} /\ y \notin \{x}.
Proof using.
  split. notin_solve. notin_solve.
Qed.

Lemma test_notin_solve_4 : forall x y,
  x \notin \{y} -> x <> y /\ y <> x.
Proof using.
  split. notin_solve. notin_solve.
Qed.

Lemma test_notin_false_1 : forall x y E F G,
  x \notin (E \u \{x} \u F) -> y \notin G.
Proof using.
  intros. dup 3.
    false. notin_false.
    notin_false.
    notin_false.
Qed.

Lemma test_notin_false_2 : forall x y : var,
  x <> x -> y = x.
Proof using.
  intros. notin_false.
Qed.

Lemma test_neq_solve : forall x y E F,
  x \notin (E \u \{y} \u F) -> y \notin E ->
  y <> x /\ x <> y.
Proof using.
  split. notin_solve. notin_solve.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Demo for fresh *)

Lemma test_fresh_solve_1 : forall xs L1 L2 n,
  fresh (L1 \u L2) n xs -> fresh L1 n xs.
Proof using.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_2 : forall xs L1 L2 n,
 fresh (L1 \u L2) n xs -> fresh L2 n xs.
Proof using.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_3 : forall xs L1 L2 n,
 fresh (L1 \u L2) n xs -> fresh \{} n xs.
Proof using.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_4 : forall xs L1 L2 n,
 fresh (L1 \u L2) n xs -> fresh L1 (length xs) xs.
Proof using.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_5 : forall xs L1 n m,
  m = n ->
  fresh L1 m xs ->
  fresh L1 n xs.
Proof using.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_6 : forall xs L1 L2 n m,
  m = n ->
  fresh (L1 \u L2) n xs ->
  fresh L1 m xs.
Proof using.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_7 : forall xs L1 L2 n m,
  n = m ->
  fresh (L1 \u L2) n xs ->
  fresh L1 m xs.
Proof using.
  intros. fresh_solve.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Demo of automation of [notin] *)

(* LibVar exports the following hints:
     Hint Extern 1 (_ \notin _) => notin_solve.
     Hint Extern 1 (_ <> _ :> var) => notin_solve.
     Hint Extern 1 ((_ \notin _) /\ _) => splits. *)

Lemma test_notin_by_auto : forall x E F G,
  x \notin E \u F -> x \notin G -> x \notin (E \u G).
Proof using. auto. Qed.

Lemma test_neq_by_auto : forall x y E,
  x \notin E \u \{y} -> y <> x.
Proof using. auto. Qed.

Lemma test_notin_false_by_hand : forall x,
  ~ x \notin \{x}.
Proof using. intros_all. notin_false. Qed.

Hint Extern 1 (~ _ \notin _) => intros_all; notin_false.

Lemma test_notin_false_by_auto : forall x,
  ~ x \notin \{x}.
Proof using. intros_all. notin_false. Qed.

(* Comment: using the following hint is a bad idea because it will
            lead to very inefficient proof scripts.
   Hint Extern 1 (False) => notin_false. *)

(* ---------------------------------------------------------------------- *)
(** ** Demo of pick_fresh_gen *)

Parameter trm : Type.
Parameter fv : trm -> vars.

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : trm => fv x) in
  constr:(A \u B \u C).

Ltac pick_fresh Y :=
  let L := gather_vars in (pick_fresh_gen L Y).

Lemma test_pick_fresh :
  forall (x y z : var) (L1 L2 L3 : vars) (t1 t2 : trm), True.
Proof using.
  intros. pick_fresh a.
Abort.

End LibVarDemo.
End LibVarDemos.

(* ---------------------------------------------------------------------- *)
(** ** Demo of LibSet tactics *)

From TLC Require Import LibSet.

Lemma inter_union_disjoint_right:
  forall A (E F G : set A),
  F \# G ->
  (E \u F) \n G = (E \n G).
Proof using.
  set_prove.
  (* intros. set_norm. set_specialize. set_norm. tauto. *)
Qed. (* demo *)

Lemma inter_union_subset_right:
  forall A (E F G : set A),
  F \c G ->
  (E \u F) \n G = (E \n G) \u F.
Proof using.
  set_prove.
Qed. (* demo *)

Lemma inter_covariant:
  forall A (E E' F F' : set A),
  E \c E' ->
  F \c F' ->
  (E \n F) \c (E' \n F').
Proof using.
  set_prove.
Qed. (* demo *)

Lemma set_decompose_inter_right :
  forall A (E F : set A),
  E = (E \n F) \u (E \- F).
Proof using.
  set_prove_classic.
Qed. (* demo *)

Lemma set_decompose_union_right :
  forall A (E F : set A),
  (E \u F) = E \u (F \- E).
Proof using.
  set_prove_classic.
Qed. (* demo *)


(** * 논리: 콕에서 다루는 논리 *)

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

(** 이전 장들에서 사실에 기반을 둔 주장(_명제_)의 많은 예들과 그것들이
    사실이라는 주장을 펴는 방법들(_증명_)을 보았다. 특히 [e1 = e2]
    형태의 _등식에 관한 명제_, 함축([P -> Q]), 한정사를 사용한
    명제([forall x, P])를 광범위하게 다루었다. 이 장에서 다른 익숙한
    형태들의 논리 추론을 하기 위해 어떻게 콕을 사용할 수 있는지를 보게
    될 것이다.

    상세한 내용을 살펴보기 전에, 콕으로 작성하는 수학적 문장의 상태에
    대해 조금 이야기하자. 콕은 _타입을 매기는_ 언어인데, 이는 콕의
    세계에 있는 모든 의미 있는 식은 연관된 타입을 갖는다는 것을 뜻한다.
    논리적 주장도 예외가 아니다. 왜냐하면 콕으로 증명하고자 시도하는
    어떤 문장도 타입을 가지고 있기 때문이다. _명제_의 타입인
    [Prop]이다. [Check] 명령어로 이것을 볼 수 있다.
*)

Check 3 = 3.
(* ===> Prop *)

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

(** _모든_ 구문 규칙을 준수하는 명제들은 콕에서 [Prop] 타입을 갖는
    것에 주목하자.  이 명제들이 참이든 거짓이든 상관없이 이 타입을
    갖는다. *)

(** 단순히 명제의 _자격을 갖추는 것_과 명제가 참임을 _증명할 수 있는 것_은
    별개의 문제다! *)

Check 2 = 2.
(* ===> Prop *)

Check forall n : nat, n = 2.
(* ===> Prop *)

Check 3 = 4.
(* ===> Prop *)

(** 정말로 명제는 단지 타입만 가지고 있는 것이 아니다. 콕의 세계의 다른 것들처럼
    똑같은 방식으로 다룰 수 있는 _일 등급 객체_이다.
 *)

(** 지금까지 명제를 작성할 수 있는 한 가지 주된 위치 [Theorem] (
    [Lemma]와 [Example]) 선언들만 보아왔다.  *)

Theorem plus_2_2_is_4 :
  2 + 2 = 4.
Proof. reflexivity.  Qed.

(** 하지만 명제는 다른 많은 방법으로 사용할 수 있다. 예를 들어,
    [Definition]을 사용하여 명제에 다른 이름을 줄 수 있다. 마치 다른
    종류의 식에 이름을 붙이는 것처럼 말이다.  *)

Definition plus_fact : Prop := 2 + 2 = 4.
Check plus_fact.
(* ===> plus_fact : Prop *)

(** 나중에 명제를 기대하는 어떤 상황에서 이 이름을 사용할 수
    있다. 예를 들어, [Theorem] 선언의 주장으로 사용할 수 있다. *)

Theorem plus_fact_is_true :
  plus_fact.
Proof. reflexivity.  Qed.

(** _매개 변수를 갖는_ 명제도 작성할 수 있다. 즉, 어떤 타입의 인자들을
    받아 명제를 리턴하는 함수들을 작성할 수 있다. *)

(** 예를 들어, 다음 함수는 숫자를 받아 이 숫자가 3과 같다고 주장하는
    명제를 리턴한다. *)

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

(** 콕에서 명제를 리턴하는 함수는 그 함수 인자의 _성질_을 정의한다라고 한다.

    예를 들어, _단사 함수_라는 익숙한 개념을 다음과 같이 정의한다.
 *)

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

Lemma succ_inj : injective S.
Proof.
  intros n m H. inversion H. reflexivity.
Qed.

(** 동치 연산자 [=]는 [Prop]을 리턴하는 함수이기도 하다.

    식 [n = m]은 [eq n m]을 보기 좋게 표현한 것인데, 콕의 [Notation]
    방법을 사용하여 정의한 것이다. [eq]은 어떠한 타입의 원소들과 함께 사용할 수 있기
    때문에 이 함수도 다형성을 갖는다. *)

Check @eq.
(* ===> forall A : Type, A -> A -> Prop *)

(** ([eq] 대신 [@eq]라고 작성했음을 주목하시오. [eq]에 대한 타입 인자
    [A]는 묵시적으로 선언되어서 [eq]의 전체 타입을 보려면 묵시적 인자
    기능을 중지시킬 필요가 있다.) *)

(* ################################################################# *)
(** * 논리적 연결자 *)

(* ================================================================= *)
(** ** 논리곱 *)

(** 명제 [A]와 [B]의 _논리곱_은 [A /\ B]라고 작성하고, [A]와 [B]가
    둘 다 참이라는 주장을 표현한다.
 *)

Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4.

(** 논리곱을 증명하기 위해 [split] 전술을 사용한다. 이 전술로 이 문장의 각 부분에 대해
    하나씩 두 개의 부분 목적들을 설정할 것이다. *)

Proof.
  (* 수업에서 다루었음 *)
  split.
  - (* 3 + 4 = 7 *) reflexivity.
  - (* 2 + 2 = 4 *) reflexivity.
Qed.

(** 어떤 명제 [A]와 [B]에 대해 [A]가 참이라고 가정하고 [B]가 참이라고
    가정하면 [A /\ B]도 참이라고 결론 지을 수 있다.  *)

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

(** 가정들과 함께 정리를 어떤 목적에 적용하면 이 정리를 위해 필요한
    가정들의 수만큼의 부분 목적들을 새로 만들어내는 효과가 있기
    때문에 [and_intro]를 적용해서 [split]와 동일한 효과를 얻을 수
    있다.
     *)

Example and_example' : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  apply and_intro.
  - (* 3 + 4 = 7 *) reflexivity.
  - (* 2 + 2 = 4 *) reflexivity.
Qed.

(** **** 연습문제: 별 두 개 (and_exercise)  *)
Example and_exercise :
  forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** 논리곱 문장을 증명하는 것에 대해서는 이쯤 해두자. 나머지 다른
    방향에 대해서 즉, 그 밖에 무엇인가를 증명하기 위해 논리곱 가정을
    _사용_하려면 [destruct] 전술을 사용한다.

    증명 문맥에 [A /\ B] 형태의 가정 [H]를 포함하는 경우 [destruct H
    as [HA HB]]라고 명령을 내리면 [H]를 이 문맥에서 없애고 두 개의
    새로운 가정들: [A]가 참이라는 [HA]와 [B]가 참이라는 [HB]을 새로
    추가한다.
  *)

Lemma and_example2 :
  forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof.
  (* 수업에서 다루었음 *)
  intros n m H.
  destruct H as [Hn Hm].
  rewrite Hn. rewrite Hm.
  reflexivity.
Qed.

(** 대개 그러하듯이 [H]를 도입한 다음 분해하지 않고 도입하자마자
    분해도 할 수 있다.
 *)

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

(** 두 가정들 [n = 0]과 [m = 0]을 하나의 논리곱으로 묶는 것을 왜
    꺼려했는지 궁금할 수도 있다. 왜냐하면 두 개의 분리된 전제들을
    가지고 이 정리를 작성할 수 있었기 때문입니다.
 *)

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

(** 이 정리를 작성하기 위해서라면 두 가지 작성 방법 모두
    좋습니다. 하지만 논리곱 가정들을 어떻게 다루는지 이해하는 것이
    중요합니다. 왜냐하면 논리곱은 증명 중간 단계에 빈번하게 발생할 수
    있기 때문입니다. 특히 매우 큰 증명 과정 중에. 여기 간단한 예가
    있습니다.
 *)

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

(** 논리곱에 대한 다른 흔하게 발생하는 상황은 [A /\ B]가 참이지만 어떤
    경우에는 단지 [A]만 (또는 [B]만) 필요한 상황이다. 다음 보조
    정리들은 그러한 경우에 유용하다.
 *)

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

(** **** 연습문제: 별 한 개, 선택 사항 (proj2)  *)
Lemma proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** 마지막으로 논리곱의 순서나 여러 피연산자들을 갖는 논리곱의 그룹을
    재배치할 필요가 있다.  다음 교환 법칙과 결합 법칙 정리들은 그런
    경우에 편리하다.
 *)

Theorem and_commut : forall P Q : Prop,
  P /\ Q -> Q /\ P.
Proof.
  (* 수업에서 다루었음 *)
  intros P Q [HP HQ].
  split.
    - (* 왼쪽 *) apply HQ.
    - (* 오른쪽 *) apply HP.  Qed.

(** **** 연습문제: 별 두 개 (and_assoc)  *)
(** (결합성에 대한 다음 증명에서 _내포된_ intro 패턴이 가정 [H : P /\
    (Q /\ R)]을 [HP : P], [HQ : Q], [HR : R]로 분해하는 과정을
    주목하시오. 거기에서부터 증명을 완료하시오.) *)

Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R [HP [HQ HR]].
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** 그런데 중위 연산자 [/\]는 사실 [and A B]를 구문상으로 직관적으로
    보이도록 만든 표기법일 뿐이다. 즉, [and]는 두 개의 명제들을 인자로
    받아 하나의 명제를 내는 콕 연산자이다.
 *)

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

(* ================================================================= *)
(** ** 논리합 *)

(** 다른 중요한 논리 연결자는 두 명제의 _논리합_이다. [A] 또는 [B]가
    참이면 [A \/ B]가 참이다. ([or : Prop -> Prop -> Prop]를 사용하여
    [or A B]로 논리합을 작성할 수 있다.) *)

(** 증명에서 논리합 가정을 사용하려면 [nat]이나 다른 데이터 타입에
    대해 진행한 것과 같이 경우 별 분석으로 진행한다. 경우 별 분석은
    [destruct]나 [intros]를 가지고 진행할 수 있다.  여기 예가 있다. *)

Lemma or_example :
  forall n m : nat, n = 0 \/ m = 0 -> n * m = 0.
Proof.
  (* 이 패턴은 [n = 0 \/ m = 0]에 대해 묵시적으로 경우 별로 분석한다. *)
  intros n m [Hn | Hm].
  - (* 이 경우는 [n = 0] *)
    rewrite Hn. reflexivity.
  - (* 이 경우는 [m = 0] *)
    rewrite Hm. rewrite <- mult_n_O.
    reflexivity.
Qed.

(** 역으로 논리합이 성립하는 것을 보이려면 둘 중 하나만 성립하는 것을
    보이면 된다.  이때 [left]와 [right] 두 가지 전술을
    사용한다. 전술의 이름에서 알 수 있듯이 첫 번째 전술은 논리합의
    왼편을 증명하면 되고, 두 번째 전술은 오른편을 증명한다.  여기 매우
    단순한 사용 예가 있다... *)

Lemma or_intro : forall A B : Prop, A -> A \/ B.
Proof.
  intros A B HA.
  left.
  apply HA.
Qed.

(** ... 그리고 [left]와 [right]를 둘 다 사용해야 하는 조금 더 흥미로운
    예가 있다.  *)

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

(** **** 연습문제: 별 한 개 (mult_eq_0)  *)
Lemma mult_eq_0 :
  forall n m, n * m = 0 -> n = 0 \/ m = 0.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 한 개 (or_commut)  *)
Theorem or_commut : forall P Q : Prop,
  P \/ Q  -> Q \/ P.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** 거짓과 부정 *)

(** 이제까지 주로 어떤 것이 _참_이라는 것을 증명하는 것에
    관여해왔다. 덧셈의 교환 법칙이 성립하고, 두 리스트를 붙이는 연산은
    결합 법칙이 성립하며, 등등. 물론 어떤 명제들이 참이 _아니다_라는
    _부정적인_ 결과에도 관심이 있을 수 있다. 그러한 부정적인 문장들을
    콕에서는 부정 연산자 [~]로 표현한다. *)

(** 부정이 어떻게 동작하는지 보기 위해서 [Tactics] 장에서 _부정의 함축
    원리(principle of explosion)_에 관해 논의한 것을 기억하자.  이
    원리가 얘기하는 바는, 만일 우리가 모순을 가정하면 어떤 명제도
    유도할 수 있다는 것이다. 이 직관을 따르면 [~ P] ("not [P]")를
    [forall Q, P -> Q]로 정의할 수 있을 것이다. 콕에서는 사실 [~ P]를
    [P -> False]로 약간 다르게 정의한다. 이때 [False]는 표준
    라이브러리에서 정의한 모순된 명제이다.
 *)

Module MyNot.

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

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

Check not.
(* ===> Prop -> Prop *)

End MyNot.

(** [False]는 모순된 명제이기 때문에 부정의 함축 원리를 이것에도
    적용한다.  만일 [False]를 증명 문맥에 추가한다면 [destruct] (또는
    [inversion]) 전술을 이 모순 명제에 적용하여 어떠한 목적도 달성할
    수 있다.
 *)

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  (* 수업에서 다루었음 *)
  intros P contra.
  destruct contra.  Qed.

(** 라틴어 _ex falso quodlibet_는 문자 그대로 "네가 바라는 것
    무엇이든지 거짓으로부터 끌어낼 수 있다"를 의미한다. 이 것은 부정의
    함축 원리에 대한 또 다른 흔한 이름이다.
 *)

(** **** 연습문제: 별 두 개, 선택 사항 (not_implies_our_not)  *)
(** 부정에 대한 콕의 정의로부터 바로 위에서 언급한 직관적인 명제를
    유도할 수 있음을 보이시오. *)

Fact not_implies_our_not : forall (P:Prop),
  ~ P -> (forall (Q:Prop), P -> Q).
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** 다음은 [0]과 [1]은 [nat]의 다른 원소들이라는 것을 서술하기 위해
    [not]을 사용하는 방법이다.
 *)

Theorem zero_not_one : ~(0 = 1).
Proof.
  intros contra. inversion contra.
Qed.

(** 이러한 등식에 대한 부정 형태의 문장은 충분히 자주 나타나므로
    특별한 표기법 [x <> y]을 도입할 필요가 있다.  *)

Check (0 <> 1).
(* ===> Prop *)

Theorem zero_not_one' : 0 <> 1.
Proof.
  intros H. inversion H.
Qed.

(** 콕에서 부정을 가지고 작업하는 것에 익숙해지기 위해서 약간 연습이
    필요하다.  비록 부정을 포함하는 문장이 왜 참인지 완벽하게 잘
    이해할 수 있지만 콕이 그것을 이해할 수 있도록 적절한 설정을 만드는
    것은 처음에 약간 복잡할 수 있다.  여기 몇 가지 익숙한 사실들을
    증명해봄으로써 조금씩 익숙해지도록 하자.
*)

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

Theorem contradiction_implies_anything : forall P Q : Prop,
  (P /\ ~P) -> Q.
Proof.
  (* 수업에서 다루었음 *)
  intros P Q [HP HNA]. unfold not in HNA.
  apply HNA in HP. destruct HP.  Qed.

Theorem double_neg : forall P : Prop,
  P -> ~~P.
Proof.
  (* 수업에서 다루었음 *)
  intros P H. unfold not. intros G. apply G. apply H.  Qed.

(** **** 연습문제: 별 두 개, 고급, 추천 (double_neg_inf)  *)
(**  [double_neg]의 비형식적인 증명을 작성해보시오:

   _Theorem_: [P] implies [~~P], for any proposition [P]. *)

(* 여기를 채우시오 *)
(** [] *)

(** **** 연습문제: 별 두 개, 추천 (contrapositive)  *)
Theorem contrapositive : forall (P Q : Prop),
  (P -> Q) -> (~Q -> ~P).
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 한 개 (not_both_true_and_false)  *)
Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 한 개, 고급 (informal_not_PNP)  *)
(** 명제 [forall P : Prop, ~(P /\ ~P)]를 영어로 비형식적인 증명을
    작성하시오. *)

(* 여기를 채우시오 *)
(** [] *)

(** 비슷하게 부등식은 부정을 사용하기 때문에 부등식을 가지고 능숙하게
    증명할 수 있으려면 약간 연습을 요구한다. 여기 유용한 요령이 있다.
    성립하지 않는 목적 (예를 들어 [false = true]와 같은 목적)을
    증명하려 한다면 [ex_falso_quodlibet]을 적용해서 이 목적을
    [False]로 변경하라. 어쩌면 문맥에 있는 [~P] 형태의 가정을 사용하기
    더 쉬울 것이다. 특히 [x<>y] 형태의 가정도 사용하기 더 쉬울 것이다.
    *)

Theorem not_true_is_false : forall b : bool,
  b <> true -> b = false.
Proof.
  intros [] H.
  - (* b = true *)
    unfold not in H.
    apply ex_falso_quodlibet.
    apply H. reflexivity.
  - (* b = false *)
    reflexivity.
Qed.

(** [ex_falso_quodlibet]로 추론하는 것이 상당히 흔해서 콕에서 미리
    준비된 전술 [exfalso]을 제공하므로 이 것을 적용하자.  *)

Theorem not_true_is_false' : forall b : bool,
  b <> true -> b = false.
Proof.
  intros [] H.
  - (* b = false *)
    unfold not in H.
    exfalso.                (* <=== *)
    apply H. reflexivity.
  - (* b = true *) reflexivity.
Qed.

(* ================================================================= *)
(** ** 참 *)

(** [False] 이외에도 콕은 표준 라이브러리에 [True]도 정의한다. 말
    그대로 참인 명제이다.  이 것을 증명하려면 미리 정의된 상수 [I :
    True]를 사용한다.  *)

Lemma True_is_true : True.
Proof. apply I. Qed.

(** [False]는 널리 사용되는 반면에 [True]는 매우 드물게
    사용된다. 왜냐하면 목적으로 증명하는 것이 매우 사소해서 그다지
    흥미롭지 않기 때문이다. 그리고 가정으로 유용한 정보를 제공하지
    않는다. 하지만 조건부 또는 고차원 [Prop]에 대한 매개변수로서
    복잡한 [Prop]를 정의할 때 상당히 유용할 수 있다. [True]를 그러한
    용도로 사용하는 예제들을 나중에 보게 될 것이다.
  *)

(* ================================================================= *)
(** ** 논리적 동치 *)

(** 편리한 "if and only if" 연결자는 두 명제가 동일한 진리 값을
    갖는다고 서술한다.  이 것은 함축 연결자 두 개를 논리곱으로 표현한
    것에 해당한다.  *)

Module MyIff.

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

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

End MyIff.

Theorem iff_sym : forall P Q : Prop,
  (P <-> Q) -> (Q <-> P).
Proof.
  (* 수업에서 다루었음 *)
  intros P Q [HAB HBA].
  split.
  - (* -> *) apply HBA.
  - (* <- *) apply HAB.  Qed.

Lemma not_true_iff_false : forall b,
  b <> true <-> b = false.
Proof.
  (* 수업에서 다루었음 *)
  intros b. split.
  - (* -> *) apply not_true_is_false.
  - (* <- *)
    intros H. rewrite H. intros H'. inversion H'.
Qed.

(** **** 연습문제: 별 한 개, 선택 사항 (iff_properties)  *)
(** [<->]이 대칭 [iff_sym] 임을 보이는 위의 증명을 가이드로 사용하여
    이 연결자가 반사적이고 추이적인 성질도 가지고 있음을
    증명하시오. *)

Theorem iff_refl : forall P : Prop,
  P <-> P.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem iff_trans : forall P Q R : Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개 (or_distributes_over_and)  *)
Theorem or_distributes_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** 어떤 콕 전술을 사용하면 [iff] 문장을 특별하게 취급해서 증명 상태를
    상세하게 다루지 않아도 됩니다. 특히 [rewrite]와 [reflexivity]
    전술은 단지 등식뿐만 아니라 [iff] 문장을 가지고 사용할 수 있다.
    이 동작을 사용하려면 등식뿐만 아니라 다른 공식들을 가지고 다시
    작성하도록 하는 특별한 콕 라이브러리를 불러들일 필요가 있다. *)

Require Import Coq.Setoids.Setoid.

(** 이 전술들이 [iff]를 어떻게 다루는지 보여주는 간단한 예가 있다.
    우선 기본적인 iff 동치 한 두 가지를 증명해보자... *)

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

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

(** [rewrite]와 [reflexivity] 전술들을 가지고 이 사실들을 이제
    사용하여 동치 형태의 문장을 매끄럽게 증명할 수 있다. 다음은 이전에
    증명한 바 있는 [mult_0] 결과에서 3개의 피연산자를 포함하는
    버전이다. *)

Lemma mult_0_3 :
  forall n m p, n * m * p = 0 <-> n = 0 \/ m = 0 \/ p = 0.
Proof.
  intros n m p.
  rewrite mult_0. rewrite mult_0. rewrite or_assoc.
  reflexivity.
Qed.

(** [apply] 전술도 [<->]과 함께 사용할 수 있다. 인자로 동치 형태가
    주어지면 [apply]는 그 동치의 어떤 편을 사용할지 추측한다. *)

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

(* ================================================================= *)
(** ** 존재 한정 *)

(** 다른 중요한 논리 연결자는 _존재 한정_이다. 타입 [T]의 어떤 [x]가
    존재하여 [x]에 대한 어떤 성질 [P]가 성립한다는 것을 [exists x : T,
    P]라고 작성하여 표현한다.  만일 콕이 현재 문맥으로부터 [x]의
    타입을 유추할 수 있다면 [forall]의 경우처럼 [: T] 타입 주석을
    생략할 수 있다. *)

(** [exists x, P] 형태의 문장을 증명하려면 [x]를 위해 특별히 선택한
    값에 대해 [P]가 성립함을 보여야 한다. 이 증명은 두 단계로
    이루어진다. 첫째, [exists t] 전술로 우리가 아는 목격자 [t]를
    콕에게 명시적으로 알려준다. 그런 다음 [x]가 나타난 자리를 모두
    [x]로 바꾼 다음 [P]가 성립함을 증명한다. *)

Lemma four_is_even : exists n : nat, 4 = n + n.
Proof.
  exists 2. reflexivity.
Qed.

(** 역으로 만일 존재 한정 [exists x, P] 명제를 현재 문맥에서 가지고
    있다면 이 것을 분해해서 어떤 목격자 [x]와 [x]에 대해 [P]가
    성립한다는 가정을 얻어 낼 수 있다. *)

Theorem exists_example_2 : forall n,
  (exists m, n = 4 + m) ->
  (exists o, n = 2 + o).
Proof.
  (* 수업에서 다루었음 *)
  intros n [m Hm]. (* 여기 묵시적으로 [destruct]를 적용함을 주목하시오 *)
  exists (2 + m).
  apply Hm.  Qed.

(** **** 연습문제: 별 한 개 (dist_not_exists)  *)
(** 모든 [x]에 대해 [P]가 성립하면 [P]가 성립하지 않는 [x]가 없음을
    증명하시오. *)

Theorem dist_not_exists : forall (X:Type) (P : X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 두 개 (dist_exists_or)  *)
(** 논리합에 대한 존재 한정 분배를 증명하시오. *)

Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
   (* 여기를 채우시오 *) Admitted.
(** [] *)

(* ################################################################# *)
(** * 명제를 다루는 프로그래밍 *)

(** 이제까지 살펴본 논리 연결자들은 간단한 명제에서부터 복잡한 것들을
    정의하는데 풍성한 어휘를 제공한다. 예를 들어 원소 [x]가 리스트
    [l]에 나타난다는 주장을 표현하는 법을 살펴보자. 이 성질은 간단한
    재귀적 구조를 가지고 있음을 주목하시오.  *)
(**    - 만일 [l]이 비어있는 리스트이면 [x]는 그 리스트에 나타날
         수 없다. 그래서 [x]는 [l]에 나타난다는 성질은 간단히
         거짓이다. *)
(**    - 그렇지 않다면 [l]은 [x' :: l'] 형태이다. 이 경우 [x]가
         [x']가 일치하거나 [l']에 나타나면 [x]가 [l]에 나타난다. *)

(** 이 성질을 원소와 리스트를 받아 명제를 리턴하는 간단한 재귀 함수로
    바로 변환할 수 있다. *)

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

(** [In]을 구체적인 리스트에 적용하면 내포된 논리합들이 쭉 나열된
    형태로 펼쳐진다. *)

Example In_example_1 : In 4 [1; 2; 3; 4; 5].
Proof.
  (* 수업에서 다루었음 *)
  simpl. right. right. right. left. reflexivity.
Qed.

Example In_example_2 :
  forall n, In n [2; 4] ->
  exists n', n = 2 * n'.
Proof.
  (* 수업에서 다루었음 *)
  simpl.
  intros n [H | [H | []]].
  - exists 1. rewrite <- H. reflexivity.
  - exists 2. rewrite <- H. reflexivity.
Qed.
(** (_덧붙여서_ 마지막 경우를 이행하기 위해서 비어있는 패턴을 사용함을
    주목하시오.) *)

(** [In]에 대한 더 일반적 형태이고 고차원인 보조 정리들도 증명할 수
    있다.

    다음 보조 정리 증명에서 [In]을 변수에 적용하여 시작하고 그 변수에
    대한 경우 별 분석을 하는 경우만 펼쳐지는 것을 주목하시오. *)

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

(** 이렇게 재귀적으로 명제를 정의하는 방법은 어떤 경우에는 편리하지만
    약간의 단점도 있다. 특히 콕에서 재귀 함수를 정의할 때 반드시
    종료해야하는 조건에 관한 제약에 관한 것이다. 다음 장에서 명제들을
    _귀납적으로_ 정의하는 법을 살펴볼 것이다. 이 방법은 나름의 장점과
    한계를 갖는 다른 기법이다. *)

(** **** 연습문제: 별 두 개 (In_map_iff)  *)
Lemma In_map_iff :
  forall (A B : Type) (f : A -> B) (l : list A) (y : B),
    In y (map f l) <->
    exists x, f x = y /\ In x l.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 두 개 (in_app_iff)  *)
Lemma in_app_iff : forall A l l' (a:A),
  In a (l++l') <-> In a l \/ In a l'.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개, 추천 (All)  *)
(** 명제를 리턴하는 함수를 그 함수 인자들의 _성질_로 볼 수 있다고 한
    점을 다시 기억하시오. 예를 들어 [P]가 [nat -> Prop] 타입을
    갖는다면 [P n]은 [n]에 대해 성질 [P]가 성립함을 서술한다.

    [In]으로부터 영감을 받아 리스트 [l]의 모든 원소들에 대해 성립하는
    어떤 성질 [P]를 기술하는 재귀 함수 [All]을 작성하시오. 당신이
    작성한 정의가 정확함을 확신하기 위해 [All_In] 보조 정리를 아래에서
    증명하시오. (물론 단순히 [All_In]의 왼편을 기술하지는 않도록
    한다.) *)

Fixpoint All {T : Type} (P : T -> Prop) (l : list T) : Prop
  (* 이 줄을 ":= _여러분의 정의_"로 다시 작성하시오 *). Admitted.

Lemma All_In :
  forall T (P : T -> Prop) (l : list T),
    (forall x, In x l -> P x) <->
    All P l.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개 (combine_odd_even)  *)
(** 아래 [combine_odd_even] 함수의 정의를 완성하시오.  인자로 숫자들의
    두 가지 성질들, [Podd]와 [Peven]을 받아 [n]이 홀수 일 때 [P n]이
    [Podd n]과 동치이고 [n]이 짝수 일 때 [P n]이 [Peven n]과 동치인
    성질 [P]를 리턴해야 한다. *)

Definition combine_odd_even (Podd Peven : nat -> Prop) : nat -> Prop
  (* 이 줄을 ":= _여러분의 정의_"로 다시 작성하시오 *). Admitted.

(** 작성한 정의를 테스트하기 위해 다음 사실들을 증명하시오. *)

Theorem combine_odd_even_intro :
  forall (Podd Peven : nat -> Prop) (n : nat),
    (oddb n = true -> Podd n) ->
    (oddb n = false -> Peven n) ->
    combine_odd_even Podd Peven n.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem combine_odd_even_elim_odd :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = true ->
    Podd n.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem combine_odd_even_elim_even :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = false ->
    Peven n.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(* ################################################################# *)
(** * 정리를 인자에 적용하기 *)

(** 콕이 많은 다른 증명 보조기와 구분되는 한 가지 특징은 _증명_을 일
    등급 객체로 다룬다는 것이다.

    이것에 대해 이야기할 것이 많이 있지만 콕을 사용하기 위해서 이것을
    상세히 이해할 필요는 없다. 이 절은 단지 맛보기만 제공하고 더 깊은
    탐구는 선택 사항으로 분류된 장 [ProofObjects]와
    [IndPrinciples]에서 다룬다. *)

(** [Check] 명령어를 사용하여 콕으로 하여금 식의 타입을 출력하도록
    요청하는 것을 보아왔다. [Check] 명령어를 사용하여 특정 식별자가
    가리키는 정리가 무엇인지 콕에게 물어볼 수도 있다. *)

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

(** 콕은 [Check]으로 어떤 식의 _타입_을 출력하는 것과 동일한 방법으로
    [plus_comm] 정리의 _문장_을 출력한다. 왜 그럴까? *)

(** 그 이유는 [plus_comm] 식별자는 사실 _증명 객체_를 가리키고 있기
    때문이다.  증명 객체는 [forall n m: nat, n + m = m + n] 문장이
    참임을 증명하는 논리적 유도과정을 표현하는 자료 구조이다. 이
    객체의 타입이 _바로_ 이 객체가 증명하는 정리의 문장이다.  *)

(** 직관적으로 정리의 문장은 그 정리를 사용할 목적이기 때문에 정리
    식별자를 [Check]로 확인하면 그 문장이 타입으로 출력되는 것이
    일리가 있다. 이것은 마치 계산을 담고 있는 객체의 타입이 그 객체를
    가지고 우리가 할 수 있는 것을 말해주는 것과 비슷하다. 예를 들어,
    [nat -> nat -> nat] 타입의 식을 가지고 있다면 그 식에 두 개의
    [nat]들을 인자로 주어 다시 [nat]을 돌려받을 수 있다. 비슷하게 [n =
    m -> n + n = m + m] 타입의 객체를 가지고 있고 타입 [n = m]의 어떤
    "인자"를 주면 [n + n = m + m]을 유도할 수 있다. *)

(** 그 과정을 생각하면 이러한 유사점은 한 걸음 더 나아갈 수
    있다. 정리를 마치 함수인 것처럼 타입이 매칭 되는 가정에 적용하여
    중간 단계의 주장들을 거치지 않고 정리의 결과를 그 가정에 맞추어
    특화시킬 수 있다. 예를 들어 다음 결과를 증명하기를 원했다고
    가정하자. *)

Lemma plus_comm3 :
  forall n m p, n + (m + p) = (p + m) + n.

(** 처음 보기에는 [plus_comm]을 두 번 적용하여 양 편을 일치하도록
    작성하여 이 정리를 증명할 수 있어야 할 것처럼 보인다. 하지만 두
    번째 [rewrite]는 첫 번째 적용한 결과를 되돌려 놓는 문제가 있다.
    *)

Proof.
  intros n m p.
  rewrite plus_comm.
  rewrite plus_comm.
  (* 처음 시작했던 곳으로 돌아왔다... *)
Abort.

(** 이 문제를 해결하는 한 가지 간단한 방법은 (우리가 이미 아는
    방법만을 사용한다면) 우리가 원하는 정확한 그 곳에 다시 작성 전술을
    적용할 수 있도록 [plus_comm]의 특화 버전을 유도하기 위해서
    [assert]를 사용하는 것이다. *)

Lemma plus_comm3_take2 :
  forall n m p, n + (m + p) = (p + m) + n.
Proof.
  intros n m p.
  rewrite plus_comm.
  assert (H : m + p = p + m).
  { rewrite plus_comm. reflexivity. }
  rewrite H.
  reflexivity.
Qed.

(** 더 우아한 방법은 [plus_comm]을 적용하기를 원하는 인자에 직접
    적용하는 것이다.  마치 다형성 함수에 타입 인자를 적용하는 것과
    매우 흡사한 방법이다. *)

Lemma plus_comm3_take3 :
  forall n m p, n + (m + p) = (p + m) + n.
Proof.
  intros n m p.
  rewrite plus_comm.
  rewrite (plus_comm m).
  reflexivity.
Qed.

(** 정리 이름을 인자로 받는 거의 모든 전술들을 이런 방식으로 "정리를
    함수처럼 사용"할 수 있다. 정리를 적용할 때 함수를 적용하는 것과
    동일한 추론 방법을 사용하는 점을 또한 주목하시오. 이렇게, 예를
    들어 인자로 와일드카드를 주어 추론되도록 하거나 정리의 어떤
    가정들을 묵시적으로 주어지도록 선언하는 것이 가능하다. 이 특징들을
    아래 증명에서 예시로 보여준다. *)

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

(** 이 절에서 보여준 관용 표현들의 더 많은 예들을 나중에 볼 것이다. *)

(* ################################################################# *)
(** * 콕 vs. 집합론 *)

(** 콕의 핵심 논리 부분, _Calculus of Inductive Constructions_,은
    정확하고 엄밀하게 증명을 쓰기 위해 수학자들이 사용한 다른 정형
    시스템과 비교할 때 몇 가지 중요한 측면에서 다르다. 예를 들어,
    종이와 연필로 증명하는 수학을 위한 가장 잘 알려진 기초는
    Zermelo-Fraenkel 집합론(ZFC)이다. 이 이론에서 수학적 객체는
    잠재적으로 많은 다른 집합들의 원소가 될 수 있다. 반면에 콕의
    논리에서 식은 기껏해야 한 가지 타입의 원소이다. 이 차이점은
    비형식적인 수학적 개념들을 표현하는 약간의 다른 방법들로 귀결되곤
    한다. 하지만 다른 방법이긴 하지만 대체로 꽤 자연스럽고 쉽게 작업할
    수 있다. 예를 들어 자연수 [n]은 짝수 집합에 속한다고 말하는 대신
    콕에서는 [ev : nat -> Prop]는 짝수를 기술하는 성질로 [ev n]이
    성립한다고 이야기 할 것이다.

    하지만 표준 수학적 추론으로 콕으로 변환하기 귀찮을 수 있고 때로는
    콕의 핵심 논리에 새로운 공리를 추가하지 않으면 심지어 그러한
    변환이 불가능한 경우 조차 있다. 이 두 세계들 사이의 가장 중요한
    차이점들 일부를 간략하게 논의하면서 이 장을 마친다. *)

(* ================================================================= *)
(** ** 함수 외연성 *)

(** 지금까지 살펴본 동치 주장은 대부분 귀납적 타입 ([nat], [bool],
    등등)의 원소들에 관한 것이었다. 하지만 콕의 동치 연산자는 다형성이
    있기 때문에 이 타입들의 원소들에 대해서만 가능한 것은 아니다. 특히
    두 _함수_가 서로 동일하다고 주장하는 명제를 작성할 수 있다. *)

Example function_equality_ex1 : plus 3 = plus (pred 4).
Proof. reflexivity. Qed.

(** 동일한 수학적 사례에서 두 함수 [f]와 [g]는 동일한 출력을 내면
    동일한 것으로 간주한다.

    (forall x, f x = g x) -> f = g

    이것을 _함수 외연성_ 원리라고 부른다.

    쉽게 설명하자면, "외연성 성질"은 객체의 관찰 가능한 동작에
    속한다. 마찬가지로 함수 외연성은 간단히 함수로부터 관찰할 수 있는
    것(예를 들어, 콕 식에서 함수를 적용한 다음 얻는 결과)으로 함수를
    구분하는 것을 의미한다.

    함수 외연성은 콕의 기본 공리가 아니다. 어떤 "합리적인" 명제들을
    증명할 수 없을 수도 있다는 것을 뜻한다. *)

Example function_equality_ex2 :
  (fun x => plus x 1) = (fun x => plus 1 x).
Proof.
   (* Stuck *)
Abort.

(** 하지만 [Axiom] 명령어를 사용하여 콕의 논리 핵심에 함수 외연성을
    추가할 수 있다. *)

Axiom functional_extensionality : forall {X Y: Type}
                                    {f g : X -> Y},
  (forall (x:X), f x = g x) -> f = g.

(** [Axiom]은 정리를 기술하고 [Admitted]를 사용하여 그 증명을 생략한
    것과 똑같은 효과를 낸다. 이 명령어를 사용하면 하지만 나중에 다시
    돌아와서 채우는 그런 것은 아니라는 것을 경고한다! *)

(** 이제 증명에서 함수 외연성을 사용할 수 있다. *)

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

(** 콕 논리에 새로운 공리를 추가할 때 당연히 주의해야 한다. 왜냐하면
    새로운 공리는 콕을 _일관성을 잃게_ 만들 수 있기 때문이다. 즉,
    [False]를 포함한 모든 명제를 증명하도록 만들 수도 있다!

    불행히도 이 공리가 더해도 안전한지 판단할 수 있는 간단한 방법은
    없다.  일반적으로 특정 공리 조합의 일관성을 확인할 때 힘든 작업이
    필요하다.

    하지만 함수 외연성을 추가해도 _일관성을 유지한다고_ 알려져
    있다. *)

(** 특정 증명이 추가된 공리에 의존하는지 검사하기 위해서 [Print
    Assumptions] 명령어를 사용한다.  *)

Print Assumptions function_equality_ex2.
(* ===>
     Axioms:
     functional_extensionality :
         forall (X Y : Type) (f g : X -> Y),
                (forall x : X, f x = g x) -> f = g *)

(** **** 연습문제: 별 네 개 (tr_rev)  *)
(** 리스트를 뒤집는 함수 [rev] 정의는 각 단계에서 [app]를 호출하는
    문제가 있다.  [app]를 리스트 길이에 비례해서 실행 시간이 걸리므로
    [rev]는 그 길이의 제곱에 해당하는 실행 시간이 걸린다. 다음 정의로
    이러한 문제를 개선할 수 있다.  *)

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

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

(** 이 버전을 _꼬리에서 재귀 함수를 호출_한다고 부른다. 왜냐하면 재귀
    함수 호출이 맨 마지막에서 수행하기 때문이다. 즉, 재귀 함수 호출
    다음에 [++]를 실행할 필요가 없다. 좋은 컴파일러는 이런 경우에 매우
    효율적인 코드를 생성할 것이다. 두 정의가 정말로 동일하다는 것을
    증명하시오. *)

Lemma tr_rev_correct : forall X, @tr_rev X = @rev X.
(* 여기를 채우시오 *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** 명제와 부울 *)

(** 콕에서 논리적 사실을 표현하는 두 가지 다른 방법을 보았다. ([bool]
    타입의) _부울_을 사용하는 방법과 ([Prop] 타입의) _명제_를 사용하는
    방법이다.

    예를 들어, [n]이 짝수라고 주장하기 위해서 (1) [evenb n]은 [true]를
    리턴한다라고 말하거나 (2) [n = double k]인 어떤 [k]가 존재한다고
    얘기할 수 있다. 정말로 짝수에 대한 이 두 가지 개념들은
    동일하다. 이를 몇 가지 보조 정리들로 쉽게 보일 수 있다.

    부울 [evenb n]은 명제 [exists k, n = double k]를 _반영한다고_ 종종
    얘기한다. *)

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

(** **** 연습문제: 별 세 개 (evenb_double_conv)  *)
Theorem evenb_double_conv : forall n,
  exists k, n = if evenb n then double k
                else S (double k).
Proof.
  (* 힌트: [Induction.v]의 [evenb_S] 보조 정리를 사용하시오. *)
  (* 여기를 채우시오 *) Admitted.
(** [] *)

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

(** 비슷하게 두 숫자 [n]과 [m]이 같다고 말하기 위해서 (1) [beq_nat n
    m]이 [true]를 리턴한다고 말하거나 (2) [n = m]이라고 말할 수
    있다. 이 두 개념들은 동일하다. *)

Theorem beq_nat_true_iff : forall n1 n2 : nat,
  beq_nat n1 n2 = true <-> n1 = n2.
Proof.
  intros n1 n2. split.
  - apply beq_nat_true.
  - intros H. rewrite H. rewrite <- beq_nat_refl. reflexivity.
Qed.

(** 순수한 논리적 관점에서 어떤 주장을 부울과 명제로 동일하게 작성할
    수 있다고 하더라도 _증명 과정_에서 동일할 필요는 없다. 동등성은 한
    가지 극단적인 예를 제공한다.  [beq_nat n m = true]를 알고 있다고
    해도 [n]과 [m]이 관여한 증명에 일반적으로 직접적인 도움이 되지
    못한다. 하지만 이 문장을 동등한 [n = m] 형태로 바꾸면 이 것을
    가지고 다시 작성 전술에 활용할 수 있다.

    짝수의 경우에도 흥미롭다. [even_bool_prop] (즉, [evenb_double],
    명제에서 부울식 주장으로 향하는)의 역 방향을 증명할 때 [k]에 대한
    귀납법을 간단히 사용했다.  반면에 역 ([evenb_double_conv]
    연습문제)은 현명한 일반화가 필요했다.  왜냐하면 [(exists k, n =
    double k) -> evenb n = true]를 직접 증명할 수 없기 때문이다.

    이 예제들에서 명제로 주장하는 것은 부울 주장보다 더
    유용하다. 하지만 항상 그러한 것은 아니다. 예를 들어, 함수 정의에서
    일반적인 명제가 참인지 거짓인지 테스트할 수 없다.  그 결과 다음
    코드를 콕이 거절한다. *)

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

(** 콕은 [bool] (또는 두 원소를 갖는 어떤 다른 귀납적 타입) 원소를
    기대했지만 [n = 2]가 [Prop] 타입이라고 불평할 것이다.  이 에러
    메시지를 내는 이유는 콕의 핵심 언어의 _계산적인_ 성질과 관련이
    있다. 콕이 표현할 수 있는 모든 함수는 계산 가능하고 항상
    종료하도록 핵심 언어를 설계하였다. 이렇게 설계한 한 가지 이유는 콕
    증명으로부터 실행 가능한 프로그램을 추출하기 위한 것이다. 그 결과
    콕에서 [Prop]은 어떤 주어진 명제가 참인지 거짓인지 판단하는
    보편적인 경우 별 분석 연산을 _가지고 있지 않다_. 왜냐하면 그러한
    연산을 허용하면 계산할 수 없는 함수를 작성할 수 있기 때문이다.

    비록 일반적인 계산 가능하지 않는 성질들을 부울 계산으로 나타낼 수
    없지만 많은 _계산 가능한_ 성질들조차 [bool]보다 [Prop]을 사용해서
    표현하는 것이 더 쉽다는 것을 주목할만하다. 왜냐하면 콕에서 재귀
    함수를 정의하는데 큰 제약이 있기 때문이다. 예를 들어 다음 장에서
    [Prop]을 사용하여 정규식과 문자열을 매칭 하는 성질을 어떻게
    정의하는지 보여준다. [bool]을 가지고 똑같은 것을 한다면 정규식
    매치 함수를 작성하는 것과 다름이 없을 것인데, 더 복잡하고 이해하기
    어렵고, 추론에 활용하는 것이 더 어려울 것이다.

    역으로 부울을 가지고 사실을 기술하는 것의 중요한 부수적인 이점은
    콕 식의 계산을 통해 어떤 증명을 자동화할 수 있다는 것이다.  이
    기법은 _반사에 의한 증명_이라 알려져 있다. 다음 문장을
    고려해보자. *)

Example even_1000 : exists k, 1000 = double k.

(** 이 사실을 가장 직접적으로 증명하는 것은 [k]의 값을 명확히 주는 것이다. *)

Proof. exists 500. reflexivity. Qed.

(** 반면에 해당하는 부울 기반 문장에 대한 증명은 한층 더 간단하다. *)

Example even_1000' : evenb 1000 = true.
Proof. reflexivity. Qed.

(** 흥미로운 점은, 두 개념이 동일하기 때문에 500을 명시적으로 언급하지
    않고 부울 기반 문장을 사용하여 앞의 명제를 증명할 수 있다는
    점이다. *)

Example even_1000'' : exists k, 1000 = double k.
Proof. apply even_bool_prop. reflexivity. Qed.

(** 이 경우 증명 크기에 관하여 얻은 것이 비록 없지만 더 큰 증명의 경우
    반사를 사용하면 훨씬 더 간단하게 증명할 수 있곤 한다. 극단적인
    예로써 유명한 _4색 정리_에 대한 콕 증명에서 반사를 사용하여 부울
    계산의 수백 가지 다른 경우들을 분석하는 것을 줄였다. 반사에 대해
    매우 깊이 설명하지 않지만 부울과 일반적인 명제의 보완적인 장점들을
    보여주는 좋은 예이다.
 *)

(** **** 연습문제: 별 두 개 (logical_connectives)  *)
(** 다음 보조 정리들은 이 장에서 공부한 명제의 연결자들을 해당하는
    부울 연산과 연관시킨다. *)

Lemma andb_true_iff : forall b1 b2:bool,
  b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof.
  (* 여기를 채우시오 *) Admitted.

Lemma orb_true_iff : forall b1 b2,
  b1 || b2 = true <-> b1 = true \/ b2 = true.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 한 개 (beq_nat_false_iff)  *)
(** 다음 정리는 [beq_nat_true_iff]의 또 다른 "부정" 형식이다. 이것은
    어떤 상황에서 더 편리하다 (나중에 예제를 살펴 볼 것이다). *)

Theorem beq_nat_false_iff : forall x y : nat,
  beq_nat x y = false <-> x <> y.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개 (beq_list)  *)
(** 어떤 타입 [A]의 원소들이 동일한지 비교하는 부울 연산자 [beq]에
    대해 [A] 타입 원소를 갖는 리스트가 동일한지 비교하는 함수
    [beq_list beq]를 정의할 수 있다. 아래의 [beq_list] 함수 정의를
    완성하시오. 그 정의가 올바른지 확인하기 위해 [beq_list_true_iff]
    보조 정리를 증명하시오. *)

Fixpoint beq_list {A : Type} (beq : A -> A -> bool)
                  (l1 l2 : list A) : bool
  (* 이 줄을 ":= _여러분의 정의_"로 다시 작성하시오 *). Admitted.

Lemma beq_list_true_iff :
  forall A (beq : A -> A -> bool),
    (forall a1 a2, beq a1 a2 = true <-> a1 = a2) ->
    forall l1 l2, beq_list beq l1 l2 = true <-> l1 = l2.
Proof.
(* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 두 개, 추천 (All_forallb)  *)
(** [Tactics] 장의 연습문제 [forall_exists_challenge]에서 [forallb]
    함수를 기억해보자. *)

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

(** 위 연습문제의 [forallb]를 [All]를 연관짓는 아래의 정리를
    증명하시오. *)

Theorem forallb_true_iff : forall X test (l : list X),
   forallb test l = true <-> All (fun x => test x = true) l.
Proof.
  (* 여기를 채우시오 *) Admitted.

(** 함수 [forallb]의 중요한 성질들 중에 이 명세로 표현되지 않는 것이
    있는가?  *)

(* 여기를 채우시오 *)
(** [] *)

(* ================================================================= *)
(** ** 고전적 vs. 건설적 논리 *)

(** 명제 [P]가 성립하는지 검사하는 것은 가능하지 않다고
    하였다. _증명_!에도 유사한 제약이 적용된다는 것에 놀랄 수도
    있다. 달리 설명하면 다음의 직관적인 유추 원리를 콕에서 유도할 수
    없다. *)

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

(** 왜 그러한지 과정 측면에서 이해하자면 [P \/ Q] 형태의 문장을
    증명하기 위해 [left]와 [right] 전술을 사용하였음을 기억하자. 각각
    논리합의 해당하는 편이 성립하는 증명을 가지고 있다는
    요구한다. 하지만 [excluded_middle]에서 전칭 한정 [P]의 경우
    _임의의_ 명제이고 그 것에 대해 아무것도 알지 못한다.  [left]와
    [right] 중에 어느 것을 적용할 지 선택할 충분한 정보가 없다.
    왜냐하면 콕은 함수 안에서 [P]가 성립하는지 여부를 기계적으로
    결정하기 위해서 충분한 정보를 갖고 있지 않는 것이기 때문이다. *)

(** 하지만 [P]를 어떤 부울 식 [b]로 투영할 수 있다면 [P]가 성립하는지
    여부를 아는 것은 매우 쉽다. [b]의 값을 들여다 보기만 하면 된다. *)

Theorem restricted_excluded_middle : forall P b,
  (P <-> b = true) -> P \/ ~ P.
Proof.
  intros P [] H.
  - left. rewrite H. reflexivity.
  - right. rewrite H. intros contra. inversion contra.
Qed.

(** 특히, 자연수 [n]과 [m]에 대한 [n = m] 식에 대해서 excluded_middle
    정의는 성립한다.  *)

Theorem restricted_excluded_middle_eq : forall (n m : nat),
  n = m \/ n <> m.
Proof.
  intros n m.
  apply (restricted_excluded_middle (n = m) (beq_nat n m)).
  symmetry.
  apply beq_nat_true_iff.
Qed.

(** 콕에 일반적인 excluded_middle이 성립하지 않는 것에 대해 이상하게
    생각할 수도 있다. 왜냐하면 결국 모든 주장은 참 또는 거짓이어야
    하기 때문이다.  그럼에도 불구하고 이 것을 가정하지 않는 장점이
    있다. 콕의 문장은 표준 수학에서 유사한 문장보다 더 강한 주장을
    만들 수 있기 때문이다. 좋은 예로 [exists x. P x]를 콕에서 증명하면
    [P x]를 증명하는 [x]의 값을 명시적으로 보여줄 수 있다.  다르게
    설명하면 존재에 대한 모든 증명은 반드시 _건설적_이다. *)

(** excluded_middle을 가정하지 않는 콕과 같은 논리를 _건설적 논리_라고
    부른다.

    임의의 명제에 대해 excluded_middle이 성립하는 ZFC와 같은 더 자주
    사용하는 논리 시스템을 _고전적_이라고 부른다. *)

(** 다음 예는 exlcluded_middle을 가정하면 왜 비 건설적인 증명이 될
    수도 있는지를 보여준다.

    _주장_: [a ^ b]가 유리수인 무리수 [a]와 [b]가 존재한다.

    _증명_: [sqrt 2]가 무리수라는 것을 증명하는 것은 어렵지 않다. 만일
    [sqrt 2 ^ sqrt 2]가 유리수라면 [a = b = sqrt 2]를 취하는 것으로
    증명할 수 있다. 만일 유리수가 아니라면 [a = sqrt 2 ^ sqrt 2]라
    하고 [b = sqrt 2]로 놓자. [a ^ b = sqrt 2 ^ (sqrt 2 * sqrt 2) =
    sqrt 2 ^ 2 = 2]. []

    여기서 무슨 일이 벌어졌는지 이해하는가? [sqrt 2 ^ sqrt 2]가
    유리수인 경우와 그렇지 않은 경우를 excluded_middle을 사용하여
    분리해서 고려하였다. 하지만 어느 것이 성립하는지 알지 못한다! 바로
    그 것 때문에 그러한 [a]와 [b]가 존재하는 것을 아는 문제를 우회해서
    매듭지었지만 실제 값이 무엇인지 결정할 수 없다 (적어도 이 논법을
    사용하여).

    건설적 논리만큼 유용하지만 한계를 가지고 있다. 고전적 논리에서
    쉽게 증명할 수 있지만 훨씬 복잡한 건설적 증명을 필요로 하는 많은
    문장들이 있다. 그리고 건설적 방법으로 전혀 증명할 수 없다고 알려진
    것도 있다! 운 좋게도 함수 외연성 처럼 excluded_middle은 콕의
    논리와 호환 가능하다고 알려져 있어서 공리로 안전하게 추가할 수
    있다. 하지만 이 책에서는 그것을 필요로 하지 않을 것이다. 왜냐하면
    우리가 다루는 결과들은 건설적 논리로 무시할만한 추가 비용으로 모두
    증명할 수 있기 때문이다.

    건설적 추론에서 어떤 증명 기법들을 피해야 하는지 이해하는데 약간의
    연습이 필요하다. 하지만 모순에 의한 주장은 특히 비건설적 증명을
    초래하는 것으로 악명이 높다. 전형적인 예를 살펴보자. 어떤 성질
    [P]를 갖는 [x]가 존재한다는 것(즉, [P x])를 증명하기를 원한다고
    가정하자.  우리의 결론이 거짓이라고 가정하면서 시작한다. 즉
    [~exists x, P x].  이 가설로부터 [forall x, ~ P x]를 유도하는 것은
    어렵지 않다. 이 중간 단계의 사실이 모순을 일으킨다는 것을 보일 수
    있다면 [P x]를 만족하는 [x]의 값을 결코 보이지 않고도 존재 증명에
    도달한다!

    여기에서 건설적 관점에서 바라볼 때 기술적 결함은 [~ ~(exists x, P
    x)] 증명을 사용하여 [exists x, P x]를 증명하였다고 주장한
    것이다. 임의의 문장에서 이중 부정을 제거하는 것을 허용하는 것은
    excluded_middle을 가정하는 것과 동일하다.  아래의 연습문제에서
    보여준다. 이렇게 이러한 논법은 새로운 공리를 추가하지 않고 콕에서
    표현할 수 없다. *)

(** **** 연습문제: 3 stars (excluded_middle_irrefutable)  *)
(** The consistency of Coq with the general excluded middle axiom
    requires complicated reasoning that cannot be carried out within
    Coq itself.  However, the following theorem implies that it is
    always safe to assume a decidability axiom (i.e., an instance of
    excluded middle) for any _particular_ Prop [P].  Why? Because we
    cannot prove the negation of such an axiom; if we could, we would
    have both [~ (P \/ ~P)] and [~ ~ (P \/ ~P)], a contradiction. *)

Theorem excluded_middle_irrefutable:  forall (P:Prop),
  ~ ~ (P \/ ~ P).
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개, 고급 (not_exists_dist)  *)
(** 다음 두 주장이 동일하다는 것은 바로 고전적 논리의 정리이다:

    ~ (exists x, ~ P x) forall x, P x

    위의 [dist_not_exists] 정리는 이 등식의 한쪽만
    증명한다. 흥미롭게도 다른 방향은 건설적 논리에서 증명할 수
    없다. 이 연습문제에서 당신이 할 일은 그 다른 방향이
    excluded_middle에서 부터 함축된다는 것을 보이는 것이다. *)

Theorem not_exists_dist :
  excluded_middle ->
  forall (X:Type) (P : X -> Prop),
    ~ (exists x, ~ P x) -> (forall x, P x).
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 다섯 개, 선택사항 (classical_axioms)  *)
(** 도전적인 사람은 Bertot와 Casteran이 작성한 책 (p. 123)에서 가져온
    연습문제를 풀어보자. 다음 네 개의 문장들 각각은
    [excluded_middle]와 함께 고전적 논리를 특징짓는 문장이라고 간주할
    수 있다. 콕으로는 어떤 것도 증명할 수 없다. 하지만 고전적 논리로
    증명하기를 원한다면 네 개 중 어떠한 것 하나를 일관성 있게 추가할
    수 있다.

    모든 다섯 개 명제 (아래 네 개와 [excluded_middle])가 동등함을
    증명하시오. *)

Definition peirce := forall P Q: Prop,
  ((P->Q)->P)->P.

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

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

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

(* 여기를 채우시오 *)
(** [] *)

(** $Date: 2017-08-22 17:13:32 -0400 (Tue, 22 Aug 2017) $ *)


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)
Set Implicit Arguments.

Require Import List.
Require Import FCF.Fold.

Section In_gen.
  Variable A : Type.
  Variable ea : A -> A -> Prop.

  Hypothesis ea_symm :
    forall a1 a2, ea a1 a2 -> ea a2 a1.

  Hypothesis ea_trans :
    forall a1 a2 a3,
      ea a1 a2 ->
      ea a2 a3 ->
      ea a1 a3.

  Fixpoint In_gen(a : A)(ls : list A) : Prop :=
    match ls with
      | nil => False
      | a' :: ls' =>
        ea a a' \/ In_gen a ls'
    end.

  Theorem In_gen_equiv_compat :
    forall (ls : list A)(a1 a2 : A),
      ea a1 a2 ->
      In_gen a1 ls ->
      In_gen a2 ls.

    induction ls; intuition; simpl in *.
    intuition.
    left.
    eapply ea_trans.
    eapply ea_symm.
    eauto.
    trivial.

    right.
    eauto.

  Qed.

End In_gen.

Theorem In_gen_eq :
  forall (A : Type)(a : A)(ls : list A),
    In a ls <-> In_gen eq a ls.

  induction ls; intuition; simpl in *.
  intuition.
  intuition.

Qed.

Section NoDup_gen.

  Variable A : Type.
  Variable ea : A -> A -> Prop.

  Inductive NoDup_gen : list A -> Prop :=
  | NoDup_gen_nil : NoDup_gen nil
  | NoDup_gen_cons :
      forall (a : A)(ls : list A),
        (~In_gen ea a ls) ->
        NoDup_gen ls ->
        NoDup_gen (a :: ls).

End NoDup_gen.

Theorem NoDup_gen_eq :
  forall (A : Type)(ls : list A),
    NoDup ls <-> NoDup_gen eq ls.

  induction ls; intuition; simpl in *.
  econstructor.
  econstructor.

  inversion H1; clear H1; subst.
  econstructor.
  intuition.
  eapply H4.
  eapply  In_gen_eq.
  trivial.
  intuition.

  inversion H1; clear H1; subst.
  econstructor.
  intuition.
  eapply H4.
  eapply In_gen_eq.
  trivial.
  intuition.

Qed.

Section NoDup_gen_map.

  Variable A B : Type.
  Variable ea : A -> A -> Prop.
  Variable eb : B -> B -> Prop.
  Variable f : A -> B.

  Hypothesis ea_symm :
    forall a1 a2,
      ea a1 a2 -> ea a2 a1.

  Hypothesis ea_trans :
    forall a1 a2 a3,
      ea a1 a2 ->
      ea a2 a3 ->
      ea a1 a3.

  Hypothesis ea_func :
    forall a1 a2, ea a1 a2 -> eb (f a1) (f a2).

  Hypothesis eb_symm :
    forall b1 b2,
      eb b1 b2 -> eb b2 b1.

  Hypothesis eb_trans :
    forall b1 b2 b3,
      eb b1 b2 ->
      eb b2 b3 ->
      eb b1 b3.

  Hypothesis ea_refl :
    forall a y,
      eb (f a) y ->
      ea a a .

  Hypothesis eb_func :
    forall a1 a2,
      eb (f a1) (f a2) -> ea a1 a2.

  Theorem In_gen_map_iff
  : forall (l : list A) (y : B),
      (In_gen eb y (map f l) <-> (exists x : A, eb (f x) y /\ In_gen ea x l)).

    induction l; intuition; simpl in *.
    intuition.
    destruct H.
    intuition.
    intuition.
    econstructor.
    intuition.
    eapply eb_symm.
    eauto.

    left.
    eapply ea_refl.
    eapply eb_symm.
    eauto.

    specialize (IHl y).
    intuition.
    destruct H2.
    intuition.
    econstructor.
    split.
    eauto.
    intuition.

    destruct H.
    intuition.
    left.
    eapply eb_trans.
    eapply eb_symm.
    eauto.
    eapply ea_func.
    trivial.

    right.
    specialize (IHl y).
    intuition.
    eapply H2.
    econstructor.
    intuition.
    eauto.
    trivial.
  Qed.

  Theorem map_NoDup_gen :
    forall (ls : list A),
      NoDup_gen ea ls ->
      NoDup_gen eb (map f ls).

    induction ls; intuition; simpl in *.
    econstructor.

    inversion H; clear H; subst.
    econstructor.
    intuition.
    eapply H2.
    eapply In_gen_map_iff in H.
    destruct H.
    intuition.
    eapply In_gen_equiv_compat; [ eauto | eauto | idtac | idtac].
    eapply eb_func.
    eauto.
    trivial.

    eauto.

  Qed.

End NoDup_gen_map.

Require Import FCF.RepeatCore.

Theorem In_gen_weaken :
  forall (A : Type)(e1 e2 : A -> A -> Prop) ls a,
    In_gen e1 a ls ->
    (forall a', e1 a a' -> e2 a a') ->
    In_gen e2 a ls.

  induction ls; intuition; simpl in *.
  intuition.

Qed.

Lemma flatten_NoDup_gen :
  forall (A : Set)(ls : list (list A)),
    NoDup_gen (fun a b => a <> nil /\ a = b) ls ->
    (forall x, In x ls -> NoDup x) ->
    (forall x1 x2, In x1 ls -> In x2 ls -> x1 <> x2 -> NoDup (x1 ++ x2)) ->
    NoDup (flatten ls).

  induction ls; intuition; simpl in *.
  econstructor.

  inversion H; clear H; subst.
  eapply app_NoDup; intuition.

  eapply in_flatten in H3.
  destruct H3.
  intuition.
  eapply app_NoDup_inv.
  eapply H1.
  right.
  eapply H6.
  left.
  reflexivity.
  intuition.
  subst.

  eapply H4.
  eapply In_gen_weaken.
  exact H6.
  intuition.
  subst.
  subst.
  simpl in *.
  intuition.
  eauto.
  eauto.

  eapply in_flatten in H2.
  destruct H2.
  intuition.
  eapply app_NoDup_inv.
  eapply H1.
  right.
  eapply H6.
  left.
  reflexivity.
  intuition.
  subst.
  eapply H4.
  eapply In_gen_weaken.
  exact H6.
  intuition.
  subst.
  subst.
  simpl in *.
  intuition.
  eauto.
  eauto.

Qed.

Theorem NoDup_gen_weaken :
  forall (A : Type)(e1 e2 : A -> A -> Prop) ls,
    NoDup_gen e1 ls ->
    (forall a1 a2, e2 a1 a2 -> e1 a1 a2) ->
    NoDup_gen e2 ls.

  induction ls; intuition; simpl in *.
  econstructor.

  inversion H; clear H; subst.
  econstructor.
  intuition.
  eapply H3.
  eapply In_gen_weaken; eauto.

  eauto.

Qed.

Theorem In_gen_zip_fst :
  forall (A B : Set)(ea : A -> A -> Prop)(lsa : list A)(lsb : list B) a b,
    In_gen (fun a b => ea (fst a) (fst b)) (a, b) (zip lsa lsb) ->
    In_gen ea a lsa.

  induction lsa; intuition; simpl in *.
  destruct lsb;
    simpl in *;
    intuition.

  right.
  eauto.
Qed.

Theorem NoDup_gen_zip_fst :
  forall (A B : Set)(ea : A -> A -> Prop)(lsa : list A)(lsb : list B),
    NoDup_gen ea lsa ->
    NoDup_gen (fun a b => ea (fst a) (fst b)) (zip lsa lsb).

  induction lsa; intuition; simpl in *.
  econstructor.

  inversion H; clear H; subst.
  destruct lsb; intuition; simpl in *.
  econstructor.

  econstructor.
  intuition.
  eapply H2.
  eapply In_gen_zip_fst.
  eauto.
  eauto.

Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Order relations                                                         *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibReflect LibOperation LibRelation.
Generalizable Variables A.

(**************************************************************************)
(* * Preorder *)

(** Definition *)

Record preorder (A:Type) (R:binary A) : Prop := {
   preorder_refl : refl R;
   preorder_trans : trans R }.

Implicit Arguments preorder_trans [A R p x z].

(** Transformations *)

Lemma preorder_flip : forall A (R:binary A),
  preorder R -> preorder (flip R).
Proof using. introv [Re Tr]. constructor; autos~ flip_trans. Qed.

Lemma preorder_large : forall A (R:binary A),
  preorder R -> preorder (large R).
Proof using. introv [Re Tr]. constructor; autos~ large_refl large_trans. Qed.

(**************************************************************************)
(* * Total preorder *)

(** Definition of total preorder relations *)

Record total_preorder (A:Type) (R:binary A) : Prop := {
   total_preorder_trans : trans R;
   total_preorder_total : total R }.

Implicit Arguments total_preorder_trans [A R x z].

(** Conversion to preorder *)

Lemma total_preorder_refl : forall A (le:binary A),
  total_preorder le -> refl le.
Proof using. introv [Tr To]. intros x. destruct~ (To x x). Qed.

Hint Resolve total_preorder_refl.

Coercion total_preorder_to_preorder A (R:binary A)
  (O:total_preorder R) : preorder R.
Proof using. lets [M _]: O. constructor~. Qed.

Hint Resolve total_preorder_to_preorder.

(** Transformations *)

Lemma total_preorder_flip : forall A (R:binary A),
  total_preorder R -> total_preorder (flip R).
Proof using. introv [Tr To]. constructor; autos~ flip_trans flip_total. Qed.

Lemma total_preorder_large : forall A (R:binary A),
  total_preorder R -> total_preorder (large R).
Proof using. introv [Re Tr]. constructor; autos~ large_trans large_total. Qed.

(** Properties *)

Lemma flip_from_not : forall A (R:binary A) x y,
  total R -> ~ R x y -> flip R x y.
Proof using. introv T H. destruct (T x y); auto_false~. Qed.

Lemma flip_strict_from_not : forall A (R:binary A) x y,
  total R -> ~ R x y -> flip (strict R) x y.
Proof using.
  introv T H. destruct (T x y). auto_false~.
  hnf. split~. intro_subst~.
Qed.

(**************************************************************************)
(* * Order *)

(** Definition *)

Record order (A:Type) (R:binary A) : Prop := {
   order_refl : refl R;
   order_trans : trans R;
   order_antisym : antisym R }.

Implicit Arguments order_trans [A R o x z].
Implicit Arguments order_antisym [A R o x y].

(** Conversion to preorder *)

Coercion order_to_preorder (A:Type) (R:binary A)
  (O:order R) : preorder R.
Proof using. destruct* O. constructors*. Qed.

Hint Resolve order_to_preorder.

(** Transformations *)

Lemma order_flip : forall A (R:binary A),
  order R -> order (flip R).
Proof using.
  introv [Re Tr An]. constructor;
  autos~ flip_trans flip_antisym.
Qed.

Lemma order_large : forall A (R:binary A),
  order R -> order (large R).
Proof using.
  introv [Re Tr An]. constructor;
  autos~ large_refl large_trans large_antisym.
Qed.

(** Properties *)

(**************************************************************************)
(* * Total Order *)

(** Definition *)

Record total_order (A:Type) (R:binary A) : Prop := {
   total_order_order :> order R;
   total_order_total : total R }.

(** Projections *)

Definition total_order_refl := order_refl.
Definition total_order_trans := order_trans.
Definition total_order_antisym := order_antisym.

Implicit Arguments total_order_trans [A R o x z].
Implicit Arguments total_order_antisym [A R o x y].

(** Construction *)

Lemma total_order_intro : forall A (R:binary A),
   trans R -> antisym R -> total R -> total_order R.
Proof using.
  introv Tra Ant Tot. constructor~. constructor~.
  intros_all. destruct~ (Tot x x).
Qed.

(** Conversion to order *)

Coercion total_order_to_total_preorder (A:Type) (R:binary A)
  (O:total_order R) : total_preorder R.
Proof using. destruct* O. constructors*. applys* order_trans. Qed.

Definition total_order_to_order := total_order_order.

Hint Resolve total_order_to_order total_order_to_total_preorder.

(** Transformations *)

Lemma total_order_flip : forall A (R:binary A),
  total_order R -> total_order (flip R).
Proof using.
  introv [Or To]. constructor;
  autos~ flip_total order_flip.
Qed.

Lemma total_order_large : forall A (R:binary A),
  total_order R -> total_order (large R).
Proof using.
  introv [Or To]. constructor;
  autos~ large_total order_large.
Qed.

(** Properties *)

Section TotalOrderProp.
Variables (A:Type) (R:binary A).
Notation "'le'" := (R).
Notation "'ge'" := (flip R).
Notation "'lt'" := (strict R).
Notation "'gt'" := (flip lt).

Hint Unfold strict flip.

Lemma total_order_le_is_large_lt :
  forall (To:total_order R),
  le = large lt.
Proof using.
  extens. intros. unfold large, strict. iff M.
  tests~: (x = y).
  destruct M. autos*. subst*. dintuition eauto.
Qed.

Lemma total_order_lt_is_strict_le :
  forall (To:total_order R),
  lt = strict le.
Proof using.
  auto.
Qed.

Lemma total_order_ge_is_large_gt :
  forall (To:total_order R),
  ge = large gt.
Proof using.
  extens. intros. unfold large, flip, strict. iff M.
  tests~: (x = y).
  destruct M. autos*. subst*. dintuition eauto.
Qed.

Lemma total_order_gt_is_strict_ge :
  forall (To:total_order R),
  gt = strict ge.
Proof using.
  extens. intros. unfold flip, large, strict. iff M.
  tests~: (x = y).
  destruct M. autos*.
  destruct M. autos*.
Qed.

Lemma total_order_lt_or_eq_or_gt :
  forall (To:total_order R), forall x y,
  lt x y \/ x = y \/ gt x y.
Proof using.
  introv H. intros. tests: (x = y).
    branch~ 2.
    destruct (total_order_total H x y).
     branch~ 1.
     branch~ 3.
Qed.

Lemma total_order_lt_or_ge :
  forall (To:total_order R), forall x y,
  lt x y \/ ge x y.
Proof using.
  intros. branches (total_order_lt_or_eq_or_gt To x y).
  left~.
  right~. subst. hnf. apply~ total_order_refl.
  right~. rewrite~ total_order_ge_is_large_gt. hnfs~.
Qed.

Lemma total_order_le_or_gt : forall x y,
  forall (To:total_order R),
  le x y \/ gt x y.
Proof using.
  intros. branches~ (total_order_lt_or_eq_or_gt To x y).
  left~. rewrite~ total_order_le_is_large_lt. hnfs~.
  left~. subst. apply~ total_order_refl.
Qed.

End TotalOrderProp.

(**************************************************************************)
(* * Strict order *)

(** Definition *)

Record strict_order (A:Type) (R:binary A) : Prop := {
   strict_order_irrefl : irrefl R;
   strict_order_asym : asym R;
   strict_order_trans : trans R }.

Implicit Arguments strict_order_trans [A R s x z].

(** Transformations *)

Lemma strict_order_flip : forall A (R:binary A),
  strict_order R -> strict_order (flip R).
Proof using.
  introv [Ir As Tr]. constructor;
  autos~ flip_antisym flip_trans flip_asym.
Qed.

Lemma strict_order_strict : forall (A:Type) (R:binary A),
  order R -> strict_order (strict R).
Proof using.
  introv [Re As Tr]. unfold strict. constructor; intros_all; simpls.
  destruct* H.
  applys* antisym_elim x y.
  split. applys* As. intros E. subst. applys* antisym_elim y z.
Qed.

Lemma order_from_strict : forall (A:Type) (R:binary A),
  strict_order R -> order (large R).
Proof using.
  introv [Re As Tr]. unfold large. constructor; simpl.
  intros_all~.
  introv [H1|E1] [H2|E2]; subst; auto.
    left. apply* trans_elim.
  introv [H1|E1] [H2|E2]; try subst; auto.
    false. apply* As.
Qed.

(**************************************************************************)
(* * Total strict order *)

(** Trichotomy *)
(* todo: move *)

Inductive trichotomy (A:Type) (R:binary A) : binary A :=
  | trichotomy_left: forall x y,
      R x y -> x <> y -> ~ R y x -> trichotomy R x y
  | trichotomy_eq : forall x,
      ~ R x x -> trichotomy R x x
  | trichotomy_right : forall x y,
      ~ R x y -> x <> y -> R y x -> trichotomy R x y.

Definition trichotomous (A:Type) (R:binary A) :=
  forall x y, trichotomy R x y.

Lemma flip_trichotomous : forall (A:Type) (R:binary A),
  trichotomous R -> trichotomous (flip R).
Proof using.
  introv H. intros x y. destruct (H x y).
  apply~ trichotomy_right.
  apply~ trichotomy_eq.
  apply~ trichotomy_left.
Qed.

(** Definition *)

Record strict_total_order (A:Type) (R:binary A) : Prop := {
   strict_total_order_trans : trans R;
   strict_total_order_trichotomous : trichotomous R }.

Implicit Arguments strict_total_order_trans [A R s x z].

(** Conversion to strict order and back *)

Lemma strict_total_order_irrefl : forall A (R:binary A),
  strict_total_order R -> irrefl R.
Proof using. introv [Tr Tk]. intros x. lets: (Tk x x). inverts~ H. Qed.

Lemma strict_total_order_asym : forall A (R:binary A),
  strict_total_order R -> asym R.
Proof using. introv [Tr Tk]. intros x y. lets: (Tk x y). inverts~ H. Qed.

Coercion strict_total_order_to_strict_order A (R:binary A)
  (O:strict_total_order R) : strict_order R.
Proof using.
  lets [M _]: O. constructor;
  autos~ strict_total_order_irrefl strict_total_order_asym.
Qed.

Hint Resolve strict_total_order_to_strict_order.

(** Transformation *)

Lemma strict_total_order_flip : forall A (R:binary A),
  strict_total_order R -> strict_total_order (flip R).
Proof using.
  introv [Tr Tk]. constructor. apply~ flip_trans.
  apply~ flip_trichotomous.
Qed.
(** From total order *)

Lemma strict_total_order_from_total_order : forall (A:Type) (R:binary A),
  total_order R -> strict_total_order (strict R).
Proof using.
  introv [[Re Tr As] To]. constructor.
  apply~ trans_strict.
  intros x y. tests: (x = y).
    subst. apply trichotomy_eq. unfolds* strict.
    unfold strict. destruct (To x y).
      apply* trichotomy_left.
      apply* trichotomy_right.
Qed.

(* ********************************************************************** *)
(** * Definition of order operators *)

(* ---------------------------------------------------------------------- *)
(** ** Classes and notation for comparison operators *)

(** Operators *)

Class Le (A : Type) := { le : binary A }.
Class Ge (A : Type) := { ge : binary A }.
Class Lt (A : Type) := { lt : binary A }.
Class Gt (A : Type) := { gt : binary A }.

Global Opaque le lt ge gt.

(** Structures *)

Class Le_preorder `{Le A} : Prop :=
  { le_preorder : preorder le }.

Class Le_total_preorder `{Le A} : Prop :=
  { le_total_preorder : total_preorder le }.

Class Le_order `{Le A} : Prop :=
  { le_order : order le }.

Class Le_total_order `{Le A} : Prop :=
  { le_total_order : total_order le }.

Class Lt_strict_order `{Lt A} : Prop :=
  { lt_strict_order : strict_order lt }.

Class Lt_strict_total_order `{Lt A} : Prop :=
  { lt_strict_total_order : strict_total_order lt }.

(** Notation *)

Notation "x <= y" := (le x y)
  (at level 70, no associativity) : comp_scope.
Notation "x >= y" := (ge x y)
  (at level 70, no associativity) : comp_scope.
Notation "x < y" := (lt x y)
  (at level 70, no associativity) : comp_scope.
Notation "x > y" := (gt x y)
  (at level 70, no associativity) : comp_scope.

Open Scope comp_scope.

Notation "x <= y <= z" := (x <= y /\ y <= z)
  (at level 70, y at next level) : comp_scope.
Notation "x <= y < z" := (x <= y /\ y < z)
  (at level 70, y at next level) : comp_scope.
Notation "x < y <= z" := (x < y /\ y <= z)
  (at level 70, y at next level) : comp_scope.
Notation "x < y < z" := (x < y /\ y < z)
  (at level 70, y at next level) : comp_scope.

(* ---------------------------------------------------------------------- *)
(** ** The operators [ge], [lt] and [gt] are deduced from [le] *)

Instance ge_from_le : forall `{Le A}, Ge A.
  constructor. apply (flip le). Defined.
Instance lt_from_le : forall `{Le A}, Lt A.
  constructor. apply (strict le). Defined.
Instance gt_from_le : forall `{Le A}, Gt A.
  constructor. apply (flip lt). Defined.

Lemma ge_is_flip_le : forall `{Le A}, ge = flip le.
Proof using. intros. apply* prop_ext_2. Qed.
Lemma lt_is_strict_le : forall `{Le A}, lt = strict le.
Proof using. intros. apply* prop_ext_2. Qed.
Lemma gt_is_flip_lt : forall `{Le A}, gt = flip lt.
Proof using. intros. apply* prop_ext_2. Qed.
Lemma gt_is_flip_strict_le : forall `{Le A}, gt = flip (strict le).
Proof using. intros. rewrite gt_is_flip_lt. rewrite~ lt_is_strict_le. Qed.

Global Opaque ge_from_le lt_from_le gt_from_le.
Hint Rewrite @gt_is_flip_strict_le @ge_is_flip_le @lt_is_strict_le : rew_to_le_def.
Tactic Notation "rew_to_le" :=
  autorewrite with rew_to_le_def in *.

Hint Rewrite @ge_is_flip_le @gt_is_flip_lt : rew_to_le_lt_def.
Tactic Notation "rew_to_le_lt" :=
  autorewrite with rew_to_le_lt_def in *.

Lemma gt_is_strict_flip_le : forall `{Le A}, gt = strict (flip le).
Proof using. intros. rew_to_le. apply flip_strict. Qed.
Lemma le_is_large_lt : forall `{Le A},
  refl le -> le = large lt.
Proof using. intros. rew_to_le. rewrite~ large_strict. Qed.
Lemma le_is_flip_ge : forall `{Le A}, le = flip ge.
Proof using. intros. rew_to_le. rewrite~ flip_flip. Qed.
Lemma lt_is_flip_gt : forall `{Le A}, lt = flip gt.
Proof using. intros. rew_to_le. rewrite~ flip_flip. Qed.
Lemma gt_is_strict_ge : forall `{Le A}, gt = strict ge.
Proof using. intros. rew_to_le. apply flip_strict. Qed.
Lemma ge_is_large_gt : forall `{Le A},
  refl le -> ge = large gt.
Proof using. intros. rewrite gt_is_strict_ge. rewrite~ large_strict. Qed.

(* ********************************************************************** *)
(** * Classes for comparison properties *)

(* ---------------------------------------------------------------------- *)
(** ** Definition of classes *)

(** symmetric structure *)

Class Ge_preorder `{Le A} : Prop :=
  { ge_preorder : preorder ge }.
Class Ge_total_preorder `{Le A} : Prop :=
  { ge_total_preorder : total_preorder ge }.
Class Ge_order `{Le A} : Prop :=
  { ge_order : order ge }.
Class Ge_total_order `{Le A} : Prop :=
  { ge_total_order : total_order le }.
Class Gt_strict_order `{Le A} : Prop :=
  { gt_strict_order : strict_order gt }.
Class Gt_strict_total_order `{Le A} : Prop :=
  { gt_strict_total_order : strict_total_order gt }.

(** properties of le *)

Class Le_refl `{Le A} :=
  { le_refl : refl le }.
Class Le_trans `{Le A} :=
  { le_trans : trans le }.
Class Le_antisym `{Le A} :=
  { le_antisym : antisym le }.
Class Le_total `{Le A} :=
  { le_total : total le }.

(** properties of ge *)

Class Ge_refl `{Ge A} :=
  { ge_refl : refl ge }.
Class Ge_trans `{Ge A} :=
  { ge_trans : trans ge }.
Class Ge_antisym `{Ge A} :=
  { ge_antisym : antisym ge }.
Class Ge_total `{Ge A} :=
  { ge_total : total ge }.

(** properties of lt *)

Class Lt_irrefl `{Lt A} :=
  { lt_irrefl : irrefl lt }.
Class Lt_trans `{Lt A} :=
  { lt_trans : trans lt }.

(** properties of gt *)

Class Gt_irrefl `{Gt A} :=
  { gt_irrefl : irrefl gt }.
Class Gt_trans `{Gt A} :=
  { gt_trans : trans gt }.

(** mixed transitivity results *)

Class Lt_Le_trans `{Le A} :=
  { lt_le_trans : forall y x z, x < y -> y <= z -> x < z }.
Class Le_Lt_trans `{Le A} :=
  { le_lt_trans : forall y x z, x <= y -> y < z -> x < z }.
Class Gt_Ge_trans `{Le A} :=
  { gt_ge_trans : forall y x z, x > y -> y >= z -> x > z }.
Class Ge_Gt_trans `{Le A} :=
  { ge_gt_trans : forall y x z, x >= y -> y > z -> x > z }.

Implicit Arguments lt_irrefl [A H Lt_irrefl].
Implicit Arguments le_trans [[A] [H] [Le_trans] x z].
Implicit Arguments ge_trans [[A] [H] [Ge_trans] x z].
Implicit Arguments lt_trans [[A] [H] [Lt_trans] x z].
Implicit Arguments gt_trans [[A] [H] [Gt_trans] x z].

(** conversion between operators *)

Class Ge_As_SLe `{Le A} : Prop :=
  { ge_as_sle : forall x y : A, (x >= y) = (y <= x) }.

Class Gt_As_SLt `{Le A} : Prop :=
  { gt_as_slt : forall x y : A, (x > y) = (y < x) }.

Class NGt_As_SLe `{Le A} : Prop :=
  { ngt_as_sle : forall x y : A, (~ x < y) = (y <= x) }.

Class NLt_As_Ge `{Le A} : Prop :=
  { nlt_as_ge : forall x y : A, (~ x < y) = (x >= y) }.

Class NGt_As_Le `{Le A} : Prop :=
  { ngt_as_le : forall x y : A, (~ x > y) = (x <= y) }.

Class NLe_As_Gt `{Le A} : Prop :=
  { nle_as_gt : forall x y : A, (~ x <= y) = (x > y) }.

Class NGe_As_Lt `{Le A} : Prop :=
  { nge_as_lt : forall x y : A, (~ x >= y) = (x < y) }.

(** inclusion between operators *)

Class Lt_to_Le `{Le A} : Prop :=
  { lt_to_le : forall x y : A, (x < y) -> (x <= y) }.

Class Gt_to_Ge `{Le A} : Prop :=
  { gt_to_ge : forall x y : A, (x > y) -> (x >= y) }.

Class NLe_to_SLe `{Le A} : Prop :=
  { nle_to_sle : forall x y : A, (~ x <= y) -> (y <= x) }.

Class NLe_to_SLt `{Le A} : Prop :=
  { nle_to_slt : forall x y : A, (~ x <= y) -> (y < x) }.

(** case analysis *)

Class Case_Eq_Lt_Gt `{Le A} : Prop :=
  { case_eq_lt_gt : forall x y : A, x = y \/ x < y \/ x > y }.

Class Case_Eq_Lt_SLt `{Le A} : Prop :=
  { case_eq_lt_slt : forall x y : A, x = y \/ x < y \/ y < x }.

Class Case_Le_Gt `{Le A} : Prop :=
  { case_le_gt : forall x y : A, x <= y \/ x > y }.

Class Case_Le_SLt `{Le A} : Prop :=
  { case_le_slt : forall x y : A, x <= y \/ y < x }.

Class Case_Lt_Ge `{Le A} : Prop :=
  { case_lt_ge : forall x y : A, x < y \/ x >= y }.

Class Case_Lt_SLe `{Le A} : Prop :=
  { case_lt_sle : forall x y : A, x < y \/ y <= x }.

(** case analysis under one assumption *)

Class Neq_Case_Lt_Gt `{Le A} : Prop :=
  { neq_case_lt_gt : forall x y : A, x <> y -> x < y \/ x > y }.

Class Neq_Case_Lt_SLt `{Le A} : Prop :=
  { neq_case_lt_slt : forall x y : A, x <> y -> x < y \/ y < x }.

Class Le_Case_Eq_Lt `{Le A} : Prop :=
  { le_case_eq_lt : forall x y : A, x <= y -> x = y \/ x < y }.

Class Ge_Case_Eq_Gt `{Le A} : Prop :=
  { ge_case_eq_gt : forall x y : A, x >= y -> x = y \/ x > y }.

(** case analysis under two assumptions *)

Class Le_NEq_To_Lt `{Le A} : Prop :=
  { le_neq_to_lt : forall x y : A, x <= y -> x <> y -> x < y }.

Class Ge_NEq_To_Gt `{Le A} : Prop :=
  { ge_neq_to_gt : forall x y : A, x >= y -> x <> y -> x > y }.

Class NLt_NSLt_To_Eq `{Le A} : Prop :=
  { nlt_nslt_to_eq : forall x y : A, ~ (lt x y) -> ~ (lt y x) -> x = y }.

(** contradiction from case analysis *)

Class Lt_Ge_false `{Le A} : Prop :=
  { lt_ge_false : forall x y : A, x < y -> x >= y -> False }.

Class Lt_Gt_false `{Le A} : Prop :=
  { lt_gt_false : forall x y : A, x < y -> x > y -> False }.

Class Lt_SLt_false `{Le A} : Prop :=
  { lt_slt_false : forall x y : A, x < y -> y < x -> False }.

(* ********************************************************************** *)
(* * Instances for comparison structures *)

Section Instances.
Context `{Le A}.

Ltac auto_star ::= try solve [ dauto ].

(** derived structures *)

Global Instance le_preorder_from_le_order :
  Le_order -> Le_preorder.
Proof using. constructor. intros. apply* order_to_preorder. Qed.

Global Instance le_total_preorder_from_le_total_order :
  Le_total_order -> Le_total_preorder.
Proof using. constructor. intros. apply* total_order_to_total_preorder. Qed.

Global Instance le_preorder_from_total_preorder :
  Le_total_preorder -> Le_preorder.
Proof using. constructor. intros. apply* total_preorder_to_preorder. Qed.

Global Instance le_order_from_le_total_order :
  Le_total_order -> Le_order.
Proof using. constructor. intros. apply* total_order_to_order. Qed.

Global Instance lt_strict_order_from_lt_strict_total_order :
  Lt_strict_total_order -> Lt_strict_order.
Proof using. constructor. intros. apply* strict_total_order_to_strict_order. Qed.

Global Instance lt_strict_order_from_le_order :
  Le_order -> Lt_strict_order.
Proof using. constructor. intros. rew_to_le. apply* strict_order_strict. Qed.

Global Instance lt_strict_total_order_from_le_total_order :
  Le_total_order -> Lt_strict_total_order.
Proof using. constructor. intros. rew_to_le. apply* strict_total_order_from_total_order. Qed.

(** symmetric structures *)

Global Instance ge_preorder_from_le_order :
  Le_order -> Ge_preorder.
Proof using. constructor. rew_to_le. apply preorder_flip. apply le_preorder. Qed.

Global Instance ge_total_preorder_from_le_total_order :
  Le_total_order -> Ge_total_preorder.
Proof using. constructor. rew_to_le. apply total_preorder_flip. apply le_total_preorder. Qed.

Global Instance ge_preorder_from_total_preorder :
  Le_total_preorder -> Ge_preorder.
Proof using. constructor. rew_to_le. apply preorder_flip. apply le_preorder. Qed.

Global Instance ge_order_from_le_total_order :
  Le_total_order -> Ge_order.
Proof using. constructor. rew_to_le. apply order_flip. apply le_order. Qed.

Global Instance gt_strict_order_from_lt_strict_total_order :
  Lt_strict_total_order -> Gt_strict_order.
Proof using. constructor. rewrite gt_is_flip_lt. apply strict_order_flip. apply lt_strict_order. Qed.

Global Instance gt_strict_order_from_le_order :
  Le_order -> Gt_strict_order.
Proof using. constructor. rewrite gt_is_flip_lt. apply strict_order_flip. apply lt_strict_order. Qed.

Global Instance gt_strict_total_order_from_le_total_order :
  Le_total_order -> Gt_strict_total_order.
Proof using. constructor. rewrite gt_is_flip_lt. apply strict_total_order_flip. apply lt_strict_total_order. Qed.

(** properties of le *)

Global Instance le_refl_from_le_preorder :
  Le_preorder -> Le_refl.
Proof using. intros [[Re Tr]]. constructor~. Qed.

Global Instance le_trans_from_le_preorder :
  Le_preorder -> Le_trans.
Proof using. intros [[Re Tr]]. constructor~. Qed.

Global Instance le_antisym_from_le_order :
  Le_order -> Le_antisym.
Proof using. constructor. intros. apply* order_antisym. Qed.

Global Instance le_total_from_le_total_order :
  Le_total_order -> Le_total.
Proof using. constructor. intros. apply* total_order_total. Qed.

(** properties of ge *)

Global Instance ge_refl_from_le_preorder :
  Le_preorder -> Ge_refl.
Proof using. constructor. rew_to_le. apply flip_refl. apply le_refl. Qed.

Global Instance ge_trans_from_le_preorder :
  Le_preorder -> Ge_trans.
Proof using. constructor. rew_to_le. apply flip_trans. apply le_trans. Qed.

Global Instance ge_antisym_from_le_order :
  Le_order -> Ge_antisym.
Proof using. constructor. rew_to_le. apply flip_antisym. apply le_antisym. Qed.

Global Instance ge_total_from_le_total_order :
  Le_total_order -> Ge_total.
Proof using. constructor. rew_to_le. apply flip_total. apply le_total. Qed.

(** properties of lt *)

Global Instance lt_irrefl_from_le_order :
  Le_order -> Lt_irrefl.
Proof using. constructor. apply strict_order_irrefl. apply lt_strict_order. Qed.

Global Instance lt_trans_from_le_order :
  Le_order -> Lt_trans.
Proof using. constructor. apply strict_order_trans. apply lt_strict_order. Qed.

(** properties of gt *)

Global Instance gt_irrefl_from_le_order :
  Le_order -> Gt_irrefl.
Proof using. constructor. apply strict_order_irrefl. apply gt_strict_order. Qed.

Global Instance gt_trans_from_le_order :
  Le_order -> Gt_trans.
Proof using. constructor. apply strict_order_trans. apply gt_strict_order. Qed.

(** mixed transitivity results *)

Global Instance lt_le_trans_from : Le_order -> Lt_Le_trans.
Proof using.
  constructor. introv K L. rew_to_le. destruct K as [U V].
  split~. apply* le_trans. intro_subst. apply V. apply* le_antisym.
Qed.

Global Instance le_le_trans_from : Le_order -> Le_Lt_trans.
Proof using.
  constructor. introv K L. rew_to_le. destruct L as [U V].
  split~. apply* le_trans. intro_subst. apply V. apply* le_antisym.
Qed.

Global Instance gt_ge_trans_from : Le_order -> Gt_Ge_trans.
Proof using.
  constructor. introv K L. rew_to_le_lt. hnf in *. apply* le_lt_trans.
Qed.

Global Instance ge_gt_trans_from : Le_order -> Ge_Gt_trans.
Proof using.
  constructor. introv K L. rew_to_le_lt. hnf in *. apply* lt_le_trans.
Qed.
(** conversion between operators *)

Global Instance ge_as_sle_from : Ge_As_SLe.
Proof using. constructor. intros. rew_to_le. auto. Qed.

Global Instance gt_as_slt_from : Gt_As_SLt.
Proof using. constructor. intros. rew_to_le. auto. Qed.

Global Instance ngt_as_sle_from : Le_total_order -> NGt_As_SLe.
Proof using.
  constructor. intros. rew_to_le. unfold strict. rew_logic. iff M.
  destruct M.
    forwards K:(flip_strict_from_not (R:=le)); eauto.
      apply le_total. apply (proj1 K).
    subst. apply le_refl.
  apply classic_left. intros P Q. apply P. apply* le_antisym.
Qed.

Global Instance nlt_as_ge_from : Le_total_order -> NLt_As_Ge.
Proof using. constructor. intros. rew_to_le_lt. unfold flip. apply ngt_as_sle. Qed.

Global Instance ngt_as_le_from : Le_total_order -> NGt_As_Le.
Proof using. constructor. intros. rew_to_le_lt. unfold flip. apply ngt_as_sle. Qed.

Global Instance nle_as_gt_from : Le_total_order -> NLe_As_Gt.
Proof using.
  constructor. intros. rew_to_le_lt. unfold flip.
  rewrite <- ngt_as_sle. rewrite~ not_not.
Qed.

Global Instance nge_as_lt_from : Le_total_order -> NGe_As_Lt.
Proof using.
  constructor. intros. rew_to_le_lt. unfold flip.
  rewrite nle_as_gt. rewrite~ gt_is_flip_lt.
Qed.

(** inclusion between operators *)

Global Instance lt_to_le_from : Lt_to_Le.
Proof using. constructor. intros. rew_to_le. unfolds* strict. Qed.

Global Instance gt_to_ge_from : Gt_to_Ge.
Proof using. constructor. intros. rew_to_le. unfolds* flip, strict. Qed.

Global Instance nle_to_sle_from : Le_total_order -> NLe_to_SLe.
Proof using.
  constructor. introv K. rewrite nle_as_gt in K.
  rew_to_le. unfolds* flip, strict.
Qed.

Global Instance nle_to_slt_from : Le_total_order -> NLe_to_SLt.
Proof using.
  constructor. introv K. rewrite nle_as_gt in K.
  rew_to_le. unfolds* flip, strict.
Qed.

(** case analysis under no assumption *)

Global Instance case_eq_lt_gt_from : Le_total_order -> Case_Eq_Lt_Gt.
Proof using.
  introv K. constructor. intros.
  lets [(M1&M2)|[M|(M1&M2)]]: (total_order_lt_or_eq_or_gt le_total_order x y).
    rewrite le_is_large_lt in M1 by applys* total_order_refl. destruct* M1.
    autos*.
    rewrite le_is_large_lt in M1 by applys* total_order_refl. destruct* M1.
Qed.

Global Instance case_eq_lt_slt_from : Le_total_order -> Case_Eq_Lt_SLt.
Proof using.
  constructor. intros. pattern lt at 2. rewrite lt_is_flip_gt.
  apply case_eq_lt_gt.
Qed.

Global Instance case_le_gt_from : Le_total_order -> Case_Le_Gt.
Proof using.
  constructor. intros.
  rewrite le_is_large_lt by applys* total_order_refl. unfold large.
  branches (total_order_lt_or_eq_or_gt le_total_order x y); eauto.
Qed.

Global Instance case_eq_lt_ge_from : Le_total_order -> Case_Lt_Ge.
Proof using.
  constructor. intros.
  rewrite ge_is_large_gt by applys* total_order_refl. unfold large.
  branches (total_order_lt_or_eq_or_gt le_total_order x y); eauto.
Qed.

Global Instance case_le_slt_from : Le_total_order -> Case_Le_SLt.
Proof using. constructor. intros. rewrite lt_is_flip_gt. apply case_le_gt. Qed.

Global Instance case_eq_lt_sle_from : Le_total_order -> Case_Lt_SLe.
Proof using. constructor. intros. rewrite le_is_flip_ge. apply case_lt_ge. Qed.

(** case analysis under one assumption *)

Global Instance neq_case_lt_gt_from : Le_total_order -> Neq_Case_Lt_Gt.
Proof using. constructor. intros. destruct* (case_eq_lt_gt x y). Qed.

Global Instance neq_case_lt_slt_from : Le_total_order -> Neq_Case_Lt_SLt.
Proof using. constructor. intros. destruct* (case_eq_lt_gt x y). Qed.

Global Instance le_case_eq_lt_from : Le_total_order -> Le_Case_Eq_Lt.
Proof using. constructor. intros. rew_to_le. unfold strict. tests*: (x = y). Qed.

Global Instance ge_case_eq_gt_from : Le_total_order -> Ge_Case_Eq_Gt.
Proof using. constructor. intros. rew_to_le. unfold flip, strict. tests*: (x = y). Qed.

(** case analysis under two assumptions *)

Global Instance le_neq_to_lt_from : Le_total_order -> Le_NEq_To_Lt.
Proof using. constructor. intros. rew_to_le. hnfs*. Qed.

Global Instance ge_neq_to_gt_from : Le_total_order -> Ge_NEq_To_Gt.
Proof using. constructor. intros. rew_to_le. hnfs*. Qed.

Global Instance nlt_nslt_to_eq_from : Le_total_order -> NLt_NSLt_To_Eq.
Proof using. constructor. intros. branches* (case_eq_lt_gt x y). Qed.

(** contradiction from case analysis *)

Global Instance lt_ge_false_from : Le_total_order -> Lt_Ge_false.
Proof using. constructor. introv H1 H2. rewrite~ <- nlt_as_ge in H2. Qed.

Global Instance lt_gt_false_from : Le_total_order -> Lt_Gt_false.
Proof using.
  constructor. introv H1 H2. rewrite~ <- nle_as_gt in H2.
  apply H2. apply* lt_to_le.
Qed.

Global Instance lt_slt_false_from_le_order :
  Le_total_order -> Lt_SLt_false.
Proof using.
  constructor. introv H1 H2. rewrite <- gt_as_slt in H2.
  apply* lt_gt_false.
Qed.

End Instances.

Implicit Arguments nle_to_sle [[A] [H] [NLe_to_SLe] x y].

(* ********************************************************************** *)
(* * Order modulo -- todo: move *)

Record order_wrt (A:Type) (E:binary A) (R:binary A) : Prop := {
   order_wrt_refl : refl R;
   order_wrt_trans : trans R;
   order_wrt_antisym : antisym_wrt E R }.

(* ********************************************************************** *)
(** * Boolean comparison *)

Open Scope comp_scope.

(** Additional notation for reflected boolean comparison.
    Use [Open Scope comp_scope_reflect] to use them. *)

Notation "x ''<=' y" := (isTrue (@le _ _ x y))
  (at level 70, no associativity) : comp_scope_reflect.
Notation "x ''>=' y" := (isTrue (@ge _ _ x y))
  (at level 70, no associativity) : comp_scope_reflect.
Notation "x ''<' y" := (isTrue (@lt _ _ x y))
  (at level 70, no associativity) : comp_scope_reflect.
Notation "x ''>' y" := (isTrue (@gt _ _ x y))
  (at level 70, no associativity) : comp_scope_reflect.


Load Functor.

Definition hom_pairing {C D : Category} a b :=
  prod (Hom C (fst a) (fst b)) (Hom D (snd a) (snd b)).

Definition id_pairing {C D : Category} (a : Ob C * Ob D) :=
  (@Id _ (fst a), @Id _ (snd a)).

Definition comp_pairing
           {C D : Category}
           (a b c: Ob C * Ob D)
           (f : hom_pairing a b)
           (g : hom_pairing b c) :=
  (Comp _ (fst f) (fst g), Comp _ (snd f) (snd g)).

Variable C D : Category.
Variable a : Ob C.
Variable b : Ob D.
Check @Id _ a.
Check hom_pairing (a, b) (a, b).
Check Build_Category ((Ob C) * (Ob D)) (hom_pairing).
Check hom_pairing.
Check id_pairing.
Check snd.

Definition Product (C D : Category) : Category.
  apply (Build_Category
           ((Ob C) * (Ob D))
           (hom_pairing)
           (fun a => id_pairing a)
           (fun a b c f g => comp_pairing a b c f g)
        ).

  unfold comp_pairing, id_pairing, hom_pairing.
  intros.
  simpl.
  rewrite (idl C), (idl D).
  simpl.
  symmetry.
  apply surjective_pairing.

  unfold comp_pairing, id_pairing, hom_pairing.
  intros.
  simpl.
  rewrite (idr C), (idr D).
  symmetry.
  apply surjective_pairing.

  unfold comp_pairing, id_pairing, hom_pairing.
  intros.
  simpl.
  rewrite <- (assoc C (fst f) (fst g) (fst h)),
             (assoc D (snd f) (snd g) (snd h)).
  trivial.
Defined.

Definition PiFst : Functor (Product C D) C.
  apply (Build_Functor _ _ _
                       (fun a b (f: Hom (Product C D) a b) => fst f)).
  simpl.
  trivial.

  simpl.
  trivial.
Defined.

Definition PiSnd : Functor (Product C D) D.
  apply (Build_Functor _ _ _
                       (fun a b (f: Hom (Product C D) a b) => snd f)).
  simpl.
  trivial.

  simpl.
  trivial.
Defined.


Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.TruncType.

(** Demonstrate the [HProp] is a (bounded) lattice w.r.t. the logical
operations. This requires Univalence. *)
Global Instance join_hor : Join HProp := hor.
Definition hand (X Y : HProp) : HProp := Build_HProp (X * Y).
Global Instance meet_hprop : Meet HProp := hand.
Global Instance bottom_hprop : Bottom HProp := False_hp.
Global Instance top_hprop : Top HProp := Unit_hp.

Section contents.
  Context `{Univalence}.

  (* We use this notation because [hor] can accept arguments of type [Type], which leads to minor confusion in the instances below *)
  Notation lor := (hor : HProp -> HProp -> HProp).

  (* This tactic attempts to destruct a truncated sum (disjunction) *)
  Local Ltac hor_intros :=
    let x := fresh in
    intro x; repeat (strip_truncations; destruct x as [x | x]).

  Instance commutative_hor : Commutative lor.
  Proof.
    intros ??.
    apply path_iff_hprop; hor_intros; apply tr; auto.
  Defined.

  Instance commutative_hand : Commutative hand.
  Proof.
    intros ??.
    apply path_hprop.
    apply equiv_prod_symm.
  Defined.

  Instance associative_hor : Associative lor.
  Proof.
    intros ???.
    apply path_iff_hprop;
    hor_intros; apply tr;
    ((by auto) || (left; apply tr) || (right; apply tr));
    auto.
  Defined.

  Instance associative_hand : Associative hand.
  Proof.
    intros ???.
    apply path_hprop.
    apply equiv_prod_assoc.
  Defined.

  Instance idempotent_hor : BinaryIdempotent lor.
  Proof.
    intros ?. compute.
    apply path_iff_hprop; hor_intros; auto.
    by apply tr, inl.
  Defined.

  Instance idempotent_hand : BinaryIdempotent hand.
  Proof.
    intros ?.
    apply path_iff_hprop.
    - intros [a _] ; apply a.
    - intros a; apply (pair a a).
  Defined.

  Instance leftidentity_hor : LeftIdentity lor False_hp.
  Proof.
    intros ?.
    apply path_iff_hprop; hor_intros; try contradiction || assumption.
    by apply tr, inr.
  Defined.

  Instance rightidentity_hor : RightIdentity lor False_hp.
  Proof.
    intros ?.
    apply path_iff_hprop; hor_intros; try contradiction || assumption.
    by apply tr, inl.
  Defined.

  Instance leftidentity_hand : LeftIdentity hand Unit_hp.
  Proof.
    intros ?.
    apply path_trunctype, prod_unit_l.
  Defined.

  Instance rightidentity_hand : RightIdentity hand Unit_hp.
  Proof.
    intros ?.
    apply path_trunctype, prod_unit_r.
  Defined.

  Instance absorption_hor_hand : Absorption lor hand.
  Proof.
    intros ??.
    apply path_iff_hprop.
    - intros X; strip_truncations.
      destruct X as [? | [? _]]; assumption.
    - intros ?. by apply tr, inl.
  Defined.

  Instance absorption_hand_hor : Absorption hand lor.
  Proof.
    intros ??.
    apply path_iff_hprop.
    - intros [? _]; assumption.
    - intros ?.
      split.
      * assumption.
      * by apply tr, inl.
  Defined.

  Global Instance boundedlattice_hprop : IsBoundedLattice HProp.
  Proof. repeat split; apply _. Defined.
End contents.


Require Export Iron.SimplePCFa.Value.

(******************************************************************************)
(* Primitive reduction step. *)
Inductive STEPP : exp -> exp -> Prop :=
 (* Application *)
 | SpAppLam
   : forall t11 x12 v2
   , STEPP (XApp (VLam t11 x12) v2)
           (substVX 0 v2 x12)

 | SpAppFix
   : forall t1 v2 v3
   , STEPP (XApp (VFix t1 v2) v3)
           (XApp (substVV 0 (VFix t1 v2) v2) v3)

 (* Naturals *)
 | SpSucc
   : forall n
   , STEPP (XOp1 OSucc (VConst (CNat n)))
           (XVal (VConst (CNat (S n))))

 | SpPredZero
   : STEPP (XOp1 OPred (VConst (CNat O)))
           (XVal (VConst (CNat O)))

 | SpPredSucc
   : forall n
   , STEPP (XOp1 OPred (VConst (CNat (S n))))
           (XVal (VConst (CNat n)))

 (* Booleans *)
 | SpIsZeroTrue
   : STEPP (XOp1 OIsZero (VConst (CNat O)))
           (XVal (VConst (CBool true)))

 | SpIsZeroFalse
   : forall n
   , STEPP (XOp1 OIsZero (VConst (CNat (S n))))
           (XVal (VConst (CBool false)))

 (* Branching *)
 | SpIfThen
   : forall x1 x2
   , STEPP (XIf (VConst (CBool true)) x1 x2) x1

 | SpIfElse
   : forall x1 x2
   , STEPP (XIf (VConst (CBool false)) x1 x2) x2.
Hint Constructors STEPP.

(* Single step reduction.
   This judgement contains the rule for 'let', which is the only form
   that holds a context while it reduces an expression. *)
Inductive STEP : exp -> exp -> Prop :=
 | SPrim
   :  forall x1 x2
   ,  STEPP x1 x2
   -> STEP  x1 x2

 | SLetStep
   :  forall t1 x1 x1' x2
   ,  STEP x1 x1'
   -> STEP (XLet t1 x1  x2)
           (XLet t1 x1' x2)

 | SLetSub
   : forall t1 v1 x2
   , STEP (XLet t1 (XVal v1) x2)
          (substVX 0 v1 x2).
Hint Constructors STEP.

(********************************************************************)
(** Multi-step evaluation. *)
Inductive STEPS : exp -> exp -> Prop :=
 | SsNone
   :  forall x1
   ,  STEPS x1 x1

 (* Take a single step. *)
 | SsStep
   :  forall x1 x2
   ,  STEP  x1 x2
   -> STEPS x1 x2

 (* Combine two evaluations into a third. *)
 | SsAppend
   :  forall x1 x2 x3
   ,  STEPS x1 x2 -> STEPS x2 x3
   -> STEPS x1 x3.

Hint Constructors STEPS.

(* TODO *)
Lemma steps_context_let1
 :  forall t1 x1 x1' x2
 ,  STEPS x1 x1'
 -> STEPS (XLet t1 x1 x2) (XLet t1 x1' x2).
Proof.
 admit.
Qed.


Require Import Coq.Classes.Equivalence.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Unicode.Utf8.

Generalizable All Variables.

Reserved Notation "x ⊔ y" (at level 36, left associativity).
Reserved Notation "x ⊓ y" (at level 40, left associativity).
Reserved Notation "⊥" (at level 0).
Reserved Notation "⊤" (at level 0).

Definition equiv `{Equivalence A} := Equivalence.equiv.

Local Open Scope equiv_scope.

Class Lattice (A : Type) `{Equivalence A} : Type := {
  meet : A → A → A where "x ⊓ y" := (meet x y);
  join : A → A → A where "x ⊔ y" := (join x y);
  top : A;
  bot : A;

  (* These exact axioms are taken from the nlab page on lattices *)
  meet_commutative : ∀ a b, a ⊓ b === b ⊓ a;
  meet_idempotent : ∀ a, a ⊓ a === a;
  meet_associative : ∀ a b c, a ⊓ (b ⊓ c) === (a ⊓ b) ⊓ c;

  join_commutative : ∀ a b, a ⊔ b === b ⊔ a;
  join_idempotent : ∀ a, a ⊔ a === a;
  join_associative : ∀ a b c, a ⊔ (b ⊔ c) === (a ⊔ b) ⊔ c;

  join_meet_absorptive : ∀ a b, a ⊔ (a ⊓ b) === a;
  meet_join_absorptive : ∀ a b, a ⊓ (a ⊔ b) === a;

  meet_id : ∀ a, a ⊓ top === a;
  join_id : ∀ a, a ⊔ bot === a;

  (* Welcome to "Setoid-Hell" *)
  meet_respectful :> Proper (equiv ==> equiv ==> equiv) meet;
  join_respectful :> Proper (equiv ==> equiv ==> equiv) join;
}.

Notation "x ⊓ y" := (meet x y).
Notation "x ⊔ y" := (join x y).
Notation "⊤" := top.
Notation "⊥" := bot.

Module Lattice.
Section Lattice.

  Context {A : Type} {equ : A → A → Prop}.
  Context {E : Equivalence equ}.
  Context {L : Lattice A}.

  Definition le_meet a b := a ⊓ b === a.

  Instance Reflexive_le_meet : Reflexive le_meet := meet_idempotent.

  Instance Transitive_le_meet : Transitive le_meet.
  Proof.
    intros x y z P Q.
    unfold le_meet in *.
    rewrite <- P.
    rewrite <- Q.
    rewrite meet_associative.
    rewrite <- meet_associative.
    rewrite meet_idempotent.
    reflexivity.
  Qed.

  Instance PreOrder_le_meet : PreOrder le_meet := {|
    PreOrder_Reflexive := Reflexive_le_meet;
    PreOrder_Transitive := Transitive_le_meet;
  |}.

  Instance PartialOrder_le_meet : PartialOrder equ le_meet.
  Proof.
    intros x y.
    split; intros H.
    - split.
      + unfold le_meet.
        rewrite <- (meet_respectful x x (reflexivity x) x y H).
        apply meet_idempotent.
      + unfold le_meet, Basics.flip.
        rewrite (meet_respectful y y (reflexivity y) x y H).
        apply meet_idempotent.
    - destruct H as [H1 H2].
      unfold le_meet, Basics.flip in *.
      rewrite <- H1 in *.
      rewrite (meet_commutative x y) in H2.
      rewrite meet_associative in H2.
      rewrite meet_idempotent in H2.
      rewrite meet_commutative in H2.
      apply H2.
  Qed.

  Definition le_join a b := a ⊔ b === b.

  Lemma le_meet_join : ∀ a b, le_meet a b ↔ le_join a b.
  Proof.
    intros a b.
    unfold le_meet, le_join in *.
    split.
    - intros H.
      rewrite <- H.
      rewrite meet_commutative.
      rewrite join_commutative.
      apply join_meet_absorptive.
    - intros H.
      rewrite <- H.
      apply meet_join_absorptive.
  Qed.

  Instance Reflexive_le_join : Reflexive le_join := join_idempotent.
  Instance Transitive_le_join : Transitive le_join.
  Proof.
    intros x y z.
    do 3 rewrite <- le_meet_join.
    apply Transitive_le_meet.
  Qed.
  Instance PreOrder_le_join : PreOrder le_join := {|
    PreOrder_Reflexive := Reflexive_le_join;
    PreOrder_Transitive := Transitive_le_join;
  |}.
  Instance PartialOrder_le_join : PartialOrder equ le_join.
  Proof.
    intros x y.
    unfold pointwise_lifting, relation_conjunction, Basics.flip, predicate_intersection, pointwise_extension.
    do 2 rewrite <- le_meet_join.
    apply PartialOrder_le_meet.
  Qed.

End Lattice.
End Lattice.


Require Import Coq.Setoids.Setoid.

Lemma drop_antecedent:
  forall P Q: Prop, P -> (P -> Q) <-> Q.
Proof.
  tauto.
Qed.

Lemma drop_antecedent_3:
  forall (A B C D : Prop),
  A ->
  B ->
  C ->
  (A -> B -> C -> D) <-> D.
Proof.
  intros.
  do 3 (erewrite drop_antecedent; eauto).
  eapply iff_refl.
Qed.