(* * Maximum element in a list *)

From Undecidability.TM.Util Require Export Prelim ArithPrelim.

(* ** Basic lemmas about upper bounds *)

(* An upper bound of a list is either in the list, or it is not in the list and is a strict upper bound *)
Lemma upperBound_In (xs : list nat) (u : nat) :
  (forall x, In x xs -> x <= u) ->
  (In u xs) \/
  (~ In u xs /\ forall x, In x xs -> x < u).
Proof.
  intros HUb. induction xs as [ | x xs IH]; intros; cbn in *.
  - right. auto.
  - spec_assert IH as [IH | [IH1 IH2]] by auto.
    + auto.
    + decide (x = u) as [ <- | Hdec].
      * left. auto.
      * right. split.
        -- intros [<- | H]; congruence.
        -- intros y [-> | H].
           ++ specialize (HUb y ltac:(now left)). lia.
           ++ specialize (IH2 y H). lia.
Qed.

(* We assume that [M] is an upper bound of [s] and [xs]. We also assume that [M] is either in xs, or every element of [x] is smaller than [s]. Then, if [M] is actually a strict upper bound of [xs], then [s] is also a strict upper bound of [xs]. *)
Lemma strict_greatest_upper_bound : forall (xs : list nat) (M s : nat),
    (In M xs \/ (M = s /\ forall x, In x xs -> x <= s)) ->
    (s <= M) ->
    (forall x, In x xs -> x < M) ->
    (forall x, In x xs -> x < s).
Proof.
  intros xs. induction xs as [ | x xs IH]; intros M s HM1 Hs HM2 y Hy; cbn in *.
  - auto.
  - destruct Hy as [ <- | Hy].
    + destruct HM1 as [ [ <- | HM1] | (->&HM1)]; eauto.
      * exfalso. specialize (HM2 x ltac:(eauto)). nia.
      * rewrite HM2; eauto.
    + destruct HM1 as [ [ <- | HM1] | (->&HM1)]; eauto.
      exfalso. specialize (HM2 x ltac:(eauto)). nia.
Qed.

(* ** Tail Recursive Definition *)

(* Compute the maximum of a list and a start-value tail-recursively *)
Fixpoint max_list_rec (s : nat) (xs : list nat) { struct xs } : nat :=
  match xs with
  | nil => s
  | x :: xs' => max_list_rec (max x s) xs'
  end.

(* We can remove the tail-recursion *)
Lemma max_list_rec_max (xs : list nat) (s1 s2 : nat) :
  max_list_rec (max s1 s2) xs = max (max_list_rec s1 xs) (max_list_rec s2 xs).
Proof.
  induction xs as [ | x xs IH] in s1,s2|-*; cbn in *.
  - reflexivity.
  - rewrite Max.max_assoc. rewrite !IH. nia.
Qed.

(* If the list is not empty, and every element in the list is greater than start-values [s1] and [s2], then the choice of start-value [s1] or [s2] doesn't matter *)
Lemma max_list_rec_irrelevant (xs : list nat) (s1 s2 : nat) :
  xs <> nil ->
  (forall x, In x xs -> s1 <= x /\ s2 <= x) ->
  max_list_rec s1 xs = max_list_rec s2 xs.
Proof.
  induction xs as [ | x xs IH]; intros Hneq Hxs; cbn in *.
  - congruence.
  - pose proof (Hxs x ltac:(auto)) as [Hxs1 Hxs2].
    destruct xs as [ | x' xs].
    + cbn. nia.
    + rewrite !max_list_rec_max. rewrite IH; eauto. congruence.
Qed.

(* The maximum is always greater or equal than the start-value *)
Lemma max_list_rec_ge (xs : list nat) (s : nat) :
  s <= max_list_rec s xs.
Proof.
  induction xs as [ | x' xs IH] in s|-*; cbn.
  - reflexivity.
  - rewrite <- IH. nia.
Qed.

(* The maximum is greater or equal than every element in the list *)
Lemma max_list_rec_ge_el (xs : list nat) (s : nat) (x : nat) :
  In x xs ->
  x <= max_list_rec s xs.
Proof.
  induction xs as [ | x' xs IH] in s,x|-*; intros Hel; cbn in *.
  - tauto.
  - destruct Hel as [ <- | Hel].
    + rewrite max_list_rec_max. rewrite <- Nat.le_max_l. apply max_list_rec_ge.
    + rewrite max_list_rec_max. rewrite <- IH; eauto. nia.
Qed.

Corollary max_list_rec_ge_el_ge (xs : list nat) (s : nat) (x y : nat) :
  In y xs ->
  x <= y ->
  x <= max_list_rec s xs.
Proof. intros. rewrite <- (max_list_rec_ge_el _ H); eauto. Qed.

(* [max_list_rec] is monotone w.r.t. the start value *)
Lemma max_list_rec_monotone (xs : list nat) (s0 s1 : nat) :
  s0 <= s1 ->
  max_list_rec s0 xs <= max_list_rec s1 xs.
Proof.
  revert s0 s1. induction xs as [ | x' xs' IH]; intros; cbn in *.
  - assumption.
  - rewrite IH; eauto. nia.
Qed.

(* ... and also w.r.t. the lists *)
Lemma max_list_rec_monotone' (xs1 xs2 : list nat) (s0 s1 : nat) :
  (Forall2 le xs1 xs2) ->
  s0 <= s1 ->
  max_list_rec s0 xs1 <= max_list_rec s1 xs2.
Proof.
  intros H. revert s0 s1. induction H; intros; cbn.
  - assumption.
  - rewrite IHForall2. apply max_list_rec_monotone.
    instantiate (1 := Init.Nat.max x s0). all:nia.
Qed.

(* [max_list_rec] is a lower bound of [z], if every element is smaller than [z]. *)
Lemma max_list_rec_lower_bound (xs : list nat) (s : nat) (z : nat) :
  s <= z ->
  (forall x, In x xs -> x <= z) ->
  max_list_rec s xs <= z.
Proof.
  revert s z. induction xs as [ | x xs IH]; intros s z Hz Hxs; cbn in *.
  - assumption.
  - pose proof (Hxs x ltac:(eauto)) as Hxs'.
    rewrite max_list_rec_max. rewrite !IH by eauto. nia.
Qed.

Corollary max_list_rec_max' (xs : list nat) (s1 s2 : nat) :
  max_list_rec (Init.Nat.max s1 s2) xs = Init.Nat.max s1 (max_list_rec s2 xs).
Proof.
  apply Nat.le_antisymm.
  - apply max_list_rec_lower_bound; eauto.
    + apply Nat.max_le_compat_l. apply max_list_rec_ge.
    + intros x Hx. rewrite <- Max.le_max_r. now apply max_list_rec_ge_el.
  - rewrite max_list_rec_max.
    apply Nat.max_le_compat; auto.
    apply max_list_rec_ge.
Qed.

Corollary max_list_rec_max'' (xs : list nat) (s1 s2 : nat) :
  max_list_rec (Init.Nat.max s1 s2) xs = Init.Nat.max (max_list_rec s1 xs) s2.
Proof.
  apply Nat.le_antisymm.
  - apply max_list_rec_lower_bound; eauto.
    + apply Nat.max_le_compat_r. apply max_list_rec_ge.
    + intros x Hx. rewrite <- Max.le_max_l. now apply max_list_rec_ge_el.
  - rewrite max_list_rec_max.
    apply Nat.max_le_compat; auto.
    apply max_list_rec_ge.
Qed.

Corollary max_list_rec_idem s xs :
  max_list_rec (max_list_rec s xs) xs = max_list_rec s xs.
Proof.
  apply Nat.le_antisymm.
  - apply max_list_rec_lower_bound; eauto. intros. now apply max_list_rec_ge_el.
  - apply max_list_rec_lower_bound; eauto.
    + now rewrite <- !max_list_rec_ge.
    + intros. rewrite <- max_list_rec_ge. now apply max_list_rec_ge_el.
Qed.

(* Either the maximum (with start-value [s]) is in the list, or it is equal to [s] and [s] is greater (or equal) than every element *)
Lemma max_list_rec_el_or_eq xs s :
  max_list_rec s xs el xs \/ max_list_rec s xs = s /\ (forall x : nat, x el xs -> x <= s).
Proof.
  revert s. induction xs as [ | x xs IH]; intros; cbn in *; eauto.
  rewrite !max_list_rec_max.
  assert (max_list_rec s xs <= max_list_rec x xs \/ max_list_rec x xs <= max_list_rec s xs) as [H|H] by lia.
  - rewrite !max_l by assumption.
    specialize (IH x) as [IH|[<- IH]].
    + left. eauto.
    + rewrite !max_list_rec_idem. auto.
  - rewrite !max_r by assumption.
    specialize (IH s) as [IH|[<- IH]].
    + left. eauto.
    + right. split.
      * apply max_list_rec_idem.
      * intros y [<-|Hy].
        -- rewrite <- H. apply max_list_rec_ge.
        -- now apply IH.
Qed.

(* This, is [max_list_rec s xs] is a strict upper bound, so is [s] *)
Corollary max_list_rec_gt xs s :
  (forall y : nat, y el xs -> y < max_list_rec s xs) ->
  forall y : nat, y el xs -> y < s.
Proof.
  intros.
  apply strict_greatest_upper_bound with (M := max_list_rec s xs) (xs := xs); eauto.
  - apply max_list_rec_el_or_eq.
  - apply max_list_rec_ge.
Qed.

(* ... and also [s] is equal to [max_list_rec s xs]. *)
Corollary max_list_rec_gt' xs s :
  (forall x : nat, x el xs -> x < max_list_rec s xs) ->
  max_list_rec s xs = s /\ (forall x : nat, x el xs -> x < s).
Proof.
  split.
  - revert H. generalize (max_list_rec_ge xs s) as L1.
    set (m := (max_list_rec s xs)). intros.
    enough (m <= s) by nia.
    apply max_list_rec_lower_bound; auto.
    intros x Hx.
    apply Nat.lt_le_incl.
    eapply max_list_rec_gt; eauto.
  - now apply max_list_rec_gt.
Qed.

(* To conclude, either the maximum is euqal to the start value (and s is a strict upper bound), or the maximum is actually in the list *)
Corollary max_list_rec_In (xs : list nat) (s : nat) :
  (max_list_rec s xs = s /\ forall x, In x xs -> x < s) \/
  In (max_list_rec s xs) xs.
Proof.
  pose proof @upperBound_In xs (max_list_rec s xs).
  spec_assert H as [H | [H1 H2]].
  - intros. now apply max_list_rec_ge_el.
  - now right.
  - left. now apply max_list_rec_gt'.
Qed.

(* ** Definition of the maximum of a list *)

(* We simply instantiate the accu to [0] *)
Definition max_list (xs : list nat) := max_list_rec 0 xs.

(* The main lemmas can be simplified now *)
Lemma max_list_ge (xs : list nat) (x : nat) :
  In x xs ->
  x <= max_list xs.
Proof. intros. unfold max_list. rewrite <- max_list_rec_ge_el; eauto. Qed.

Lemma max_list_lower_bound (xs : list nat) (z : nat) :
  (forall x, In x xs -> x <= z) ->
  max_list xs <= z.
Proof. intros. unfold max_list. apply max_list_rec_lower_bound. lia. auto. Qed.

Lemma max_list_monotone (f : nat -> nat) (xs : list nat) :
  (forall x, x <= f x) ->
  max_list xs <= max_list (map f xs).
Proof.
  intros. apply max_list_lower_bound.
  intros x Hx. rewrite H. apply max_list_ge. apply in_map_iff. eauto.
Qed.

(* If the list is not empty, then the maximum is in the list *)
Lemma max_list_In (xs : list nat) :
  xs <> nil ->
  In (max_list xs) xs.
Proof.
  destruct xs as [ | x xs]; [ congruence | intros _].
  pose proof max_list_rec_In (x :: xs) 0 as [ (_&Absurd) | NotSoAbsurd ].
  - exfalso. specialize (Absurd x ltac:(auto)). lia.
  - apply NotSoAbsurd.
Qed.

(* ** Maximum of a function *)

(* A size of a largest element in a list, w.r.t. to a size function *)
Section max_list_map.
  Variable (X : Type) (f : X -> nat).

  Definition max_list_map (xs : list X) := max_list (map f xs).

  (* This version may be useful sometimes *)
  Definition max_list_map_rec (s : nat) (xs : list X) := max_list_rec s (map f xs).

  Lemma max_list_map_ge (xs : list X) (x : X) :
    In x xs ->
    f x <= max_list_map xs.
  Proof. intros. unfold max_list_map. apply max_list_ge. apply in_map_iff. eauto. Qed.

  Lemma max_list_map_lower_bound (xs : list X) (z : nat) :
    (forall x, In x xs -> f x <= z) ->
    max_list_map xs <= z.
  Proof. intros. unfold max_list_map. apply max_list_lower_bound. intros ? (?&<-&?) % in_map_iff. auto. Qed.

  Lemma max_list_map_In (xs : list X) :
    xs <> nil ->
    exists x, f x = max_list_map xs /\ In x xs.
  Proof.
    intros Hnil.
    apply in_map_iff.
    apply max_list_In.
    destruct xs; cbn in *; congruence.
  Qed.

End max_list_map.

(* [max_list_map] is monotone w.r.t. the function *)
Lemma max_list_map_monotone (X : Type) (f1 f2 : X -> nat) (xs : list X) :
  (forall (x : X), In x xs -> f1 x <= f2 x) ->
  max_list_map f1 xs <= max_list_map f2 xs.
Proof.
  intros. unfold max_list_map. apply max_list_lower_bound.
  intros ? (x&<-&?) % in_map_iff. rewrite H. apply max_list_ge. apply in_map_iff. eauto. auto.
Qed.


Require Import BuiltIn.
Require Import Relation_Definitions.

Open Scope Z_scope.

(* Idea of the proof: by induction on (range := max_index - min_index)
The general proof of raising_order statement is in several steps:
- change the lemmas in order to get min_index and range instead of min_index and max_index
- prove raising_order_induction via trivial induction on range and use of transitive property
  lt_trans
- adapt this result to our use case *)

(* First proving a general lemma proving that a simple raising order is true for
   all types having a transitive relation *)
Lemma raising_order_induction:
  forall (T: Type) (f: int -> T) (lt_T: relation T) (lt_trans: transitive T lt_T)
    range min_index
    (* Raising Order hypothesis *)
    (Harr: forall k : int, min_index <= k <= min_index + Z.of_nat range ->
      k + 1 <= min_index + Z.of_nat range -> lt_T (f k) (f (k + 1))),
  (* New raising order conclusion *)
  forall (i j: int)
    (Hij: i < j)
    (Hjrange: min_index <= j <= min_index + Z.of_nat range)
    (Hirange: min_index <= i <= min_index + Z.of_nat range),
      lt_T (f i) (f j).
Proof.
induction range; intros.

(* Base case *)
{
 assert (i = min_index) by (rewrite Nat2Z.inj_0 in Hirange; omega).
 assert (j = min_index) by (rewrite Nat2Z.inj_0 in Hjrange; omega).
 subst. destruct (Z.lt_irrefl _ Hij).
}

(* Induction case *)
{
 (* There are 2 cases:
  - we can use the induction hypothesis directly because j <= min_index + range
  - we cannot because j = min_index + range + 1 *)
 assert (Hcase: j <= min_index + Z_of_nat range \/ j = min_index + Z_of_nat (S range)).
 {
  rewrite Nat2Z.inj_succ in Hjrange.
  rewrite <- Zplus_succ_r_reverse in Hjrange.
  destruct Hjrange. eapply Z.le_succ_r in H0. intuition. right. subst. simpl.
  rewrite Zpos_P_of_succ_nat. omega.
 }

 destruct Hcase as [Hjless | Hjeq].
 (* First case is easily proved *)
 {
  eapply IHrange; destruct Hjrange; eauto; try omega.
  intros. eapply Harr; simpl; intuition. rewrite Zpos_P_of_succ_nat. omega.
  rewrite Zpos_P_of_succ_nat. omega.
 }

 {
  assert (lt_T (f (j - 1)) (f j)).
  (* Some ugly transformation to get the property we need *)
  {
   pose (a := j-1). replace j with (a + 1).
   replace (a + 1 - 1) with a.
   eapply Harr; unfold a; eauto; try omega. omega.
   unfold a. omega.
  }

  (* Again we need two cases *)
  assert (j = i + 1 \/ i < (j - 1)) by omega.

  destruct H0.
  (* First case is easy *)
  { rewrite H0. eapply (Harr i); eauto. rewrite <- Hjeq. rewrite H0. omega. }

  {
   eapply lt_trans with (f (j - 1)); eauto.

   (* Adapted Harr_rec to use the induction hyptohesis *)
   assert (Harr_rec: forall k : int,
           min_index <= k <= min_index + Z.of_nat range ->
           k + 1 <= min_index + Z.of_nat range -> lt_T (f k) (f (k + 1))).
   {
    intros. eapply Harr.
    intuition. eapply Z.le_trans; eauto. simpl. rewrite Zpos_P_of_succ_nat. omega.
    eapply Z.le_trans; eauto. simpl. rewrite Zpos_P_of_succ_nat. omega.
   }

   (* Use induction hypothesis and prove last details *)
   eapply (IHrange min_index Harr_rec i (j-1)); try eapply H0; eauto; try omega.
   replace (Z.of_nat range) with (Z.of_nat (S range) - 1). omega.
   simpl Z.of_nat. rewrite Zpos_P_of_succ_nat. omega.
   replace (Z.of_nat range) with (Z.of_nat (S range) - 1). omega.
   simpl Z.of_nat. rewrite Zpos_P_of_succ_nat. omega.
  }
 }
}
Qed.

(* This is just adapting raising_order_induction to remove range from the statement *)
Lemma generic_raising_order:
  forall (T: Type) (lt_T: relation T) (lt_trans: transitive T lt_T) (f : int -> T) max_int min_int
    (Harr: forall i (Hirange: min_int <= i <= max_int), i + 1 <= max_int ->
      lt_T (f i) (f (i + 1))),
    forall i (Hirange: min_int <= i <= max_int) j (Hjrange: min_int <= j <= max_int),
      i < j -> lt_T (f i) (f j).
Proof.
intros.
pose (range := max_int - min_int).
assert (max_int = min_int + range). unfold range. omega.
rewrite H0 in *.
assert (Hrange: 0 <= range) by (unfold range in *; omega).
generalize (IZN range Hrange). intros Hex. destruct Hex as (n, Hn).
rewrite Hn in *. eapply raising_order_induction; eauto.
Qed.

(* This is just replacing the raising order hypothesis with the
   exact right one. (Should be about (i-1) and i not i and (i + 1) *)
Lemma generic_raising_order_minus:
  forall (T: Type) (lt_T: relation T) (lt_trans: transitive T lt_T) (f : int -> T) max_int min_int
    (Harr: forall i (Hirange: min_int <= i <= max_int), i - 1 >= min_int ->
      lt_T (f (i - 1)) (f i)),
    forall i (Hirange: min_int <= i <= max_int) j (Hjrange: min_int <= j <= max_int),
      i < j -> lt_T (f i) (f j).
Proof.
intros.
pose (range := max_int - min_int).
assert (max_int = min_int + range). unfold range. omega.
rewrite H0 in *.
assert (Hrange: 0 <= range) by (unfold range in *; omega).
generalize (IZN range Hrange). intros Hex. destruct Hex as (n, Hn).
rewrite Hn in *. eapply raising_order_induction; eauto.
intros. assert (k = (k + 1) - 1). ring.
rewrite H3. replace  (k + 1 - 1 + 1) with (k + 1) by ring.
eapply Harr; intuition.
Qed.


Require Export lecture3.

(* # Contents *)
(*
In this lecture, we will be formalizing a separation logic for the ML-like
language that we discussed in the second lecture. The topics that we discuss
during the lecture are as follows:

- Separation logic
- Deep embedding versus shallow embedding
- Weakest preconditions
*)
(* # Separation logic *)
(*
The syntax of our separation logic is as follows:

  P, Q ::= emp
         | P ** Q | P -* Q
         | emp | l ~> v
         | All x, P | Ex x, P |
         | wp e (fun v => Q)

We will not explain all of these connectives in detail right immediately. The
semantics of most will be described in the course of this lecture, accompanied
by a formal description in Coq. However, we will highlight the core connectives
of separation logic, whose informal semantics is as follows:

  l ~> v := _the points-to connective_
            the memory consists of exactly one location `l` with value `v`

  P ** Q := _separating conjunction_
            the memory can be split into two _disjoint_ parts, so that the
            first satisfies P and the second satisfies Q

  emp    := _the empty connective_
            the memory is empty

Using these connectives, one can give very precise descriptions of memory
footprints, for example:

  l1 ~> 6 ** l2 ~> 8
  \Ex v, l1 ~> v ** l2 ~> 2 * v

The first example describes a memory that consists of two locations `l1` and
`l2` that respectively contain the values 6 and 8. Since the separation
conjunction `P ** Q` ensures that the parts of the memory described by `P` and
`Q` are disjoint, we know that `l1` and `l2` are in different (i.e. they do not
alias). This makes separating conjunction very different from conjunction
`P /\ Q`, which says that `P` and `Q` both hold for the same memory.

The second example describes the memories that contain two different locations
`l1` and `l2`, so that the value of `l2` is twice that of `l1`.

Making use of separating conjunction, we can give very concise specifications of
programs that manipulate pointers, for example, take the following Hoare logic
specification of the swap function:

  {{ l ~> v ** k ~> w }} swap l k {{ l ~> w ** k ~> v }}
     ^                               ^
   precondition                     postcondition

This specification expresses that swap is indeed swapping, as witnessed by the
fact that the values of the locations `l` and `k` have been swapped. But apart
from that, it also expresses in the precondition that the locations `l` and `k`
should be different before executing the program, and in the postcondition
that these are still different.
*)

(* # Shallow embedding versus deep embedding *)
(*
In the second lecture, we have already seen how we could use Coq to model a
programming language. In that section, we started by defining a _syntax_ for
our language in terms of an inductive type, and then gave an operational
semantics for this language. The approach of first defining a syntax is called
a _deep embedding_.

In this section, we proceed differently: we are not going to define an explicit
syntax for our separation logic. Instead, we are going to define the connectives
of our separation logic directly by their _semantic interpretation_.  This is
called a _shallow embedding_.
*)

(* # Shallow embedding of separation logic *)
(*
The first question that we need to answer is: what will be the semantic
interpretation of the connectives of our separation logic? As we have just seen,
formulas in separation logic describe sets of memories. For example:

  \Ex v, l1 ~> v ** l2 ~> 2 * v

Describes describes all memories that contain two different locations `l1` and
`l2`, so that the value of `l2` is twice that of `l1`.

The natural way to describe sets of memories in Coq is by means of a predicate:
*)
Definition iProp := mem -> Prop.

(*
Now, let us try to give a semantic interpretation of separating conjunction.
For this, recall the informal description of `P ** Q`: the memory can be split
into two _disjoint_ parts, so that the first satisfies `P` and the second
satisfies `Q`. In the previous lecture we put a lot of effort in formalizing
disjointness and unions of finite maps. Since our memories are represented as
finite maps, that effort will pay of now:
*)
Definition iSep (P Q : iProp) : iProp := fun m =>
  exists m1 m2, m = munion m1 m2 /\ mdisjoint m1 m2 /\ P m1 /\ Q m2.
Notation "P ** Q" := (iSep P Q) (at level 80, right associativity).

(*
Recall that in predicates are functions. So, to construct an element of type
`iProp` (i.e. `mem -> Prop`) we use a lambda abstraction of Coq.

In order to write down separation logic propositions in a concise way, we use
the `Notation` command to setup Coq's parser and pretty printer.
*)

(*
In the same spirit as separating conjunction, we can now describe the points-to
connective and the empty connective. These definitions crucially relies on the
singleton finite map `msingleton l v` and the empty finite map `mempty` that we
have defined in the first lecture.
*)
Definition points_to (l : nat) (v : val) : iProp := fun m =>
  m = msingleton l v.
Notation "l ~> v" := (points_to l v) (at level 20).

Definition iEmp : iProp := fun m => m = mempty.
Notation "'emp'" := iEmp.

(*
Together with separating conjunction, we have a corresponding form of
implication: the magic wand `P -* Q`. It describes the memories described by `Q`
minus those described by `P`, i.e., it describes the memories such that, if you
(disjointly) add memories satisfying `P`, you obtain resources satisfying `Q`.
*)
Definition iWand (P Q : iProp) : iProp := fun m =>
  forall m2, mdisjoint m2 m -> P m2 -> Q (munion m2 m).
Notation "P -* Q" :=
  (iWand P Q) (at level 99, Q at level 200, right associativity).

(*
Finally, we lift the quantifiers of Coq into our separation logic. Note that
we use the functions of Coq to represent the binder.
*)
Definition iForall {A} (P : A -> iProp) : iProp := fun m => forall x, P x m.
Notation "'All' x1 .. xn , P" :=
  (iForall (fun x1 => .. (iForall (fun xn => P)) ..))
  (at level 200, x1 binder, xn binder, right associativity).

Definition iExists {A} (P : A -> iProp) : iProp := fun m => exists x, P x m.
Notation "'Ex' x1 .. xn , P" :=
  (iExists (fun x1 => .. (iExists (fun xn => P)) ..))
  (at level 200, x1 binder, xn binder, right associativity).

(*
In order to express mathematical statements in our separation logic (for as
equality, that a number is even, ...), we will now define an embedding of Coq
propositions (type `Prop`) into the propositions of our separation logic (type
`iProp`). We define this using (higher-order) existential quantification.
*)
Definition iPure (p : Prop) : iProp := Ex _ : p, emp.
Notation "@[ p ]" := (iPure p) (at level 20, p at level 200).

(* ## Weakest preconditions and Hoare triples *)
(*
So far, we have defined basic logical connectives of our separation logic. But
last, but not least, we of course need some way of expressing properties of
programs. We do this using Hoare triples:

  {{ P }} e {{ Q }}

In this lecture, we consider Hoare triples for total program correctness, so the
intuitive meaning of the Hoare triple is:

  If the precondition holds for the memory before hand, then the
  expression `e` results in a value `v`, such that `Q v` holds.

Note that our postconditions have type `val -> iProp`, which allows us to
talk about the result value of an expression. For example:

  {{ l ~> v ** k ~> w }}
    swap l k
  {{ fun v => @[ v = VUnit ] ** l ~> w ** k ~> v }}

Instead of defining Hoare triples directly, we first define the notion of
weakest preconditions.

  wp e Q

And then define Hoare triples as :

  {{ P }} e {{ Q }} := P |- wp e Q

Where |- is the point-wise entailment of `iProp`:
*)

Definition iEntails (P Q : iProp) : Prop := forall m, P m -> Q m.
Notation "P |- Q" := (iEntails P Q) (at level 99, Q at level 200).

(*
Now, before we give the formal definition of weakest preconditions, there is
one final catch. An important part of separation logic is that we have the
so-called _framing_ rule:

        {{ P }} e {{ Q }}
  -----------------------------
   {{ P ** R }} e {{ P ** R }}

Let us see this rule in action. As we have seen before, we can give the
following specification to the swap function:

  {{ l ~> v ** k ~> w }} swap l k {{ l ~> w ** k ~> v }}

This specification looks overly restrictive as the pre- and post-condition say
that the memory should exactly contain the locations `l` and `k`. However,
using the frame rule, we can derive also:

  {{ l ~> v ** k ~> w ** R }} swap l k {{ l ~> w ** k ~> v ** R }}

Where `R` is any formula of separation logic, for example, `k' ~> w'` for
some other location `k'`. As we see here, the frame rule allows us to reason
locally: we can state and prove specifications with a small memory footprint,
and then use framing to extend them to bigger memory footprints, so that we can
use the specification in larger contexts too.

In order to make sure that we can prove the framing rule, the definition of
weakest preconditions becomes slightly more complicated. We also have to
qualify over all possible frames `mf`:
*)
Definition wp (e : expr) (Q : val -> iProp) : iProp := fun m =>
  forall mf, mdisjoint m mf ->
    exists m' v, mdisjoint m' mf /\
                 big_step e (munion m mf) v (munion m' mf) /\
                 Q v m'.

Definition hoare (P : iProp) (e : expr) (Q : val -> iProp) : Prop :=
  P |- wp e Q.

(* # Basic rules of the logic *)
(*
Let us first prove that entailment |- is a pre-order, i.e. it is reflexive and
transitive. These properties are crucial to compose proofs.
*)
Lemma iEntails_refl P : P |- P.
Proof.
  unfold iEntails.
  intros m Hm.
  assumption.
Qed.
Lemma iEntails_trans P Q R : (P |- Q) -> (Q |- R) -> P |- R.
Proof.
  (* Note that we do not really have to unfold `iEntails`: the `intros` tactic
  will do that for us. *)
  intros HPQ HQR m HP. apply HQR. apply HPQ. assumption.
Qed.

(* ## Rules for separating conjunction *)
(*
We now prove the key properties of separating conjunction: monotonicity, the
identity laws w.r.t. `emp`, commutativity, and associativity.
*)
Lemma iSep_mono_l P1 P2 Q : (P1 |- P2) -> P1 ** Q |- P2 ** Q.
Proof.
  intros HP m Hm.
  unfold iSep in Hm.
  destruct Hm as [m1 Hm].
  destruct Hm as [m2 Hm].
  destruct Hm as [Heq Hm].
  destruct Hm as [Hdisj Hm].
  destruct Hm as [HPm1 HQm2].
(* As we see, writing down this sequence of existential and conjunction
eliminations becomes pretty tedious. It requires many tactics, and we have to
name all the auxiliary results. Fortunately, Coq allows us to nest these
`destruct`s in the following way. *)
Restart.
  intros HP m Hm.
  unfold iSep in Hm.
  destruct Hm as [m1 [m2 [Heq [Hdisj [HPm1 HQm2]]]]].
(* This is much shorter, but still results in a lot of brackets. Coq provides
yet another syntax to make this more concise. *)
Restart.
  intros HP m Hm.
  unfold iSep in Hm.
  destruct Hm as (m1 & m2 & Heq & Hdisj & HPm1 & HQm2).
(*
The syntax `(x1 & x2 & ... & xn)` is just sugar for `[x1 [x2 [... [xn-1 xn]]]]`.

And finally, we can even perform the eliminations directly while introducing:
*)
Restart.
  intros HP m (m1 & m2 & Heq & Hdisj & HP1 & HQ).
  subst m.
  unfold iSep.
  exists m1, m2.
  split.
  { reflexivity. }
  split.
  { assumption. }
  split.
  { apply HP. assumption. }
  assumption.
Restart.
(* Or to make the proof even shorter, we can use `eauto`, which uses all
hypotheses (including implications, like the entailment) in the context by
default. *)
  intros HP m (m1 & m2 & Heq & Hdisj & HPm1 & HQm2).
  subst m. unfold iSep. eauto 10.
Qed.
Lemma iSep_comm P Q : P ** Q |- Q ** P.
Proof.
  intros m (m1 & m2 & Heq & Hdisj & HP & HQ).
  exists m2, m1.
  rewrite <-munion_comm by assumption.
  auto using mdisjoint_sym.
Qed.
Lemma iSep_assoc P Q R : P ** (Q ** R) |- (P ** Q) ** R.
Proof.
  intros m (m1 & m' & Heq & Hdisj & HP & (m2 & m3 & Heq' & Hdisj' & HQ & HR)).
  subst.
  exists (munion m1 m2), m3. split.
  { rewrite munion_assoc. reflexivity. }
  split.
  { eauto using mdisjoint_union_l, mdisjoint_union_inv_rr. }
  split.
  { exists m1, m2. eauto using mdisjoint_union_inv_rl. }
  assumption.
Qed.

(** ### Exercise *)
(*
Prove the following laws.
*)
Lemma iSep_emp_l P : P |- emp ** P.
Proof. Admitted.
Lemma iSep_emp_l_inv P : emp ** P |- P.
Proof. Admitted.

(* ## Rules for magic wand *)
Lemma iWand_intro_r P Q R : (P ** Q |- R) -> P |- Q -* R.
Proof.
  intros H m Hm m' ? HQ. apply H. rewrite munion_comm by assumption.
  exists m, m'; auto using mdisjoint_sym.
Qed.
Lemma iWand_elim P Q : P ** (P -* Q) |- Q.
Proof.
  intros m (m1 & m2 & ? & ? & ? & ?). subst.
  apply H2; auto.
Qed.

(* ## Rules for universal quantification *)
Lemma iForall_intro {A} P (Q : A -> iProp) :
  (forall x, P |- Q x) -> (P |- All x, Q x).
Proof. intros H m HP x. apply H. assumption. Qed.
Lemma iForall_elim {A} (P : A -> iProp) x : (All z, P z) |- P x.
Proof. intros m HP. apply HP. Qed.

(* ## Rules for existential quantification *)
(* ### Exercise *)
(*
Prove the following laws.
*)
Lemma iExist_intro {A} (P : A -> iProp) x : P x |- Ex z, P z.
Proof. Admitted.
Lemma iExist_elim {A} (P : A -> iProp) Q :
  (forall x, P x |- Q) -> (Ex z, P z) |- Q.
Proof. Admitted.

(* ## Derived rules of the logic *)
(*
So far, we have proved a bunch of rules for our separation logic by unfolding
the definition of the separation logic connectives. However, it turns out that
many additional rules can be _derived_ from the rules we have seen so far.
*)
Lemma iSep_emp_r P : P |- P ** emp.
Proof.
  apply iEntails_trans with (emp ** P).
  { apply iSep_emp_l. }
  apply iSep_comm.
Qed.
Lemma iSep_emp_r_inv P : P ** emp |- P.
Proof.
  apply iEntails_trans with (emp ** P).
  { apply iSep_comm. }
  apply iSep_emp_l_inv.
Qed.

Lemma iSep_mono_r P Q1 Q2 :
  (Q1 |- Q2) -> P ** Q1 |- P ** Q2.
Proof.
  intros HQ. apply iEntails_trans with (Q1 ** P).
  { apply iSep_comm. }
  apply iEntails_trans with (Q2 ** P).
  { apply iSep_mono_l. assumption. }
  apply iSep_comm.
Qed.

(*** ## Exercise *)
(*
Prove the following derived laws. Make sure to not unfold the definitions of
the connectives of our separation logic, but only use the rules we have already
proven. Hint: you need to use transitivity of entailment many times.
*)
Lemma iSep_mono P1 P2 Q1 Q2 :
  (P1 |- P2) -> (Q1 |- Q2) -> P1 ** Q1 |- P2 ** Q2.
Proof. Admitted.

(* This lemma is quite subtle: you need to use the rules for commutativity,
associativity and monotonicity of separating conjunction. I advice to first work
out the proof on paper, and then do it in Coq. *)
Lemma iSep_assoc' P Q R : (P ** Q) ** R |- P ** (Q ** R).
Proof. Admitted.

Lemma iWand_intro_l P Q R : (Q ** P |- R) -> P |- Q -* R.
Proof. Admitted.

(* This lemma is very difficult: you need to use the introduction and
elimination rules for magic wand `-*`. *)
Lemma iExist_sep {A} (P : A -> iProp) Q :
  (Ex x, P x) ** Q |- Ex x, P x ** Q.
Proof. Admitted.

Lemma iPure_intro (p : Prop) : p -> emp |- @[ p ].
Proof. Admitted.

Lemma iPure_elim (p : Prop) P Q : (p -> P |- Q) -> @[ p ] ** P |- Q.
Proof. Admitted.

(* ## Logical rules for weakest preconditions *)
(*
We now prove the framing rule for weakest preconditions. Convince yourself
that from this rule, we get the framing rule for Hoare triples.

The proof below is a bit subtle, as we need to use properties about `munion`
and `mdisjoint` many times.
*)
Lemma wp_frame Q R e :
  wp e Q ** R |- wp e (fun v => Q v ** R).
Proof.
  intros m (m1 & m2 & Heq & Hdisj & Hwp & HR). subst m.
  intros mf Hm.
  destruct (Hwp (munion m2 mf)) as (m' & v & Hdisj' & Hbig & HQ).
  { eauto using mdisjoint_union_r, mdisjoint_union_inv_ll. }
  exists (munion m' m2), v. split.
  { eauto 4 using mdisjoint_union_l, mdisjoint_union_inv_rr, mdisjoint_union_inv_lr. }
  split.
  { rewrite <-!munion_assoc. assumption. }
  exists m', m2. split.
  { reflexivity. }
  eauto using mdisjoint_union_inv_rl.
Qed.

(* ### Exercise *)
(*
Prove the rule below.
*)
Lemma wp_mono Q R e :
  (forall v, Q v |- R v) ->
  wp e Q |- wp e R.
Proof. Admitted.

(* # Structural rules for weakest preconditions *)
Lemma wp_val v Q : Q v |- wp (EVal v) Q.
Proof. intros m HQ mf Hm. exists m, v. eauto with big_step. Qed.

Lemma wp_ctx E e Q :
  wp e (fun w => wp (fill E (EVal w)) Q) |- wp (fill E e) Q.
Proof.
  intros m Hwp mf Hdisj.
  destruct (Hwp mf) as (m' & v & Hdisj' & Hbig & Hwp').
  { assumption. }
  destruct (Hwp' mf) as (m'' & v'' & Hdisj'' & Hbig' & HQ).
  { assumption. }
  eauto 10 using big_step_fill.
Qed.

Lemma wp_let x e1 e2 Q :
  wp e1 (fun v => wp (subst x v e2) Q) |- wp (ELet x e1 e2) Q.
Proof.
  intros m Hwp mf Hdisj.
  destruct (Hwp mf Hdisj) as (mf' & v' & Hdisj' & Hbig & Hwp2).
  destruct (Hwp2 mf Hdisj') as (mf'' & v'' & Hdisj'' & Hbig' & HQ).
  exists mf'',  v''. eauto with big_step.
Qed.

(* ### Exercise *)
(*
Prove the rules below: all of these follow the same structure as the proofs
above.
*)
Lemma wp_seq e1 e2 Q :
  wp e1 (fun _ => wp e2 Q) |- wp (ESeq e1 e2) Q.
Proof. Admitted.

Lemma wp_if_true e2 e3 Q :
  wp e2 Q |- wp (EIf (EVal (VBool true)) e2 e3) Q.
Proof. Admitted.

Lemma wp_if_false e2 e3 Q :
  wp e3 Q |- wp (EIf (EVal (VBool false)) e2 e3) Q.
Proof. Admitted.

Lemma wp_while e1 e2 Q :
  wp (EIf e1 (ESeq e2 (EWhile e1 e2)) (EVal VUnit)) Q |- wp (EWhile e1 e2) Q.
Proof. Admitted.

Lemma wp_op op v1 v2 v Q :
  eval_bin_op op v1 v2 = Some v ->
  Q v |- wp (EOp op (EVal v1) (EVal v2)) Q.
Proof. Admitted.

(* # Stateful rules for weakest preconditions *)
(*
We finish by proving the rules for the operations of our language that
manipulate the state. Let us take a look at the rules for load and store (in
mixed informal and Coq notations):

  l ~> v ** (l ~> v -* Q v)     |- wp !l Q.
  l ~> v ** (l ~> w -* Q VUnit) |- wp (!l := w) Q.

So, what does the second rule say: In order to prove the weakest precondition
of a store, we have to show that `l` already exists in the memory. This is done
by showing that we have the points-to connective `l ~> v`. Now, since the only
way of introducing a separating conjunction is monotonicity, this means we have
to give up the point-to connective `l ~> v`, which leaves us with
`l ~> w -* Q VUnit`. By introducing the magic wand, we consequentially get the
point-to connective back, but now with the new value `w`.

The same kind of pattern is used for the other rules.
*)
Lemma wp_load l v Q :
  l ~> v ** (l ~> v -* Q v) |- wp (ELoad (EVal (VLoc l))) Q.
Proof.
  intros m HQ mf Hdisj.
  destruct HQ as (m1 & m2 & Heq & Hdisj' & Hpointsto & HQ). subst m.
  unfold points_to in Hpointsto. subst m1.
  exists (munion (msingleton l v) m2), v. split.
  { assumption. }
  split.
  { eapply Load_big_step.
    - eapply Val_big_step.
    - rewrite <-munion_assoc. rewrite munion_lookup.
      rewrite msingleton_lookup. simpl. reflexivity. }
  apply HQ.
  { assumption. }
  unfold points_to. reflexivity.
Qed.

(* ### Exercise (very difficult) *)
(*
Prove the rules below: all of these follow the same structure as the proofs
above. Hint: you need to make extensive use of properties about finite maps.
Use Coq's `Search` command to find these. For example:
*)
Search (minsert _ _ (msingleton _ _) = _).
(*
Yields:

  minsert_singleton:
    forall (A : Type) (i : nat) (x y : A),
    minsert i x (msingleton i y) = msingleton i x
*)
Lemma wp_store l v w Q :
  l ~> v ** (l ~> w -* Q VUnit) |- wp (EStore (EVal (VLoc l)) (EVal w)) Q.
Proof. Admitted.

Lemma wp_alloc v Q :
  (All l, l ~> v -* Q (VLoc l)) |- wp (EAlloc (EVal v)) Q.
Proof. Admitted.

Lemma wp_free l v Q :
  l ~> v ** Q VUnit |- wp (EFree (EVal (VLoc l))) Q.
Proof. Admitted.

(* # An example *)
(*
Finally, we will look at an example. We take the simplest program that
manipulates pointers: the swap function.
*)

(*
  swap x y :=
    let tmp := !x in
    x := !y;
    y := tmp
*)
Definition swap (x y : val) : expr :=
  ELet "tmp" (ELoad (EVal x))
    (ESeq (EStore (EVal x) (ELoad (EVal y)))
          (EStore (EVal y) (EVar "tmp"))).

(* Transitivity with the premises swapped *)
Lemma iEntails_trans' P Q R : (Q |- R) -> (P |- Q) -> P |- R.
Proof. eauto using iEntails_trans. Qed.

Lemma swap_correct l k v w :
  hoare
    (l ~> v ** k ~> w)
    (swap (VLoc l) (VLoc k))
    (fun ret => @[ret = VUnit] ** l ~> w ** k ~> v).
Proof.
  unfold hoare.
  unfold swap.
  eapply iEntails_trans'.
  { apply wp_let. }
  eapply iEntails_trans'.
  { apply wp_load. }
  apply iSep_mono_r. apply iWand_intro_l.
  simpl.
  eapply iEntails_trans'.
  { apply (wp_ctx (SeqCtx _ :: StoreCtxR _ :: nil)). }
  eapply iEntails_trans'.
  { apply wp_load. }
  eapply iEntails_trans'.
  { apply iSep_comm. }
  apply iSep_mono_l. apply iWand_intro_r.
  simpl.
  eapply iEntails_trans'.
  { apply (wp_ctx (SeqCtx _ :: nil)). }
  eapply iEntails_trans'.
  { apply wp_store. }
  apply iSep_mono_r. apply iWand_intro_l.
  simpl.
  eapply iEntails_trans'.
  { apply wp_seq. }
  eapply iEntails_trans'.
  { apply wp_val. }
  eapply iEntails_trans'.
  { apply wp_store. }
  eapply iEntails_trans'.
  { apply iSep_comm. }
  apply iSep_mono_l. apply iWand_intro_r.
  eapply iEntails_trans.
  { apply iSep_emp_l. }
  apply iSep_mono_l.
  apply iPure_intro.
  reflexivity.
Qed.

(* # Conclusion *)
(*
As you have seen, proving the correctness of our simple example already takes
a lot of work. For example, we have to:

- Use transitivity of entailment to use the weakest precondition rules.
- After we have used a rule for a load or store, we have to "frame".
- We often have to reorder the premises on the LHS of the turnstile.
- We have to pick evaluation contexts ourselves when we use `wp_ctx`.

Of course, most of these steps are completely mechanical, and as such, Coq is
well capable of automating this. Unfortunately, automating proofs in separation
logic in Coq is beyond the scope of these lectures.

If you would like to know more about it, please take a look at the following
paper:

  Robbert Krebbers, Amin Timany and Lars Birkedal
  Interactive Proofs in Higher-Order Concurrent Separation Logic
  POPL 2017

If you want to see separation logic in Coq in practice, try the Iris project,
a state-of-the art higher-order concurrent separation logic that has been
implemented and verified in Coq:

  http://iris-project.org

*)


(* Exercise 30 *)

Require Import BenB.

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

Theorem exercise_030 : (exists x, P x \/ Q x) /\ (forall x, ~ Q x) -> (exists x, P x).
Proof.
imp_i a1.
exi_e (exists x:D, P x \/ Q x) a a2.
con_e1 (forall x:D, ~Q x).
hyp a1.
dis_e (P a \/ Q a) a3 a3.
hyp a2.
exi_i a.
hyp a3.
neg_e (Q a).
all_e (forall x:D, ~Q x) a.
con_e2 (exists x:D, P x \/ Q x).
hyp a1.
hyp a3.
Qed.


(*using definitions from http://www.math.ucla.edu/~tao/resource/general/121.1.00s/vector_axioms.html *)

Require Import Reals.Rbase.
Require Import Reals.Rfunctions.

Module AxiomaticNormedRealVectorSpace.

Inductive rvector (d: nat) : Set :=
| zero
| add (x y : rvector d)
| inverse (x: rvector d)
| smult (r:R) (x: rvector d).

Class NormedVectorSpace (d: nat) :=
  {
    norm:  rvector d -> R;

    rv_axiom_additive : forall x y z : rvector d,
    (add d x y) = (add d y x)  /\
    (add d (add d x y) z) = (add d x (add d y z)) /\
    (add d (zero d) x) = (add d x (zero d)) /\
    (add d x (zero d)) = x /\
    (add d (inverse d x) x) = (add d x (inverse d x)) /\
    (add d x (inverse d x)) = zero d;

    rv_axiom_multiplicaive : forall (x : rvector d), forall (b c : R),
    smult d R0 x = zero d /\
    smult d R1 x = x /\
    smult d (Rmult b c) x = smult d b (smult d c x);

    rv_axiom_distributive : forall (x y : rvector d), forall (a b : R),
    smult d b (add d x y) = add d (smult d b x) (smult d b y) /\
    smult d (Rplus a b) x = add d (smult d a x) (smult d b x);

    norm_axiom_zero : forall (x:rvector d),
          norm (zero d) = R0 <-> x=zero d;

    norm_axiom_abs : forall (x: rvector d), forall (a:R),
    norm (smult d a x) = Rmult (Rabs a) (norm x);

    norm_axiom_add : forall (x y : rvector d),
    norm (add d x y) = Rplus (norm x) (norm y);
  }.

End AxiomaticNormedRealVectorSpace.


Require Import ZArith Zpow_facts.

Open Scope Z_scope.

Fixpoint plength (p: positive) : positive :=
  match p with
    xH => xH
  | xO p1 => Pos.succ (plength p1)
  | xI p1 => Pos.succ (plength p1)
  end.

Theorem plength_correct: forall p, (Zpos p < 2 ^ Zpos (plength p))%Z.
assert (F: (forall p, 2 ^ (Zpos (Pos.succ p)) = 2 * 2 ^ Zpos p)%Z).
intros p; replace (Zpos (Pos.succ p)) with (1 + Zpos p)%Z.
rewrite Zpower_exp; auto with zarith.
red; intros; discriminate.
rewrite Zpos_succ_morphism; unfold Z.succ; auto with zarith.
intros p; elim p; simpl plength; auto.
intros p1 Hp1; rewrite F; repeat rewrite Zpos_xI.
assert (tmp: (forall p, 2 * p = p + p)%Z);
  try repeat rewrite tmp; auto with zarith.
intros p1 Hp1; rewrite F; rewrite (Zpos_xO p1).
assert (tmp: (forall p, 2 * p = p + p)%Z);
  try repeat rewrite tmp; auto with zarith.
rewrite Zpower_1_r; auto with zarith.
Qed.

Theorem plength_pred_correct: forall p, (Zpos p <= 2 ^ Zpos (plength (Pos.pred p)))%Z.
intros p; case (Psucc_pred p); intros H1.
subst; simpl plength.
rewrite Zpower_1_r; auto with zarith.
pattern p at 1; rewrite <- H1.
rewrite Zpos_succ_morphism; unfold Z.succ; auto with zarith.
generalize (plength_correct (Pos.pred p)); auto with zarith.
Qed.

Definition Pdiv p q :=
  match Z.div (Zpos p) (Zpos q) with
    Zpos q1 => match (Zpos p) - (Zpos q) * (Zpos q1) with
                 Z0 => q1
               | _ => (Pos.succ q1)
               end
  |  _ => xH
  end.

Theorem Pdiv_le: forall p q,
  Zpos p <= Zpos q * Zpos (Pdiv p q).
intros p q.
unfold Pdiv.
assert (H1: Zpos q > 0); auto with zarith.
assert (H1b: Zpos p >= 0).
  red; intros; discriminate.
generalize (Z_div_ge0 (Zpos p) (Zpos q) H1 H1b).
generalize (Z_div_mod_eq (Zpos p) (Zpos q) H1); case Z.div.
  intros HH _; rewrite HH; rewrite Zmult_0_r; rewrite Zmult_1_r; simpl.
case (Z_mod_lt (Zpos p) (Zpos q) H1); auto with zarith.
intros q1 H2.
replace (Zpos p - Zpos q * Zpos q1) with (Zpos p mod Zpos q).
  2: pattern (Zpos p) at 2; rewrite H2; auto with zarith.
generalize H2 (Z_mod_lt (Zpos p) (Zpos q) H1); clear H2;
  case Zmod.
  intros HH _; rewrite HH; auto with zarith.
  intros r1 HH (_,HH1); rewrite HH; rewrite Zpos_succ_morphism.
  unfold Z.succ; rewrite Zmult_plus_distr_r; auto with zarith.
  intros r1 _ (HH,_); case HH; auto.
intros q1 HH; rewrite HH.
unfold Z.ge; simpl Z.compare; intros HH1; case HH1; auto.
Qed.

Definition is_one p := match p with xH => true | _ => false end.

Theorem is_one_one: forall p, is_one p = true -> p = xH.
intros p; case p; auto; intros p1 H1; discriminate H1.
Qed.

Definition get_height digits p :=
  let r := Pdiv p digits in
   if is_one r then xH else Pos.succ (plength (Pos.pred r)).

Theorem get_height_correct:
  forall digits N,
   Zpos N <= Zpos digits * (2 ^ (Zpos (get_height digits N) -1)).
intros digits N.
unfold get_height.
assert (H1 := Pdiv_le N digits).
case_eq (is_one (Pdiv N digits)); intros H2.
rewrite (is_one_one _ H2) in H1.
rewrite Zmult_1_r in H1.
change (2^(1-1))%Z with 1; rewrite Zmult_1_r; auto.
clear H2.
apply Z.le_trans with (1 := H1).
apply Zmult_le_compat_l; auto with zarith.
rewrite Zpos_succ_morphism; unfold Z.succ.
rewrite Zplus_comm; rewrite Zminus_plus.
apply plength_pred_correct.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (z : natural) (lf3 : natural) (lf2 : natural) : natural :=
  plus z (plus lf2 lf3).


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

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

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

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense. {
    apply Hc with (x := 0).
    - apply le_n.
    - apply le_S. apply le_n. }
  discriminate Nonsense. Qed.

Theorem total_relation_not_a_partial_function:
  ~ (partial_function total_relation).
Proof.
  unfold not. unfold partial_function. intros.

  assert (0=1) as shit. {
  apply H with (x:=0).
  - apply tot_rel.
  - apply tot_rel.
  }
  inversion shit.
Qed.

Theorem empty_relation_partial_function:
  partial_function empty_relation.
Proof.
  unfold partial_function. intros. inversion H.
Qed.

Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.
Theorem le_reflexive :
  reflexive le.
Proof.
  unfold reflexive. intros n. apply le_n. Qed.

Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).
Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  - (* le_n *) apply Hnm.
  - (* le_S *) apply le_S. apply IHHmo. Qed.

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

Theorem lt_trans' :
  transitive lt.
Proof.
  (* Prove this by induction on evidence that m is less than o. *)
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [| m' Hm'o].
  - apply le_S in Hnm. apply Hnm.
  - apply le_S in IHHm'o. apply IHHm'o.
Qed.

Theorem lt_trans'' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  - inversion Hmo.
  - apply le_S in Hnm.
    apply le_trans with (a := (S n)) (b := (S m)) (c := (S o')).
  -- apply Hnm. -- apply Hmo.
Qed.

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

Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  intros. inversion H.
  - apply le_n.
  - apply le_Sn_le in H1. apply H1.
Qed.

Theorem le_Sn_n : forall n,
  ~ (S n <= n).
Proof.
  unfold not. intros. induction n.
  - inversion H. - apply IHn. apply le_S_n in H. apply H.
Qed.

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

Theorem le_not_symmetric :
  ~ (symmetric le).
Proof.
  unfold not. unfold symmetric. intros.
  assert (1<=0) as shit.
  {intros. apply H. apply n_le_Sn.
  }
  inversion shit.
Qed.

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

Theorem le_antisymmetric :
  antisymmetric le.
Proof.
  intros a b. generalize dependent a. induction b.
  - intros. inversion H. reflexivity.
  - intros. destruct a.
  -- inversion H0.
  -- Search S.
  apply Sn_le_Sm__n_le_m in H.
  apply IHb in H.
  + rewrite H. reflexivity.
  + apply Sn_le_Sm__n_le_m in H0. apply H0.
Qed.

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

Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).
Theorem le_order :
  order le.
Proof.
  unfold order. split.
    - (* refl *) apply le_reflexive.
    - split.
      + (* antisym *) apply le_antisymmetric.
      + (* transitive. *) apply le_trans. Qed.


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

          IEEE754  :  Float

          Laurent Thery

  *****************************************************************************
  ******************************************************
   Module Float.v
   Inspired by the Diadic of Patrick Loiseleur
  *******************************************************)
Require Export Omega.
Require Export Compare.
Require Export Rpow.
Section definitions.
Variable radix : Z.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.
(* The type float represents the set of numbers who can be written:
   x = n*b^p with  n and p in Z. (pdic numbers)
   n = Fnum and p = Fexp 						*)

Record float : Set := Float {Fnum : Z; Fexp : Z}.

Theorem floatEq :
 forall p q : float, Fnum p = Fnum q -> Fexp p = Fexp q -> p = q.
intros p q; case p; case q; simpl in |- *; intros;
 apply (f_equal2 (A1:=Z) (A2:=Z)); auto.
Qed.

Theorem floatDec : forall x y : float, {x = y} + {x <> y}.
intros x y; case x; case y; intros Fnum2 Fexp2 Fnum1 Fexp1.
case (Z_eq_dec Fnum1 Fnum2); intros H1.
case (Z_eq_dec Fexp1 Fexp2); intros H2.
left; apply floatEq; auto.
right; red in |- *; intros H'; Contradict H2; inversion H'; auto.
right; red in |- *; intros H'; Contradict H1; inversion H'; auto.
Qed.

Definition Fzero (x : Z) := Float 0 x.

Definition is_Fzero (x : float) := Fnum x = 0%Z.

Theorem is_FzeroP : forall x : float, is_Fzero x \/ ~ is_Fzero x.
unfold is_Fzero in |- *; intro; CaseEq (Fnum x); intros;
 (right; discriminate) || (left; auto).
Qed.
Coercion IZR : Z >-> R.
Coercion INR : nat >-> R.
Coercion Z_of_nat : nat >-> Z.

Definition FtoR (x : float) := (Fnum x * powerRZ (IZR radix) (Fexp x))%R.

Local Coercion FtoR : float >-> R.

Theorem FzeroisReallyZero : forall z : Z, Fzero z = 0%R :>R.
intros z; unfold FtoR in |- *; simpl in |- *; auto with real.
Qed.

Theorem is_Fzero_rep1 : forall x : float, is_Fzero x -> x = 0%R :>R.
intros x H; unfold FtoR in |- *.
red in H; rewrite H; simpl in |- *; auto with real.
Qed.

Theorem LtFnumZERO : forall x : float, (0 < Fnum x)%Z -> (0 < x)%R.
intros x; case x; unfold FtoR in |- *; simpl in |- *.
intros Fnum1 Fexp1 H'; replace 0%R with (Fnum1 * 0)%R;
 [ apply Rmult_lt_compat_l | ring ]; auto with real zarith.
Qed.

Theorem is_Fzero_rep2 : forall x : float, x = 0%R :>R -> is_Fzero x.
intros x H'.
case (Rmult_integral _ _ H'); simpl in |- *; auto.
case x; simpl in |- *.
intros Fnum1 Fexp1 H'0; red in |- *; simpl in |- *; auto with real zarith.
apply eq_IZR_R0; auto.
intros H'0; Contradict H'0; apply powerRZ_NOR; auto with real zarith.
Qed.

Theorem NisFzeroComp :
 forall x y : float, ~ is_Fzero x -> x = y :>R -> ~ is_Fzero y.
intros x y H' H'0; Contradict H'.
apply is_Fzero_rep2; auto.
rewrite H'0.
apply is_Fzero_rep1; auto.
Qed.
(* Some inegalities that will be helpful *)

Theorem Rlt_monotony_exp :
 forall (x y : R) (z : Z),
 (x < y)%R -> (x * powerRZ radix z < y * powerRZ radix z)%R.
intros x y z H'; apply Rmult_lt_compat_r; auto with real zarith.
Qed.

Theorem Rle_monotone_exp :
 forall (x y : R) (z : Z),
 (x <= y)%R -> (x * powerRZ radix z <= y * powerRZ radix z)%R.
intros x y z H'; apply Rmult_le_compat_r; auto with real zarith.
Qed.

Theorem Rlt_monotony_contra_exp :
 forall (x y : R) (z : Z),
 (x * powerRZ radix z < y * powerRZ radix z)%R -> (x < y)%R.
intros x y z H'; apply Rmult_lt_reg_l with (r := powerRZ radix z);
 auto with real zarith.
repeat rewrite (Rmult_comm (powerRZ radix z)); auto.
Qed.

Theorem Rle_monotony_contra_exp :
 forall (x y : R) (z : Z),
 (x * powerRZ radix z <= y * powerRZ radix z)%R -> (x <= y)%R.
intros x y z H'; apply Rmult_le_reg_l with (r := powerRZ radix z);
 auto with real zarith.
repeat rewrite (Rmult_comm (powerRZ radix z)); auto.
Qed.

Theorem FtoREqInv1 :
 forall p q : float, ~ is_Fzero p -> p = q :>R -> Fnum p = Fnum q -> p = q.
intros p q H' H'0 H'1.
apply floatEq; auto.
unfold FtoR in H'0.
apply Rpow_eq_inv with (r := IZR radix); auto 6 with real zarith.
apply Rlt_dichotomy_converse; right; red in |- *.
unfold Rabs in |- *; case (Rcase_abs radix).
intros H'2; Contradict H'2; apply Rle_not_lt; apply Ropp_le_cancel;
 auto with real.
intros H'2; replace 1%R with (IZR 1); auto with real zarith.
apply Rmult_eq_reg_l with (r := IZR (Fnum p)); auto with real.
pattern (Fnum p) at 2 in |- *; rewrite H'1; auto.
Qed.

Theorem FtoREqInv2 :
 forall p q : float, p = q :>R -> Fexp p = Fexp q -> p = q.
intros p q H' H'0.
apply floatEq; auto.
apply eq_IZR; auto.
apply Rmult_eq_reg_l with (r := powerRZ radix (Fexp p));
 auto with real zarith.
repeat rewrite (Rmult_comm (powerRZ radix (Fexp p)));
 pattern (Fexp p) at 2 in |- *; rewrite H'0; auto with real zarith.
Qed.

Theorem Rlt_Float_Zlt :
 forall p q r : Z, (Float p r < Float q r)%R -> (p < q)%Z.
intros p q r H'.
apply lt_IZR.
apply Rlt_monotony_contra_exp with (z := r); auto with real.
Qed.

Theorem Rle_Float_Zle :
 forall p q r : Z, (Float p r <= Float q r)%R -> (p <= q)%Z.
intros p q r H'.
apply le_IZR.
apply Rle_monotony_contra_exp with (z := r); auto with real.
Qed.
(* Properties for floats with 1 as mantissa *)

Theorem oneExp_le :
 forall x y : Z, (x <= y)%Z -> (Float 1%nat x <= Float 1%nat y)%R.
intros x y H'; unfold FtoR in |- *; simpl in |- *.
repeat rewrite Rmult_1_l; auto with real zarith.
apply Rle_powerRZ; try replace 1%R with (IZR 1); auto with real zarith zarith.
Qed.

Theorem oneExp_lt :
 forall x y : Z, (x < y)%Z -> (Float 1%nat x < Float 1%nat y)%R.
intros x y H'; unfold FtoR in |- *; simpl in |- *.
repeat rewrite Rmult_1_l; auto with real zarith.
Qed.

Theorem oneExp_Zlt :
 forall x y : Z, (Float 1%nat x < Float 1%nat y)%R -> (x < y)%Z.
intros x y H'; case (Zle_or_lt y x); auto; intros ZH; Contradict H'.
apply Rle_not_lt; apply oneExp_le; auto.
Qed.

Theorem oneExp_Zle :
 forall x y : Z, (Float 1%nat x <= Float 1%nat y)%R -> (x <= y)%Z.
intros x y H'; case (Zle_or_lt x y); auto; intros ZH; Contradict H'.
apply Rgt_not_le; red in |- *; apply oneExp_lt; auto.
Qed.

Definition Fdigit (p : float) := digit radix (Fnum p).

Definition Fshift (n : nat) (x : float) :=
  Float (Fnum x * Zpower_nat radix n) (Fexp x - n).

Theorem sameExpEq : forall p q : float, p = q :>R -> Fexp p = Fexp q -> p = q.
intros p q; case p; case q; unfold FtoR in |- *; simpl in |- *.
intros Fnum1 Fexp1 Fnum2 Fexp2 H' H'0; rewrite H'0; rewrite H'0 in H'.
cut (Fnum1 = Fnum2).
intros H'1; rewrite <- H'1; auto.
apply eq_IZR; auto.
apply Rmult_eq_reg_l with (r := powerRZ radix Fexp1);
 repeat rewrite (Rmult_comm (powerRZ radix Fexp1));
 auto.
apply Rlt_dichotomy_converse; right; auto with real.
red in |- *; auto with real.
Qed.

Theorem FshiftFdigit :
 forall (n : nat) (x : float),
 ~ is_Fzero x -> Fdigit (Fshift n x) = Fdigit x + n.
intros n x; case x; unfold Fshift, Fdigit, is_Fzero in |- *; simpl in |- *.
intros p1 p2 H; apply digitAdd; auto.
Qed.

Theorem FshiftCorrect : forall (n : nat) (x : float), Fshift n x = x :>R.
intros n x; unfold FtoR in |- *; simpl in |- *.
rewrite Rmult_IZR.
rewrite Zpower_nat_Z_powerRZ; auto.
repeat rewrite Rmult_assoc.
rewrite <- powerRZ_add; auto with real zarith.
rewrite Zplus_minus; auto.
Qed.

Theorem FshiftCorrectInv :
 forall x y : float,
 x = y :>R ->
 (Fexp x <= Fexp y)%Z -> Fshift (Zabs_nat (Fexp y - Fexp x)) y = x.
intros x y H' H'0; try apply sameExpEq; auto.
apply trans_eq with (y := FtoR y); auto.
apply FshiftCorrect.
generalize H' H'0; case x; case y; simpl in |- *; clear H' H'0 x y.
intros Fnum1 Fexp1 Fnum2 Fexp2 H' H'0; rewrite inj_abs; auto with zarith.
Qed.

Theorem FshiftO : forall x : float, Fshift 0 x = x.
intros x; unfold Fshift in |- *; apply floatEq; simpl in |- *.
replace (Zpower_nat radix 0) with 1%Z; auto with zarith.
simpl in |- *; auto with zarith.
Qed.

Theorem FshiftCorrectSym :
 forall x y : float,
 x = y :>R -> exists n : nat, (exists m : nat, Fshift n x = Fshift m y).
intros x y H'.
case (Z_le_gt_dec (Fexp x) (Fexp y)); intros H'1.
exists 0; exists (Zabs_nat (Fexp y - Fexp x)).
rewrite FshiftO.
apply sym_equal.
apply FshiftCorrectInv; auto.
exists (Zabs_nat (Fexp x - Fexp y)); exists 0.
rewrite FshiftO.
apply FshiftCorrectInv; auto with zarith.
Qed.

Theorem FshiftAdd :
 forall (n m : nat) (p : float), Fshift (n + m) p = Fshift n (Fshift m p).
intros n m p; case p; unfold Fshift in |- *; simpl in |- *.
intros Fnum1 Fexp1; apply floatEq; simpl in |- *; auto with zarith.
rewrite Zpower_nat_is_exp; auto with zarith.
rewrite (Zmult_comm (Zpower_nat radix n)); auto with zarith.
rewrite <- (Zminus_plus_simpl_r (Fexp1 - m) n m).
replace (Fexp1 - m + m)%Z with Fexp1; auto with zarith.
replace (Z_of_nat (n + m)) with (n + m)%Z; auto with zarith arith.
rewrite <- inj_plus; auto.
Qed.

Theorem ReqGivesEqwithSameExp :
 forall p q : float,
 exists r : float,
   (exists s : float, p = r :>R /\ q = s :>R /\ Fexp r = Fexp s).
intros p q; exists (Fshift (Zabs_nat (Fexp p - Zmin (Fexp p) (Fexp q))) p);
 exists (Fshift (Zabs_nat (Fexp q - Zmin (Fexp p) (Fexp q))) q);
 repeat split; auto with real.
rewrite FshiftCorrect; auto.
rewrite FshiftCorrect; auto.
simpl in |- *.
replace (Z_of_nat (Zabs_nat (Fexp p - Zmin (Fexp p) (Fexp q)))) with
 (Fexp p - Zmin (Fexp p) (Fexp q))%Z.
replace (Z_of_nat (Zabs_nat (Fexp q - Zmin (Fexp p) (Fexp q)))) with
 (Fexp q - Zmin (Fexp p) (Fexp q))%Z.
case (Zmin_or (Fexp p) (Fexp q)); intros H'; rewrite H'; auto with zarith.
rewrite inj_abs; auto.
apply Zplus_le_reg_l with (p := Zmin (Fexp p) (Fexp q)); auto with zarith.
generalize (Zle_min_r (Fexp p) (Fexp q)); auto with zarith.
rewrite inj_abs; auto.
apply Zplus_le_reg_l with (p := Zmin (Fexp p) (Fexp q)); auto with zarith.
Qed.

Theorem FdigitEq :
 forall x y : float,
 ~ is_Fzero x -> x = y :>R -> Fdigit x = Fdigit y -> x = y.
intros x y H' H'0 H'1.
cut (~ is_Fzero y); [ intros NZy | idtac ].
2: red in |- *; intros H'2; case H'.
2: apply is_Fzero_rep2; rewrite H'0; apply is_Fzero_rep1; auto.
case (Zle_or_lt (Fexp x) (Fexp y)); intros Eq1.
case (Zle_lt_or_eq _ _ Eq1); clear Eq1; intros Eq1.
absurd
 (Fdigit (Fshift (Zabs_nat (Fexp y - Fexp x)) y) =
  Fdigit y + Zabs_nat (Fexp y - Fexp x)).
rewrite FshiftCorrectInv; auto.
rewrite <- H'1.
red in |- *; intros H'2.
absurd (0%Z = (Fexp y - Fexp x)%Z); auto with zarith arith.
rewrite <- (inj_abs (Fexp y - Fexp x)); auto with zarith.
apply Zlt_le_weak; auto.
apply FshiftFdigit; auto.
apply sameExpEq; auto.
absurd
 (Fdigit (Fshift (Zabs_nat (Fexp x - Fexp y)) x) =
  Fdigit x + Zabs_nat (Fexp x - Fexp y)).
rewrite FshiftCorrectInv; auto.
rewrite <- H'1.
red in |- *; intros H'2.
absurd (0%Z = (Fexp x - Fexp y)%Z); auto with zarith arith.
rewrite <- (inj_abs (Fexp x - Fexp y)); auto with zarith.
apply Zlt_le_weak; auto.
apply FshiftFdigit; auto.
Qed.
End definitions.
Hint Resolve Rlt_monotony_exp Rle_monotone_exp: real.
Hint Resolve Zlt_not_eq Zlt_not_eq_rev: zarith.


Theorem le_0_n:
        forall n:nat, 0 <= n.
Proof.
        intros. elim n.
        auto.
        intros. auto.
Qed.

Theorem le_n_0_eq:
        forall n:nat, n <= 0 -> n =0.
Proof.
        intros n h.
        inversion h.
        trivial.
Qed.

Theorem le_plus_minus' :
        forall n m : nat, m <= n -> n = m + (n - m).
Proof.
        intro n. elim n.
        intros m h. inversion h. trivial.        induction m.
        intros; trivial.
        intros. simpl.
        assert (forall n m : nat, n = m -> S n = S m).
        intros; auto.
        apply H1. apply H. apply le_S_n.
        trivial.
Qed.

Theorem le_plus_minus2' :
        forall n m:nat, m <= n -> n = m + (n - m).
Proof.
        intro n. elim n.
        intros m h; inversion h; simpl; trivial.
        intro. intro. intro. case m. intros; simpl; trivial. intro. intro. simpl. assert (h: forall m n:nat,  m = n -> S m = S n). intros; simpl; rewrite <- H1; simpl ; trivial.
        apply h; apply H; apply le_S_n; trivial.
Qed.

Section primes.
        Definition divides (n m : nat) := exists p:nat, p*n = m.
        Theorem divides_0 :
                forall n: nat, divides n 0.
        Proof.
                intro.
                unfold divides.
                exists 0;trivial.
        Qed.

        Theorem divides_plus:
                forall n m : nat, divides n m -> divides n (n + m).
        Proof.
                unfold divides.
                intros.
                inversion H.
                exists (S x). simpl. rewrite <- H0. trivial.
        Qed.

Require Import Arith.

        Theorem not_divides_plus:
                forall n m:nat, 0 < m -> m < n -> ~divides n m.
        Proof.
                unfold divides.
                unfold not.
                intros n m h1 h2 h3. inversion h3.
                destruct x. simpl in H; rewrite <- H in h1; inversion h1. assert ( S x >= S O). change ( 1 + x  >= 0 + 1).  SearchPattern (_ + _ = _ + _). rewrite <- plus_comm. SearchPattern(_ <= _ -> _ <= _). apply plus_le_compat_r. apply le_0_n.  assert (S x * n >= 1 * n). apply mult_le_compat_r. apply H0. rewrite -> H in H1. simpl in H1. unfold lt in h2. assert ( S m >= S (n + 0)). change (1 + m >= 1 + n + 0). SearchPattern (_ <= _ -> _ <= _). rewrite <- plus_assoc. apply plus_le_compat_l. apply H1. assert ( S(n + 0) <= n). eapply le_trans. apply H2. apply h2. rewrite <- plus_comm in H3. simpl in H3. assert (forall n, ~(S n <= n)). intro n0; elim n0. intro h7; inversion h7. unfold not; intros. apply H4. apply le_S_n. apply H5. unfold not in H4. eapply H4; apply H3.
         Qed.

        Theorem not_divides_lt:
                forall n m : nat, 0 < m -> m < n -> ~divides n m.
        Proof.
                unfold not.
                intros n m h1 h2 h3.
                unfold divides in h3.
                inversion h3.
                destruct x. simpl in H; rewrite <- H in h1; inversion h1.
                assert (forall x, S x >= S O).
                intros; change (1 + x0 >= 1 + 0). SearchPattern (_ <= _ -> _ <= _). apply plus_le_compat_l; apply le_0_n. assert (S x * n >= 1 * n). apply mult_le_compat_r; apply H0. rewrite -> H in H1; simpl in H1; rewrite plus_comm in H1; simpl in H1. SearchPattern (_ <= _ -> ~ _ < _). assert (~m < n). apply le_not_lt. apply H1. contradiction.
                Qed.
        Lemma le_1_Sn:
                forall x, S x >= S O.
        Proof.
                intro x; elim x. apply le_n. intros n h1; apply le_S; trivial.
        Qed.

        Theorem not_lt_2_divides :
                forall n m : nat, n <> 1 -> n < 2 -> 0 < m -> ~divides n m.
        Proof.
                unfold not; unfold divides; intros n m h1 h2 h3 h4.
                inversion h4. inversion h2. contradiction. inversion H1. rewrite -> H3 in H; rewrite -> mult_comm in H; simpl in H. rewrite <- H in h3; inversion h3. inversion H3.
        Qed.

        Definition le_plus_minus :
               forall n m:nat, le m n -> n = m +(n-m) := le_plus_minus'.

        Theorem lt_lt_or_eq:
                forall n m : nat, n < S m -> n < m \/ n = m.
        Proof.
                intros n m h1.
                unfold lt in h1. assert (n <= m). apply le_S_n. apply h1. inversion H. right;trivial. left; unfold lt. change (1 + n <= 1 + m0). apply plus_le_compat_l. apply H0.
        Qed.

Require Import ZArith.
        Ltac tactic7p2 :=
                match goal with
                | [ |- context [( (xI ?X1))] ] => rewrite (Zpos_xI X1); tactic7p2
                | [ |- context [( (xO ?X2))]] => match X2 with
                | xH => fail 1
                | _ => rewrite (Zpos_xO X2); tactic7p2
                end
                | [ |- _] => idtac
                end.

        Theorem testtactic7p2:
                forall x,Zpos(xI( xO (xO x))) =Zpos (xI( xO (xO x))).
        Proof.
                intros x.
                tactic7p2.
                Check Zpos_xI.
        Abort.


Parameter A B C : Prop.
Lemma AimpA : A -> A.
Proof.
	intro.
	apply H.
Qed.

Lemma imp_trans : (A->B)->(B->C)->A->C.
Proof.
	intros.
	apply H in H1.
	apply H0 in H1.
	apply H1.
Qed.

Lemma and_comm : A /\ B -> B /\ A.
Proof.
	intro.
	destruct H .
	split.
	apply H0.
	apply H.
Qed.

Lemma or_comm : A \/ B -> B \/ A.
Proof.
	intro.
	destruct H.
	right.
	apply H.
	left.
	apply H.
Qed.

(* Using the Print command, print the proofs obtained
for AimpA and imp_trans. What are these terms ? Does it help
understanding why -> is used both for logical implication
and arrow types ? *)
Print AimpA.
Print imp_trans.

Lemma AimpNotA : A -> ~~A.
Proof.
	intro.
	unfold not.
	intros.
	apply H0 in H.
	apply H.
Qed.

Lemma noname : (A \/ B)/\ C -> A /\ C \/ B /\ C.
Proof.
	intro.
	destruct H.
	destruct H.
	left.
	split.
	apply H.
	apply H0.
	right.
	split.
	apply H.
	apply H0.
Qed.

Lemma EMequiv : (forall P:Prop, P \/ ~P) <-> (forall P:Prop, ~~P -> P).
Proof.
	unfold iff.
	split.
	intros.
	destruct H with P.
	apply H1.
	unfold not in H1.
	unfold not in H0.
	apply H0 in H1.
	contradiction.

	intros.
	apply H.
	unfold not.
	intros.
	apply H0.
	right.
	intro.
	apply H0.
	left.
	apply H1.
Qed.

(*Require Import Classical.*)

(* Socrate is a men, all mens are mortal, therefore socrate is mortal *)

Parameter Person:Type.
Parameter Socrate : Person.
Parameter Men Mortal : Person->Prop.

Lemma socrateMortal : Men Socrate /\ (forall P:Person, Men P -> Mortal P) -> Mortal Socrate.
Proof.
	intros.
	destruct H.
	apply H0 in H.
	apply H.
Qed.

(* Drinker's paradox *)

Parameter EM : forall P, ~~ P -> P.

Lemma drinker : exists p:Person, ~ Mortal p -> forall q:Person, ~ (Mortal q).
Proof.
	apply EM.
	intro.
	apply H.
	exists Socrate.
	intros.
	intro.
	apply H.
	exists q.
	intros.
	contradiction.
Qed.

(* Element type *)
Parameter Elt:Type.
(* Binary operator *)
Parameter op : Elt -> Elt -> Elt.
(* Inversion operation *)
Parameter inv : Elt -> Elt.
(* Associativity of op*)
Parameter assoc : forall a b c, op (op a b) c = op a (op b c).
Parameter e:Elt.
(* there exists an identity element *)
Parameter id_l : forall a, op e a = a.
Parameter id_r : forall a, op a e = a.
(* there exists an inverse element *)
Parameter inv_l : forall a, op (inv a) a = e.
Parameter inv_r : forall a, op a (inv a) = e.

Lemma group : forall x y, inv (op x y) = op (inv y) (inv x).
Proof.
	intros.
	transitivity (op (op (inv y) (inv x)) (op (op x y) (inv (op x y)))).
	rewrite assoc.
	rewrite assoc.
	rewrite <- assoc with (a:=inv x) (b:=x).
	rewrite inv_l.
	rewrite id_l.
	rewrite <- assoc with (a:=inv y) (b:=y).
	rewrite inv_l.
	rewrite id_l.
	reflexivity.

	rewrite inv_r.
	rewrite id_r.
	reflexivity.
Qed.


(*
  Verificación Formal - Unam 2020-2
  Ciro Iván García López
  Proyecto 1. Session Type Systems Verification
*)
From PROYI Require Import  Defs_Proposition.

(*
Observación presente en la definición 2.2 (primer parrafo).
*)
Proposition Doble_Duality_ULLT  :
forall A : Proposition ,
(A^⊥)^⊥ = A.
Proof.
  intros.
  induction A; auto.
  - simpl. rewrite -> IHA1. rewrite -> IHA2. reflexivity.
  - simpl. rewrite -> IHA1. rewrite -> IHA2. reflexivity.
  - simpl. rewrite -> IHA. reflexivity.
  - simpl. rewrite -> IHA. reflexivity.
Qed.

(*
Prueba de las propiedades descritas en la definición 2.2.
*)
Proposition Dual_Implication_Tensor :
forall A B : Proposition ,
((A −∘ B)^⊥) = (A ⊗ (B^⊥)).
Proof.
  intros.
  unfold ULLT_IMP.
  simpl.
  rewrite -> (Doble_Duality_ULLT A).
  reflexivity.
Qed.

Proposition Dual_Tensor_Implication :
forall A B : Proposition,
((A ⊗ B )^⊥) = (A −∘ (B^⊥)).
Proof.
  intros.
  simpl.
  unfold ULLT_IMP.
  reflexivity.
Qed.

Proposition Doble_Dual_Implication :
forall A B : Proposition,
(((A −∘ B)^⊥)^⊥) = (A −∘ B).
Proof.
  intros.
  unfold ULLT_IMP.
  rewrite -> (Doble_Duality_ULLT).
  reflexivity.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (z : natural) (y : natural) : natural := plus z (mult z y).


Module map.
Require Import Arith.
Inductive list (X : Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.
 Check nil.
Check (cons nat 2 (nil nat)).

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

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

Arguments nil {_}.
Arguments cons {_} h t.
Check nil.
Check cons.

Fixpoint length'' {X: Type} (l: list X) : nat :=
  match l with
  | nil  => 0
  | cons  h t => S (length' t)
  end.
Example test_length'': length'' (cons 1 nil) = 1.
Proof. simpl. reflexivity. Qed.

Fixpoint app {X: Type} (l1 l2 : list X) : list X :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.
Example test_app1:
  app (cons 1 (cons 2 nil)) (cons 3 nil) = (cons 1 (cons 2 (cons 3 nil))).
 Proof. simpl. reflexivity. Qed.

Fixpoint rev {X: Type} (l: list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.
Example test_rev1:
  rev (cons 1 (cons 2 (cons 3 nil))) =  (cons 3 (cons 2 (cons 1 nil))).
 Proof. simpl. reflexivity. Qed.
Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).
Example test_app2 : (cons 1 (cons 2 (cons 3 nil))) = [1, 2, 3].
 Proof. simpl. reflexivity. Qed.

Fixpoint repeat {X : Type} (n : X) (count : nat) : list X :=
  match count with
  | O => []
  | S c' => n :: (repeat n c')
  end.
Example test_repeat1:
  repeat true 2 = [true, true].
Proof. reflexivity. Qed.

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

Inductive prod (X Y: Type) : Type :=
  pair : X -> Y -> prod X Y.
Check pair.
Check pair _ _ 1 2.
Arguments pair {_} {_} x y.
Check pair.
Check pair 1 [1].
Notation "( x , y )" := (pair x y).
Check (1, 3).
Notation "X * Y" := (prod X Y) : type_scope.
Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with (x,y) => x end.

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

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

Inductive option (X: Type) : Type :=
  | Some : X -> option X
  | None: option X.
Arguments Some {_} x.
Arguments None {_}.
Check Some 2.
Check None.

Definition head {X: Type} (l : list X) : option X :=
  match l with
  | nil => None
  | h::t => Some h
  end.
Example test_head1 : head [2, 4] = Some 2.
Proof. reflexivity. Qed.

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

Fixpoint map {X Y: Type} (f : X -> Y) (l : list X) : list Y :=
  match l with
  | nil => nil
  | x :: t => f x :: (map f t)
  end.
Example test_map1 : map (plus 2) [1, 2, 3] = [3, 4, 5].
Proof. reflexivity. Qed.

Theorem map_assoc : forall (X Y: Type) (f: X -> Y) (l1 l2: list X),
   map f (l1 ++ l2) = (map f l1) ++ (map f l2).
Proof.
  intros X Y f l1 l2.
  induction l1 as [| n l1']. reflexivity.
  simpl. rewrite -> IHl1'. reflexivity. Qed.

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

Fixpoint foldr {X Y : Type} (f : X -> Y -> Y) (l : list X) (b : Y) : Y :=
  match l with
  | nil => b
  | h :: t => f h (foldr f t b)
  end.
Example test_foldr1 : foldr plus [1, 2, 3, 4] 0 = 10.
Proof. reflexivity. Qed.

End map.


Require Export BaseLists Removal.

(**** Cardinality *)

Section Cardinality.
  Variable X : eqType.
  Implicit Types A B : list X.

  Fixpoint card A :=
    match A with
      | nil => 0
      | x::A => if Dec (x el A) then card A else 1 + card A
    end.

  Lemma card_cons x A :
    x el A -> card (x::A) = card A.
  Proof.
    intros H. cbn. decide (x el A) as [H1|H1]; tauto.
  Qed.

  Lemma card_cons' x A :
    ~ x el A -> card (x::A) = 1 + card A.
  Proof.
    intros H. cbn. decide (x el A) as [H1|H1]; tauto.
  Qed.

  Lemma card_in_rem x A :
    x el A -> card A = 1 + card (rem A x).
  Proof.
    intros D.
    induction A as [|y A].
    - contradiction D.
    - decide (y = x) as [->|H].
      + clear D. rewrite rem_fst.
        cbn. decide (x el A) as [H1|H1].
        * auto.
        * now rewrite (rem_id H1).
      + assert (x el A) as H1 by (destruct D; tauto). clear D.
        rewrite (rem_fst' _ H). specialize (IHA H1).
        simpl card at 2.
        decide (y el rem A x) as [H2|H2].
        * rewrite card_cons. exact IHA.
          apply in_rem_iff in H2. intuition.
        * rewrite card_cons'. now rewrite IHA.
          contradict H2.  now apply in_rem_iff.
  Qed.

  Lemma card_not_in_rem A x :
    ~ x el A -> card A = card (rem A x).
  Proof.
    intros D; rewrite rem_id; auto.
  Qed.

  Lemma card_le A B :
    A <<= B -> card A <= card B.
  Proof.
  revert B.
  induction A as [|x A]; intros B D; cbn.
  - omega.
  - apply incl_lcons in D as [D D1].
    decide (x el A) as [E|E].
    + auto.
    + rewrite (card_in_rem D).
      enough (card A <= card (rem B x)) by omega.
      apply IHA. auto.
  Qed.

  Lemma card_eq A B :
    A === B -> card A = card B.
  Proof.
    intros [E F]. apply card_le in E. apply card_le in F. omega.
  Qed.

  Lemma card_cons_rem x A :
    card (x::A) = 1 + card (rem A x).
  Proof.
    rewrite (card_eq (rem_equi x A)). cbn.
    decide (x el rem A x) as [D|D].
    - exfalso. apply in_rem_iff in D; tauto.
    - reflexivity.
  Qed.

  Lemma card_0 A :
    card A = 0 -> A = nil.
  Proof.
    destruct A as [|x A]; intros D.
    - reflexivity.
    - exfalso. rewrite card_cons_rem in D. omega.
  Qed.

  Lemma card_ex A B :
    card A < card B -> exists x, x el B /\ ~ x el A.
  Proof.
    intros D.
    decide (B <<= A) as [E|E].
    - exfalso. apply card_le in E. omega.
    - apply list_exists_not_incl; auto.
  Qed.

  Lemma card_equi A B :
    A <<= B -> card A = card B -> A === B.
  Proof.
    revert B.
    induction A as [|x A]; cbn; intros B D E.
    - symmetry in E. apply card_0 in E. now rewrite E.
    - apply incl_lcons in D as [D D1].
      decide (x el A) as [F|F].
      + rewrite (IHA B); auto.
      + rewrite (IHA (rem B x)).
        * symmetry. apply rem_reorder, D.
        * auto.
        * apply card_in_rem in D. omega.
  Qed.

  Lemma card_lt A B x :
    A <<= B -> x el B -> ~ x el A -> card A < card B.
  Proof.
    intros D E F.
    decide (card A = card B) as [G|G].
    + exfalso. apply F. apply (card_equi D); auto.
    + apply card_le in D. omega.
  Qed.

  Lemma card_or A B :
    A <<= B -> A === B \/ card A < card B.
  Proof.
    intros D.
    decide (card A = card B) as [F|F].
    - left. apply card_equi; auto.
    - right. apply card_le in D. omega.
  Qed.

End Cardinality.

Instance card_equi_proper (X: eqType) :
  Proper (@equi X ==> eq) (@card X).
Proof.
  hnf. apply card_eq.
Qed.


(** * 6.822 Formal Reasoning About Programs, Spring 2021 - Pset 2 *)

Require Import Coq.NArith.NArith. Open Scope N_scope.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Coq.micromega.Lia.
Require Import Frap.Frap.

Module Type S.
  Definition fact: N -> N :=
    recurse by cases
    | 0 => 1
    | n + 1 => (n + 1) * recurse
    end.

  (*[5%]*) Parameter exp: N -> N -> N.
  Axiom test_exp_2_3: exp 2 3 = 8.
  Axiom test_exp_3_2: exp 3 2 = 9.
  Axiom test_exp_4_1: exp 4 1 = 4.
  Axiom test_exp_5_0: exp 5 0 = 1.
  Axiom test_exp_1_3: exp 1 3 = 1.

  Definition seq (f: N -> N): N -> N -> list N :=
    recurse by cases
    | 0 => fun start => []
    | n + 1 => fun start => f start :: recurse (start + 1)
    end.

  Definition ith: N -> list N -> N :=
    recurse by cases
    | 0 => fun (l: list N) => match l with
                              | h :: t => h
                              | nil => 0
                              end
    | i + 1 => fun (l: list N) => match l with
                                  | h :: t => recurse t
                                  | nil => 0
                                  end
    end.

  Fixpoint len(l: list N): N :=
    match l with
    | [] => 0
    | h :: t => 1 + len t
    end.

  (*[12%]*)
  Axiom seq_spec: forall f count i start, i < count -> ith i (seq f count start) = f (start + i).

  (*[12%]*)
  Axiom ith_out_of_bounds_0: forall i l, len l <= i -> ith i l = 0.

  Definition C(n k: N): N := fact n / (fact (n - k) * fact k).

  Definition bcoeff(n: N): N -> N :=
    recurse by cases
    | 0 => 1
    | k + 1 => recurse * (n - k) / (k + 1)
    end.

  (*[7%]*)
  Axiom fact_nonzero: forall n, fact n <> 0.

  (*[7%]*)
  Axiom Cn0: forall n, C n 0 = 1.

  (*[7%]*)
  Axiom Cnn: forall n, C n n = 1.

  (*[25%]*)
  Axiom bcoeff_correct: forall n k, k <= n -> bcoeff n k = C n k.

  Definition Pascal's_rule: Prop := forall n k,
      1 <= k <= n ->
      C (n+1) k = C n (k - 1) + C n k.

  Definition nextLine(l: list N): list N :=
    1 :: seq (fun k => ith (k - 1) l + ith k l) (len l) 1.

  Definition all_coeffs_fast: N -> list N :=
    recurse by cases
    | 0 => [1]
    | n + 1 => nextLine recurse
    end.

  (*[25%]*)
  Axiom all_coeffs_fast_correct:
    Pascal's_rule ->
    forall n k,
      k <= n ->
      ith k (all_coeffs_fast n) = C n k.
End S.


(* ************************************************* *)
(* prop1 and simply typed lambda calculus *)
(* ************************************************* *)

Section prop1.

Parameters A B C : Prop.

(* exercise 1 *)
(* prove the following three lemma's *)
(* also use Print to see the proof-term *)
Lemma one1 : ((A -> B -> A) -> A) -> A.
Proof.
intros. apply H. intros. exact H0.
Qed.

Lemma one2 : (A -> B -> C) -> (A -> B) -> A -> C.
Proof.
intros. apply H. exact H1. apply H0. exact H1.
Qed.

Lemma one3 : (B -> (A -> B) -> C) -> B -> C.
Proof.
intros. apply H. exact H0. intro. exact H0.
Qed.

(* exercise 2 *)
(* give of each of the following three types an inhabitant *)
Definition two1 : (A -> A -> B) -> (C -> A) -> C -> B :=
fun (f : A -> A -> B) (g : C -> A) (c : C) =>
  f (g c) (g c)
  .

Definition two2 : (A -> A -> B) -> A -> B :=
fun (f : A -> A -> B) (a:A) =>
  f a a
  .

Definition two3 : (A -> B -> C) -> B -> A -> C :=
fun (f : A -> B -> C) (b:B) (a:A) =>
  f a b
  .

(* exercise 3 *)
(* complete the following four simply typed lambda terms *)
Definition three1 :=
 fun (x : A -> B -> C) (y : A -> B) (z : A) => x z (y z)
  .

Definition three2 :=
 fun (x : B -> A -> C) (y : A -> B) (z : A) => x (y z) z
  .

Definition three3 :=
 fun (x : (B -> A) -> A -> C) (y : A) => x (fun z : B => y) y
  .

Definition three4 :=
 fun (x : A -> B -> C)
     (y : (A -> B -> C) -> A)
     (z : (A -> B -> C) -> B)
  => x (y x) (z x)
  .

(* exercise 4 *)
(* prove the following two lemma's *)
Lemma four1 : (~A \/ B) -> (A -> B).
Proof.
unfold not. intros. elim H. intros. elimtype False. apply H1. exact H0.
intro H1. exact H1.
Qed.

Lemma four2 : (A \/ ~ A) -> ~~A -> A.
Proof.
unfold not. intros. elim H. intro H1. exact H1.
intro H1. elimtype False. apply H0. exact H1.
Qed.

End prop1.

(* ************************************************* *)
(* pred1 and lambda P *)
(* ************************************************* *)

Section pred1.

Parameter Terms : Set.
Parameters M N : Terms.
Parameters P Q : Terms -> Prop.
Parameters R : Terms -> Terms -> Prop.

(* exercise 5 *)
(* prove the following three lemma's *)
(* use Print to see the proof-term *)
(* see practical work 7 *)
Lemma five1 : (forall x:Terms, ~ (P x)) -> ~ (exists x:Terms, P x).
Proof.
unfold not. intros Hall Hexists. elim Hexists. exact Hall.
Qed.

Lemma five2 : forall x:Terms, (P x -> ~ (forall y:Terms, ~(P y))).
Proof.
unfold not. intros. apply H0 with x. exact H.
Qed.

Lemma five3 :
  (forall x y :Terms, R x y -> ~ (R y x)) ->
  (forall x:Terms, ~ (R x x)).
Proof.
unfold not. intros.
apply H with x x. exact H0. exact H0.
Qed.

(* exercise 6 *)
(* give inhabitants of the following two types *)

Definition six1 :
  (forall x y : Terms, R x y -> R y x) ->
  (forall x   : Terms, R x M -> R M x) :=
fun (f : forall x y : Terms, R x y -> R y x) =>
  fun (x:Terms) (r : R x M) => f x M r
  .

Definition six2 :
  (forall x y z : Terms, R x y -> R y z -> R x z) ->
  R M N ->
  R N M ->
  R M M :=
fun (f:forall x y z : Terms, R x y -> R y z -> R x z)
    (rMN : R M N)
    (rNM : R N M) =>
  f M N M rMN rNM
  .

(* exercise 7 *)
(* complete the following two lambda-terms *)

Definition seven1 :=
  fun (H : forall x:Terms, P x -> Q x) =>
  fun (I : P M) =>
  H M I
  .

Definition seven2 :=
  fun (H : forall x y : Terms, R x y -> R y x) =>
  fun (I : R M N) =>
  H M N I
  .

Definition seven3 :=
  fun (H : Terms -> P M) =>
  fun (I : forall x, P x -> Q x) =>
  I M (H M)
  .

End pred1.

(* ************************************************* *)
(* prop2 and polymorphic lambda calculus *)
(* ************************************************* *)

Section prop2.

(* exercise 8 *)
(* prove the following two lemma's *)
Lemma eight1 : forall a:Prop, a -> forall b:Prop, b -> a.
Proof.
intros. exact H.
Qed.

Lemma eight2 : (forall a:Prop, a) ->
  forall b:Prop, forall c:Prop, ((b->c)->b)->b.
Proof.
intros. apply H0. intro. apply H.
Qed.

(* exercise 9 *)
(* find inhabitants of the following two types *)
Definition nine1 : forall a:Prop, (forall b:Prop, b) -> a :=
fun (a:Prop) (H:forall b:Prop, b) => H a
  .

Definition nine2 : forall a:Prop, a -> (forall b:Prop, ((a -> b) -> b)) :=
fun (a:Prop) (H:a) (b:Prop) (H0:a->b) => H0 H
  .

(* exercise 10 *)
(* complete the following lambda terms *)

Definition ten1 :=
  fun (a:Prop) =>
  fun (x: forall b:Prop, b) =>
  x a
  .

Definition ten2 :=
  fun (a:Prop) =>
  fun (x:a) =>
  fun (b:Prop) =>
  fun (y:b) =>
  x
  .

End prop2.

(* ************************************************* *)
(* inductive datatypes and predicates *)
(* ************************************************* *)

Section inductivetypes.

(* given *)
Fixpoint plus (n m : nat) {struct n} : nat :=
  match n with
  | O => m
  | S p => S (plus p m)
  end.

(* exercise 11 *)
(* prove the following three lemma's *)
Lemma plus_n_O : forall n : nat, n = plus n 0.
Proof.
intro n. induction n.
simpl. reflexivity.
simpl. rewrite <- IHn. reflexivity.
Qed.

Lemma plus_n_S : forall n m : nat, S (plus n m) = plus n (S m).
Proof.
intros n m. induction n.
simpl. reflexivity.
simpl. rewrite <- IHn. reflexivity.
Qed.

Lemma com : forall n m : nat, plus n m = plus m n.
Proof.
induction n. induction m. simpl. reflexivity.
simpl. rewrite <- IHm. simpl. reflexivity.
induction m. simpl. rewrite -> IHn. simpl. reflexivity.
simpl. rewrite IHn. rewrite <- IHm. simpl. rewrite -> IHn. reflexivity.
Qed.

(* given *)
Inductive polybintree (X : Set) : Set :=
    polyleaf : X -> polybintree X
  | polynode : polybintree X -> polybintree X -> polybintree X.

(* exercise 12 *)
(* give a definition counttree that counts the number of leafs *)

Fixpoint counttree (X : Set) (b : polybintree X) {struct b} : nat :=
  match b with
  | polyleaf _ => O
  | polynode l r => plus (counttree X l) (counttree X r)
  end
  .

(* exercise 13 *)
(* give a definition sum that adds the values on the leafs
   for a tree with natural numbers on the leafs *)

Fixpoint sum (b:polybintree nat) {struct b} : nat :=
  match b with
  | polyleaf x => x
  | polynode l r => plus (sum l) (sum r)
  end
  .

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

(* given *)
Definition andb (b1 b2:bool) : bool := ifb b1 b2 false.

(* exercise 14 *)
(* give a definition and that computes the conjunction
   of the values of all leafs where all leafs have a
   boolean label
   use andb for conjunction on booleans *)

Fixpoint conjunction (t : polybintree bool) {struct t} : bool :=
  match t with
  | polyleaf b => b
  | polynode l r => andb (conjunction l) (conjunction r)
  end
  .

End inductivetypes.

(*
vim: filetype=coq
*)


(** 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) (y : natural) : natural := mult (Succ y) z.


(** 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 (lf2 : natural) (y : natural) (lf1 : natural) : natural :=
  plus lf2 lf1.


(* https://coq-math-problems.github.io/Problem1/ *)

Require Import PeanoNat.

Require Import Hack.CMP.Decr.
Require Import Hack.CMP.Bounded.
Require Hack.CMP.Arith.

(* The solution was first prototyped in OCaml in p1.ml, and
   the Coq proof work the same way, by noticing that either:
   - the valley continues,
   - the function from there on has a lower bound, and if not,
   - we've eventually reached a bound of 0 *)

Definition eventually_bounded_by_at (f: nat -> nat) (n: nat) (x: nat)
  := forall y, x <= y -> f y <= n.
Definition eventually_bounded_by (f: nat -> nat) (n: nat)
  := exists x, eventually_bounded_by_at f n x.
Definition eventually_bounded (f: nat -> nat)
  := exists n, eventually_bounded_by f n.

Theorem bounded_is_eventually_bounded: forall f, bounded f -> eventually_bounded f.
Proof.
  intros.
  destruct H as [b pb].
  refine (ex_intro _ b _).
  refine (ex_intro _ 0 _).
  unfold eventually_bounded_by_at.
  intros.
  exact (pb y).
Qed.

Definition valley (f: nat -> nat)(n x : nat) :=
  forall y, (x <= y) -> (y <= x+n) -> f y = f x.

Lemma eventually_bounded_by_0:
  forall f,
  eventually_bounded_by f 0 ->
  forall n, exists x, valley f n x.
Proof.
  intros.
  destruct H as [x px].
  refine (ex_intro _ x _).
  unfold valley.
  intros.
  transitivity 0.
  - exact (proj1 (Nat.le_0_r _) (px y H)).
  - symmetry.
    exact (proj1 (Nat.le_0_r _) (px x (le_n x))).
Qed.

Lemma valley_continues_or_bound_decreases:
  forall f n x m,
  decr f ->
  f x = m -> valley f n x ->
  valley f (S n) x \/ (eventually_bounded_by f (pred m)).
Proof.
  intros.
  case (Nat.eq_dec (f (x + S n)) m).
  + intro.
    left.
    unfold valley.
    intros y G0 G1.
    assert (x + S n = S (x + n)). { apply eq_sym; trivial. }
    rewrite H2 in G1.
    case (Arith.leq_and_not _ _ G1).
    - intro.
      rewrite H3.
      rewrite <- H2.
      transitivity m.
      * assumption.
      * symmetry.
        assumption.
    - intro.
      exact (H1 _ G0 H3).
  + intro.
    right.
    refine (ex_intro _ (x + S n) _).
    intros y H2.
    pose (p := H1 (x + n) (Nat.le_add_r _ _) (le_n _)).
    rewrite H0 in p.
    pose (q := decr_estimate _ H _ _ (proj1 (Nat.add_le_mono_l _ _ x) (le_S n n (le_n _)))).
    rewrite p in q.
    exact (Nat.le_trans _ _ _ (decr_estimate _ H _ _ H2) (Arith.leq_and_not'' _ _ q n0)).
Qed.

Lemma decr_and_eventually_bounded_by:
  forall f n m x,
  decr f ->
  eventually_bounded_by_at f (S m) x ->
  valley f n x \/ (eventually_bounded_by f m).
Proof.
  intro f.
  induction n.
  + intros.
    left.
    unfold valley.
    intros y H1 H2.
    assert (x = y).
    - rewrite <- plus_n_O in H2.
      exact (Nat.le_antisymm _ _ H1 H2).
    - rewrite H3.
      reflexivity.
  + intros m x D pb.
    case (IHn m x D pb).
    - intro.
      case (valley_continues_or_bound_decreases f n x (f x) D eq_refl H).
      * apply or_introl.
      * intros H1.
        right.
        destruct H1 as [x0 px0].
        refine (ex_intro _ x0 _).
        intros y H1.
        exact (Nat.le_trans _ _ _ (px0 y H1) (Nat.pred_le_mono _ _ (pb x (le_n _)))).
    - apply or_intror.
Qed.

Lemma decr_valleys_lemma:
  forall m f,
  eventually_bounded_by f m -> decr f ->
  forall n, exists x, valley f n x.
Proof.
  induction m.
  + intros f eB0 D.
    exact (eventually_bounded_by_0 f eB0).
  + intros f eBSM D n.
    destruct eBSM as [x pb].
    case (decr_and_eventually_bounded_by f n m x D pb).
    - intro.
      refine (ex_intro _ x _).
      assumption.
    - intro eBM.
      exact (IHm f eBM D n).
Qed.

Theorem decr_valleys: forall n f, decr f -> exists x, valley f n x.
Proof.
  intros.
  destruct (bounded_is_eventually_bounded f (decr_is_bounded f H)) as [b pb].
  exact (decr_valleys_lemma b f pb H n).
Qed.


(* Add some trivial facts about nats to the auto hint database,
   so we don't have to use omega as much. *)
Require Import Iron.Tactics.

Lemma nat_eq_cases
 :  forall (n m : nat)
 ,  n = m \/ ~(n = m).
Proof. intros. omega. Qed.
Hint Resolve nat_eq_cases.

Lemma nat_zero_le_all
 : forall n, 0 <= n.
Proof.
 intros. omega.
Qed.
Hint Resolve nat_zero_le_all.

Lemma nat_zero_lt_succ
 : forall n, 0 < S n.
Proof.
 intros. omega.
Qed.
Hint Resolve nat_zero_lt_succ.

(* Don't add transitivity lemmas to the hints database as it
   can severley degrade performance. *)
Lemma nat_trans_le
 : forall a b c
 , a <= b -> b <= c -> a <= c.
Proof.
 intros. omega.
Qed.

(* Normalise naturals to use successor representation instead
   of addition. *)
Lemma nat_plus_zero
 : forall n, n + 0 = n.
Proof. auto. Qed.
Hint Rewrite nat_plus_zero : global.

Lemma nat_zero_plus
 :  forall n, 0 + n = n.
Proof. auto. Qed.
Hint Rewrite nat_zero_plus : global.

Lemma nat_minus_zero
 : forall n, n - 0 = n.
Proof. intros. omega. Qed.
Hint Rewrite nat_minus_zero : global.

Lemma nat_plus_one
 : forall n, n + 1 = S n.
Proof. intros. omega. Qed.

(* Tactics **********************************************************)
(* Normalise naturals. *)
Tactic Notation "norm_nat"
 := first
    [ rewrite nat_plus_zero
    | rewrite nat_minus_zero
    | rewrite nat_plus_one ].

(* Convert boolean (in)equalities *)
Ltac eqs_beq_nat
 := repeat match goal with
    | [ H : true = beq_nat ?n ?m |- _]
    => symmetry in H; apply beq_nat_true in H

    | [H : false = beq_nat ?n ?m |- _]
    => symmetry in H; apply beq_nat_false in H
    end.

(* Break on boolean equality *)
Ltac break_beq_nat
 := match goal with
     |  [ |- context [beq_nat ?n ?m] ]
     => let X := fresh in remember (beq_nat n m) as X; destruct X
    end; eqs_beq_nat.


Inductive sign : Type :=
  | pos : sign
  | neg : sign.

Record rational : Type :=
  { direction   : sign
  ; numerator   : nat
  ; denominator : nat (* The /predecesor/ of the denominator, to avoid division by zero *)
  }.

Definition reduce_rational (x:rational) : rational :=
  match x with
  | {| direction   := s
     ; numerator   := n
     ; denominator := d
     |} => let    gcf := Nat.gcd n (S d)
           in let n'  := Nat.div n gcf
           in let d'  := Nat.pred (Nat.div (S d) gcf)
           in {| direction   := s
               ; numerator   := n'
               ; denominator := d'
               |}
  end.

(* what does 2/4 reduce to? *)
Eval compute in (reduce_rational {| direction := pos; numerator := 2; denominator := 3 |}).

(* Equality via simplification of factors *)
Definition eq_rational (x y : rational) : Prop :=
  match x,y with
  | {| numerator   := 0
     ; denominator := 0
     |}
  , {| numerator   := 0
     ; denominator := 0
     |} => True (* if both numbers are 0/1 *)
  | _,_ => match reduce_rational x, reduce_rational y with
           | {| direction   := s1
              ; numerator   := n1
              ; denominator := d1
              |}
           , {| direction   := s2
              ; numerator   := n2
              ; denominator := d2
              |} => s1 = s2 /\ n1 = n2 /\ d1 = d2
           end
  end.

(* does 1/2 = 2/4? *)
Eval compute in (eq_rational {| direction := pos; numerator := 1; denominator := 1 |}
                             {| direction := pos; numerator := 2; denominator := 3 |}).


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

Lemma dist_n_0 : forall n,
  dist n 0 = n.
Proof.
  destruct n; reflexivity.
Qed.

Lemma dist_sym : forall m n,
  dist m n = dist n m.
Proof.
  induction m; intro n.
  - simpl.
    symmetry; apply dist_n_0.
  - simpl.
    destruct n.
    + reflexivity.
    + apply IHm.
Qed.


(* BEGIN FIX *)
Inductive AExp : Type :=
| ALit (n : nat)
| APlus (a1 a2 : AExp)
| ASub (a1 a2 : AExp)
(* END FIX *)
| AMul (a1 a2 : AExp)
.

(* BEGIN FIX *)
Fixpoint aeval (a : AExp) : nat :=
match a with
 | ALit n => n
 | APlus a1 a2 => aeval a1 + aeval a2
 | ASub a1 a2 => aeval a1 - aeval a2
(* END FIX *)
 | AMul a1 a2 => aeval a1 * aeval a2
end.

(* BEGIN FIX *)
Example aeval_test1 : forall n : nat, aeval (ALit n) = n.
Proof. reflexivity. Qed.
(* END FIX *)

(* BEGIN FIX *)
Example aeval_test2 : forall n m : nat, aeval (APlus (ALit n) (ALit m)) = n + m.
Proof. reflexivity. Qed.
(* END FIX *)

(* Irj egy tesztet a szorzasra az osszeadas mintajara *)
Example aeval_test3 : forall n m : nat, aeval (AMul (ALit n) (ALit m)) = n * m.
Proof.
  reflexivity.
Qed.


Require Export Poly.

Theorem double_injective':
  forall n m, double n = double m -> n = m.
Proof.
  intros n.
  induction n as [|n'].
  Case "n = 0". simpl. intros m eq.
  destruct m as [|m'].
  SCase "m = 0". reflexivity.
  SCase "m = S m'". inversion eq.
  Case "n = S n'".
  intros m eq.
  destruct m as [|m'].
  SCase "m = 0".
  inversion eq.
  SCase "m = S m'".
  assert (n' = m') as H.
  SSCase "Proof os assertion".
  apply IHn'.
  inversion eq. reflexivity.
  rewrite -> H. reflexivity.
Qed.

Theorem double_injective_take2:
  forall n m, double n = double m -> n = m.
Proof.
  intros n m.
  generalize dependent n.
  induction m as [|m'].
  Case "m=0". simpl. intros n eq. destruct n as [|n'].
  SCase "n=0". reflexivity.
  SCase "n= S n'". inversion eq.
  Case "m= S m'". intros n eq.
  destruct n as [|n'].
  SCase "n = 0". inversion eq.
  SCase "n = S n'".
  assert (n' = m') as H.
  SSCase "Proof of assertion".
  apply IHm'.
  inversion eq.
  reflexivity.
  inversion H.
  reflexivity.
Qed.

Theorem plus_n_n_injective_take2:
  forall n m, n + n = m + m -> n = m.
Proof.
  intros.
  generalize dependent n.
  induction m as [|m'].
  Case "m=0".
  destruct n as [|n'].
  SCase "n=0". reflexivity.
  SCase "n=S n'". intro. inversion H.
  Case "m=S m'".
  intros.
  destruct n as [|n'].
  SCase "n = 0".    inversion H.
  SCase "n = S n'".
  rewrite <- plus_n_Sm in H.
  rewrite <- plus_n_Sm in H.
  apply eq_remove_S.
  apply IHm'.
  inversion H.
  reflexivity.
Qed.

Theorem index_after_last:
  forall (n:nat) (X:Type) (l :list X), length l = n -> index (S n) l = None.
Proof.
  intros.
  generalize dependent n.
  induction l as [|l0 l'].
  Case "l=[]".
  simpl. intros. reflexivity.
  Case "l=l0:l'".
  simpl. intros.
  rewrite <- H.
  apply IHl'.
  reflexivity.
Qed.

Theorem length_snoc''':
  forall (n : nat) (X : Type) (v : X) (l : list X),
    length l = n -> length (snoc l v) = S n.
Proof.
  intros.
  generalize dependent n.
  induction l as [| l0 l'].
  Case "l=[]".
  simpl. intros. rewrite <- H. reflexivity.
  Case "l=l0::l'".
  simpl. intros. apply eq_remove_S in H. rewrite <- H.
  apply eq_remove_S.
  apply IHl'.
  reflexivity.
Qed.

Theorem app_length_cons:
  forall (X:Type) (l1 l2:list X) (x : X) (n : nat),
    length (l1 ++ (x :: l2)) = n -> S (length (l1 ++ l2)) = n.
Proof.
  intros.
  generalize dependent n.
  generalize dependent l2.
  induction l1 as [|n0 l1'].
  Case "l1=[]".
  simpl. intros. apply H.
  Case "l1=n0 l1'".
  simpl. intros. rewrite <- H.
  apply eq_remove_S. apply IHl1'.
  reflexivity.
Qed.

Theorem app_length_twice:
  forall (X:Type) (n:nat) (l:list X),
    length l = n -> length (l ++ l) = n + n.
Proof.
  intros.
  generalize dependent n.
  induction l as [|n0 l'].
  Case "l=[]".
  simpl. intros. rewrite <- H. reflexivity.
  Case "l=n0:l'".
  intros. destruct n.
  SCase "n = 0".
  inversion H.
  SCase "n = S n'".
  simpl.
  remember (length (l' ++ n0 :: l')) as nn.
  symmetry in Heqnn.
  apply app_length_cons in Heqnn.
  rewrite <- Heqnn.
  rewrite <- plus_n_Sm.
  assert (length (l' ++ l') = n + n) as H1.
  inversion H.
  apply IHl'. reflexivity.
  rewrite H1.
  reflexivity.
Qed.