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

Check 3 = 3: Prop.

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

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

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

Check @eq : forall A : Type, A -> A -> Prop.

Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  split.
  - reflexivity.
  - reflexivity.
Qed.

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

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

Example and_exercise : forall n m : nat , n + m = 0 -> n= 0 /\ m = 0.
Proof.
 split.
 - destruct n.
  + reflexivity.
  + discriminate H.
 - destruct m.
  + reflexivity.
  + rewrite <- plus_n_Sm in H. discriminate.
Qed
.

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

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

Example add_example3:
  forall n m : nat, n + m = 0 -> n * m = 0.
Proof.
  intros n m H.
  apply and_exercise in H.
  destruct H as [Hn Hm]  .
  rewrite Hn.
  reflexivity.
Qed.

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

Lemma proj2: forall P Q : Prop, P /\ Q -> Q.
Proof.
  intros P Q HPQ.
  destruct HPQ as [_ HP].
  apply HP.
  Qed
.

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

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

(* A /\ B is a syntactic sugar for and A B. *)
Check and : Prop -> Prop -> Prop.

Lemma eq_mult_0 : forall n m : nat, n = 0 \/ m = 0 -> n * m = 0.
Proof.
  intros n m [Hn | Hm].
  - rewrite Hn. reflexivity.
  - rewrite Hm. rewrite <- mult_n_O. reflexivity.
Qed.

Lemma or_intro_l : forall A B : Prop, A -> A \/ B.
Proof.
  intros A B HA.
  left.
  apply HA.
Qed
.
Lemma or_intro_r : forall A B : Prop, B -> A \/ B.
Proof.
  intros A B HB.
  right.
  apply HB.
Qed
.

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

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

Theorem ex_falso_eudlibet : forall P : Prop,
  False -> P.
Proof.
  intros P contra.
  destruct contra.
Qed.

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

Notation "x <> y" := (~ (x = y)).

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

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

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

Theorem double_neg : forall P : Prop,
  P -> ~~P.
Proof.
  intros P H. unfold not. intros G. apply G. apply H. Qed
.

Theorem contrapositive : forall P Q : Prop,
  (P -> Q) -> (~ Q -> ~ P).
Proof.
  intros P Q HPQ.
  unfold not. intros HQ. intros HP.
  apply HQ. apply HPQ. apply HP.
Qed
.

Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
  intros P. unfold not. intros [HP HNP]. apply HNP. apply HP.
Qed
.

Theorem not_true_is_false : forall b : bool,
  b <> true -> b = false.
Proof.
  intros b H.
  destruct b eqn: HE.
  - unfold not in H.
    apply ex_falso_eudlibet. (* exfalso . *)
    apply H. reflexivity.
  - reflexivity.
Qed
.

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

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

Module MyIff.
Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P).
Notation "P <-> Q" := (iff P Q)
  (at level 95, no associativity) : type_scope.
End MyIff.

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

Lemma not_true_iff_false : forall b, b <> true <-> b = false.
Proof.
  intros b. split.
  - apply not_true_is_false.
  - intros H. rewrite H. intros H'. discriminate H'.
Qed.

Theorem or_distribute_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R. split.
  - intros [H1|[H2 H3]].
    + split.
      * left. apply H1.
      * left. apply H1.
    + split.
      * right. apply H2.
      * right. apply H3.
  - intros [[] []].
   + left. apply H.
   + left. apply H.
   + left. apply H0.
   + right. split.
    * apply H.
    * apply H0.
Qed.

Theorem and_distribute_over_or : forall P Q R : Prop,
  P /\ (Q \/ R) <-> (P /\ Q) \/ (P /\ R).
Proof.
  intros P Q R. split.
  - intros [H1 [H2|H3]].
    + left. split.
      * apply H1.
      * apply H2.
    + right. split.
      * apply H1.
      * apply H3.
  - intros [[H1 H2]|[H1 H2]].
   + split.
    * apply H1.
    * left. apply H2.
   + split.
    * apply H1.
    * right. apply H2.
Qed.

(* Setoids and Logical Equivalence *)
From Coq Require Import Setoids.Setoid. (* allows to use rewrite and reflexivity with iff statements, not just equalities. *)

Theorem mult_eq_0 : forall n m , n * m = 0 -> n = 0 \/ m = 0.
Proof. intros [] [] H.
  - right. reflexivity.
  - left. reflexivity.
  - right. reflexivity.
  - simpl in H. discriminate H.
Qed
.

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

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

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

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

(* Existential Quantification *)
Definition Even x := exists n : nat, x = double n.

Lemma four_is_even : Even 4.
Proof.
  unfold Even. exists 2. reflexivity.
Qed.

Theorem exists_example : forall n,
  (exists m, n = 4 + m) -> (exists o, n = 2 + o).
Proof.
  intros n [m Hm].
  exists (2 + m).
  apply Hm.
Qed.

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

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

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

Example In_example_1 : In 4 [1; 2; 3; 4; 5].
Proof.
  simpl. right. right. right. left. reflexivity.
Qed.
Example In_example_2 :
  forall n, In n [2; 4] ->
  exists n', n = 2 * n'.
Proof.
  simpl.
  intros n [H | [H | []]].
  - exists 1. rewrite <- H. reflexivity.
  - exists 2. rewrite <- H. reflexivity.
Qed.

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

Check or_intro_r : forall A B : Prop, B -> A \/ B.

Theorem In_map_iff : forall A B (f : A -> B) (l : list A) (y : B),
  In y (map f l) <-> exists x, f x = y /\ In x l.
Proof.
  intros A B f l y. induction l as [|x l IHl].
  - simpl. split.
    + intros [].
    + intros [_ [_ []]].
  - simpl. split.
    + intros [H1|H2].
      * exists x. split.
        ** apply H1.
        ** left. reflexivity.
      * apply IHl in H2. destruct H2 as [x' [H1 H2]].
        exists x'. split.
        ** apply H1.
        ** right. apply H2.
    + intros [x' [H1 [H2|H2]]].
      * left. rewrite H2. apply H1.
      * right. rewrite IHl. exists x'. split.
        ** apply H1.
        ** apply H2.
Qed.

Theorem In_app_iff : forall A l l' (a : A),
  In a (l ++ l') <-> In a l \/ In a l'.
Proof.
  intros A l. induction l as [| a' l' IH].
  - simpl. split.
    + intros H. right. apply H.
    + intros [[]|H].
      apply H.
  - intros l1 a. simpl. rewrite IH. apply or_assoc.
Qed
.

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

Theorem All_In :
  forall T (P : T -> Prop) (l : list T),
    (forall x, In x l -> P x) <-> All P l.
Proof.
  intros T P l. split.
  - intros H. induction l as [|h t IHl].
    + reflexivity.
    + simpl. split.
      * apply H. simpl. left. reflexivity.
      * apply IHl. intro H1. intro H2. apply H. simpl. right. apply H2.
  - (* <- *)intros HA x H. generalize dependent l. induction l as [|h t IH].
    + simpl. intros. destruct H.
    + simpl. intros [H1 H2]. intros [H3|H4].
      * rewrite <- H3. apply H1.
      * apply IH.
        ** apply H2.
        ** apply H4.
Qed
.

(* Exercise: 2 stars, standard, optional (combine_odd_even) *)
Definition combine_odd_even (Podd Peven : nat -> Prop) : nat -> Prop
  . Abort.

  (* TODO: solve the exercise. *)

(* Applying Theorems to Arguments *)

(* Proofs are first-class objects in Coq. *)

Check add_comm : forall n m : nat, n + m = m + n.
(* The type of the proof object is the proposition which it is a proof of. *)

Lemma add_comm3 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z. (* x + (y + z) *)
  rewrite add_comm. (* y + z + x *)
  rewrite (add_comm y z). (* z + y + x. Proofs can be applied *)
  reflexivity.
Qed.

Theorem in_not_nil :
  forall A (x : A) (l : list A), In x l -> l <> [].
Proof.
  intros A x l H. unfold not. intros Hl.
  rewrite Hl in H. simpl in H. apply H.
Qed.

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

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

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

Lemma in_not_nil_42_take5 :
  forall l : list nat , In 42 l -> l <> [].
Proof.
  intros l H.
  apply (in_not_nil _ _ _ H). (* Use theorem as a function to map H and apply the returned value (Prop). *)
Qed.

Check proj1 : forall P Q : Prop, P /\ Q -> P.

Definition mult_n_0 := mult_n_O.

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

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

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

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

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

(* Prints Axioms theorems rely on. *)
Print Assumptions function_equality_ex2.

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

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

Lemma rev_append_const : forall X (l1 l2 : list X),
  rev_append l1 l2 = rev_append l1 [] ++ l2.
Proof.
  intros X.
  induction l1.
  - intros l2. reflexivity.
  - intros l2. simpl. rewrite IHl1. symmetry. rewrite IHl1.
    rewrite <- app_assoc. reflexivity.
Qed.

Theorem tr_rev_correct : forall X, @tr_rev X = @rev X.
Proof.
  intros X.
  apply functional_extensionality.
  induction x as [| h x' IHx].
  - reflexivity.
  - simpl. rewrite <- IHx. unfold tr_rev. simpl.
    (* rev_append x' [h] = rev_append x' [] ++ [h] *)
    apply rev_append_const.
Qed.

Lemma even_double : forall k, even (double k) = true.
Proof.
  induction k as [|k' IHk'].
  - reflexivity.
  - simpl. apply IHk'.
Qed.

Lemma even_double_conv : forall n : nat, exists k : nat,
 n = if even n then double k else S (double k).
Proof.
  induction n as [|n' IHn].
  - exists 0. reflexivity.
  - destruct (even n') eqn:E.
    + (* n' is Even *) destruct IHn as [k IHn].
      exists k. rewrite even_S. rewrite E. simpl. rewrite IHn. reflexivity.
    + (* n' is odd *) destruct IHn as [k IHn].
      exists (S k). rewrite even_S. rewrite E. simpl. rewrite IHn. reflexivity.
Qed.

Theorem even_bool_prop : forall n,
  even n = true <-> Even n.
Proof.
  intros n. split.
  - intros H. destruct (even_double_conv n) as[k Hk].
    rewrite H in Hk. rewrite Hk. exists k. reflexivity.
  - intros [k H]. rewrite H. apply even_double.
Qed.

Search eqb.

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

Example not_even_1001 : even 1001 = false.
Proof.
  reflexivity.
Qed.

Example not_even_1001' : ~ (Even 1001).
Proof.
  rewrite <- even_bool_prop.
  unfold not.
  simpl.
  intros H.
  discriminate H.
Qed.

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

(*
Note the complementary strengths of booleans and general propositions. Being able to cross back and forth between the boolean and propositional worlds will often be conveninent.
*)

Theorem andb_true_iff : forall b1 b2: bool,
  b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof.
  split.
  - intros H. destruct b1.
    + split.
      * reflexivity.
      * destruct b2.
        ** reflexivity.
        ** simpl in H. apply H.
    + split.
      * simpl in H. apply H.
      * simpl in H. discriminate H.
  - intros [H1 H2]. rewrite H1. rewrite H2. reflexivity.
Qed.

Theorem orb_true_iff : forall b1 b2,
  b1 || b2 = true <-> b1 = true \/ b2 = true.
Proof.
  split.
  - intros H. destruct b1.
    + left. reflexivity.
    + simpl in H. right. apply H.
  - intros [H|H].
    + rewrite H. reflexivity.
    + rewrite H. destruct b1.
      * reflexivity.
      * reflexivity.
Qed.

Check not_true_iff_false : forall b : bool, b <> true <-> b = false.

Theorem eqb_neq : forall x y : nat,
  x =? y = false <-> x <> y.
Proof.
  split.
  - intros H. rewrite <- not_true_iff_false in H. unfold not in H. unfold not. intros H2. apply H. rewrite eqb_eq. apply H2.
  - intros H. rewrite <- not_true_iff_false. unfold not in H. unfold not. intros H2. apply H. rewrite eqb_eq in H2. apply H2.
Qed.

Fixpoint eqb_list {A : Type} (eqb : A -> A -> bool)
  (l1 l2 : list A) : bool :=
  match l1, l2 with
  | nil, nil => true
  | nil, _ => false
  | _, nil => false
  | h1::l1', h2::l2' => if eqb h1 h2 then eqb_list eqb l1' l2' else false
    end
.

Theorem eqb_list_true_iff :
  forall A (eqb : A -> A -> bool),
    (forall a1 a2, eqb a1 a2 = true <-> a1 = a2)
    -> forall l1 l2, eqb_list eqb l1 l2 = true <-> l1 = l2.
Proof.
  intros A eqb H. induction l1 as [| n1 l1' IHl1].
  - simpl. split.
    + destruct l2.
      * reflexivity.
      * discriminate.
    + intro H2. rewrite <- H2. reflexivity.
  - split.
    + simpl. destruct l2 as [|n2 l2'].
      * discriminate.
      * destruct (eqb n1 n2) eqn:E.
        ** intros H2. apply H in E. rewrite E. rewrite IHl1 in H2. rewrite H2. reflexivity.
        ** discriminate.
    + intros H2. rewrite <- H2. simpl. assert (E: eqb n1 n1 = true). {
      rewrite H. reflexivity.
    }
      rewrite E. rewrite IHl1. reflexivity.
Qed.

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

Theorem forallb_true_iff : forall X test (l : list X),
  forallb test l = true <-> All (fun x => test x = true) l.
Proof.
  induction l as [|n l' IHl].
  - split.
    + reflexivity.
    + reflexivity.
  - simpl. rewrite andb_true_iff. rewrite IHl. reflexivity.
Qed.

(** Classicla vs. Constructive Logic **)

Definition excluded_middle := forall P : Prop,
  P \/ ~ P. (* Not provable !! *)

(* If P is reflected to some boolean term b... *)
Theorem restricted_excluded_middle : forall P b,
  (P <-> b = true) -> P \/ ~ P.
Proof.
  intros P [] H.
  - left. rewrite H. reflexivity.
  - right. rewrite H. discriminate.
Qed.

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

(* In Coq, existential conditions are constructive. i.e. For exists x, P x, it's always possible to exhibit a value of x for which we can prove P x.
Such logics are referred to as constructive logics.

Move conventional logical systems such as ZFC, in which the excluded middle does hold for arbitrary propositions, are referred to as classical.
*)

(*
~( P \/ ~P )
( ~P \/ ~~P )

*)
Theorem excluded_middle_irrefutable : forall (P : Prop),
  ~ ~ (P \/ ~ P).
Proof.
  unfold not. intros P H.
  assert (HP: P -> False). {
    intro H2.
    apply H.
    left.
    apply H2.
  }
  apply H. right. apply HP.
Qed.

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

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

Theorem excluded_middle_peirce : excluded_middle -> peirce.
Proof.
  unfold excluded_middle, peirce.
  intros EM P Q H.
  destruct (EM P) as [HP|HP].
  - apply HP.
  - apply H. intros P2. exfalso. apply HP. apply P2.
Qed.

Theorem peirce_double_negation_elimination : peirce -> double_negation_elimination.
Proof.
  unfold peirce, double_negation_elimination, not.
  intros HP P NNP.
  apply (HP P False). intros H. destruct (NNP H).
Qed.

Theorem double_negation_elimination_de_morgan_not_and_not : double_negation_elimination -> de_morgan_not_and_not.
Proof.
  unfold double_negation_elimination, de_morgan_not_and_not, not.
  intros HP P Q H. apply HP. intros HPQ. apply H. split.
  - intros P2. apply HPQ. left. apply P2.
  - intros Q2. apply HPQ. right. apply Q2.
Qed.

Theorem de_morgan_not_and_not_implies_to_or : de_morgan_not_and_not -> implies_to_or.
Proof.
  unfold de_morgan_not_and_not, implies_to_or, not.
  intros HP P Q HPQ. apply HP. intros [H1 H2]. apply H1. intro P2.
  apply H2, HPQ, P2.
Qed.

Lemma or_symmetry : forall A B : Prop, A \/ B <-> B \/ A.
Proof.
  split.
  - intros [HA|HB].
    + right. apply HA.
    + left. apply HB.
  - intros [HB|HA].
    + right. apply HB.
    + left. apply HA.
Qed.

Theorem implies_to_or_excluded_middle : implies_to_or -> excluded_middle.
Proof.
  unfold implies_to_or, excluded_middle, not.
  intros HP P. rewrite or_symmetry. apply HP. intro P2. apply P2.
Qed.


Require Import Coq.Arith.PeanoNat.
Require Import Lia.
Require Import Psatz.

Definition divides(a b:nat) := {k:nat & a * k = b}.
Definition isPrime(n:nat) := forall a b:nat, (divides n (a * b)) -> ((divides n a)+(divides n b)).

Definition add_comm
     : forall n m : nat, n + m = m + n.
intro n.
destruct n.
all: intro m.
2: generalize n; clear n.
all: induction m.
reflexivity.
simpl.
rewrite <- IHm.
simpl; reflexivity.
simpl.
induction n.
reflexivity.
simpl.
rewrite IHn.
reflexivity.
intro n.
simpl.
rewrite <- IHm.
simpl.
induction n.
simpl.
reflexivity.
rewrite IHm.
simpl.
rewrite IHn.
rewrite <- IHm.
simpl.
reflexivity.
Defined.

Lemma add_comm_assoc : forall a b c:nat, (a + (b + c)) = (b + (a + c)).
intro a.
induction a.
all: simpl; try reflexivity.
intros b c.
rewrite (add_comm b (S _)).
simpl.
rewrite <- (add_comm b (_ + _)).
rewrite IHa.
reflexivity.
Defined.

Lemma add_assoc : forall a b c:nat, (a + (b + c)) = a + b + c.
intro a.
induction a.
all: simpl; try reflexivity.
intros b c.
rewrite IHa.
reflexivity.
Defined.

Definition mul_comm
     : forall n m : nat, n * m = m * n.
intro n.
destruct n.
all: intro m.
2: generalize n; clear n.
all: induction m.
reflexivity.
simpl.
rewrite <- IHm.
simpl; reflexivity.
simpl.
induction n.
reflexivity.
simpl.
apply IHn.
intro n.
transitivity ((S n * m) + (S n)).
2: transitivity ((m * (S n)) + (S n)).
2: rewrite IHm; reflexivity.
all: simpl.
all: repeat rewrite (add_comm _ (S _)).
all: simpl.
2:reflexivity.
induction n.
all: simpl.
reflexivity.
repeat rewrite (add_comm _ (S _)).
rewrite IHn.
repeat rewrite (add_comm _ (S _)).
simpl.
rewrite (add_comm _ m).
rewrite add_comm_assoc.
reflexivity.
Defined.

Inductive Even : nat -> Type :=
|EO : Even 0
|ES : forall n:nat, Odd n -> Even (S n)
with Odd : nat -> Type :=
|OS : forall n:nat, Even n -> Odd (S n).

Fixpoint twoDividesEven1(n:nat)(H:Even n) : (divides 2 n) :=
match H with
 | EO => existT (fun k : nat => 2 * k = 0) 0 eq_refl
 | ES n0 o =>
     match o with
     | OS n1 e =>
         let (x, e0) := twoDividesEven1 n1 e in
         existT (fun k : nat => 2 * k = S (S n1)) (S x)
           (eq_ind_r (fun n2 : nat => n2 = S (S n1))
              (eq_ind_r (fun n2 : nat => S (S n2) = S (S n1))
                 (eq_ind_r (fun n2 : nat => S (S n2) = S (S n1)) eq_refl e0) (mul_comm x 2))
              (mul_comm 2 (S x)))
     end
 end.

Fixpoint twoDividesEven2(n:nat)(H:divides 2 n) : (Even n).
destruct H.
induction e.
induction x.
constructor 1.
simpl.
repeat progress (try rewrite (add_comm _ 0); simpl;
                 try rewrite (add_comm _ (S _)); simpl).
constructor 2.
constructor 1.
simpl in IHx.
repeat progress (try rewrite (add_comm _ 0) in IHx; simpl in IHx;
                 try rewrite (add_comm _ (S _)) in IHx; simpl in IHx).
apply IHx.
Defined.

Lemma EvenOrOddS : forall n:nat, (Even n + Odd n) -> (Even (S n) + Odd (S n)).
intros.
destruct H.
constructor 2.
constructor 1.
apply e.
constructor 1.
constructor 2.
apply o.
Defined.

Fixpoint EvenOrOdd(n:nat) : Even n + Odd n :=
match n with
 | 0 => inl EO
 | S k => EvenOrOddS _ (EvenOrOdd k)
end.

Lemma add_commS : forall n m:nat, S (S (n + m)) = S n + S m.
simpl.
intros.
rewrite (add_comm _ (S _)).
simpl.
rewrite (add_comm n m).
reflexivity.
Defined.

Lemma timesS : forall a b:nat, S ((a * b) + a + b) = (S a) * (S b).
simpl.
intros.
rewrite (mul_comm _ (S _)).
simpl.
rewrite (mul_comm b a).
rewrite (add_comm _ (a * b)).
rewrite (add_comm_assoc ).
rewrite (add_comm b a).
rewrite (add_assoc ).
reflexivity.
Defined.

Fixpoint OddEvenPlus{a b:nat}(Ha : Even a)(Hb : Odd b) {struct Hb}: (Odd (a + b)) :=
match Ha with
 |EO => @eq_rect nat b Odd Hb (0 + b) eq_refl
 |ES n o => match Hb with
            |OS m e =>
                   eq_rect _ _ (@eq_rect nat (S (S (m + n))) Odd (OS (S (m + n)) (ES (m + n) (EvenOddPlus e o))) (S (S (n + m)))
    (f_equal S (f_equal S (add_comm m n)))) _ (add_commS _ _)
            end
end
with EvenOddPlus{a b:nat}(Ha : Even a)(Hb : Odd b) {struct Ha}: (Odd (a + b)) :=
match Ha with
 |EO => @eq_rect nat b Odd Hb (0 + b) eq_refl
 |ES n o => match Hb with
            |OS m e =>
                   eq_rect _ _ (@eq_rect nat (S (S (m + n))) Odd (OS (S (m + n)) (ES (m + n) (OddEvenPlus e o))) (S (S (n + m)))
    (f_equal S (f_equal S (add_comm m n)))) _ (add_commS _ _)
            end
end.

Definition EvenTimes{a:nat}(b:nat)(Ha : Even a) : (Even (a * b)).
apply twoDividesEven2.
destruct (twoDividesEven1 _ Ha).
induction e.
exists (x * b).
simpl.
repeat (rewrite (add_comm _ 0); simpl).
repeat (rewrite (mul_comm _ b); simpl).
induction b.
all: simpl.
reflexivity.
rewrite add_comm_assoc.
rewrite <- add_assoc.
rewrite IHb.
repeat rewrite add_assoc.
reflexivity.
Defined.

Fixpoint EvenEvenPlus{a b:nat}(Ha : Even a)(Hb : Even b) {struct Ha}: (Even (a + b)) :=
match Ha with
 |EO => @eq_rect nat b Even Hb (0 + b) eq_refl
 |ES n On => match Hb with
             |EO => let p : (S n) = (S n) + 0 := eq_sym (add_comm (S n) 0) in
                    @eq_rect nat (S n) Even (ES _ On) ((S n) + 0) p
             |ES m Om => let p : (S (S (n + m))) = (S n + S m) := add_commS _ _ in
                          eq_rect _ Even (ES _ (OS _ (OddOddPlus On Om))) _ p
             end
end
with
OddOddPlus{a b:nat}(Ha : Odd a)(Hb : Odd b) {struct Ha}: (Even (a + b)) :=
match Ha with
 |OS n En => match Hb with
             |OS m Em => let p : (S (S (n + m))) = (S n + S m) := add_commS _ _ in
                          eq_rect _ Even (ES _ (OS _ (EvenEvenPlus En Em))) _ p
             end
end.

Definition OddOddTimes{a b:nat}(Ha : Odd a)(Hb : Odd b) : (Odd (a * b)) :=
match Ha with
|OS n En => match Hb with
            |OS m Em => let p : S _ = _ := timesS _ _ in
                        eq_rect _ Odd (OS _ (EvenEvenPlus (EvenEvenPlus (EvenTimes _ En) En) Em)) _ p
            end
end.

Lemma NotBothEvenOdd : forall n:nat, Even n -> Odd n -> False.
induction n.
all: intros.
inversion H0.
inversion H.
inversion H0.
induction H3.
induction H1.
apply (IHn H4 H2).
Defined.

Theorem twoIsPrime : isPrime 2.
intros a b X.
destruct (EvenOrOdd a).
constructor 1.
apply (twoDividesEven1 _ e).
constructor 2.
destruct (EvenOrOdd b).
apply (twoDividesEven1 _ e).
assert (EX := twoDividesEven2 _ X).
assert (OX := OddOddTimes o o0).
destruct (NotBothEvenOdd _ EX OX).
Defined.

(*Definition Prime := @sigT nat isPrime.*)
Definition Prime := {n:nat & isPrime n}.

Example TwoPrime : Prime := existT isPrime 2 twoIsPrime.

Theorem Grothendieck : (isPrime 51) -> False.
unfold isPrime.
simpl.
intro H.
destruct (H 3 17 (existT _ 1 eq_refl)) as [[k ?H]|[k ?H]].
all: induction k.
all: simpl in H0.
all: try repeat rewrite (add_comm _ (S _)) in H0.
all: inversion H0.
Defined.

Theorem rootPrime : forall p:nat, (forall n:nat, ((S (S (n))) * (S (S (n)))) <= p -> (divides (S (S (n))) p) -> False) -> (isPrime p).
Proof with (simpl in *; try ((constructor 1; (lia || nia || psatz nat 2)) || (constructor 2; (lia || nia || psatz nat 2)))).
unfold isPrime, divides.
intros.
destruct H0.
all: destruct a...
all: destruct b...
all: destruct x...
all: try induction a...
all: try induction b...
all: try induction x...
all: rewrite (mul_comm p _) in e...
all: induction e...


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


Theorem a1 : forall (P Q : Prop), (P /\ Q) -> ~(~P \/ ~Q).
Proof.
  unfold not.
  intros.
  case H0; intros; case H; intros.
  apply (H1 H2).
  apply (H1 H3).
Qed.

Theorem a2 : forall (P Q : Prop), (P \/ Q) -> ~(~P /\ ~Q).
Proof.
  unfold not.
  intros.
  case H; intros; case H0; intros.
  apply (H2 H1).
  apply (H3 H1).
Qed.

Theorem e1 : forall (X:Type) (P : X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  unfold not.
  intros.
  case H0; intros.
  apply (H1 (H x)).
Qed.

Theorem e2 : forall (X:Type) (P : X -> Prop),
  (exists x, P x) -> ~ (forall x, ~ P x).
Proof.
  unfold not.
  intros.
  case H; intros.
  apply (H0 x H1).
Qed.


(*
D1. Zero Sum Sequences
======================
We prove that given an infinite sequence α and a number n, there exists numbers
i and k such that 0 < k and i + k ≤ n and the sequence α_{i}..α_{i+k} sums to 0
modulo n. The proof for this theorem is based on a "sliding window" over the
first n elements of α.
*)

From graph_pebbling Require Import A_primitives.

Lemma unfold_mod i n :
  n ≠ 0 -> ∃ m, i `mod` n = i - n * m ∧ n * m ≤ i.
Proof. exists (i `div` n); nia. Qed.

Ltac unfold_mod m :=
  let H := fresh "H" in
  edestruct unfold_mod as (m & -> & H); [done|].

Theorem zero_sum_sequence (α : nat -> nat) n :
  n ≠ 0 -> ∃ i k, 0 < k ∧ i + k ≤ n ∧ n ∣ summation (α <$> seq i k).
Proof.
intros Hn; pose (β i := summation (α <$> seq 0 i) `mod` n).
destruct (nat_pigeonhole β (S n) n) as (i&j&H1&H2); unfold β in *; [lia|lia|].
exists i, (j - i); repeat split; [lia|lia|]; revert H2.
replace j with (i + (j - i)) at 1 by lia.
rewrite seq_app, fmap_app, summation_app; cbn.
unfold_mod m_i; unfold_mod m_j; exists (m_j - m_i); nia.
Qed.

Lemma fmap_seq_take_drop {A} (α : nat -> A) i k l :
  (∀ j, i ≤ j < i + k -> l !! j = Some (α j)) ->
  α <$> seq i k = take k (drop i l).
Proof.
induction k; intros.
- symmetry; apply take_0.
- erewrite seq_S, take_S_r, fmap_app, IHk. done.
  + intros; apply H; lia.
  + rewrite lookup_drop; apply H; lia.
Qed.

Corollary zero_sum_sublist (l : list nat) :
  l ≠ [] -> ∃ l', l' ≠ [] ∧ l' `sublist_of` l ∧ length l ∣ summation l'.
Proof.
intros Hl; apply non_empty_length in Hl; pose (α i := default 0 (l !! i)).
destruct (zero_sum_sequence α (length l)) as (i & k & H1 & H2 & H3); [done|].
eexists; split; [|split; [|done]].
- apply non_empty_length; rewrite fmap_length, seq_length; lia.
- erewrite fmap_seq_take_drop.
  + etrans; [apply sublist_take|apply sublist_drop].
  + intros; unfold α; destruct (l !! j) eqn:E; [done|exfalso].
    apply lookup_ge_None in E; lia.
Qed.


(************************************************************************)
(* Copyright 2006 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 2.1                        *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses/lgpl-2.1.html>         *)
(************************************************************************)

Require Export Qsyntax.
Require Export Field_Theory_Q.
Require Export Q_ordered_field_properties.

Definition Qabs (q:Q):Q:=
  match q with
  | Zero => Zero
  | Qpos qp => Qpos qp
  | Qneg qp => Qpos qp
  end.

Lemma Qabs_eq: forall q, Zero<=q -> Qabs q = q.
Proof.
 intros [|q|q] Hq; simpl; trivial; unfold Qle in Hq; contradiction Hq; auto.
Qed.

Lemma Qabs_non_eq: forall q, q<=Zero -> Qabs q = (-q).
Proof.
 intros [|q|q] Hq; simpl; trivial; unfold Qle in Hq; contradiction Hq; auto.
Qed.

Lemma Qabs_eq_pos: forall q, Zero<q -> Qabs q = q.
Proof.
 intros [|q|q] Hq; simpl; trivial; contradiction (Zero_not_lt_Qneg q).
Qed.

Lemma Qabs_non_eq_neg: forall q, q<Zero -> Qabs q = (-q).
Proof.
 intros [|q|q] Hq; simpl; trivial; contradiction (Qpos_not_lt_Zero q).
Qed.

Lemma Qabs_Qmult: forall q1 q2, Qabs (q1*q2) = (Qabs q1) * (Qabs q2).
Proof.
 intros [|q1|q1] [|q2|q2]; simpl; trivial.
Qed.

Lemma Qabs_5: forall q p, Qabs q <= p -> (- p <= q)/\ (q<= p).
Proof.
 intros [|q|q] [|p|p]; simpl; unfold Qle; intros Hqp; split; auto;
 solve [ apply Zero_not_lt_Qneg|apply Qpos_not_lt_Qneg|apply Qle_opp; simpl; assumption].
Qed.

Lemma Qabs_6: forall q p, Qabs q <= p -> q<= p.
Proof.
 intros q p H; apply (proj2 (Qabs_5 _ _ H)).
Qed.

Lemma Qabs_7: forall q p, Qabs q <= p -> - p <= q.
 intros q p H; apply (proj1 (Qabs_5 _ _ H)).
Qed.

Lemma Qabs_8: forall q p, - p <= q -> q <= p -> Qabs q <= p.
Proof.
 intros [|q|q] [|p|p]; simpl; unfold Qle; intros H1 H2; auto; apply Qle_opp; simpl; assumption.
Qed.

Lemma Qabs_nonneg: forall q, Zero <= Qabs q.
Proof.
 intros [|q|q]; simpl; auto.
Qed.

Lemma Qle_Qabs: forall q, q <= Qabs q.
Proof.
 intros [|q|q]; simpl; auto.
Qed.

Lemma Qle_Qabs_Qopp: forall q, -q <= Qabs q.
Proof.
 intros [|q|q]; simpl; auto.
Qed.

Lemma Qabs_Qle_Qopp: forall q, - (Qabs q) <= q.
Proof.
 intros [|qp|qp]; simpl; auto.
Qed.

Lemma Qabs_triangle: forall p q, Qabs (p + q) <= Qabs p + Qabs q.
Proof.
 intros p q.
 destruct (Q_le_lt_dec Zero p) as [Hp|Hp]; destruct (Q_le_lt_dec Zero q) as [Hq|Hq].
  repeat rewrite Qabs_eq; auto.

  assert (Hp1:=Qabs_eq _ Hp); assert (Hq1:=Qabs_non_eq_neg _ Hq); rewrite Hp1; rewrite Hq1;
  destruct (Q_le_lt_dec Zero (p+q)) as [Hpq|Hpq].
   rewrite Qabs_eq; trivial; apply Qle_Zero_Qminus_neg; stepl (q+q);[|ring]; auto.
   rewrite Qabs_non_eq_neg; trivial; apply Qle_Zero_Qminus; stepr (p+p);[|ring]; auto.

  assert (Hp1:=Qabs_non_eq_neg _ Hp); assert (Hq1:=Qabs_eq _ Hq); rewrite Hp1; rewrite Hq1;
  destruct (Q_le_lt_dec Zero (p+q)) as [Hpq|Hpq].
   rewrite Qabs_eq; trivial; apply Qle_Zero_Qminus_neg; stepl (p+p);[|ring]; auto.
   rewrite Qabs_non_eq_neg; trivial; apply Qle_Zero_Qminus; stepr (q+q);[|ring]; auto.

  repeat rewrite Qabs_non_eq_neg; auto; (stepr (-(p+q)) by ring); trivial.
Qed.

Lemma Qabs_Qopp:forall q, Qabs q = Qabs (-q).
Proof.
 intros [|qp|qp]; trivial.
Qed.

Lemma Qabs_Qminus_sym:forall q1 q2, Qabs (q1-q2) = Qabs (q2-q1).
Proof.
 intros q1 q2; rewrite Qabs_Qopp; apply (f_equal Qabs); ring.
Qed.

Lemma Qabs_nonzero_pos:forall q, q<> Zero -> Zero < Qabs q.
Proof.
 intros [|qp|qp] H; simpl; trivial; contradiction H; trivial.
Qed.

Lemma Qabs_Qminus_Zero_eq:forall q1 q2, Qabs (q1-q2) = Zero -> q1=q2.
Proof.
 intros q1 q2 Hq; destruct (Q_zerop (q1-q2)) as [H|H]; auto; contradiction (Qlt_irreflexive Zero);
 stepr (Qabs (q1 - q2)); trivial; apply Qabs_nonzero_pos; trivial.
Qed.

Lemma Qabs_Zero_Qminus_eq:forall q1 q2, q1=q2 -> Qabs (q1-q2) = Zero.
Proof.
 intros q1 q2 Hq; rewrite Hq; replace (q2-q2) with Zero by ring; reflexivity.
Qed.

Lemma Qabs_Qminus_bound:forall low up q1 q2, low <= q1 -> q1 <= up -> low <= q2 -> q2 <= up -> Qabs (q1-q2) <= up-low.
Proof.
 intros l u q1 q2 Hq1l Hq1u Hq2l Hq2u.
 destruct (Q_le_lt_dec q2 q1) as [H|H];
 [ rewrite Qabs_eq;
  [
  | apply Qle_Qminus_Zero
  ]
 | rewrite Qabs_non_eq_neg;
   [ stepl (q2-q1);[|ring]
   | apply Qlt_Qminus_Zero_neg
   ]
 ]; trivial; unfold Qminus; apply Qle_plus_plus; try apply Qopp_Qle; trivial.
Qed.

Lemma upper_bound_affine_base_interval_twice:forall a b c d x, -Qone<=x -> x<=Qone ->
 (a*x+b)*(c*x+d) <= Qabs (a*c) + Qabs (a*d+c*b)+b*d.
Proof.
 intros a b c d x Hxl Hxu.
 assert (Hxx0:=Qmult_mult_nonneg x).
 assert (Hxx1:=Qmult_mult_Qle_Qone_Qopp_Qone _ Hxl Hxu).
 stepl ((a*c)*(x*x)+(a*d+c*b)*x+b*d); [|ring].
 repeat apply Qle_plus_plus; trivial.
  stepr (Qabs (a*c)*Qone); [|ring];
  apply Qle_trans with (Qabs (a*c)*(x*x));
  [apply Qle_reg_mult_r_strong; trivial; apply Qle_Qabs| apply Qle_reg_mult_l_strong; trivial; apply Qabs_nonneg]...
  apply Qle_trans with (Qabs((a*d+c*b)*x)); [apply Qle_Qabs|];
  rewrite Qabs_Qmult; stepr (Qabs(a*d+c*b)*Qone); [|ring];
  apply Qle_reg_mult_l_strong; [apply Qabs_nonneg|];
  apply Qabs_8; trivial...
Qed.

Lemma lower_bound_affine_base_interval_twice:forall a b c d x, -Qone<=x -> x<=Qone ->
        -Qabs (a*c) + -Qabs (a*d+c*b)+b*d <= (a*x+b)*(c*x+d).
Proof.
 intros a b c d x Hxl Hxu.
 assert (Hxx0:=Qmult_mult_nonneg x).
 assert (Hxx1:=Qmult_mult_Qle_Qone_Qopp_Qone _ Hxl Hxu).
 stepr ((a*c)*(x*x)+(a*d+c*b)*x+b*d); [|ring].
 repeat apply Qle_plus_plus; trivial.
  stepl (-Qabs (a*c)*Qone); [|ring];
  apply Qle_trans with (-Qabs (a*c)*(x*x));
  [ apply Qle_opp;
    repeat rewrite <- Qmult_Qopp_left; apply Qle_reg_mult_l_strong; trivial; rewrite Qopp_involutive; apply Qabs_nonneg
  | apply Qle_reg_mult_r_strong; trivial; apply Qabs_Qle_Qopp
  ]...
  apply Qle_trans with (-Qabs((a*d+c*b)*x)); [|apply Qabs_Qle_Qopp];
  apply Qopp_Qle;
  rewrite Qabs_Qmult; stepr (Qabs(a*d+c*b)*Qone); [|ring];
  apply Qle_reg_mult_l_strong; [apply Qabs_nonneg|];
  apply Qabs_8; trivial...
Qed.


(**
This exercise shows how to use representation predicates in Iris. We consider
some basic operations on linked lists. Although heap-lang is untyped, our
representation of lists intuitively corresponds to the following (rec-) type
in an ML-style language:

  list A := option (ref (A * list A))
*)
From iris.heap_lang Require Import proofmode notation.

(** A function that sums all elements of a list, defined as a heap-lang value: *)
Definition sum_list : val :=
  rec: "sum_list" "l" :=
    match: "l" with           (* A list is either... *)
      NONE => #0              (* ... the empty list *)
    | SOME "p" =>             (* ... or [SOME p], where [p] points to a pair ... *)
      let: "x" := Fst !"p" in (* ... whose first component is the head of the list *)
      let: "l" := Snd !"p" in (* ... and whose second component is the rest of the list. *)
      "x" + "sum_list" "l"
    end.

(** A function that increases all elements of a list in-place: *)
Definition inc_list : val :=
  rec: "inc_list" "n" "l" :=
    match: "l" with
      NONE => #()
    | SOME "p" =>
      let: "x" := Fst !"p" in
      let: "l" := Snd !"p" in
      "p" <- ("n" + "x", "l");;
      "inc_list" "n" "l"
    end.

(** The previous functions combined. *)
Definition sum_inc_list : val := λ: "n" "l",
  inc_list "n" "l";;
  sum_list "l".

(** A function that maps a function over all elements of a list: *)
Definition map_list : val :=
  rec: "inc_list" "f" "l" :=
    match: "l" with
      NONE => #()
    | SOME "p" =>
      let: "x" := Fst !"p" in
      let: "l" := Snd !"p" in
      "p" <- ("f" "x", "l");;
      "inc_list" "f" "l"
    end.

Section proof.
Context `{!heapG Σ}.

(** Representation predicate in separation logic for a list of integers [l]: *)
Fixpoint is_list (l : list Z) (v : val) : iProp Σ :=
  match l with
  | [] => ⌜ v = NONEV ⌝
  | x :: l' => ∃ (p : loc), ⌜ v = SOMEV #p ⌝ ∗
                 ∃ v' : val, p ↦ (#x, v') ∗ is_list l' v'
  end%I.

(**
In order to give a specification of [sum_list] we relate its result to the
sum defined as a pure Coq function.
*)
Definition sum_list_coq (l : list Z) : Z :=
  fold_right Z.add 0 l.

(**
The proof of the recursive function [sum_list] requires some form of recursion.
We can either do the induction over the list [l], or use the Löb induction
principle, given by the step-indexed nature of Iris. *)

(** The proof using induction over [l]: *)
Lemma sum_list_spec_induction l v :
  {{{ is_list l v }}} sum_list v {{{ RET #(sum_list_coq l); is_list l v }}}.
Proof.
  iIntros (Φ) "Hl Post".
  iInduction l as [|x l] "IH" forall (v Φ); simpl.
  (**
  Note that the option type is in fact encoded using sum types.
  Hence, [NONE] is syntactic sugar for [InjL #()] (or [InjLV #()]
  for values), and [SOME x] is syntactic sugar for [InjR x].
  *)
  - iDestruct "Hl" as %->.
    wp_rec.
    wp_match.
    iApply "Post". iPureIntro. reflexivity.
  - iDestruct "Hl" as (p) "[-> Hl]". iDestruct "Hl" as (v) "[Hp Hl]".
    wp_rec.
    wp_match.
    wp_load. wp_proj. wp_let.
    wp_load. wp_proj. wp_let.
    wp_apply ("IH" with "Hl"). iIntros "Hl". wp_op.
    iApply "Post".
    iExists p. iSplitR; [done|].
    iExists v. iSplitR "Hl"; [iApply "Hp"|iApply "Hl"].
Qed.

(** The proof using Löb induction. The parts which are in common with
[sum_list_spec_induction] are shortened using automation. *)
Lemma sum_list_spec_löb l v :
  {{{ is_list l v }}} sum_list v {{{ RET #(sum_list_coq l); is_list l v }}}.
Proof.
  iIntros (Φ) "Hl Post".
  iLöb as "IH" forall (l v Φ). destruct l as [|x l]; simpl; wp_rec.
  - iDestruct "Hl" as %->. wp_match. by iApply "Post".
  - iDestruct "Hl" as (p -> v) "[Hp Hl]". wp_match.
    do 2 (wp_load; wp_proj; wp_let).
    wp_apply ("IH" with "Hl"). iIntros "Hl". wp_op.
    iApply "Post". eauto with iFrame.
Qed.

(** *Exercise*: Do the proof of [inc_list] yourself. Use ordinary induction. *)
Lemma inc_list_spec_induction n l v :
  {{{ is_list l v }}}
    inc_list #n v
  {{{ RET #(); is_list (map (Z.add n) l) v }}}.
Proof.
  iIntros (Φ) "Hl Post".
  iInduction l as [|x l] "IH" forall (v Φ); simpl.
  - iDestruct "Hl" as %->.
    wp_rec. wp_let. wp_match.
    by iApply "Post".
  - iDestruct "Hl" as (p) "[-> Hl] /=". iDestruct "Hl" as (v) "[Hp Hl]".
    wp_rec. wp_let.
    wp_match.
    wp_load. wp_proj. wp_let.
    wp_load. wp_proj. wp_let.
    wp_op. wp_store.
    wp_apply ("IH" with "Hl"). iIntros "Hl".
    iApply "Post".
    iExists p. iSplitR; [done|].
    iExists v. iSplitR "Hl"; [iApply "Hp"|iApply "Hl"].
Qed.

(** *Exercise*: Now do the proof again using Löb induction. *)
Lemma inc_list_spec_löb n l v :
  {{{ is_list l v }}}
    inc_list #n v
  {{{ RET #(); is_list (map (Z.add n) l) v }}}.
Proof.
  iIntros (Φ) "Hl Post".
  iLöb as "IH" forall (l v Φ). destruct l as [|x l]; simpl; wp_rec; wp_let.
  - iDestruct "Hl" as %->. wp_match. by iApply "Post".
  - iDestruct "Hl" as (p -> v) "[Hp Hl] /=". wp_match.
    do 2 (wp_load; wp_proj; wp_let). wp_op. wp_store.
    wp_apply ("IH" with "Hl"). iIntros "Hl".
    iApply "Post". eauto with iFrame.
Qed.

(** *Exercise*: Do the proof of [sum_inc_list] by making use of the lemmas of
[sum_list] and [inc_list] we just proved. Make use of [wp_apply]. *)
Lemma sum_inc_list_spec n l v :
  {{{ is_list l v }}}
    sum_inc_list #n v
  {{{ RET #(sum_list_coq (map (Z.add n) l)); is_list (map (Z.add n) l) v }}}.
Proof.
  iIntros (Φ) "Hl Post". do 2 wp_let.
  wp_apply (inc_list_spec_induction with "Hl"); iIntros "Hl /="; wp_seq.
  wp_apply (sum_list_spec_induction with "Hl"); auto.
Qed.

(** *Optional exercise*: Prove the following spec of [map_list] which makes use
of a nested Texan triple, This spec is rather weak, as it requires [f] to be
pure, if you like, you can try to make it more general. *)
Lemma map_list_spec_induction (f : val) (f_coq : Z → Z) l v :
  (∀ n, {{{ True }}} f #n {{{ RET #(f_coq n); True }}}) -∗
  {{{ is_list l v }}} map_list f v {{{ RET #(); is_list (map f_coq l) v }}}.
Proof.
  iIntros "#Hf" (Φ) "!# Hl Post".
  iLöb as "IH" forall (l v Φ). destruct l as [|x l]; simpl; wp_rec; wp_let.
  - iDestruct "Hl" as %->. wp_match. by iApply "Post".
  - iDestruct "Hl" as (p -> v) "[Hp Hl] /=". wp_match.
    do 2 (wp_load; wp_proj; wp_let).
    wp_apply ("Hf" with "[//]"); iIntros "_ /=".
    wp_store.
    wp_apply ("IH" with "Hl"). iIntros "Hl".
    iApply "Post". eauto with iFrame.
Qed.
End proof.


Require Import Coq.ZArith.ZArith.
Require Import Coq.ZArith.Znumtheory.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.Tactics.DivideExistsMul.
Require Import Crypto.Util.Tactics.DestructHead.
Local Open Scope Z_scope.

Module Z.
  Lemma divide_mul_div: forall a b c (a_nonzero : a <> 0) (c_nonzero : c <> 0),
    (a | b * (a / c)) -> (c | a) -> (c | b).
  Proof.
    intros ? ? ? ? ? divide_a divide_c_a; do 2 Z.divide_exists_mul.
    rewrite divide_c_a in divide_a.
    rewrite Z.div_mul' in divide_a by auto.
    replace (b * k) with (k * b) in divide_a by ring.
    replace (c * k * k0) with (k * (k0 * c)) in divide_a by ring.
    rewrite Z.mul_cancel_l in divide_a by (intuition auto with nia; rewrite H in divide_c_a; ring_simplify in divide_a; intuition).
    eapply Zdivide_intro; eauto.
  Qed.

  Lemma divide2_even_iff : forall n, (2 | n) <-> Z.even n = true.
  Proof.
    intros n; split. {
      intro divide2_n.
      Z.divide_exists_mul; [ | pose proof (Z.mod_pos_bound n 2); lia].
      rewrite divide2_n.
      apply Z.even_mul.
    } {
      intro n_even.
      pose proof (Zmod_even n) as H.
      rewrite n_even in H.
      apply Zmod_divide; lia || auto.
    }
  Qed.

  Lemma divide_pow_le b n m : 0 <= n <= m -> (b ^ n | b ^ m).
  Proof.
    intros. replace m with (n + (m - n)) by ring.
    rewrite Z.pow_add_r by lia.
    apply Z.divide_factor_l.
  Qed.

  Lemma mod_divide_full a b : (a mod b = 0) <-> (b | a).
  Proof.
    destruct (Z_zerop b); auto using Z.mod_divide; subst; [].
    rewrite Zmod_0_r; cbv [Z.divide]; intuition (destruct_head'_ex; subst; try exists 0; lia).
  Qed.

  Lemma mod_div_mod_full a m n : (n | m) -> a mod n = (a mod m) mod n.
  Proof.
    intros (p,Hp); rewrite (Z_div_mod_eq_full a m) at 1.
    rewrite Hp at 1.
    destruct (Z_zerop n); subst; try now autorewrite with zsimplify_const.
    rewrite Z.mul_shuffle0, Z.add_comm, Z.mod_add; auto.
  Qed.
  #[global]
   Hint Rewrite <- mod_div_mod_full using assumption : zsimplify push_Zmod.
End Z.


Require Import Ashley.Axioms.
Require Import Ashley.Logic.
Require Import Ashley.Logic.Unary.

(*
Require Import Ashley.Set.
Require Import Ashley.Topology.
Require Import Ashley.Function.
*)
Check O.
Check nat.
Check Set.
Check Type.
Check Prop.
Check gt.
Check S.
Check 34.
Check (3 > 0).
Check (0 = 0).
Check ((0 = 0) = (0 = 1)).
Check True.

Section Test.

Variables A B C : Prop.

Lemma abbcac: (A -> B) -> (B -> C) -> A -> C.
intro ab.
intro bc.
intro a.
apply bc.
apply ab.
apply a.
Save.

Lemma orc: A \/ B -> B \/ A.
intro ab.
elim ab.
clear ab.
right.
apply H.
left.
apply H.
Save.

Check orc.
Print orc.

Check bool.
Print bool.

End Test.

Check true.

Parameter Other : Prop.
Axiom Tertium : ~~Other.

Lemma Tertium_collapse: Other.
assume_not.
apply Tertium.
apply H.
Save.

Definition pqr : Prop -> Prop -> Prop := fun a b => a \/ b.
Definition pqr1 : nat -> nat -> nat := fun a b => a + b.

Require Import Coq.Reals.Reals.

Print R.

Local Open Scope R_scope.

Definition zz : R := 0.

Check Rmax.
Print Rmax.

Class Fuzzy (F : Prop -> R) (very : Prop -> Prop) : Type :=
{
  fuzzy_lower_bound : forall a, F a >= 0;
  fuzzy_upper_bound : forall a, F a <= 1;
  fuzzy_false : F False = 0;
  fuzzy_implies : forall a b : Prop, F (a -> b) = 1 + (Rmin (F b - F a) 0);
  fuzzy_very: forall a, F (very a) = (F a) * (F a)
}.

Section Fuzzy.
Context `{fuzzy:Fuzzy}.

Lemma fuzzy_true : F True = 1.
transitivity (F (True -> True)).
cut ((True -> True) = True).
intros.
rewrite H.
trivial.
apply prop_ext.
split.
intros.
trivial.
intros.
trivial.
rewrite fuzzy_implies.

????.

auto.

Lemma fuzzy_not : forall a:Prop, F(~a) = 1 - F(a).
intros.
rewrite (fuzzy_implies a False).
rewrite fuzzy_false.
unfold Rmin.
auto.

Lemma fuzzy_and : forall a b:Prop, F(a /\ b) = Rmin (F a) (F b).
intros.

End Fuzzy.

Class Modal (U : Prop -> Prop) : Type :=
{
  modal_N1 : U True;
  modal_N2 : forall a b, (U a -> U b) -> U (a -> b);
  modal_K : forall (a:Prop) (b:Prop), U (a -> b) -> U a -> U b
}.

Section Modal.

Context `{M:Modal}.

Lemma thing: U (False -> True).

Lemma modal_collapse_with_prop_ext : forall a:Prop, a -> U a.
intros.
cut (a = True).
intros.
rewrite H0.
apply modal_N.
apply prop_ext.
split.
trivial.
intro.
apply H.
Save.

End Modal.


(** * ProofsAndPrograms: The Fundamentals of the Coq Proof Assistant *)

(** Ignore this line *)
Set Warnings "-notation-overridden,-parsing".

(* ################################################################# *)
(** * Programs *)

(** Let's start by defining a simple inductive datatype, corresponding
   to a coin: *)

Inductive coin : Type :=
| heads : coin
| tails : coin.

(** We can define a function [flip] that turns the coin over: *)

Definition flip (c : coin) : coin :=
  match c with
  | heads => tails
  | tails => heads
  end.

(** Let's look at a few examples of coin flips. *)

Compute (flip heads).
Compute (flip tails).

(** You might notice that this coin corresponds to a boolean value.
   Conveniently, Coq makes the same observation! This allows us to
   write an alternative definition of flip. *)

Definition flip' (c : coin) := if c then tails else heads.

Compute (flip' heads).
Compute (flip' tails).

(** In general, Coq will allow us to use its conditional statement for
   any datatype with two constructors. The first constructor will be
   treated as [true] and the second as [false]. This [if] statement is
   really just notation for the corresponding [match] statement. *)

(** We will often want to check the types of various objects from
   [coin] to coins to functions. For this we use the [Check]
   command. *)

Check heads.
Check coin.
Check flip.
Check (flip heads).

(** Let's look at a slightly more complicated datatype corresponding to
   a play in the game Rock-Paper-Scissors: *)

Inductive play : Type :=
| rock : play
| paper : play
| scissors : play.

(** There are three possible outcomes: a win a loss and a tie. *)
Inductive outcome : Type :=
| win : outcome
| loss : outcome
| tie : outcome.

(** We can use these to define a game of Rock-Paper-Scissors. *)

Definition game (p1 p2 : play) : outcome :=
  match p1, p2 with
  | rock, scissors  => win
  | scissors, paper => win
  | paper, rock     => win
  | scissors, rock  => loss
  | paper, scissors => loss
  | rock, paper     => loss
  | _, _            => tie
  end.

(** That's pretty wordy, even given our use of wildcard characters to
   capture the three remaining cases, where both players tie. It would
   be nice if there were some way to express 'A beats B' and then use
   that to define losses. *)

(** Fortunately, Coq has the ability to define exactly that through its
   use of propositions. *)

(* ################################################################# *)
(** * Propositions *)

(** A predicate in Coq, which has the type [Prop], expresses the truth
   of a given claim. Let's define a prop corresponding to 'A beats B'.
   *)

Inductive beats : play -> play -> Prop :=
| crushes : beats rock scissors
| cuts    : beats scissors paper
| covers  : beats paper rock.

(** Since [beats] takes any two plays to a Prop, both of the following
   are valid propositions. *)

Check (beats rock scissors).
Check (beats rock rock).

(** The important difference between [beats rock scissors] and [beats
   rock rock] is that [beats rock scissors] is _True_. For a Prop to
   be true means that there is an element of that type. *)

Check crushes.

(** It so happens that [beats rock rock] is _False_, but showing its
   falsity is somewhat complicated. We'll return to the subject of
   falsity later in this chapter.  *)

(** It's worth noting that 'Prop' isn't special. We could replace every
   instance of Prop in this chapter with 'Type' and nothing would
   break. The significance of 'Prop' lies in its interpretation: We
   treat 'beats' not as a Type that depends on two plays but as a
   _claim_ about those two plays. *)

(** We can easily define [loses] and [ties]: *)

Inductive loses : play -> play -> Prop :=
| crushed  : loses scissors rock
| cut      : loses paper scissors
| covered  : loses rock paper.

Inductive ties : play -> play -> Prop :=
| tie_rock : ties rock rock
| tie_paper : ties paper paper
| tie_scissors : ties scissors scissors.

(** Time to start proving things!
   Here's a simple claim : If A beats B, then B loses to A. *)

Definition beats_backwards_loses (p1 p2 : play) (b : beats p1 p2) : loses p2 p1 :=
  match b with
  | crushes => crushed
  | cuts    => cut
  | covers  => covered
  end.

(** In fact, we could have simply defined '[loses] in terms of [beats]! *)

Definition loses' (p1 p2 : play) := beats p2 p1.

(** **** Exercise: 2 stars (loses_then_loses')  *)
(** Show that these two definitions of [loses] are equivalent. *)

Definition loses_then_loses' (p1 p2 : play) (l : loses p1 p2) : loses' p1 p2
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Definition loses'_then_loses (p1 p2 : play) (l : loses' p1 p2) : loses p1 p2
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

(** [] *)

(** Our examples above didn't involve any computation - we haven't even
   defined any (traditional) functions on plays. Let's try proving
   some things about coin flipping.  *)

(** First, we will introduce two predicates on pair of coins: *)

Inductive same : coin -> coin -> Prop :=
| same_heads : same heads heads
| same_tails : same tails tails.

Inductive inverse : coin -> coin -> Prop :=
| heads_tails : inverse heads tails
| tails_heads : inverse tails heads.

(** Let's first show that flipping always yields an inverse. *)
Definition flip_inverse (c : coin) : inverse c (flip c) :=
  match c with
  | heads => heads_tails
  | tails => tails_heads
  end.

(** We can also show that flipping a coin twice yields the original
   coin. *)

Definition flip_involutive (c : coin) : same c (flip (flip c)) :=
  match c with
  | heads => same_heads
  | tails => same_tails
  end.

(** Just like any coq term, we can reuse earlier proofs: *)

Definition flip_thrice (c : coin) : same (flip c) (flip (flip (flip c)))
(* WORKED IN CLASS *) :=
  flip_involutive (flip c).

(* ################################################################# *)
(** * Logic *)

(** Now that we know how to prove things, it would be nice to have some
   logical connectives, like [and] and [or] to increase the
   expressiveness of our logic. It would also be nice to have more
   tools for logical reasoning, which we will develop in this section.
   *)

(* ================================================================= *)
(** ** Logic 101 *)

(** Let's start off with a simple rule of logic: Modus Ponens Modus
   Ponens says that if X -> Y and X are true, so is Y.  In our
   context, that means that from a function of type [X -> Y] and a
   term of type [X], we can construct a [Y]. *)

Definition modus_ponens (X Y : Prop) (P : X -> Y) (x : X) : Y := P x.

(** Note that Modus Ponens is simply function application! *)

(** Here's the chain rule, which corresponds to function composition: *)
Definition chain_rule (X Y Z : Prop) (P : X -> Y) (Q : Y -> Z) : X -> Z :=
  fun x => Q (P x).

(** We know that a [Prop] is true if it has any elements. A false
   [Prop] would then be a Prop without any elements. While many Props
   are true and many are false, it's worth having at least one
   archetypal [True] and [False]. *)

Inductive True := t.
Inductive False := .

(** [False] is actually a really exciting thing to prove. If I can
   construct an element of [False], I can obtain whatever I want -
   even elements of other uninhabited Props! *)

Definition ex_falso_quodlibet (X : Prop) (f : False) : X :=
  match f with
  end.

(** **** Exercise: 2 stars (X_then_X)  *)
(** State and prove the theorem that for any X, X implies X. *)

(** What does this correspond to computationally? *)

(** We can now use our chain rule to reverse modus ponens. *)

Definition modus_tollens (X Y : Prop) : (X -> Y) -> (Y -> False) -> (X -> False) :=
  chain_rule X Y False.

(* ================================================================= *)
(** ** And and Or *)
(** Let's define some standard logical connectives: *)

Inductive and (X Y : Prop) : Prop :=
  conj : X -> Y -> and X Y.

Inductive or (X Y : Prop) : Prop :=
 | or_introl : X -> or X Y
 | or_intror : Y -> or X Y.

(** The following commands just say that we don't need to provide type
    arguments to our constructors of [and] and [or]. *)
Arguments conj {X Y}.
Arguments or_introl {X Y}.
Arguments or_intror {X Y}.

(** We can also introduce some notations for these connectives: *)
Infix "/\" := and : type_scope.
Infix "\/" := or : type_scope.

(** From the perspective of functional programming, [and] and [or] are
    just product types and sum types respectively. Indeed, the Coq
    standard library separately defines [A * B] and [A + B] over
    [Type]s. But it's useful to have these for Props as well. *)

(** What can we prove about [and] and [or]?
   Some basic properties include symmetry and associativity. *)

Definition and_symm (X Y : Prop) : X /\ Y -> Y /\ X
(* WORKED IN CLASS *) :=
  fun xy =>
  match xy with
  | conj x y => conj y x
  end.

(** **** Exercise: 2 stars (or_symm)  *)
(** Prove a similar theorem for `or` *)

Definition or_symm (X Y : Prop) : X \/ Y -> Y \/ X
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

(** [] *)

Definition and_assoc (X Y Z : Prop) : (X /\ Y) /\ Z -> X /\ (Y /\ Z)
(* WORKED IN CLASS *) :=
  fun xyz =>
  match xyz with
  | conj (conj x y) z => conj x (conj y z)
  end.

(* ################################################################# *)
(** * The Proof Environment *)

(** Unfortunately, these proofs can get pretty heavy, especially when
   there are a lot of cases to match on. For instance, consider the
   following proof that [or] is associative. *)

Definition or_assoc (X Y Z : Prop) : (X \/ Y) \/ Z -> X \/ (Y \/ Z) :=
  fun xyz =>
    match xyz with
    | or_introl xy => match xy with
                     | or_introl x => or_introl x
                     | or_intror y => or_intror (or_introl y)
                     end
    | or_intror z => or_intror (or_intror z)
    end.

(** And it just gets messier from here. *)

(** Instead of having to write out Coq proofs as complicated programs
    involving multiple levels of matching, function application and so
    forth, Coq provides a convenient environment for building proofs,
    step by step.

   Here's [and_symm] again: *)

Lemma and_symm' (X Y : Prop) : X /\ Y -> Y /\ X.
Proof.
(* WORKED IN CLASS *)
  intros xy.             (* introduce the hypotheses *)
  destruct xy as [x y].  (* case analysis *)
  apply (conj y x).      (* apply a term *)
Qed.

(** Since in lemmas we don't reference X and Y on the right hand side
    of [:=], we tend to name all of our arguments on the right side of
    the [:] We can also apply [conj] and fill in X and Y later. *)

Lemma and_symm'' : forall (X Y : Prop), X /\ Y -> Y /\ X.
Proof.
  intros X Y xy.
  destruct xy as [x y].
  apply conj.
  apply y.
  apply x.
Qed.

(** Let's return to `or_assoc` *)

Lemma or_assoc' : forall (X Y Z : Prop), (X \/ Y) \/ Z -> X \/ (Y \/ Z).
Proof.
  (* WORKED IN CLASS *)
  intros X Y Z xyz.
  destruct xyz as [xy | z].
  (* Two goals! We can address each separately. *)
  - destruct xy as [x | y].
    + apply or_introl.
      apply x.
    + apply or_intror.
      apply or_introl.
      apply y.
  - apply or_intror.
    apply or_intror.
    apply z.
Qed.

(** **** Exercise: 3 stars (or_distributes_over_and)  *)
Theorem or_distributes_over_and : forall X Y Z : Prop,
  X \/ (Y /\ Z) -> (X \/ Y) /\ (X \/ Z).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Constructive Logic *)

(** Since Coq requires us to construct a term in order to demonstrate
    that a type is inhabited, not all theorems of classical logic are
    true in Coq's own logic. *)

Lemma excluded_middle : forall (X : Prop), X \/ (X -> False).
Proof.
    intros X.
  (* Unfortunately, we can't proceed as we have no hypotheses
     and no elements of type X or X -> False *)
  Abort.

(** The law of double negation is more interesting: *)

Definition double_negation_forwards : forall (X : Prop), X -> ((X -> False) -> False).
Proof.
  (* WORKED IN CLASS *)
  intros X x.
  intros nx.
  apply nx.
  apply x.
Qed.

Definition double_negation_backwards : forall (X : Prop), ((X -> False) -> False) -> X.
Proof.
    intros X nnx.
  (* Once again, there's no clear way to proceed. Indeed
     ~ ~ X -> X is not a theorem of Coq's logic *)
  Abort.

(** Jumping back to our game of rock-paper-scissors, using the proof
    system it's not hard to prove some basic theorems. *)

Lemma beats_same : forall (x y y' : play), beats x y -> ties y y' -> beats x y'.
Proof.
  (* WORKED IN CLASS *)
  intros x y y' B T.
  destruct T.
  - apply B.
  - apply B.
  - apply B.
Qed.

(** Here's a more succinct definition of [ties]: *)

Inductive ties' : play -> play -> Prop :=
| ties_same : forall (p : play), ties' p p.

(** Let's try proving the theorem above in our new system. *)

Lemma beats_same' : forall (x y y' : play), beats x y -> ties' y y' -> beats x y'.
Proof.
  (* WORKED IN CLASS *)
  intros x y y' B T.
  destruct T as [t].
  apply B.
Qed.

(** **** Exercise: 2 stars (ties_symm)  *)
(** Using the new definition, prove that if a ties b then b ties a *)
Theorem ties_symm : forall (x y : play), ties' x y -> ties' y x.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Equality *)

(** Note that we separately defined [ties] and [same] for plays and
    coins.  Wouldn't it be nice if we could define a single proposition
    for any type that claims two terms of that type are identical? *)

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

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

(** Of course, there are other, arguably more useful ways to define
    equality.  Here's Leibniz's definition (and, as far as we know, not
    Newton's): *)

Definition Leq (A : Type) (a b : A) : Prop := forall (P : A -> Prop), P a -> P b.

Notation "x =L y" := (Leq _ x y) (at level 70): type_scope.

(** That is, 'a' is equal to 'b' if everything true of 'a' is true of
    'b'. *)

(** Let's show that Leq is at least as strong as eq. *)

Lemma Leq_then_eq : forall (A : Type) (a b : A), a =L b -> a == b.
Proof.
  (* WORKED IN CLASS *)
  intros A a b L.
  unfold Leq in L.
  apply L.
  apply eq_refl.
Qed.

Print Leq_then_eq.

(** Let's try going in the opposite direction. *)

Lemma eq_then_Leq : forall (A : Type) (a b : A), a == b -> a =L b.
Proof.
  intros A a b H.
  unfold Leq.
  intros P p.
  destruct H.
  apply p.
Qed.

(** For convenience, we can package these up into a single claim. *)

Definition iff (A B : Prop) := (A -> B) /\ (B -> A).
Notation "A <-> B" := (iff A B) (at level 95) : type_scope.

Definition eq_Leq (A : Type) (a b : A) : a == b <-> a =L b :=
  conj (eq_then_Leq A a b) (Leq_then_eq A a b).

(** What does this tell us? It says that it's okay to replace a with b
    throughout a proposition if we know that [eq a b]. Let's try it
    out. *)

Lemma inverse_of_flip : forall (x y : coin), flip x == y -> inverse x y.
Proof.
  (* WORKED IN CLASS *)
  intros x y H.
  apply (eq_then_Leq coin (flip x) y).
  apply H.
  Search inverse.
  apply flip_inverse.
Qed.

(** This observation forms the basis of Coq's [rewrite] rule, which
    uses a hypotheses of the form [a = b] to replace all instances of
    [a] with [b] in a proposition.  We'll use Coq's standard library
    equality (which is identical to our own) to illustrate: *)

Lemma eq_trans : forall (A : Type) (a b c : A), a = b -> b = c -> a = c.
Proof.
  intros A a b c H H0.
  rewrite H.
  apply H0.
Qed.

(** **** Exercise: 1 star (eq_trans')  *)
(** Exercise: Prove this using our version of eq, which doesn't have
    [rewrite]. **)
(** Remove "[Admitted.]" and fill in the proof. *)

Lemma eq_trans' : forall (A : Type) (a b c : A),  a == b -> b == c -> a == c.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (y_is_nice)  *)
(** Exercise: Use one of the lemmas above to prove that y
    is nice **)
(** Remove "[Admitted.]" and fill in the proof. *)
Lemma y_is_nice : forall (X : Type) (x y : X) (nice : X -> Prop),
    x == y -> nice x -> nice y.
Proof.
(* FILL IN HERE *) Admitted.

(** [] *)


Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Inductive maybe (A : Set) (P : A -> Prop) : Set :=
| Unknown : maybe P
| Found   : forall x : A, P x -> maybe P.

Notation "{{ x | P }}" := (maybe (fun x => P)).
Notation "??" := (@Unknown _ _).
Notation "[| x |]" := (@Found _ _ x _).

Program Definition pred_strong7(n: nat):  {{m | n = m + 1}} :=
 match n return {{m | n = m + 1}} with
  | 0 => ??
  | n'.+1 => [| n' |]
  end.

Next Obligation. by rewrite addn1. 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) (lf2 : natural) : natural :=
  plus lf2 (mult z y).


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


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


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

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_s_midpoint :
	forall A B C,
	BetS A B C ->
	Cong A B B C ->
	Midpoint A B C.
Proof.
	intros A B C.
	intros BetS_A_B_C.
	intros Cong_AB_BC.

	unfold Midpoint.
	split.
	exact BetS_A_B_C.
	exact Cong_AB_BC.
Qed.

End Euclid.


(*** *********************** ***)
(*** TOWERS OF HANOI - DISCS ***)
(*** *********************** ***)

(* James Power * James.Power@May.ie * http://www.cs.may.ie/~jpower/ *)
(* Dept. of Computer Science, NUI Maynooth, Co. Kildare, Ireland.   *)

(* This file is part of the Towers of Hanoi in ILL example
 * In it, we define the discs and the "smaller" relation
 * as well as some lemmas relating to quantification over disc-lists
 *)

From Coq Require Import List.
Import ListNotations.
Notation Empty := (@nil _).

(*************)
(*** DISCS ***)
(*************)

Parameter Disc : Set.

Parameter smaller : Disc -> Disc -> Prop.

Axiom smallTrans :
  forall (x y z:Disc), (smaller x y) -> (smaller y z) -> (smaller x z).

(* Can we transfer a disc onto a pole? *)
Definition canTxfrTo : Disc -> list Disc -> Prop :=
  fun (d:Disc) (ds:list Disc) =>
  (Forall (fun d':Disc => smaller d d') ds).

(* Can we move a disc-list onto a pole? *)
Definition canMoveTo : list Disc -> list Disc -> Prop :=
  fun d1 d2:list Disc =>
  (Forall (fun d':Disc => canTxfrTo d' d2) d1).

(* When is a list of discs in order? *)
Inductive ordered : list Disc -> Prop :=
  ord_nil : ordered Empty
| ord_cons : forall (d:Disc)(ds:list Disc),
             canTxfrTo d ds -> ordered ds -> ordered (cons d ds).

Lemma CanMoveEmpty
  (ds:list Disc): canMoveTo ds Empty.
Proof.
induction ds; unfold canMoveTo.
apply Forall_nil.
intros; unfold canTxfrTo; apply Forall_cons; [ apply Forall_nil| assumption].
Qed.

Lemma CanMoveApp
  (ds d1 d2:list Disc):
  canMoveTo ds d1 -> canMoveTo ds d2 -> canMoveTo ds (d1++d2).
Proof.
induction ds as [|a l IH].
intros; simpl; unfold canMoveTo; apply Forall_nil.
intros CM1 CM2.
unfold canMoveTo in CM1; inversion CM1.
unfold canMoveTo in CM2; inversion CM2.
unfold canMoveTo; apply Forall_cons.
unfold canTxfrTo; apply Forall_app; split; assumption.
apply IH; assumption.
Qed.

Lemma OrdCat
  (d1 d2:list Disc): ordered (d1++d2) -> ordered d1.
Proof.
induction d1 as [|a l IH].
intros; apply ord_nil.
intros ORD.
simpl in ORD; inversion ORD; apply ord_cons.
unfold canTxfrTo; unfold canTxfrTo in H1;
  apply Forall_app with (l1:=l) (l2:=d2); assumption.
apply (IH H2).
Qed.

Lemma OrdMove
  (d1 d2:list Disc): ordered (d1++d2) -> canMoveTo d1 d2.
Proof.
induction d1 as [|a l IH].
intros; unfold canMoveTo; apply Forall_nil.
intros ORD; simpl in ORD; inversion ORD.
unfold canMoveTo; unfold canMoveTo in IH; apply Forall_cons.
unfold canTxfrTo; unfold canTxfrTo in H1.
apply Forall_app with (l1:=l) (l2:=d2); assumption.
apply IH; assumption.
Qed.


Require Import List.
Require Import String.
Require Import ZArith.

Definition var := string.

(* expressions *)
Inductive Expr : Type :=
| Int : Z -> Expr
| Var : var -> Expr
| Add : Expr -> Expr -> Expr
| Mul : Expr -> Expr -> Expr.

(* statements *)
Inductive Stmt : Type :=
| Skip : Stmt
| Assign : var -> Expr -> Stmt
| Seq : Stmt -> Stmt -> Stmt
| Cond : Expr -> Stmt -> Stmt -> Stmt
| While : Expr -> Stmt -> Stmt.

Definition Heap := list (var * Z).

Fixpoint lkup (x: var) (h: Heap) :=
  match h with
    | nil => 0%Z
    | (k, v) :: h' => if string_dec x k then v else lkup x h'
  end.

Inductive Eval : Heap -> Expr -> Z -> Prop :=
| EInt : forall h z,
  Eval h (Int z) z
| EVar : forall h v,
  Eval h (Var v) (lkup v h)
| EAdd : forall h e1 e2 c1 c2 c3,
  Eval h e1 c1 ->
  Eval h e2 c2 ->
  c3 = (c1 + c2)%Z ->
  Eval h (Add e1 e2) c3
| EMul : forall h e1 e2 c1 c2 c3,
  Eval h e1 c1 ->
  Eval h e2 c2 ->
  c3 = (c1 * c2)%Z ->
  Eval h (Mul e1 e2) c3.

Inductive Step : Heap -> Stmt -> Heap -> Stmt -> Prop :=
| SAssign : forall h v e c,
  Eval h e c ->
  Step h (Assign v e) ((v, c) :: h) Skip
| SSeq1 : forall h s,
  Step h (Seq Skip s) h s
| SSeq2 : forall h s1 h' s1' s2,
  Step h s1 h' s1' ->
  Step h (Seq s1 s2) h' (Seq s1' s2)
| SCondT : forall h e c s1 s2,
  Eval h e c ->
  c <> 0%Z ->
  Step h (Cond e s1 s2) h s1
| SCondF : forall h e c s1 s2,
  Eval h e c ->
  c = 0%Z ->
  Step h (Cond e s1 s2) h s2
| SWhileT : forall h e c s,
  Eval h e c ->
  c <> 0%Z ->
  Step h (While e s) h (Seq s (While e s))
| SWhileF : forall h e c s,
  Eval h e c ->
  c = 0%Z ->
  Step h (While e s) h Skip.

Inductive StepN : Heap -> Stmt -> nat -> Heap -> Stmt -> Prop :=
| StepN_refl : forall h s,
  StepN h s 0 h s
| StepN_step : forall h s h' s' h'' s'' n,
  Step h s h' s' ->
  StepN h' s' n h'' s'' ->
  StepN h s (S n) h'' s''.

(** Divergance *)

Definition canStep h s :=
  exists h', exists s', Step h s h' s'.

Definition notSkip s :=
  match s with
  | Skip => False
  | _ => True
  end.

Lemma notSkip_canStep:
  forall h s, notSkip s -> canStep h s.
Admitted.

Lemma diverges_take1:
  forall h n, exists h', exists s',
  StepN h (While (Int 1) Skip) n h' s'.
  (* stuck *)
Admitted.

Lemma diverges_take2:
  forall h n, exists h', exists s',
  StepN h (While (Int 1) Skip) n h' s' /\ s' <> Skip.
Proof.
Admitted.

Lemma diverges_take3:
  forall h n,
  StepN h (While (Int 1) Skip) n h (While (Int 1) Skip).
Proof.
Admitted.

Definition w1 := While (Int 1) Skip.
Definition w2 := Cond (Int 1) (Seq Skip (While (Int 1) Skip)) Skip.
Definition w3 := Seq Skip (While (Int 1) Skip).

Lemma diverges_take4:
  forall h n, exists s,
  StepN h (While (Int 1) Skip) n h s /\
  (s = w1 \/ s = w2 \/ s = w3).
Proof.
Admitted.

(** Nonneg *)

(** Interpreters *)

Locate "+".

Fixpoint eval (h: Heap) (e: Expr) : Z :=
  match e with
    | Int z => z
    | Var v => lkup v h
    | Add e1 e2 => Z.add (eval h e1) (eval h e2)
    | Mul e1 e2 => Z.mul (eval h e1) (eval h e2)
  end.

(* notree *)
Lemma eval_Eval:
  forall h e c,
  eval h e = c -> Eval h e c.
Proof.
  intro. intro. induction e.
  { intros. simpl in *. subst. constructor. }
  { intros. simpl in *. rewrite <- H. constructor. }
  { intros. simpl in *. econstructor.
    { firstorder. }
    { firstorder. }
    { firstorder. }
  }
  { intros. simpl in *. econstructor.
    { firstorder. }
    { firstorder. }
    { firstorder. }
  }
Qed.

(* notree *)
Lemma Eval_eval:
  forall h e c,
  Eval h e c -> eval h e = c.
Proof.
  intros. induction H.
  { reflexivity. }
  { reflexivity. }
  { subst. reflexivity. }
  { subst. reflexivity. }
Qed.

(* notree *)
Lemma Eval_eval':
  forall h e,
  Eval h e (eval h e).
Proof.
  intros. remember (eval h e) as c. apply eval_Eval. omega.
Qed.

Check Z.eq_dec.

Definition isSkip (s: Stmt) : bool :=
  match s with
    | Skip => true
    | _ => false
  end.

(* notree *)
Lemma isSkip_t:
  forall s, isSkip s = true -> s = Skip.
Proof.
  intros. destruct s.
  { reflexivity. }
  { discriminate. }
  { discriminate. }
  { discriminate. }
  { discriminate. }
Qed.

(* notree *)
Lemma isSkip_f:
  forall s, isSkip s = false -> s <> Skip.
Proof.
  intros. destruct s.
  { discriminate. }
  { discriminate. }
  { discriminate. }
  { discriminate. }
  { discriminate. }
Qed.

Fixpoint step (h: Heap) (s: Stmt) : option (Heap * Stmt) :=
  match s with
    | Skip => None
    | Assign v e => Some ((v, eval h e)::h, Skip)
    | Seq s1 s2 =>
      if isSkip s1 then
        Some (h, s2)
      else
        match step h s1 with
          | Some (h', s1') => Some (h', Seq s1' s2)
          | None => None
        end
    | Cond e s1 s2 =>
        if Z.eq_dec (eval h e) 0%Z then
          Some (h, s2)
        else
          Some (h, s1)
    | While e s =>
        if Z.eq_dec (eval h e) 0%Z then
          Some (h, Skip)
        else
          Some (h, Seq s (While e s))
  end.

(* notree *)
Lemma step_None_Skip:
  forall h s, step h s = None -> s = Skip.
Proof.
  intros. induction s.
  { reflexivity. }
  { simpl in *. inversion H. }
  { simpl in *. destruct (isSkip s1) eqn:?.
    { discriminate. }
    { destruct (step h s1) eqn:?.
      { destruct p. discriminate. }
      { firstorder. apply isSkip_f in Heqb. firstorder. }
    }
  }
  { simpl in *. destruct (Z.eq_dec (eval h e) 0) eqn:?.
    { discriminate. }
    { discriminate. }
  }
  { simpl in *. destruct (Z.eq_dec (eval h e) 0) eqn:?.
    { discriminate. }
    { discriminate. }
  }
Qed.

(* notree *)
Lemma step_Step:
  forall h s h' s',
  step h s = Some (h', s') -> Step h s h' s'.
Proof.
  intro. intro. induction s.
  { discriminate. }
  { intros. simpl in *. inversion H. constructor. apply Eval_eval'. }
  { intros. simpl in *. destruct (isSkip s1) eqn:?.
    { apply isSkip_t in Heqb. inversion H. subst. constructor. }
    { apply isSkip_f in Heqb. destruct (step h s1) eqn:?.
      { destruct p. inversion H. subst. constructor. firstorder. }
      { discriminate. }
    }
  }
  { intros. simpl in *. destruct (Z.eq_dec (eval h e) 0) eqn:?.
    { clear Heqs. inversion H. subst. apply eval_Eval in e0.
      econstructor.
      { eauto. }
      { reflexivity. }
    }
    { clear Heqs. inversion H. subst. remember (eval h' e).
      symmetry in Heqz. apply eval_Eval in Heqz.
      econstructor.
      { eauto. }
      { assumption. }
    }
  }
  { intros. simpl in *. destruct (Z.eq_dec (eval h e) 0) eqn:?.
    { clear Heqs0. inversion H. subst. apply eval_Eval in e0.
      econstructor.
      { eauto. }
      { reflexivity. }
    }
    { clear Heqs0. inversion H. subst. remember (eval h' e).
      symmetry in Heqz. apply eval_Eval in Heqz.
      econstructor.
      { eauto. }
      { assumption. }
    }
  }
Qed.

(* notree *)
Lemma Step_step:
  forall h s h' s',
  Step h s h' s' -> step h s = Some (h', s').
Proof.
  intros. induction H.
  { simpl. apply Eval_eval in H. subst. constructor. }
  { constructor. }
  { simpl. destruct (isSkip s1) eqn:?.
    { apply isSkip_t in Heqb. subst. inversion H. }
    { rewrite IHStep. reflexivity. }
  }
  { simpl. destruct (Z.eq_dec (eval h e) 0) eqn:?.
    { apply Eval_eval in H. omega. }
    { reflexivity. }
  }
  { simpl. destruct (Z.eq_dec (eval h e) 0) eqn:?.
    { reflexivity. }
    { apply Eval_eval in H. omega. }
  }
  { simpl. destruct (Z.eq_dec (eval h e) 0) eqn:?.
    { apply Eval_eval in H. omega. }
    { reflexivity. }
  }
  { simpl. destruct (Z.eq_dec (eval h e) 0) eqn:?.
    { reflexivity. }
    { apply Eval_eval in H. omega. }
  }
Qed.

Fixpoint stepn (h: Heap)  (s: Stmt) (n: nat) : option (Heap * Stmt) :=
  match n with
    | O => Some (h, s)
    | S m =>
      match step h s with
        | Some st' => stepn (fst st') (snd st') m
        | None => None
      end
  end.

(* notree *)
Lemma stepn_StepN:
  forall n h s h' s',
  stepn h s n = Some (h', s') ->
  StepN h s n h' s'.
Proof.
  intro. induction n.
  { intros. simpl in *. inversion H. subst. constructor. }
  { intros. simpl in *. destruct (step h s) eqn:?.
    { destruct p. simpl in *. econstructor.
      { apply step_Step. eassumption. }
      { apply IHn. eassumption. }
    }
    { discriminate. }
  }
Qed.

(* notree *)
Lemma StepN_stepn:
  forall h s n h' s',
  StepN h s n h' s' ->
  stepn h s n = Some (h', s').
Proof.
  intros. induction H.
  { simpl. reflexivity. }
  { simpl. destruct (step h s) eqn:?.
    { destruct p. simpl. apply Step_step in H. congruence. }
    { apply Step_step in H. congruence. }
  }
Qed.

Fixpoint run (n: nat) (h: Heap)  (s: Stmt) : Heap * Stmt :=
  match n with
    | O => (h, s)
    | S m =>
      match step h s with
        | Some (h', s') => run m h' s'
        | None => (h, s)
      end
  end.

Inductive StepStar : Heap -> Stmt -> Heap -> Stmt -> Prop :=
| StepStar_refl : forall h s,
  StepStar h s h s
| StepStar_step : forall h s h' s' h'' s'',
  Step h s h' s' ->
  StepStar h' s' h'' s'' ->
  StepStar h s h'' s''.

(* notree *)
Lemma run_StepStar:
  forall n h s h' s',
  run n h s = (h', s') -> StepStar h s h' s'.
Proof.
  intro. induction n.
  { intros. simpl in *. inversion H. subst. constructor. }
  { intros. simpl in *. destruct (step h s) eqn:?.
    { destruct p. econstructor.
      { apply step_Step. eassumption. }
      { apply IHn. assumption. }
    }
    { inversion H. subst. constructor. }
  }
Qed.

(* notree *)
Lemma nostep_run_refl:
  forall h s, step h s = None ->
  forall n, run n h s = (h, s).
Proof.
  intros. destruct n.
  { simpl. reflexivity. }
  { simpl. rewrite H. reflexivity. }
Qed.

(* notree *)
Lemma run_combine:
  forall m n h s h' s' h'' s'',
  run m h s = (h', s') ->
  run n h' s' = (h'', s'') ->
  run (m + n) h s = (h'', s'').
Proof.
  intro. induction m.
  { intros. simpl in *. inversion H. subst. assumption. }
  { intros. simpl in *. destruct (step h s) eqn:?.
    { destruct p. eapply IHm.
      { eauto. }
      { eauto. }
    }
    { inversion H. subst. apply nostep_run_refl with (n := n) in Heqo.
      congruence.
    }
  }
Qed.


(** * Utheory.v: Specification of [U], interval [ [0,1] ] *)

Require Export Misc.
Require Export Ccpo.
Set Implicit Arguments.
Open Local Scope O_scope.

(** ** Basic operators of U *)
(**
    - Constants : [0] and [1]
    - Constructor : [ [1/1+] n ] $(\equiv \frac{1}{n+1})$ #(=1/(1+n))#
    - Operations : [x+y] (=min (x+y,1)), [x*y], [ [1-] x]
    - Relations : [x <= y], [x==y]
*)

Module Type Universe.
Parameter U : Type.
Generalizable All Variables.
Declare Instance ordU: ord U.
Declare Instance cpoU: cpo U.
Bind Scope U_scope with U.
Delimit Scope U_scope with U.

Parameters Uplus Umult Udiv: U -> U -> U.
Parameter Uinv : U -> U.
Parameter Unth : nat -> U.

Infix "+" := Uplus : U_scope.
Infix "*"  := Umult  : U_scope.
Infix "/"  := Udiv  : U_scope.
Notation "[1-]  x" := (Uinv x)  (at level 35, right associativity) : U_scope.

Notation "[1/]1+ n" := (Unth n) (at level 35, right associativity) : U_scope.
Open Local Scope U_scope.

Definition U1 : U := [1-] 0.
Notation "1" := U1 : U_scope.

(** ** Basic Properties *)

Hypothesis Udiff_0_1 : ~0 == 1.
(*
Hypothesis Unit : forall x:U, x <= 1.
*)

Hypothesis Uplus_sym : forall x y:U, x + y == y + x.
Hypothesis Uplus_assoc : forall x y z:U, x + (y + z) == x + y + z.
Hypothesis Uplus_zero_left : forall x:U, 0 + x == x.

Hypothesis Umult_sym : forall x y:U, x * y == y * x.
Hypothesis Umult_assoc : forall x y z:U, x * (y * z) == x * y * z.
Hypothesis Umult_one_left : forall x:U, 1 * x == x.

Hypothesis Uinv_one : [1-] 1 == 0.

(*
Hypothesis Uinv_opp_left : forall x, [1-] x + x == 1.
*)

Hypothesis Umult_div : forall x y, ~ 0 == y -> x <= y -> y * (x/y) == x.
Hypothesis Udiv_le_one : forall x y,  ~ 0 == y -> y <= x -> (x/y) == 1.
Hypothesis Udiv_by_zero : forall x y,  0 == y -> (x/y) == 0.

(** - Property  : [1 - (x + y) + x = 1 - y ] holds when [x+y] does not overflow *)
Hypothesis Uinv_plus_left : forall x y, y <= [1-] x -> [1-] (x + y) + x == [1-] y.

(** - Property  : [(x + y) * z  = x * z + y * z] holds when [x+y] does not overflow *)
Hypothesis Udistr_plus_right : forall x y z, x <= [1-] y -> (x + y) * z == x * z + y * z.

(** - Property  : [1 - (x  y) = (1 - x) * y + (1-y) ] *)
Hypothesis Udistr_inv_right : forall x y:U,  [1-] (x * y) == ([1-] x) * y + [1-] y.

(** - Totality of the order *)
Hypothesis Ule_class : forall x y : U, class (x <= y).

Hypothesis Ule_total : forall x y : U, orc (x <= y) (y <= x).
Implicit Arguments Ule_total [].

(** - The relation [x <=  y] is compatible with operators *)

Declare Instance Uplus_mon_right :forall x,monotonic (Uplus x).

(* Instance Uplus_mon_right : forall x, monotonic (Uplus x). *)

Declare Instance Umult_mon_right : forall x, monotonic (Umult x).
(* Instance Umult_mon_right : forall x, monotonic (Umult x). *)

Hypothesis Uinv_le_compat : forall x y:U, x <= y -> [1-] y <= [1-] x.

(** - Properties of simplification in case there is no overflow *)
Hypothesis Uplus_le_simpl_right : forall x y z, z <= [1-] x -> x + z <= y + z -> x <= y.

Hypothesis Umult_le_simpl_left : forall x y z: U, ~ 0 == z -> z * x <= z * y -> x <= y .

(** -  Property of [Unth]: [1 / n+1 == 1 - n  * (1/n+1)] *)
Hypothesis Unth_prop : forall n, [1/]1+n == [1-](compn Uplus 0 (fun k => [1/]1+n) n).

(** - Archimedian property *)
Hypothesis archimedian : forall x, ~0 == x -> exc (fun n => [1/]1+n <= x).

(** - Stability properties of lubs with respect to [+] and [*] *)

Hypothesis Uplus_right_continuous : forall k, continuous (mon (Uplus k)).
Hypothesis Umult_right_continuous : forall k, continuous (mon (Umult k)).

End Universe.

Declare Module Univ:Universe.
Export Univ.

Hint Resolve Udiff_0_1 Unth_prop.
Hint Resolve Uplus_sym Uplus_assoc Umult_sym Umult_assoc.
Hint Resolve Uinv_one  Uinv_plus_left Umult_div Udiv_le_one Udiv_by_zero.
Hint Resolve Uplus_zero_left Umult_one_left Udistr_plus_right Udistr_inv_right.
Hint Resolve Uplus_mon_right Umult_mon_right Uinv_le_compat.
Hint Resolve lub_le le_lub Uplus_right_continuous Umult_right_continuous.
(* lub_eq_mult lub_eq_plus_cte_left.*)
Hint Resolve Ule_total Ule_class.