(** * 리스트: 구조적 데이터를 가지고 작업하기 *)

Require Export Induction.
Module NatList.

(* ################################################################# *)
(** * 숫자들의 쌍들 *)

(** [Inductive] 정의에서 각 생성자는 어떤 개수의 인자들을 받을 수
    있다. [true]와 [O]와 같이 인자를 받지 않는 생성자, [S]와 같이
    하나의 인자를 받는 생성자가 있고, 다음 예에서 하나 이상을 받는
    생성자를 보여준다. *)

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

(** 이 선언을 읽는 법은 "숫자들 쌍을 만드는 단 한 가지 방법이 있는데,
    생성자 [pair]를 [nat] 타입의 두 인자들에 적용하는 것이다."  *)

Check (pair 3 5).

(** 쌍에서 첫 번째와 두 번째 요소들을 꺼내는 두 개의 간단한 함수들이
    있다.  이 정의들은 또한 두 개의 인자를 받은 생성자들에 대해 패턴
    매치를 하는 법도 보여준다. *)

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

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

Compute (fst (pair 3 5)).
(* ===> 3 *)

(** 쌍들은 상당히 자주 사용되기 때문에 [pair x y] 대신에 표준 수학
    표기법 [(x,y)]으로 쓸 수 있으면 좋을 것이다. 콕에서 [Notation]
    선언으로 가능하다. *)

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

(** 쌍에 대한 새로운 표기법은 식과 패턴 매치에서 모두 사용될 수
    있다. ([Basics] 장의 [minus] 함수의 정의에서 사실 이미
    보았다. 표준 라이브러리 일부로 쌍에 대한 표기법도 제공하기 때문에
    동작한 것이다. *)

Compute (fst (3,5)).

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

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

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

(** 쌍들에 대한 몇 가지 간단한 사실들을 증명해보자.

    특별한 방법으로 이 명제들을 서술하면 reflexivity (와 그리고 내장된
    간략화) 만으로 증명들을 완성할 수 있다. *)

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

(** 하지만 만일 보조 정리를 더 자연스러운 방법으로 서술하면
    [reflexivity]만으로 충분하지 않다. *)

Theorem surjective_pairing_stuck : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  simpl. (* 아무것도 간략화되지 않는다! *)
Abort.

(** [p]의 구조를 드러내서 [simpl]로 [fst]와 [snd]에서의 패턴 매치를
    수행할 수 있어야 한다. 이것은 [destruct]를 가지고 할 수 있다. *)

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

(** [nat] 타입의 값들을 가지고 다룰 때와 달리 [destruct]는 단 하나의 부분
    목적 만을 만든다는 것을 주목하시오. [natprod] 타입의 값들은 한 가지 방법으로만
    생성할 수 있기 때문이다. *)

(** **** 연습문제: 별 하나 (snd_fst_is_swap)  *)
Theorem snd_fst_is_swap : forall (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 하나, 선택사항 (fst_swap_is_snd)  *)
Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(* ################################################################# *)
(** * 숫자 리스트 *)

(** 쌍에 대한 정의를 일반화하면 다음과 같이 숫자 _리스트_의 타입을
    기술할 수 있다.  "리스트는 비어있는 리스트이거나 숫자와 또 다른
    리스트의 쌍이다." *)

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

(** 예를 들어, 세 개의 원소를 갖는 리스트가 여기 있다. *)

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

(** 쌍들을 다룰 때와 같이 익숙한 프로그래밍 표기법으로 리스트를 쓰는 것이
    더 편리하다. 다음 선언들로 [::]을 중위 표기 [cons]로 사용하고
    대괄호를 리스트를 만드는 "바깥쪽을 감싸는" 표기법으로 사용할 수 있다. *)

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

(** 이 선언들을 자세하게 이해할 필요는 없지만 관심이 있다면 여기 대강
    설명한다.  [right associativity] 주석을 달아 콕으로 하여금 [::]을
    여러 번 사용한 식 들에서 괄호를 어떻게 씌울지 정한다. 예를 들어
    다음 세 가지 선언들은 모두 동일한 의미를 갖는다. *)

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

(** [at level 60]은 [::]과 다른 중위 연산자를 함께 사용한 식들에서
    괄호를 어떻게 매길지 정한다. 예를 들어, [+]를 [plus] 함수에 대한
    중위 표기법으로 50 레벨로 정의하였기 때문에,

  Notation "x + y" := (plus x y) (at level 50, left associativity).

   [+] 연산자는 [::]보다 더 빨리 묶인다. 그래서 [1 + 2 :: [3]]은 콕이
   우리가 기대한 대로 [(1 + 2) :: [3]]으로 해석하고, [1 + (2 ::
   [3])]으로 해석하지 않는다.

   (.v 파일에서 "[1 + 2 :: [3]]"와 같은 식을 읽을 때 조금 혼동스러울
   수 있다. 3을 감싸는 안쪽 괄호는 리스트를 표시하지만, 바깥쪽
   괄호(HTML에서 보이지 않는)는 "coqdoc" 도구가 텍스트가 아니라 콕
   코드로 표시해야 한다는 명령어이다.)

   위에서 두 번째와 세 번째 [Notation] 선언들은 리스트에 대한 표준
   대괄호 표기법을 도입한다. 세 번째 선언의 오른편은 콕에서 n개를
   나열하는 표기법을 사용하는 예시를 보여주고 이진 생성자들의 반복해서
   내포된 형태로 변환되는 예를 설명한다. *)

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

(** 많은 함수들이 리스트를 다루기에 유용하다. 예를 들어, [repeat]
    함수는 [n]과 [count]를 받아 모든 원소가 [n]이고 길이가 [count]인
    리스트를 반환한다. *)

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

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

(** [length] 함수는 리스트의 길이를 계산한다. *)

Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => O
  | h :: t => S (length t)
  end.

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

(** [app] 함수는 두 리스트들을 붙여 하나의 리스트를 만든다. *)

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

(** 사실 [app]은 뒤이어 나올 어떤 부분에서 많이 사용될 것이다. 그래서
    중위 표기법을 도입하는 것이 편리하다.  *)

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

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

(* ----------------------------------------------------------------- *)
(** *** (기본 값을 지정한) Head와 Tail *)

(** 리스트 프로그래밍의 두 가지 작은 예제가 있다. [hd] 함수는 인자로
    주어진 리스트의 첫 번째 원소 ("head")를 반환하고 [tl] 함수는 첫
    번째 원소를 제외한 모든 것 ("tail")을 리턴한다. 물론 비어 있는
    리스트는 첫 번째 원소가 없기 때문에 그런 경우에 리턴할 기본 값을
    지정해야 한다. *)

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

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

Example test_hd1:             hd 0 [1;2;3] = 1.
Proof. reflexivity.  Qed.
Example test_hd2:             hd 0 [] = 0.
Proof. reflexivity.  Qed.
Example test_tl:              tl [1;2;3] = [2;3].
Proof. reflexivity.  Qed.

(* ----------------------------------------------------------------- *)
(** *** 연습문제들 *)

(** **** 연습문제: 별 두 개, 추천 (list_funs)  *)
(** 아래의 [nonzero], [oddmembers], [countoddmembers] 정의를
    완성하시오.  이 함수들이 하는 일을 이해하기 위해 테스트들을 살펴
    보시오. *)

Fixpoint nonzeros (l:natlist) : natlist
  (* 이 줄을 ":= 로 시작하는 정의"로 바꾸시오. *). Admitted.

Example test_nonzeros:
  nonzeros [0;1;0;2;3;0;0] = [1;2;3].
  (* 여기를 채우시오 *) Admitted.

Fixpoint oddmembers (l:natlist) : natlist
  (* 이 줄을 ":= 로 시작하는 정의"로 바꾸시오. *). Admitted.

Example test_oddmembers:
  oddmembers [0;1;0;2;3;0;0] = [1;3].
  (* 여기를 채우시오 *) Admitted.

Definition countoddmembers (l:natlist) : nat
  (* 이 줄을 ":= 로 시작하는 정의"로 바꾸시오. *). Admitted.

Example test_countoddmembers1:
  countoddmembers [1;0;3;1;4;5] = 4.
  (* 여기를 채우시오 *) Admitted.

Example test_countoddmembers2:
  countoddmembers [0;2;4] = 0.
  (* 여기를 채우시오 *) Admitted.

Example test_countoddmembers3:
  countoddmembers nil = 0.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개, 고급 (alternate)  *)
(** 두 리스트를 "지퍼로 잠그는 방식"으로 첫 번째 리스트에서 취한
    원소들과 두 번째 리스트에서 취한 원소들 사이를 번갈아 가며 하나의
    리스트로 만들도록 [alternate]를 완성하시오.

    [alternate]를 자연스럽고 우아하게 작성하려면 콕에서 요구하는 모든
    [Fixpoint] 정의들이 "분명하게 종료해야 한다"는 점을 만족시키지
    못할 것이다. 그 대신 두 리스트들의 원소들을 동시에 고려하는 조금
    더 긴 해법을 찾아보시오. (한 가지 가능한 해는 새로운 종류의 쌍들을
    정의하는 것인데 이 것이 유일한 방법은 아니다.  *)

Fixpoint alternate (l1 l2 : natlist) : natlist
  (* 이 줄을 ":= 로 시작하는 정의"로 바꾸시오. *). Admitted.

Example test_alternate1:
  alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
  (* 여기를 채우시오 *) Admitted.

Example test_alternate2:
  alternate [1] [4;5;6] = [1;4;5;6].
  (* 여기를 채우시오 *) Admitted.

Example test_alternate3:
  alternate [1;2;3] [4] = [1;4;2;3].
  (* 여기를 채우시오 *) Admitted.

Example test_alternate4:
  alternate [] [20;30] = [20;30].
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** 리스트로 표현한 가방(bags) 자료 구조 *)

(** [bag] (또는 [multiset])은 집합과 같다. 다만, 각 원소가 단 한 번이
    아니라 여러 번 나타날 수 있다는 점이 다르다. 숫자들을 담은 가방
    자료 구조를 표현하는 한 가지 가능한 구현은 리스트를 사용하는
    것이다.  *)

Definition bag := natlist.

(** **** 연습문제: 별 세 개, 추천 (bag_functions)  *)
(** 가방 자료 구조를 다루는 [count], [sum], [add], [member] 함수들의
    정의를 완성하시오. *)

Fixpoint count (v:nat) (s:bag) : nat
  (* 이 줄을 ":= 로 시작하는 정의"로 바꾸시오. *). Admitted.

(** 아래 증명들은 모두 [reflexivity]만 사용해도 증명할 수 있다. *)

Example test_count1:              count 1 [1;2;3;1;4;1] = 3.
 (* 여기를 채우시오 *) Admitted.
Example test_count2:              count 6 [1;2;3;1;4;1] = 0.
 (* 여기를 채우시오 *) Admitted.

(** 중복 집합 [sum]은 집합 [union]과 유사하다. [sum a b]는 [a]와 [b]의
    모든 원소들을 포함한다. (수학자들은 대개 중복 집합에 대한
    [union]을 sum 대신 max를 사용하여 조금 다르게 정의한다. 이 연산에
    대해 [union]이라고 부르지 않는 이유이다. [sum]의 정의에서 인자
    이름을 명시적으로 주지 않고 작성하고 있다. 더욱이 [Fixpoint] 대신
    [Definion] 키워드를 사용한다.  따라서 그 인자들 이름을 지었더라도
    재귀 방식으로 다룰 수 없을 것이다. 이런 식으로 문제를 제시하는
    의도는 스스로 [sum]이 다른 방식으로 구현될 수 있는지 생각해보라는
    것이다. 아마도 이미 정의했던 함수들을 사용할 수 있다.  *)

Definition sum : bag -> bag -> bag
  (* 이 줄을 ":= 로 시작하는 정의"로 바꾸시오. *). Admitted.

Example test_sum1:              count 1 (sum [1;2;3] [1;4;1]) = 3.
 (* 여기를 채우시오 *) Admitted.

Definition add (v:nat) (s:bag) : bag
  (* 이 줄을 ":= 로 시작하는 정의"로 바꾸시오. *). Admitted.

Example test_add1:                count 1 (add 1 [1;4;1]) = 3.
 (* 여기를 채우시오 *) Admitted.
Example test_add2:                count 5 (add 1 [1;4;1]) = 0.
 (* 여기를 채우시오 *) Admitted.

Definition member (v:nat) (s:bag) : bool
  (* 이 줄을 ":= 로 시작하는 정의"로 바꾸시오. *). Admitted.

Example test_member1:             member 1 [1;4;1] = true.
 (* 여기를 채우시오 *) Admitted.

Example test_member2:             member 2 [1;4;1] = false.
 (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개, 선택사항 (bag_more_functions)  *)
(** 여기 가방 자료 구조를 다루는 함수들이 있으니 연습해보시오.  *)

(** remove_one을 제거할 숫자를 포함하지 않는 가방 자료 구조에 적용하면
    동일한 가방을 변경하지 않고 반환해야 한다. *)

Fixpoint remove_one (v:nat) (s:bag) : bag
  (* 이 줄을 ":= 로 시작하는 정의"로 바꾸시오. *). Admitted.

Example test_remove_one1:
  count 5 (remove_one 5 [2;1;5;4;1]) = 0.
  (* 여기를 채우시오 *) Admitted.

Example test_remove_one2:
  count 5 (remove_one 5 [2;1;4;1]) = 0.
  (* 여기를 채우시오 *) Admitted.

Example test_remove_one3:
  count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
  (* 여기를 채우시오 *) Admitted.

Example test_remove_one4:
  count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
  (* 여기를 채우시오 *) Admitted.

Fixpoint remove_all (v:nat) (s:bag) : bag
  (* 이 줄을 ":= 로 시작하는 정의"로 바꾸시오. *). Admitted.

Example test_remove_all1:  count 5 (remove_all 5 [2;1;5;4;1]) = 0.
 (* 여기를 채우시오 *) Admitted.
Example test_remove_all2:  count 5 (remove_all 5 [2;1;4;1]) = 0.
 (* 여기를 채우시오 *) Admitted.
Example test_remove_all3:  count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
 (* 여기를 채우시오 *) Admitted.
Example test_remove_all4:  count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
 (* 여기를 채우시오 *) Admitted.

Fixpoint subset (s1:bag) (s2:bag) : bool
  (* 이 줄을 ":= 로 시작하는 정의"로 바꾸시오. *). Admitted.

Example test_subset1:              subset [1;2] [2;1;4;1] = true.
 (* 여기를 채우시오 *) Admitted.
Example test_subset2:              subset [1;2;2] [2;1;4;1] = false.
 (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개, 추천 (bag_theorem)  *)
(** 함수 [count]와 [add]와 관련된 가방 자료 구조에 대한 흥미로운 정리
    [bag_theorem]를 작성하고 증명하시오. 이 것은 열린 문제이기 때문에
    참인 정리이지만 증명하기 위해서 아직 배우지 않은 방법이 필요할
    수도 있다.  막히면 자유롭게 질문하시오! *)

(*
Theorem bag_theorem : ...
Proof.
  ...
Qed.
*)

(** [] *)

(* ################################################################# *)
(** * 리스트에 대한 추론 *)

(** 숫자들을 다루었을 때처럼 리스트 처리 함수들에 대한 간단한 사실들은
    종종 간략화를 통해 완전히 증명할 수 있다. 예를 들어,
    [reflexivity]로 간략화를 수행하면 아래 정리를 충분히 증명할 수
    있다...  *)

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

(** ... 왜냐하면 [[]]을 [app] 정의에서 match로 조사할 식으로 대체해서
    그 매치 자체가 간략화되기 때문이다. *)

(** 그리고 숫자들에 대해서와 같이 알려지지 않은 리스트의 가능한 형태에
    관해 경우 별로 분석하는 것이 도움이 될 수 있다. *)

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

(** 여기 [nil]의 경우 [tl nil = nil]로 정의하였기 때문에 증명할 수
    있다.  [destruct] 전술에 [as] 주석으로 [n]과 [l'] 이름들을 여기
    도입한다.  리스트에 대한 [cons] 생성자의 두 인자들(리스트의 머리와
    꼬리)에 이 이름들을 붙인다. *)

(** 비록 리스트에 대한 흥미로운 정리들을 증명하려면 대개 귀납법이
    필요하다. *)

(* ----------------------------------------------------------------- *)
(** *** 짧은 설교 *)

(** 예제 증명 스크립트들을 읽기만 하면 제대로 이해하지 못할 것이다!
    콕을 사용하고 각 단계가 얻는 바를 생각하면서 각 증명의 상세 내용을
    따라가는 것이 중요하다.  그렇지 않으면 증명들을 시작할 때
    연습문제들은 아무런 의미가 없을 것이 분명하다.  충분히
    얘기했다. *)

(* ================================================================= *)
(** ** 리스트에 대한 귀납법 *)

(** [natlist] 같은 자료형들에 대한 귀납법으로 증명하는 것은 자연수에
    대한 귀납법 보다 조금 덜 익숙 할 수 있지만 아이디어는 똑같이
    간단하다. 각 [Inductive] 선언은 선언한 생성자들을 사용하여 만들 수
    있는 데이터 값들의 집합을 정의한다. 부울형은 [true] 또는
    [false]이고 숫자는 [O]와 [S]를 다른 숫자에 적용한 것이고, 리스트는
    [nil] 또는 숫자와 리스트에 적용한 [cons]이다.

    더욱이 선언한 생성자들을 다른 것에 적용하는 것만이 유일하게
    귀납적으로 정의한 집합의 원소들이 가질 수 있는 _유일하게_ 가능한
    모양이다. 그리고 이러한 사실을 통해 귀납적으로 정의된 집합들에
    대해 유추하는 방법을 직접적으로 제공한다. 숫자는 [O]이거나 그렇지
    않으면 [S]를 _더 작은_ 숫자에 적용한 것이고, 리스트는 [nil]이거나
    그렇지 않으면 [cons]를 어떤 숫자와 어떤 _더 작은_ 리스트에 적용한
    것이며, 등등. 그래서 리스트 [l]을 언급하는 어떤 명제 [P]가 있고,
    _모든_ 리스트에 대해 [P]가 성립한다고 주장하고 싶다면 다음과 같이
    추론할 수 있다.

      - 첫째, [l]이 [nil] 일 때 [P]가 참이라고 증명하시오.

      - 그런 다음 [l]이 어떤 숫자 [n]과 어떤 작은 리스트 [l']에 대한
        [cons n l'] 일 때, [P]가 [l']에 대해 참이라고 가정하에 [P]가
        참임을 보이시오.

    더 큰 리스트는 오직 더 작은 리스트들 (궁극적으로 [nil]에 도달할 것인)로
    만들기 때문에 이 두 주장들을 합하면 [P]가 모든 리스트 [l]에 대해 참이라는
    것을 증명한다. 여기 구체적인 예가 있다. *)

Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    reflexivity.
  - (* l1 = cons n l1' *)
    simpl. rewrite -> IHl1'. reflexivity.  Qed.

(** 자연수에 대한 귀납법을 적용할 때처럼 [induction] 전술에서 [cons]
    경우에 [as...] 절로 더 작은 리스트 [l1']에 해당하는 귀납 가정에
    이름을 붙인다. 다시 한번 반복하면, 이 콕 증명은 고정된 형태로
    작성한 문서로 보아서는 더욱 안된다. 대화식 콕 세션에서 증명을 읽고
    있다면 무엇이 진행되고 있는지 쉽게 알 수 있고 현재 목적과 문맥을
    각 지점에서 볼 수 있다. 하지만 이러한 상태는 콕 증명으로 작성한
    부분에서는 드러나 있지 않다. 그래서 사람을 위해서 작성한 자연어로
    서술된 증명은 더 명백한 이정표를 포함할 필요가 있을 것이다. 특히
    두 번째 경우에 귀납적 가정이 무엇인지 독자들에게 정확히
    환기시킨다면 증명의 흐름을 잃지 않도록 유지하는데 도움이 될
    것이다. *)

(** 비교를 위해 여기 동일한 정리를 비형식적으로 증명해본다. *)

(** _정리_: 모든 리스트 [l1], [l2], [l3]에 대하여,
   [(l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3)].

   _증명_: [l1]에 관한 귀납법에 의하여.

   - 첫째, [l1 = []]라 가정하자.  다음을 증명해야 한다.

       ([] ++ l2) ++ l3 = [] ++ (l2 ++ l3),

     [++] 정의에 의해 바로 성립한다.

   - 다음은, 아래 등식이 성립하는 [l1 = n::l1']을 가정하자.

       (l1' ++ l2) ++ l3 = l1' ++ (l2 ++ l3)

     (귀납 가정). 다음 등식이 성립함을 보여야 한다.

       ((n :: l1') ++ l2) ++ l3 = (n :: l1') ++ (l2 ++ l3).

     [++] 정의와 아래 등식에 의해 성립한다.

       n :: ((l1' ++ l2) ++ l3) = n :: (l1' ++ (l2 ++ l3)),

     위 등식은 귀납 가정에 의해 바로 성립한다.  [] *)

(* ----------------------------------------------------------------- *)
(** *** 리스트 뒤집기 *)

(** 리스트에 대한 조금 더 어려운 귀납 증명의 예에 대해 리스트 뒤집는
    함수 [rev]를 [app]를 사용해서 정의한다고 가정하자. *)

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

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

(* ----------------------------------------------------------------- *)
(** *** [rev]의 성질들 *)

(** 새롭게 정의한 [rev]에 대한 몇 가지 정리들을 이제
    증명해보자. 지금까지 본 것보다 조금 더 도전적인 증명으로 리스트를
    뒤집으면 그 길이가 달라지지 않는다는 것을 증명하자.  처음
    귀납법으로 증명해보면 비어있지 않는 리스트의 경우에서 막힌다... *)

Theorem rev_length_firsttry : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - (* l = [] *)
    reflexivity.
  - (* l = n :: l' *)
    (* 이 것은 까다로운 경우이다. 그동안 증명해온 것과 같이 간략화로 시작해보자. *)
    simpl.
    (* 이제 막힌 것처럼 보인다. 이 목적은 [++]를 포함한 등식이지만
       현재 문맥이나 전역 환경에서 증명에 유용한 등식이 없다! IH를 사용해서
       현재 목적을 다시 작성하면 약간 증명을 진행할 수 있다...  *)
    rewrite <- IHl'.
    (* ... 하지만 이제 더이상 나아갈 수 없다. *)
Abort.

(** [++]와 [length]를 연관 짓는 등식을 취하자. 이 등식으로 증명을
    진행할 수도 있고 별도의 보조 정리로 증명할 수도 있을 것이다. *)

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

(** 이 보조 정리를 가능한 일반화시키기 위해, [rev] 적용 결과에 대한
    것이 아닌 _모든_ [natlist]들에 대해 한정사를 두었다. 이 목적이
    참인지 여부는 분명히 뒤집을 리스트에 의존하지 않기 때문에 이렇게
    한정사를 두는 것이 자연스럽다. 더욱이 더 일반적인 성질을 증명하기
    더 쉽다. *)

(** 이제 원래 증명을 완성할 수 있다. *)

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

(** 비교를 위해 두 정리들을 비형식적으로 증명한 것이 여기 있다.

    _정리_: 모든 리스트 [l1]과 [l2]에 대해
       [length (l1 ++ l2) = length l1 + length l2].

    _증명_: [l1]에 대한 귀납법에 의해.

    - 첫째, [l1 = []]을 가정하자.  다음을 증명하자.

        length ([] ++ l2) = length [] + length l2,

      [length]와 [++]의 정의들로 부터 바로 보일 수 있다.

    - 다음으로, 아래 등식과 함께 [l1 = n::l1']을 가정하자.

        length (l1' ++ l2) = length l1' + length l2.

      다음을 증명해야 한다.

        length ((n::l1') ++ l2) = length (n::l1') + length l2).

      [length]와 [++] 정의들과 귀납 가정과 함께 바로 보일 수 있다. [] *)

(** _정리_: 모든 리스트 [l]에 대해, [length (rev l) = length l].

    _증명_: [l]에 관한 귀납법에 의해.

      - 첫째, [l = []]를 가정하자.  다음 등식을 증명해야 한다.

          length (rev []) = length [],

        이 등식은 [length]와 [rev] 정의들에서 직접 유도할 수 있다.

      - 다음으로, 아래 등식과 함께 [l = n::l']를 가정하자

          length (rev l') = length l'.

        다음 등식을 증명해야 한다.

          length (rev (n :: l')) = length (n :: l').

        [rev] 정의에 의해, 위 등식은 아래 등식으로 증명할 수 있는데,

          length ((rev l') ++ [n]) = S (length l')

        이전 보조 정리에 의해 이 등식은 아래 등식과 동일하다.

          length (rev l') + length [n] = S (length l').

        동일한 이 등식은 귀납 가정과 [length] 정의에 의해 바로 보일 수 있다. *)

(** 이 증명들 스타일은 꽤 지루하고 현학적이다. 이 증명들 처음 두
    세 개를 살펴보면, 상세한 내용이 적은 (머리 속으로 또는 필요하다면
    메모 용지에 쉽게 작성할 수 있는) 그리고 중요한 단계들만 강조하는
    증명들을 따라가기가 더 쉽다는 것을 발견할 수 있다. 이런 더 압축된
    스타일로 위 증명을 다시 작성하면 다음과 같이 보일 것이다.  *)

(** _정리_: 모든 리스트 [l], [length (rev l) = length l]에 대해.

    _증명_: 첫째, 어떤 [l]에 대해 [length (l ++ [n]) = S (length
     l)]이다.  ([l]에 대한 직접적인 귀납 증명으로 보일 수 있다.)

     그 주요 성질은, [l = n'::l'] 경우의 귀납 가정과 함께 위 등식을
     사용하여 [l]에 대한 귀납법으로 다시 보일 수 있다. *)

(** 주어진 상황에서 어느 스타일이 더 좋은지는 기대하는 독자의 교육
    정도와 독자가 이미 익숙한 증명과 얼마나 비슷한지에 따라 다르다. 더
    현학적인 스타일이 현재 목적을 위한 좋은 초기 설정이다. *)

(* ================================================================= *)
(** ** [Search] *)

(** 예를 들어 [rewrite]를 사용하여, 이미 증명한 다른 정리들을 이용하여
    증명하는 것을 보았다.  그러나 어떤 정리를 참조하기 위해 이름을 알
    필요가 있다! 정말로 이전에 증명한 정리들을 기억하는 것 조차 종종
    어렵고 또한 그 정리들의 이름들은 더 기억하기 어렵다.

    콕의 [Search] 명령은 이럴 때 꽤 도움이 된다. [Search foo]를 치면 콕은 [foo]가
    포함된 모든 정리들의 목록을 보여줄 것이다. 예를 들어, [rev]에 대해 증명했던 정리들의
    목록을 보기 위해서 다음 주석을 제거해보라. *)

  Search rev.

(** 다음 연습문제들을 풀 때 그리고 이 책을 읽는 동안 [Search]를
    기억하라. 왜냐하면 많은 시간을 절약하게 해줄 것이기 때문이다!

    프룹제너럴(ProofGeneral)을 사용하면 [C-C C-a C-a]를 가지고
    [Search]를 실행할 수 있다. [C-c C-;] 명령어로 그 결과를 버퍼로
    옮겨올 수 있다. *)

(* ================================================================= *)
(** ** 리스트 연습문제들, 파트 1 *)

(** **** 연습문제: 별 세 개 (list_exercises)  *)
(** 리스트에 대한 추가 연습: *)

Theorem app_nil_r : forall l : natlist,
  l ++ [] = l.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem rev_app_distr: forall l1 l2 : natlist,
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  (* 여기를 채우시오 *) Admitted.

(** 다음 연습문제에 대한 짧은 해가 있다. 증명이 엉키면 뒤로 물러나서
    더 간단한 방법을 찾아보려고 노력해보라. *)

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  (* 여기를 채우시오 *) Admitted.

(** [nonzeros]의 구현에 대한 연습문제: *)

Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 두 개 (beq_natlist)  *)
(** [beq_natlist] 정의를 채우시오. 이 함수는 두 리스트의 숫자들이 같은
    지 비교한다. 모든 리스트 [l]에 대해 [beq_natlist l l]는 [true]를
    냄을 증명하시오.  *)

Fixpoint beq_natlist (l1 l2 : natlist) : bool
  (* 이 줄을 ":= 로 시작하는 정의"로 바꾸시오. *). Admitted.

Example test_beq_natlist1 :
  (beq_natlist nil nil = true).
 (* 여기를 채우시오 *) Admitted.

Example test_beq_natlist2 :
  beq_natlist [1;2;3] [1;2;3] = true.
(* 여기를 채우시오 *) Admitted.

Example test_beq_natlist3 :
  beq_natlist [1;2;3] [1;2;4] = false.
 (* 여기를 채우시오 *) Admitted.

Theorem beq_natlist_refl : forall l:natlist,
  true = beq_natlist l l.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** 리스트 연습문제들, 파트 2 *)

(** **** 연습문제: 별 세 개, 고급 (bag_proofs)  *)
(** 위의 가방 자료구조에 대해 정의들에 관하여 증명하는 한 두 가지 작은
    정리들이 있다. *)

Theorem count_member_nonzero : forall (s : bag),
  leb 1 (count 1 (1 :: s)) = true.
Proof.
  (* 여기를 채우시오 *) Admitted.

(** [leb]에 대한 다음 보조 정리는 다음 증명에 도움이 될 수도 있다. *)

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

Theorem remove_decreases_count: forall (s : bag),
  leb (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개, 선택사항 (bag_count_sum)  *)
(** 함수 [count]와 [sum]을 사용하는 가방 자료 구조에 대한 정리
    [bag_count_sum]을 흥미롭게 작성하고 증명해보시오. ([count]를
    정의하는 법에 따라 그 증명이 어려울 수도 있다!)  *)
(* 여기를 채우시오 *)
(** [] *)

(** **** 연습문제: 별 네 개, 고급 (rev_injective)  *)
(** [rev] 함수가 단사 함수임을 증명하시오. 즉,

    forall (l1 l2 : natlist), rev l1 = rev l2 -> l1 = l2.

(어렵게 증명하는 방법과 쉽게 증명하는 방법이 있다.) *)

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

(* ################################################################# *)
(** * 선택사항들 *)

(** 어떤 리스트의 [n]번째 원소를 반환하는 함수를 작성한다고
    가정하자. 그 함수의 타입을 [nat -> natlist -> nat]로 하면 리스트가
    너무 짧을 때 리턴할 어떤 숫자를 선택해야 할 것이다...  *)

Fixpoint nth_bad (l:natlist) (n:nat) : nat :=
  match l with
  | nil => 42  (* arbitrary! *)
  | a :: l' => match beq_nat n O with
               | true => a
               | false => nth_bad l' (pred n)
               end
  end.

(** 위 정의는 그다지 좋지 않다. 왜냐하면 [nth_bad]가 [42]를 반환하면
    입력 리스트에 값이 실제로 나타나는지 추가 처리 없이 구분할 수 없기
    때문이다.  더 나은 대응 방법은 [nth_bad]의 반환 타입을 변경해서
    가능한 결과 중 하나로 에러 값을 포함시키는 것이다. 이러한 타입을
    [natoption]이라고 부른다. *)

Inductive natoption : Type :=
  | Some : nat -> natoption
  | None : natoption.

(** 위 [nth_bad] 정의를 변경해서 리스트가 너무 짧을 때 [None]를
    반환하고 리스트가 충분한 원소들로 구성되어 [n] 위치에 [a]가 나타날
    때 [Some a]를 리턴할 수 있다. 이 새로운 함수를 [nth_error]으로
    이름 지어 에러를 결과로 낼 수 있음을 나타낸다.  *)

Fixpoint nth_error (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => match beq_nat n O with
               | true => Some a
               | false => nth_error l' (pred n)
               end
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [4;5;6;7] 3 = Some 7.
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [4;5;6;7] 9 = None.
Proof. reflexivity. Qed.

(** (In the HTML version, the boilerplate proofs of these
    examples are elided.  Click on a box if you want to see one.)

    This example is also an opportunity to introduce one more small
    feature of Coq's programming language: conditional
    expressions... *)

Fixpoint nth_error' (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => if beq_nat n O then Some a
               else nth_error' l' (pred n)
  end.

(** 콕의 조건식은 다른 언어의 조건식과 한 가지 작은 일반화를 제외하고
    정확히 똑같다.  부울이 기본으로 제공되는 타입이 아니기 때문에
    실제로 콕은 정확히 두 가지 생성자들을 가지고 _어떤_ 귀납적으로
    정의한 타입에 대한 조건식을 지원한다. 조건식을 계산해서
    [Inductive] 정의의 첫 번째 생성자가 나오면 참이고, 두 번째
    생성자가 나오면 거짓이라고 간주한다. *)

(** 아래 함수는 [natopion]에서 [nat]을 꺼내고 [None] 경우에 제공된
    기본 값을 반환한다. *)

Definition option_elim (d : nat) (o : natoption) : nat :=
  match o with
  | Some n' => n'
  | None => d
  end.

(** **** 연습문제: 별 두 개 (hd_error)  *)
(** 동일한 아이디어를 사용하여 초기 [hd] 함수를 [nil] 경우에 기본
    원소를 전달하지 않아도 되도록 수정하시오.  *)

Definition hd_error (l : natlist) : natoption
  (* 이 줄을 ":= 로 시작하는 정의"로 바꾸시오. *). Admitted.

Example test_hd_error1 : hd_error [] = None.
 (* 여기를 채우시오 *) Admitted.

Example test_hd_error2 : hd_error [1] = Some 1.
 (* 여기를 채우시오 *) Admitted.

Example test_hd_error3 : hd_error [5;6] = Some 5.
 (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 하나, 선택사항 (option_elim_hd)  *)
(** 이 연습문제는 새로운 함수 [hd_error]를 예전 함수 [hd]와 연관짓는다. *)

Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim default (hd_error l).
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

End NatList.

(* ################################################################# *)
(** * 부분 맵 *)

(** 콕에서 어떤 자료 구조를 정의할 수 있는지 설명하는 마지막 예로
    간단한 _부분 맵_ 자료 타입이 있다. 대부분의 프로그래밍언어에 있는
    맵이나 딕셔너리 자료 구조와 유사하다. *)

(** 첫째, 새로운 귀납적 자료형 [id]를 정의해서 부분 맵의 "키"로 사용한다. *)

Inductive id : Type :=
  | Id : nat -> id.

(** 내부적으로 [id]는 단지 숫자이다. 각 숫자를 [Id] 태그로 감싸 별도의
    타입을 도입하면 정의들이 더 읽기 좋고 나중에 우리가 원하면 표현을
    변경시킬 수 있는 유연성을 제공한다.

    [id]들이 똑같은지 테스트할 필요가 있을 것이다. *)

Definition beq_id (x1 x2 : id) :=
  match x1, x2 with
  | Id n1, Id n2 => beq_nat n1 n2
  end.

(** **** Exercise: 1 star (beq_id_refl)  *)
Theorem beq_id_refl : forall x, true = beq_id x x.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** 이제 부분 맵의 타입을 정의한다: *)

Module PartialMap.
Export NatList.

Inductive partial_map : Type :=
  | empty  : partial_map
  | record : id -> nat -> partial_map -> partial_map.

(** 이 선언을 다음과 같이 읽을 수 있다. "[partial_map]을 만드는 두
    가지 방법이 있다. [empty] 생성자를 사용하여 비어 있는 부분 맵을
    표현하거나 [record] 생성자를 키와 값과 다른 [partial_map]에
    적용하여 기존 부분 맵에 키와 값 매핑을 추가하여 [partial_map]을
    만든다." *)

(** [update] 함수는 부분 맵에서 주어진 키에 대한 내용을 바꾸거나
    주어진 키가 아직 없으면 새로운 내용을 추가한다.  *)

Definition update (d : partial_map)
                  (x : id) (value : nat)
                  : partial_map :=
  record x value d.

(** 마지막으로 [find] 함수는 [partial_map]에서 주어진 키를 탐색한다.
    그 키를 찾지 못하면 [None]를 반환하고, 그 키와 [val]이 연관되어
    있다면 [Some val]을 리턴한다. 만일 같은 키가 여러 값들에 매핑되어
    있으면 [find]는 첫 번째로 만나는 것을 반환할 것이다. *)

Fixpoint find (x : id) (d : partial_map) : natoption :=
  match d with
  | empty         => None
  | record y v d' => if beq_id x y
                     then Some v
                     else find x d'
  end.

(** **** 연습문제: 별 하나 (update_eq)  *)
Theorem update_eq :
  forall (d : partial_map) (x : id) (v: nat),
    find x (update d x v) = Some v.
Proof.
 (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 하나 (update_neq)  *)
Theorem update_neq :
  forall (d : partial_map) (x y : id) (o: nat),
    beq_id x y = false -> find x (update d y o) = find x d.
Proof.
 (* 여기를 채우시오 *) Admitted.
(** [] *)
End PartialMap.

(** **** 연습문제: 별 두 개 (baz_num_elts)  *)
(** 아래의 귀납적 정의를 고려하자: *)

Inductive baz : Type :=
  | Baz1 : baz -> baz
  | Baz2 : baz -> bool -> baz.

(** [baz] 타입은 _몇 개_의 원소들을 가지고 있는가? (영어로 답하거나
    당신의 언어로 답하시오.)

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

(** $Date: 2017-08-24 10:54:05 -0400 (Thu, 24 Aug 2017) $ *)

(* Local Variables: *)
(* coq-prog-name: "/Applications/CoqIDE_8.6.1.app/Contents/Resources/bin/coqtop" *)
(* coq-load-path: nil *)
(* End: *)


Require Export SfLib.

Module AExp.

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

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

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

Example test_aeval1:
  aeval (APlus (ANum 2) (ANum 2)) = 4.
Proof. reflexivity. Qed.

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

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

Example test_optimize_0plus:
  optimize_0plus (APlus (ANum 2)
                        (APlus (ANum 0)
                               (APlus (ANum 0) (ANum 1))))
  = APlus (ANum 2) (ANum 1).
Proof. reflexivity. Qed.

Theorem optimize_0plus_sound :
  forall a,
    aeval (optimize_0plus a) = aeval a.
Proof.
  intros a.
  induction a.
  Case "ANum". reflexivity.
  Case "APlus".
    destruct a1.
    SCase "a1 = ANum n".
      destruct n.
      SSCase "n = 0". simpl. apply IHa2.
      SSCase "n <> 0". simpl. rewrite IHa2. reflexivity.
    SCase "a1 = APlus a1_1 a1_2".
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
    SCase "a1 = AMinus a1_1 a1_2".
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
    SCase "a1 = AMult a1_1 a2_2".
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
  Case "AMinus".
    simpl. rewrite IHa1. rewrite IHa2. reflexivity.
  Case "AMult".
    simpl. rewrite IHa1. rewrite IHa2. reflexivity.
Qed.

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

Tactic Notation "aexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ANum" | Case_aux c "APlus"
    | Case_aux c "AMinus" | Case_aux c "AMult" ].

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

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

Tactic Notation "bexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "BTrue" | Case_aux c "BFalse"
    | Case_aux c "BEq" | Case_aux c "BLe"
    | Case_aux c "BNot" | Case_aux c "BAnd" ].

Theorem optimize_0plus_b_sound :
  forall b,
    beval (optimize_0plus_b b) = beval b.
Proof.
  intros b.
  bexp_cases (induction b) Case;
    try reflexivity;
    try (simpl; repeat (rewrite optimize_0plus_sound); reflexivity);
    try (simpl; rewrite IHb; reflexivity);
    try (simpl; rewrite IHb1; rewrite IHb2; reflexivity).
Qed.


Require Import PeanoNat.
Inductive multiple_of_3 : nat -> Prop :=
  | O_multiple : multiple_of_3 O
  | SSS_multiple n (H : multiple_of_3 n) : multiple_of_3 (S (S (S n))).

Inductive multiple_of_3' : nat -> Prop :=
  | thirty_multiple : multiple_of_3' 30
  | twenty_one_multiple : multiple_of_3' 21
  | sum_multiple n m (H : multiple_of_3' n) (H' : multiple_of_3' m) : multiple_of_3' (n + m)
  | difference_multiple l n m (H : multiple_of_3' n) (H' : multiple_of_3' m) (H'' : l + n = m) : multiple_of_3' l.

Lemma zero' : multiple_of_3' 0.
  Proof.
    apply (difference_multiple 0 21 21).
    apply twenty_one_multiple.
    apply twenty_one_multiple.
    simpl.
    reflexivity.
    Qed.

Lemma three' : multiple_of_3' 3.
  Proof.
    apply (difference_multiple 3 9 12).
    apply (difference_multiple 9 21 30).
    constructor.
    constructor.
    simpl.
    reflexivity.
    apply (difference_multiple 12 9 21).
    apply (difference_multiple 9 21 30).
    constructor.
    constructor.
    simpl.
    reflexivity.
    constructor.
    simpl.
    reflexivity.
    simpl.
    reflexivity.
  Qed.

Lemma all' : forall n : nat, multiple_of_3' n -> multiple_of_3' (S (S (S n))).
  Proof.
    intros.
    assert (forall x : nat, S (S (S x)) = x + 3).
      intro.
      rewrite Nat.add_comm.
      unfold "+".
      reflexivity.
    rewrite H0.
    apply (sum_multiple n 3).
    assumption.
    apply three'.
Qed.

Theorem multiple_of_3_iff_multiple_of_3' :
  forall n, multiple_of_3 n <-> multiple_of_3' n.
Proof.
  intros.
  split.
  intros.
  induction H.
  apply zero'.
  apply (sum_multiple _ _ three' IHmultiple_of_3).
  intros.
  induction H.
  repeat constructor.
  repeat constructor.
  induction IHmultiple_of_3'1.
  simpl.
  exact IHmultiple_of_3'2.
  simpl.
  constructor.
  apply IHIHmultiple_of_3'1.
  refine (difference_multiple n 3 (S (S (S n))) three' H _).
  rewrite Nat.add_comm.
  simpl.
  reflexivity.
  generalize dependent m.
  generalize dependent l.
  intros.

Qed.


Require Import Setoid.

(* Derived from https://people.cs.umass.edu/~arjun/courses/cs691pl-spring2014/assignments/groups.html,
   but without any automation. *)

Section Group.

(* The set of the group. *)
Variable G : Set.

(* The binary operator. *)
Variable f : G -> G -> G.
Infix "*" := f (at level 40, left associativity).

(* The group identity. *)
Variable e : G.

(* The inverse operator. *)
Variable i : G -> G.

(* The operator [f] is associative. *)
Variable assoc : forall (a b c : G), (a * b) * c = a * (b * c).

(* [e] is the left-identity for all elements [a]. *)
Variable id_l : forall (a : G), e * a = a.

(* [i a] is the left-inverse of [a]. *)
Variable inv_l : forall (a : G), i a * a = e.

(* Theorems in group theory. *)

(* The identity [e] is unique. *)
Theorem e_unique :
  forall (a : G), a * a = a -> a = e.
Proof.
  intros.
  rewrite <- (id_l a) at 1.
  rewrite <- (inv_l a).
  rewrite assoc.
  rewrite H. auto.
Qed.

(* [i a] is the right-inverse of [a]. *)
Theorem inv_r :
  forall (a : G), a * i a = e.
Proof.
  intros.
  apply e_unique.
  rewrite assoc. rewrite <- (assoc (i a) a (i a)).
  rewrite inv_l.
  rewrite id_l. auto.
Qed.

(* [e] is the right-identity. *)
Theorem id_r :
  forall (a : G), a * e = a.
Proof.
  intros.
  rewrite <- (inv_l a).
  rewrite <- assoc.
  rewrite inv_r, id_l.
  auto.
Qed.

(* [x] can be cancelled on the left. *)
Theorem cancel_l :
  forall (a b x : G), x * a = x * b -> a = b.
Proof.
  intros.
  rewrite <- (id_l a), <- (id_l b).
  rewrite <- (inv_l x).
  rewrite assoc, assoc.
  rewrite H.
  auto.
Qed.

(* [x] can be cancelled on the right. *)
Theorem cancel_r :
  forall (a b x : G), a * x = b * x -> a = b.
Proof.
  intros.
  rewrite <- (id_r a), <- (id_r b).
  rewrite <- (inv_r x).
  rewrite <- assoc, <- assoc.
  rewrite H.
  auto.
Qed.

(* The left identity is unique. *)
Theorem e_uniq_l :
  forall (a x : G), x * a = a -> x = e.
Proof.
  intros.
  apply (cancel_r _ _ a).
  rewrite id_l.
  auto.
Qed.

(* The left inverse is unique. *)
Theorem inv_uniq_l :
  forall (a b : G), a * b = e -> a = i b.
Proof.
  intros.
  apply (cancel_r _ _ (b * e)).
  rewrite <- assoc, <- assoc.
  rewrite H, id_l, inv_l.
  rewrite id_l.
  auto.
Qed.

(* The left identity is unique. *)
Theorem e_uniq_r :
  forall (a x : G), a * x = a -> x = e.
Proof.
  intros.
  apply (cancel_l _ _ a).
  rewrite id_r.
  auto.
Qed.

(* The right inverse is unique. *)
Theorem inv_uniq_r :
  forall (a b : G), a * b = e -> b = i a.
Proof.
  intros.
  apply (cancel_l _ _ (e * a)).
  rewrite assoc, assoc.
  rewrite H, id_r, inv_r.
  rewrite id_r.
  auto.
Qed.

(* The inverse operator distributes over the group operator. *)
Theorem inv_distr :
  forall (a b : G), i (a * b) = i b * i a.
Proof.
  intros. symmetry.
  apply inv_uniq_l.
  rewrite assoc. rewrite <- (assoc (i a) a b).
  rewrite inv_l.
  rewrite id_l.
  rewrite inv_l.
  auto.
Qed.

(* The inverse of an inverse produces the original element. *)
Theorem double_inv : forall (a : G), i (i a) = a.
Proof.
  intros. symmetry.
  apply inv_uniq_l.
  apply inv_r.
Qed.

(* The identity is its own inverse. *)
Theorem id_inv : i e = e.
Proof.
  intros. symmetry.
  apply inv_uniq_l.
  apply id_l.
Qed.

Theorem inv_a_eq_a_implies_abelian :
  (forall (a : G), a = i a) -> forall (x y : G), x * y = y * x.
Proof.
  intros.
  pose proof (H x) as H1.
  pose proof (H y) as H2.
  pose proof (H (y * x)) as H3.
  rewrite inv_distr in H3.
  rewrite H1 at 1.
  rewrite H2 at 1.
  auto.
Qed.

End Group.

Check id_inv.


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

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

Compute (next_weekday friday).
Compute (next_weekday (next_weekday friday)).

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

Inductive bool: Type := true | false.

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

Definition andb (b_1 : bool) (b_2: bool): bool :=
match b_1 with
  | true => b_2
  | false => false
end.

Definition orb (b_1 : bool) (b_2: bool): bool :=
match b_1 with
  | true => true
  | false => b_2
end.

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Notation "x || y" := (orb x y).
Notation "x && y" := (andb x y).

Example test_orb5: false || false || true = true.
Proof. simpl. reflexivity. Qed.

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

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

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
match b1, b2, b3 with
  | true, true, true => true
  | _,_,_ => false (* or do (x,y) and match with _ or do x,y and do _,_ *)
end.

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

Check true.
Check (negb true).
Check negb.

Inductive rgb: Type := red | green | blue.

Inductive color: Type := black | white | primary (p: rgb).

Definition monochrome (c: color): bool :=
match c with primary _ => false | _ => true end.

Definition isred (c: color): bool :=
match c with
  | primary red => true
  | _ => false
end.

Module NatPlayground.

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

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

End NatPlayground.

Check S (S (S O)). (* wow it prints it in a decimal form! *)

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

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

Example test_oddb1: oddb 1 = true.
Proof. simpl. reflexivity. Qed.
Example test_oddb2: oddb 4 = false.
Proof. simpl. reflexivity. Qed.

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

Compute (plus 3 2).

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

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

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

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

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

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

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.
Check ((0 + 1) + 1).

Fixpoint eqb (n m : nat) : bool :=
match n, m with
  | 0, 0 => true
  | S n, S m => eqb n m
  | _, _ => false
end.

Fixpoint leb (n m : nat) : bool :=
match n, m with
  | 0, _ => true
  | S n, S m => leb n m
  | _, _ => false
end.

Example test_leb1: (leb 2 2) = true.
Proof. simpl. reflexivity. Qed.
Example test_leb2: (leb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_leb3: (leb 4 2) = false.
Proof. simpl. reflexivity. Qed.

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.
Example test_leb3': (4 <=? 2) = false.
Proof. simpl. reflexivity. Qed.

Definition ltb (n m : nat) : bool :=
match m with
  | 0 => false
  | S m' => leb n m'
end.

Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.

Example test_ltb1: (ltb 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_ltb2: (ltb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ltb3: (ltb 4 2) = false.
Proof. simpl. reflexivity. Qed.

Theorem plus_O_n : forall n : nat, 0 + n = n.
Proof. intro n. reflexivity. Qed.

(* reflexivity expands definitions since it finishes the proof,
simpl is just a step so it doesn't mess up the state without our permission. *)

(* Example Theorem Lemma Remark Fact  mean almost the same *)

Theorem plus_1_l : forall n:nat, 1 + n = S n.
Proof.
  intros n. reflexivity. Qed.
Theorem mult_0_l : forall n:nat, 0 * n = 0. (* _l suffix means "on the left" *)
Proof.
  intros n. reflexivity. Qed.

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

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

(* Admitted command means believe it *)

Theorem mult_0_plus : forall n m : nat, (0 + n) * m = n * m.
Proof.
  intros n m. rewrite plus_O_n. reflexivity. Qed.

Theorem mult_S_1 : forall n m : nat,
  m = S n ->
  m * (1 + n) = m * m.
Proof.
  intros n m H.
  rewrite plus_1_l, H. reflexivity. Qed. (* !!! multiple rewrites !! *)

Theorem plus_1_neq_0_firsttry : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n.
(* command Abort means give up for a minute *)
  destruct n as [|n'] eqn:E. (* you may leave off eqn:E, then the assumption (from the case-split) named E will not be added to your list *)
  - reflexivity. (* - "focuses" the goal *)
  - reflexivity. (* remember, reflexivity itself uses some simplification *)
Qed.

(* - are called bullets, not needed, but they separate, you do not want
Coq to interpret proof boundaries differently than you! *)

Theorem negb_involutive : forall b : bool, negb (negb b) = b.
Proof.
  intros b. destruct b (*as [|]*). (* you can ommit empty lists like these *)
  { reflexivity. }
  - reflexivity. Qed.

(* no []s or [] or [|] are ok here *)
(* bullets nest, first - then + then * then just braces: {} *)
(* you can use braces any time though, and they obviously allow you to reuse the bullet shapes. *)

(* shorthand: intro + destruct *)

Theorem plus_1_neq_0' : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity. Qed.

(* shorthand intro + destruct no names *)
Theorem andb_commutative'' :
  forall b c, andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros [] [] E.
  - reflexivity.
  - exact E.
  - reflexivity.
  - exact E. Qed.

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

(* Coq's 0%nat 0%Z notation *)

(* for Fixpoint, coq requires that for all Fixpoint definitions, some
arugument is structurally decreasing *)

(*
Fixpoint wont_compile (n: nat) (flag: bool): nat :=
match n,flag with
  | 0,_ => 0
  | _, true => wont_compile (minus n 2) false
  | _, false => wont_compile (plus n 1) true
end.
*)

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

From Coq Require Export String.
Definition manual_grade_for_negation_fn_applied_twice : option (nat*string) := None.

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

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

Inductive bin : Type :=
  | Z
  | A (n : bin)
  | B (n : bin).

Fixpoint incr (m:bin) : bin :=
match m with
  | Z => B Z
  | A m' => B m'
  | B m' => A (incr m')
end.

Fixpoint bin_to_nat (m:bin) : nat :=
match m with
  | Z => 0
  | A m' => 2 * bin_to_nat m'
  | B m' => 1 + 2 * bin_to_nat m'
end.

Example test_bin_incr1: bin_to_nat (incr (A (B Z))) = 1 + bin_to_nat (A (B Z)).
Proof. reflexivity. Qed.
Example test_bin_incr2: bin_to_nat (incr (A (A (B Z)))) = 1 + bin_to_nat (A (A (B Z))).
Proof. reflexivity. Qed.
Example test_bin_incr3: bin_to_nat (incr (B (A (B Z)))) = 1 + bin_to_nat (B (A (B Z))).
Proof. reflexivity. Qed.
Example test_bin_incr4: bin_to_nat (incr (A (B (B Z)))) = 1 + bin_to_nat (A (B (B Z))).
Proof. reflexivity. Qed.
Example test_bin_incr5: bin_to_nat (incr (B(B(A (B (B Z)))))) = 1 + bin_to_nat (B(B(A (B (B Z))))).
Proof. reflexivity. Qed.


Require Import Omega.

From q3_2001 Require Export misc.

Definition ceil (x y : nat) :=
  match y with
  | 0 => x (* Division by zero convention (anything would do). *)
  | S y' => let D := Nat.divmod x y' 0 y' in
              if (snd D) =? y' then fst D else S (fst D)
  end.

Lemma ceil_spec_0 : forall x y z : nat,
  y <> 0 -> (ceil x y <= z <-> x <= y * z).
Proof.
  intros x [|y'] z H; unfold ceil.
  - contradiction.
  - pose (q := (fst (Nat.divmod x y' 0 y'))).
    pose (u := (snd (Nat.divmod x y' 0 y'))).
    fold q. fold u.
    pose (H' := (Nat.divmod_spec x y' 0 y' (le_refl y'))).
    assert (HD : (q, u) = Nat.divmod x y' 0 y'). { symmetry. apply surjective_pairing. }
    rewrite <- HD in H'. destruct H' as [Heq Hu].
    assert (Hq : x = (S y') * q + y' - u). { omega. }
    destruct (u =? y') eqn:H_rem; rewrite -> Hq.
    + apply Nat.eqb_eq in H_rem. rewrite <- H_rem.
      assert (Hrw : forall w, w + u - u = w). { intros w. omega. } rewrite -> (Hrw (S u * q)).
      split; [apply mult_le_compat_l | apply (mult_S_le_reg_l u q z)].
    + apply Nat.eqb_neq in H_rem.
      split; intros H_ineq.
      * assert (H1 : S y' * q + y' - u <= S y' * q + S y'). { omega. }
        assert (H2 : S y' * q + S y' = S y' * S q). { auto. }
        rewrite -> H2 in H1.
        assert (H3 : S y' * S q <= S y' * z). { apply mult_le_compat_l. assumption. }
        omega.
      * assert (H1 : S y' * q + y' - u = S y' * q + (y' - u)). { omega. } rewrite -> H1 in H_ineq.
        assert (H2 : 0 < y' - u). { omega. }
        assert (H3 : S y' * q < S y' * z). { omega. }
        rewrite <- Nat.mul_lt_mono_pos_l in H3.
        -- assumption.
        -- apply Nat.lt_0_succ.
Qed.

Lemma ceil_spec_1 : forall x y z : nat,
  y <> 0 -> (z < ceil x y <-> y * z < x).
Proof.
  intros x y z Hy.
  destruct (Nat.le_gt_cases x (y*z)) as [Hx|Hx];
  destruct (Nat.le_gt_cases (ceil x y) z) as [Hz|Hz]; split; intros H; try omega.
  - rewrite <- (ceil_spec_0 _ _ _ Hy) in Hx. omega.
  - rewrite -> (ceil_spec_0 _ _ _ Hy) in Hz. omega.
Qed.

Lemma ceil_spec_2 : forall x : nat,
  ceil x 1 = x.
Proof.
  intros. assert (H : 1 <> 0). { intros contra. inversion contra. }
  assert (H_lt : ceil x 1 <= x). {
    rewrite -> (ceil_spec_0 _ _ _ H). rewrite Nat.mul_1_l. apply le_refl.
  }
  assert (H_gt : ceil x 1 >= x). {
    unfold ge. rewrite <- (Nat.mul_1_l (ceil x 1)).
    rewrite <- (ceil_spec_0 x 1 (ceil x 1) H). apply le_refl.
  }
  apply Nat.le_antisymm; assumption.
Qed.

Lemma ceil_spec_3 : forall x y : nat,
  y <> 0 -> x <= y * ceil x y.
Proof. intros. rewrite <- ceil_spec_0; trivial. Qed.

Lemma ceil_spec_4 : forall x y x' y' : nat,
  y <> 0 -> x' <= x -> y <= y' -> ceil x' y' <= ceil x y.
Proof.
  intros x y x' y' Hyn0 Hx Hy.
  assert (Hy' : y' <> 0). { omega. }
  rewrite -> (ceil_spec_0 _ _ _ Hy').
  apply (le_trans x' x (y' * ceil x y)).
  - assumption.
  - apply (le_trans x (y * ceil x y) (y' * ceil x y)).
    + apply (ceil_spec_3 _ _ Hyn0).
    + apply mult_le_compat_r. assumption.
Qed.

Lemma ceil_spec_5 : forall x y z : nat,
  y <> 0 -> z <> 0 -> ceil x y = ceil (z*x) (z*y).
Proof.
  intros x y z Hy Hz.
  assert (Hr : ceil (z*x) (z*y) <= ceil x y). {
    apply ceil_spec_0.
    - apply mult_is_O'; assumption.
    - rewrite <- mult_assoc. apply Nat.mul_le_mono_l. apply ceil_spec_3. assumption.
  }
  assert (Hl : ceil x y <= ceil (z*x) (z*y)). {
    apply ceil_spec_0.
    - omega.
    - rewrite -> Nat.mul_le_mono_pos_l with (p:=z).
      + rewrite mult_assoc. apply ceil_spec_3. apply mult_is_O'; assumption.
      + omega.
  }
  apply Nat.le_antisymm; assumption.
Qed.


From mathcomp
  Require Import ssreflect.

Section ModusPonens.
Variables X Y : Prop.

Hypothesis XtoY_is_true : X -> Y.
Hypothesis X_is_true : X.

Theorem MP : Y.
Proof.
move: X_is_true.
by [].
Qed.

End ModusPonens.

Section HilbertSAxiom.
Variables A B C : Prop.

Theorem HS1 : (A -> (B -> C)) -> ((A -> B) -> (A -> C)).
Proof.
move=> AtoBtoC_is_true.
move=> AtoB_is_true.
move=> A_is_true.

apply: (MP B C).

apply: (MP A (B -> C)).
by [].
by [].

apply: (MP A B).
by [].
by [].
Qed.

Theorem HS2 : (A -> (B -> C)) -> ((A -> B) -> (A -> C)).
Proof.
move=> AtoBtoC_is_true AtoB_is_true A_is_true.
by apply: (MP B C); [apply: (MP A (B -> C)) | apply: (MP A B)].
Qed.

Theorem HS3 : (A -> (B -> C)) -> ((A -> B) -> (A -> C)).
Proof.
move=> AtoBtoC_is_true AtoB_is_true A_is_true.
by move: A_is_true (AtoB_is_true A_is_true).
Qed.

End HilbertSAxiom.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint fac (fac_arg0 : natural) : natural
           := match fac_arg0 with
              | Zero => Succ Zero
              | Succ n => mult (fac n) n
              end.

Fixpoint qfac (qfac_arg0 : natural) (qfac_arg1 : natural) : natural
           := match qfac_arg0, qfac_arg1 with
              | Zero, n => n
              | Succ n, m => qfac n (mult m n)
              end.

Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
intros.
induction x.
lfind.  reflexivity.
Admitted.

Lemma mult_zero : forall (x : natural), mult x Zero = Zero.
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma mult_succ : forall (x y : natural), plus (mult x y) x = mult x (Succ y).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite plus_succ. rewrite plus_assoc. rewrite (plus_commut y x). rewrite <- plus_assoc. rewrite IHx. rewrite plus_succ. reflexivity.
Qed.

Lemma mult_commut : forall (x y : natural), mult x y = mult y x.
Proof.
intros.
induction x.
- rewrite mult_zero. reflexivity.
- simpl. rewrite IHx. rewrite mult_succ. reflexivity.
Qed.

Lemma distrib : forall (x y z : natural), mult (plus x y) z = plus (mult x z) (mult y z).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. rewrite plus_assoc. rewrite (plus_commut (mult y z) z). rewrite <- plus_assoc. reflexivity.
Qed.

Lemma mult_assoc : forall (x y z : natural), mult (mult x y) z = mult x (mult y z).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite distrib. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural), eq (mult (fac x) y) (qfac x y).
Proof.
induction x.
- reflexivity.
- intros. simpl. rewrite <- IHx. rewrite mult_assoc. rewrite (mult_commut x y). reflexivity.
Qed.


Require Import Arith.

Goal forall P : nat -> Prop, (forall n m, P n -> P m) -> (exists p, P p) -> forall q, P q.
Proof.
  intros.
  destruct H0.
  apply (H x).
  apply H0.
Qed.

Goal forall P : nat -> Prop, P 2 -> (exists y, P (1 + y)).
Proof.
  intros.
  exists 1.
  apply H.
Qed.

Goal forall P Q : nat -> Prop, P 0 -> (forall x, P x -> Q x) -> Q 0.
Proof.
  intros.
  apply H0.
  apply H.
Qed.


Require Import XR_Rabs.
Require Import XR_Rsqr.
Require Import XR_Rsqr_lt_abs_0.
Require Import XR_plus_lt_is_lt.
Require Import XR_Rle_0_sqr.

Local Open Scope R_scope.

Lemma triangle_rectangle_lt :
  forall x y z:R,
    Rsqr x + Rsqr y < Rsqr z -> Rabs x < Rabs z /\ Rabs y < Rabs z.
Proof.
  intros x y z.
  intro h.
  split.
  {
    apply Rsqr_lt_abs_0.
    apply plus_lt_is_lt with (Rsqr y).
    { apply Rle_0_sqr. }
    { exact h. }
  }
  {
    apply Rsqr_lt_abs_0.
    apply plus_lt_is_lt with (Rsqr x).
    { apply Rle_0_sqr. }
    {
      rewrite Rplus_comm.
      exact h.
    }
  }
Qed.


Set Warnings "-notation-overridden,-parsing".
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Maps.

Module AExp.

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

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

(* Evaluation *)

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

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

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

Example test_optimize_0plus:
  optimize_0plus (APlus (ANum 2)
                        (APlus (ANum 0)
                               (APlus (ANum 0) (ANum 1))))
  = APlus (ANum 2) (ANum 1).
Proof. simpl. reflexivity. Qed.

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

(* Coq Automation *)

(* Try *)

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

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

(* The ; Tactical (Simple Form) *)

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

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

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

(* The ; Tactical (General Form) *)

(* T; [T1 | T2 | ... | Tn]
   is a tactic that first performs T and then performs T1 on the first
   subgoal generated by T, performs T2 on the second subgoal, etc. *)

(* The repeat Tactical *)

Theorem In10 : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat (try (left; reflexivity); right).
Qed.

Theorem In10' : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat (left; reflexivity).
  repeat (right; (try (left; reflexivity))).
Qed.

(* Exercise *)

Fixpoint optimize_0plus_b (b : bexp) : bexp :=
  match b with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq x y => BEq (optimize_0plus x) (optimize_0plus y)
  | BLe x y => BLe (optimize_0plus x) (optimize_0plus y)
  | BNot b => BNot (optimize_0plus_b b)
  | BAnd x y => BAnd (optimize_0plus_b x) (optimize_0plus_b y)
  end.

Theorem optimize_0plus_b_sound : forall b,
  beval (optimize_0plus_b b) = beval b.
Proof.
  intros. induction b;
  try (simpl; reflexivity).
  try simpl; rewrite optimize_0plus_sound;
      rewrite optimize_0plus_sound; reflexivity.
  try simpl; rewrite optimize_0plus_sound;
      rewrite optimize_0plus_sound; reflexivity.
  - simpl. rewrite IHb. reflexivity.
  - simpl. rewrite IHb1. rewrite IHb2. reflexivity.
Qed.

(* The omega Tactic *)

Example silly_presburger_example : forall m n o p,
  m + n <= n + o /\ o + 3 = p + 3 ->
  m <= p.
Proof. intros. omega. Qed.

(* A Few More Handy Tactics *)

(* clear H: Delete hypothesis H from the context.
   subst x
   subst
   rename ... into ...
   assumption
   contradiction
   constructor *)

(* Evaluation as a Relation *)

Module aevalR_first_try.

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

Notation "e '\\' n" := (aevalR e n)
                       (at level 50, left associativity)
                       : type_scope.

End aevalR_first_try.

Reserved Notation "e '\\' n" (at level 50, left associativity).

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

Inductive S : Type :=
  | cons : Set -> S.

(* Equivalence of the Definitions *)

Theorem aeval_iff_aevalR : forall a n, (a \\ n) <-> aeval a = n.
Proof.
  split.
  - intros. induction H; simpl.
    + reflexivity.
    + rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
    + rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
    + rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
  - generalize dependent n.
    induction a; simpl; intros; subst.
    + apply E_ANum.
    + apply E_APlus.
      * apply IHa1. reflexivity.
      * apply IHa2. reflexivity.
    + apply E_AMinus.
      * apply IHa1. reflexivity.
      * apply IHa2. reflexivity.
    + apply E_AMult.
      * apply IHa1. reflexivity.
      * apply IHa2. reflexivity.
Qed.

Inductive bevalR : bexp -> bool -> Prop :=
  | E_BTrue : BTrue \\ true
  | E_BFalse : BFalse \\ false
  | E_BEq : forall e1 e2 n1 n2,
    (aevalR e1 n1) -> (aevalR e2 n2) -> (BEq e1 e2) \\ beq_nat n1 n2
  | E_BLe : forall e1 e2 n1 n2,
    (aevalR e1 n1) -> (aevalR e2 n2) -> (BLe e1 e2) \\ leb n1 n2
  | E_BNot : forall e1 b1,
    (e1 \\ b1) -> (BNot e1) \\ negb b1
  | E_BAnd : forall e1 e2 b1 b2,
    (e1 \\ b1) -> (e2 \\ b2) -> (BAnd e1 e2) \\ (andb b1 b2)
  where "e '\\' b" := (bevalR e b) : type_scope.

Theorem beval_iff_bevalR : forall b bv,
  bevalR b bv <-> beval b = bv.
Proof.
  split.
  - intros. induction H; simpl.
    + reflexivity.
    + reflexivity.
    + apply aeval_iff_aevalR in H. apply aeval_iff_aevalR in H0.
      rewrite H. rewrite H0.
      reflexivity.
    + apply aeval_iff_aevalR in H. apply aeval_iff_aevalR in H0.
      rewrite H. rewrite H0.
      reflexivity.
    + subst. reflexivity.
    + subst. reflexivity.
  - generalize dependent bv.
    induction b; simpl; intros; subst.
    + apply E_BTrue.
    + apply E_BFalse.
    + apply E_BEq.
      * apply aeval_iff_aevalR. reflexivity.
      * apply aeval_iff_aevalR. reflexivity.
    + apply E_BLe.
      * apply aeval_iff_aevalR. reflexivity.
      * apply aeval_iff_aevalR. reflexivity.
    + apply E_BNot.
      apply IHb. reflexivity.
    + apply E_BAnd.
      * apply IHb1. reflexivity.
      * apply IHb2. reflexivity.
Qed.

End AExp.

(* Computational vs. Relation Definitions *)

Module aevalR_division.

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

Reserved Notation "e '\\' n" (at level 50, left associativity).

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum : forall (n:nat),
      (ANum n) \\ n
  | E_APlus : forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (APlus a1 a2) \\ (n1 + n2)
  | E_AMinus : forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (AMinus a1 a2) \\ (n1 - n2)
  | E_AMult :  forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (AMult a1 a2) \\ (n1 * n2)
  | E_ADiv :  forall (a1 a2: aexp) (n1 n2 n3: nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (n2 > 0) ->
      (mult n2 n3 = n1) -> (ADiv a1 a2) \\ n3

where "a '\\' n" := (aevalR a n) : type_scope.

End aevalR_division.

(* TODO aevalR_extended. *)

(* Expressions with Variables *)

(* States *)

Definition state := total_map nat.

Definition empty_state : state := t_empty 0.

(* Syntax *)

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

Definition W : id := Id "W".
Definition X : id := Id "X".
Definition Y : id := Id "Y".
Definition Z : id := Id "Z".

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

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

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

Example aexp1 : aeval (t_update empty_state X 5)
                      (APlus (ANum 3) (AMult (AId X) (ANum 2))) = 13.
Proof.
  simpl. reflexivity.
Qed.

(* Commands *)

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

Definition fact_in_coq : com :=
  Z ::= AId X;;
  Y ::= ANum 1;;
  WHILE BNot (BEq (AId Z) (ANum 0)) DO
    Y ::= AMult (AId Y) (AId Z);;
    Z ::= AMinus (AId Z) (ANum 1)
  END.

Reserved Notation "c1 '/' st '\\' st'"
                  (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st, SKIP / st \\ st
  | E_Ass : forall st a1 n x,
    aeval st a1 = n ->
    (x ::= a1) / st \\ (t_update st x n)
  | E_Seq : forall c1 c2 st st' st'',
    c1 / st \\ st' ->
    c2 / st' \\ st'' ->
    (c1 ;; c2) / st \\ st''
  | E_IfTrue : forall st st' b c1 c2,
    beval st b = true ->
    c1 / st \\ st' ->
    (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_IfFalse : forall st st' b c1 c2,
    beval st b = false ->
    c2 / st \\ st' ->
    (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_WhileFalse : forall b st c,
    beval st b = false ->
    (WHILE b DO c END) / st \\ st
  | E_WhileTrue : forall st st' st'' b c,
    beval st b = true ->
    c / st \\ st' ->
    (WHILE b DO c END) / st' \\ st'' ->
    (WHILE b DO c END) / st \\ st''
  where "c1 '/' st '\\' st'" := (ceval c1 st st').

Example ceval_example1 :
  (X ::= ANum 2;;
   IFB BLe (AId X) (ANum 1)
     THEN Y ::= ANum 3
     ELSE Z ::= ANum 4
   FI)
  /  empty_state
  \\ (t_update (t_update empty_state X 2) Z 4).
Proof.
  eapply E_Seq.
  - apply E_Ass. reflexivity.
  - apply E_IfFalse.
    + simpl. reflexivity.
    + apply E_Ass. reflexivity.
Qed.

(* TODO Exercises *)

(* Determinism of Evaluation *)

Theorem ceval_dterministic : forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof.
  intros.
  generalize dependent st2.
  induction H; intros st2 E2; inversion E2; subst.
  - reflexivity.
  - reflexivity.
  - assert (EQ : st' = st'0).
    { apply IHceval1. apply H3. }
    subst. apply IHceval2. apply H6.
  - apply IHceval. apply H7.
  - rewrite H in H6. inversion H6.
  - rewrite H in H6. inversion H6.
  - apply IHceval. apply H7.
  - reflexivity.
  - rewrite H in H2. inversion H2.
  - rewrite H in H6. inversion H6.
  - assert (EQ : st' = st'0).
    { apply IHceval1. apply H5. }
    apply IHceval2. subst. apply H8.
Qed.

(* Reasoning About Imp Programs *)

Definition plus2 : com :=
  X ::= (APlus (AId X) (ANum 2)).

Theorem plus2_spec : forall st n st',
  st X = n ->
  plus2 / st \\ st' ->
  st' X = n + 2.
Proof.
  intros.
  inversion H0.
  subst. simpl. apply t_update_eq.
Qed.

(* TODO Exercises *)


(****************************************************************************

          IEEE754  :  MSB

          Laurent Thery

  ******************************************************************************)
Require Export Fprop.
Require Export Zdivides.
Require Export Fnorm.
Section mf.
Variable radix : Z.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.

Let FtoRradix := FtoR radix.
Local Coercion FtoRradix : float >-> R.

Fixpoint maxDiv (v : Z) (p : nat) {struct p} : nat :=
  match p with
  | O => 0
  | S p' =>
      match ZdividesP v (Zpower_nat radix p) with
      | left _ => p
      | right _ => maxDiv v p'
      end
  end.

Theorem maxDivLess : forall (v : Z) (p : nat), maxDiv v p <= p.
intros v p; elim p; simpl in |- *; auto.
intros n H'; case (ZdividesP v (radix * Zpower_nat radix n)); auto.
Qed.

Theorem maxDivLt :
 forall (v : Z) (p : nat),
 ~ Zdivides v (Zpower_nat radix p) -> maxDiv v p < p.
intros v p; case p; simpl in |- *; auto.
intros H'; case H'.
apply Zdivides1.
intros n H'; case (ZdividesP v (radix * Zpower_nat radix n)); auto.
intros H'0; case H'; auto.
intros H'0; generalize (maxDivLess v n); auto with arith.
Qed.

Theorem maxDivCorrect :
 forall (v : Z) (p : nat), Zdivides v (Zpower_nat radix (maxDiv v p)).
intros v p; elim p.
unfold maxDiv in |- *; rewrite Zpower_nat_O; auto.
apply Zdivides1.
simpl in |- *.
intros n H'; case (ZdividesP v (radix * Zpower_nat radix n)); simpl in |- *;
 auto with zarith.
Qed.

Theorem maxDivSimplAux :
 forall (v : Z) (p q : nat),
 p = maxDiv v (S (q + p)) -> p = maxDiv v (S p).
intros v p q; elim q.
simpl in |- *; case (ZdividesP v (radix * Zpower_nat radix p)); auto.
intros n H' H'0.
apply H'; auto; clear H'.
simpl in H'0; generalize H'0; clear H'0.
case (ZdividesP v (radix * (radix * Zpower_nat radix (n + p)))).
2: simpl in |- *; auto.
intros H' H'0; Contradict H'0; auto with zarith.
Qed.

Theorem maxDivSimpl :
 forall (v : Z) (p q : nat),
 p < q -> p = maxDiv v q -> p = maxDiv v (S p).
intros v p q H' H'0.
apply maxDivSimplAux with (q := q - S p); auto.
replace (S (q - S p + p)) with q; auto with zarith.
Qed.

Theorem maxDivSimplInvAux :
 forall (v : Z) (p q : nat),
 p = maxDiv v (S p) -> p = maxDiv v (S (q + p)).
intros v p q H'; elim q.
simpl in |- *; auto.
intros n; simpl in |- *.
case (ZdividesP v (radix * Zpower_nat radix (n + p))); auto.
case (ZdividesP v (radix * (radix * Zpower_nat radix (n + p)))); auto.
intros H'0 H'1 H'2; Contradict H'2; auto with zarith.
case (ZdividesP v (radix * (radix * Zpower_nat radix (n + p)))); auto.
intros H'0 H'1 H'2; case H'1.
case H'0; intros z1 Hz1; exists (radix * z1)%Z;rewrite Hz1.
unfold Zpower_nat; simpl; ring.
Qed.

Theorem maxDivSimplInv :
 forall (v : Z) (p q : nat),
 p < q -> p = maxDiv v (S p) -> p = maxDiv v q.
intros v p q H' H'0.
replace q with (S (q - S p + p)); auto with zarith.
apply maxDivSimplInvAux; auto.
Qed.

Theorem maxDivUnique :
 forall (v : Z) (p : nat),
 p = maxDiv v (S p) ->
 Zdivides v (Zpower_nat radix p) /\ ~ Zdivides v (Zpower_nat radix (S p)).
intros v p H'; split.
rewrite H'.
apply maxDivCorrect; auto.
red in |- *; intros H'0; generalize H'; clear H'.
simpl in |- *.
case (ZdividesP v (radix * Zpower_nat radix p)); simpl in |- *; auto.
intros H' H'1; Contradict H'1; auto with zarith.
Qed.

Theorem maxDivUniqueDigit :
 forall v : Z,
 v <> 0 ->
 Zdivides v (Zpower_nat radix (maxDiv v (digit radix v))) /\
 ~ Zdivides v (Zpower_nat radix (S (maxDiv v (digit radix v)))).
intros v H'.
apply maxDivUnique; auto.
apply maxDivSimpl with (q := digit radix v); auto.
apply maxDivLt; auto.
apply NotDividesDigit; auto.
Qed.

Theorem maxDivUniqueInverse :
 forall (v : Z) (p : nat),
 Zdivides v (Zpower_nat radix p) ->
 ~ Zdivides v (Zpower_nat radix (S p)) -> p = maxDiv v (S p).
intros v p H' H'0; simpl in |- *.
case (ZdividesP v (radix * Zpower_nat radix p)); auto.
intros H'1; case H'0; simpl in |- *; auto.
intros H'1.
generalize H'; case p; simpl in |- *; auto.
intros n H'2; case (ZdividesP v (radix * Zpower_nat radix n)); auto.
intros H'3; case H'3; auto.
Qed.

Theorem maxDivUniqueInverseDigit :
 forall (v : Z) (p : nat),
 v <> 0 ->
 Zdivides v (Zpower_nat radix p) ->
 ~ Zdivides v (Zpower_nat radix (S p)) -> p = maxDiv v (digit radix v).
intros v p H' H'0 H'1.
apply maxDivSimplInv; auto.
2: apply maxDivUniqueInverse; auto.
apply Zpower_nat_anti_monotone_lt with (n := radix); auto.
apply Zle_lt_trans with (m := Zabs v); auto.
rewrite <- (fun x => Zabs_eq (Zpower_nat radix x)); auto with zarith;
 apply ZDividesLe; auto.
apply digitMore; auto.
Qed.

Theorem maxDivPlus :
 forall (v : Z) (n : nat),
 v <> 0 ->
 maxDiv (v * Zpower_nat radix n) (digit radix v + n) =
 maxDiv v (digit radix v) + n.
intros v n H.
replace (digit radix v + n) with (digit radix (v * Zpower_nat radix n)); auto.
apply sym_equal.
apply maxDivUniqueInverseDigit; auto.
red in |- *; intros Z1; case (Zmult_integral _ _ Z1); intros Z2.
case H; auto.
absurd (0 < Zpower_nat radix n)%Z; auto with zarith.
rewrite Zpower_nat_is_exp.
repeat rewrite (fun x : Z => Zmult_comm x (Zpower_nat radix n)).
apply ZdividesMult; auto.
case (maxDivUniqueDigit v); auto.
replace (S (maxDiv v (digit radix v) + n)) with
 (S (maxDiv v (digit radix v)) + n); auto.
rewrite Zpower_nat_is_exp.
repeat rewrite (fun x : Z => Zmult_comm x (Zpower_nat radix n)).
red in |- *; intros H'.
absurd (Zdivides v (Zpower_nat radix (S (maxDiv v (digit radix v))))).
case (maxDivUniqueDigit v); auto.
apply ZdividesDiv with (p := Zpower_nat radix n); auto with zarith.
apply digitAdd; auto with zarith.
Qed.

Definition LSB (x : float) :=
  (Z_of_nat (maxDiv (Fnum x) (Fdigit radix x)) + Fexp x)%Z.

Theorem LSB_shift :
 forall (x : float) (n : nat), ~ is_Fzero x -> LSB x = LSB (Fshift radix n x).
intros x n H'; unfold LSB, Fdigit in |- *; simpl in |- *.
rewrite digitAdd; auto with arith.
rewrite maxDivPlus; auto.
rewrite inj_plus; ring.
Qed.

Theorem LSB_comp :
 forall (x y : float) (n : nat), ~ is_Fzero x -> x = y :>R -> LSB x = LSB y.
intros x y H' H'0 H'1.
case (FshiftCorrectSym radix) with (2 := H'1); auto.
intros m1 H'2; elim H'2; intros m2 E; clear H'2.
rewrite (LSB_shift x m1); auto.
rewrite E; auto.
apply sym_equal; apply LSB_shift; auto.
apply (NisFzeroComp radix) with (x := x); auto.
Qed.

Theorem maxDiv_opp :
 forall (v : Z) (p : nat), maxDiv v p = maxDiv (- v) p.
intros v p; elim p; simpl in |- *; auto.
intros n H; case (ZdividesP v (radix * Zpower_nat radix n));
 case (ZdividesP (- v) (radix * Zpower_nat radix n)); auto.
intros Z1 Z2; case Z1.
case Z2; intros z1 Hz1; exists (- z1)%Z; rewrite Hz1; ring.
intros Z1 Z2; case Z2.
case Z1; intros z1 Hz1; exists (- z1)%Z.
rewrite <- (Zopp_involutive v); rewrite Hz1; ring.
Qed.

Theorem LSB_opp : forall x : float, LSB x = LSB (Fopp x).
intros x; unfold LSB in |- *; simpl in |- *.
rewrite Fdigit_opp; auto.
rewrite maxDiv_opp; auto.
Qed.

Theorem maxDiv_abs :
 forall (v : Z) (p : nat), maxDiv v p = maxDiv (Zabs v) p.
intros v p; elim p; simpl in |- *; auto.
intros n H; case (ZdividesP v (radix * Zpower_nat radix n));
 case (ZdividesP (Zabs v) (radix  * Zpower_nat radix n));
 auto.
intros Z1 Z2; case Z1.
case Z2; intros z1 Hz1; exists (Zabs z1); rewrite Hz1.
rewrite Zabs_Zmult; f_equal. apply Zabs_eq. auto with zarith.
intros Z1 Z2; case Z2.
case Z1; intros z1 Hz1.
case (Zle_or_lt v 0); intros Z4.
exists (- z1)%Z; rewrite <- (Zopp_involutive v);
 rewrite <- (Zabs_eq_opp v); auto; rewrite Hz1; ring.
exists z1; rewrite <- (Zabs_eq v); auto with zarith; rewrite Hz1; ring.
Qed.

Theorem LSB_abs : forall x : float, LSB x = LSB (Fabs x).
intros x; unfold LSB in |- *; simpl in |- *.
rewrite Fdigit_abs; auto.
rewrite maxDiv_abs; auto.
Qed.

Definition MSB (x : float) := Zpred (Z_of_nat (Fdigit radix x) + Fexp x).

Theorem MSB_shift :
 forall (x : float) (n : nat), ~ is_Fzero x -> MSB x = MSB (Fshift radix n x).
intros; unfold MSB, Fshift, Fdigit in |- *; simpl in |- *.
rewrite digitAdd; auto with zarith.
rewrite inj_plus; unfold Zpred in |- *; ring.
Qed.

Theorem MSB_comp :
 forall (x y : float) (n : nat), ~ is_Fzero x -> x = y :>R -> MSB x = MSB y.
intros x y H' H'0 H'1.
case (FshiftCorrectSym radix) with (2 := H'1); auto.
intros m1 H'2; elim H'2; intros m2 E; clear H'2.
rewrite (MSB_shift x m1); auto.
rewrite E; auto.
apply sym_equal; apply MSB_shift; auto.
apply (NisFzeroComp radix) with (x := x); auto.
Qed.

Theorem MSB_opp : forall x : float, MSB x = MSB (Fopp x).
intros x; unfold MSB in |- *; simpl in |- *.
rewrite Fdigit_opp; auto.
Qed.

Theorem MSB_abs : forall x : float, MSB x = MSB (Fabs x).
intros x; unfold MSB in |- *; simpl in |- *.
rewrite Fdigit_abs; auto.
Qed.

Theorem LSB_le_MSB : forall x : float, ~ is_Fzero x -> (LSB x <= MSB x)%Z.
intros x H'; unfold LSB, MSB in |- *.
apply Zle_Zpred.
cut (maxDiv (Fnum x) (Fdigit radix x) < Fdigit radix x); auto with zarith.
apply maxDivLt; auto.
unfold Fdigit in |- *; apply NotDividesDigit; auto.
Qed.

Theorem Fexp_le_LSB : forall x : float, (Fexp x <= LSB x)%Z.
intros x; unfold LSB in |- *.
auto with zarith.
Qed.

Theorem Ulp_Le_LSigB :
 forall x : float, (Float 1%nat (Fexp x) <= Float 1%nat (LSB x))%R.
intros x; apply (oneExp_le radix); auto.
apply Fexp_le_LSB; auto.
Qed.

Theorem Fexp_le_MSB : forall x : float, ~ is_Fzero x -> (Fexp x <= MSB x)%Z.
intros x H'; unfold MSB in |- *.
cut (Fdigit radix x <> 0%Z :>Z); unfold Zpred in |- *;
 auto with zarith.
unfold Fdigit in |- *.
red in |- *; intros H'0; absurd (digit radix (Fnum x) = 0); auto with zarith.
apply not_eq_sym; apply lt_O_neq; apply digitNotZero; auto.
Qed.

Theorem MSB_le_abs :
 forall x : float, ~ is_Fzero x -> (Float 1%nat (MSB x) <= Fabs x)%R.
intros x H'; unfold MSB, FtoRradix, FtoR in |- *; simpl in |- *.
replace (Zpred (Fdigit radix x + Fexp x)) with
 (Zpred (Fdigit radix x) + Fexp x)%Z; [ idtac | unfold Zpred in |- *; ring ].
rewrite powerRZ_add; auto with real zarith.
rewrite Rmult_1_l.
repeat rewrite (fun r : R => Rmult_comm r (powerRZ radix (Fexp x))).
apply Rmult_le_compat_l; auto with real zarith.
rewrite <- inj_pred; auto with real zarith.
rewrite <- Zpower_nat_Z_powerRZ; auto.
apply Rle_IZR; auto.
unfold Fdigit in |- *; auto with arith.
apply digitLess; auto.
unfold Fdigit in |- *.
apply not_eq_sym; apply lt_O_neq; apply digitNotZero; auto.
Qed.

Theorem abs_lt_MSB :
 forall x : float, (Fabs x < Float 1%nat (Zsucc (MSB x)))%R.
intros x.
rewrite (MSB_abs x).
unfold MSB, FtoRradix, FtoR in |- *.
rewrite <- Zsucc_pred; simpl in |- *.
rewrite powerRZ_add; auto with real zarith.
rewrite Rmult_1_l.
repeat rewrite (fun r : R => Rmult_comm r (powerRZ radix (Fexp x))).
apply Rmult_lt_compat_l; auto with real zarith.
rewrite <- Zpower_nat_Z_powerRZ; auto with arith.
apply Rlt_IZR.
unfold Fdigit in |- *; auto with arith.
unfold Fabs in |- *; simpl in |- *.
pattern (Zabs (Fnum x)) at 1 in |- *; rewrite <- (Zabs_eq (Zabs (Fnum x)));
 auto with zarith.
Qed.

Theorem LSB_le_abs :
 forall x : float, ~ is_Fzero x -> (Float 1%nat (LSB x) <= Fabs x)%R.
intros x H'; apply Rle_trans with (FtoRradix (Float 1%nat (MSB x))).
apply (oneExp_le radix); auto.
apply LSB_le_MSB; auto.
apply MSB_le_abs; auto.
Qed.

Theorem MSB_monotoneAux :
 forall x y : float,
 (Fabs x <= Fabs y)%R -> Fexp x = Fexp y -> (MSB x <= MSB y)%Z.
intros x y H' H'0; unfold MSB in |- *.
rewrite <- H'0.
cut (Fdigit radix x <= Fdigit radix y)%Z;
 [ unfold Zpred in |- *; auto with zarith | idtac ].
unfold Fdigit in |- *; apply inj_le.
apply digit_monotone; auto.
apply le_IZR.
apply Rmult_le_reg_l with (r := powerRZ radix (Fexp x));
 auto with real zarith.
repeat rewrite (Rmult_comm (powerRZ radix (Fexp x))); auto.
pattern (Fexp x) at 2 in |- *; rewrite H'0; auto.
Qed.

Theorem MSB_monotone :
 forall x y : float,
 ~ is_Fzero x -> ~ is_Fzero y -> (Fabs x <= Fabs y)%R -> (MSB x <= MSB y)%Z.
intros x y H' H'0 H'1; rewrite (MSB_abs x); rewrite (MSB_abs y).
case (Zle_or_lt (Fexp (Fabs x)) (Fexp (Fabs y))); simpl in |- *; intros Zle1.
rewrite
 MSB_shift with (x := Fabs y) (n := Zabs_nat (Fexp (Fabs y) - Fexp (Fabs x))).
apply MSB_monotoneAux; auto.
unfold FtoRradix in |- *; repeat rewrite Fabs_correct; auto with real arith.
rewrite FshiftCorrect; auto with real arith.
repeat rewrite Fabs_correct; auto with real arith.
repeat rewrite Rabs_Rabsolu; repeat rewrite <- Fabs_correct;
 auto with real arith.
unfold Fshift in |- *; simpl in |- *.
rewrite inj_abs; [ ring | auto with zarith ].
apply Fabs_Fzero; auto.
rewrite
 MSB_shift with (x := Fabs x) (n := Zabs_nat (Fexp (Fabs x) - Fexp (Fabs y))).
apply MSB_monotoneAux; auto.
unfold FtoRradix in |- *; repeat rewrite Fabs_correct; auto with real arith.
rewrite FshiftCorrect; auto with real arith.
repeat rewrite Fabs_correct; auto with real arith.
repeat rewrite Rabs_Rabsolu; repeat rewrite <- Fabs_correct;
 auto with real arith.
unfold Fshift in |- *; simpl in |- *.
rewrite inj_abs; [ ring | auto with zarith ].
apply Fabs_Fzero; auto.
Qed.

Theorem MSB_le_multAux :
 forall x y : float,
 ~ is_Fzero x -> ~ is_Fzero y -> (MSB x + MSB y <= MSB (Fmult x y))%Z.
intros x y H' H'0; unfold MSB, Fmult, Fdigit in |- *; simpl in |- *.
replace
 (Zpred (digit radix (Fnum x) + Fexp x) +
  Zpred (digit radix (Fnum y) + Fexp y))%Z with
 (Zpred
    (digit radix (Fnum x) + Zpred (digit radix (Fnum y)) + (Fexp x + Fexp y)));
 [ idtac | unfold Zpred in |- *; ring ].
cut
 (digit radix (Fnum x) + Zpred (digit radix (Fnum y)) <=
  digit radix (Fnum x * Fnum y))%Z;
 [ unfold Zpred in |- *; auto with zarith | idtac ].
rewrite <- inj_pred; auto with float zarith; try rewrite <- inj_plus.
apply inj_le.
rewrite <- digitAdd; auto with zarith.
apply digit_monotone; auto with zarith.
repeat rewrite Zabs_Zmult.
apply Zle_Zmult_comp_l; auto with zarith.
rewrite (fun x => Zabs_eq (Zpower_nat radix x)); auto with zarith.
apply not_eq_sym; apply lt_O_neq; apply digitNotZero; auto.
Qed.

Theorem MSB_le_mult :
 forall x y : float,
 ~ is_Fzero x ->
 ~ is_Fzero y ->
 (Fmult (Float 1%nat (MSB x)) (Float 1%nat (MSB y)) <=
  Float 1%nat (MSB (Fmult x y)))%R.
intros x y H' H'0.
rewrite <- oneZplus.
apply (oneExp_le radix); auto.
apply MSB_le_multAux; auto.
Qed.

Theorem mult_le_MSBAux :
 forall x y : float,
 ~ is_Fzero x -> ~ is_Fzero y -> (MSB (Fmult x y) <= Zsucc (MSB x + MSB y))%Z.
intros x y H' H'0; unfold MSB, Fmult, Fdigit in |- *; simpl in |- *.
replace
 (Zsucc
    (Zpred (digit radix (Fnum x) + Fexp x) +
     Zpred (digit radix (Fnum y) + Fexp y))) with
 (Zpred (digit radix (Fnum x) + digit radix (Fnum y) + (Fexp x + Fexp y)));
 [ idtac | unfold Zpred, Zsucc in |- *; ring ].
cut
 (digit radix (Fnum x * Fnum y) <=
  digit radix (Fnum x) + digit radix (Fnum y))%Z;
 [ unfold Zpred in |- *; auto with zarith | idtac ].
rewrite <- inj_plus.
apply inj_le; auto.
rewrite <- digitAdd; auto with arith.
apply digit_monotone; auto with arith.
repeat rewrite Zabs_Zmult.
apply Zle_Zmult_comp_l; auto with zarith.
rewrite (fun x => Zabs_eq (Zpower_nat radix x)); auto with zarith.
Qed.

Theorem mult_le_MSB :
 forall x y : float,
 ~ is_Fzero x ->
 ~ is_Fzero y ->
 (Float 1%nat (MSB (Fmult x y)) <=
  radix * Fmult (Float 1%nat (MSB x)) (Float 1%nat (MSB y)))%R.
intros x y H' H'0; rewrite <- oneZplus.
replace (radix * Float 1%nat (MSB x + MSB y))%R with
 (FtoRradix (Float 1%nat (Zsucc (MSB x + MSB y)))).
apply (oneExp_le radix); auto.
apply mult_le_MSBAux; auto.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
rewrite powerRZ_Zs; auto with real zarith; ring.
Qed.

Theorem MSB_mix :
 forall x y : float,
 ~ is_Fzero x ->
 ~ is_Fzero y ->
 (Fabs x * Float 1%nat (MSB y) < radix * (Fabs y * Float 1%nat (MSB x)))%R.
intros x y H' H'0; rewrite (MSB_abs x); rewrite (MSB_abs y).
apply Rle_lt_trans with (Fabs x * Fabs y)%R; auto with real.
apply Rmult_le_compat_l; auto with real.
unfold FtoRradix in |- *; rewrite Fabs_correct; auto with real arith.
rewrite <- MSB_abs; apply MSB_le_abs; auto.
rewrite (Rmult_comm (Fabs x)).
replace (radix * (Fabs y * Float 1%nat (MSB (Fabs x))))%R with
 (Fabs y * (radix * Float 1%nat (MSB (Fabs x))))%R;
 [ idtac | ring ].
apply Rmult_lt_compat_l; auto with real.
unfold FtoRradix, FtoR in |- *; simpl in |- *; auto with real arith.
rewrite Rmult_comm; replace 0%R with (powerRZ radix (Fexp y) * 0)%R;
 [ idtac | ring ].
apply Rmult_lt_compat_l; auto with real arith.
rewrite Zabs_absolu.
replace 0%R with (INR 0); [ idtac | simpl in |- *; auto ];
 rewrite <- INR_IZR_INZ; apply INR_lt_nm.
apply absolu_lt_nz; auto.
replace (radix * Float 1%nat (MSB (Fabs x)))%R with
 (FtoRradix (Float 1%nat (Zsucc (MSB (Fabs x))))).
rewrite <- MSB_abs; apply abs_lt_MSB; auto.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
rewrite powerRZ_Zs; auto with real zarith; ring.
Qed.

Theorem LSB_rep :
 forall x y : float,
 ~ is_Fzero y ->
 (LSB x <= LSB y)%Z -> exists z : Z, y = Float z (Fexp x) :>R.
intros x y H' H'0.
case (Zle_or_lt (Fexp x) (Fexp y)); intros Zl1.
exists (Fnum y * Zpower_nat radix (Zabs_nat (Fexp y - Fexp x)))%Z.
pattern (Fexp x) at 2 in |- *;
 replace (Fexp x) with (Fexp y - Zabs_nat (Fexp y - Fexp x))%Z.
unfold FtoRradix in |- *;
 rewrite <-
  (FshiftCorrect radix) with (n := Zabs_nat (Fexp y - Fexp x)) (x := y);
 auto.
rewrite inj_abs; try ring; auto with zarith.
exists (Zquotient (Fnum y) (Zpower_nat radix (Zabs_nat (Fexp x - Fexp y)))).
unfold FtoRradix in |- *;
 rewrite <-
  (FshiftCorrect radix)
                        with
                        (n := Zabs_nat (Fexp x - Fexp y))
                       (x :=
                         Float
                           (Zquotient (Fnum y)
                              (Zpower_nat radix (Zabs_nat (Fexp x - Fexp y))))
                           (Fexp x)); auto.
unfold Fshift in |- *; simpl in |- *.
cut (0 <= Fexp x - Fexp y)%Z;
 [ intros Le1; repeat rewrite inj_abs | auto with zarith ];
 auto.
unfold FtoR in |- *; simpl in |- *; auto.
replace (Fexp x - (Fexp x - Fexp y))%Z with (Fexp y); [ idtac | ring ].
replace
 (Zquotient (Fnum y) (Zpower_nat radix (Zabs_nat (Fexp x - Fexp y))) *
  Zpower_nat radix (Zabs_nat (Fexp x - Fexp y)))%Z with (
 Fnum y); auto.
apply ZdividesZquotient; auto with zarith.
apply
 ZdividesTrans
  with (m := Zpower_nat radix (maxDiv (Fnum y) (Fdigit radix y))).
apply maxDivCorrect.
apply ZdividesLessPow; auto.
apply ZleLe.
rewrite inj_abs; auto with zarith.
apply Zplus_le_reg_l with (p := Fexp y).
apply Zle_trans with (LSB x).
replace (Fexp y + (Fexp x - Fexp y))%Z with (Fexp x); [ idtac | ring ].
apply Fexp_le_LSB.
rewrite Zplus_comm; auto.
Qed.

Theorem LSB_rep_min :
 forall p : float, exists z : Z, p = Float z (LSB p) :>R.
intros p;
 exists (Zquotient (Fnum p) (Zpower_nat radix (Zabs_nat (LSB p - Fexp p)))).
unfold FtoRradix, FtoR, LSB in |- *; simpl in |- *.
rewrite powerRZ_add; auto with real zarith.
rewrite <- Rmult_assoc.
replace (maxDiv (Fnum p) (Fdigit radix p) + Fexp p - Fexp p)%Z with
 (Z_of_nat (maxDiv (Fnum p) (Fdigit radix p))); auto.
rewrite absolu_INR.
rewrite <- Zpower_nat_Z_powerRZ; auto with zarith.
rewrite <- Rmult_IZR.
rewrite <- ZdividesZquotient; auto with zarith.
apply maxDivCorrect.
ring.
Qed.
End mf.


Require Import Even.
From mathcomp Require Import eqtype ssrnat fintype div bigop prime binomial.
Require Import ssreflect ssrfun ssrbool.

Theorem t: forall n:nat,even(n*(1+n)).
Proof.
intros.
apply even_mult_aux.
elim n.
left.
SearchAbout(even _).
apply even_O.
intros.
elim H.
right.
SearchAbout(even _).
apply even_S, odd_S, H0.
left.
apply H0.
Qed.

Theorem tri:forall n:nat, even(n*(1+n)*(2+n)).
Proof.
intros.
apply even_mult_aux.
left.
apply t.
Qed.

Theorem sqn_even:forall n:nat, even (n ^ 2) -> even n.
Proof.
intros.
rewrite <-mulnn in H.
apply even_mult_aux in H.
destruct H.
apply H.
apply H.
Qed.


Require Import Arith.
Require Import Recdef.
Require Import List.

Open Scope list_scope.

Fixpoint num_oc n l :=
  match l with
    | nil => 0
    | cons h tl =>
      match eq_nat_dec n h with
        | left _ => S(num_oc n tl)
        | right _ => num_oc n tl
      end
  end.

Definition equiv l l' := forall n:nat, num_oc n l = num_oc n l'.

(** Prove os dois lemas a seguir. *)
Lemma equiv_sub: forall l l' a, equiv l l' -> equiv (a::l) (a::l').
Proof.
  intros l l' a H.
  unfold equiv in *.
  intro n.
  simpl num_oc.
  destruct (Nat.eq_dec n a).
  - subst.
    rewrite <- H.
    reflexivity.
  - subst.
    rewrite <- H.
    reflexivity.
Qed.

Lemma equiv_trans: forall l l' l'', equiv l l' -> equiv l' l'' -> equiv l l''.
Proof.
  intros l l' l'' H H1.
  unfold equiv in *.
  intro n.
  rewrite <- H1.
  rewrite <- H.
  reflexivity.
Qed.

Function bubble l {measure length l} :=
  match l with
    | h0 :: h1 :: tl =>
      match le_lt_dec h0 h1 with
        | left _ => h0 :: (bubble (h1 :: tl))
        | right _ => h1 :: (bubble (h0 :: tl))
      end
    | _ => l
    end.
Proof.
  intros. simpl. auto.
  intros. simpl. auto.
Defined.

Compute (bubble (1::3::0::nil)).

Lemma bubble_equiv: forall l, equiv (bubble l) l.
Proof.
  intro l.
  functional induction (bubble l).
  - unfold equiv in *.
    intro n.
    remember (h1 :: tl) as l eqn: H.
    simpl num_oc.
    destruct (Nat.eq_dec n h0).
    + rewrite IHl0.
      reflexivity.
    + rewrite IHl0.
      reflexivity.
  - unfold equiv in *.
    intro n.
    simpl num_oc at 1.
    destruct (Nat.eq_dec n h1).
    + rewrite IHl0.
      simpl.
      destruct (Nat.eq_dec n h0).
      * destruct (Nat.eq_dec n h1).
        ** reflexivity.
        ** apply False_ind.
           contradiction.
      * destruct (Nat.eq_dec n h1).
        ** reflexivity.
        ** apply False_ind.
           contradiction.
    + rewrite IHl0.
      simpl.
      destruct (Nat.eq_dec n h0).
      * destruct (Nat.eq_dec n h1).
        ** apply False_ind.
           contradiction.
        ** reflexivity.
      * destruct (Nat.eq_dec n h1).
        ** apply False_ind.
           contradiction.
        ** reflexivity.
  - unfold equiv.
    reflexivity.
Qed.

(** Construa uma nova prova do lema anterior usando o fato que equiv é uma relação transitiva. *)
Lemma bubble_equiv': forall l, equiv (bubble l) l.
Proof.
  intro l.
  functional induction (bubble l).
  - unfold equiv in *.
    intro n.
    remember (h1 :: tl) as l eqn: H.
    rewrite  (equiv_sub (bubble l) l).
    + reflexivity.
    + assumption.
  - unfold equiv in *.
    intro n.
    rewrite (equiv_sub (bubble (h0 :: tl)) (h0 :: tl)).
    simpl num_oc at 1.
    + destruct (Nat.eq_dec n h0).
      * destruct (Nat.eq_dec n h1).
        ** subst.
           inversion _x.
           admit. subst.
           contradiction.
        **
      *
    + assumption.
  - unfold equiv in *.
    intro n.
    reflexivity.
Qed.

(** Adicionar definição de bubbleSort *)
Fixpoint bubbleSort (l: list nat) : list nat :=
  match l with
  | nil => l
  | h::tl => bubble (h :: (bubbleSort tl))
  end.

Compute (bubbleSort (1::3::0::nil)).

Lemma bubbleSort_equiv: forall l, equiv (bubbleSort l) l.
Proof.
  induction l.
  - simpl.
    unfold equiv.
    reflexivity.
  - unfold equiv in *.
    intro n.
    simpl bubbleSort.
    simpl num_oc at 2.
    destruct (Nat.eq_dec n a).
    + rewrite <- IHl.
      assert (H: S (num_oc n (bubbleSort l)) = num_oc n (a::(bubbleSort l))).
      { simpl num_oc at 2.
        destruct (Nat.eq_dec n a).
        - reflexivity.
        - apply False_ind.
          contradiction. }
      rewrite H.
      generalize n.
      fold (equiv  (bubble(a :: bubbleSort l)) (a :: bubbleSort l)).
      apply bubble_equiv.
    + rewrite <- IHl.
      assert (H: num_oc n (bubbleSort l) = num_oc n (a::(bubbleSort l))).
      { simpl num_oc at 2.
        destruct (Nat.eq_dec n a).
        - apply False_ind.
          contradiction.
        - reflexivity. }
      rewrite H.
      generalize n.
      fold (equiv  (bubble(a :: bubbleSort l)) (a :: bubbleSort l)).
      apply bubble_equiv.
Qed.


(* https://stackoverflow.com/questions/55333331/coq-proof-that-factorial-n-factorial-k-factorial-n-k-is-integer/55944121#55944121 *)

From Coq Require Import Arith.

(* Let's prove that (n+m)! is divisible by n! * m!. *)

(* fact2 x y = (x+1) * (x+2) * .. * (x+y) *)

Fixpoint fact2 x y := match y with
  | O => 1
  | S y' => (x + y) * fact2 x y'
end.

Lemma fact2_0 : forall x, fact2 0 x = fact x.
Proof.
  induction x.
  - auto.
  - simpl. rewrite IHx. auto. Qed.

Lemma fact_fact2 : forall x y, fact x * fact2 x y = fact (x + y).
Proof.
  induction x.
  - intros. simpl. rewrite fact2_0. ring.
  - induction y.
    + simpl. replace (x + 0) with x by ring. ring.
    + simpl. replace (x + S y) with (S x + y) by ring. rewrite <- IHy. simpl. ring. Qed.

Lemma fact2_left : forall x y, fact2 x (S y) = S x * fact2 (S x) y.
Proof. intros x y. generalize dependent x. induction y.
  - intros. simpl. ring.
  - intros. unfold fact2. fold (fact2 x (S y)). fold (fact2 (S x) y).
    rewrite IHy. ring. Qed.

Lemma fact_div_fact2 : forall x y, exists e, fact2 x y = e * fact y.
Proof. intros x y. generalize dependent x. induction y.
  - intros. simpl. exists 1. auto.
  - induction x.
    + unfold fact2. fold (fact2 0 y). unfold fact. fold (fact y). destruct (IHy 0). rewrite H.
      exists x. ring.
    + unfold fact2. fold (fact2 (S x) y).
      destruct (IHy (S x)). destruct IHx. exists (x0 + x1).
      replace ((S x + S y) * fact2 (S x) y) with (S x * fact2 (S x) y + S y * fact2 (S x) y) by ring.
      rewrite <- fact2_left. rewrite H0. rewrite H.
      replace (S y * (x0 * fact y)) with (x0 * (S y * fact y)) by ring.
      unfold fact. fold (fact y). ring. Qed.

Theorem fact_div_fact_fact : forall x y, exists e, fact (x + y) = e * (fact x * fact y).
Proof. intros x y. destruct (fact_div_fact2 x y). exists x0.
  rewrite <- fact_fact2. rewrite H. ring. Qed.


Require Export Tree_Inf.
Require Relations.

Set Implicit Arguments.

Section LTree_bisimilar_def.
 Variable A:Set.

(* An extensional equality on (LTree A) *)
 CoInductive LTree_bisimilar : (LTree A)->(LTree A)->Prop :=
  LTree_bisimilar_leaf : LTree_bisimilar LLeaf LLeaf
| LTree_bisimilar_bin : forall (a:A) (t1 t'1 t2 t'2 : LTree A),
                LTree_bisimilar t1 t'1 ->
                LTree_bisimilar t2 t'2 ->
                LTree_bisimilar (LBin a t1 t2) (LBin a t'1 t'2).

Require Import Relations.

Lemma LTree_bisimilar_refl : (reflexive _ LTree_bisimilar).
Proof.
 unfold reflexive; cofix.
 intro a; case a ; constructor; auto.
Qed.

Lemma LTree_bisimilar_sym : (symmetric _ LTree_bisimilar).
Proof.
 unfold symmetric; cofix.
 intros x y; case x; case y.
 constructor.
 inversion_clear 1.
 inversion_clear 1.
 inversion_clear 1.
 constructor; auto.
Qed.

Lemma LTree_bisimilar_trans : (transitive _ LTree_bisimilar).
Proof.
 unfold transitive; cofix.
 intros x y z ; case x; case y.
 case z;[auto | inversion_clear 2].
 inversion_clear 1.
 inversion_clear 1.
 inversion_clear 1.
 case z; inversion_clear 1.
 constructor; eauto.
Qed.

 Theorem LTree_bisimilar_label :
   forall (p:path) (t t': LTree A),
          LTree_bisimilar t t' ->
          LTree_label t p = LTree_label t' p.
 Proof.
  simple induction p.
  intros t t'; case t; case t'.
  simpl; auto.
  inversion_clear 1.
  inversion_clear 1.
  inversion_clear 1; simpl; auto.
   intros a l;case a; intros H t t'; case t; case t'.
  auto.
  inversion_clear 1.
  inversion_clear 1.
  inversion_clear 1; simpl.
  repeat  rewrite LTree_label_rw0.
  auto.
  repeat  rewrite LTree_label_rw1; auto.
  inversion_clear 1.
  inversion_clear 1.
  inversion_clear 1.
  repeat  rewrite LTree_label_rw1; auto.
 Qed.

 Theorem label_LTree_bisimilar :  forall t t': LTree A,
                          (forall p:path, LTree_label t p = LTree_label t' p)->
                          LTree_bisimilar t t'.
 Proof.
  cofix.
  intros t t'; case t; case t'.
  constructor.
  intros a l l0 H.
  generalize (H nil ).
  simpl.
  unfold LTree_label; simpl.
  discriminate 1.
  intros a l l0 H.
  generalize (H nil).
  simpl.
  unfold LTree_label; simpl.
  discriminate 1.
  intros a l l0 a0 t1 t2 H.
  cut (a = a0).
  simple induction 1; constructor.
  apply label_LTree_bisimilar.
  intro p ;  generalize (H (cons d0 p)).
  repeat rewrite LTree_label_rw0; auto.
  apply label_LTree_bisimilar.
  intro p ; generalize (H (cons d1 p)).
  repeat rewrite LTree_label_rw1; auto.
  generalize (H nil).
  repeat rewrite LTree_label_rw_root_bin; auto.
  injection 1;auto.
 Qed.

End LTree_bisimilar_def.


From mathcomp Require Import all_ssreflect.

(** *** Exercise 1:
    - Let's define the subtype of odd and even natural numbers
    - Intrument Coq to recognize odd/even number built out
      of product and successor
    - Inherit on [odd_nat] the [eqType] structure
*)

Structure odd_nat := Odd {
  oval :> nat;
  oprop : odd oval
}.
Lemma oddP (n : odd_nat) : odd n.
Proof. by case: n. Qed.

Structure even_nat := Even {
  eval :> nat;
  eprop : ~~ (odd eval)
}.
Lemma evenP (n : even_nat) : ~~ (odd n).
Proof. by case: n. Qed.

Example test_odd (n : odd_nat) : ~~ (odd 6) && odd (n * 3).
Proof. Fail by rewrite oddP evenP. Abort.

Canonical even_0 := Even 0 isT.

Lemma oddS n : ~~ (odd n) -> odd n.+1.
Proof.
Qed.

Lemma evenS n : (odd n) -> ~~ (odd n.+1).
Proof.
Qed.

Canonical odd_even (m : even_nat) :=
  Odd m.+1 (oddS m (eprop m)).
Canonical even_odd (m : odd_nat) :=

Lemma odd_mulP (n m : odd_nat) : odd (n * m).
Proof.
Qed.
Canonical odd_mul (n m : odd_nat) :=

Example test_odd (n : odd_nat) : ~~ (odd 6) && odd (n * 3).
Proof. by rewrite oddP evenP. Qed.

Fail Check forall n m : odd_nat, n == m.

Canonical odd_subType :=
Definition odd_eqMixin :=
Canonical odd_eqType :=

Check forall n m : odd_nat, n == m.