Require Import Orders.

(**** Aliases ****)
Definition dlink {A: Type} := @list A. (* "Doubly Linked List". *)
Definition dmerge {A: Type} := @app A.
Definition dsingle {A: Type} (x: A) := cons x nil.
Definition dempty {A: Type} := @nil A.
Definition dlength {A: Type} := @length A.
Definition dmin {A: Type} (d : @dlink A) := (* TO DO *)
  match d with
  | nil => None
  | cons hd tl => Some hd
  end.
Definition drest {A: Type} (d: @dlink A) : @dlink A := (* TO DO *)
  (* Removes the minimum element, and returns the rest of the dlink. *)
  @nil A.
Definition dconsolidate {A N: Type} (* TO DO *)
           (key: A -> N) (link: A -> A -> A) (d: @dlink A): @dlink A :=
  (* A generic consolidation function. See the `consolidate` procedure of CLRS. *)
  dempty.

(**************** Definition ****************)
Module Ops (X: OrderedType).
  Definition lt (a b: X.t) : bool :=
    match X.compare a b with
    | Eq => false
    | Lt => true
    | Gt => false
    end.
  Local Notation "a < b" := (lt a b).

  (* Definition of a Fibonacci Heap. Notable aspects
     - There is no "Node" type. Nodes are themselves fheaps. *)
  Inductive fheap :=
  | Leaf : fheap
  | Atop : X.t -> fheap -> fheap
  | Ptr : @dlink fheap -> fheap.

  (**** Helpers ****)
  Definition extractdl (H : fheap) : (@dlink fheap) :=
    match H with
    | Leaf => dempty
    | Atop x _ => dsingle H
    | Ptr d => d
    end.

  Definition singleton (x: X.t) :=
    Atop x Leaf.

  Definition top (H : fheap) :=
    match H with
    | Leaf => None
    | Atop x _ => Some x
    | Ptr _ => None
    end.

  Definition degree (H : fheap) : nat :=
    match H with
    | Leaf => 0
    | Atop x H' =>
      match H' with
      | Leaf => 0
      | _ => 1
      end
    | Ptr d =>
      dlength d
    end.

  Definition minimum_t (H: fheap) : option X.t :=
    (* "Minimum temporary". Needed as a helper function, but is also one of the
       core operations of an fheap. Identical to `minimum` as of Sun Apr  7 23:28:54
       EDT 2019 *)
    match H with
    | Leaf => None
    | Atop x _ => Some x
    | Ptr d =>
      match (dmin d) with
      | None => None (* Should not happen *)
      | Some H' => top H'
      end
    end.

  Definition link (H1 H2: fheap) : fheap :=
    (* The `fib-heap-link` procedure of CLRS. Links two fheaps constructed using
    `Atop`. *)
    match H1, H2 with
    | Atop x1 H1', Atop x2 H2' =>
      if (x1 < x2) then
        Atop x1 (Ptr (dmerge
                        (extractdl H1')
                        (extractdl H2)))
      else
        Atop x2 (Ptr (dmerge
                        (extractdl H1)
                        (extractdl H2')))
    | _, _ => Leaf (* Should not happen *)
    end.

  Definition consolidate (H: fheap) : fheap :=
    (* The `consolidate` procedure of CLRS. To achieve the required amortized
    time bounds, needs to run in time linear to the number of nodes in the root list. *)
    Ptr (dconsolidate degree link (extractdl H)).

  (**************** Mergeable heap operations ****************)
  (* As defined in CLRS, a mergeable heap has 5 fundamental operations:
   * Make-heap()
   * Insert(H, x)
   * Minimum(H)
   * Extract-min(H)
   * Union(H1, H2)
   In addition, their implementation of a fibonacci heap has two additional *)
  (* operations:
   * Decrease-key(H, x, k)
   * Delete(H, x) *)

  Definition make_heap := Leaf.

  Fixpoint union (H1 H2: fheap) : fheap :=
    match H1, H2 with
    | Leaf, _ => H2
    | _, Leaf => H1 (* I believe these are necessary for efficiency reasons --
                       so we don't get long pointers of leaves *)
    | _, _ => Ptr (dmerge (extractdl H1) (extractdl H2))
    end.

  Definition insert (x: X.t) (H: fheap) : fheap :=
    union (singleton x) H.

  Definition minimum : fheap -> option X.t := minimum_t.

  (* Unlike imperative implementations, doesn't return the minimum
  element. Rather, returns the fheap with the element removed. *)
  Definition extract_min (H: fheap) : option fheap :=
    match H with
    | Leaf => None
    | Atop _ H' => Some H'
    | Ptr d =>
      match (dmin d) with
      | None => None (* Should not happen *)
      | Some H' =>
        match H' with
        | Leaf => None (* Should not happen *)
        | Ptr _ => None (* Should not happen *)
        | Atop x H'' => Some (consolidate (union H'' (Ptr (drest d))))
        end
      end
    end.

End Ops.


Require Import List.
Import ListNotations.

(** ** Traditional Definition *)

Definition symbol := nat.
Definition string X := list X.
Definition card X : Type := string X * string X.
Definition stack X := list (card X).
Definition SRS := stack nat.
Definition BSRS := stack bool.

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

Fixpoint tau1 {X : Type} (A : stack X) : string X :=
  match A with
  | [] => []
  | (x / y) :: A => x ++ (tau1 A)
  end.

Fixpoint tau2 {X : Type} (A : stack X) : string X :=
  match A with
  | [] => []
  | (x / y) :: A => y ++ tau2 A
  end.

(* Post correspondence problem *)
Definition PCP P := exists A : SRS, incl A P /\ A <> [] /\ tau1 A = tau2 A.

(* Modified Post correspondence problem *)
Definition MPCP '((x,y), P) := exists A : SRS, incl A (x/y :: P) /\ x ++ tau1 A = y ++ tau2 A.

(*
  Problem:
    Binary modified Post correspondence problem (BMPCP)

  BMPCP:
    Given a pair (x, y) of binary strings and
    a list P of pairs of binary strings,
    is there a list A = [(x₁, y₁),...,(xₙ, yₙ)] of pairs of binary strings such that
    x ++ x₁ ++ ... ++ xₙ = y ++ y₁ ++ ... yₙ?

*)
Definition BMPCP '((x,y), P) := exists A : BSRS, incl A (x/y :: P) /\ x ++ tau1 A = y ++ tau2 A.


(* --------- COMREHENSIVE EXAM ITP READING COURSE 2020-21 2ND SEM --------

             Remove all the Admitted from this file by completing the proofs.

Note that before trying to work with this file you should compile the following files in the
given order:
 1. GenReflect.v and
 2. SetSpecs.v
More precisely open terminal and go to the folder containing these files and type,
coqc GenReflect.v (press enter)
coqc SetSpecs.v   (press enter)

--- Following is an overview of the functions and predicates defined in this file ----

-- In this file we would like to formalize the concept of sorting in a list.  We consider
   lists of elements (on an arbitrary type A) with a boolean comparison operator
   (lr: A-> A-> bool). Most of  the results in this file assumes only
   1. reflexive,
   2. transitive and
   3. comparable
   nature of the boolean operator lr.
   Only the last result (equality of head) assumes the antisymmetric
   property of lr (i.e the comparison operator).

   Following are the concepts formalized in this file:

   Sorted l      <==> A Proposition to specify that l is sorted w.r.t comp operator lr
   putin a l      ==> puts the element a into a sorted list at its correct position w.r.t lr
   sort l         ==> a function that sorts the list l w.r.t the comp operator lr

   Some of the useful results in this file are:

   Lemma putin_correct (H_trans: transitive lr)(H_comp: comparable lr):
    forall (a:A) (l: list A), Sorted l -> Sorted (putin a l).

   Lemma nodup_putin (a:A)(l:list A): NoDup (a::l)-> NoDup (putin a l).

   Lemma sort_correct (H_trans: transitive lr)(H_comp: comparable lr):
    forall(l: list A), Sorted (sort l).

   Lemma sort_equal (l: list A): Equal l (sort l).

   Lemma nodup_sort (l: list A): NoDup l -> NoDup (sort l). ------------------  *)

Require Export Lists.List.
Require Export GenReflect SetSpecs.
Require Export Omega.

Set Implicit Arguments.

Section Sorting.
  Context {A: Type }.

  Variable lr: A->A-> bool.
  Notation " a <=r b":= (lr a b)(at level 70, no associativity).

 (* ------------- sorting a list of elements by lr relation ------------------------------*)

  Inductive  Sorted : list A-> Prop:=
  | nil_Sorted: Sorted nil
  | cons_Sorted (a:A)(l: list A): Sorted l -> (forall x, (In x l -> (a <=r x))) -> Sorted (a::l).

  Lemma Sorted_intro (a:A)(b:A)(l: list A)(Htrans: transitive lr):
    a <=r b -> Sorted (b::l)-> Sorted (a::b::l).
  Proof. intros H1 H2. apply cons_Sorted .
- apply H2.
- intros x H3 . inversion H2 . subst .  inversion H3 . rewrite <- H . apply H1.
assert (H_e : b <=r x ) . apply H5 . apply H .
apply (Htrans b ) .
+ apply H1 .
+ apply H_e . Qed .
  Lemma Sorted_elim1 (a:A) (b:A) (l: list A): (Sorted (a::b::l)) -> (a <=r b).
  Proof. intros H . inversion H . subst . apply H3 . simpl . left . reflexivity . Qed .
  Lemma Sorted_elim4 (a:A) (l:list A): Sorted (a::l) ->(forall x, In x l -> a <=r x).
  Proof. intros . inversion H . subst . apply H4 . apply H0 . Qed .
  Lemma Sorted_elim2 (a:A) (l:list A)(Hrefl: reflexive lr):
    Sorted (a::l) ->(forall x, In x (a::l) -> a <=r x).
  Proof. intros H x H1. inversion H . subst . destruct H1 . rewrite <- H0 . apply ( Hrefl ) .
apply H4 . apply H0 . Qed .
  Lemma Sorted_elim3 (a:A) (l:list A): (Sorted (a::l)) -> Sorted l.
  Proof. intros H . inversion H . subst . apply H2 . Qed .
  Lemma Sorted_single (a:A) : (Sorted (a::nil)).
  Proof. apply cons_Sorted .
- apply nil_Sorted .
- intros  . destruct H . Qed .
  Hint Resolve Sorted_elim1 Sorted_elim2 Sorted_elim3 Sorted_elim4
       Sorted_single Sorted_intro: core.

  Fixpoint putin (a: A) (l: list A) : list A:=
    match l with
    |nil=> a::nil
    |b::l1 => match a <=r b with
             |true => a::l
             |false => b::(putin a l1)
                    end
    end.

  Lemma putin_intro (a:A) (l: list A): forall x, In x l -> In x (putin a l).
  Proof. intros x H . induction l  as [| b] .
- destruct H .
- simpl . case_eq ( a<=r b) .
+ intros . simpl . simpl in H . auto .
+ intros . simpl . simpl in H . destruct H .
++ auto .
++ right . apply IHl . apply H . Qed .
  Lemma putin_intro1 (a:A) (l: list A): In a (putin a l).
  Proof. induction l . simpl . left .  reflexivity .
simpl . case_eq ( a <=r a0 ) .
+ intros . simpl  . left . reflexivity .
+ intros . simpl . right . apply IHl . Qed .
  Lemma putin_elim (a:A) (l: list A): forall x, In x (putin a l) -> (x=a)\/(In x l).
  Proof.  intros  x H. induction l .
simpl in H. simpl . intuition . simpl in H. simpl . destruct lr in H .
+ simpl in H . intuition .
+ simpl in H . destruct  H .
++ auto .
++ destruct IHl . apply H . auto . auto . Qed .
  Definition comparable (lr: A->A-> bool) := forall x y, lr x y=false -> lr y x.

  Lemma putin_correct (H_trans: transitive lr)(H_comp: comparable lr):
    forall (a:A) (l: list A), Sorted l -> Sorted (putin a l).
  Proof. intros a l H. induction l . simpl . auto . simpl . inversion H . subst .
case_eq ( a <=r a0 ) .
+ intros . apply cons_Sorted . apply H . intros . destruct H1 . rewrite <- H1 . apply H0 .
apply ( H_trans a0 ) . apply H0 . apply H3 . apply H1 .
+ intros H4 . apply cons_Sorted . apply IHl . apply H2 . intros . apply putin_elim in H0 .
apply H_comp in H4 . destruct H0 . rewrite H0 . apply H4 . apply H3 . apply H0 .
 Qed .

  Lemma nodup_putin (a:A)(l:list A): NoDup (a::l)-> NoDup (putin a l).
  Proof.  { revert a. induction l.
          { simpl. auto. }
          { intros a0 H. assert (Ha: NoDup (a::l)).  eauto.
            simpl. destruct (a0 <=r a) eqn: H1. auto.
            constructor.
            { intro H2. assert ( H2a: a=a0 \/ In a l). eauto using putin_elim.
              destruct H2a. subst a. inversion H. eauto.  inversion Ha; contradiction. }
            apply IHl. inversion H. constructor; eauto.  } } Qed.

  Lemma putin_card (a:A)(l: list A): | putin a l | = S (|l|).
  Proof. { induction l.
         { simpl;auto. }
         { simpl. case (a <=r a0) eqn:H.
           simpl; auto. simpl; rewrite IHl; auto. } } Qed.

  Hint Resolve putin_intro putin_intro1 putin_elim putin_correct nodup_putin: core.

   Fixpoint sort (l: list A): list A:=
    match l with
    |nil => nil
    |a::l1 => putin a (sort l1)
    end.

  Lemma sort_intro (l: list A): forall x, In x l -> In x (sort l).
  Proof.  intros . induction l . destruct H . simpl in H .
destruct H . simpl . rewrite <- H . apply putin_intro1 . simpl . apply putin_intro . apply IHl . apply H .
Qed .

  Lemma sort_elim (l: list A): forall x, In x (sort l) -> In x l.
  Proof. intros  . induction l . simpl in H . simpl . apply H .
 simpl . simpl in H . apply putin_elim in H . destruct H . auto . right . auto . Qed .
  Lemma sort_correct (H_trans: transitive lr)(H_comp: comparable lr):
    forall(l: list A), Sorted (sort l).
  Proof. intros . induction l . simpl . apply nil_Sorted .
 simpl . apply putin_correct . auto . auto . auto . Qed .
  Hint Resolve sort_elim sort_intro sort_correct: core.

  (*--upto this point only reflexive, transitive and comparable property of <=r is needed--- *)

  (* ---------------------head in Sorted lists l and l'-------------------------- *)

   Definition empty: list A:= nil.

  Lemma empty_equal_nil_l (l: list A): l [=] empty -> l = empty.
  Proof. { case l. auto. intros s l0. unfold "[=]". intro H.
           destruct H as [H1 H2]. absurd (In s empty). all: eauto. } Qed.

   (*-------- antisymmetric requirement is only needed in the following lemma--------*)
  Lemma head_equal_l (a b: A)(l s: list A)(Href: reflexive lr)(Hanti: antisymmetric lr):
    Sorted (a::l)-> Sorted (b::s)-> Equal (a::l) (b::s)-> a=b.
  Proof. { intros H H1 H2.
         assert(H3: In b (a::l)).
         unfold "[=]" in H2. apply H2. auto.
         assert (H3A: a <=r b). eapply Sorted_elim2;eauto.
         assert(H4: In a (b::s)).
         unfold "[=]" in H2. apply H2. auto.
         assert (H4A: b <=r a). eapply Sorted_elim2;eauto.
         eapply Hanti. split_;auto. } Qed.

End Sorting.

(*
 Definition l := 12::42::12::11::20::0::3::30::20::0::nil.
 Eval compute in (sort (fun x y => Nat.ltb y x) l).
 Eval compute in (sort (fun x y => ~~ (Nat.ltb x y)) l).
*)


Section star_rel.

Unset Implicit Arguments.

Variable X : Set.
Variable R : X -> X -> Prop.

Inductive star : X -> X -> Prop :=
  |star_refl : forall x, star x x
  |star_R    : forall x y z, star x y -> R y z -> star x z.

Lemma R_to_star : forall x y, R x y -> star x y.
Proof.
  intros.
  apply (star_R _ x _).
  apply star_refl.
  exact H.
Qed.

Lemma star_trans : forall x y z, star x y -> star y z -> star x z.
Proof.
  intros.
  induction H0.
  exact H.
  apply (star_R _ y _).
  apply IHstar.
  exact H.
  exact H1.
Qed.

End star_rel.

Set Implicit Arguments.

Section commuting_rels.

Variable X : Set.

Definition commute (R S : X -> X -> Prop) :=
  forall x y z, R x y -> S x z -> exists w, S y w /\ R z w.

Definition diamond(R : X -> X -> Prop) :=
 commute R R.

Definition confluent(R : X -> X -> Prop) :=
  diamond (star X R).

Definition subrel(R S : X -> X -> Prop) := forall x y, R x y -> S x y.

End commuting_rels.

Section diamond_confluence.

Variable X : Set.
Variables R S : X -> X -> Prop.

Variable subRS : subrel R S.
Variable subSRst : subrel S (star X R).
Variable dS : diamond S.

Lemma diamond_strip : commute S (star X R).
Proof.
  intros x y z Hxy Hxz.
  induction Hxz.
  exists y.
  split.
  apply star_refl.
  exact Hxy.
  destruct (IHHxz Hxy) as [w [Hw1 Hw2]].
  destruct (dS Hw2 (subRS H)) as [u [Hu1 Hu2]].
  exists u.
  split.
  apply (star_trans X _ _ w _).
  exact Hw1.
  apply subSRst.
  exact Hu1.
  exact Hu2.
Qed.

Lemma diamond_confluence : confluent R.
Proof.
  intros x y z Hxy Hxz.
  induction Hxy.
  exists z.
  split.
  exact Hxz.
  apply star_refl.
  destruct (IHHxy Hxz) as [w [Hw1 Hw2]].
  destruct (diamond_strip (subRS H) Hw1) as [u [Hu1 Hu2]].
  exists u.
  split.
  exact Hu1.
  apply (star_trans X _ _ w _).
  exact Hw2.
  apply subSRst.
  exact Hu2.
Qed.

End diamond_confluence.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Test for matrix.
  author    : ZhengPu Shi
  date      : 2021.12
 *)

From FCS Require Export MatrixAll.

Module Test_Mat_R_MLL.
  Import MatrixAllR.MLL.
  Open Scope R.

  Check T.
  Check 3 : T.

  Parameter m1 : mat 3 4.
  Parameter m2 : mat 3 4.
  Check m1 == m2.

  (* build concrete matrix *)
  Definition ex_m_1_1 : mat 1 1 := mat_1_1 2.
  Definition ex_m_3_3 : mat 3 3 := mat_3_3 1 2 3 4 5 6 7 8 9.
  Compute ex_m_1_1.
  Compute ex_m_3_3.

  (* zero matrix, identity matrix *)
  Compute mat0 3 4.
  Compute mat1 3.

  (* matrix mapping *)
  Compute mmap (fun x => x * 2) (ex_m_3_3).
  Compute mmap2 (Rminus) ex_m_3_3 ex_m_3_3.

  (* matrix addition *)
  Check madd m1 m2.
  Compute madd ex_m_3_3 ex_m_3_3.
  Example ex_madd : forall r c (m1 m2 : mat r c), madd m1 m2 == madd m2 m1.
  intros. apply madd_comm. Qed.

  (* matrix subtraction *)
  Compute msub ex_m_3_3 (mat1 3).

  (* matrix scalar multiplication *)
  Compute mcmul 3 ex_m_3_3.
  Compute mmulc ex_m_3_3 3.

  (* matrix transpose *)
  Compute mtrans ex_m_3_3.

  (* matrix multiplication *)
  Compute mmul ex_m_3_3 (mtrans ex_m_3_3).
  Compute mmul ex_m_3_3 ex_m_3_3.

  (* Example for coordinate transform *)

  (*   Import List.
  Import ListNotations. *)

  Section coordinate_transform_test.
    Variable θ ψ φ : R.
    Definition Rx (α : R) : mat 3 3 :=
      mat_3_3
        1         0           0
        0         (cos α)     (sin α)
        0         (-sin α)    (cos α).

    Definition Ry (β : R) : mat 3 3 :=
      mat_3_3
        (cos β)   0           (-sin β)
        0         1           0
        (sin β)   0           (cos β).

    Definition Rz (γ : R) : mat 3 3 :=
      mat_3_3
        (cos γ)   (sin γ)   0
        (-sin γ)  (cos γ)   0
        0         0         1.

    Definition R_b_e_direct : mat 3 3 :=
      mat_3_3
        (cos θ * cos ψ)
        (cos ψ * sin θ * sin φ - sin ψ * cos φ)
        (cos ψ * sin θ * cos φ + sin φ * sin ψ)

        (cos θ * sin ψ)
        (sin ψ * sin θ * sin φ + cos ψ * cos φ)
        (sin ψ * sin θ * cos φ - cos ψ * sin φ)

        (-sin θ)
        (sin φ * cos θ)
        (cos φ * cos θ).

    Open Scope M.
    Opaque cos sin.

    Lemma Rx_Ry_Rz_eq_Rbe : (Rz ψ)⊤ × (Ry θ)⊤ × (Rx φ)⊤ == R_b_e_direct.
    Proof.
      lma.
    Qed.

  End coordinate_transform_test.

End Test_Mat_R_MLL.


(** * Logic: Logic in Coq *)

Set Warnings "-notation-overridden,-parsing".
From LF Require Export Tactics.
Check 3 = 3.
(* ===> Prop *)
Check forall n m : nat, n + m = m + n.
(* ===> Prop *)
Check 2 = 2.
(* ===> Prop *)
Check forall n : nat, n = 2.
(* ===> Prop *)
Check 3 = 4.
(* ===> Prop *)

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

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

Theorem plus_fact_is_true :
  plus_fact.
Proof. reflexivity.  Qed.

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

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

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

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

(* ################################################################# *)
(** * Logical Connectives *)

(** ** Conjunction *)
Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  split;reflexivity.
Qed.
Lemma and_intro : forall A B : Prop, A -> B -> A /\ B.
Proof.
  intros A B HA HB. split.
  - apply HA.
  - apply HB.
Qed.
Example and_example' : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  apply and_intro;reflexivity.
Qed.

(** **** Exercise: 2 stars, standard (and_exercise)  *)
Example and_exercise :
  forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  intros n m.
  split.
  -destruct n.
    +reflexivity.
    +discriminate H.
  -destruct m.
    +reflexivity.
    +destruct n.
      *simpl in H. discriminate H.
      *discriminate H.
Qed.
(** [] *)

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

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

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

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

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

(** **** Exercise: 1 star, standard, optional (proj2)  *)
Lemma proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  intros P Q.
  intros [HP HQ].
  apply HQ.
Qed.
(** [] *)

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

(** **** Exercise: 2 stars, standard (and_assoc) *)

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

(* ================================================================= *)
(** ** Disjunction *)

Lemma or_example :
  forall n m : nat, n = 0 \/ m = 0 -> n * m = 0.
Proof.
  (* This pattern implicitly does case analysis on
     [n = 0 \/ m = 0] *)
  intros n m [Hn | Hm].
  - (* Here, [n = 0] *)
    rewrite Hn. reflexivity.
  - (* Here, [m = 0] *)
    rewrite Hm. rewrite <- mult_n_O.
    reflexivity.
Qed.

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

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

(** **** Exercise: 1 star, standard (mult_eq_0)  *)
Lemma mult_eq_0 :
  forall n m, n * m = 0 -> n = 0 \/ m = 0.
Proof.
  intros n m.
  destruct n.
  -left. reflexivity.
  - destruct m.
    +right. reflexivity.
    +intros H. simpl in H. discriminate H.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (or_commut)  *)
Theorem or_commut : forall P Q : Prop,
  P \/ Q  -> Q \/ P.
Proof.
  intros P Q [HP | HQ].
  -right. apply HP.
  -left. apply HQ.
Qed.
(** [] *)

(* ================================================================= *)
(** ** Falsehood and Negation **)

Module MyNot.
Definition not (P:Prop) := P -> False.
Notation "~ x" := (not x) : type_scope.

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

End MyNot.

(** Since [False] is a contradictory proposition, the principle of
    explosion also applies to it. If we get [False] into the proof
    context, we can use [destruct] on it to complete any goal: *)

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

(** The Latin _ex falso quodlibet_ means, literally, "from falsehood
    follows whatever you like"; this is another common name for the
    principle of explosion. *)

(** **** Exercise: 2 stars, standard, optional (not_implies_our_not)

    Show that Coq's definition of negation implies the intuitive one
    mentioned above: *)

Fact not_implies_our_not : forall (P:Prop),
  ~ P -> (forall (Q:Prop), P -> Q).
Proof.
  intros P H Q.
  unfold not in H.
  intros H1.
  apply H in H1.
  destruct H1.
Qed.
(** [] *)

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

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

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

Theorem double_neg : forall P : Prop,
  P -> ~~P.
Proof.
  (* WORKED IN CLASS *)
  intros P H. unfold not. intros G. apply G. apply H.  Qed.

(** **** Exercise: 2 stars, advanced (double_neg_inf)

    Write an informal proof of [double_neg]:

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

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_double_neg_inf : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard, recommended (contrapositive)  *)
Theorem contrapositive : forall (P Q : Prop),
  (P -> Q) -> (~Q -> ~P).
Proof.
  intros P Q.
  intros H.
  unfold not.
  intros H1 H2.
  apply H in H2. apply H1 in H2.
  apply H2.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (not_both_true_and_false)  *)
Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
  intros P.
  unfold not.
  intros [HP nHP].
  apply nHP in HP.
  apply HP.
Qed.
(** [] *)

(** **** Exercise: 1 star, advanced (informal_not_PNP)

    Write an informal proof (in English) of the proposition [forall P
    : Prop, ~(P /\ ~P)]. *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_informal_not_PNP : option (nat*string) := None.
(** [] *)

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

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

(* ================================================================= *)
(** ** Truth *)

(** Besides [False], Coq's standard library also defines [True], a
    proposition that is trivially true. To prove it, we use the
    predefined constant [I : True]: *)

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

(* ================================================================= *)
(** ** Logical Equivalence *)

(** The handy "if and only if" connective, which asserts that two
    propositions have the same truth value, is just the conjunction of
    two implications. *)

Module MyIff.

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

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

End MyIff.

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

Lemma not_true_iff_false : forall b,
  b <> true <-> b = false.
Proof.
  (* WORKED IN CLASS *)
  intros b. split.
  - (* -> *) apply not_true_is_false.
  - (* <- *)
    intros H. rewrite H. intros H'. discriminate H'.
Qed.

(** **** Exercise: 1 star, standard, optional (iff_properties)

    Using the above proof that [<->] is symmetric ([iff_sym]) as
    a guide, prove that it is also reflexive and transitive. *)

Theorem iff_refl : forall P : Prop,
  P <-> P.
Proof.
  intros P. split.
  -intros H. apply H.
  -intros H. apply H.
Qed.
Theorem iff_trans : forall P Q R : Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  intros P Q R.
  intros [HP HQ1].
  intros [HQ2 HR].
  split.
  -intros H. apply HP in H. apply HQ2 in H. apply H.
  -intros H. apply HR in H. apply HQ1 in H. apply H.
Qed.
(** [] *)

(** **** Exercise: 3 stars, standard (or_distributes_over_and)  *)
Theorem or_distributes_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R.
  split.
  -intros [HP | [HQ HR]].
   +split.
     *left. apply HP.
     *left. apply HP.
   +split.
     *right. apply HQ.
     *right. apply HR.
  -intros [[HP1 | HQ] [HP2 | HR]].
   +left. apply HP1.
   +left. apply HP1.
   +left. apply HP2.
   +right. split.
    *apply HQ.
    *apply HR.
Qed.
(** [] *)

From Coq Require Import Setoids.Setoid.

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

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

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

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

(* ================================================================= *)
(** ** Existential Quantification *)

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

(** Conversely, if we have an existential hypothesis [exists x, P] in
    the context, we can destruct it to obtain a witness [x] and a
    hypothesis stating that [P] holds of [x]. *)

Theorem exists_example_2 : forall n,
  (exists m, n = 4 + m) ->
  (exists o, n = 2 + o).
Proof.
  (* WORKED IN CLASS *)
  intros n [m Hm]. (* note implicit [destruct] here *)
  exists (2 + m).
  apply Hm.  Qed.

(** **** Exercise: 1 star, standard, recommended (dist_not_exists)

    Prove that "[P] holds for all [x]" implies "there is no [x] for
    which [P] does not hold."  (Hint: [destruct H as [x E]] works on
    existential assumptions!)  *)

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

(** **** Exercise: 2 stars, standard (dist_exists_or)

    Prove that existential quantification distributes over
    disjunction. *)

Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  intros X P Q.
  split.
  -intros H. destruct H as [x [HP | HQ]].
   +left. exists x. apply HP.
   +right. exists x. apply HQ.
  -intros H. destruct H as [HP | HQ].
   +destruct HP as [x PX].
    exists x. left. apply PX.
   +destruct HQ as [x QX].
    exists x. right. apply QX.
Qed.
(** [] *)

(* ################################################################# *)
(** * Programming with Propositions *)

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

(** When [In] is applied to a concrete list, it expands into a
    concrete sequence of nested disjunctions. *)

Example In_example_1 : In 4 [1; 2; 3; 4; 5].
Proof.
  (* WORKED IN CLASS *)
  simpl. right. right. right. left. reflexivity.
Qed.

Example In_example_2 :
  forall n, In n [2; 4] ->
  exists n', n = 2 * n'.
Proof.
  (* WORKED IN CLASS *)
  simpl.
  intros n [H | [H | []]].
  - exists 1. rewrite <- H. reflexivity.
  - exists 2. rewrite <- H. reflexivity.
Qed.
(** (Notice the use of the empty pattern to discharge the last case
    _en passant_.) *)

(** We can also prove more generic, higher-level lemmas about [In].

    Note, in the next, how [In] starts out applied to a variable and
    only gets expanded when we do case analysis on this variable: *)

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

(** This way of defining propositions recursively, though convenient
    in some cases, also has some drawbacks.  In particular, it is
    subject to Coq's usual restrictions regarding the definition of
    recursive functions, e.g., the requirement that they be "obviously
    terminating."  In the next chapter, we will see how to define
    propositions _inductively_, a different technique with its own set
    of strengths and limitations. *)

(** **** Exercise: 2 stars, standard (In_map_iff)  *)
Lemma In_map_iff :
  forall (A B : Type) (f : A -> B) (l : list A) (y : B),
    In y (map f l) <->
    exists x, f x = y /\ In x l.
Proof.
  intros A B f l y.
  split.
  -induction l.
   +simpl. intros contra. destruct contra.
   +simpl. intros [H1 | H2].
    * exists x. split.
     {apply H1. }
     {left. reflexivity. }
    * apply IHl in H2. destruct H2 as [z [H3 H4]].
      exists z. split.
      {apply H3. }
      {right. apply H4. }
  -intros [x [H1 H2]].
   rewrite <- H1. apply In_map. apply H2.
Qed.

(** [] *)

(** **** Exercise: 2 stars, standard (In_app_iff)  *)
Lemma In_app_iff : forall A l l' (a:A),
  In a (l++l') <-> In a l \/ In a l'.
Proof.
  intros A l l' a.
  split.
  -intros H. induction l.
    +simpl. simpl in H. right. apply H.
    +simpl. simpl in H. destruct H as [H1 | H2].
     *left. unfold In. left. apply H1.
     *apply IHl in H2. destruct H2 as [H3 | H4].
      {left. right. apply H3. }
      {right. apply H4. }
  -intros H. induction l.
    + simpl in H. destruct H.
      *destruct H.
      *simpl. apply H.
    + simpl in H. apply or_assoc in H. simpl. destruct H as [H1 | H2].
      *left. apply H1.
      *apply IHl in H2. right. apply H2.
Qed.

(** [] *)

(** **** Exercise: 3 stars, standard, recommended (All)  *)

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

Lemma All_In :
  forall T (P : T -> Prop) (l : list T),
    (forall x, In x l -> P x) <->
    All P l.
Proof.
  intros T P l .
  split.
  -intros H.
    induction l.
    +simpl. reflexivity.
    +simpl. simpl in H. split.
      *apply H. left. reflexivity.
      *apply IHl. intros y. intros H1. apply H. right. apply H1.
  -intros H.
    induction l.
     +intros y. intros H1. simpl in H1. destruct H1.
     +simpl. intros x0 H'.
      destruct H'.
      *simpl in H. destruct H as [H1 H2]. rewrite <- H0. apply H1.
      *simpl in H. destruct H as [H1 H2]. apply IHl. apply H2. apply H0.
Qed.
(** [] *)

(** **** Exercise: 3 stars, standard (combine_odd_even) *)

Definition combine_odd_even (Podd Peven : nat -> Prop) : nat -> Prop:=
  fun (n:nat) => if oddb n then Podd n else Peven n.

(** To test your definition, prove the following facts: *)

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

Theorem combine_odd_even_elim_odd :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = true ->
    Podd n.
Proof.
  intros Podd Peven n H1 H2.
  unfold combine_odd_even in H1.
  rewrite H2 in H1.
  apply H1.
Qed.
Theorem combine_odd_even_elim_even :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = false ->
    Peven n.
Proof.
  intros Podd Peven n H1 H2.
  unfold combine_odd_even in H1.
  rewrite H2 in H1.
  apply H1.
Qed.
(** [] *)

(* ################################################################# *)
(** * Applying Theorems to Arguments *)

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

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

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

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

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

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

(* Explicitly apply the lemma to the value for [x]. *)
Lemma in_not_nil_42_take4 :
  forall l : list nat, In 42 l -> l <> [].
Proof.
  intros l H.
  apply (in_not_nil nat 42).
  apply H.
Qed.

(* Explicitly apply the lemma to a hypothesis. *)
Lemma in_not_nil_42_take5 :
  forall l : list nat, In 42 l -> l <> [].
Proof.
  intros l H.
  apply (in_not_nil _ _ _ H).
Qed.

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

(** We will see many more examples in later chapters. *)

(* ################################################################# *)
(** * Coq vs. Set Theory *)
(* ================================================================= *)
(** ** Functional Extensionality *)

Example function_equality_ex1 :
  (fun x => 3 + x) = (fun x => (pred 4) + x).
Proof. reflexivity. Qed.

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

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

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

(** **** Exercise: 4 stars, standard (tr_rev_correct) *)

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

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

Lemma tr_rev_lemma : forall X  (l1 l2 : list X),
  rev_append l1 l2 = (rev l1)++l2.
Proof.
  intros X l1.
  induction l1.
  -intros l2. simpl. reflexivity.
  -intros l2. simpl. rewrite <- app_assoc. simpl. apply IHl1.
Qed.
Lemma tr_rev_correct : forall X, @tr_rev X = @rev X.
Proof.
  intros X.
  apply functional_extensionality.
  unfold tr_rev.
  intros x.
  rewrite tr_rev_lemma.
  apply app_nil_r.
Qed.
(** [] *)

(* ================================================================= *)
(** ** Propositions and Booleans *)

(** ... that [evenb n] evaluates to [true]... *)
Example even_42_bool : evenb 42 = true.
Proof. reflexivity. Qed.

(** ... or that there exists some [k] such that [n = double k]. *)
Example even_42_prop : exists k, 42 = double k.
Proof. exists 21. reflexivity. Qed.

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

(** **** Exercise: 3 stars, standard (evenb_double_conv)  *)
Theorem evenb_double_conv : forall n,
  exists k, n = if evenb n then double k
                else S (double k).
Proof.
  intros n.
  induction n.
  - simpl. exists 0. reflexivity.
  - destruct (evenb n) eqn: H.
    + rewrite evenb_S. rewrite H. simpl. destruct IHn as [k E]. exists k. rewrite E.
      reflexivity.
    + rewrite evenb_S. rewrite H. simpl. destruct IHn as [k E]. exists (S k). rewrite E.
      reflexivity.
Qed.
  (* Hint: Use the [evenb_S] lemma from [Induction.v]. *)
(** [] *)

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

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

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

Example even_1000 : exists k, 1000 = double k.
Proof. exists 500. reflexivity. Qed.

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

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

Example not_even_1001 : evenb 1001 = false.
Proof.
  (* WORKED IN CLASS *)
  reflexivity.
Qed.

(** In contrast, propositional negation may be more difficult
    to grasp. *)

Example not_even_1001' : ~(exists k, 1001 = double k).
Proof.
  (* WORKED IN CLASS *)
  rewrite <- even_bool_prop.
  unfold not.
  simpl.
  intro H.
  discriminate H.
Qed.

Lemma plus_eqb_example : forall n m p : nat,
    n =? m = true -> n + p =? m + p = true.
Proof.
  (* WORKED IN CLASS *)
  intros n m p H.
    rewrite eqb_eq in H.
  rewrite H.
  rewrite eqb_eq.
  reflexivity.
Qed.

Lemma andb_true_iff : forall b1 b2:bool,
  b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof.
  intros b1 b2. split.
  -intros H. unfold andb in H. split.
    +destruct b1.
      *reflexivity.
      *destruct H. reflexivity.
    +destruct b2.
      *reflexivity.
      *destruct H. destruct b1.
        {reflexivity. }
        {reflexivity. }
  -intros [HA HB].
    unfold andb. rewrite HA.
    rewrite HB. reflexivity.
Qed.
Lemma orb_true_iff : forall b1 b2,
  b1 || b2 = true <-> b1 = true \/ b2 = true.
Proof.
  intros b1 b2. split.
  -intros H. destruct b1.
   + left. reflexivity.
   + simpl in H. right. apply H.
  -intros [HA | HB].
    +rewrite HA. reflexivity.
    +rewrite HB. destruct b1.
      *reflexivity.
      *reflexivity.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (eqb_neq) *)

Theorem eqb_neq : forall x y : nat,
  x =? y = false <-> x <> y.
Proof.
  intros x y. split.
  - intros H. unfold not. destruct (x=?y) eqn: H1.
    + discriminate H.
    + intros H2. rewrite H2 in H1. rewrite<- eqb_refl in H1. discriminate H1.
  - intros H. unfold not in H. destruct (x=?y) eqn: H1.
    +apply eqb_eq in H1. apply H in H1. destruct H1.
    +reflexivity.
Qed.
(** [] *)

(** **** Exercise: 3 stars, standard (eqb_list) *)

Fixpoint eqb_list {A : Type} (eqb : A -> A -> bool)
                  (l1 l2 : list A) : bool :=
  match l1, l2 with
  |[],[] =>true
  |[], h::t => false
  |h::t, [] => false
  |h1::t1, h2::t2 => match (eqb h1 h2) with
        |true => eqb_list eqb t1 t2
        |false => false
  end
end.

Lemma eqb_list_true_iff :
  forall A (eqb : A -> A -> bool),
    (forall a1 a2, eqb a1 a2 = true <-> a1 = a2) ->
    forall l1 l2, eqb_list eqb l1 l2 = true <-> l1 = l2.
Proof.
  intros A eqb.
  intros H.
  split.
  -revert l2. induction l1.
    +intros l2. destruct l2 eqn: H1.
      *reflexivity.
      *intros H2. discriminate H2.
    +simpl. intros l2. destruct l2 eqn: H3.
      *intros H4. discriminate H4.
      *destruct (eqb x x0) eqn:H6.
       {intros H5. apply H in H6. apply IHl1 in H5. rewrite H6. rewrite H5. reflexivity. }
       {intros H5. discriminate H5. }
  Abort.

(** [] *)

(** **** Exercise: 2 stars, standard, recommended (All_forallb)

    Recall the function [forallb], from the exercise
    [forall_exists_challenge] in chapter [Tactics]: *)

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

(** Prove the theorem below, which relates [forallb] to the [All]
    property of the above exercise. *)

Theorem forallb_true_iff : forall X test (l : list X),
   forallb test l = true <-> All (fun x => test x = true) l.
Proof.
  intros X test l.
  split.
  -intros H. induction l.
    + reflexivity.
    + simpl. simpl in H. apply andb_true_iff in H. destruct H as [H1 H2].
      apply IHl in H2.
      split.
      *apply H1.
      *apply H2.
  -intros H. induction l.
    + reflexivity.
    + simpl. simpl in H. destruct H as [H1 H2]. apply IHl in H2.
      apply andb_true_iff.
      split.
      *apply H1.
      *apply H2.
Qed.

(** Are there any important properties of the function [forallb] which
    are not captured by this specification? *)

(* FILL IN HERE

    [] *)

(* ================================================================= *)
(** ** Classical vs. Constructive Logic *)
Definition excluded_middle := forall P : Prop,
  P \/ ~ P.

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

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

(** **** Exercise: 3 stars, standard (excluded_middle_irrefutable) *)

Theorem excluded_middle_irrefutable: forall (P:Prop),
  ~ ~ (P \/ ~ P).
Proof.
  intros P.
  unfold not.
  intros H1. apply H1.
  right. intros H2. apply H1. left. apply H2.
Qed.
(** [] *)

(** **** Exercise: 3 stars, advanced (not_exists_dist)*)

Theorem not_exists_dist :
  excluded_middle ->
  forall (X:Type) (P : X -> Prop),
    ~ (exists x, ~ P x) -> (forall x, P x).
Proof.
  intros e_m X P H x.
  unfold not in H.
  assert(H1: P x\/~P x). {apply e_m. }
  destruct H1 as [H3 | H4].
  - apply H3.
  - unfold not in H4. apply ex_falso_quodlibet. apply H.
    exists x. apply H4.
Qed.
(** [] *)

(** **** Exercise: 5 stars, standard, optional (classical_axioms) *)

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

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

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

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

Lemma em_pe: excluded_middle->peirce.
Proof.
  intros em P Q.
  assert(H1: P\/~P). {apply em. }
  assert(H2: Q\/~Q). {apply em. }
  destruct H1 as [HP | nHP].
  -intros H'. apply HP.
  -intros. unfold not in nHP. destruct H2 as [HQ | nHQ].
    +assert(H': P->Q). {intros. apply HQ. }
    apply H in H'. apply H'.
    +assert(H': P->Q). {intros. apply nHP in H0. inversion H0. }
    apply H in H'. apply H'.
Qed.

Lemma pe_dne: peirce -> double_negation_elimination.
Proof.
  intros pe P nP.
  unfold not in nP.
  assert(H:((P->False)->P)->P). {apply pe. }
  apply H.
  intros H1.
  apply nP in H1.
  destruct H1.
Qed.
Lemma dne_dmnan: double_negation_elimination->de_morgan_not_and_not.
Proof.
  intros dne P Q H.
  assert(H1:~~(P\/Q) ->(P\/Q)). {apply dne. }
  apply H1.
  unfold not.
  unfold not in H.
  intros. apply H.
  split.
  -intros. assert(H': P\/Q). { left. apply H2. }
   apply H0 in H'. apply H'.
  -intros. assert(H': P\/Q). { right. apply H2. }
   apply H0 in H'. apply H'.
Qed.
Lemma dmnan_ito : de_morgan_not_and_not->implies_to_or.
Proof.
  intros dmnan P Q H.
  unfold not.
  assert(H1:~(~(P->False) /\ ~Q) ->(P->False)\/Q). {apply dmnan. }
  apply H1.
  unfold not.
  intros.
  destruct H0 as [H2 H3].
  apply H2. intros.
  apply H in H0.
  apply H3 in H0.
  apply H0.
Qed.
Lemma ito_em: implies_to_or ->excluded_middle.
Proof.
  intros ito.
  unfold excluded_middle.
  intros P.
  assert(H:(P->P)-> (~P\/P)). {apply ito. }
  assert(H':P->P). {intro. apply H0. }
  apply H in H'.
  destruct H' as [H1 | H2].
  -right. apply H1.
  -left. apply H2.
Qed.

(* Wed Jan 9 12:02:45 EST 2019 *)


Require Import HoTT Coq.Init.Peano.

Definition Book_1_1 := (fun (A B C : Type) (f : A -> B) (g : B -> C) => g o f).

Theorem Book_1_1_refl : forall (A B C D : Type) (f : A -> B) (g : B -> C) (h : C -> D),
                          h o (g o f) = (h o g) o f.
Proof.
  reflexivity.
Defined.

Definition Book_1_2_prod_lib := @HoTT.Types.Prod.equiv_uncurry.
Section Book_1_2_prod.
  Variable A B : Type.

  (** Recursor with projection functions instead of pattern-matching. *)
  Let prod_rec_proj C (g : A -> B -> C) (p : A * B) : C :=
    g (fst p) (snd p).
  Definition Book_1_2_prod := prod_rec_proj.

  Proposition Book_1_2_prod_fst : fst = prod_rec_proj A (fun a b => a).
  Proof.
    reflexivity.
  Defined.

  Proposition Book_1_2_prod_snd : snd = prod_rec_proj B (fun a b => b).
  Proof.
    reflexivity.
  Defined.
End Book_1_2_prod.


Require Import Arith Arith.Even Arith.Div2.
Require Import Braun.common.util Omega.
Set Implicit Arguments.

(* START: bin_tree *)
Inductive bin_tree {A:Set} : Set :=
| bt_mt   : bin_tree
| bt_node : A -> bin_tree -> bin_tree -> bin_tree.
(* STOP: bin_tree *)
Hint Constructors bin_tree.

(* START: Braun *)
Inductive Braun {A:Set} : (@bin_tree A) -> nat -> Prop :=
| B_mt   : Braun bt_mt 0
| B_node : forall (x:A) s s_size t t_size,
  t_size <= s_size <= t_size+1 ->
  Braun s s_size -> Braun t t_size ->
  Braun (bt_node x s t) (s_size+t_size+1).
(* STOP: Braun *)
Hint Constructors Braun.

Lemma braun_node_construction:
  forall (A:Set) (x:A) n s t,
    Braun s (div2 (n+1)) ->
    Braun t (div2 n) ->
    Braun (bt_node x s t) (S n).
Proof.
  intros.
  replace (S n) with (div2 (n+1) + div2 n + 1).
  constructor; auto.
  apply (ind_0_1_SS (fun n => div2 n <= div2 (n+1) <= div2 n + 1));
    try (intros;simpl;omega).
  rewrite div_ceil_floor_sum.
  replace (S n + 1) with (S (S n));[|omega].
  replace (div2 (S (S n))) with (S (div2 n));[|simpl;reflexivity].
  replace (n+1) with (S n);[|omega].
  omega.
Qed.
Hint Resolve braun_node_construction.


Require Import Relations.Relation_Definitions.

Inductive Process :=
  | Nil : Process
  | Input : nat -> (nat -> Process) -> Process
  | Output : nat -> Process -> Process
  | Sum : Process -> Process -> Process
  | Res : nat -> Process -> Process.

Definition small_step : relation Process :=
  fun p1 p2 =>
    match p1 with
    | Input x f =>
      exists v, p2 = f v
    | Output x p =>
      p2 = p
    | Sum p1' p2' =>
      p2 = Sum p1' p2' \/ p2 = Sum p1 p2'
    | Res x p =>
      exists y, p2 = Res y p /\ x <> y
    | _ => False
    end.

Inductive multi_step : relation Process :=
  | refl : forall p, multi_step p p
  | step : forall p1 p2 p3, small_step p1 p2 -> multi_step p2 p3 -> multi_step p1 p3.

Inductive bisim : relation Process :=
  | bisim_refl : forall p, bisim p p
  | bisim_trans : forall p1 p2 p3, bisim p1 p2 -> small_step p2 p3 -> bisim p1 p3
  | bisim_symm : forall p1 p2, bisim p1 p2 -> bisim p2 p1.

Definition bisimulation (R : relation Process) :=
  forall p q, R p q -> (forall p', small_step p p' -> exists q', R p' q' /\ small_step q q') /\
                (forall q', small_step q q' -> exists p', R p' q' /\ small_step p p').

Definition bisimilarity (R : relation Process) :=
  forall p q, R p q -> exists q', bisim q q' /\ multi_step p q'.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (z : natural) (x : natural) : natural := plus Zero (mult x z).


Require Import Logic.Class.Eq.
Require Import Logic.Lam.Syntax.

(* If equality on v is decidable, then so is equality on T v                    *)
Lemma eqDecidable : forall (v:Type) (e:Eq v),
    forall (s t:T v), {s = t} + {s <> t}.
Proof.
    intros v e s t. revert s t.
    induction s as [x|s1 IH1 s2 IH2|x s1 IH1];
    destruct t as [y|t1 t2|y t1].
    - destruct (eqDec x y) as [E|E].
        + subst. left. reflexivity.
        + right. intros H. inversion H. subst. apply E. reflexivity.
    - right. intros H. inversion H.
    - right. intros H. inversion H.
    - right. intros H. inversion H.
    - destruct (IH1 t1) as [E1|E1], (IH2 t2) as [E2|E2].
        + subst. left. reflexivity.
        + right. intros H. inversion H. subst. apply E2. reflexivity.
        + right. intros H. inversion H. subst. apply E1. reflexivity.
        + right. intros H. inversion H. subst. apply E1. reflexivity.
    - right. intros H. inversion H.
    - right. intros H. inversion H.
    - right. intros H. inversion H.
    - destruct (eqDec x y) as [E|E], (IH1 t1) as [E1|E1].
        + subst. left. reflexivity.
        + right. intros H. inversion H. subst. apply E1. reflexivity.
        + right. intros H. inversion H. subst. apply E.  reflexivity.
        + right. intros H. inversion H. subst. apply E.  reflexivity.
Defined.

Arguments eqDecidable {v} {e}.

Instance EqT (v:Type) (e:Eq v) : Eq (T v) := { eqDec := eqDecidable }.


(** * Maps: Total and Partial Maps *)

(** Maps (or dictionaries) are ubiquitous data structures, both in
    software construction generally and in the theory of programming
    languages in particular; we're going to need them in many places
    in the coming chapters.  They also make a nice case study using
    ideas we've seen in previous chapters, including building data
    structures out of higher-order functions (from [Basics] and
    [Poly]) and the use of reflection to streamline proofs (from
    [IndProp]).

    We'll define two flavors of maps: _total_ maps, which include a
    "default" element to be returned when a key being looked up
    doesn't exist, and _partial_ maps, which return an [option] to
    indicate success or failure.  The latter is defined in terms of
    the former, using [None] as the default element. *)

(* ###################################################################### *)
(** * The Coq Standard Library *)

(** One small digression before we start.

    Unlike the chapters we have seen so far, this one does not
    [Require Import] the chapter before it (and, transitively, all the
    earlier chapters).  Instead, in this chapter and from now, on
    we're going to import the definitions and theorems we need
    directly from Coq's standard library stuff.  You should not notice
    much difference, though, because we've been careful to name our
    own definitions and theorems the same as their counterparts in the
    standard library, wherever they overlap. *)

Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.FunctionalExtensionality.

(** Documentation for the standard library can be found at
    http://coq.inria.fr/library/.

    The [SearchAbout] command is a good way to look for theorems
    involving objects of specific types. *)

(* ###################################################################### *)
(** * Identifiers *)

(** First, we need a type for the keys that we use to index into our
    maps.  For this purpose, we again use the type [id] from the
    [Lists] chapter.  To make this chapter self contained, we repeat
    its definition here, together with the equality comparison
    function for [id]s and its fundamental property. *)

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

Definition beq_id id1 id2 :=
  match id1,id2 with
    | Id n1, Id n2 => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall id, true = beq_id id id.
Proof.
  intros [n]. simpl. rewrite <- beq_nat_refl.
  reflexivity. Qed.

(** The following useful property of [beq_id] follows from an
    analogous lemma about numbers: *)

Theorem beq_id_true_iff : forall id1 id2 : id,
  beq_id id1 id2 = true <-> id1 = id2.
Proof.
   intros [n1] [n2].
   unfold beq_id.
   rewrite beq_nat_true_iff.
   split.
   - (* -> *) intros H. rewrite H. reflexivity.
   - (* <- *) intros H. inversion H. reflexivity.
Qed.

(** Similarly: *)

Theorem beq_id_false_iff : forall x y : id,
  beq_id x y = false
  <-> x <> y.
Proof.
  intros x y. rewrite <- beq_id_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

(** This useful variant follows just by rewriting: *)

Theorem false_beq_id : forall x y : id,
   x <> y
   -> beq_id x y = false.
Proof.
  intros x y. rewrite beq_id_false_iff.
  intros H. apply H. Qed.

(* ###################################################################### *)
(** * Total Maps *)

(** Our main job in this chapter will be to build a definition of
    partial maps that is similar in behavior to the one we saw in the
    [Lists] chapter, plus accompanying lemmas about their behavior.

    This time around, though, we're going to use _functions_, rather
    than lists of key-value pairs, to build maps.  The advantage of
    this representation is that it offers a more _extensional_ view of
    maps, where two maps that respond to queries in the same way will
    be represented as literally the same thing (the same function),
    rather than just "equivalent" data structures.  This, in turn,
    simplifies proofs that use maps.

    We build partial maps in two steps.  First, we define a type of
    _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

Definition total_map (A:Type) := id -> A.

(** Intuitively, a total map over an element type [A] _is_ just a
    function that can be used to look up [id]s, yielding [A]s.

    The function [t_empty] yields an empty total map, given a default
    element; this map always returns the default element when applied
    to any id. *)

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A:Type} (m : total_map A)
                    (x : id) (v : A) :=
  fun x' => if beq_id x x' then v else m x'.

(** This definition is a nice example of higher-order programming.
    The [t_update] function takes a _function_ [m] and yields a new
    function [fun x' => ...] that behaves like the desired map.

    For example, we can build a map taking [id]s to [bool]s, where [Id
    3] is mapped to [true] and every other key is mapped to [false],
    like this: *)

Definition examplemap :=
  t_update (t_update (t_empty false) (Id 1) false)
           (Id 3) true.

(** This completes the definition of total maps.  Note that we don't
    need to define a [find] operation because it is just function
    application! *)

Example update_example1 : examplemap (Id 0) = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap (Id 1) = false.
Proof. reflexivity. Qed.

Example update_example3 : examplemap (Id 2) = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap (Id 3) = true.
Proof. reflexivity. Qed.

(** To use maps in later chapters, we'll need several fundamental
    facts about how they behave.  Even if you don't work the following
    exercises, make sure you thoroughly understand the statements of
    the lemmas!  (Some of the proofs require the functional
    extensionality axiom discussed in the [Logic] chapter, which is
    also included in the standard library.) *)

(** **** Exercise: 2 stars, optional (t_update_eq)  *)
(** First, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall A (m: total_map A) x v,
  (t_update m x v) x = v.
Proof.
  intros. unfold t_update.
  rewrite <- beq_id_refl. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_neq)  *)
(** On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (t_update m x1 v) x2 = m x2.
Proof.
  intros. unfold t_update.
  apply false_beq_id in H. rewrite H. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_shadow)  *)
(** If we update a map [m] at a key [x] with a value [v1] and then
    update again with the same key [x] and another value [v2], the
    resulting map behaves the same (gives the same result when applied
    to any key) as the simpler map obtained by performing just
    the second [update] on [m]: *)

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2
  = t_update m x v2.
Proof.
  intros. unfold t_update.
  apply functional_extensionality. intros.
  destruct (beq_id x x0).
  - reflexivity.
  - reflexivity.
Qed.
(** [] *)

(** For the final two lemmas about total maps, it's convenient to use
    the reflection idioms introduced in chapter [IndProp].  We begin
    by proving a fundamental _reflection lemma_ relating the equality
    proposition on [id]s with the boolean function [beq_id]. *)

(** **** Exercise: 2 stars (beq_idP)  *)
(** Use the proof of [beq_natP] in chapter [IndProp] as a template to
    prove the following: *)

Lemma beq_idP : forall x y, reflect (x = y) (beq_id x y).
Proof.
  intros x y.
  apply iff_reflect. rewrite beq_id_true_iff. reflexivity.
Qed.
(** [] *)

(** Now, given [id]s [x1] and [x2], we can use the [destruct (beq_idP
    x1 x2)] to simultaneously perform case analysis on the result of
    [beq_id x1 x2] and generate hypotheses about the equality (in the
    sense of [=]) of [x1] and [x2]. *)

(** **** Exercise: 2 stars (t_update_same)  *)
(** Using the example in chapter [IndProp] as a template, use
    [beq_idP] to prove the following theorem, which states that if we
    update a map to assign key [x] the same value as it already has in
    [m], then the result is equal to [m]: *)

Theorem t_update_same : forall X x (m : total_map X),
  t_update m x (m x) = m.
Proof.
  intros. unfold t_update.
  apply functional_extensionality. intros.
  destruct (beq_idP x x0) as [H | H'].
  - rewrite H. reflexivity.
  - reflexivity.
Qed.
(** [] *)

(** **** Exercise: 3 stars, recommended (t_update_permute)  *)
(** Use [beq_idP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
    (t_update (t_update m x2 v2) x1 v1)
  = (t_update (t_update m x1 v1) x2 v2).
Proof.
  intros. unfold t_update.
  apply functional_extensionality. intros.
  destruct (beq_idP x1 x).
  - destruct (beq_idP x2 x).
    * destruct H. rewrite e. rewrite e0. reflexivity.
    * reflexivity.
  - destruct (beq_idP x2 x).
    * reflexivity.
    * reflexivity.
Qed.
(** [] *)

(* ###################################################################### *)
(** * Partial maps *)

(** Finally, we define _partial maps_ on top of total maps.  A partial
    map with elements of type [A] is simply a total map with elements
    of type [option A] and default element [None]. *)

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A:Type} : partial_map A :=
  t_empty None.

Definition update {A:Type} (m : partial_map A)
                  (x : id) (v : A) :=
  t_update m x (Some v).

(** We can now lift all of the basic lemmas about total maps to
    partial maps.  *)

Lemma update_eq : forall A (m: partial_map A) x v,
  (update m x v) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (X:Type) v x1 x2
                       (m : partial_map X),
  x2 <> x1 ->
  (update m x2 v) x1 = m x1.
Proof.
  intros X v x1 x2 m H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall A (m: partial_map A) v1 v2 x,
  update (update m x v1) x v2 = update m x v2.
Proof.
  intros A m v1 v2 x1. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall X v x (m : partial_map X),
  m x = Some v ->
  update m x v = m.
Proof.
  intros X v x m H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (X:Type) v1 v2 x1 x2
                                (m : partial_map X),
  x2 <> x1 ->
    (update (update m x2 v2) x1 v1)
  = (update (update m x1 v1) x2 v2).
Proof.
  intros X v1 v2 x1 x2 m. unfold update.
  apply t_update_permute.
Qed.

(** $Date: 2015-12-11 17:17:29 -0500 (Fri, 11 Dec 2015) $ *)


(*
  Nombre : Taller 2 Logica proposicional
  Autor : Guido Salazar
  Fecha : 11/09/2020
*)

(*Definición de LP*)

(*Punto 1*)

(*Definiciòn de los conectivos l+ogicos*)
Inductive con : Type :=
  |and : con
  |or : con
  |imp : con.

(*Definición de LP*)
Inductive LP : Set :=
  | p: LP
  | q: LP
  | neg: LP -> LP
  | phi: LP -> con -> LP -> LP.

(*Punto 2*)

(*El conjunto LP es inductivo, ya que usa la recurrencia para poder definirse a si mismo apartir de un caso base.
  Es decir, que parte desde un conjunto muy basico y a partir de reglas ir creando un conjunto mas grandes.
  Especificamente en este caso se usa la inducción estructural, donde el caso base son los atomos, y hay dos casos
  inductivos, la negación y la composición binaria que toma dos LP y los junto con un conector binario.*)

(*Punto 3*)

(*La función parentesis devuelve la cantidad de parentesis que tiene una formula phi, para esto se asume que
  la negación no agrega un parentesis. Por ejemplo si phi pertenece a L Sigma, entonces ~phi tambien pertenece a L Sigma,
  no se escribe ~(phi).*)
Fixpoint parentesis (lp : LP) : nat :=
  match lp with
    | p => 0
    | q => 0
    | neg PHI => 0 + parentesis PHI
    | phi PHI1 _ PHI2 => 2 + (parentesis PHI1) + (parentesis PHI2)
  end.

(*Punto 4*)

(*Esta función me devuelve la cantidad de negaciones en una formula propocicional*)
Fixpoint simbolos_neg (lp : LP) : nat :=
  match lp with
    | p => 0
    | q => 0
    | neg PHI => 1 + simbolos_neg PHI
    | phi PHI1 _ PHI2 => 0 + (simbolos_neg PHI1) + (simbolos_neg PHI2)
  end.

(*Punto 5*)

(*Esta función me devuelve la cantidad de atomos proposicionales en una formula propocicional*)
Fixpoint num_var_LP (lp : LP) : nat :=
  match lp with
    | p => 1
    | q => 1
    | neg PHI => 0 + num_var_LP PHI
    | phi PHI1 _ PHI2 => 0 + (num_var_LP PHI1) + (num_var_LP PHI2)
  end.

(*Pruebas definición de LP*)

Definition lp1 := p.
Definition lp2 := q.
Definition lp3 := phi lp1 or lp2.
Definition lp4 := neg (phi (phi lp3 and lp2) or (neg lp1)).

Compute lp1.
Compute lp2.
Compute lp3.
Compute lp4.

Compute parentesis lp3.
Compute parentesis lp4.
Compute simbolos_neg lp4.
Compute num_var_LP lp4.

(*Definicion de cadenas de numero*)

(*Punto 1*)
(*Definición de una cadena de numeros*)
Inductive cadena : Set :=
  | Vacio : cadena
  | Nodo : nat -> cadena -> cadena.

(*Punto 2*)

(*Función que me dice si una cadena esta vacia o no*)
Definition cadena_vacia (c : cadena) : bool :=
  match c with
    | Vacio => true
    | Nodo _ _ => false
  end.

(*Punto 3*)

(*Función que retorna la longitud de una cadena*)
Fixpoint longitud (c : cadena) : nat :=
  match c with
    | Vacio => 0
    | Nodo _ c1 => 1 + (longitud c1)
  end.

(*Punto 4*)

(*Función que suma el valor de cada elemento en una cadena*)
Fixpoint suma_cadena (c : cadena) : nat :=
  match c with
    | Vacio => 0
    | Nodo n c1 => n + (suma_cadena c1)
  end.

(*Punto 5*)

(*Función auxiliar que concatena dos cadenas*)
Fixpoint concatenar (c1 c2 : cadena) : cadena :=
  match c1 with
    | Vacio => c2
    | Nodo n c => Nodo n (concatenar c c2)
  end.

(*Función que recibe una cadena y retorna la misma cadena invertida*)
Fixpoint invertir (c : cadena) : cadena :=
    match c with
    | Vacio => Vacio
    | Nodo n c1 => concatenar (invertir c1) (Nodo n Vacio)
  end.

(*Pruebas Definición Cadena*)
Definition c0 := Vacio.
Definition c1 := Nodo 3 Vacio.
Definition c2 := Nodo 5 (Nodo 45 Vacio).

Compute c0.
Compute c1.
Compute c2.

Definition c3 := concatenar c2 c1.

Compute c3.

Compute cadena_vacia c0.
Compute cadena_vacia c1.
Compute longitud c2.
Compute longitud c3.
Compute suma_cadena c3.
Compute invertir c3.


From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.
From elpi Require Import elpi.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* SB木のInductiveによる表現 *)
Inductive sbtree : nat -> nat -> nat -> nat -> Prop :=
  sbtInit  : sbtree 0 1 1 0
| sbtLeft  : forall m n m' n',
               sbtree m n m' n' -> sbtree m n (m + m') (n + n')
| sbtRight : forall m n m' n',
               sbtree m n m' n' -> sbtree (m + m') (n + n') m' n'.

(* (m+m')/(n+n')を作る関数 *)
Definition calc_sbnode (m n m' n' : nat) : (nat * nat) := (m + m', n + n').
Eval compute in calc_sbnode 0 1 1 0. (* = (1, 1) : nat * nat 1/1のつもり *)
Eval compute in calc_sbnode 0 1 1 1. (* = (1, 2) : nat * nat 1/2のつもり *)
Eval compute in calc_sbnode 0 1 1 2. (* = (1, 3) : nat * nat 1/3のつもり *)
Eval compute in calc_sbnode 1 3 1 2. (* = (2, 5) : nat * nat 2/5のつもり *)
Eval compute in calc_sbnode 2 5 1 2. (* = (3, 7) : nat * nat 3/7のつもり *)

Check @sbtLeft 0 1 1 0 sbtInit. (* = 1/1 *)
Check (sbtLeft (sbtLeft sbtInit)). (* = 1/3 *)

(*
  sbtree a b c d が成り立つ場合に、その証明手順を調べるElpiプログラム
    (いずれはsbtree専用autoタクティクみたいなものを作れたらと思います。)
*)
Elpi Program check_sbtree lp:{{

  pred check_sbtree o:int, o:int, o:int, o:int.

  check_sbtree 0 1 1 0 :- coq.say "apply: sbtInit. (sbtree 0 1 1 0 → No more subgoals)".

  check_sbtree A B C D :- X = A, Y = B, Z is (C - A), W is (D - B),
                          X >= 0, Y >= 0, Z >= 0, W >= 0,
                          coq.say "apply: sbtLeft. (sbtree" A B C D "→ sbtree" X Y Z W ")",
                 	        check_sbtree X Y Z W.

  check_sbtree A B C D :- X is (A - C), Y is (B - D), Z = C, W = D,
                          X >= 0, Y >= 0, Z >= 0, W >= 0,
                          coq.say "apply: sbtRight. (sbtree" A B C D "→ sbtree" X Y Z W ")",
                          check_sbtree X Y Z W.

}}.

(* (0+1)/(1+0) = 1/1 がSB木のノードかどうかの確認 *)
Elpi Query lp:{{ check_sbtree 0 1 1 0. }}.
(*
  apply: sbtInit. (sbtree 0 1 1 0 → No more subgoals)
*)

(* (0+1)/(1+1) = 1/2 がSB木のノードかどうかの確認 *)
Elpi Query lp:{{ check_sbtree 0 1 1 1. }}.
(*
  apply: sbtLeft. (sbtree 0 1 1 1 → sbtree 0 1 1 0 )
  apply: sbtInit. (sbtree 0 1 1 0 → No more subgoals)
*)

(* (0+1)/(1+1) = 1/2 がSB木のノードであることの証明 *)
Goal sbtree 0 1 1 1. (* 0/1, 1/1 -> (0+1)/(1+1) = 1/2 *)
Proof.
  apply: sbtLeft.
  by apply: sbtInit.
Qed.

(* (2+1)/(5+2) = 3/7 がSB木のノードかどうかの確認 *)
Elpi Query lp:{{ check_sbtree 2 5 1 2. }}.
(*
  apply: sbtRight. (sbtree 2 5 1 2 → sbtree 1 3 1 2 )
  apply: sbtRight. (sbtree 1 3 1 2 → sbtree 0 1 1 2 )
  apply: sbtLeft. (sbtree 0 1 1 2 → sbtree 0 1 1 1 )
  apply: sbtLeft. (sbtree 0 1 1 1 → sbtree 0 1 1 0 )
  apply: sbtInit. (sbtree 0 1 1 0 → No more subgoals)
*)

(* (2+1)/(5+2) = 3/7 がSB木のノードであることの証明 *)
Goal sbtree 2 5 1 2. (* 2/5, 1/2 -> (2+1)/(5+2) = 3/7 *)
Proof.
  apply: (@sbtRight 1 3 1 2). (* 1/3, 1/2 -> (1+1)/(3+2) = 2/5 *)
  apply: (@sbtRight 0 1 1 2). (* 0/1, 1/2 -> (0+1)/(1+2) = 1/3 *)
  apply: (@sbtLeft 0 1 1 1). (* 0/1, 1/1 -> (0+1)/(1+1) = 1/2 *)
  apply: (@sbtLeft 0 1 1 0). (* 0/1, 1/0 -> (0+1)/(1+0) = 1/1 *)
  by apply: sbtInit.
Qed.

Eval compute in 1 * 3 - 2 * 4. (* m' * n - m * n' = 0 *)
Eval compute in 1 * 5 - 2 * 2. (* m' * n - m * n' = 1 *)
Elpi Query lp:{{ check_sbtree 2 3 1 4. }}.
(*
  The elpi command check_sbtree failed without giving a specific error message.
  Please report this inconvenience to the authors of the program.

  SB木のノードでなかった場合に、エラーメッセージを表示して終了させる方法が不明です。
  (elpiで実行すれば、Failureが返ります。)
*)


(**  Injection from the set of  ordinal terms in Cantor normal form
  into the set of Schutte's countable ordinal numbers stricly less than
  epsilon0.

  Pierre Castéran, Univ. Bordeaux and LaBRI

   This is intented to be a validation of main constructions and functions
   designed for the type [T1].

*)

(*  Pierre Casteran
    LaBRI, Université Bordeaux 1
*)

From hydras Require Import Epsilon0.Epsilon0 ON_Generic.
From hydras Require Import Schutte_basics  Schutte.Addition  AP CNF.

Import List  PartialFun Ensembles.

(* begin snippet injectDef *)

Fixpoint inject (t:T1) : Ord :=
  match t with
  | T1.zero => zero
  | T1.cons a n b => AP._phi0 (inject a) * S n + inject b
  end.

(* end snippet injectDef *)

Lemma inject_of_finite_pos : forall n, inject (\F (S n)) = F (S n).
Proof.
 induction n;simpl.
 -  rewrite phi0_zero.
    rewrite alpha_plus_zero; auto with schutte.
 - clear IHn.  induction n; simpl ; auto.
    + repeat rewrite phi0_zero.
      rewrite alpha_plus_zero; auto with schutte.
      * rewrite <- succ_is_plus_1.
             f_equal.
    + rewrite alpha_plus_zero.
     *  rewrite alpha_plus_zero in IHn.
        rewrite IHn.
        replace (AP._phi0 zero) with (F 1).
        rewrite <- succ_is_plus_1; auto with schutte.
        symmetry; auto with schutte.
        apply phi0_zero.
Qed.

(* begin snippet commutationLemmas *)

(*| .. coq:: no-out |*)

Theorem inject_of_zero : inject T1.zero = zero.
Proof. reflexivity. Qed.

Theorem inject_of_finite (n : nat):
  inject (\F n) =  n.
(*||*) (*| .. coq:: none |*)
Proof.
  destruct n.
  - apply inject_of_zero.
  - apply inject_of_finite_pos.
Qed.
(*||*)

Theorem inject_of_omega :
  inject T1omega = Schutte_basics._omega. (* .no-out *)
(*| .. coq:: none |*)
Proof.
 simpl; repeat rewrite alpha_plus_zero.
 rewrite phi0_zero;  generalize omega_second_AP; destruct 1.
 red in H; unfold Ensembles.In in H0; now rewrite omega_eqn.
Qed.
(*||*)

Theorem inject_of_phi0 (alpha : T1):
  inject (T1.phi0 alpha) = AP._phi0 (inject alpha). (* .no-out *)
(*| .. coq:: none |*)
Proof.
  simpl; now rewrite alpha_plus_zero.
Qed.

(*||*)
(* end snippet commutationLemmas *)

(* begin hide *)

Lemma phi0_mult_lt_phi0 (alpha beta : Ord) :
    alpha < beta ->
    forall n,  (AP._phi0 alpha) * S n  < AP._phi0 beta.
Proof.
  induction n;simpl;auto.
  -  apply phi0_mono;auto.
  -  apply AP_plus_closed; trivial.
    + apply AP_phi0.
    + apply phi0_mono;auto.
Qed.

Lemma phi0_mult_plus_lt_phi0 alpha beta n gamma :
  alpha < gamma -> beta < AP._phi0 gamma ->
  mult_Sn (AP._phi0 alpha) n  + beta < AP._phi0 gamma.
Proof.
  intros;apply AP_plus_closed ; auto with schutte.
  -  apply AP_phi0.
  -  apply  phi0_mult_lt_phi0;auto.
Qed.

Lemma phi0_mult_plus_lt_phi0R alpha beta n gamma :
  mult_Sn (AP._phi0 alpha) n  + beta < AP._phi0 gamma ->
  alpha < gamma /\ beta < AP._phi0 gamma.
Proof.
  split.
  - assert (H0 : AP._phi0 alpha < AP._phi0 gamma).
    {  eapply le_lt_trans.
       2:eexact H.
       apply le_trans with  (mult_Sn (AP._phi0 alpha) n).
       clear H; induction n.
       simpl;auto with schutte.
       simpl;   apply le_plus_r.
       apply le_plus_l;auto with schutte.
    }
    apply phi0_mono_R;auto.
   -   eapply le_lt_trans.
       2:eexact H.
       apply le_plus_r;auto with schutte.
Qed.

Lemma zero_lt alpha n beta :
  zero < mult_Sn (AP._phi0 alpha) n + beta.
Proof.
 apply lt_le_trans with (AP._phi0 alpha).
 -  apply phi0_positive;auto.
 - apply le_trans with ( mult_Sn (AP._phi0 alpha) n).
  induction n; simpl; auto with schutte.
   +  apply le_plus_r;auto.
   +  apply  le_plus_l;auto with schutte.
Qed.

Lemma head_lt :  forall a a' n n' b b',
    a  < a' -> b < AP._phi0 a'  ->
    mult_Sn (AP._phi0 a) n + b < mult_Sn (AP._phi0 a') n' + b'.
Proof.
 intros.
 apply lt_le_trans with (AP._phi0 a').
 - apply phi0_mult_plus_lt_phi0;auto.
 -  apply le_trans with (mult_Sn (AP._phi0 a') n').
  + induction n';simpl;auto.
   *  left; auto.
   *  apply le_plus_r;auto with schutte.
  +  apply le_plus_l;auto with schutte.
Qed.

Lemma coeff_lt : forall a  n n' b b',
    b < AP._phi0 a  ->(n < n')%nat ->
    mult_Sn (AP._phi0 a) n + b < mult_Sn (AP._phi0 a) n' + b'.
Proof.
 intros;  apply lt_le_trans with (mult_Sn (AP._phi0 a) n').
 -  apply lt_le_trans with (mult_Sn (AP._phi0 a) n + AP._phi0 a).
   +  apply plus_mono_r; auto.
   +  apply mult_Sn_mono3; auto.
     *  apply  phi0_positive; auto.
 - apply le_plus_l.
Qed.

Lemma inject_mono_0 : forall alpha,
    T1.nf alpha ->
    forall beta gamma,
      T1.lt  beta gamma ->
      T1.lt gamma alpha ->
      T1.nf beta -> T1.nf gamma ->
      (inject beta < inject gamma)%sch.
Proof with eauto with T1.
  intros alpha;  T1.transfinite_induction alpha.
  intros x Indx Nx;  induction beta; destruct gamma.
  {  intros H H0;  T1.T1_inversion H. }
  { intros H H0 H1 H2;  simpl;
      apply lt_le_trans with (AP._phi0 (inject gamma1))%sch.
    -  apply phi0_positive;auto with schutte.
    - eapply le_trans.
      2:eapply le_plus_l; auto with schutte.
      apply le_a_mult_Sn_a; auto with schutte.
  }
  intros H H0 H1 H2;  T1.T1_inversion H.
  intros H H0 H1 H2; simpl;  destruct (T1.lt_inv H).
  -   apply head_lt.
      +  eapply IHbeta1 ...

         * apply T1.lt_trans with  (T1.cons gamma1 n0 gamma2) ...
      +  apply lt_trans with (inject (T1.phi0 beta1)).
         *   eapply IHbeta2 ...
             apply T1.nf_helper_phi0.
             apply T1.nf_helper_intro with n; auto.
             apply Comparable.le_lt_trans with (T1.cons beta1 n beta2); auto with T1.
             apply T1.le_phi0 ; eauto with T1.
             eapply T1.lt_trans ...
         * simpl; rewrite alpha_plus_zero.
           apply phi0_mono,  IHbeta1; auto.
           apply T1.lt_trans with (T1.cons gamma1 n0 gamma2) ...
           eauto with T1.
           eauto with T1.
  -     decompose [or and] H3.
        subst;  apply coeff_lt.
        + replace  (AP._phi0 (inject gamma1)) with (inject (T1.phi0 gamma1)).
          *  apply IHbeta2.
             apply T1.nf_helper_phi0.
             eapply T1.nf_helper_intro; eauto.
             apply Comparable.le_lt_trans with (T1.cons gamma1 n0 gamma2); auto.
             destruct n0.
             apply T1.le_tail ...
             apply Comparable.lt_incl_le.
             apply T1.coeff_lt; auto with arith.
             eauto with T1.
             eapply T1.nf_phi0; eauto with T1.
          * cbn; rewrite alpha_plus_zero ...
        +  auto.
        +  subst; apply plus_mono_r.
           apply IHbeta2; eauto with schutte T1.
           eapply T1.lt_trans.
           2: eapply H0.
           auto with T1.
           apply T1.tail_lt_cons; auto.
Qed.

(* end hide *)

Theorem inject_mono (beta gamma : T1) :
  T1.lt  beta gamma ->
  T1.nf beta -> T1.nf gamma ->
  inject beta < inject gamma.
Proof.
  intros H H0 H1; apply inject_mono_0 with (T1.succ gamma);auto.
  -  apply T1.succ_nf;auto.
  -  apply T1.lt_succ;auto.
Qed.

Theorem inject_injective (beta gamma : T1) : nf beta -> nf gamma ->
                                             inject beta = inject gamma -> beta = gamma.
Proof.
  intros H H0 H1.
  destruct (LT_eq_LT_dec H H0) as [[H2 | H2] | H2]; auto.
  destruct H2 as [H3 [H4 H5]].   apply inject_mono in H4; auto.
  rewrite H1 in H4; auto.
  destruct (lt_irrefl H4); auto.
  destruct H2 as [H3 [H4 H5]].   apply inject_mono in H4; auto.
  rewrite H1 in H4; auto.
  destruct (lt_irrefl H4); auto.
Qed.

Theorem inject_monoR (beta gamma : T1) :
  T1.nf beta -> T1.nf gamma ->
  inject beta < inject gamma ->
  (beta  t1< gamma)%t1.
Proof.
  intros H H0 H1;
  destruct (T1.lt_eq_lt_dec beta gamma) as [[H2 | H2] | H2].
  -  now split.
  -  subst ;  case (lt_irrefl  H1).
  -  destruct (@lt_irrefl (inject beta)).
     eapply lt_trans with (inject gamma); auto.
     now apply inject_mono.
Qed.

(* begin snippet injectLtEpsilon0 *)

Theorem inject_lt_epsilon0 (alpha : T1):
  inject alpha < epsilon0. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  assert (Ap := epsilon0_AP); induction alpha; simpl.
  - rewrite <- epsilon0_fxp; apply phi0_positive.
  - apply AP_plus_closed; auto.
    apply AP_mult_Sn_closed; auto.
    now apply phi0_lt_epsilon0.
Qed.
(*||*)
(* end snippet injectLtEpsilon0 *)

(* begin hide *)

Section Equations_for_addition.

  Lemma plus_alpha_mult_phi0 (alpha beta : Ord)  (H: alpha < AP._phi0 beta)
        (n : nat) : alpha + mult_Sn (AP._phi0 beta) n = mult_Sn (AP._phi0 beta) n.
  Proof.
    induction n.
    - simpl;    destruct (AP_phi0 beta ) as [ _ H1];   apply  (H1 _ H).
    - simpl;  rewrite plus_assoc; now rewrite IHn.
  Qed.

  Lemma mult_Sn_dist (alpha : Ord) (n p : nat) :
    mult_Sn alpha (S (n + p)) = mult_Sn alpha p + mult_Sn alpha n.
  Proof.
    induction n; simpl.
    - reflexivity.
    - rewrite  plus_assoc;  f_equal.
      now   rewrite <- IHn.
  Qed.

  (*

  Quoted from Epsilon0.T1

  Fixpoint plus (alpha beta : T1) :T1 :=
  match alpha,beta with
  |  zero, y  => y
 |  x, zero  => x
 |  cons a n b, cons c p d =>
    (match compare a c with
     | Lt => cons c p d
     | Gt => (cons a n (plus b (cons c p d)))
     | Eq  => (cons a (S (n+p)) d)
     end)
  end
where "alpha + beta" := (plus alpha beta) : t1_scope.
   *)

  Variables (a b c d : Ord) (n p : nat).

  Hypotheses (Hnfa : b < AP._phi0 a)
             (Hnfc : d < AP._phi0 c).
  Let alpha := mult_Sn  (AP._phi0 a) n + b.
  Let beta := mult_Sn  (AP._phi0 c) p + d.
  Section case1.
    Hypothesis Hac: a < c.

    Lemma case_lt : alpha + beta = beta.
    Proof.
      unfold alpha, beta.
      rewrite <-
              (plus_assoc (mult_Sn (AP._phi0 a) n)
                          b
                          (mult_Sn (AP._phi0 c) p + d)).
      assert (b < AP._phi0 c).
      { apply lt_trans with (AP._phi0 a); auto with schutte.
        now apply phi0_mono.
      }
      rewrite (plus_assoc b (mult_Sn (AP._phi0 c) p) d).
      rewrite (plus_alpha_mult_phi0 _ _ H p).
      rewrite  plus_assoc .
      rewrite plus_alpha_mult_phi0.
      auto.
      apply AP_mult_Sn_closed.
      apply AP_phi0.
      now apply phi0_mono.
    Qed.

  End case1.

  Section case2.
    Hypothesis Hac : c < a.

    Lemma case_gt : alpha + beta = mult_Sn (AP._phi0 a) n +
                                   (b + beta).
    Proof.
      unfold alpha;  now  rewrite plus_assoc.
    Qed.

  End case2.

  Section case3.

    Hypothesis Hac : a = c.

    Lemma case_Eq : alpha + beta = mult_Sn (AP._phi0 a) (S (n + p)) + d.
    Proof.
      unfold alpha, beta; subst c; rewrite <- plus_assoc.
      rewrite (plus_assoc b (mult_Sn (AP._phi0 a) p) d).
      rewrite (plus_alpha_mult_phi0 _ _ Hnfa).
      rewrite plus_assoc;  f_equal.
      rewrite Nat.add_comm; now  rewrite mult_Sn_dist.
    Qed.

  End case3.

End Equations_for_addition.

(* end hide *)

Lemma inject_rw (a b: T1) n : inject (T1.cons a n b) =
                              mult_Sn (AP._phi0 (inject a)) n + inject b.
Proof. reflexivity. Qed.

(* begin snippet injectPlus *)

Theorem inject_plus (alpha beta : T1):
  nf alpha -> nf beta ->
  inject (alpha + beta)%t1 = inject alpha + inject beta. (* .no-out *)
(*| .. coq:: none |*)
Proof with eauto with T1.
  induction alpha.
  - simpl;  now rewrite zero_plus_alpha.
  -  intros H H0;  destruct beta.
     + simpl (inject (T1.cons  alpha1 n alpha2));
         rewrite <- plus_assoc; simpl (inject T1.zero);
           now rewrite alpha_plus_zero.

     + repeat rewrite inject_rw.
       simpl.
       destruct (compare alpha1 beta1) eqn:H1;
       repeat rewrite inject_rw.
       * apply compare_eq_iff in H1 as <-.
          rewrite <- (case_Eq (inject alpha1) (inject alpha2)
                              (inject alpha1) (inject  beta2) n n0) ...
          -- assert (H1 : (alpha2 t1< T1.phi0  alpha1)%t1).
             {  rewrite nf_LT_iff in H;  tauto. }
          rewrite <- inject_of_phi0.
          apply inject_mono ...
          -- rewrite <- inject_of_phi0; apply inject_mono ...
             rewrite nf_LT_iff in H0 ...
             decompose [and] H0 ...
        * rewrite compare_lt_iff in H1.
          { repeat rewrite inject_rw; rewrite case_lt; auto.
            rewrite <- inject_of_phi0;  apply inject_mono ...
            -  rewrite nf_LT_iff in H; decompose [and] H ...
            -  apply inject_mono; eauto with T1.
          }
        * rewrite compare_gt_iff in H1.
          repeat rewrite inject_rw; rewrite case_gt.
          f_equal; rewrite IHalpha2 ...
Qed.
(*||*)
(* end snippet injectPlus *)

(* begin snippet injectMultFinR *)

Theorem inject_mult_fin_r (alpha : T1)  :
  nf alpha ->
  forall n:nat,
    inject (alpha *  n)%t1 =  inject alpha * n. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  induction n.
  - simpl.
    destruct alpha; simpl; auto.
    destruct alpha1; simpl; auto.
  -  destruct n.
     +  simpl (inject alpha * 1).
        simpl (alpha * 1)%t1.
        destruct alpha; auto.
        destruct alpha1.
        *   f_equal;  destruct n; simpl; auto.
            assert (alpha2 = T1.zero).
            {  eapply nf_of_finite; eauto. }
            -- subst. f_equal; ring.
            -- assert (alpha2 = T1.zero).
            {  eapply nf_of_finite; eauto. }
            subst.
            replace (n * 1)%nat with n; auto with arith.
*  replace (n * 1)%nat with n; auto with arith.
     +   change ((S (S n)):T1) with  (FS (S n)); rewrite mult_Sn_add.
         replace (S (S n)) with (S (S (n + 0)))%nat.
         simpl mult_fin_r;  rewrite inject_plus; auto with arith.
         *  replace (alpha * (FS n))%t1 with (alpha * (S n))%t1.
            --  rewrite IHn;  replace (n+0)%nat with n.
                reflexivity.
                auto with arith.
            -- reflexivity.
         *
           {
             clear IHn; induction n; simpl.
             destruct alpha;  auto.
             destruct alpha1.
             apply nf_of_finite in H; subst; apply nf_FS.
             replace (n * 1)%nat with n; auto with arith.
             destruct alpha; auto with T1.
             destruct alpha1.
              apply nf_of_finite in H; subst; apply nf_FS.
             eapply nf_coeff_irrelevance. eauto.
           }
         *   auto with arith.
         * auto.
Qed.
(*||*)
(* end snippet injectMultFinR *)

Lemma inject_lt_epsilon0_ex_cnf  (alpha : Ord) :
  forall (H  : alpha < epsilon0)
         (l: list Ord),  is_cnf_of alpha l ->
                         exists t: T1,  nf t /\ inject t = eval l.
Proof.
  pattern alpha; apply well_founded_induction with (R:=lt).
  { exact all_ord_acc. }
  { clear alpha; intros alpha IHalpha H.
    destruct l.
    -  exists T1.zero;  simpl;   unfold nf; split; auto.
    - inversion_clear   1.
      pose (H3 := IHalpha o).
      assert (H0 : o < alpha).
      { simpl in H2;
          subst alpha; apply lt_le_trans with (AP._phi0 o).
        - apply lt_phi0; apply le_lt_trans with (AP._phi0 o).
          + apply le_phi0.
          +  apply le_lt_trans with (2:= H); apply le_plus_l.
        -   apply le_plus_l.
      }
      assert (H4 : o < epsilon0).
      { apply lt_trans with alpha; auto. }
      specialize (H3 H0 H4);  destruct (cnf_exists o) as [x H5].
      specialize (IHalpha (eval l)).
      assert (H6 : eval l < alpha). {
        simpl in H2;   subst alpha;   apply sorted_lt;  auto. }
      assert (H7 : eval l < epsilon0).
      { apply lt_trans with alpha; auto. }
      destruct (H3 _ H5) as [x0 H8].
      destruct H8 as [H8 H9]; specialize  (IHalpha H6 H7).
      + destruct (IHalpha l).
        * split; trivial.
          eapply sorted_tail; eauto.
        *   destruct H10 as [H10 H11];  exists (T1.phi0 x0 + x1)%t1.
            split.
            -- apply plus_nf ; eauto with T1.
            -- simpl eval;  rewrite <- H11;  rewrite inject_plus; auto with T1.
               simpl (inject (T1.phi0 x0)); rewrite H9;  destruct H5.
               rewrite <- H12;  rewrite alpha_plus_zero; auto.
  }
Qed.

Theorem inject_lt_epsilon0_ex  (alpha : Ord) (H  : alpha < epsilon0) :
  exists t: T1,  nf t /\ inject t = alpha.
Proof.
  destruct (cnf_exists alpha) as [l Hl].
  destruct (inject_lt_epsilon0_ex_cnf alpha H l Hl) as [t [H1 H2]].
  exists t; split ; [trivial | ].
  destruct Hl; congruence.
Qed.

Theorem inject_lt_epsilon0_ex_unique  (alpha : Ord) (H : alpha < epsilon0) :
  exists! t: T1,  nf t /\ inject t =  alpha.
Proof.
  destruct (inject_lt_epsilon0_ex alpha H ) as [t [H0 H1]].
  exists t; split.
  - now split.
  - intros t' [H2 H3].
    rewrite <- H3 in H1;  now apply inject_injective.
Qed.

(* begin snippet embedding *)

Theorem embedding : fun_bijection (nf: Ensemble T1)
                                  (members epsilon0)
                                  inject. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  split.
  -   intros x Hx; apply inject_lt_epsilon0.
  -  intros y Hy; destruct (inject_lt_epsilon0_ex y Hy) as [x [Hx Hx1]];
       exists x; auto.
  -  intros x x' Hx Hx' H; apply inject_injective; auto.
Qed.
(*||*)
(* end snippet embedding *)

(* begin snippet Epsilon0Correct *)

#[ global ] Instance Epsilon0_correct :
  ON_correct epsilon0 Epsilon0  (fun alpha => inject (cnf alpha)). (* .no-out *)
(* end snippet Epsilon0Correct *)

Proof.
  split.
  - intro a; apply embedding; red; apply cnf_ok.
  - intros; destruct (inject_lt_epsilon0_ex_unique _ H) as [x [[H0 H1] H2]].
    exists (mkord H0);now cbn.
  - intros a b; destruct (compare_correct a b).
   + now subst.
   + apply inject_mono;destruct H; tauto.
   + apply inject_mono;  destruct H; tauto.
Qed.

(** Correctness of E0.plus *)

Theorem  E0_plus_correct :  ON_op_ok  E0add plus.
Proof.
  red; destruct x,y; cbn.
  rewrite inject_plus; auto.
Qed.


Require Import Classical_Prop.

Record subset (X : Type) := as_subset { pred :> X -> Prop }.
Notation "x : A" := ((pred _ A) x) (at level 70, no associativity) : type_scope.

(*Definition eqv_pred {X : Type} {P : X -> Prop} (x : X) :
  (pred (as_subset X P)) x <-> P x.
Proof. reflexivity. Qed.
#[export] Hint Resolve eqv_pred : subsets.*)

Require Import Reals.
Require Import Lra.
Open Scope R_scope.

Variable P : R -> Prop.
Definition A := as_subset R P.

Variable x : R.
Check (x : A).
Check (is_lub A).

Notation "[ a , b ]" := (as_subset R (fun x => (a <= x <= b))).

Check (x : [0,1]).

Goal is_upper_bound [0,1] 1.
Proof.
  unfold is_upper_bound.
  intro a.
  intro a_in_interval.
  assert (0 <= a <= 1) by auto.
  lra.
Qed.

Goal 1/2 : [0,1].
Proof.
  enough (0 <= 1/2 <= 1) by auto.
  lra.
Qed.

(* (Bad) alternative *)
(* Clashes with default x : A notation on forall or exists statements. *)
Notation "x ∈ A" := ((pred _ A) x) (at level 70, no associativity) : type_scope.
Check (x ∈ [0,1]).


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

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

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

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

Fixpoint rev (rev_arg0 : Lst) : Lst
           := match rev_arg0 with
              | nil => nil
              | cons x y => append (rev y) (cons x nil)
              end.

Fixpoint qreva (qreva_arg0 : Lst) (qreva_arg1 : Lst) : Lst
           := match qreva_arg0, qreva_arg1 with
              | nil, x => x
              | cons z x, y => qreva x (cons z y)
              end.

Theorem append_nil: forall (l: Lst), append l nil = l.
Proof.
  induction l.
  { simpl. f_equal. assumption. }
  { simpl. reflexivity. }
Qed.

Theorem append_assoc:
  forall (l1 l2 l3: Lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
  induction l1; induction l2; induction l3; try (simpl; reflexivity).
  { simpl. rewrite <- IHl1. f_equal. }
  { simpl. rewrite 2 append_nil. reflexivity. }
  { simpl. rewrite append_nil.  reflexivity. }
  { simpl. rewrite 2 append_nil. reflexivity. }
Qed.

Theorem qreva_append : forall (x y : Lst), (qreva x y) = (append (rev x) y).
Proof.
  induction x; induction y; simpl; try reflexivity.
  { rewrite IHx.
    rewrite <- append_assoc.
    f_equal. }
  { rewrite IHx.
    rewrite append_nil.
    reflexivity. }
Qed.

Theorem theorem0 : forall (x : Lst), eq (rev x) (qreva x nil).
Proof.
  intros.
  rewrite qreva_append.
  rewrite append_nil.
  reflexivity.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_equalanglestransitive.
Require Export GeoCoq.Elements.OriginalProofs.lemma_supplements.

Section Euclid.

Context `{Ax1:euclidean_neutral_ruler_compass}.

Lemma lemma_supplements2 :
   forall A B C D E F J K L P Q R,
   RT A B C P Q R -> CongA A B C J K L -> RT J K L D E F ->
   CongA P Q R D E F /\ CongA D E F P Q R.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists a b c d e, (Supp a b c d e /\ CongA A B C a b c /\ CongA P Q R d b e)) by (conclude_def RT );destruct Tf as [a[b[c[d[e]]]]];spliter.
let Tf:=fresh in
assert (Tf:exists j k l m n, (Supp j k l m n /\ CongA J K L j k l /\ CongA D E F m k n)) by (conclude_def RT );destruct Tf as [j[k[l[m[n]]]]];spliter.
assert (CongA a b c A B C) by (conclude lemma_equalanglessymmetric).
assert (CongA a b c J K L) by (conclude lemma_equalanglestransitive).
assert (CongA a b c j k l) by (conclude lemma_equalanglestransitive).
assert (CongA d b e m k n) by (conclude lemma_supplements).
assert (CongA P Q R m k n) by (conclude lemma_equalanglestransitive).
assert (CongA m k n D E F) by (conclude lemma_equalanglessymmetric).
assert (CongA P Q R D E F) by (conclude lemma_equalanglestransitive).
assert (CongA D E F P Q R) by (conclude lemma_equalanglessymmetric).
close.
Qed.

End Euclid.